mirror of
https://github.com/TREX-CoE/qmckl.git
synced 2024-06-01 02:45:43 +02:00
Compare commits
67 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| 9553059bbe | |||
| 8c5ec872ed | |||
| 5ee297a1c9 | |||
| 5040ce1087 | |||
| fd9ce7ed5e | |||
| 574cde88e5 | |||
| e0abd84059 | |||
| b2395ece87 | |||
| f745899f3a | |||
| 83dea2b773 | |||
| 21f40b3a13 | |||
| e07b8bfa55 | |||
| 41615ba14b | |||
| 2f0ca9f674 | |||
| be2a7199c2 | |||
| 2228ab23c5 | |||
| 48b80f68f1 | |||
| 24e3f8dd11 | |||
| 949cfb6f82 | |||
| 6ce1d2cbb9 | |||
| 6caf3521a4 | |||
| c6ea9c13a4 | |||
| e20be734cc | |||
| 023c9cda85 | |||
| f08ed5da6d | |||
| 3a73e5722b | |||
| a0e1843963 | |||
| 5060bde30f | |||
| dd3db966b0 | |||
| ffbeb97df4 | |||
| 43ebd409a8 | |||
| 098b6deec3 | |||
| d257e28b92 | |||
| 7e1dad0e4e | |||
| 7fc10a47a1 | |||
| 43b4aa81bd | |||
| b1891b267e | |||
| 141a0a866e | |||
| dba15f6b84 | |||
| 27b1134a4c | |||
| 034f2e81e8 | |||
|
2f69d2af21 | ||
| f150eb1610 | |||
| 4df54f21c7 | |||
| c6d193887a | |||
| dbb49a2df5 | |||
| 6bf9388a4e | |||
| 063aada9e4 | |||
| 952ca05bf0 | |||
| f1764a5717 | |||
| 5d8dfacffe | |||
| a7523fbf77 | |||
| eaa44b45c4 | |||
| c70b7b246b | |||
| 5118359099 | |||
| 0ddaf0cd29 | |||
| 89a4a57c32 | |||
| ad378103a5 | |||
| 1dc1c0f192 | |||
| 233edeeae2 | |||
| 47c4ee7d01 | |||
| ab596fe408 | |||
| de98045fe4 | |||
| 0d9af3c497 | |||
| 50fa3aa754 | |||
| 7a995a0f6b | |||
| 0d2327cae3 |
72
.github/workflows/scorecards.yml
vendored
72
.github/workflows/scorecards.yml
vendored
|
|
@ -1,72 +0,0 @@
|
|||
# This workflow uses actions that are not certified by GitHub. They are provided
|
||||
# by a third-party and are governed by separate terms of service, privacy
|
||||
# policy, and support documentation.
|
||||
|
||||
name: Scorecards supply-chain security
|
||||
on:
|
||||
# For Branch-Protection check. Only the default branch is supported. See
|
||||
# https://github.com/ossf/scorecard/blob/main/docs/checks.md#branch-protection
|
||||
branch_protection_rule:
|
||||
# To guarantee Maintained check is occasionally updated. See
|
||||
# https://github.com/ossf/scorecard/blob/main/docs/checks.md#maintained
|
||||
schedule:
|
||||
- cron: '33 0 * * 5'
|
||||
push:
|
||||
branches: [ "master" ]
|
||||
|
||||
# Declare default permissions as read only.
|
||||
permissions: read-all
|
||||
|
||||
jobs:
|
||||
analysis:
|
||||
name: Scorecards analysis
|
||||
runs-on: ubuntu-latest
|
||||
permissions:
|
||||
# Needed to upload the results to code-scanning dashboard.
|
||||
security-events: write
|
||||
# Needed to publish results and get a badge (see publish_results below).
|
||||
id-token: write
|
||||
# Uncomment the permissions below if installing in a private repository.
|
||||
# contents: read
|
||||
# actions: read
|
||||
|
||||
steps:
|
||||
- name: "Checkout code"
|
||||
uses: actions/checkout@93ea575cb5d8a053eaa0ac8fa3b40d7e05a33cc8 # v3.1.0
|
||||
with:
|
||||
persist-credentials: false
|
||||
|
||||
- name: "Run analysis"
|
||||
uses: ossf/scorecard-action@99c53751e09b9529366343771cc321ec74e9bd3d # v2.0.6
|
||||
with:
|
||||
results_file: results.sarif
|
||||
results_format: sarif
|
||||
# (Optional) Read-only PAT token. Uncomment the `repo_token` line below if:
|
||||
# - you want to enable the Branch-Protection check on a *public* repository, or
|
||||
# - you are installing Scorecards on a *private* repository
|
||||
# To create the PAT, follow the steps in https://github.com/ossf/scorecard-action#authentication-with-pat.
|
||||
# repo_token: ${{ secrets.SCORECARD_READ_TOKEN }}
|
||||
|
||||
# Public repositories:
|
||||
# - Publish results to OpenSSF REST API for easy access by consumers
|
||||
# - Allows the repository to include the Scorecard badge.
|
||||
# - See https://github.com/ossf/scorecard-action#publishing-results.
|
||||
# For private repositories:
|
||||
# - `publish_results` will always be set to `false`, regardless
|
||||
# of the value entered here.
|
||||
publish_results: true
|
||||
|
||||
# Upload the results as artifacts (optional). Commenting out will disable uploads of run results in SARIF
|
||||
# format to the repository Actions tab.
|
||||
- name: "Upload artifact"
|
||||
uses: actions/upload-artifact@3cea5372237819ed00197afe530f5a7ea3e805c8 # v3.1.0
|
||||
with:
|
||||
name: SARIF file
|
||||
path: results.sarif
|
||||
retention-days: 5
|
||||
|
||||
# Upload the results to GitHub's code scanning dashboard.
|
||||
- name: "Upload to code-scanning"
|
||||
uses: github/codeql-action/upload-sarif@807578363a7869ca324a79039e6db9c843e0e100 # v2.1.27
|
||||
with:
|
||||
sarif_file: results.sarif
|
||||
|
|
@ -38,7 +38,7 @@ VERSION_MINOR = @VERSION_MINOR@
|
|||
VERSION_PATCH = @VERSION_PATCH@
|
||||
|
||||
SUBDIRS =
|
||||
CLEANFILES = qmckl.mod qmckl_verificarlo_f.mod
|
||||
CLEANFILES = qmckl.mod qmckl_verificarlo_f.mod qmckl_constants.mod
|
||||
EXTRA_DIST =
|
||||
|
||||
pkgconfigdir = $(libdir)/pkgconfig
|
||||
|
|
@ -46,6 +46,7 @@ pkgconfig_DATA = pkgconfig/qmckl.pc
|
|||
|
||||
qmckl_h = include/qmckl.h
|
||||
qmckl_f = include/qmckl_f.F90
|
||||
qmckl_fo = include/qmckl_f.o
|
||||
include_HEADERS = $(qmckl_h) $(qmckl_f)
|
||||
|
||||
header_tests = tests/chbrclf.h tests/n2.h
|
||||
|
|
@ -61,7 +62,7 @@ lib_LTLIBRARIES = src/libqmckl.la
|
|||
src_libqmckl_la_SOURCES = $(qmckl_h) $(qmckl_f) $(C_FILES) $(F_FILES) $(H_PRIVATE_FUNC_FILES) $(H_PRIVATE_TYPE_FILES)
|
||||
src_libqmckl_la_LDFLAGS = $(LDFLAGS)
|
||||
|
||||
CLEANFILES+=$(test_qmckl_fo) $(qmckl_fo) $(test_qmckl_o) $(FH_TYPE_FILES) $(FH_FUNC_FILES)
|
||||
CLEANFILES+=$(qmckl_fo) $(test_qmckl_o) $(FH_TYPE_FILES) $(FH_FUNC_FILES)
|
||||
|
||||
|
||||
include generated.mk
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
|
||||
<img src="https://trex-coe.eu/sites/default/files/styles/responsive_no_crop/public/2022-01/QMCkl%20code.png?itok=UvOUClA5" width=200>
|
||||
|
||||
|
||||
|
||||
|
||||
The domain of quantum chemistry needs a library in which the main
|
||||
kernels of Quantum Monte Carlo (QMC) methods are implemented. In the
|
||||
library proposed in this project, we expose the main algorithms in a
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@
|
|||
|
||||
export srcdir="."
|
||||
python3 ${srcdir}/tools/build_makefile.py
|
||||
autoreconf -i -Wall --no-recursive
|
||||
autoreconf -vi -Wall --no-recursive
|
||||
|
|
|
|||
42
configure.ac
42
configure.ac
|
|
@ -35,7 +35,7 @@
|
|||
|
||||
AC_PREREQ([2.69])
|
||||
|
||||
AC_INIT([qmckl],[0.5.2],[https://github.com/TREX-CoE/qmckl/issues],[],[https://trex-coe.github.io/qmckl/index.html])
|
||||
AC_INIT([qmckl],[1.0.0],[https://github.com/TREX-CoE/qmckl/issues],[],[https://trex-coe.github.io/qmckl/index.html])
|
||||
AC_CONFIG_AUX_DIR([tools])
|
||||
AM_INIT_AUTOMAKE([subdir-objects color-tests parallel-tests silent-rules 1.11])
|
||||
|
||||
|
|
@ -58,6 +58,22 @@ AS_IF([test "x$with_ifort" = "xyes"], [
|
|||
FCFLAGS="-march=native -ip -Ofast -ftz -finline -g -mkl=sequential" ])
|
||||
|
||||
# Intel C compiler
|
||||
AC_ARG_WITH([icx],
|
||||
[AS_HELP_STRING([--with-icx],
|
||||
[Use Intel C compiler])],
|
||||
[with_icx=$withval],
|
||||
[with_icx=no])
|
||||
|
||||
AS_IF([test "x$with_icx" = "xyes"], [
|
||||
CC=icx
|
||||
CFLAGS="-march=native -Ofast -ftz -finline -g -qmkl=sequential" ])
|
||||
|
||||
AS_IF([test "x$with_icx.$with_ifort" = "xyes.yes"], [
|
||||
ax_blas_ok="yes"
|
||||
ax_lapack_ok="yes"
|
||||
BLAS_LIBS=""
|
||||
LAPACK_LIBS=""])
|
||||
|
||||
AC_ARG_WITH([icc],
|
||||
[AS_HELP_STRING([--with-icc],
|
||||
[Use Intel C compiler])],
|
||||
|
|
@ -518,21 +534,27 @@ AC_MSG_RESULT([$ivdep])
|
|||
|
||||
# Checking ALIGNED
|
||||
|
||||
AC_MSG_CHECKING([for aligned_alloc])
|
||||
AC_MSG_CHECKING([for posix_memalign])
|
||||
AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
]], [[
|
||||
int main() {
|
||||
void * pointer = aligned_alloc(64, 100);
|
||||
free(pointer);
|
||||
return 0;
|
||||
void *ptr;
|
||||
int ret = posix_memalign(&ptr, 64, 1024);
|
||||
if (ret != 0) {
|
||||
return EXIT_FAILURE;
|
||||
}
|
||||
free(ptr);
|
||||
return 0;
|
||||
}
|
||||
]])],
|
||||
[have_aligned_alloc=yes], [have_aligned_alloc=no
|
||||
[have_posix_memalign=yes], [have_posix_memalign=no
|
||||
])
|
||||
AS_IF([test "x$have_aligned_alloc" = "xyes"], [
|
||||
AC_DEFINE([HAVE_ALIGNED_ALLOC], [1], [Define to 1 if you have the aligned_alloc function.])
|
||||
AS_IF([test "x$have_posix_memalign" = "xyes"], [
|
||||
AC_DEFINE([HAVE_POSIX_MEMALIGN], [1], [Define to 1 if you have the posix_memalign function.])
|
||||
])
|
||||
AC_MSG_RESULT([$have_aligned_alloc])
|
||||
AC_MSG_RESULT([$have_posix_memalign])
|
||||
|
||||
aligned=""
|
||||
AC_MSG_CHECKING([for vector aligned pragma])
|
||||
|
|
@ -550,7 +572,7 @@ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
|
|||
[aligned='_Pragma("vector aligned")'], [
|
||||
])
|
||||
|
||||
AS_IF([test "x$have_aligned_alloc" = "xno"], [
|
||||
AS_IF([test "x$have_posix_memalign" = "xno"], [
|
||||
aligned=""
|
||||
])
|
||||
|
||||
|
|
|
|||
|
|
@ -65,6 +65,10 @@
|
|||
|
||||
#serial 12
|
||||
|
||||
# Updates for QMCKl:
|
||||
# - sgemm -> dgemm
|
||||
# - Include check for ARMPL
|
||||
|
||||
AU_ALIAS([ACX_BLAS], [AX_BLAS])
|
||||
AC_DEFUN([AX_BLAS], [
|
||||
AC_PREREQ(2.50)
|
||||
|
|
@ -91,8 +95,8 @@ LIBS="$LIBS $FLIBS"
|
|||
if test $ax_blas_ok = no; then
|
||||
if test "x$BLAS_LIBS" != x; then
|
||||
save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS"
|
||||
AC_MSG_CHECKING([for $sgemm in $BLAS_LIBS])
|
||||
AC_TRY_LINK_FUNC($sgemm, [ax_blas_ok=yes], [BLAS_LIBS=""])
|
||||
AC_MSG_CHECKING([for $dgemm in $BLAS_LIBS])
|
||||
AC_TRY_LINK_FUNC($dgemm, [ax_blas_ok=yes], [BLAS_LIBS=""])
|
||||
AC_MSG_RESULT($ax_blas_ok)
|
||||
LIBS="$save_LIBS"
|
||||
fi
|
||||
|
|
@ -101,22 +105,22 @@ fi
|
|||
# BLAS linked to by default? (happens on some supercomputers)
|
||||
if test $ax_blas_ok = no; then
|
||||
save_LIBS="$LIBS"; LIBS="$LIBS"
|
||||
AC_MSG_CHECKING([if $sgemm is being linked in already])
|
||||
AC_TRY_LINK_FUNC($sgemm, [ax_blas_ok=yes])
|
||||
AC_MSG_CHECKING([if $dgemm is being linked in already])
|
||||
AC_TRY_LINK_FUNC($dgemm, [ax_blas_ok=yes])
|
||||
AC_MSG_RESULT($ax_blas_ok)
|
||||
LIBS="$save_LIBS"
|
||||
fi
|
||||
|
||||
# BLAS in OpenBLAS library? (http://xianyi.github.com/OpenBLAS/)
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(openblas, $sgemm, [ax_blas_ok=yes
|
||||
AC_CHECK_LIB(openblas, $dgemm, [ax_blas_ok=yes
|
||||
BLAS_LIBS="-lopenblas"])
|
||||
fi
|
||||
|
||||
# BLAS in ATLAS library? (http://math-atlas.sourceforge.net/)
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(atlas, ATL_xerbla,
|
||||
[AC_CHECK_LIB(f77blas, $sgemm,
|
||||
[AC_CHECK_LIB(f77blas, $dgemm,
|
||||
[AC_CHECK_LIB(cblas, cblas_dgemm,
|
||||
[ax_blas_ok=yes
|
||||
BLAS_LIBS="-lcblas -lf77blas -latlas"],
|
||||
|
|
@ -136,33 +140,41 @@ fi
|
|||
|
||||
# BLAS in Intel MKL library?
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(mkl, $sgemm, [ax_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread"],,[-lguide -lpthread])
|
||||
AC_CHECK_LIB(mkl, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread"],,[-lguide -lpthread])
|
||||
fi
|
||||
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(mkl_gnu_thread, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-lmkl_gnu_thread -lmkl_core -ldl"],,[-lmkl_core -ldl])
|
||||
fi
|
||||
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(mkl_sequential, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-lmkl_sequential -lmkl_core -ldl"],,[-lmkl_core -ldl])
|
||||
fi
|
||||
|
||||
# BLAS in Apple vecLib library?
|
||||
if test $ax_blas_ok = no; then
|
||||
save_LIBS="$LIBS"; LIBS="-framework vecLib $LIBS"
|
||||
AC_MSG_CHECKING([for $sgemm in -framework vecLib])
|
||||
AC_TRY_LINK_FUNC($sgemm, [ax_blas_ok=yes;BLAS_LIBS="-framework vecLib"])
|
||||
AC_MSG_CHECKING([for $dgemm in -framework vecLib])
|
||||
AC_TRY_LINK_FUNC($dgemm, [ax_blas_ok=yes;BLAS_LIBS="-framework vecLib"])
|
||||
AC_MSG_RESULT($ax_blas_ok)
|
||||
LIBS="$save_LIBS"
|
||||
fi
|
||||
|
||||
# BLAS in Alpha CXML library?
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(cxml, $sgemm, [ax_blas_ok=yes;BLAS_LIBS="-lcxml"])
|
||||
AC_CHECK_LIB(cxml, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-lcxml"])
|
||||
fi
|
||||
|
||||
# BLAS in Alpha DXML library? (now called CXML, see above)
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(dxml, $sgemm, [ax_blas_ok=yes;BLAS_LIBS="-ldxml"])
|
||||
AC_CHECK_LIB(dxml, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-ldxml"])
|
||||
fi
|
||||
|
||||
# BLAS in Sun Performance library?
|
||||
if test $ax_blas_ok = no; then
|
||||
if test "x$GCC" != xyes; then # only works with Sun CC
|
||||
AC_CHECK_LIB(sunmath, acosp,
|
||||
[AC_CHECK_LIB(sunperf, $sgemm,
|
||||
[AC_CHECK_LIB(sunperf, $dgemm,
|
||||
[BLAS_LIBS="-xlic_lib=sunperf -lsunmath"
|
||||
ax_blas_ok=yes],[],[-lsunmath])])
|
||||
fi
|
||||
|
|
@ -170,26 +182,46 @@ fi
|
|||
|
||||
# BLAS in SCSL library? (SGI/Cray Scientific Library)
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(scs, $sgemm, [ax_blas_ok=yes; BLAS_LIBS="-lscs"])
|
||||
AC_CHECK_LIB(scs, $dgemm, [ax_blas_ok=yes; BLAS_LIBS="-lscs"])
|
||||
fi
|
||||
|
||||
# BLAS in SGIMATH library?
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(complib.sgimath, $sgemm,
|
||||
AC_CHECK_LIB(complib.sgimath, $dgemm,
|
||||
[ax_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath"])
|
||||
fi
|
||||
|
||||
# BLAS in IBM ESSL library? (requires generic BLAS lib, too)
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(blas, $sgemm,
|
||||
[AC_CHECK_LIB(essl, $sgemm,
|
||||
AC_CHECK_LIB(blas, $dgemm,
|
||||
[AC_CHECK_LIB(essl, $dgemm,
|
||||
[ax_blas_ok=yes; BLAS_LIBS="-lessl -lblas"],
|
||||
[], [-lblas $FLIBS])])
|
||||
fi
|
||||
|
||||
# BLAS in ARMPL library?
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(armpl_lp64_mp, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-larmpl_lp64_mp"])
|
||||
fi
|
||||
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(armpl_lp64, $dgemm, [ax_blas_ok=yes;BLAS_LIBS="-larmpl_lp64"])
|
||||
fi
|
||||
|
||||
|
||||
# BLAS in ACML?
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(acml_mp, $dgemm, [ax_blas_ok=yes; BLAS_LIBS="-lacml_mp"])
|
||||
fi
|
||||
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(acml, $dgemm, [ax_blas_ok=yes; BLAS_LIBS="-lacml"])
|
||||
fi
|
||||
|
||||
|
||||
# Generic BLAS library?
|
||||
if test $ax_blas_ok = no; then
|
||||
AC_CHECK_LIB(blas, $sgemm, [ax_blas_ok=yes; BLAS_LIBS="-lblas"])
|
||||
AC_CHECK_LIB(blas, $dgemm, [ax_blas_ok=yes; BLAS_LIBS="-lblas"])
|
||||
fi
|
||||
|
||||
AC_SUBST(BLAS_LIBS)
|
||||
|
|
|
|||
1653
org/qmckl_ao.org
1653
org/qmckl_ao.org
File diff suppressed because it is too large
Load Diff
|
|
@ -972,31 +972,40 @@ double* qmckl_alloc_double_of_tensor(const qmckl_context context,
|
|||
const int64_t ldb,
|
||||
const double beta,
|
||||
double* const C,
|
||||
const int64_t ldc );
|
||||
const int64_t ldc );
|
||||
#+end_src
|
||||
|
||||
#+begin_src f90 :tangle (eval f) :exports none
|
||||
integer function qmckl_dgemm_f(context, TransA, TransB, &
|
||||
function qmckl_dgemm(context, TransA, TransB, &
|
||||
m, n, k, alpha, A, LDA, B, LDB, beta, C, LDC) &
|
||||
result(info)
|
||||
use qmckl
|
||||
bind(C) result(info)
|
||||
use qmckl_constants
|
||||
#ifdef HAVE_LIBQMCKLDGEMM
|
||||
use qmckl_dgemm_tiled_module
|
||||
#endif
|
||||
implicit none
|
||||
integer(qmckl_context), intent(in) :: context
|
||||
character , intent(in) :: TransA, TransB
|
||||
integer*8 , intent(in) :: m, n, k
|
||||
double precision , intent(in) :: alpha, beta
|
||||
integer*8 , intent(in) :: lda
|
||||
double precision , intent(in) :: A(lda,*)
|
||||
integer*8 , intent(in) :: ldb
|
||||
double precision , intent(in) :: B(ldb,*)
|
||||
integer*8 , intent(in) :: ldc
|
||||
double precision , intent(out) :: C(ldc,*)
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: TransA
|
||||
character(c_char ) , intent(in) , value :: TransB
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: k
|
||||
real (c_double ) , intent(in) , value :: alpha
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: beta
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
integer(qmckl_exit_code) :: info
|
||||
|
||||
#ifdef HAVE_LIBQMCKLDGEMM
|
||||
double precision,allocatable,dimension(:,:) :: A1
|
||||
double precision,allocatable,dimension(:,:) :: B1
|
||||
double precision,allocatable,dimension(:,:) :: C1
|
||||
#endif
|
||||
|
||||
integer*8 :: i, j, LDA1, LDB1, LDC1
|
||||
|
||||
info = QMCKL_SUCCESS
|
||||
|
|
@ -1040,25 +1049,25 @@ integer function qmckl_dgemm_f(context, TransA, TransB, &
|
|||
! Copy A to A1
|
||||
allocate(A1(k,m))
|
||||
do j=1,m
|
||||
do i=1,k
|
||||
A1(i,j) = A(j,i)
|
||||
end do
|
||||
do i=1,k
|
||||
A1(i,j) = A(j,i)
|
||||
end do
|
||||
end do
|
||||
|
||||
! Copy B to B1
|
||||
allocate(B1(n,k))
|
||||
do j=1,k
|
||||
do i=1,n
|
||||
B1(i,j) = B(j,i)
|
||||
end do
|
||||
do i=1,n
|
||||
B1(i,j) = B(j,i)
|
||||
end do
|
||||
end do
|
||||
|
||||
! Copy C to C1
|
||||
allocate(C1(n,m))
|
||||
do j=1,m
|
||||
do i=1,n
|
||||
C1(i,j) = C(j,i)
|
||||
end do
|
||||
do i=1,n
|
||||
C1(i,j) = C(j,i)
|
||||
end do
|
||||
end do
|
||||
|
||||
LDA1 = size(A1,1)
|
||||
|
|
@ -1070,7 +1079,7 @@ integer function qmckl_dgemm_f(context, TransA, TransB, &
|
|||
|
||||
do j=1,n
|
||||
do i=1,m
|
||||
transpose C(i,j) = alpha*C1(j,i) + beta*C(i,j)
|
||||
transpose C(i,j) = alpha*C1(j,i) + beta*C(i,j)
|
||||
end do
|
||||
end do
|
||||
|
||||
|
|
@ -1079,73 +1088,39 @@ transpose C(i,j) = alpha*C1(j,i) + beta*C(i,j)
|
|||
call dgemm(transA, transB, int(m,4), int(n,4), int(k,4), &
|
||||
alpha, A, int(LDA,4), B, int(LDB,4), beta, C, int(LDC,4))
|
||||
#endif
|
||||
|
||||
|
||||
end function qmckl_dgemm_f
|
||||
|
||||
end function qmckl_dgemm
|
||||
#+end_src
|
||||
|
||||
*** C interface :noexport:
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_dgemm_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_dgemm &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: TransA
|
||||
character(c_char) , intent(in) , value :: TransB
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: k
|
||||
real (c_double ) , intent(in) , value :: alpha
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(in) , value :: beta
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
|
||||
integer(c_int32_t), external :: qmckl_dgemm_f
|
||||
info = qmckl_dgemm_f &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc)
|
||||
|
||||
end function qmckl_dgemm
|
||||
#+end_src
|
||||
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_dgemm_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_dgemm &
|
||||
integer(qmckl_exit_code) function qmckl_dgemm &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: TransA
|
||||
character(c_char) , intent(in) , value :: TransB
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: TransA
|
||||
character(c_char ) , intent(in) , value :: TransB
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: k
|
||||
real (c_double ) , intent(in) , value :: alpha
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(in) , value :: beta
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
|
||||
end function qmckl_dgemm
|
||||
end interface
|
||||
|
|
@ -1295,25 +1270,30 @@ printf("qmckl_dgemm ok\n");
|
|||
#+END_src
|
||||
|
||||
#+begin_src f90 :tangle (eval f) :exports none
|
||||
integer function qmckl_dgemm_safe_f(context, TransA, TransB, &
|
||||
function qmckl_dgemm_safe(context, TransA, TransB, &
|
||||
m, n, k, alpha, A, size_A, LDA, B, size_B, LDB, beta, C, size_C, LDC) &
|
||||
result(info)
|
||||
use qmckl
|
||||
result(info) bind(C)
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context), intent(in) :: context
|
||||
character , intent(in) :: TransA, TransB
|
||||
integer*8 , intent(in) :: m, n, k
|
||||
double precision , intent(in) :: alpha, beta
|
||||
integer*8 , intent(in) :: lda
|
||||
integer*8 , intent(in) :: size_A
|
||||
double precision , intent(in) :: A(lda,*)
|
||||
integer*8 , intent(in) :: ldb
|
||||
integer*8 , intent(in) :: size_B
|
||||
double precision , intent(in) :: B(ldb,*)
|
||||
integer*8 , intent(in) :: ldc
|
||||
integer*8 , intent(in) :: size_C
|
||||
double precision , intent(out) :: C(ldc,*)
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: TransA
|
||||
character(c_char ) , intent(in) , value :: TransB
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: k
|
||||
real (c_double ) , intent(in) , value :: alpha
|
||||
integer (c_int64_t) , intent(in) , value :: size_A
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: size_B
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(in) , value :: beta
|
||||
integer (c_int64_t) , intent(in) , value :: size_C
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
|
||||
integer(qmckl_exit_code) :: info
|
||||
info = QMCKL_SUCCESS
|
||||
|
||||
if (context == QMCKL_NULL_CONTEXT) then
|
||||
|
|
@ -1369,77 +1349,40 @@ integer function qmckl_dgemm_safe_f(context, TransA, TransB, &
|
|||
call dgemm(transA, transB, int(m,4), int(n,4), int(k,4), &
|
||||
alpha, A, int(LDA,4), B, int(LDB,4), beta, C, int(LDC,4))
|
||||
|
||||
end function qmckl_dgemm_safe_f
|
||||
end function qmckl_dgemm_safe
|
||||
#+end_src
|
||||
|
||||
*** C interface :noexport:
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_dgemm_safe_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm_safe")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_dgemm_safe &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, size_A, lda, B, size_B, ldb, beta, C, size_C, ldc) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: TransA
|
||||
character(c_char) , intent(in) , value :: TransB
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: k
|
||||
real (c_double ) , intent(in) , value :: alpha
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_A
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_B
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(in) , value :: beta
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_C
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
|
||||
integer(c_int32_t), external :: qmckl_dgemm_safe_f
|
||||
info = qmckl_dgemm_safe_f &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, size_A, lda, B, size_B, ldb, beta, C, size_C, ldc)
|
||||
|
||||
end function qmckl_dgemm_safe
|
||||
#+end_src
|
||||
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_dgemm_safe_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm_safe")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_dgemm_safe &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, size_A, lda, B, size_B, ldb, beta, C, size_C, ldc) &
|
||||
integer(qmckl_exit_code) function qmckl_dgemm_safe &
|
||||
(context, TransA, TransB, m, n, k, alpha, A, size_max_A, lda, B, size_max_B, ldb, beta, C, size_max_C, ldc) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: TransA
|
||||
character(c_char) , intent(in) , value :: TransB
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: TransA
|
||||
character(c_char ) , intent(in) , value :: TransB
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: k
|
||||
real (c_double ) , intent(in) , value :: alpha
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_A
|
||||
integer (c_int64_t) , intent(in) , value :: size_max_A
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_B
|
||||
integer (c_int64_t) , intent(in) , value :: size_max_B
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(in) , value :: beta
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_C
|
||||
integer (c_int64_t) , intent(in) , value :: size_max_C
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,*)
|
||||
|
||||
end function qmckl_dgemm_safe
|
||||
end interface
|
||||
|
|
@ -1756,17 +1699,19 @@ print(C.T)
|
|||
LAPACK library.
|
||||
|
||||
#+begin_src f90 :tangle (eval f) :exports none
|
||||
integer function qmckl_adjugate_f(context, na, A, LDA, B, ldb, det_l) &
|
||||
result(info)
|
||||
use qmckl
|
||||
function qmckl_adjugate(context, n, A, LDA, B, ldb, det_l) &
|
||||
result(info) bind(C)
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context) , intent(in) :: context
|
||||
double precision, intent(in) :: A (LDA,*)
|
||||
integer*8, intent(in) :: LDA
|
||||
double precision, intent(out) :: B (LDB,*)
|
||||
integer*8, intent(in) :: LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(inout) :: det_l
|
||||
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(inout) :: det_l
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
integer(qmckl_exit_code) :: info
|
||||
|
||||
info = QMCKL_SUCCESS
|
||||
|
||||
|
|
@ -1775,7 +1720,7 @@ integer function qmckl_adjugate_f(context, na, A, LDA, B, ldb, det_l) &
|
|||
return
|
||||
endif
|
||||
|
||||
if (na <= 0_8) then
|
||||
if (n <= 0_8) then
|
||||
info = QMCKL_INVALID_ARG_2
|
||||
return
|
||||
endif
|
||||
|
|
@ -1785,37 +1730,37 @@ integer function qmckl_adjugate_f(context, na, A, LDA, B, ldb, det_l) &
|
|||
return
|
||||
endif
|
||||
|
||||
if (LDA < na) then
|
||||
if (LDA < n) then
|
||||
info = QMCKL_INVALID_ARG_4
|
||||
return
|
||||
endif
|
||||
|
||||
select case (na)
|
||||
select case (n)
|
||||
case (5)
|
||||
call adjugate5(A,LDA,B,LDB,na,det_l)
|
||||
call adjugate5(A,LDA,B,LDB,n,det_l)
|
||||
case (4)
|
||||
call adjugate4(A,LDA,B,LDB,na,det_l)
|
||||
call adjugate4(A,LDA,B,LDB,n,det_l)
|
||||
case (3)
|
||||
call adjugate3(A,LDA,B,LDB,na,det_l)
|
||||
call adjugate3(A,LDA,B,LDB,n,det_l)
|
||||
case (2)
|
||||
call adjugate2(A,LDA,B,LDB,na,det_l)
|
||||
call adjugate2(A,LDA,B,LDB,n,det_l)
|
||||
case (1)
|
||||
det_l = a(1,1)
|
||||
b(1,1) = 1.d0
|
||||
det_l = a(1,1)
|
||||
b(1,1) = 1.d0
|
||||
case default
|
||||
call adjugate_general(context, na, A, LDA, B, LDB, det_l)
|
||||
call adjugate_general(context, n, A, LDA, B, LDB, det_l)
|
||||
end select
|
||||
|
||||
end function qmckl_adjugate_f
|
||||
end function qmckl_adjugate
|
||||
#+end_src
|
||||
|
||||
#+begin_src f90 :tangle (eval f) :exports none
|
||||
subroutine adjugate2(A,LDA,B,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
|
||||
double precision :: C(2,2)
|
||||
|
|
@ -1831,10 +1776,10 @@ end subroutine adjugate2
|
|||
|
||||
subroutine adjugate3(a,LDA,B,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
|
||||
double precision :: C(4,3)
|
||||
|
|
@ -1855,10 +1800,10 @@ end subroutine adjugate3
|
|||
|
||||
subroutine adjugate4(a,LDA,B,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
|
||||
double precision :: C(4,4)
|
||||
|
|
@ -1885,10 +1830,10 @@ end subroutine adjugate4
|
|||
|
||||
subroutine adjugate5(A,LDA,B,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
|
||||
double precision :: C(8,5)
|
||||
|
|
@ -1925,10 +1870,10 @@ end subroutine adjugate5
|
|||
|
||||
subroutine cofactor2(a,LDA,b,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8 :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision :: det_l
|
||||
|
||||
det_l = a(1,1)*a(2,2) - a(1,2)*a(2,1)
|
||||
|
|
@ -1940,10 +1885,10 @@ end subroutine cofactor2
|
|||
|
||||
subroutine cofactor3(a,LDA,b,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
integer :: i
|
||||
|
||||
|
|
@ -1967,10 +1912,10 @@ end subroutine cofactor3
|
|||
|
||||
subroutine cofactor4(a,LDA,b,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
integer :: i,j
|
||||
det_l = a(1,1)*(a(2,2)*(a(3,3)*a(4,4)-a(3,4)*a(4,3)) &
|
||||
|
|
@ -2010,10 +1955,10 @@ end subroutine cofactor4
|
|||
|
||||
subroutine cofactor5(A,LDA,B,LDB,na,det_l)
|
||||
implicit none
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDA,na)
|
||||
integer*8, intent(in) :: LDA, LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
integer :: i,j
|
||||
|
||||
|
|
@ -2188,51 +2133,25 @@ subroutine cofactor5(A,LDA,B,LDB,na,det_l)
|
|||
end
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_adjugate_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_adjugate &
|
||||
(context, n, A, lda, B, ldb, det_l) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(inout) :: det_l
|
||||
|
||||
integer(c_int32_t), external :: qmckl_adjugate_f
|
||||
info = qmckl_adjugate_f &
|
||||
(context, n, A, lda, B, ldb, det_l)
|
||||
|
||||
end function qmckl_adjugate
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_adjugate_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_adjugate &
|
||||
integer(qmckl_exit_code) function qmckl_adjugate &
|
||||
(context, n, A, lda, B, ldb, det_l) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(inout) :: det_l
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
|
||||
end function qmckl_adjugate
|
||||
end interface
|
||||
|
|
@ -2244,11 +2163,11 @@ subroutine adjugate_general(context, na, A, LDA, B, LDB, det_l)
|
|||
use qmckl
|
||||
implicit none
|
||||
integer(qmckl_context), intent(in) :: context
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
integer*8, intent(in) :: LDA
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
integer*8, intent(in) :: LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(in) :: A (LDA,na)
|
||||
double precision, intent(out) :: B (LDB,na)
|
||||
double precision, intent(inout) :: det_l
|
||||
|
||||
double precision :: work(LDA*max(na,64))
|
||||
|
|
@ -2315,7 +2234,7 @@ end subroutine adjugate_general
|
|||
|
||||
#+begin_src f90 :tangle (eval f_test)
|
||||
integer(qmckl_exit_code) function test_qmckl_adjugate(context) bind(C)
|
||||
use qmckl
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context), intent(in), value :: context
|
||||
|
||||
|
|
@ -2642,22 +2561,25 @@ printf("qmckl_adjugate ok\n");
|
|||
LAPACK library.
|
||||
|
||||
#+begin_src f90 :tangle (eval f) :exports none
|
||||
integer function qmckl_adjugate_safe_f(context, &
|
||||
function qmckl_adjugate_safe(context, &
|
||||
na, A, size_A, LDA, B, size_B, LDB, det_l) &
|
||||
result(info)
|
||||
use qmckl
|
||||
implicit none
|
||||
integer(qmckl_context) , intent(in) :: context
|
||||
double precision, intent(in) :: A (LDA,*)
|
||||
integer*8, intent(in) :: size_A
|
||||
integer*8, intent(in) :: LDA
|
||||
double precision, intent(out) :: B (LDB,*)
|
||||
integer*8, intent(in) :: size_B
|
||||
integer*8, intent(in) :: LDB
|
||||
integer*8, intent(in) :: na
|
||||
double precision, intent(inout) :: det_l
|
||||
result(info) bind(C)
|
||||
use qmckl_constants
|
||||
use qmckl, only: qmckl_adjugate
|
||||
|
||||
integer, external :: qmckl_adjugate_f
|
||||
implicit none
|
||||
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
integer (c_int64_t) , intent(in) , value :: na
|
||||
integer (c_int64_t) , intent(in) , value :: size_A
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: size_B
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(inout) :: det_l
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
|
||||
integer(qmckl_exit_code) :: info
|
||||
|
||||
info = QMCKL_SUCCESS
|
||||
|
||||
|
|
@ -2671,7 +2593,7 @@ integer function qmckl_adjugate_safe_f(context, &
|
|||
return
|
||||
endif
|
||||
|
||||
info = qmckl_adjugate_f(context, na, A, LDA, B, LDB, det_l)
|
||||
info = qmckl_adjugate(context, na, A, LDA, B, LDB, det_l)
|
||||
|
||||
if (info == QMCKL_INVALID_ARG_4) then
|
||||
info = QMCKL_INVALID_ARG_5
|
||||
|
|
@ -2683,60 +2605,32 @@ integer function qmckl_adjugate_safe_f(context, &
|
|||
return
|
||||
endif
|
||||
|
||||
end function qmckl_adjugate_safe_f
|
||||
end function qmckl_adjugate_safe
|
||||
#+end_src
|
||||
|
||||
*** C interface
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_adjugate_safe_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate_safe")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_adjugate_safe &
|
||||
(context, n, A, size_A, lda, B, size_B, ldb, det_l) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: size_A
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: size_B
|
||||
real (c_double ) , intent(inout) :: det_l
|
||||
|
||||
integer(c_int32_t), external :: qmckl_adjugate_safe_f
|
||||
info = qmckl_adjugate_safe_f &
|
||||
(context, n, A, size_A, lda, B, size_B, ldb, det_l)
|
||||
|
||||
end function qmckl_adjugate_safe
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_adjugate_safe_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate_safe")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_adjugate_safe &
|
||||
(context, n, A, size_A, lda, B, size_B, ldb, det_l) &
|
||||
integer(qmckl_exit_code) function qmckl_adjugate_safe &
|
||||
(context, n, A, size_max_A, lda, B, size_max_B, ldb, det_l) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_max_A
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: size_A
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: size_max_B
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: size_B
|
||||
real (c_double ) , intent(inout) :: det_l
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(out) :: B(ldb,*)
|
||||
|
||||
end function qmckl_adjugate_safe
|
||||
end interface
|
||||
|
|
|
|||
|
|
@ -222,7 +222,6 @@ qmckl_context_touch(const qmckl_context context)
|
|||
|
||||
qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
|
||||
|
||||
// ctx->electron.walker_old = ctx->electron.walker;
|
||||
ctx->date += 1UL;
|
||||
ctx->point.date = ctx-> date;
|
||||
return QMCKL_SUCCESS;
|
||||
|
|
|
|||
|
|
@ -86,24 +86,30 @@ int main() {
|
|||
const double* B,
|
||||
const int64_t ldb,
|
||||
double* const C,
|
||||
const int64_t ldc );
|
||||
const int64_t ldc );
|
||||
#+end_src
|
||||
|
||||
#+begin_src f90 :tangle (eval f)
|
||||
integer function qmckl_distance_sq_f(context, transa, transb, m, n, &
|
||||
function qmckl_distance_sq(context, transa, transb, m, n, &
|
||||
A, LDA, B, LDB, C, LDC) &
|
||||
result(info)
|
||||
use qmckl
|
||||
bind(C) result(info)
|
||||
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context) , intent(in) :: context
|
||||
character , intent(in) :: transa, transb
|
||||
integer*8 , intent(in) :: m, n
|
||||
integer*8 , intent(in) :: lda
|
||||
real*8 , intent(in) :: A(lda,*)
|
||||
integer*8 , intent(in) :: ldb
|
||||
real*8 , intent(in) :: B(ldb,*)
|
||||
integer*8 , intent(in) :: ldc
|
||||
real*8 , intent(out) :: C(ldc,*)
|
||||
|
||||
integer (qmckl_context) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
|
||||
integer(qmckl_exit_code) :: info
|
||||
|
||||
integer*8 :: i,j
|
||||
real*8 :: x, y, z
|
||||
|
|
@ -216,7 +222,7 @@ integer function qmckl_distance_sq_f(context, transa, transb, m, n, &
|
|||
|
||||
end select
|
||||
|
||||
end function qmckl_distance_sq_f
|
||||
end function qmckl_distance_sq
|
||||
#+end_src
|
||||
|
||||
*** Performance
|
||||
|
|
@ -224,59 +230,29 @@ end function qmckl_distance_sq_f
|
|||
This function is more efficient when ~A~ and ~B~ are
|
||||
transposed.
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_distance_sq_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_distance_sq &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
|
||||
integer(c_int32_t), external :: qmckl_distance_sq_f
|
||||
info = qmckl_distance_sq_f &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc)
|
||||
|
||||
end function qmckl_distance_sq
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_sq_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_sq_args,fname=get_value("Name"))
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_distance_sq &
|
||||
integer(qmckl_exit_code) function qmckl_distance_sq &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: transa
|
||||
character(c_char ) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
|
||||
end function qmckl_distance_sq
|
||||
end interface
|
||||
|
|
@ -288,7 +264,6 @@ integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C)
|
|||
|
||||
use qmckl
|
||||
use qmckl_verificarlo_f
|
||||
use iso_c_binding
|
||||
|
||||
implicit none
|
||||
|
||||
|
|
@ -485,25 +460,28 @@ end function test_qmckl_distance_sq
|
|||
const double* B,
|
||||
const int64_t ldb,
|
||||
double* const C,
|
||||
const int64_t ldc );
|
||||
const int64_t ldc );
|
||||
#+end_src
|
||||
|
||||
*** Source
|
||||
#+begin_src f90 :tangle (eval f)
|
||||
integer function qmckl_distance_f(context, transa, transb, m, n, &
|
||||
function qmckl_distance(context, transa, transb, m, n, &
|
||||
A, LDA, B, LDB, C, LDC) &
|
||||
result(info)
|
||||
use qmckl
|
||||
bind(C) result(info)
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context) , intent(in) :: context
|
||||
character , intent(in) :: transa, transb
|
||||
integer*8 , intent(in) :: m, n
|
||||
integer*8 , intent(in) :: lda
|
||||
real*8 , intent(in) :: A(lda,*)
|
||||
integer*8 , intent(in) :: ldb
|
||||
real*8 , intent(in) :: B(ldb,*)
|
||||
integer*8 , intent(in) :: ldc
|
||||
real*8 , intent(out) :: C(ldc,*)
|
||||
integer(qmckl_context), intent(in), value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (qmckl_exit_code) :: info
|
||||
|
||||
integer*8 :: i,j
|
||||
real*8 :: x, y, z
|
||||
|
|
@ -628,73 +606,41 @@ integer function qmckl_distance_f(context, transa, transb, m, n, &
|
|||
|
||||
end select
|
||||
|
||||
end function qmckl_distance_f
|
||||
end function qmckl_distance
|
||||
#+end_src
|
||||
|
||||
*** Performance
|
||||
|
||||
This function is more efficient when ~A~ and ~B~ are transposed.
|
||||
|
||||
** C interface :noexport:
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_distance_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_distance &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
|
||||
integer(c_int32_t), external :: qmckl_distance_f
|
||||
info = qmckl_distance_f &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc)
|
||||
|
||||
end function qmckl_distance
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_args,fname="qmckl_distance")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_distance &
|
||||
integer(qmckl_exit_code) function qmckl_distance &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: transa
|
||||
character(c_char ) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
|
||||
end function qmckl_distance
|
||||
end interface
|
||||
#+end_src
|
||||
|
||||
*** Performance
|
||||
|
||||
This function is more efficient when ~A~ and ~B~ are transposed.
|
||||
|
||||
*** Test :noexport:
|
||||
#+begin_src f90 :tangle (eval f_test)
|
||||
|
||||
|
|
@ -702,7 +648,6 @@ integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C)
|
|||
|
||||
use qmckl
|
||||
use qmckl_verificarlo_f
|
||||
use iso_c_binding
|
||||
|
||||
implicit none
|
||||
|
||||
|
|
@ -909,26 +854,29 @@ end function test_qmckl_dist
|
|||
const int64_t ldb,
|
||||
double* const C,
|
||||
const int64_t ldc,
|
||||
const double rescale_factor_kappa );
|
||||
const double rescale_factor_kappa );
|
||||
#+end_src
|
||||
|
||||
*** Source
|
||||
#+begin_src f90 :tangle (eval f)
|
||||
integer function qmckl_distance_rescaled_f(context, transa, transb, m, n, &
|
||||
function qmckl_distance_rescaled(context, transa, transb, m, n, &
|
||||
A, LDA, B, LDB, C, LDC, rescale_factor_kappa) &
|
||||
result(info)
|
||||
use qmckl
|
||||
bind(C) result(info)
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context) , intent(in) :: context
|
||||
character , intent(in) :: transa, transb
|
||||
integer*8 , intent(in) :: m, n
|
||||
integer*8 , intent(in) :: lda
|
||||
real*8 , intent(in) :: A(lda,*)
|
||||
integer*8 , intent(in) :: ldb
|
||||
real*8 , intent(in) :: B(ldb,*)
|
||||
integer*8 , intent(in) :: ldc
|
||||
real*8 , intent(out) :: C(ldc,*)
|
||||
real*8 , intent(in) :: rescale_factor_kappa
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: transa
|
||||
character(c_char ) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: rescale_factor_kappa
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer(qmckl_exit_code) :: info
|
||||
|
||||
integer*8 :: i,j
|
||||
real*8 :: x, y, z, dist, rescale_factor_kappa_inv
|
||||
|
|
@ -1055,7 +1003,7 @@ integer function qmckl_distance_rescaled_f(context, transa, transb, m, n, &
|
|||
|
||||
end select
|
||||
|
||||
end function qmckl_distance_rescaled_f
|
||||
end function qmckl_distance_rescaled
|
||||
#+end_src
|
||||
|
||||
*** Performance
|
||||
|
|
@ -1064,61 +1012,30 @@ end function qmckl_distance_rescaled_f
|
|||
|
||||
** C interface :noexport:
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_distance_rescaled_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_distance_rescaled &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: rescale_factor_kappa
|
||||
|
||||
integer(c_int32_t), external :: qmckl_distance_rescaled_f
|
||||
info = qmckl_distance_rescaled_f &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa)
|
||||
|
||||
end function qmckl_distance_rescaled
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_args,fname="qmckl_distance_rescaled")
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_distance_rescaled &
|
||||
integer(qmckl_exit_code) function qmckl_distance_rescaled &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: transa
|
||||
character(c_char ) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: rescale_factor_kappa
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(ldc,n)
|
||||
|
||||
end function qmckl_distance_rescaled
|
||||
end interface
|
||||
|
|
@ -1201,7 +1118,6 @@ print(en_distance_rescaled)
|
|||
integer(qmckl_exit_code) function test_qmckl_dist_rescaled(context) bind(C)
|
||||
|
||||
use qmckl
|
||||
use iso_c_binding
|
||||
|
||||
implicit none
|
||||
|
||||
|
|
@ -1368,7 +1284,7 @@ end function test_qmckl_dist_rescaled
|
|||
| ~lda~ | ~int64_t~ | in | Leading dimension of array ~A~ |
|
||||
| ~B~ | ~double[][ldb]~ | in | Array containing the $n \times 3$ matrix $B$ |
|
||||
| ~ldb~ | ~int64_t~ | in | Leading dimension of array ~B~ |
|
||||
| ~C~ | ~double[4][n][ldc]~ | out | Array containing the $4 \times m \times n$ matrix $C$ |
|
||||
| ~C~ | ~double[n][ldc][4]~ | out | Array containing the $4 \times m \times n$ matrix $C$ |
|
||||
| ~ldc~ | ~int64_t~ | in | Leading dimension of array ~C~ |
|
||||
| ~rescale_factor_kappa~ | ~double~ | in | Factor for calculating rescaled distances derivatives |
|
||||
|
||||
|
|
@ -1406,21 +1322,25 @@ end function test_qmckl_dist_rescaled
|
|||
#+end_src
|
||||
|
||||
#+begin_src f90 :tangle (eval f)
|
||||
integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
|
||||
function qmckl_distance_rescaled_gl(context, transa, transb, m, n, &
|
||||
A, LDA, B, LDB, C, LDC, rescale_factor_kappa) &
|
||||
result(info)
|
||||
use qmckl
|
||||
bind(C) result(info)
|
||||
use qmckl_constants
|
||||
implicit none
|
||||
integer(qmckl_context) , intent(in) :: context
|
||||
character , intent(in) :: transa, transb
|
||||
integer*8 , intent(in) :: m, n
|
||||
integer*8 , intent(in) :: lda
|
||||
real*8 , intent(in) :: A(lda,*)
|
||||
integer*8 , intent(in) :: ldb
|
||||
real*8 , intent(in) :: B(ldb,*)
|
||||
integer*8 , intent(in) :: ldc
|
||||
real*8 , intent(out) :: C(4,ldc,*)
|
||||
real*8 , intent(in) :: rescale_factor_kappa
|
||||
|
||||
integer(qmckl_exit_code) :: info
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: transa
|
||||
character(c_char ) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: rescale_factor_kappa
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(4,ldc,n)
|
||||
|
||||
integer*8 :: i,j
|
||||
real*8 :: x, y, z, dist, dist_inv
|
||||
|
|
@ -1503,11 +1423,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
|
|||
x = A(1,i) - B(1,j)
|
||||
y = A(2,i) - B(2,j)
|
||||
z = A(3,i) - B(3,j)
|
||||
dist = dsqrt(x*x + y*y + z*z)
|
||||
! Avoid floating-point exception
|
||||
if (dist == 0.d0) then
|
||||
dist = 69.d0/rescale_factor_kappa
|
||||
endif
|
||||
dist = max(1.d-20, dsqrt(x*x + y*y + z*z))
|
||||
dist_inv = 1.0d0/dist
|
||||
rij = dexp(-rescale_factor_kappa * dist)
|
||||
C(1,i,j) = x * dist_inv * rij
|
||||
|
|
@ -1524,11 +1440,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
|
|||
x = A(i,1) - B(1,j)
|
||||
y = A(i,2) - B(2,j)
|
||||
z = A(i,3) - B(3,j)
|
||||
dist = dsqrt(x*x + y*y + z*z)
|
||||
! Avoid floating-point exception
|
||||
if (dist == 0.d0) then
|
||||
dist = 69.d0/rescale_factor_kappa
|
||||
endif
|
||||
dist = max(1.d-20, dsqrt(x*x + y*y + z*z))
|
||||
dist_inv = 1.0d0/dist
|
||||
rij = dexp(-rescale_factor_kappa * dist)
|
||||
C(1,i,j) = x * dist_inv * rij
|
||||
|
|
@ -1545,11 +1457,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
|
|||
x = A(1,i) - B(j,1)
|
||||
y = A(2,i) - B(j,2)
|
||||
z = A(3,i) - B(j,3)
|
||||
dist = dsqrt(x*x + y*y + z*z)
|
||||
! Avoid floating-point exception
|
||||
if (dist == 0.d0) then
|
||||
dist = 69.d0/rescale_factor_kappa
|
||||
endif
|
||||
dist = max(1.d-20, dsqrt(x*x + y*y + z*z))
|
||||
dist_inv = 1.0d0/dist
|
||||
rij = dexp(-rescale_factor_kappa * dist)
|
||||
C(1,i,j) = x * dist_inv * rij
|
||||
|
|
@ -1566,11 +1474,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
|
|||
x = A(i,1) - B(j,1)
|
||||
y = A(i,2) - B(j,2)
|
||||
z = A(i,3) - B(j,3)
|
||||
dist = dsqrt(x*x + y*y + z*z)
|
||||
! Avoid floating-point exception
|
||||
if (dist == 0.d0) then
|
||||
dist = 69.d0/rescale_factor_kappa
|
||||
endif
|
||||
dist = max(1.d-20, dsqrt(x*x + y*y + z*z))
|
||||
dist_inv = 1.0d0/dist
|
||||
rij = dexp(-rescale_factor_kappa * dist)
|
||||
C(1,i,j) = x * dist_inv * rij
|
||||
|
|
@ -1582,66 +1486,36 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
|
|||
|
||||
end select
|
||||
|
||||
end function qmckl_distance_rescaled_gl_f
|
||||
end function qmckl_distance_rescaled_gl
|
||||
#+end_src
|
||||
|
||||
This function is more efficient when ~A~ and ~B~ are transposed.
|
||||
|
||||
#+CALL: generate_c_interface(table=qmckl_distance_rescaled_gl_args,fname=get_value("Name"))
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
||||
integer(c_int32_t) function qmckl_distance_rescaled_gl &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
|
||||
bind(C) result(info)
|
||||
|
||||
use, intrinsic :: iso_c_binding
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n,4)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: rescale_factor_kappa
|
||||
|
||||
integer(c_int32_t), external :: qmckl_distance_rescaled_gl_f
|
||||
info = qmckl_distance_rescaled_gl_f &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa)
|
||||
|
||||
end function qmckl_distance_rescaled_gl
|
||||
#+end_src
|
||||
|
||||
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_gl_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
|
||||
|
||||
#+RESULTS:
|
||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||
interface
|
||||
integer(c_int32_t) function qmckl_distance_rescaled_gl &
|
||||
integer(qmckl_exit_code) function qmckl_distance_rescaled_gl &
|
||||
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
|
||||
bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
implicit none
|
||||
|
||||
integer (c_int64_t) , intent(in) , value :: context
|
||||
character(c_char) , intent(in) , value :: transa
|
||||
character(c_char) , intent(in) , value :: transb
|
||||
integer (qmckl_context), intent(in) , value :: context
|
||||
character(c_char ) , intent(in) , value :: transa
|
||||
character(c_char ) , intent(in) , value :: transb
|
||||
integer (c_int64_t) , intent(in) , value :: m
|
||||
integer (c_int64_t) , intent(in) , value :: n
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
integer (c_int64_t) , intent(in) , value :: lda
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
integer (c_int64_t) , intent(in) , value :: ldb
|
||||
real (c_double ) , intent(out) :: C(ldc,n,4)
|
||||
integer (c_int64_t) , intent(in) , value :: ldc
|
||||
real (c_double ) , intent(in) , value :: rescale_factor_kappa
|
||||
real (c_double ) , intent(in) :: A(lda,*)
|
||||
real (c_double ) , intent(in) :: B(ldb,*)
|
||||
real (c_double ) , intent(out) :: C(4,ldc,n)
|
||||
|
||||
end function qmckl_distance_rescaled_gl
|
||||
end interface
|
||||
|
|
|
|||
|
|
@ -334,6 +334,10 @@ qmckl_set_electron_coord(qmckl_context context,
|
|||
ctx->electron.walker.num = walk_num;
|
||||
memcpy(&(ctx->electron.walker.point), &(ctx->point), sizeof(qmckl_point_struct));
|
||||
|
||||
// If it is the first time we set the electrons, we set also walkers_old.
|
||||
if (ctx->electron.walker_old.num == 0) {
|
||||
qmckl_set_electron_coord(context, transp, walk_num, coord, size_max);
|
||||
}
|
||||
return QMCKL_SUCCESS;
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -460,8 +460,8 @@ int main(int argc, char** argv)
|
|||
gettimeofday(&timecheck, NULL);
|
||||
after = (long)timecheck.tv_sec * 1000 + (long)timecheck.tv_usec / 1000;
|
||||
|
||||
printf("Number of MOs: %ld\n", mo_num);
|
||||
printf("Number of grid points: %ld\n", point_num);
|
||||
printf("Number of MOs: %ld\n", (long) mo_num);
|
||||
printf("Number of grid points: %ld\n", (long) point_num);
|
||||
printf("Execution time : %f seconds\n", (after - before)*1.e-3);
|
||||
|
||||
#+end_src
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -125,7 +125,7 @@ void* qmckl_malloc(qmckl_context context,
|
|||
~qmckl_context~.
|
||||
|
||||
4. The function then allocates memory:
|
||||
If the ~HAVE_HPC~ and ~HAVE_ALIGNED_ALLOC~ macros are defined, the memory
|
||||
If the ~HAVE_HPC~ and ~HAVE_POSIX_MEMALIGN~ macros are defined, the memory
|
||||
allocation is done using the ~aligned_alloc~ function with a 64-byte alignment,
|
||||
rounding up the requested size to the nearest multiple of 64 bytes. Else, the
|
||||
memory allocation is done using the standard ~malloc~ function.
|
||||
|
|
@ -153,11 +153,11 @@ void* qmckl_malloc(qmckl_context context, const qmckl_memory_info_struct info) {
|
|||
qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
|
||||
|
||||
/* Allocate memory and zero it */
|
||||
#if defined(HAVE_HPC) && defined(HAVE_ALIGNED_ALLOC)
|
||||
assert( ((info.size+64) >> 6) << 6 >= info.size );
|
||||
void * pointer = aligned_alloc(64, ((info.size+64) >> 6) << 6 );
|
||||
void * pointer = NULL;
|
||||
#if defined(HAVE_HPC) && defined(HAVE_POSIX_MEMALIGN)
|
||||
if (posix_memalign(&pointer, 64, info.size) != 0) pointer = NULL;
|
||||
#else
|
||||
void * pointer = malloc(info.size);
|
||||
pointer = malloc(info.size);
|
||||
#endif
|
||||
if (pointer == NULL) {
|
||||
return NULL;
|
||||
|
|
|
|||
956
org/qmckl_mo.org
956
org/qmckl_mo.org
File diff suppressed because it is too large
Load Diff
|
|
@ -1,4 +1,4 @@
|
|||
#+TITLE: Numerical precision
|
||||
3+TITLE: Numerical precision
|
||||
#+SETUPFILE: ../tools/theme.setup
|
||||
#+INCLUDE: ../tools/lib.org
|
||||
|
||||
|
|
@ -86,8 +86,8 @@ trapfpe ()
|
|||
default parameters determining the target numerical precision and
|
||||
range are defined. Following the IEEE Standard for Floating-Point
|
||||
Arithmetic (IEEE 754),
|
||||
/precision/ refers to the number of significand bits and /range/
|
||||
refers to the number of exponent bits.
|
||||
/precision/ refers to the number of significand bits (including the
|
||||
sign bit) and /range/ refers to the number of exponent bits.
|
||||
|
||||
#+NAME: table-precision
|
||||
| ~QMCKL_DEFAULT_PRECISION~ | 53 |
|
||||
|
|
@ -329,23 +329,28 @@ int qmckl_get_numprec_range(const qmckl_context context) {
|
|||
|
||||
* Helper functions
|
||||
|
||||
~qmckl_get_numprec_epsilon~ returns $\epsilon = 2^{1-n}$ where ~n~ is the precision.
|
||||
We need to remove the sign bit from the precision.
|
||||
** Epsilon
|
||||
|
||||
#+begin_src c :comments org :tangle (eval h_func) :exports none
|
||||
~qmckl_get_numprec_epsilon~ returns $\epsilon = 2^{1-n}$ where ~n~ is the precision.
|
||||
We need to remove the sign bit from the precision.
|
||||
|
||||
#+begin_src c :comments org :tangle (eval h_func) :exports none
|
||||
double qmckl_get_numprec_epsilon(const qmckl_context context);
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
# Source
|
||||
#+begin_src c :tangle (eval c)
|
||||
# Source
|
||||
#+begin_src c :tangle (eval c)
|
||||
double qmckl_get_numprec_epsilon(const qmckl_context context) {
|
||||
const int precision = qmckl_get_numprec_precision(context);
|
||||
return 1. / (double) (1L << (precision-2));
|
||||
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT)
|
||||
return QMCKL_INVALID_CONTEXT;
|
||||
const qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
|
||||
const int precision = ctx->numprec.precision;
|
||||
return 1. / (double) ( ((uint64_t) 1) << (precision-2));
|
||||
}
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
# Fortran interface
|
||||
#+begin_src f90 :tangle (eval fh_func) :exports none
|
||||
# Fortran interface
|
||||
#+begin_src f90 :tangle (eval fh_func) :exports none
|
||||
interface
|
||||
real (c_double) function qmckl_get_numprec_epsilon(context) bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
|
|
@ -353,7 +358,137 @@ double qmckl_get_numprec_epsilon(const qmckl_context context) {
|
|||
integer (qmckl_context), intent(in), value :: context
|
||||
end function qmckl_get_numprec_epsilon
|
||||
end interface
|
||||
#+end_src
|
||||
#+end_src
|
||||
|
||||
** Testing the number of unchanged bits
|
||||
|
||||
To test that a given approximation keeps a given number of bits
|
||||
unchanged, we need a function that returns the number of unchanged
|
||||
bits in the range, and in the precision.
|
||||
|
||||
For this, we first count by how many units in the last place (ulps) two
|
||||
numbers differ.
|
||||
|
||||
#+begin_src c :tangle (eval c)
|
||||
int64_t countUlpDifference_64(double a, double b) {
|
||||
|
||||
union int_or_float {
|
||||
int64_t i;
|
||||
double f;
|
||||
} x, y;
|
||||
|
||||
x.f = a;
|
||||
y.f = b;
|
||||
|
||||
// Handle sign bit discontinuity: if the signs are different and either value is not zero
|
||||
if ((x.i < 0) != (y.i < 0) && (x.f != 0.0) && (y.f != 0.0)) {
|
||||
// Use the absolute values and add the distance to zero for both numbers
|
||||
int64_t distanceToZeroForX = x.i < 0 ? INT64_MAX + x.i : INT64_MAX - x.i;
|
||||
int64_t distanceToZeroForY = y.i < 0 ? INT64_MAX + y.i : INT64_MAX - y.i;
|
||||
return distanceToZeroForX + distanceToZeroForY;
|
||||
}
|
||||
|
||||
// Calculate the difference in their binary representations
|
||||
int64_t result = x.i - y.i;
|
||||
result = result > 0 ? result : -result;
|
||||
return result;
|
||||
}
|
||||
#+end_src
|
||||
|
||||
#+begin_src c :comments org :tangle (eval h_func) :exports none
|
||||
int32_t qmckl_test_precision_64(double a, double b);
|
||||
int32_t qmckl_test_precision_32(float a, float b);
|
||||
#+end_src
|
||||
|
||||
#+begin_src c :tangle (eval c)
|
||||
int32_t qmckl_test_precision_64(double a, double b) {
|
||||
|
||||
int64_t diff = countUlpDifference_64(a,b);
|
||||
|
||||
if (diff == 0) return 53;
|
||||
|
||||
int32_t result = 53;
|
||||
|
||||
for (int i=0 ; i<53 && diff != 0 ; ++i) {
|
||||
diff >>= 1;
|
||||
result--;
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
#+end_src
|
||||
|
||||
|
||||
#+begin_src c :tangle (eval c)
|
||||
int32_t qmckl_test_precision_32(float a, float b) {
|
||||
return qmckl_test_precision_64( (double) a, (double) b );
|
||||
}
|
||||
#+end_src
|
||||
|
||||
#+begin_src f90 :tangle (eval fh_func) :exports none
|
||||
interface
|
||||
integer (c_int) function qmckl_test_precision_32(a,b) bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
real (c_float), intent(in), value :: a, b
|
||||
end function qmckl_test_precision_32
|
||||
end interface
|
||||
|
||||
interface
|
||||
integer (c_int) function qmckl_test_precision_64(a,b) bind(C)
|
||||
use, intrinsic :: iso_c_binding
|
||||
import
|
||||
real (c_double), intent(in), value :: a, b
|
||||
end function qmckl_test_precision_64
|
||||
end interface
|
||||
#+end_src
|
||||
|
||||
* Approximate functions
|
||||
|
||||
** Exponential
|
||||
|
||||
Fast exponential function, adapted from Johan Rade's implementation
|
||||
(https://gist.github.com/jrade/293a73f89dfef51da6522428c857802d). It
|
||||
is based on Schraudolph's paper:
|
||||
|
||||
N. Schraudolph, "A Fast, Compact Approximation of the Exponential Function",
|
||||
/Neural Computation/ *11*, 853–862 (1999).
|
||||
(available at https://nic.schraudolph.org/pubs/Schraudolph99.pdf)
|
||||
|
||||
#+begin_src c :tangle (eval c)
|
||||
float fastExpf(float x)
|
||||
{
|
||||
const float a = 12102203.0;
|
||||
const float b = 1064986816.0;
|
||||
x = a * x + b;
|
||||
|
||||
const float c = 8388608.0;
|
||||
const float d = 2139095040.0;
|
||||
if (x < c || x > d)
|
||||
x = (x < c) ? 0.0f : d;
|
||||
|
||||
uint32_t n = (uint32_t) x;
|
||||
memcpy(&x, &n, 4);
|
||||
return x;
|
||||
}
|
||||
|
||||
|
||||
double fastExp(double x)
|
||||
{
|
||||
const double a = 6497320848556798.0;
|
||||
const double b = 4606985713057410560.0;
|
||||
x = a * x + b;
|
||||
|
||||
const double c = 4503599627370496.0;
|
||||
const double d = 9218868437227405312.0;
|
||||
if (x < c || x > d)
|
||||
x = (x < c) ? 0.0 : d;
|
||||
|
||||
uint64_t n = (uint64_t) x;
|
||||
memcpy(&x, &n, 8);
|
||||
return x;
|
||||
}
|
||||
#+end_src
|
||||
|
||||
* End of files :noexport:
|
||||
|
||||
|
|
|
|||
|
|
@ -365,11 +365,11 @@ qmckl_exit_code qmckl_sm_naive_hpc(
|
|||
const uint64_t LDS,
|
||||
const uint64_t Dim,
|
||||
const uint64_t N_updates,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict determinant) {
|
||||
|
||||
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
||||
return qmckl_failwith( context,
|
||||
|
|
@ -435,11 +435,11 @@ qmckl_exit_code qmckl_sm_naive_hpc(
|
|||
static inline qmckl_exit_code qmckl_sm_naive_{Dim}(
|
||||
const qmckl_context context,
|
||||
const uint64_t N_updates,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict determinant) {
|
||||
|
||||
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
||||
return qmckl_failwith(context,
|
||||
|
|
@ -561,13 +561,14 @@ qmckl_exit_code qmckl_sm_naive(const qmckl_context context,
|
|||
NULL);
|
||||
}
|
||||
|
||||
#ifdef HAVE_HPC
|
||||
#ifdef HAVE_HPC__BROKEN_WITH_CRAY
|
||||
if (LDS == (1+(Dim-1)/SIMD_LENGTH)*SIMD_LENGTH) { // Most cases
|
||||
switch (Dim) {
|
||||
<<naive_switch-case_generator()>>
|
||||
}
|
||||
}
|
||||
else { // Updating smaller sub-matrix
|
||||
else
|
||||
{ // Updating smaller sub-matrix
|
||||
return qmckl_sm_naive_hpc(
|
||||
context,
|
||||
LDS,
|
||||
|
|
@ -1033,14 +1034,14 @@ qmckl_exit_code qmckl_sm_splitting_core_hpc(
|
|||
uint64_t LDS,
|
||||
uint64_t Dim,
|
||||
uint64_t N_updates,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict later_updates,
|
||||
uint64_t* __restrict later_index,
|
||||
uint64_t* __restrict later,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict later_updates,
|
||||
uint64_t* restrict later_index,
|
||||
uint64_t* restrict later,
|
||||
double* restrict determinant) {
|
||||
|
||||
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
||||
return qmckl_failwith(
|
||||
|
|
@ -1117,14 +1118,14 @@ qmckl_exit_code qmckl_sm_splitting_core_hpc(
|
|||
static inline qmckl_exit_code qmckl_sm_splitting_core_{Dim}(
|
||||
const qmckl_context context,
|
||||
uint64_t N_updates,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict later_updates,
|
||||
uint64_t* __restrict later_index,
|
||||
uint64_t* __restrict later,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict later_updates,
|
||||
uint64_t* restrict later_index,
|
||||
uint64_t* restrict later,
|
||||
double* restrict determinant) {
|
||||
|
||||
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
||||
return qmckl_failwith(
|
||||
|
|
@ -1252,7 +1253,7 @@ qmckl_exit_code qmckl_sm_splitting_core(
|
|||
uint64_t* later,
|
||||
double* determinant) {
|
||||
|
||||
#ifdef HAVE_HPC
|
||||
#ifdef HAVE_HPC__BROKEN_WITH_CRAY
|
||||
if (LDS == (1+(Dim-1)/SIMD_LENGTH)*SIMD_LENGTH) { // Most cases
|
||||
switch (Dim) {
|
||||
<<slagel_splitting_switch-case_generator()>>
|
||||
|
|
@ -1662,11 +1663,11 @@ qmckl_exit_code qmckl_woodbury_2x2_doc (
|
|||
qmckl_exit_code qmckl_woodbury_2x2_hpc(const qmckl_context context,
|
||||
const uint64_t LDS,
|
||||
const uint64_t Dim,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict determinant) {
|
||||
/*
|
||||
C := S^{-1} * U, dim x 2
|
||||
B := 1 + V * C, 2 x 2
|
||||
|
|
@ -1688,8 +1689,6 @@ qmckl_exit_code qmckl_woodbury_2x2_hpc(const qmckl_context context,
|
|||
for (uint64_t i = 0; i < Dim; i++) {
|
||||
C[i * 2] = 0;
|
||||
C[i * 2 + 1] = 0;
|
||||
IVDEP
|
||||
ALIGNED
|
||||
for (uint64_t k = 0; k < LDS; k++) {
|
||||
C[i * 2] += Slater_inv[i * LDS + k] * Updates[k];
|
||||
C[i * 2 + 1] += Slater_inv[i * LDS + k] * Updates[LDS + k];
|
||||
|
|
@ -1723,8 +1722,6 @@ qmckl_exit_code qmckl_woodbury_2x2_hpc(const qmckl_context context,
|
|||
double __attribute__((aligned(8))) tmp[2 * LDS];
|
||||
double* r1dim = &(Slater_inv[row1 * LDS]);
|
||||
double* r2dim = &(Slater_inv[row2 * LDS]);
|
||||
IVDEP
|
||||
ALIGNED
|
||||
for (uint64_t j = 0; j < LDS; j++) {
|
||||
tmp[j] = Binv[0] * r1dim[j] + Binv[1] * r2dim[j];
|
||||
tmp[LDS + j] = Binv[2] * r1dim[j] + Binv[3] * r2dim[j];
|
||||
|
|
@ -1732,8 +1729,6 @@ qmckl_exit_code qmckl_woodbury_2x2_hpc(const qmckl_context context,
|
|||
|
||||
// Compute (S^T)^{-1} - C * tmp : Dim x LDS
|
||||
for (uint64_t i = 0; i < Dim; i++) {
|
||||
IVDEP
|
||||
ALIGNED
|
||||
for (uint64_t j = 0; j < LDS; j++) {
|
||||
Slater_inv[i * LDS + j] -= C[i * 2] * tmp[j];
|
||||
Slater_inv[i * LDS + j] -= C[i * 2 + 1] * tmp[LDS + j];
|
||||
|
|
@ -1748,11 +1743,11 @@ qmckl_exit_code qmckl_woodbury_2x2_hpc(const qmckl_context context,
|
|||
#+begin_src c
|
||||
static inline qmckl_exit_code qmckl_woodbury_2x2_{Dim}(
|
||||
const qmckl_context context,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict determinant) {
|
||||
/*
|
||||
C := S^{-1} * U, dim x 2
|
||||
B := 1 + V * C, 2 x 2
|
||||
|
|
@ -1883,7 +1878,7 @@ qmckl_exit_code qmckl_woodbury_2x2(const qmckl_context context,
|
|||
NULL);
|
||||
}
|
||||
|
||||
#ifdef HAVE_HPC
|
||||
#ifdef HAVE_HPC__BROKEN_WITH_CRAY
|
||||
if (LDS == (1+(Dim-1)/SIMD_LENGTH)*SIMD_LENGTH) { // Most cases
|
||||
switch (Dim) {
|
||||
<<woodbury_2x2_switch-case_generator()>>
|
||||
|
|
@ -2314,11 +2309,11 @@ qmckl_exit_code qmckl_woodbury_3x3_doc (
|
|||
qmckl_exit_code qmckl_woodbury_3x3_hpc(const qmckl_context context,
|
||||
const uint64_t LDS,
|
||||
const uint64_t Dim,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict determinant) {
|
||||
/*
|
||||
C := S^{-1} * U, dim x 3
|
||||
B := 1 + V * C, 3 x 3
|
||||
|
|
@ -2420,11 +2415,11 @@ qmckl_exit_code qmckl_woodbury_3x3_hpc(const qmckl_context context,
|
|||
#+begin_src c
|
||||
static inline qmckl_exit_code qmckl_woodbury_3x3_{Dim}(
|
||||
const qmckl_context context,
|
||||
const double* __restrict Updates,
|
||||
const uint64_t* __restrict Updates_index,
|
||||
const double* restrict Updates,
|
||||
const uint64_t* restrict Updates_index,
|
||||
const double breakdown,
|
||||
double* __restrict Slater_inv,
|
||||
double* __restrict determinant) {
|
||||
double* restrict Slater_inv,
|
||||
double* restrict determinant) {
|
||||
/*
|
||||
C := S^{-1} * U, dim x 3
|
||||
B := 1 + V * C, 3 x 3
|
||||
|
|
@ -2575,7 +2570,7 @@ qmckl_exit_code qmckl_woodbury_3x3(const qmckl_context context,
|
|||
NULL);
|
||||
}
|
||||
|
||||
#ifdef HAVE_HPC
|
||||
#ifdef HAVE_HPC__BROKEN_WITH_CRAY
|
||||
if (LDS == (1+(Dim-1)/SIMD_LENGTH)*SIMD_LENGTH) { // Most cases
|
||||
switch (Dim) {
|
||||
<<woodbury_3x3_switch-case_generator()>>
|
||||
|
|
@ -3037,7 +3032,7 @@ qmckl_exit_code qmckl_sm_splitting(
|
|||
"qmckl_sm_splitting",
|
||||
NULL);
|
||||
}
|
||||
#ifdef HAVE_HPC
|
||||
#ifdef HAVE_HPC__BROKEN_WITH_CRAY
|
||||
return qmckl_sm_splitting_hpc(
|
||||
context,
|
||||
LDS,
|
||||
|
|
|
|||
|
|
@ -368,7 +368,7 @@ qmckl_trexio_read_ao_X(qmckl_context context, trexio_t* const file)
|
|||
*** Number of atomic orbitals
|
||||
|
||||
#+begin_src c :tangle (eval c)
|
||||
int64_t ao_num = 0LL;
|
||||
int64_t ao_num = 0;
|
||||
|
||||
rcio = trexio_read_ao_num_64(file, &ao_num);
|
||||
if (rcio != TREXIO_SUCCESS) {
|
||||
|
|
@ -515,7 +515,7 @@ qmckl_trexio_read_ao_X(qmckl_context context, trexio_t* const file)
|
|||
for (int i=0 ; i<nucleus_num ; ++i) {
|
||||
nucleus_shell_num[i] = 0;
|
||||
}
|
||||
|
||||
|
||||
for (int i=0 ; i<shell_num ; ++i) {
|
||||
const int k = tmp_array[i];
|
||||
if (k < 0 || k >= nucleus_num) {
|
||||
|
|
@ -601,7 +601,7 @@ qmckl_trexio_read_ao_X(qmckl_context context, trexio_t* const file)
|
|||
if (shell_prim_num == NULL) {
|
||||
return qmckl_failwith( context,
|
||||
QMCKL_ALLOCATION_FAILED,
|
||||
"qmckl_trexio_read_basis_shell_prim_num_X",
|
||||
"qmckl_trexio_read_basis_shell_index",
|
||||
NULL);
|
||||
}
|
||||
|
||||
|
|
@ -617,7 +617,7 @@ qmckl_trexio_read_ao_X(qmckl_context context, trexio_t* const file)
|
|||
shell_prim_num = NULL;
|
||||
return qmckl_failwith( context,
|
||||
QMCKL_ALLOCATION_FAILED,
|
||||
"qmckl_trexio_read_basis_shell_prim_num_X",
|
||||
"qmckl_trexio_read_basis_shell_index",
|
||||
NULL);
|
||||
}
|
||||
|
||||
|
|
@ -632,7 +632,7 @@ qmckl_trexio_read_ao_X(qmckl_context context, trexio_t* const file)
|
|||
tmp_array = NULL;
|
||||
return qmckl_failwith( context,
|
||||
QMCKL_FAILURE,
|
||||
"trexio_read_basis_shell_prim_num",
|
||||
"qmckl_trexio_read_basis_shell_index",
|
||||
trexio_string_of_error(rcio));
|
||||
}
|
||||
|
||||
|
|
@ -640,16 +640,18 @@ qmckl_trexio_read_ao_X(qmckl_context context, trexio_t* const file)
|
|||
for (int i=0 ; i<shell_num ; ++i) {
|
||||
shell_prim_num[i] = 0;
|
||||
}
|
||||
|
||||
|
||||
for (int i=0 ; i<prim_num ; ++i) {
|
||||
const int k = tmp_array[i];
|
||||
if (k < 0 || k >= shell_num) {
|
||||
qmckl_free(context, tmp_array);
|
||||
qmckl_free(context, shell_prim_num);
|
||||
char msg[128];
|
||||
sprintf(&msg[0], "Irrelevant data in TREXIO file: k = %d", k);
|
||||
return qmckl_failwith( context,
|
||||
QMCKL_FAILURE,
|
||||
"trexio_read_basis_shell_prim_num",
|
||||
"Irrelevant data in TREXIO file");
|
||||
"qmckl_trexio_read_basis_shell_index",
|
||||
&msg[0]);
|
||||
}
|
||||
shell_prim_num[k] += 1;
|
||||
}
|
||||
|
|
@ -1332,7 +1334,7 @@ double * mo_coef = (double*) malloc (ao_num * mo_num * sizeof(double));
|
|||
rc = qmckl_get_mo_basis_coefficient(context, mo_coef, mo_num*ao_num);
|
||||
qmckl_check(context, rc);
|
||||
for (int i=0 ; i<ao_num * mo_num ; i++) {
|
||||
printf("%d %e %e %e\n", i, mo_coef[i], chbrclf_mo_coef[i],
|
||||
printf("%d %e %e %e\n", i, mo_coef[i], chbrclf_mo_coef[i],
|
||||
( fabs(mo_coef[i] - chbrclf_mo_coef[i])/fabs(mo_coef[i])) );
|
||||
assert ( fabs(mo_coef[i] - chbrclf_mo_coef[i])/fabs(mo_coef[i]) < 1.e-12 );
|
||||
}
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ qmckl_module = Extension(name = "._" + MODULE_NAME,
|
|||
|
||||
|
||||
setup(name = MODULE_NAME,
|
||||
version = "0.5.2",
|
||||
version = "1.0.0",
|
||||
author = "TREX-CoE",
|
||||
author_email = "posenitskiy@irsamc.ups-tlse.fr",
|
||||
description = """Python API of the QMCkl library""",
|
||||
|
|
|
|||
|
|
@ -178,14 +178,14 @@ def main():
|
|||
F_TEST_FILES += [f_test]
|
||||
|
||||
if f_test in DEPS:
|
||||
DEPS_TEST[f_test] += [tangled, "$(test_qmckl_fo)"]
|
||||
DEPS_TEST[f_test] += [tangled]
|
||||
else:
|
||||
DEPS_TEST[f_test] = [tangled, "$(test_qmckl_fo)"]
|
||||
DEPS_TEST[f_test] = [tangled]
|
||||
|
||||
if c_test_x in TESTS:
|
||||
TESTS[c_test_x] += [f_test, "$(test_qmckl_fo)"]
|
||||
TESTS[c_test_x] += [f_test]
|
||||
else:
|
||||
TESTS[c_test_x] = [f_test, "$(test_qmckl_fo)"]
|
||||
TESTS[c_test_x] = [f_test]
|
||||
|
||||
output = ["",
|
||||
"## Source files",
|
||||
|
|
@ -240,8 +240,7 @@ def main():
|
|||
output+= ["",
|
||||
"## Test files",
|
||||
"",
|
||||
"$(header_tests): $(TANGLED_FILES)",
|
||||
"$(test_qmckl_fo): $(test_qmckl_f)"]
|
||||
"$(header_tests): $(TANGLED_FILES)" ]
|
||||
output += ["",
|
||||
"check_PROGRAMS = $(TESTS)" ]
|
||||
for f in sorted(TESTS.keys()):
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ cat << EOF > ${qmckl_f}
|
|||
!
|
||||
!
|
||||
!
|
||||
module qmckl
|
||||
module qmckl_constants
|
||||
use, intrinsic :: iso_c_binding
|
||||
EOF
|
||||
|
||||
|
|
@ -85,6 +85,13 @@ do
|
|||
cat $i >> ${qmckl_f}
|
||||
done
|
||||
|
||||
cat << EOF >> ${qmckl_f}
|
||||
end module qmckl_constants
|
||||
|
||||
module qmckl
|
||||
use qmckl_constants
|
||||
EOF
|
||||
|
||||
for i in ${HEADERS}
|
||||
do
|
||||
cat $i >> ${qmckl_f}
|
||||
|
|
|
|||
|
|
@ -35,10 +35,10 @@
|
|||
*** Fortran-C type conversions
|
||||
|
||||
#+NAME:f_of_c
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
|
||||
f_of_c_d = { '' : ''
|
||||
, 'qmckl_context' : 'integer (c_int64_t)'
|
||||
, 'qmckl_exit_code' : 'integer (c_int32_t)'
|
||||
, 'qmckl_context' : 'integer (qmckl_context)'
|
||||
, 'qmckl_exit_code' : 'integer (qmckl_exit_code)'
|
||||
, 'bool' : 'logical*8'
|
||||
, 'int32_t' : 'integer (c_int32_t)'
|
||||
, 'int64_t' : 'integer (c_int64_t)'
|
||||
|
|
@ -53,8 +53,8 @@ f_of_c_d = { '' : ''
|
|||
#+NAME:c_of_f
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
|
||||
ctypeid_d = { '' : ''
|
||||
, 'qmckl_context' : 'integer(c_int64_t)'
|
||||
, 'qmckl_exit_code' : 'integer(c_int32_t)'
|
||||
, 'qmckl_context' : 'integer(qmckl_context)'
|
||||
, 'qmckl_exit_code' : 'integer(qmckl_exit_code)'
|
||||
, 'integer' : 'integer(c_int32_t)'
|
||||
, 'integer*8' : 'integer(c_int64_t)'
|
||||
, 'real' : 'real(c_float)'
|
||||
|
|
@ -164,7 +164,7 @@ return template
|
|||
*** Generates a C interface to the Fortran function
|
||||
|
||||
#+NAME: generate_c_interface
|
||||
#+BEGIN_SRC python :var table=[] :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
|
||||
#+BEGIN_SRC python :var table=[] :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
|
||||
<<c_of_f>>
|
||||
<<f_of_c>>
|
||||
<<parse_table>>
|
||||
|
|
@ -181,7 +181,7 @@ results = [ f"{rettyp_c} function {fname} &"
|
|||
, f" ({args}) &"
|
||||
, " bind(C) result(info)"
|
||||
, ""
|
||||
, " use, intrinsic :: iso_c_binding"
|
||||
, " use qmckl_constants"
|
||||
, " implicit none"
|
||||
, ""
|
||||
]
|
||||
|
|
@ -220,7 +220,7 @@ return results
|
|||
*** Generates a Fortran interface to the C function
|
||||
|
||||
#+NAME: generate_f_interface
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_func) :comments org :exports none"
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_func) :comments org :exports none"
|
||||
<<c_of_f>>
|
||||
<<f_of_c>>
|
||||
<<parse_table>>
|
||||
|
|
@ -234,7 +234,7 @@ results = [ f"interface"
|
|||
, f" {rettyp_c} function {fname} &"
|
||||
, f" ({args}) &"
|
||||
, " bind(C)"
|
||||
, " use, intrinsic :: iso_c_binding"
|
||||
, " use qmckl_constants"
|
||||
, " import"
|
||||
, " implicit none"
|
||||
, ""
|
||||
|
|
@ -269,7 +269,7 @@ return results
|
|||
#+END_SRC
|
||||
|
||||
#+NAME: generate_private_f_interface
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_private_func) :comments org :exports none"
|
||||
#+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_private_func) :comments org :exports none"
|
||||
<<c_of_f>>
|
||||
<<f_of_c>>
|
||||
<<parse_table>>
|
||||
|
|
@ -283,7 +283,7 @@ results = [ f"interface"
|
|||
, f" {rettyp_c} function {fname} &"
|
||||
, f" ({args}) &"
|
||||
, " bind(C)"
|
||||
, " use, intrinsic :: iso_c_binding"
|
||||
, " use qmckl_constants"
|
||||
, " import"
|
||||
, " implicit none"
|
||||
, ""
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user