diff --git a/Make.inc.in b/Make.inc.in index 5ff454bf..4266526f 100755 --- a/Make.inc.in +++ b/Make.inc.in @@ -65,6 +65,8 @@ PRECMODNAME=@PRECMODNAME@ METHDMODNAME=@METHDMODNAME@ UTILMODNAME=@UTILMODNAME@ +CBINDLIBNAME=libpsb_cbind.a + @PSBLASRULES@ diff --git a/Makefile b/Makefile index 50981dd0..389360ca 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ include Make.inc -all: libd based precd kryld utild +all: libd based precd kryld utild cbindd @echo "=====================================" @echo "PSBLAS libraries Compilation Successful." @@ -8,6 +8,8 @@ based: libd precd utild: based kryld: precd based +cbindd: precd kryld utild + libd: (if test ! -d lib ; then mkdir lib; fi) (if test ! -d include ; then mkdir include; fi; $(INSTALL_DATA) Make.inc include/Make.inc.psblas) @@ -19,6 +21,8 @@ kryld: cd krylov && $(MAKE) lib utild: cd util&& $(MAKE) lib +cbindd: + cd cbind&& $(MAKE) lib install: all (./mkdir.sh $(INSTALL_INCLUDEDIR) &&\ @@ -38,6 +42,7 @@ clean: cd prec && $(MAKE) clean cd krylov && $(MAKE) clean cd util && $(MAKE) clean + cd cbind && $(MAKE) clean check: all make check -C test/serial @@ -51,6 +56,7 @@ veryclean: cleanlib cd prec && $(MAKE) veryclean cd krylov && $(MAKE) veryclean cd util && $(MAKE) veryclean + cd cbind && $(MAKE) clean cd test/fileread && $(MAKE) clean cd test/pargen && $(MAKE) clean cd test/util && $(MAKE) clean diff --git a/cbind/Makefile b/cbind/Makefile new file mode 100644 index 00000000..88d0120d --- /dev/null +++ b/cbind/Makefile @@ -0,0 +1,23 @@ +include ../Make.inc + +HERE=. +LIBDIR=../lib +INCDIR=../include +LIBNAME=$(CBINDLIBNAME) + +lib: based + /bin/cp -p $(CPUPDFLAG) $(HERE)/$(LIBNAME) $(LIBDIR) + /bin/cp -p $(CPUPDFLAG) *$(.mod) *.h $(INCDIR) + + + +based: + cd base && $(MAKE) lib LIBNAME=$(LIBNAME) + + +clean: + cd base && $(MAKE) clean + + +veryclean: clean + /bin/rm -f $(HERE)/$(LIBNAME) $(LIBMOD) *$(.mod) *.h diff --git a/cbind/base/Makefile b/cbind/base/Makefile new file mode 100644 index 00000000..fb342ac1 --- /dev/null +++ b/cbind/base/Makefile @@ -0,0 +1,44 @@ +TOP=../.. +include $(TOP)/Make.inc +LIBDIR=$(TOP)lib +INCLUDEDIR=$(TOP)/include +HERE=.. + +FINCLUDES=$(FMFLAG). $(FMFLAG)$(INCLUDEDIR) +CINCLUDES=-I$(INCLUDEDIR) + +OBJS= psb_objhandle_mod.o psb_base_cbind_mod.o psb_cpenv_mod.o\ + psb_base_tools_cbind_mod.o psb_base_string_cbind_mod.o\ + psb_base_psblas_cbind_mod.o psb_d_tools_cbind_mod.o psb_c_base.o \ + psb_d_serial_cbind_mod.o psb_c_dbase.o psb_d_psblas_cbind_mod.o +CMOD=psb_base_cbind.h psb_c_base.h psb_c_dbase.h + +LIBMOD=psb_base_cbind_mod$(.mod) psb_cpenv_mod$(.mod) psb_objhandle_mod$(.mod)\ + psb_base_tools_cbind_mod$(.mod) psb_base_string_cbind_mod$(.mod) psb_base_psblas_cbind_mod$(.mod)\ + psb_d_tools_cbind_mod$(.mod) psb_d_serial_cbind_mod$(.mod) psb_d_psblas_cbind_mod$(.mod) +LOCAL_MODS=$(LIBMOD) +LIBNAME=$(CBINDLIBNAME) + + +lib: $(OBJS) $(CMOD) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + /bin/cp -p $(LIBMOD) $(CMOD) $(HERE) + + +psb_base_cbind_mod.o: psb_cpenv_mod.o psb_objhandle_mod.o psb_base_tools_cbind_mod.o \ + psb_base_string_cbind_mod.o psb_base_psblas_cbind_mod.o +psb_base_tools_cbind_mod.o: psb_objhandle_mod.o psb_base_string_cbind_mod.o +psb_d_tools_cbind_mod.o psb_d_serial_cbind_mod.o: psb_base_tools_cbind_mod.o + +psb_base_psblas_cbind_mod.o: psb_d_psblas_cbind_mod.o +psb_d_psblas_cbind_mod.o: psb_objhandle_mod.o psb_base_string_cbind_mod.o +psb_cpenv_mod.o: psb_base_string_cbind_mod.o + +veryclean: clean + /bin/rm -f $(HERE)/$(LIBNAME) + +clean: + /bin/rm -f $(OBJS) $(LOCAL_MODS) + +veryclean: clean diff --git a/cbind/base/psb_base_cbind.h b/cbind/base/psb_base_cbind.h new file mode 100644 index 00000000..6e07e499 --- /dev/null +++ b/cbind/base/psb_base_cbind.h @@ -0,0 +1,7 @@ +#ifndef PSB_BASE_CBIND_ +#define PSB_BASE_CBIND_ + +#include "psb_c_base.h" +#include "psb_c_dbase.h" + +#endif diff --git a/cbind/base/psb_base_cbind_mod.f90 b/cbind/base/psb_base_cbind_mod.f90 new file mode 100644 index 00000000..a943e57e --- /dev/null +++ b/cbind/base/psb_base_cbind_mod.f90 @@ -0,0 +1,6 @@ +module psb_base_cbind_mod + use psb_objhandle_mod + use psb_cpenv_mod + use psb_base_tools_cbind_mod + use psb_base_psblas_cbind_mod +end module psb_base_cbind_mod diff --git a/cbind/base/psb_base_psblas_cbind_mod.f90 b/cbind/base/psb_base_psblas_cbind_mod.f90 new file mode 100644 index 00000000..8a53ea2f --- /dev/null +++ b/cbind/base/psb_base_psblas_cbind_mod.f90 @@ -0,0 +1,6 @@ +module psb_base_psblas_cbind_mod + + use iso_c_binding + use psb_d_psblas_cbind_mod + +end module psb_base_psblas_cbind_mod diff --git a/cbind/base/psb_base_string_cbind_mod.f90 b/cbind/base/psb_base_string_cbind_mod.f90 new file mode 100644 index 00000000..05cd9d7d --- /dev/null +++ b/cbind/base/psb_base_string_cbind_mod.f90 @@ -0,0 +1,38 @@ +module psb_base_string_cbind_mod + use iso_c_binding + +contains + + subroutine stringc2f(cstring,fstring) + character(c_char) :: cstring(*) + character(len=*) :: fstring + integer :: i + + i = 1 + do + if (cstring(i) == c_null_char) exit + if (i > len(fstring)) exit + fstring(i:i) = cstring(i) + i = i + 1 + end do + do + if (i > len(fstring)) exit + fstring(i:i) = " " + i = i + 1 + end do + return + end subroutine stringc2f + + subroutine stringf2c(fstring,cstring) + character(c_char) :: cstring(*) + character(len=*) :: fstring + integer :: i + + do i=1, len(fstring) + cstring(i) = fstring(i:i) + end do + cstring(len(fstring)+1) = c_null_char + return + end subroutine stringf2c + +end module psb_base_string_cbind_mod diff --git a/cbind/base/psb_base_tools_cbind_mod.F90 b/cbind/base/psb_base_tools_cbind_mod.F90 new file mode 100644 index 00000000..1ea32827 --- /dev/null +++ b/cbind/base/psb_base_tools_cbind_mod.F90 @@ -0,0 +1,295 @@ +module psb_base_tools_cbind_mod + use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + +contains + + function psb_c_error() bind(c) result(res) + implicit none + integer(c_int) :: res + res = 0 + call psb_error() + end function psb_c_error + + function psb_c_clean_errstack() bind(c) result(res) + implicit none + integer(c_int) :: res + res = 0 + call psb_clean_errstack() + end function psb_c_clean_errstack + + function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res) + implicit none + + integer(c_int) :: res + integer(c_int), value :: ng, ictxt + integer(c_int) :: vg(*) + type(psb_c_object_type) :: cdh + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + if (ng <=0) then + write(0,*) 'Invalid size' + return + end if + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call descp%free(info) + if (info == 0) deallocate(descp,stat=info) + if (info /= 0) return + end if + + allocate(descp,stat=info) + if (info < 0) return + + call psb_cdall(ictxt,descp,info,vg=vg(1:ng)) + cdh%item = c_loc(descp) + res = info + + end function psb_c_cdall_vg + + + function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res) + implicit none + + integer(c_int) :: res + integer(c_int), value :: nl, ictxt + integer(c_int) :: vl(*) + type(psb_c_object_type) :: cdh + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + if (nl <=0) then + write(0,*) 'Invalid size' + return + end if + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call descp%free(info) + if (info == 0) deallocate(descp,stat=info) + if (info /= 0) return + end if + + allocate(descp,stat=info) + if (info < 0) return + + call psb_cdall(ictxt,descp,info,vl=vl(1:nl)) + cdh%item = c_loc(descp) + res = info + + end function psb_c_cdall_vl + + function psb_c_cdall_nl(nl,ictxt,cdh) bind(c,name='psb_c_cdall_nl') result(res) + implicit none + + integer(c_int) :: res + integer(c_int), value :: nl, ictxt + type(psb_c_object_type) :: cdh + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + if (nl <=0) then + write(0,*) 'Invalid size' + return + end if + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call descp%free(info) + if (info == 0) deallocate(descp,stat=info) + if (info /= 0) return + end if + + allocate(descp,stat=info) + if (info < 0) return + + call psb_cdall(ictxt,descp,info,nl=nl) + cdh%item = c_loc(descp) + res = info + + end function psb_c_cdall_nl + + function psb_c_cdall_repl(n,ictxt,cdh) bind(c,name='psb_c_cdall_repl') result(res) + implicit none + + integer(c_int) :: res + integer(c_int), value :: n, ictxt + type(psb_c_object_type) :: cdh + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + if (n <=0) then + write(0,*) 'Invalid size' + return + end if + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call descp%free(info) + if (info == 0) deallocate(descp,stat=info) + if (info /= 0) return + end if + + allocate(descp,stat=info) + if (info < 0) return + + call psb_cdall(ictxt,descp,info,mg=n,repl=.true.) + cdh%item = c_loc(descp) + res = info + + end function psb_c_cdall_repl + + function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: cdh + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call psb_cdasb(descp,info) + res = info + end if + + end function psb_c_cdasb + + + function psb_c_cdfree(cdh) bind(c,name='psb_c_cdfree') result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: cdh + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call descp%free(info) + if (info == 0) deallocate(descp,stat=info) + if (info /= 0) return + cdh%item = c_null_ptr + end if + + res = info + return + end function psb_c_cdfree + + function psb_c_cdins(nz,ia,ja,cdh) bind(c,name='psb_c_cdins') result(res) + + implicit none + integer(c_int) :: res + integer(c_int), value :: nz + type(psb_c_object_type) :: cdh + integer(c_int) :: ia(*),ja(*) + + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + call psb_cdins(nz,ia(1:nz),ja(1:nz),descp,info) + res = info + end if + return + end function psb_c_cdins + + + + function psb_c_cd_get_local_rows(cdh) bind(c,name='psb_c_cd_get_local_rows') result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + res = descp%get_local_rows() + + end if + + end function psb_c_cd_get_local_rows + + + + function psb_c_cd_get_local_cols(cdh) bind(c,name='psb_c_cd_get_local_cols') result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + res = descp%get_local_cols() + + end if + + end function psb_c_cd_get_local_cols + + function psb_c_cd_get_global_rows(cdh) bind(c,name='psb_c_cd_get_global_rows') result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + res = descp%get_global_rows() + + end if + + end function psb_c_cd_get_global_rows + + + + function psb_c_cd_get_global_cols(cdh) bind(c,name='psb_c_cd_get_global_cols') result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + integer :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + res = descp%get_global_cols() + + end if + + end function psb_c_cd_get_global_cols + + +end module psb_base_tools_cbind_mod + diff --git a/cbind/base/psb_c_base.c b/cbind/base/psb_c_base.c new file mode 100644 index 00000000..96a6df34 --- /dev/null +++ b/cbind/base/psb_c_base.c @@ -0,0 +1,39 @@ +#include +#include +#include "psb_c_base.h" + +psb_c_descriptor* psb_c_new_descriptor() +{ + psb_c_descriptor* temp; + + temp=(psb_c_descriptor *) malloc(sizeof(psb_c_descriptor)); + temp->descriptor=NULL; + return(temp); +} + + +void psb_c_print_errmsg() +{ + char *mesg; + + for (mesg = psb_c_pop_errmsg(); mesg != NULL; mesg = psb_c_pop_errmsg()) { + fprintf(stderr,"%s\n",mesg); + free(mesg); + } + +} + + +#define PSB_MAX_ERRLINE_LEN 132 +#define PSB_MAX_ERR_LINES 4 +static int maxlen=PSB_MAX_ERR_LINES*(PSB_MAX_ERRLINE_LEN+2); +char *psb_c_pop_errmsg() +{ + char *tmp; + tmp = (char*) malloc(maxlen*sizeof(char)); + if (psb_c_f2c_errmsg(tmp,maxlen)<=0) { + free(tmp); tmp = NULL; + } + return(tmp); +} + diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h new file mode 100644 index 00000000..6738a249 --- /dev/null +++ b/cbind/base/psb_c_base.h @@ -0,0 +1,80 @@ +#ifndef PSB_C_BASE__ +#define PSB_C_BASE__ +#ifdef __cplusplus +extern "C" { + typedef char _Bool; +#endif + + typedef int psb_err_t; + typedef int psb_ctx_t; +#define PSB_ERR_ERROR -1 +#define PSB_ERR_SUCCESS 0 + + + typedef struct PSB_C_DESCRIPTOR { + void *descriptor; + } psb_c_descriptor; + + + + int psb_c_error(); + int psb_c_clean_errstack(); + void psb_c_print_errmsg(); + char *psb_c_pop_errmsg(); + int psb_c_f2c_errmsg(char *, int); + void psb_c_seterraction_ret(); + void psb_c_seterraction_print(); + void psb_c_seterraction_abort(); + + /* Environment routines */ + int psb_c_init(); + void psb_c_exit_ctxt(int ictxt); + void psb_c_exit(int ictxt); + void psb_c_abort(int ictxt); + void psb_c_barrier(int ictxt); + void psb_c_info(int ictxt, int *iam, int *np); + double psb_c_wtime(); + int psb_c_get_errstatus(); + + void psb_c_ibcast(int ictxt, int n, int *v, int root); + void psb_c_dbcast(int ictxt, int n, double *v, int root); + void psb_c_hbcast(int ictxt, const char *v, int root); + + /* Descriptor/integer routines */ + psb_c_descriptor* psb_c_new_descriptor(); + int psb_c_cdall_vg(int ng, int *vg, int ictxt, psb_c_descriptor *cd); + int psb_c_cdall_vl(int nl, int *vl, int ictxt, psb_c_descriptor *cd); + int psb_c_cdall_nl(int nl, int ictxt, psb_c_descriptor *cd); + int psb_c_cdall_repl(int n, int ictxt, psb_c_descriptor *cd); + int psb_c_cdasb(psb_c_descriptor *cd); + int psb_c_cdfree(psb_c_descriptor *cd); + int psb_c_cdins(int nz, const int *ia, const int *ja, psb_c_descriptor *cd); + + + int psb_c_cd_get_local_rows(psb_c_descriptor *cd); + int psb_c_cd_get_local_cols(psb_c_descriptor *cd); + int psb_c_cd_get_global_rows(psb_c_descriptor *cd); + int psb_c_cd_get_global_rows(psb_c_descriptor *cd); + + + /* legal values for upd argument */ +#define psb_upd_srch_ 98764 +#define psb_upd_perm_ 98765 +#define psb_upd_def_ psb_upd_srch_ + /* legal values for dupl argument */ +#define psb_dupl_ovwrt_ 0 +#define psb_dupl_add_ 1 +#define psb_dupl_err_ 2 +#define psb_dupl_def_ psb_dupl_ovwrt_ + + /* legal values for afmt */ +#define PSB_AFMT_CSR "CSR" +#define PSB_AFMT_CSC "CSC" +#define PSB_AFMT_COO "COO" +#define PSB_AFMT_RSB "RSB" + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif diff --git a/cbind/base/psb_c_dbase.c b/cbind/base/psb_c_dbase.c new file mode 100644 index 00000000..6cc4d8dc --- /dev/null +++ b/cbind/base/psb_c_dbase.c @@ -0,0 +1,39 @@ +#include +#include "psb_c_dbase.h" + +psb_c_dvector* psb_c_new_dvector() +{ + psb_c_dvector* temp; + + temp=(psb_c_dvector *) malloc(sizeof(psb_c_dvector)); + temp->dvector=NULL; + return(temp); +} + +double* psb_c_dvect_get_cpy(psb_c_dvector *xh) +{ + double *temp=NULL; + int vsize=0; + + if ((vsize=psb_c_dvect_get_nrows(xh))<0) + return(temp); + + if (vsize==0) + vsize=1; + + if ((temp=(double *)malloc(vsize*sizeof(double)))!=NULL) + psb_c_dvect_f_get_cpy(temp,xh); + + return(temp); + +} + + +psb_c_dspmat* psb_c_new_dspmat() +{ + psb_c_dspmat* temp; + + temp=(psb_c_dspmat *) malloc(sizeof(psb_c_dspmat)); + temp->dspmat=NULL; + return(temp); +} diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h new file mode 100644 index 00000000..42125e5a --- /dev/null +++ b/cbind/base/psb_c_dbase.h @@ -0,0 +1,64 @@ +#ifndef PSB_C_DBASE_ +#define PSB_C_DBASE_ +#include "psb_c_base.h" + +#ifdef __cplusplus +extern "C" { +#endif + +typedef struct PSB_C_DVECTOR { + void *dvector; +} psb_c_dvector; + +typedef struct PSB_C_DSPMAT { + void *dspmat; +} psb_c_dspmat; + + +/* dense vectors */ +psb_c_dvector* psb_c_new_dvector(); +int psb_c_dvect_get_nrows(psb_c_dvector *xh); +double *psb_c_dvect_get_cpy( psb_c_dvector *xh); +int psb_c_dvect_f_get_cpy(double *v, psb_c_dvector *xh); +int psb_c_dvect_zero(psb_c_dvector *xh); + +int psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh); +int psb_c_dgeins(int nz, const int *irw, const double *val, + psb_c_dvector *xh, psb_c_descriptor *cdh); +int psb_c_dgeins_add(int nz, const int *irw, const double *val, + psb_c_dvector *xh, psb_c_descriptor *cdh); +int psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh); +int psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh); + +/* sparse matrices*/ +psb_c_dspmat* psb_c_new_dspmat(); +int psb_c_dspall(psb_c_dspmat *mh, psb_c_descriptor *cdh); +int psb_c_dspasb(psb_c_dspmat *mh, psb_c_descriptor *cdh); +int psb_c_dspfree(psb_c_dspmat *mh, psb_c_descriptor *cdh); +int psb_c_dspins(int nz, const int *irw, const int *icl, const double *val, + psb_c_dspmat *mh, psb_c_descriptor *cdh); +int psb_c_dmat_get_nrows(psb_c_dspmat *mh); +int psb_c_dmat_get_ncols(psb_c_dspmat *mh); + +/* int psb_c_dspasb_opt(psb_c_dspmat *mh, psb_c_descriptor *cdh, */ +/* const char *afmt, int upd, int dupl); */ +int psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear); +/* int psb_c_dspprint(psb_c_dspmat *mh); */ + +/* psblas computational routines */ +double psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh); +double psb_c_dgenrm2(psb_c_dvector *xh, psb_c_descriptor *cdh); +double psb_c_dgeamax(psb_c_dvector *xh, psb_c_descriptor *cdh); +double psb_c_dgeasum(psb_c_dvector *xh, psb_c_descriptor *cdh); +double psb_c_dspnrmi(psb_c_dvector *xh, psb_c_descriptor *cdh); +int psb_c_dgeaxpby(double alpha, psb_c_dvector *xh, + double beta, psb_c_dvector *yh, psb_c_descriptor *cdh); +int psb_c_dspmm(double alpha, psb_c_dspmat *ah, psb_c_dvector *xh, + double beta, psb_c_dvector *yh, psb_c_descriptor *cdh); +int psb_c_dspsm(double alpha, psb_c_dspmat *th, psb_c_dvector *xh, + double beta, psb_c_dvector *yh, psb_c_descriptor *cdh); +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif diff --git a/cbind/base/psb_cpenv_mod.f90 b/cbind/base/psb_cpenv_mod.f90 new file mode 100644 index 00000000..eaf3d8f2 --- /dev/null +++ b/cbind/base/psb_cpenv_mod.f90 @@ -0,0 +1,170 @@ +module psb_cpenv_mod + use iso_c_binding + +contains + + function psb_c_get_errstatus() bind(c) result(res) + use psb_base_mod + implicit none + + integer(c_int) :: res + + res = psb_get_errstatus() + end function psb_c_get_errstatus + + function psb_c_init() bind(c) + use psb_base_mod + implicit none + + integer(c_int) :: psb_c_init + + integer :: ictxt + + call psb_init(ictxt) + psb_c_init = ictxt + end function psb_c_init + + subroutine psb_c_exit_ctxt(ictxt) bind(c) + use psb_base_mod + integer(c_int), value :: ictxt + + call psb_exit(ictxt,close=.false.) + return + end subroutine psb_c_exit_ctxt + + subroutine psb_c_exit(ictxt) bind(c) + use psb_base_mod + integer(c_int), value :: ictxt + + call psb_exit(ictxt) + return + end subroutine psb_c_exit + + subroutine psb_c_abort(ictxt) bind(c) + use psb_base_mod + integer(c_int), value :: ictxt + + call psb_abort(ictxt) + return + end subroutine psb_c_abort + + + subroutine psb_c_info(ictxt,iam,np) bind(c) + use psb_base_mod + integer(c_int), value :: ictxt + integer(c_int) :: iam,np + + call psb_info(ictxt,iam,np) + return + end subroutine psb_c_info + + subroutine psb_c_barrier(ictxt) bind(c) + use psb_base_mod + integer(c_int), value :: ictxt + + call psb_barrier(ictxt) + end subroutine psb_c_barrier + + real(c_double) function psb_c_wtime() bind(c) + use psb_base_mod + + psb_c_wtime = psb_wtime() + end function psb_c_wtime + + subroutine psb_c_ibcast(ictxt,n,v,root) bind(c) + use psb_base_mod + implicit none + integer(c_int), value :: ictxt,n, root + integer(c_int) :: v(*) + + if (n < 0) then + write(0,*) 'Wrong size in BCAST' + return + end if + if (n==0) return + + call psb_bcast(ictxt,v(1:n),root=root) + end subroutine psb_c_ibcast + + subroutine psb_c_dbcast(ictxt,n,v,root) bind(c) + use psb_base_mod + implicit none + integer(c_int), value :: ictxt,n, root + real(c_double) :: v(*) + + if (n < 0) then + write(0,*) 'Wrong size in BCAST' + return + end if + if (n==0) return + + call psb_bcast(ictxt,v(1:n),root=root) + end subroutine psb_c_dbcast + + subroutine psb_c_hbcast(ictxt,v,root) bind(c) + use psb_base_mod + implicit none + integer(c_int), value :: ictxt, root + character(c_char) :: v(*) + integer :: n, iam, np + + call psb_info(ictxt,iam,np) + + if (iam==root) then + n = 1 + do + if (v(n) == c_null_char) exit + n = n + 1 + end do + end if + call psb_bcast(ictxt,n,root=root) + call psb_bcast(ictxt,v(1:n),root=root) + end subroutine psb_c_hbcast + + function psb_c_f2c_errmsg(cmesg,len) bind(c) result(res) + use psb_base_mod + use psb_base_string_cbind_mod + implicit none + character(c_char), intent(inout) :: cmesg(*) + integer(c_int), intent(in), value :: len + integer(c_int) :: res + character(len=psb_max_errmsg_len_), allocatable :: fmesg(:) + character(len=psb_max_errmsg_len_) :: tmp + integer :: i, j, ll, il + + res = 0 + call psb_errpop(fmesg) + ll = 1 + if (allocated(fmesg)) then + res = size(fmesg) + do i=1, size(fmesg) + tmp = fmesg(i) + il = len_trim(tmp) + il = min(il,len-ll) + !write(0,*) 'loop f2c_errmsg: ', ll,il + call stringf2c(tmp(1:il),cmesg(ll:ll+il)) + cmesg(ll+il)=c_new_line + ll = ll+il+1 + end do + !write(0,*) 'From f2c_errmsg: ', ll,len + end if + cmesg(ll) = c_null_char + end function psb_c_f2c_errmsg + + subroutine psb_c_seterraction_ret() bind(c) + use psb_base_mod + call psb_set_erraction(psb_act_ret_) + end subroutine psb_c_seterraction_ret + + subroutine psb_c_seterraction_print() bind(c) + use psb_base_mod + call psb_set_erraction(psb_act_print_) + end subroutine psb_c_seterraction_print + + subroutine psb_c_seterraction_abort() bind(c) + use psb_base_mod + call psb_set_erraction(psb_act_abort_) + end subroutine psb_c_seterraction_abort + + +end module psb_cpenv_mod diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 new file mode 100644 index 00000000..c55e3228 --- /dev/null +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -0,0 +1,279 @@ +module psb_d_psblas_cbind_mod + use iso_c_binding + +contains + + function psb_c_dgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + integer(c_int) :: res + + type(psb_c_object_type) :: xh,yh, cdh + real(c_double), value :: alpha,beta + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer :: info + + + 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 + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geaxpby(alpha,xp,beta,yp,descp,info) + + res = info + + end function psb_c_dgeaxpby + + function psb_c_dgenrm2(xh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + real(c_double) :: res + + type(psb_c_object_type) :: xh,cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + res = -1.0 + + 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 + + res = psb_genrm2(xp,descp,info) + + end function psb_c_dgenrm2 + + function psb_c_dgeamax(xh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + real(c_double) :: res + + type(psb_c_object_type) :: xh,cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + res = -1.0 + 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 + + res = psb_geamax(xp,descp,info) + + end function psb_c_dgeamax + + function psb_c_dgeasum(xh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + real(c_double) :: res + + type(psb_c_object_type) :: xh,cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + res = -1.0 + + 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 + + res = psb_geasum(xp,descp,info) + + end function psb_c_dgeasum + + + function psb_c_dspnrmi(mh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + real(c_double) :: res + + type(psb_c_object_type) :: mh,cdh + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer :: info + + res = -1.0 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + res = psb_spnrmi(ap,descp,info) + + end function psb_c_dspnrmi + + function psb_c_dgedot(xh,yh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + real(c_double) :: res + + type(psb_c_object_type) :: xh,yh,cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer :: info + + res = -1.0 + 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 + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + res = psb_gedot(xp,yp,descp,info) + + end function psb_c_dgedot + + + function psb_c_dspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + integer(c_int) :: res + + type(psb_c_object_type) :: ah,xh,yh, cdh + real(c_double), value :: alpha, beta + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + type(psb_dspmat_type), pointer :: ap + integer :: info + + 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 + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call psb_spmm(alpha,ap,xp,beta,yp,descp,info) + + res = info + + end function psb_c_dspmm + + + function psb_c_dspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + integer(c_int) :: res + + type(psb_c_object_type) :: ah,xh,yh, cdh + real(c_double), value :: alpha, beta + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + type(psb_dspmat_type), pointer :: ap + integer :: info + + 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 + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call psb_spsm(alpha,ap,xp,beta,yp,descp,info) + + res = info + + end function psb_c_dspsm + + +end module psb_d_psblas_cbind_mod diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 new file mode 100644 index 00000000..7a8d95f5 --- /dev/null +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -0,0 +1,119 @@ +module psb_d_serial_cbind_mod + use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + use psb_base_tools_cbind_mod + +contains + + + function psb_c_dvect_get_nrows(xh) bind(c) result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: xh + + type(psb_d_vect_type), pointer :: vp + integer :: info + + res = -1 + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + res = vp%get_nrows() + end if + + end function psb_c_dvect_get_nrows + + function psb_c_dvect_f_get_cpy(v,xh) bind(c) result(res) + implicit none + + integer(c_int) :: res + real(c_double) :: v(*) + type(psb_c_object_type) :: xh + + type(psb_d_vect_type), pointer :: vp + real(psb_dpk_), allocatable :: fv(:) + integer :: info, sz + + res = -1 + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + fv = vp%get_vect() + sz = size(fv) + v(1:sz) = fv(1:sz) + end if + + end function psb_c_dvect_f_get_cpy + + + function psb_c_dvect_zero(xh) bind(c) result(res) + implicit none + + integer(c_int) :: res + type(psb_c_object_type) :: xh + + type(psb_d_vect_type), pointer :: vp + integer :: info + + res = -1 + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + call vp%set(dzero) + end if + + end function psb_c_dvect_zero + + + function psb_c_dmat_get_nrows(mh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + integer(c_int) :: res + + type(psb_c_object_type) :: mh + type(psb_dspmat_type), pointer :: ap + integer :: info + + res = 0 + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + res = ap%get_nrows() + + end function psb_c_dmat_get_nrows + + + function psb_c_dmat_get_ncols(mh) bind(c) result(res) + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + implicit none + integer(c_int) :: res + + type(psb_c_object_type) :: mh + type(psb_dspmat_type), pointer :: ap + integer :: info + + res = 0 + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + res = ap%get_ncols() + + end function psb_c_dmat_get_ncols + + + +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 new file mode 100644 index 00000000..f01aba8e --- /dev/null +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -0,0 +1,385 @@ +module psb_d_tools_cbind_mod + use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + use psb_base_tools_cbind_mod + +contains + + function psb_c_dgeall(xh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: xh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + 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 + return + end if + allocate(xp) + call psb_geall(xp,descp,info) + xh%item = c_loc(xp) + res = min(0,info) + + return + end function psb_c_dgeall + + function psb_c_dgeasb(xh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: xh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + 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 + + call psb_geasb(xp,descp,info) + res = min(0,info) + + return + end function psb_c_dgeasb + + function psb_c_dgefree(xh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: xh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + 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 + + call psb_gefree(xp,descp,info) + res = min(0,info) + xh%item = c_null_ptr + + return + end function psb_c_dgefree + + + function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + integer(c_int), value :: nz + integer(c_int) :: irw(*) + real(c_double) :: val(*) + type(psb_c_object_type) :: xh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + 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 + + call psb_geins(nz,irw(1:nz),val(1:nz),& + & xp,descp,info, dupl=psb_dupl_ovwrt_) + res = min(0,info) + + return + end function psb_c_dgeins + + + function psb_c_dgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + integer(c_int), value :: nz + integer(c_int) :: irw(*) + real(c_double) :: val(*) + type(psb_c_object_type) :: xh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer :: info + + 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 + + call psb_geins(nz,irw(1:nz),val(1:nz),& + & xp,descp,info, dupl=psb_dupl_add_) + res = min(0,info) + + return + end function psb_c_dgeins_add + + + function psb_c_dspall(mh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: mh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer :: info,n + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(mh%item)) then + return + end if + allocate(ap) + call psb_spall(ap,descp,info) + mh%item = c_loc(ap) + res = min(0,info) + + return + end function psb_c_dspall + + + + function psb_c_dspasb(mh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: mh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer :: info,n + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + call psb_spasb(ap,descp,info) + res = min(0,info) + return + end function psb_c_dspasb + + + function psb_c_dspfree(mh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + type(psb_c_object_type) :: mh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer :: info,n + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + call psb_spfree(ap,descp,info) + res = min(0,info) + mh%item=c_null_ptr + return + end function psb_c_dspfree + + +#if 0 + + function psb_c_dspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) + +#ifdef HAVE_LIBRSB + use psb_d_rsb_mat_mod +#endif + implicit none + integer(c_int) :: res + integer(c_int), value :: cdh, mh,upd,dupl + character(c_char) :: afmt(*) + integer :: info,n, fdupl + character(len=5) :: fafmt +#ifdef HAVE_LIBRSB + type(psb_d_rsb_sparse_mat) :: arsb +#endif + + res = -1 + call psb_check_descriptor_handle(cdh,info) + if (info < 0) return + call psb_check_double_spmat_handle(mh,info) + if (info < 0) return + + call stringc2f(afmt,fafmt) + select case(fafmt) +#ifdef HAVE_LIBRSB + case('RSB') + call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& + & upd=upd,dupl=dupl,mold=arsb) +#endif + case default + call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& + & afmt=fafmt,upd=upd,dupl=dupl) + end select + + res = min(0,info) + + return + end function psb_c_dspasb_opt +#endif + + function psb_c_dspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) + + implicit none + integer(c_int) :: res + integer(c_int), value :: nz + integer(c_int) :: irw(*), icl(*) + real(c_double) :: val(*) + type(psb_c_object_type) :: mh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer :: info,n + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + + call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) + res = min(0,info) + return + end function psb_c_dspins + + + function psb_c_dsprn(mh,cdh,clear) bind(c) result(res) + + implicit none + integer(c_int) :: res + logical(c_bool), value :: clear + type(psb_c_object_type) :: mh + type(psb_c_object_type) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer :: info + logical :: fclear + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,ap) + else + return + end if + + fclear = clear + call psb_sprn(ap,descp,info,clear=fclear) + res = min(0,info) + + return + end function psb_c_dsprn +!!$ +!!$ function psb_c_dspprint(mh) bind(c) result(res) +!!$ +!!$ implicit none +!!$ integer(c_int) :: res +!!$ integer(c_int), value :: mh +!!$ integer :: info +!!$ +!!$ +!!$ res = -1 +!!$ call psb_check_double_spmat_handle(mh,info) +!!$ if (info < 0) return +!!$ +!!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat') +!!$ +!!$ res = 0 +!!$ +!!$ return +!!$ end function psb_c_dspprint + + +end module psb_d_tools_cbind_mod + diff --git a/cbind/base/psb_objhandle_mod.f90 b/cbind/base/psb_objhandle_mod.f90 new file mode 100644 index 00000000..3d5cf5d5 --- /dev/null +++ b/cbind/base/psb_objhandle_mod.f90 @@ -0,0 +1,20 @@ +module psb_objhandle_mod + use iso_c_binding + + type, bind(c) :: psb_c_object_type + type(c_ptr) :: item = c_null_ptr + end type psb_c_object_type + + type, bind(c) :: psb_c_descriptor + type(c_ptr) :: item = c_null_ptr + end type psb_c_descriptor + + type, bind(c) :: psb_c_dvector + type(c_ptr) :: item = c_null_ptr + end type psb_c_dvector + + type, bind(c) :: psb_c_dspmat + type(c_ptr) :: item = c_null_ptr + end type psb_c_dspmat + +end module psb_objhandle_mod