diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index 7cbcafa..6b77119 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -24,11 +24,26 @@ jobs: run: git clone https://github.com/hniksic/emacs-htmlize && cp emacs-htmlize/htmlize.el docs/ - name: make - run: make -C src/ doc + run: make -C src/ doc && ls -sh ./docs/ + + - name: pwd + run: pwd + + - name: ls + run: ls -sh ./docs + +# - name: Deploy +# uses: peaceiris/actions-gh-pages@v3 +# with: +# github_token: ${{ secrets.GITHUB_TOKEN }} +# publish_dir: ./docs - name: Deploy - uses: peaceiris/actions-gh-pages@v3 + uses: JamesIves/github-pages-deploy-action@4.1.0 with: - github_token: ${{ secrets.GITHUB_TOKEN }} - publish_dir: ./docs + branch: gh-pages + folder: ./docs + +# github_token: ${{ secrets.GITHUB_TOKEN }} +# publish_dir: ./docs diff --git a/.github/workflows/test-build.yml b/.github/workflows/test-build.yml index bcc00a2..0e65800 100644 --- a/.github/workflows/test-build.yml +++ b/.github/workflows/test-build.yml @@ -37,4 +37,6 @@ jobs: git submodule sync git submodule update --init --recursive - name: make - run: make -C src/ test + run: make -C src/ check + - name: make + run: make distcheck diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b3c7c38 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +docs/index.html +docs/htmlize.el +autom4te.cache/ +config.log +config.status +src/auto/ +src/ltximg/ +src/qmckl.mod +*.swp +*.tar.gz + + diff --git a/.gitmodules b/.gitmodules index 8ad4907..6d6dce9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "munit"] path = munit url = https://github.com/nemequ/munit/ +[submodule "docs/org-html-themes"] + path = docs/org-html-themes + url = https://github.com/fniessen/org-html-themes.git diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..9d09487 --- /dev/null +++ b/Makefile @@ -0,0 +1,78 @@ +# Use POSIX-compliant Makefiles +.POSIX: + +# Clear suffix list +.SUFFIXES: + +package = qmckl +version = 0.1-alpha +tarname = $(package) +distdir = $(tarname)-$(version) +prefix = /usr/local + +QMCKL_ROOT=$(CURDIR) +shared_lib=$(QMCKL_ROOT)/lib/libqmckl.so +static_lib=$(QMCKL_ROOT)/lib/libqmckl.a +qmckl_h=$(QMCKL_ROOT)/include/qmckl.h +qmckl_f=$(QMCKL_ROOT)/share/qmckl/fortran/qmckl_f.f90 + +export prefix shared_lib static_lib qmckl_h qmckl_f + + +all clean doc check install uninstall: + $(MAKE) -C src $@ + +dist: $(distdir).tar.gz + + +$(distdir).tar.gz: $(distdir) + tar chof - $(distdir) | gzip -9 -c > $@ + rm -rf $(distdir) + + +$(distdir): $(qmckl_h) $(qmckl_f) $(static_lib) $(shared_lib) src/Makefile.generated doc FORCE + mkdir -p $(distdir) + mkdir -p $(distdir)/munit + mkdir -p $(distdir)/src + mkdir -p $(distdir)/include + mkdir -p $(distdir)/share/qmckl/fortran + mkdir -p $(distdir)/share/doc/qmckl/html/ + mkdir -p $(distdir)/share/doc/qmckl/text/ + mkdir -p $(distdir)/man + cp munit/munit.h munit/munit.c $(distdir)/munit/ + cp src/*.c src/*.h src/*.f90 $(distdir)/src/ + cp src/Makefile.generated $(distdir)/src/Makefile + cp include/* $(distdir)/include + cp Makefile $(distdir)/ + cp docs/*.html $(distdir)/share/doc/qmckl/html/ + cp docs/*.css $(distdir)/share/doc/qmckl/html/ + cp docs/*.txt $(distdir)/share/doc/qmckl/text/ + cp share/qmckl/fortran/* $(distdir)/share/qmckl/fortran + mkdir -p $(distdir)/lib + + +FORCE: + rm -f -- $(distdir).tar.gz + rm -rf -- $(distdir) + + +distcheck: $(distdir).tar.gz + gzip -cd $(distdir).tar.gz | tar xvf - + cd $(distdir) && $(MAKE) all check + rm $(distdir)/lib/libqmckl.so + rm $(distdir)/include/qmckl.h + rm $(distdir)/share/qmckl/fortran/qmckl_f.f90 + rm $(distdir)/share/doc/qmckl/html/*.html + rm $(distdir)/share/doc/qmckl/html/*.css + rm $(distdir)/share/doc/qmckl/text/*.txt + cd $(distdir) && $(MAKE) clean + rm -rf $(distdir) + @echo "*** Package $(distdir).tar.gz is ready for distribution." + + +$(qmckl_h) $(qmckl_f) $(static_lib) $(shared_lib) src/Makefile.generated: + $(MAKE) -C src $@ + + + +.PHONY: all clean dist doc install uninstall FORCE diff --git a/TODO.org b/TODO.org index 1fad144..b565b64 100644 --- a/TODO.org +++ b/TODO.org @@ -16,3 +16,6 @@ context. * Complex numbers * Adjustable number for derivatives (1,2,3) +* Put pictures +* Make the Makefile part of the documented code ? +* Put the data-flow graph in the code. diff --git a/configure.org b/configure.org new file mode 100644 index 0000000..010d101 --- /dev/null +++ b/configure.org @@ -0,0 +1,137 @@ +#+TITLE: QMCkl configuration + +This files contains al the information to generate the files required +by Autotools to build the =configure= script for the library. + +* Scripts analyzing source code + +** Version of the library + + #+NAME: version + #+BEGIN_SRC sh +echo 1.0 + #+END_SRC + + #+RESULTS: version + : 1.0 + + #+NAME: issues + #+BEGIN_SRC sh +echo "https://github.com/TREX-CoE/qmckl/issues" + #+END_SRC + + #+RESULTS: issues + : https://github.com/TREX-CoE/qmckl/issues + + #+NAME: website + #+BEGIN_SRC sh +echo "https://trex-coe.github.io/qmckl/index.html" + #+END_SRC + + #+RESULTS: website + : https://trex-coe.github.io/qmckl/index.html + + + #+NAME: revision + #+BEGIN_SRC sh +git log --oneline | head -1 + #+END_SRC + + #+RESULTS: revision + : 5f2da3e Fixed website + +** C Header files + + #+NAME: headers + #+BEGIN_SRC sh :tangle no +#grep --regexp="\#include\\s+<.*>" --no-filename src/*.org \ +grep --regexp="\#include\\s*<.*>" --no-filename src/*.org \ + | sort \ + | uniq \ + | cut -d '<' -f 2 \ + | cut -d '>' -f 1 \ + | tr '\n' ' ' + #+END_SRC + + #+RESULTS: headers + : assert.h errno.h math.h stdint.h stdlib.h string.h + + +* configure.ac + +** Initialization + + #+BEGIN_SRC sh :noweb yes :tangle configure.ac +# This file was generated from the org-mode file configure.org + +VERSION=[<>] +AC_SUBST([VERSION]) + +AC_REVISION([<>]) +AC_INIT([QMCkl],[<>], + [<>], [], + [<>]) + #+END_SRC + +** Source files + #+BEGIN_SRC sh :noweb yes :tangle configure.ac +AC_CONFIG_SRCDIR([src/README.org]) + #+END_SRC + +** C Compiler + + #+BEGIN_SRC sh :noweb yes :tangle configure.ac +AC_LANG_PUSH([C]) +AC_PROG_CC + +AC_CHECK_HEADERS([<>]) + #+END_SRC + +** Fortran Compiler + + #+BEGIN_SRC sh :noweb yes :tangle configure.ac +AC_PROG_FC([ifort gfortran flang],[Fortran]) +AC_PROG_FC_C_O +AC_FC_SRCEXT([f90]) +AC_FC_FREEFORM + #+END_SRC + +** External libraries + + #+BEGIN_SRC sh :tangle configure.ac +AC_CHECK_HEADER([munit/munit.h], [echo found], [echo not found] ) + +AC_CHECK_LIB([pthread], [pthread_create]) + +AC_SEARCH_LIBS([dgemm], [blas mkl], + [], + AC_MSG_ERROR([Unable to find a BLAS library]) + ]) + #+END_SRC + +** Makefile + + #+BEGIN_SRC sh :tangle configure.ac +AC_CONFIG_FILES(Makefile) + #+END_SRC + +** Library + + #+BEGIN_SRC sh :tangle configure.ac + + #+END_SRC + +** Documentation + + #+BEGIN_SRC sh :noweb yes :tangle configure.ac +AC_CHECK_PROGS([HAS_EMACS],[emacs],[]) + #+END_SRC + +** Finalization + + #+BEGIN_SRC sh :tangle configure.ac +AC_OUTPUT + #+END_SRC + +* Makefile.am + diff --git a/docs/.gitignore b/docs/.gitignore index e69de29..2211df6 100644 --- a/docs/.gitignore +++ b/docs/.gitignore @@ -0,0 +1 @@ +*.txt diff --git a/docs/org-html-themes b/docs/org-html-themes new file mode 160000 index 0000000..f7224a4 --- /dev/null +++ b/docs/org-html-themes @@ -0,0 +1 @@ +Subproject commit f7224a489462abc2c2174edbf7d4e82c0e276183 diff --git a/docs/qmckl.css b/docs/qmckl.css new file mode 100644 index 0000000..cfc7a63 --- /dev/null +++ b/docs/qmckl.css @@ -0,0 +1,972 @@ +/* Adapted from worg.css */ + +@import url(https://fonts.googleapis.com/css?family=Droid+Sans|Droid+Sans+Mono|Droid+Serif); + +@media all +{ + html { + margin: 0; + font: .9em/1.6em "Droid Serif", Cambria, Georgia, "DejaVu Serif", serif; + background-image: url(/img/org-mode-unicorn-logo-worg.png); + background-attachment: fixed; + background-position: right bottom; + background-repeat: no-repeat; + background-color: white; + } + + body { + font-size: 14pt; + line-height: 22pt; + color: black; + margin-top: 0; + } + + body #content { + padding-top: 2em; + margin: auto; + max-width: 70%; + background-color: white; + } + + body #support { + position: fixed; + top:0; + display:block; + font-size: 12pt; + right:0pt; + text-align: right; + padding: .2em 1em; + background: #EEE; + border-radius: 10px; + } + + body .title { + margin-left: 0px; + font-size: 22pt; + } + + #org-div-home-and-up{ + position: fixed; + right: 0.5em; + margin-top: 70px; + font-family:sans-serif; + } + + /* TOC inspired by http://jashkenas.github.com/coffee-script */ + #table-of-contents { + margin-top: 105px; + font-size: 10pt; + font-family:sans-serif; + position: fixed; + right: 0em; + top: 0em; + background: white; + line-height: 12pt; + text-align: right; + box-shadow: 0 0 1em #777777; + -webkit-box-shadow: 0 0 1em #777777; + -moz-box-shadow: 0 0 1em #777777; + -webkit-border-bottom-left-radius: 5px; + -moz-border-radius-bottomleft: 5px; + /* ensure doesn't flow off the screen when expanded */ + max-height: 80%; + overflow: auto; } + #table-of-contents h2 { + font-size: 13pt; + max-width: 9em; + border: 0; + font-weight: normal; + padding-left: 0.5em; + padding-right: 0.5em; + padding-top: 0.05em; + padding-bottom: 0.05em; } + #table-of-contents #text-table-of-contents { + display: none; + text-align: left; } + #table-of-contents:hover #text-table-of-contents { + display: block; + padding: 0.5em; + margin-top: -1.5em; } + + #license { + background-color: #eeeeee; + } + + h1 { + font-size:2.1em; + padding:0 0 30px 0; + margin-top: 10px; + margin-bottom: 10px; + margin-right: 7%; + color: grey; + } + + h2 { + font-family:sans-serif; + font-size:1.45em; + padding:10px 0 10px 0; + color: black; + border-bottom: 1px solid #ddd; + padding-top: 1.5em; + } + + .outline-text-2 { + margin-left: 0.1em + } + + h3 { + font-family:sans-serif; + font-size:1.3em; + color: grey; + margin-left: 0.6em; + padding-top: 1.5em; + } + + /* #A34D32;*/ + + + .outline-text-3 { + margin-left: 0.9em; + } + + h4 { + font-family:sans-serif; + font-size:1.2em; + margin-left: 1.2em; + color: #A5573E; + padding-top: 1.5em; + } + + .outline-text-4 { + margin-left: 1.45em; + } + + a {text-decoration: none; font-weight: 400;} + a:visited {text-decoration: none; font-weight: 400;} + a:hover {text-decoration: underline;} + + .todo { + color: #CA0000; + } + + .done { + color: #006666; + } + + .timestamp-kwd { + color: #444; + } + + .tag { + background-color: #ffff; + color: #ffff; + } + + li { + margin: .4em; + } + + table { + border: 1; + border-color: grey; + } + + thead { + border: 0; + } + + tbody { + border: 0; + } + + tr { + border: 0; + } + + td { + border-left: 0px; + border-right: 0px; + border-top: 0px; + border-bottom: 0px; + } + + th { + border-left: 0px; + border-right: 0px; + border-top: 1px solid grey; + border-bottom: 1px solid grey; + } + + code { + font-size: 100%; + color: black; + padding: 0px 0.2em; + } + + img { + border: 0; + } + + .share img { + opacity: .4; + -moz-opacity: .4; + filter: alpha(opacity=40); + } + + .share img:hover { + opacity: 1; + -moz-opacity: 1; + filter: alpha(opacity=100); + } + + pre { + font-family: Droid Sans Mono, Monaco, Consolas, "Lucida Console", monospace; + color: black; + font-size: 90%; + padding: 0.5em; + overflow: auto; + border: none; + background-color: #f2f2f2; + border-radius: 5px; + } + + .org-info-box { + clear:both; + margin-left:auto; + margin-right:auto; + padding:0.7em; + } + .org-info-box img { + float:left; + margin:0em 0.5em 0em 0em; + } + .org-info-box p { + margin:0em; + padding:0em; + } + + + .builtin { + /* font-lock-builtin-face */ + color: #f4a460; + } + .comment { + /* font-lock-comment-face */ + color: #737373; + } + .comment-delimiter { + /* font-lock-comment-delimiter-face */ + color: #666666; + } + .constant { + /* font-lock-constant-face */ + color: #db7093; + } + .doc { + /* font-lock-doc-face */ + color: #b3b3b3; + } + .function-name { + /* font-lock-function-name-face */ + color: #5f9ea0; + } + .headline { + /* headline-face */ + color: #ffffff; + background-color: #000000; + font-weight: bold; + } + .keyword { + /* font-lock-keyword-face */ + color: #4682b4; + } + .negation-char { + } + .regexp-grouping-backslash { + } + .regexp-grouping-construct { + } + .string { + /* font-lock-string-face */ + color: #ccc79a; + } + .todo-comment { + /* todo-comment-face */ + color: #ffffff; + background-color: #000000; + font-weight: bold; + } + .variable-name { + /* font-lock-variable-name-face */ + color: #ff6a6a; + } + .warning { + /* font-lock-warning-face */ + color: #ffffff; + background-color: #cd5c5c; + font-weight: bold; + } + .important { + /* font-lock-warning-face */ + background-color: #e3e3f7; + } + .exercise { + /* font-lock-warning-face */ + background-color: #e3f7e3; + } + .note { + /* font-lock-warning-face */ + background-color: #f7f7d9; + } + pre.a { + color: inherit; + background-color: inherit; + font: inherit; + text-decoration: inherit; + } + pre.a:hover { + text-decoration: underline; + } + + /* Styles for org-info.js */ + + .org-info-js_info-navigation + { + border-style:none; + } + + #org-info-js_console-label + { + font-size:10px; + font-weight:bold; + white-space:nowrap; + } + + .org-info-js_search-highlight + { + background-color:#ffff00; + color:#000000; + font-weight:bold; + } + + #org-info-js-window + { + border-bottom:1px solid black; + padding-bottom:10px; + margin-bottom:10px; + } + + + + .org-info-search-highlight + { + background-color:#adefef; /* same color as emacs default */ + color:#000000; + font-weight:bold; + } + + .org-bbdb-company { + /* bbdb-company */ + font-style: italic; + } + .org-bbdb-field-name { + } + .org-bbdb-field-value { + } + .org-bbdb-name { + /* bbdb-name */ + text-decoration: underline; + } + .org-bold { + /* bold */ + font-weight: bold; + } + .org-bold-italic { + /* bold-italic */ + font-weight: bold; + font-style: italic; + } + .org-border { + /* border */ + background-color: #000000; + } + .org-buffer-menu-buffer { + /* buffer-menu-buffer */ + font-weight: bold; + } + .org-builtin { + /* font-lock-builtin-face */ + color: #da70d6; + } + .org-button { + /* button */ + text-decoration: underline; + } + .org-c-nonbreakable-space { + /* c-nonbreakable-space-face */ + background-color: #ff0000; + font-weight: bold; + } + .org-calendar-today { + /* calendar-today */ + text-decoration: underline; + } + .org-comment { + /* font-lock-comment-face */ + color: #b22222; + } + .org-comment-delimiter { + /* font-lock-comment-delimiter-face */ + color: #b22222; + } + .org-constant { + /* font-lock-constant-face */ + color: #5f9ea0; + } + .org-cursor { + /* cursor */ + background-color: #000000; + } + .org-default { + /* default */ + color: #000000; + background-color: #ffffff; + } + .org-diary { + /* diary */ + color: #ff0000; + } + .org-doc { + /* font-lock-doc-face */ + color: #bc8f8f; + } + .org-escape-glyph { + /* escape-glyph */ + color: #a52a2a; + } + .org-file-name-shadow { + /* file-name-shadow */ + color: #7f7f7f; + } + .org-fixed-pitch { + } + .org-fringe { + /* fringe */ + background-color: #f2f2f2; + } + .org-function-name { + /* font-lock-function-name-face */ + color: #0000ff; + } + .org-header-line { + /* header-line */ + color: #333333; + background-color: #e5e5e5; + } + .org-help-argument-name { + /* help-argument-name */ + font-style: italic; + } + .org-highlight { + /* highlight */ + background-color: #b4eeb4; + } + .org-holiday { + /* holiday */ + background-color: #ffc0cb; + } + .org-info-header-node { + /* info-header-node */ + color: #a52a2a; + font-weight: bold; + font-style: italic; + } + .org-info-header-xref { + /* info-header-xref */ + color: #0000ff; + text-decoration: underline; + } + .org-info-menu-header { + /* info-menu-header */ + font-weight: bold; + } + .org-info-menu-star { + /* info-menu-star */ + color: #ff0000; + } + .org-info-node { + /* info-node */ + color: #a52a2a; + font-weight: bold; + font-style: italic; + } + .org-info-title-1 { + /* info-title-1 */ + font-size: 172%; + font-weight: bold; + } + .org-info-title-2 { + /* info-title-2 */ + font-size: 144%; + font-weight: bold; + } + .org-info-title-3 { + /* info-title-3 */ + font-size: 120%; + font-weight: bold; + } + .org-info-title-4 { + /* info-title-4 */ + font-weight: bold; + } + .org-info-xref { + /* info-xref */ + color: #0000ff; + text-decoration: underline; + } + .org-isearch { + /* isearch */ + color: #b0e2ff; + background-color: #cd00cd; + } + .org-italic { + /* italic */ + font-style: italic; + } + .org-keyword { + /* font-lock-keyword-face */ + color: #a020f0; + } + .org-lazy-highlight { + /* lazy-highlight */ + background-color: #afeeee; + } + .org-link { + /* link */ + color: #0000ff; + text-decoration: underline; + } + .org-link-visited { + /* link-visited */ + color: #8b008b; + text-decoration: underline; + } + .org-match { + /* match */ + background-color: #ffff00; + } + .org-menu { + } + .org-message-cited-text { + /* message-cited-text */ + color: #ff0000; + } + .org-message-header-cc { + /* message-header-cc */ + color: #191970; + } + .org-message-header-name { + /* message-header-name */ + color: #6495ed; + } + .org-message-header-newsgroups { + /* message-header-newsgroups */ + color: #00008b; + font-weight: bold; + font-style: italic; + } + .org-message-header-other { + /* message-header-other */ + color: #4682b4; + } + .org-message-header-subject { + /* message-header-subject */ + color: #000080; + font-weight: bold; + } + .org-message-header-to { + /* message-header-to */ + color: #191970; + font-weight: bold; + } + .org-message-header-xheader { + /* message-header-xheader */ + color: #0000ff; + } + .org-message-mml { + /* message-mml */ + color: #228b22; + } + .org-message-separator { + /* message-separator */ + color: #a52a2a; + } + .org-minibuffer-prompt { + /* minibuffer-prompt */ + color: #0000cd; + } + .org-mm-uu-extract { + /* mm-uu-extract */ + color: #006400; + background-color: #ffffe0; + } + .org-mode-line { + /* mode-line */ + color: #000000; + background-color: #bfbfbf; + } + .org-mode-line-buffer-id { + /* mode-line-buffer-id */ + font-weight: bold; + } + .org-mode-line-highlight { + } + .org-mode-line-inactive { + /* mode-line-inactive */ + color: #333333; + background-color: #e5e5e5; + } + .org-mouse { + /* mouse */ + background-color: #000000; + } + .org-negation-char { + } + .org-next-error { + /* next-error */ + background-color: #eedc82; + } + .org-nobreak-space { + /* nobreak-space */ + color: #a52a2a; + text-decoration: underline; + } + .org-org-agenda-date { + /* org-agenda-date */ + color: #0000ff; + } + .org-org-agenda-date-weekend { + /* org-agenda-date-weekend */ + color: #0000ff; + font-weight: bold; + } + .org-org-agenda-restriction-lock { + /* org-agenda-restriction-lock */ + background-color: #ffff00; + } + .org-org-agenda-structure { + /* org-agenda-structure */ + color: #0000ff; + } + .org-org-archived { + /* org-archived */ + color: #7f7f7f; + } + .org-org-code { + /* org-code */ + color: #7f7f7f; + } + .org-org-column { + /* org-column */ + background-color: #e5e5e5; + } + .org-org-column-title { + /* org-column-title */ + background-color: #e5e5e5; + font-weight: bold; + text-decoration: underline; + } + .org-org-date { + /* org-date */ + color: #a020f0; + text-decoration: underline; + } + .org-org-done { + /* org-done */ + color: #228b22; + font-weight: bold; + } + .org-org-drawer { + /* org-drawer */ + color: #0000ff; + } + .org-org-ellipsis { + /* org-ellipsis */ + color: #b8860b; + text-decoration: underline; + } + .org-org-formula { + /* org-formula */ + color: #b22222; + } + .org-org-headline-done { + /* org-headline-done */ + color: #bc8f8f; + } + .org-org-hide { + /* org-hide */ + color: #e5e5e5; + } + .org-org-latex-and-export-specials { + /* org-latex-and-export-specials */ + color: #8b4513; + } + .org-org-level-1 { + /* org-level-1 */ + color: #0000ff; + } + .org-org-level-2 { + /* org-level-2 */ + color: #b8860b; + } + .org-org-level-3 { + /* org-level-3 */ + color: #a020f0; + } + .org-org-level-4 { + /* org-level-4 */ + color: #b22222; + } + .org-org-level-5 { + /* org-level-5 */ + color: #228b22; + } + .org-org-level-6 { + /* org-level-6 */ + color: #5f9ea0; + } + .org-org-level-7 { + /* org-level-7 */ + color: #da70d6; + } + .org-org-level-8 { + /* org-level-8 */ + color: #bc8f8f; + } + .org-org-link { + /* org-link */ + color: #a020f0; + text-decoration: underline; + } + .org-org-property-value { + } + .org-org-scheduled-previously { + /* org-scheduled-previously */ + color: #b22222; + } + .org-org-scheduled-today { + /* org-scheduled-today */ + color: #006400; + } + .org-org-sexp-date { + /* org-sexp-date */ + color: #a020f0; + } + .org-org-special-keyword { + /* org-special-keyword */ + color: #bc8f8f; + } + .org-org-table { + /* org-table */ + color: #0000ff; + } + .org-org-tag { + /* org-tag */ + font-weight: bold; + } + .org-org-target { + /* org-target */ + text-decoration: underline; + } + .org-org-time-grid { + /* org-time-grid */ + color: #b8860b; + } + .org-org-todo { + /* org-todo */ + color: #ff0000; + } + .org-org-upcoming-deadline { + /* org-upcoming-deadline */ + color: #b22222; + } + .org-org-verbatim { + /* org-verbatim */ + color: #7f7f7f; + text-decoration: underline; + } + .org-org-warning { + /* org-warning */ + color: #ff0000; + font-weight: bold; + } + .org-outline-1 { + /* outline-1 */ + color: #0000ff; + } + .org-outline-2 { + /* outline-2 */ + color: #b8860b; + } + .org-outline-3 { + /* outline-3 */ + color: #a020f0; + } + .org-outline-4 { + /* outline-4 */ + color: #b22222; + } + .org-outline-5 { + /* outline-5 */ + color: #228b22; + } + .org-outline-6 { + /* outline-6 */ + color: #5f9ea0; + } + .org-outline-7 { + /* outline-7 */ + color: #da70d6; + } + .org-outline-8 { + /* outline-8 */ + color: #bc8f8f; + } + .outline-text-1, .outline-text-2, .outline-text-3, .outline-text-4, .outline-text-5, .outline-text-6 { + /* Add more spacing between section. Padding, so that folding with org-info.js works as expected. */ + + } + + .org-preprocessor { + /* font-lock-preprocessor-face */ + color: #da70d6; + } + .org-query-replace { + /* query-replace */ + color: #b0e2ff; + background-color: #cd00cd; + } + .org-regexp-grouping-backslash { + /* font-lock-regexp-grouping-backslash */ + font-weight: bold; + } + .org-regexp-grouping-construct { + /* font-lock-regexp-grouping-construct */ + font-weight: bold; + } + .org-region { + /* region */ + background-color: #eedc82; + } + .org-rmail-highlight { + } + .org-scroll-bar { + /* scroll-bar */ + background-color: #bfbfbf; + } + .org-secondary-selection { + /* secondary-selection */ + background-color: #ffff00; + } + .org-shadow { + /* shadow */ + color: #7f7f7f; + } + .org-show-paren-match { + /* show-paren-match */ + background-color: #40e0d0; + } + .org-show-paren-mismatch { + /* show-paren-mismatch */ + color: #ffffff; + background-color: #a020f0; + } + .org-string { + /* font-lock-string-face */ + color: #bc8f8f; + } + .org-texinfo-heading { + /* texinfo-heading */ + color: #0000ff; + } + .org-tool-bar { + /* tool-bar */ + color: #000000; + background-color: #bfbfbf; + } + .org-tooltip { + /* tooltip */ + color: #000000; + background-color: #ffffe0; + } + .org-trailing-whitespace { + /* trailing-whitespace */ + background-color: #ff0000; + } + .org-type { + /* font-lock-type-face */ + color: #228b22; + } + .org-underline { + /* underline */ + text-decoration: underline; + } + .org-variable-name { + /* font-lock-variable-name-face */ + color: #b8860b; + } + .org-variable-pitch { + } + .org-vertical-border { + } + .org-warning { + /* font-lock-warning-face */ + color: #ff0000; + font-weight: bold; + } + .rss_box {} + .rss_title, rss_title a {} + .rss_items {} + .rss_item a:link, .rss_item a:visited, .rss_item a:active {} + .rss_item a:hover {} + .rss_date {} + + pre.src { + position: static; + overflow: visible; + padding-top: 1.2em; + } + + label.org-src-name { + font-size: 80%; + font-style: italic; + } + + #show_source {margin: 0; padding: 0;} + + #postamble { + font-size: 75%; + min-width: 700px; + max-width: 80%; + line-height: 14pt; + margin-left: 20px; + margin-top: 10px; + padding: .2em; + background-color: #ffffff; + z-index: -1000; + } + + +} /* END OF @media all */ + +@media screen +{ + #table-of-contents { + position: fixed; + margin-top: 105px; + float: right; + border: 1px solid #red; + max-width: 50%; + overflow: auto; + } +} /* END OF @media screen */ diff --git a/docs/theme.setup b/docs/theme.setup new file mode 100644 index 0000000..bbb2ba6 --- /dev/null +++ b/docs/theme.setup @@ -0,0 +1,16 @@ +# -*- mode: org; -*- + +#+HTML_LINK_HOME: index.html +#+OPTIONS: H:4 num:t toc:t \n:nil @:t ::t |:t ^:t -:t f:t *:t <:t d:(HIDE) + +# SETUPFILE: ../docs/org-html-themes/org/theme-readtheorg.setup + +#+INFOJS_OPT: toc:t mouse:underline path:org-info.js +#+HTML_HEAD: + +#+STARTUP: align fold nodlcheck hidestars oddeven lognotestate +#+AUTHOR: TREX CoE +#+LANGUAGE: en + + + diff --git a/include/.gitignore b/include/.gitignore new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/include/.gitignore @@ -0,0 +1 @@ + diff --git a/lib/.gitignore b/lib/.gitignore new file mode 100644 index 0000000..17eec9d --- /dev/null +++ b/lib/.gitignore @@ -0,0 +1,2 @@ +libqmckl.so +libqmckl.a diff --git a/man/.gitignore b/man/.gitignore new file mode 100644 index 0000000..e69de29 diff --git a/share/qmckl/fortran/.gitignore b/share/qmckl/fortran/.gitignore new file mode 100644 index 0000000..8f5f4da --- /dev/null +++ b/share/qmckl/fortran/.gitignore @@ -0,0 +1 @@ +qmckl_f.f90 diff --git a/src/Makefile b/src/Makefile index 7f78a9b..aabe343 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,66 +1,135 @@ +# Header :noexport: + + +# This file was created by tools/Building.org + +.POSIX: + +# Dependencies + + +LIBS=-lpthread + +# Variables + + +QMCKL_ROOT=$(shell dirname $(CURDIR)) + +shared_lib=$(QMCKL_ROOT)/lib/libqmckl.so +static_lib=$(QMCKL_ROOT)/lib/libqmckl.a +qmckl_h=$(QMCKL_ROOT)/include/qmckl.h +qmckl_f=$(QMCKL_ROOT)/share/qmckl/fortran/qmckl_f.f90 + +export CC CFLAGS FC FFLAGS LIBS QMCKL_ROOT + +ORG_SOURCE_FILES=$(wildcard *.org) +C_SOURCE_FILES=$(patsubst %.org,%.c,$(ORG_SOURCE_FILES)) +INCLUDE=-I$(QMCKL_ROOT)/include/ + +# Compiler options + +# GNU, Intel and LLVM compilers are supported. Choose here: + + COMPILER=GNU #COMPILER=INTEL #COMPILER=LLVM +# GNU + + ifeq ($(COMPILER),GNU) +#---------------------------------------------------------- CC=gcc -g -CFLAGS=-fPIC -fexceptions -Wall -Werror -Wpedantic -Wextra +CFLAGS=-fPIC $(INCLUDE) \ + -fexceptions -Wall -Werror -Wpedantic -Wextra -fmax-errors=3 FC=gfortran -g -FFLAGS=-fPIC -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant -Wuninitialized -fbacktrace -ffpe-trap=zero,overflow,underflow -finit-real=nan +FFLAGS=-fPIC $(INCLUDE) \ + -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising \ + -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation \ + -Wreal-q-constant -Wuninitialized -fbacktrace -finit-real=nan \ + -ffpe-trap=zero,overflow,underflow -LIBS=-lgfortran -lm +LIBS+=-lgfortran -lm +#---------------------------------------------------------- endif +# Intel + + ifeq ($(COMPILER),INTEL) +#---------------------------------------------------------- CC=icc -xHost -CFLAGS=-fPIC -g -O2 +CFLAGS=-fPIC -g -O2 $(INCLUDE) FC=ifort -xHost -FFLAGS=-fPIC -g -O2 +FFLAGS=-fPIC -g -O2 $(INCLUDE) -LIBS=-lm -lifcore -lirc +LIBS+=-lm -lifcore -lirc +#---------------------------------------------------------- +CC=icc -xHost endif -#TODO +# LLVM + + ifeq ($(COMPILER),LLVM) +#---------------------------------------------------------- CC=clang -CFLAGS=-fPIC -g -O2 +CFLAGS=-fPIC -g -O2 $(INCLUDE) FC=flang -FFLAGS=fPIC -g -O2 +FFLAGS=fPIC -g -O2 $(INCLUDE) -LIBS=-lm +LIBS+=-lm +#---------------------------------------------------------- endif +# Rules -export CC CFLAGS FC FFLAGS LIBS +# The source files are created during the generation of the file ~Makefile.generated~. +# The Makefile.generated is the one that will be distributed with the library. -MERGED_ORG=merged_qmckl.org -ORG_SOURCE_FILES=$(wildcard *.org) -OBJECT_FILES=$(filter-out $(EXCLUDED_OBJECTS), $(patsubst %.org,%.o,$(ORG_SOURCE_FILES))) -.PHONY: clean +.PHONY: clean shared static doc all check install uninstall syntax .SECONDARY: # Needed to keep the produced C and Fortran files -libqmckl.so: Makefile.generated - $(MAKE) -f Makefile.generated +$(shared_lib) $(static_lib) install uninstall: $(qmckl_h) $(qmckl_f) Makefile.generated + $(MAKE) -f Makefile.generated $@ -test: Makefile.generated - $(MAKE) -f Makefile.generated test +$(qmckl_f) $(qmckl_h): Makefile.generated + $(QMCKL_ROOT)/tools/build_qmckl_h.sh +shared: $(shared_lib) +static: $(static_lib) +all: shared static doc check + +check: $(static_lib) + $(MAKE) -f Makefile.generated check + +syntax: + cppcheck --addon=cert qmckl_*.c doc: $(ORG_SOURCE_FILES) - ./merge_org.sh - ./create_doc.sh $(MERGED_ORG) - rm $(MERGED_ORG) - + $(QMCKL_ROOT)/tools/build_doc.sh clean: - rm -f qmckl.h test_qmckl_* test_qmckl.c test_qmckl qmckl_*.f90 qmckl_*.c qmckl_*.o qmckl_*.h Makefile.generated libqmckl.so *.html *.fh *.mod + - $(MAKE) -f Makefile.generated clean + - $(RM) test_qmckl_* test_qmckl.c \ + $(qmckl_h) $(qmckl_f) \ + qmckl_*.f90 qmckl_*.c qmckl_*.h \ + Makefile.generated *.html *.txt -Makefile.generated: Makefile create_makefile.sh $(ORG_SOURCE_FILES) - ./merge_org.sh - ./create_makefile.sh $(MERGED_ORG) - rm $(MERGED_ORG) +veryclean: clean FORCE + - $(RM) $(QMCKL_ROOT)/docs/*.html \ + $(QMCKL_ROOT)/docs/*.txt +Makefile.generated: Makefile $(QMCKL_ROOT)/tools/create_makefile.sh $(ORG_SOURCE_FILES) + $(QMCKL_ROOT)/tools/create_makefile.sh + + +.SUFFIXES: .org .c + +.org.c: + $(QMCKL_ROOT)/tools/tangle.sh $< diff --git a/src/README.org b/src/README.org index abe0663..86e2908 100644 --- a/src/README.org +++ b/src/README.org @@ -1,207 +1,68 @@ #+TITLE: QMCkl source code documentation -#+EXPORT_FILE_NAME: index.html +#+PROPERTY: comments org +#+SETUPFILE: ../docs/theme.setup -#+SETUPFILE: https://fniessen.github.io/org-html-themes/setup/theme-readtheorg.setup +------------------ -* Introduction - The ultimate goal of QMCkl is to provide a high-performance + #+begin_comment + The .org files is included here in the order specified in the + table_of_contents file. + #+end_comment + + #+NAME: toc + #+begin_src sh :exports none +grep TITLE $(cat table_of_contents) | tr ':' ' ' + #+end_src + + #+RESULTS: toc + | qmckl.org | #+TITLE | Header | files | + | qmckl_error.org | #+TITLE | Error | handling | + | qmckl_context.org | #+TITLE | Context | | + | qmckl_precision.org | #+TITLE | Multi-precision | | + | qmckl_memory.org | #+TITLE | Memory | management | + | qmckl_distance.org | #+TITLE | Distances | | + | qmckl_ao.org | #+TITLE | Atomic | Orbitals | + | test_qmckl.org | #+TITLE | Testing | | + + #+begin_src python :var data=toc :exports results :results raw +result = [] +for row in data: + filename = row[0].split('.')[0] + ".html" + title = ' '.join(row[2:]).strip() + result += [ f" - [[./{filename}][{title}]]" ] +return '\n'.join(result) + #+end_src + + #+RESULTS: + - [[./qmckl.html][Introduction]] + - [[./qmckl_error.html][Error handling]] + - [[./qmckl_context.html][Context]] + - [[./qmckl_precision.html][Multi-precision]] + - [[./qmckl_memory.html][Memory management]] + - [[./qmckl_distance.html][Distances]] + - [[./qmckl_ao.html][Atomic Orbitals]] + - [[./test_qmckl.html][Testing]] + + +-------------------------------- + + + The ultimate goal of the QMCkl library is to provide a high-performance implementation of the main kernels of QMC. In this particular - repository, we focus on the definition of the API and the tests, and - on a /pedagogical/ presentation of the algorithms. We expect the - HPC experts to use this repository as a reference for re-writing - optimized libraries. + implementation of the library, we focus on the definition of the API + and the tests, and on a /pedagogical/ presentation of the + algorithms. We expect the HPC experts to use this repository as a + reference for re-writing optimized libraries. - Literate programming is particularly adapted in this context. - Source files are written in [[https://karl-voit.at/2017/09/23/orgmode-as-markup-only/][org-mode]] format, to provide useful - comments and LaTex formulas close to the code. There exists multiple - possibilities to convert org-mode files into different formats such - as HTML or pdf. For a tutorial on literate programming with - org-mode, follow [[http://www.howardism.org/Technical/Emacs/literate-programming-tutorial.html][this link]]. + The source code of the library is available at + https://github.com/trex-coe/qmckl + and bug reports should be submitted at + https://github.com/trex-coe/qmckl/issues. - The code is extracted from the org files using Emacs as a - command-line tool in the =Makefile=, and then the produced files are - compiled. +------------------ -** Language used - - Fortran is one of the most common languages used by the community, - and is simple enough to make the algorithms readable. Hence we - propose in this pedagogical implementation of QMCkl to use Fortran - to express the algorithms. For specific internal functions where - the C language is more natural, C is used. - - As Fortran modules generate compiler-dependent files, the use of - modules is restricted to the internal use of the library, otherwise - the compliance with C is violated. - - The external dependencies should be kept as small as possible, so - external libraries should be used /only/ if their used is strongly - justified. - -** Source code editing - - Any text editor can be used to edit org-mode files. For a better - user experience Emacs is recommended. For users hating Emacs, it - is good to know that Emacs can behave like Vim when switched into - ``Evil'' mode. There also exists [[https://www.spacemacs.org][Spacemacs]] which helps the - transition for Vim users. - - For users with a preference for Jupyter notebooks, the following - script can convert jupyter notebooks to org-mode files: - - #+BEGIN_SRC sh tangle: nb_to_org.sh -#!/bin/bash -# $ nb_to_org.sh notebook.ipynb -# produces the org-mode file notebook.org - -set -e - -nb=$(basename $1 .ipynb) -jupyter nbconvert --to markdown ${nb}.ipynb --output ${nb}.md -pandoc ${nb}.md -o ${nb}.org -rm ${nb}.md - #+END_SRC - - And pandoc can convert multiple markdown formats into org-mode. - -** Writing in Fortran - - The Fortran source files should provide a C interface using - =iso_c_binding=. The name of the Fortran source files should end - with =_f.f90= to be properly handled by the Makefile. The names of - the functions defined in fortran should be the same as those - exposed in the API suffixed by =_f=. Fortran interface files - should also be written in the =qmckl_f.f90= file. - - For more guidelines on using Fortran to generate a C interface, see - [[http://fortranwiki.org/fortran/show/Generating+C+Interfaces][this link]]. - -** Coding style - # TODO: decide on a coding style - - To improve readability, we maintain a consistent coding style in - the library. - - - For C source files, we will use __(decide on a coding style)__ - - For Fortran source files, we will use __(decide on a coding - style)__ - - Coding style can be automatically checked with [[https://clang.llvm.org/docs/ClangFormat.html][clang-format]]. - -** Design of the library - - The proposed API should allow the library to: - - deal with memory transfers between CPU and accelerators - - use different levels of floating-point precision - - We chose a multi-layered design with low-level and high-level - functions (see below). - -*** Naming conventions - - Use =qmckl_= as a prefix for all exported functions and variables. - All exported header files should have a filename with the prefix - =qmckl_=. - - If the name of the org-mode file is =xxx.org=, the name of the - produced C files should be =xxx.c= and =xxx.h= and the name of the - produced Fortran files should be =xxx.f90= - - Arrays are in uppercase and scalars are in lowercase. - - In the names of the variables and functions, only the singular - form is allowed. - -*** Application programming interface - - The application programming interface (API) is designed to be - compatible with the C programming language (not C++), to ensure - that the library will be easily usable in /any/ language. This - implies that only the following data types are allowed in the API: - - - 32-bit and 64-bit floats and arrays (=real= and =double=) - - 32-bit and 64-bit integers and arrays (=int32_t= and =int64_t=) - - Pointers should be represented as 64-bit integers (even on - 32-bit architectures) - - ASCII strings are represented as a pointers to a character - arrays and terminated by a zero character (C convention). - - Complex numbers can be represented by an array of 2 floats. - - # TODO : Link to repositories for bindings - To facilitate the use in other languages than C, we provide some - bindings in other languages in other repositories. - -*** Global state - - Global variables should be avoided in the library, because it is - possible that one single program needs to use multiple instances - of the library. To solve this problem we propose to use a pointer - to a =context= variable, built by the library with the - =qmckl_context_create= function. The =context= contains the global - state of the library, and is used as the first argument of many - QMCkl functions. - - The internal structure of the context is not specified, to give a - maximum of freedom to the different implementations. Modifying - the state is done by setters and getters, prefixed by - =qmckl_context_set_= an =qmckl_context_get_=. When a context - variable is modified by a setter, a copy of the old data structure - is made and updated, and the pointer to the new data structure is - returned, such that the old contexts can still be accessed. It is - also possible to modify the state in an impure fashion, using the - =qmckl_context_update_= functions. The context and its old - versions can be destroyed with =qmckl_context_destroy=. - -*** Low-level functions - - Low-level functions are very simple functions which are leaves of - the function call tree (they don't call any other QMCkl function). - - These functions are /pure/, and unaware of the QMCkl - =context=. They are not allowed to allocate/deallocate memory, and - if they need temporary memory it should be provided in input. - -*** High-level functions - - High-level functions are at the top of the function call tree. - They are able to choose which lower-level function to call - depending on the required precision, and do the corresponding type - conversions. These functions are also responsible for allocating - temporary storage, to simplify the use of accelerators. - - The high-level functions should be pure, unless the introduction - of non-purity is justified. All the side effects should be made in - the =context= variable. - - # TODO : We need an identifier for impure functions - -*** Numerical precision - - The number of bits of precision required for a function should be - given as an input of low-level computational functions. This input - will be used to define the values of the different thresholds that - might be used to avoid computing unnecessary noise. High-level - functions will use the precision specified in the =context= - variable. - -** Algorithms - - Reducing the scaling of an algorithm usually implies also reducing - its arithmetic complexity (number of flops per byte). Therefore, - for small sizes \(\mathcal{O}(N^3)\) and \(\mathcal{O}(N^2)\) - algorithms are better adapted than linear scaling algorithms. As - QMCkl is a general purpose library, multiple algorithms should be - implemented adapted to different problem sizes. - -** Rules for the API - - - =stdint= should be used for integers (=int32_t=, =int64_t=) - - integers used for counting should always be =int64_t= - - floats should be by default =double=, unless explicitly mentioned - - pointers are converted to =int64_t= to increase portability - -* Documentation + [[https://trex-coe.eu/sites/default/files/inline-images/euflag.jpg]] [[https://trex-coe.eu][TREX: Targeting Real Chemical Accuracy at the Exascale]] project has received funding from the European Union’s Horizon 2020 - Research and Innovation program - under grant agreement no. 952165. The content of this document does not represent the opinion of the European Union, and the European Union is not responsible for any use that might be made of such content. +# -*- mode: org -*- diff --git a/src/create_doc.sh b/src/create_doc.sh deleted file mode 100755 index 39327c8..0000000 --- a/src/create_doc.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash -INPUT=$1 - -if [[ -f ../docs/htmlize.el ]] -then - emacs --batch --load ../docs/htmlize.el --load ../docs/config.el $INPUT -f org-html-export-to-html -else - emacs --batch --load ../docs/config.el $INPUT -f org-html-export-to-html -fi - -mv index.html ../docs - - diff --git a/src/create_makefile.sh b/src/create_makefile.sh deleted file mode 100755 index ee8168f..0000000 --- a/src/create_makefile.sh +++ /dev/null @@ -1,95 +0,0 @@ -#!/bin/bash - -INPUT=$1 -OUTPUT=Makefile.generated - -# Tangle org files -emacs \ - $INPUT \ - --batch \ - -f org-babel-tangle \ - --kill - - - -# Create the list of *.o files to be created - -OBJECTS="" -for i in $(ls qmckl_*.c) ; do - FILE=${i%.c} - OBJECTS="${OBJECTS} ${FILE}.o" -done >> $OUTPUT - -for i in $(ls qmckl_*.f90) ; do - FILE=${i%.f90} - OBJECTS="${OBJECTS} ${FILE}.o" -done >> $OUTPUT - -TESTS="" -for i in $(ls test_qmckl_*.c) ; do - FILE=${i%.c}.o - TESTS="${TESTS} ${FILE}" -done >> $OUTPUT - -TESTS_F="" -for i in $(ls test_qmckl_*.f90) ; do - FILE=${i%.f90}.o - TESTS_F="${TESTS_F} ${FILE}" -done >> $OUTPUT - - -# Write the Makefile - -cat << EOF > $OUTPUT -CC=$CC -CFLAGS=$CFLAGS -I../munit/ - -FC=$FC -FFLAGS=$FFLAGS -OBJECT_FILES=$OBJECTS -TESTS=$TESTS -TESTS_F=$TESTS_F - -LIBS=$LIBS - -libqmckl.so: \$(OBJECT_FILES) - \$(CC) -shared \$(OBJECT_FILES) -o libqmckl.so - -%.o: %.c - \$(CC) \$(CFLAGS) -c \$*.c -o \$*.o - -%.o: %.f90 qmckl_f.o - \$(FC) \$(FFLAGS) -c \$*.f90 -o \$*.o - -test_qmckl: test_qmckl.c libqmckl.so \$(TESTS) \$(TESTS_F) - \$(CC) \$(CFLAGS) -Wl,-rpath,$PWD -L. \ - ../munit/munit.c \$(TESTS) \$(TESTS_F) -lqmckl \$(LIBS) test_qmckl.c -o test_qmckl - -test: test_qmckl - ./test_qmckl - -.PHONY: test -EOF - -for i in $(ls qmckl_*.c) ; do - FILE=${i%.c} - echo "${FILE}.o: ${FILE}.c " *.h -done >> $OUTPUT - -for i in $(ls qmckl_*.f90) ; do - FILE=${i%.f90} - echo "${FILE}.o: ${FILE}.f90" -done >> $OUTPUT - -for i in $(ls test_qmckl_*.c) ; do - FILE=${i%.c} - echo "${FILE}.o: ${FILE}.c qmckl.h" -done >> $OUTPUT - - -for i in $(ls test_qmckl*.f90) ; do - FILE=${i%.f90} - echo "${FILE}.o: ${FILE}.f90" -done >> $OUTPUT - - diff --git a/src/hpc/qmckl_tile.org b/src/hpc/qmckl_tile.org new file mode 100644 index 0000000..6c88fe7 --- /dev/null +++ b/src/hpc/qmckl_tile.org @@ -0,0 +1,521 @@ +#+TITLE: Tiled arrays +#+SETUPFILE: ../docs/theme.setup + +To increase performance, matrices may be stored as tiled +arrays. Instead of storing a matrix in a two-dimensional array, it may +be stored as a two dimensional array of small matrices (a rank 4 +tensor). This improves the locality of the data in matrix +multiplications, and also enables the possibility to use BLAS3 +while also exploiting part of the sparse structure of the matrices. + + Tile + │ ┌──────┬──────┬──────┐ + │ │1 4 7 │ │ │ + └───────►│2 5 8 │ T_12 │ T_13 │ + │3 6 9 │ │ │ + ├──────┼──────┼──────┤ + │ │ │ │ + │ T_21 │ T_22 │ T_23 │ + │ │ │ │ + ├──────┼──────┼──────┤ + │ │ │ │ + │ T_31 │ T_32 │ T_33 │ + │ │ │ │ + └──────┴──────┴──────┘ + + In this file, tiled matrice will be produced for the following + types: + + #+NAME: types + | float | + | double | + +* Headers :noexport: + + #+NAME: filename + #+begin_src elisp :tangle no +(file-name-nondirectory (substring buffer-file-name 0 -4)) + #+end_src + + #+begin_src c :tangle (eval h_private_type) +#ifndef QMCKL_TILE_HPT +#define QMCKL_TILE_HPT + #+end_src + + #+begin_src c :tangle (eval c_test) :noweb yes +#include "qmckl.h" +#include "munit.h" +MunitResult test_<>() { + qmckl_context context; + context = qmckl_context_create(); + #+end_src + + #+begin_src c :tangle (eval c) +#include +#include +#include +#include +#include + +#include "qmckl_context_type.h" +#include "qmckl_error_type.h" +#include "qmckl_memory_private_type.h" +#include "qmckl_tile_private_type.h" + +#include "qmckl_context_func.h" +#include "qmckl_error_func.h" +#include "qmckl_memory_private_func.h" +#include "qmckl_tile_private_func.h" + #+end_src + +* Data structures + +** Tile + + A tile is a small matrix of fixed size. The dimensions of the + tiles is fixed at compile-time to increase performance. It is + defined as $2^s$: + + | s | tile size | + |---+-----------| + | 2 | 4 | + | 3 | 8 | + | 4 | 16 | + | 5 | 32 | + | 6 | 64 | + | 7 | 128 | + + + #+begin_src c :tangle (eval h_private_type) +#define TILE_SIZE_SHIFT 3 +#define TILE_SIZE 8 +#define VEC_SIZE 8 + #+end_src + + + #+NAME: tile_hpt + #+begin_src c +typedef struct $T$_tile_struct { + $T$ element[TILE_SIZE][TILE_SIZE]; + int64_t is_null; + int64_t padding[VEC_SIZE-1]; +} $T$_tile_struct; + #+end_src + +** Tiled matrix + + A tiled matrix is a two-dimensional array of tiles. + + #+NAME: matrix_hpt + #+begin_src c +typedef struct $T$_tiled_matrix { + $T$_tile_struct** tile; + size_t n_row; + size_t n_col; + size_t n_tile_row; + size_t n_tile_col; +} $T$_tiled_matrix; + #+end_src + + When a tiled matrix is initialized, it is set to zero. + + #+NAME: init_hpf + #+begin_src c +qmckl_exit_code $T$_tiled_matrix_init (qmckl_context context, + $T$_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col); + #+end_src + + #+NAME: init_c + #+begin_src c +qmckl_exit_code $T$_tiled_matrix_init (qmckl_context context, + $T$_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { +} $T$_tiled_matrix; + #+end_src + + When a tiled matrix is initialized, it is set to zero. + + #+NAME: init_hpf + #+begin_src c +qmckl_exit_code $T$_tiled_matrix_init (qmckl_context context, + $T$_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col); + #+end_src + + #+NAME: init_c + #+begin_src c +qmckl_exit_code $T$_tiled_matrix_init (qmckl_context context, + $T$_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return QMCKL_INVALID_CONTEXT; + } + + if (m == NULL) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "$T$_tiled_matrix_init", + NULL); + } + + if (n_tile_row == (size_t) 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_3, + "$T$_tiled_matrix_init", + NULL); + } + + if (n_tile_col == (size_t) 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_4, + "$T$_tiled_matrix_init", + NULL); + } + + qmckl_memory_info_struct info = qmckl_memory_info_struct_zero; + size_t n = n_tile_row * n_tile_col; + + /* Check overflow */ + if (n/n_tile_col != n_tile_row + || n > SIZE_MAX / sizeof($T$_tile_struct) ) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "$T$_tiled_matrix_init", + "n_tile_row * n_tile_col overflows" ); + } + + /* Allocate array of column pointers */ + info.size = n_tile_col * sizeof($T$_tile_struct*) ; + m->tile = ($T$_tile_struct**) qmckl_malloc(context, info); + + if (m->tile == NULL) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "$T$_tiled_matrix_init", + NULL); + } + + + /* Allocate array of tiles */ + info.size = n * sizeof($T$_tile_struct) ; + m->tile[0] = ($T$_tile_struct*) qmckl_malloc(context, info); + + if (m->tile[0] == NULL) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "$T$_tiled_matrix_init", + NULL); + } + + /* Compute array of pointers to the 1st element of columns */ + for (size_t i=1 ; itile[i] = m->tile[i-1] + n_tile_row; + } + + m->n_tile_row = n_tile_row; + m->n_tile_col = n_tile_col; + return QMCKL_SUCCESS; +} + + + #+end_src + +* Write templates + + #+begin_src python :noweb yes :results drawer :var types=types :exports results +def generate(f, text): + result = [ f"#+begin_src c :tangle (eval {f})" ] + for t in types: + t=t[0] + result += [ text.replace("$T$",t), "" ] + + result += [ "#+end_src" ] + return '\n'.join(result) + +return '\n'.join( [ "" + +, generate("h_private_type", """ +<> + +<> +""") + +, "" + +, generate("h_private_func", """ +<> +""") + +, "" + +, generate("c", """ +<> +""") + +] ) + #+end_src + + #+RESULTS: + :results: + + #+begin_src c :tangle (eval h_private_type) + + typedef struct float_tile_struct { + float element[TILE_SIZE][TILE_SIZE]; + int32_t is_null; + int32_t padding; + } float_tile_struct; + + typedef struct float_tiled_matrix { + float_tile_struct** tile; + size_t n_tile_row; + size_t n_tile_col; + } float_tiled_matrix; + + + + typedef struct double_tile_struct { + double element[TILE_SIZE][TILE_SIZE]; + int32_t is_null; + int32_t padding; + } double_tile_struct; + + typedef struct double_tiled_matrix { + double_tile_struct** tile; + size_t n_tile_row; + size_t n_tile_col; + } double_tiled_matrix; + + + #+end_src + + #+begin_src c :tangle (eval h_private_func) + + qmckl_exit_code float_tiled_matrix_init (qmckl_context context, + float_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col); + + + + qmckl_exit_code double_tiled_matrix_init (qmckl_context context, + double_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col); + + + #+end_src + + #+begin_src c :tangle (eval c) + + qmckl_exit_code float_tiled_matrix_init (qmckl_context context, + float_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return QMCKL_INVALID_CONTEXT; + } + + if (m == NULL) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "float_tiled_matrix_init", + NULL); + } + + if (n_tile_row == (size_t) 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_3, + "float_tiled_matrix_init", + NULL); + } + + if (n_tile_col == (size_t) 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_4, + "float_tiled_matrix_init", + NULL); + } + + qmckl_memory_info_struct info = qmckl_memory_info_struct_zero; + size_t n = n_tile_row * n_tile_col; + + /* Check overflow */ + if (n/n_tile_col != n_tile_row + || n > SIZE_MAX / sizeof(float_tile_struct) ) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "float_tiled_matrix_init", + "n_tile_row * n_tile_col overflows" ); + } + + /* Allocate array of column pointers */ + info.size = n_tile_col * sizeof(float_tile_struct*) ; + m->tile = (float_tile_struct**) qmckl_malloc(context, info); + + if (m->tile == NULL) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "float_tiled_matrix_init", + NULL); + } + + + /* Allocate array of tiles */ + info.size = n * sizeof(float_tile_struct) ; + m->tile[0] = (float_tile_struct*) qmckl_malloc(context, info); + + if (m->tile[0] == NULL) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "float_tiled_matrix_init", + NULL); + } + + /* Compute array of pointers to the 1st element of columns */ + for (size_t i=1 ; itile[i] = m->tile[i-1] + n_tile_row; + } + + m->n_tile_row = n_tile_row; + m->n_tile_col = n_tile_col; + return QMCKL_SUCCESS; + } + + + + + qmckl_exit_code double_tiled_matrix_init (qmckl_context context, + double_tiled_matrix* m, + size_t n_tile_row, + size_t n_tile_col) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return QMCKL_INVALID_CONTEXT; + } + + if (m == NULL) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "double_tiled_matrix_init", + NULL); + } + + if (n_tile_row == (size_t) 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_3, + "double_tiled_matrix_init", + NULL); + } + + if (n_tile_col == (size_t) 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_4, + "double_tiled_matrix_init", + NULL); + } + + qmckl_memory_info_struct info = qmckl_memory_info_struct_zero; + size_t n = n_tile_row * n_tile_col; + + /* Check overflow */ + if (n/n_tile_col != n_tile_row + || n > SIZE_MAX / sizeof(double_tile_struct) ) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "double_tiled_matrix_init", + "n_tile_row * n_tile_col overflows" ); + } + + /* Allocate array of column pointers */ + info.size = n_tile_col * sizeof(double_tile_struct*) ; + m->tile = (double_tile_struct**) qmckl_malloc(context, info); + + if (m->tile == NULL) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "double_tiled_matrix_init", + NULL); + } + + + /* Allocate array of tiles */ + info.size = n * sizeof(double_tile_struct) ; + m->tile[0] = (double_tile_struct*) qmckl_malloc(context, info); + + if (m->tile[0] == NULL) { + return qmckl_failwith(context, + QMCKL_ALLOCATION_FAILED, + "double_tiled_matrix_init", + NULL); + } + + /* Compute array of pointers to the 1st element of columns */ + for (size_t i=1 ; itile[i] = m->tile[i-1] + n_tile_row; + } + + m->n_tile_row = n_tile_row; + m->n_tile_col = n_tile_col; + return QMCKL_SUCCESS; + } + + + + #+end_src + :end: + +* End of files :noexport: + + #+begin_src c :tangle (eval h_private_type) +#endif + #+end_src + +*** Test + #+begin_src c :tangle (eval c_test) + if (qmckl_context_destroy(context) != QMCKL_SUCCESS) + return QMCKL_FAILURE; + return MUNIT_OK; +} + #+end_src + +**✸ Compute file names + #+begin_src emacs-lisp +; The following is required to compute the file names + +(setq pwd (file-name-directory buffer-file-name)) +(setq name (file-name-nondirectory (substring buffer-file-name 0 -4))) +(setq f (concat pwd name "_f.f90")) +(setq fh (concat pwd name "_fh.f90")) +(setq c (concat pwd name ".c")) +(setq h (concat name ".h")) +(setq h_private (concat name "_private.h")) +(setq c_test (concat pwd "test_" name ".c")) +(setq f_test (concat pwd "test_" name "_f.f90")) + +; Minted +(require 'ox-latex) +(setq org-latex-listings 'minted) +(add-to-list 'org-latex-packages-alist '("" "listings")) +(add-to-list 'org-latex-packages-alist '("" "color")) + + #+end_src + + #+RESULTS: + | | color | + | | listings | + + +# -*- mode: org -*- +# vim: syntax=c + + diff --git a/src/merge_org.sh b/src/merge_org.sh deleted file mode 100755 index b4b2101..0000000 --- a/src/merge_org.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/bash - -for i in README.org \ - qmckl.org \ - qmckl_memory.org \ - qmckl_context.org \ - qmckl_distance.org \ - qmckl_ao.org \ - qmckl_footer.org \ - test_qmckl.org -do - cat $i >> merged_qmckl.org -done diff --git a/src/qmckl.org b/src/qmckl.org index ce5a3ce..b72d451 100644 --- a/src/qmckl.org +++ b/src/qmckl.org @@ -1,64 +1,266 @@ -** =qmckl.h= header file +#+TITLE: Introduction +#+PROPERTY: comments org +#+SETUPFILE: ../docs/theme.setup +# -*- mode: org -*- - This file produces the =qmckl.h= header file, which is to be included - when qmckl functions are used. +* Using QMCkl - We also create here the =qmckl_f.f90= which is the Fortran interface file. +The =qmckl.h= header file installed in the =${prefix}/include= directory +has to be included in C codes when QMCkl functions are used: -*** Top of header files :noexport: - - #+BEGIN_SRC C :tangle qmckl.h -#ifndef QMCKL_H -#define QMCKL_H -#include -#include -#include - #+END_SRC +#+begin_src c :tangle no +#include "qmckl.h" +#+end_src - #+BEGIN_SRC f90 :tangle qmckl_f.f90 -module qmckl - use, intrinsic :: iso_c_binding - #+END_SRC +In Fortran programs, the =qmckl_f.f90= installed in +=${prefix}/share/qmckl/fortran= interface file should be copied in the source +code using the library, and the Fortran codes should use the ~qmckl~ module as - The bottoms of the files are located in the [[qmckl_footer.org]] file. - -*** Constants +#+begin_src f90 :tangle no +use qmckl +#+end_src -**** Success/failure +Both files are located in the =include/= directory. - These are the codes returned by the functions to indicate success - or failure. All such functions should have as a return type =qmckl_exit_code=. +* Developing in QMCkl - #+BEGIN_SRC C :comments org :tangle qmckl.h -#define QMCKL_SUCCESS 0 -#define QMCKL_FAILURE 1 +** Literate programming -typedef int32_t qmckl_exit_code; -typedef int64_t qmckl_context ; + In a traditional source code, most of the lines of source files of a program + are code, scripts, Makefiles, and only a few lines are comments explaining + parts of the code that are non-trivial to understand. The documentation of + the prorgam is usually written in a separate directory, and is often outdated + compared to the code. - #+END_SRC + Literate programming is a different approach to programming, + where the program is considered as a publishable-quality document. Most of + the lines of the source files are text, mathematical formulas, tables, + figures, /etc/, and the lines of code are just the translation in a computer + language of the ideas and algorithms expressed in the text. More importantly, + the "document" is structured like a text document with sections, subsections, + a bibliography, a table of contents /etc/, and the place where pieces of code + appear are the places where they should belong for the reader to understand + the logic of the program, not the places where the compiler expects to find + them. Both the publishable-quality document and the binary executable are + produced from the same source files. - #+BEGIN_SRC f90 :comments org :tangle qmckl_f.f90 -integer, parameter :: QMCKL_SUCCESS = 0 -integer, parameter :: QMCKL_FAILURE = 0 - #+END_SRC + Literate programming is particularly well adapted in this context, as the + central part of this project is the documentation of an API. The + implementation of the algorithms is just an expression of the algorithms in a + language that can be compiled, so that the correctness of the algorithms can + be tested. -**** Precision-related constants + We have chosen to write the source files in [[https://karl-voit.at/2017/09/23/orgmode-as-markup-only/][org-mode]] format, + as any text editor can be used to edit org-mode files. To + produce the documentation, there exists multiple possibilities to convert + org-mode files into different formats such as HTML or PDF. The source code is + easily extracted from the org-mode files invoking the Emacs text editor from + the command-line in the =Makefile=, and then the produced files are compiled. + Moreover, within the Emacs text editor the source code blocks can be executed + interactively, in the same spirit as Jupyter notebooks. - Controlling numerical precision enables optimizations. Here, the - default parameters determining the target numerical precision and - range are defined. +** Source code editing - #+BEGIN_SRC C :comments org :tangle qmckl.h -#define QMCKL_DEFAULT_PRECISION 53 -#define QMCKL_DEFAULT_RANGE 11 - #+END_SRC + For a tutorial on literate programming with org-mode, follow [[http://www.howardism.org/Technical/Emacs/literate-programming-tutorial.html][this link]]. - #+BEGIN_SRC f90 :comments org :tangle qmckl_f.f90 -integer, parameter :: QMCKL_DEFAULT_PRECISION = 53 -integer, parameter :: QMCKL_DEFAULT_RANGE = 11 - #+END_SRC - + Any text editor can be used to edit org-mode files. For a better + user experience Emacs is recommended. For users hating Emacs, it + is good to know that Emacs can behave like Vim when switched into + ``Evil'' mode. + + In the =tools/init.el= file, we provide a minimal Emacs configuration + file for vim users. This file should be copied into =.emacs.d/init.el=. + + For users with a preference for Jupyter notebooks, we also provide the + =tools/nb_to_org.sh= script can convert jupyter notebooks into org-mode + files. + + Note that pandoc can be used to convert multiple markdown formats into + org-mode. + +** Choice of the programming language + + Most of the codes of the [[https://trex-coe.eu][TREX CoE]] are written in Fortran with some scripts in + Bash and Python. Outside of the CoE, Fortran is also important (Casino, Amolqc), + and other important languages used by the community are C and C++ (QMCPack, + QWalk), and Julia is gaining in popularity. The library we design should be + compatible with all of these languages. The QMCkl API has to be compatible + with the C language since libraries with a C-compatible API can be used in + every other language. + + High-performance versions of the QMCkl, with the same API, will be rewritten by + the experts in HPC. These optimized libraries will be tuned for specific + architectures, among which we can cite x86 based processors, and GPU + accelerators. Nowadays, the most efficient software tools to take advantage of + low-level features of the processor (intrinsics) and of GPUs are for C++ + developers. It is highly probable that the optimized implementations will be + written in C++, and this is agreement with our choice to make the API + C-compatible. + + Fortran is one of the most common languages used by the community, and is simple + enough to make the algorithms readable both by experts in QMC, and experts in + HPC. Hence we propose in this pedagogical implementation of QMCkl to use Fortran + to express the QMC algorithms. As the main languages of the library is C, this + implies that the exposed C functions call the Fortran routine. However, for + internal functions related to system programming, the C language is more natural + than Fortran. + + The Fortran source files should provide a C interface using the + ~iso_c_binding~ module. The name of the Fortran source files should end with + =_f.f90= to be properly handled by the =Makefile=. The names of the functions + defined in Fortran should be the same as those exposed in the API suffixed by + =_f=. + + For more guidelines on using Fortran to generate a C interface, see + [[http://fortranwiki.org/fortran/show/Generating+C+Interfaces][this link]]. + +** Coding rules + + The authors should follow the recommendations of the C99 + [[https://wiki.sei.cmu.edu/confluence/display/c/SEI+CERT+C+Coding+Standard][SEI+CERT C Coding Standard]]. + + Compliance can be checked with =cppcheck= as: + + #+begin_src bash +cppcheck --addon=cert --enable=all *.c &> cppcheck.out + #+end_src + +** Design of the library + + The proposed API should allow the library to: deal with memory transfers + between CPU and accelerators, and to use different levels of floating-point + precision. We chose a multi-layered design with low-level and high-level + functions (see below). + +** Naming conventions + + To avoid namespace collisions, we use =qmckl_= as a prefix for all exported + functions and variables. All exported header files should have a file name + prefixed with =qmckl_=. + + If the name of the org-mode file is =xxx.org=, the name of the + produced C files should be =xxx.c= and =xxx.h= and the name of the + produced Fortran file should be =xxx.f90=. + + Arrays are in uppercase and scalars are in lowercase. + + In the names of the variables and functions, only the singular + form is allowed. + +** Application programming interface + + In the C language, the number of bits used by the integer types can change + from one architecture to another one. To circumvent this problem, we choose to + use the integer types defined in ~~ where the number of bits used for + the integers are fixed. + + To ensure that the library will be easily usable in /any/ other language + than C, we restrict the data types in the interfaces to the following: + - 32-bit and 64-bit integers, scalars and and arrays (~int32_t~ and ~int64_t~) + - 32-bit and 64-bit floats, scalars and and arrays (~float~ and ~double~) + - Pointers are always casted into 64-bit integers, even on legacy 32-bit architectures + - ASCII strings are represented as a pointers to character arrays + and terminated by a ~'\0'~ character (C convention). + - Complex numbers can be represented by an array of 2 floats. + - Boolean variables are stored as integers, ~1~ for ~true~ and ~0~ for ~false~ + - Floating point variables should be by default ~double~ unless explicitly mentioned + - integers used for counting should always be ~int64_t~ + + To facilitate the use in other languages than C, we will provide some + bindings in other languages in other repositories. + + # TODO : Link to repositories for bindings + # To facilitate the use in other languages than C, we provide some + # bindings in other languages in other repositories. + +** Global state + + Global variables should be avoided in the library, because it is + possible that one single program needs to use multiple instances + of the library. To solve this problem we propose to use a pointer + to a [[./qmckl_context.html][=context=]] variable, built by the library with the + =qmckl_context_create= function. The <<<=context=>>> contains the global + state of the library, and is used as the first argument of many + QMCkl functions. + + The internal structure of the context is not specified, to give a + maximum of freedom to the different implementations. Modifying + the state is done by setters and getters, prefixed by + =qmckl_set_= an =qmckl_get_=. + +** Headers + + A single =qmckl.h= header to be distributed by the library + is built by concatenating some of the produced header files. + To facilitate building the =qmckl.h= file, we separate types from + function declarations in headers. Types should be defined in header + files suffixed by =_type.h=, and functions in files suffixed by + =_func.h=. + As these files will be concatenated in a single file, they should + not be guarded by ~#ifndef *_H~, and they should not include other + produced headers. + + Some particular types that are not exported need to be known by the + context, and there are some functions to update instances of these + types contained inside the context. For example, a + ~qmckl_numprec_struct~ is present in the context, and the function + ~qmckl_set_numprec_range~ takes a context as a parameter, and set a + value in the ~qmckl_numprec_struct~ contained in the context. + Because of these intricate dependencies, a private header is + created, containing the ~qmckl_numprec_struct~. This header is + included in the private header which defines the type of the + context. Headers for private types are suffixed by =_private_type.h= + and headers for private functions, =_private_func.h=. + Fortran interfaces should also be written in the =*_f_func.f90= file, + and the types definitions should be written in the =*_f_type.f90= file. + + | File | Scope | Description | + |--------------------+---------+------------------------------| + | =*_type.h= | Public | Type definitions | + | =*_func.h= | Public | Function definitions | + | =*_private_type.h= | Private | Type definitions | + | =*_private_func.h= | Private | Function definitions | + | =*fh_type.f90= | Public | Fortran type definitions | + | =*fh_func.f90= | Public | Fortran function definitions | + +** Low-level functions + + Low-level functions are very simple functions which are leaves of + the function call tree (they don't call any other QMCkl function). + + These functions are /pure/, and unaware of the QMCkl + =context=. They are not allowed to allocate/deallocate memory, and + if they need temporary memory it should be provided in input. + +** High-level functions + + High-level functions are at the top of the function call tree. + They are able to choose which lower-level function to call + depending on the required precision, and do the corresponding type + conversions. These functions are also responsible for allocating + temporary storage, to simplify the use of accelerators. + + The high-level functions should be pure, unless the introduction + of non-purity is justified. All the side effects should be made in + the =context= variable. + + # TODO : We need an identifier for impure functions + +** Numerical precision + + The number of bits of precision required for a function should be + given as an input of low-level computational functions. This input + will be used to define the values of the different thresholds that + might be used to avoid computing unnecessary noise. High-level + functions will use the precision specified in the =context= + variable. + +** Algorithms + + Reducing the scaling of an algorithm usually implies also reducing + its arithmetic complexity (number of flops per byte). Therefore, + for small sizes \(\mathcal{O}(N^3)\) and \(\mathcal{O}(N^2)\) + algorithms are better adapted than linear scaling algorithms. As + QMCkl is a general purpose library, multiple algorithms should be + implemented adapted to different problem sizes. - # -*- mode: org -*- - # vim: syntax=c diff --git a/src/qmckl_ao.org b/src/qmckl_ao.org index f9095ab..2a6cb80 100644 --- a/src/qmckl_ao.org +++ b/src/qmckl_ao.org @@ -1,82 +1,924 @@ -** Atomic Orbitals +#+TITLE: Atomic Orbitals +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org + +The atomic basis set is defined as a list of shells. Each shell $s$ is +centered on a nucleus $A$, possesses a given angular momentum $l$ and a +radial function $R_s$. The radial function is a linear combination of +\emph{primitive} functions that can be of type Slater ($p=1$) or +Gaussian ($p=2$): + +\[ + R_s(\mathbf{r}) = \mathcal{N}_s |\mathbf{r}-\mathbf{R}_A|^{n_s} + \sum_{k=1}^{N_{\text{prim}}} a_{ks} + \exp \left( - \gamma_{ks} | \mathbf{r}-\mathbf{R}_A | ^p \right). +\] + +In the case of Gaussian functions, $n_s$ is always zero. +The normalization factor $\mathcal{N}_s$ ensures that all the functions +of the shell are normalized to unity. As this normalization requires +the ability to compute overlap integrals, it should be written in the +file to ensure that the file is self-contained and does not require +the client program to have the ability to compute such integrals. + +Atomic orbitals (AOs) are defined as + +\[ +\chi_i (\mathbf{r}) = P_{\eta(i)}(\mathbf{r})\, R_{\theta(i)} (\mathbf{r}) +\] + +where $\theta(i)$ returns the shell on which the AO is expanded, +and $\eta(i)$ denotes which angular function is chosen. + +In this section we describe the kernels used to compute the values, +gradients and Laplacian of the atomic basis functions. + +* Headers :noexport: + #+begin_src elisp :noexport :results none +(org-babel-lob-ingest "../tools/lib.org") +#+end_src - This files contains all the routines for the computation of the - values, gradients and Laplacian of the atomic basis functions. + #+begin_src c :tangle (eval h_private_type) +#ifndef QMCKL_AO_HPT +#define QMCKL_AO_HPT +#include + #+end_src - 3 files are produced: - - a source file : =qmckl_ao.f90= - - a C test file : =test_qmckl_ao.c= - - a Fortran test file : =test_qmckl_ao_f.f90= - -*** Test :noexport: - #+BEGIN_SRC C :tangle test_qmckl_ao.c + #+begin_src c :tangle (eval c_test) :noweb yes #include "qmckl.h" #include "munit.h" -MunitResult test_qmckl_ao() { +MunitResult test_<>() { qmckl_context context; context = qmckl_context_create(); - #+END_SRC + #+end_src -*** Polynomials + #+begin_src c :tangle (eval c) +#include +#include +#include +#include +#include - \[ - P_l(\mathbf{r},\mathbf{R}_i) = (x-X_i)^a (y-Y_i)^b (z-Z_i)^c - \] - \begin{eqnarray*} - \frac{\partial }{\partial x} P_l\left(\mathbf{r},\mathbf{R}_i \right) & - = & a (x-X_i)^{a-1} (y-Y_i)^b (z-Z_i)^c \\ - \frac{\partial }{\partial y} P_l\left(\mathbf{r},\mathbf{R}_i \right) & - = & b (x-X_i)^a (y-Y_i)^{b-1} (z-Z_i)^c \\ - \frac{\partial }{\partial z} P_l\left(\mathbf{r},\mathbf{R}_i \right) & - = & c (x-X_i)^a (y-Y_i)^b (z-Z_i)^{c-1} \\ - \end{eqnarray*} - \begin{eqnarray*} - \left( \frac{\partial }{\partial x^2} + - \frac{\partial }{\partial y^2} + - \frac{\partial }{\partial z^2} \right) P_l - \left(\mathbf{r},\mathbf{R}_i \right) & = & - a(a-1) (x-X_i)^{a-2} (y-Y_i)^b (z-Z_i)^c + \\ - && b(b-1) (x-X_i)^a (y-Y_i)^{b-1} (z-Z_i)^c + \\ - && c(c-1) (x-X_i)^a (y-Y_i)^b (z-Z_i)^{c-1} - \end{eqnarray*} +#include "qmckl_error_type.h" +#include "qmckl_context_type.h" +#include "qmckl_context_private_type.h" +#include "qmckl_memory_private_type.h" -**** =qmckl_ao_power= +#include "qmckl_error_func.h" +#include "qmckl_memory_private_func.h" +#include "qmckl_memory_func.h" +#include "qmckl_context_func.h" + #+end_src - Computes all the powers of the =n= input data up to the given - maximum value given in input for each of the $n$ points: +* Context + + The following arrays are stored in the context: + + | ~type~ | | Gaussian (~'G'~) or Slater (~'S'~) | + | ~shell_num~ | | Number of shells | + | ~prim_num~ | | Total number of primitives | + | ~shell_center~ | ~[shell_num]~ | Id of the nucleus on which each shell is centered | + | ~shell_ang_mom~ | ~[shell_num]~ | Angular momentum of each shell | + | ~shell_prim_num~ | ~[shell_num]~ | Number of primitives in each shell | + | ~shell_prim_index~ | ~[shell_num]~ | Address of the first primitive of each shell in the ~EXPONENT~ array | + | ~shell_factor~ | ~[shell_num]~ | Normalization factor for each shell | + | ~exponent~ | ~[prim_num]~ | Array of exponents | + | ~coefficient~ | ~[prim_num]~ | Array of coefficients | + + For H_2 with the following basis set, + + #+BEGIN_EXAMPLE +HYDROGEN +S 5 +1 3.387000E+01 6.068000E-03 +2 5.095000E+00 4.530800E-02 +3 1.159000E+00 2.028220E-01 +4 3.258000E-01 5.039030E-01 +5 1.027000E-01 3.834210E-01 +S 1 +1 3.258000E-01 1.000000E+00 +S 1 +1 1.027000E-01 1.000000E+00 +P 1 +1 1.407000E+00 1.000000E+00 +P 1 +1 3.880000E-01 1.000000E+00 +D 1 +1 1.057000E+00 1.0000000 + #+END_EXAMPLE + + we have: + + #+BEGIN_EXAMPLE +type = 'G' +shell_num = 12 +prim_num = 20 +shell_center = [1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2] +shell_ang_mom = ['S', 'S', 'S', 'P', 'P', 'D', 'S', 'S', 'S', 'P', 'P', 'D'] +shell_factor = [ 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1.] +shell_prim_num = [5, 1, 1, 1, 1, 1, 5, 1, 1, 1, 1, 1] +shell_prim_index = [1, 6, 7, 8, 9, 10, 11, 16, 17, 18, 19, 20] +exponent = [ 33.87, 5.095, 1.159, 0.3258, 0.1027, 0.3258, 0.1027, + 1.407, 0.388, 1.057, 33.87, 5.095, 1.159, 0.3258, 0.1027, + 0.3258, 0.1027, 1.407, 0.388, 1.057] +coefficient = [ 0.006068, 0.045308, 0.202822, 0.503903, 0.383421, + 1.0, 1.0, 1.0, 1.0, 1.0, 0.006068, 0.045308, 0.202822, + 0.503903, 0.383421, 1.0, 1.0, 1.0, 1.0, 1.0] + #+END_EXAMPLE + +** Data structure + + #+begin_src c :comments org :tangle (eval h_private_type) +typedef struct qmckl_ao_basis_struct { + int32_t uninitialized; + int64_t shell_num; + int64_t prim_num; + int64_t * shell_center; + char * shell_ang_mom; + int64_t * shell_prim_num; + int64_t * shell_prim_index; + double * shell_factor; + double * exponent ; + double * coefficient ; + bool provided; + char type; +} qmckl_ao_basis_struct; + #+end_src + + The ~uninitialized~ integer contains one bit set to one for each + initialization function which has not bee called. It becomes equal + to zero after all initialization functions have been called. The + struct is then initialized and ~provided == true~. - \[ P_{ij} = X_j^i \] +** Access functions + + #+begin_src c :comments org :tangle (eval h_private_func) :exports none +char qmckl_get_ao_basis_type (const qmckl_context context); +int64_t qmckl_get_ao_basis_shell_num (const qmckl_context context); +int64_t qmckl_get_ao_basis_prim_num (const qmckl_context context); +int64_t* qmckl_get_ao_basis_shell_center (const qmckl_context context); +char* qmckl_get_ao_basis_shell_ang_mom (const qmckl_context context); +int64_t* qmckl_get_ao_basis_shell_prim_num (const qmckl_context context); +int64_t* qmckl_get_ao_basis_shell_prim_index (const qmckl_context context); +double* qmckl_get_ao_basis_shell_factor (const qmckl_context context); +double* qmckl_get_ao_basis_exponent (const qmckl_context context); +double* qmckl_get_ao_basis_coefficient (const qmckl_context context); + #+end_src -***** Arguments + When all the data for the AOs have been provided, the following + function returns ~true~. - | =context= | input | Global state | - | =n= | input | Number of values | - | =X(n)= | input | Array containing the input values | - | =LMAX(n)= | input | Array containing the maximum power for each value | - | =P(LDP,n)= | output | Array containing all the powers of =X= | - | =LDP= | input | Leading dimension of array =P= | + #+begin_src c :comments org :tangle (eval h_func) +bool qmckl_ao_basis_provided (const qmckl_context context); + #+end_src + + #+NAME:post + #+begin_src c :exports none +if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; +} + #+end_src + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +char qmckl_get_ao_basis_type (const qmckl_context context) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (char) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return (char) 0; + } + + assert (ctx->ao_basis.type != (char) 0); + return ctx->ao_basis.type; +} + + +int64_t qmckl_get_ao_basis_shell_num (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (int64_t) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 1; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return (int64_t) 0; + } + + assert (ctx->ao_basis.shell_num > (int64_t) 0); + return ctx->ao_basis.shell_num; +} + + +int64_t qmckl_get_ao_basis_prim_num (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (int64_t) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 2; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return (int64_t) 0; + } + + assert (ctx->ao_basis.prim_num > (int64_t) 0); + return ctx->ao_basis.prim_num; +} + + +int64_t* qmckl_get_ao_basis_shell_center (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 3; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.shell_center != NULL); + return ctx->ao_basis.shell_center; +} + + +char* qmckl_get_ao_basis_shell_ang_mom (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 4; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.shell_ang_mom != NULL); + return ctx->ao_basis.shell_ang_mom; +} + + +int64_t* qmckl_get_ao_basis_shell_prim_num (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 5; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.shell_prim_num != NULL); + return ctx->ao_basis.shell_prim_num; +} + + +int64_t* qmckl_get_ao_basis_shell_prim_index (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 6; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.shell_prim_index != NULL); + return ctx->ao_basis.shell_prim_index; +} + + +double* qmckl_get_ao_basis_shell_factor (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 7; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.shell_factor != NULL); + return ctx->ao_basis.shell_factor; +} + + +double* qmckl_get_ao_basis_exponent (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + + int32_t mask = 1 << 8; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.exponent != NULL); + return ctx->ao_basis.exponent; +} + + +double* qmckl_get_ao_basis_coefficient (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return NULL; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 9; + + if ( (ctx->ao_basis.uninitialized & mask) != 0) { + return NULL; + } + + assert (ctx->ao_basis.coefficient != NULL); + return ctx->ao_basis.coefficient; +} + + +bool qmckl_ao_basis_provided(const qmckl_context context) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return false; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + return ctx->ao_basis.provided; +} + #+end_src + +** Initialization functions + + To set the basis set, all the following functions need to be + called. When + + #+begin_src c :comments org :tangle (eval h_func) +qmckl_exit_code qmckl_set_ao_basis_type (qmckl_context context, const char t); +qmckl_exit_code qmckl_set_ao_basis_shell_num (qmckl_context context, const int64_t shell_num); +qmckl_exit_code qmckl_set_ao_basis_prim_num (qmckl_context context, const int64_t prim_num); +qmckl_exit_code qmckl_set_ao_basis_shell_prim_index (qmckl_context context, const int64_t * shell_prim_index); +qmckl_exit_code qmckl_set_ao_basis_shell_center (qmckl_context context, const int64_t * shell_center); +qmckl_exit_code qmckl_set_ao_basis_shell_ang_mom (qmckl_context context, const char * shell_ang_mom); +qmckl_exit_code qmckl_set_ao_basis_shell_prim_num (qmckl_context context, const int64_t * shell_prim_num); +qmckl_exit_code qmckl_set_ao_basis_shell_factor (qmckl_context context, const double * shell_factor); +qmckl_exit_code qmckl_set_ao_basis_exponent (qmckl_context context, const double * exponent); +qmckl_exit_code qmckl_set_ao_basis_coefficient (qmckl_context context, const double * coefficient); + #+end_src + + #+NAME:pre2 + #+begin_src c :exports none +if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return QMCKL_NULL_CONTEXT; + } + +qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + #+end_src + + #+NAME:post2 + #+begin_src c :exports none +ctx->ao_basis.uninitialized &= ~mask; +ctx->ao_basis.provided = (ctx->ao_basis.uninitialized == 0); + +return QMCKL_SUCCESS; + #+end_src + + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +qmckl_exit_code qmckl_set_ao_basis_type(qmckl_context context, const char t) { + <> + + if (t != 'G' && t != 'S') { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_ao_basis_type", + NULL); + } + + int32_t mask = 1; + ctx->ao_basis.type = t; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_shell_num(qmckl_context context, const int64_t shell_num) { + <> + + if (shell_num <= 0) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_ao_basis_shell_num", + "shell_num <= 0"); + } + + int64_t prim_num = qmckl_get_ao_basis_prim_num(context); + + if (0L < prim_num && prim_num < shell_num) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_ao_basis_shell_num", + "shell_num > prim_num"); + } + + int32_t mask = 1 << 1; + ctx->ao_basis.shell_num = shell_num; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_prim_num(qmckl_context context, const int64_t prim_num) { + <> + + if (prim_num <= 0) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_ao_basis_shell_num", + "prim_num must be positive"); + } + + int64_t shell_num = qmckl_get_ao_basis_shell_num(context); + + if (prim_num < shell_num) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_ao_basis_shell_num", + "prim_num < shell_num"); + } + + int32_t mask = 1 << 2; + ctx->ao_basis.prim_num = prim_num; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_shell_center(qmckl_context context, const int64_t* shell_center) { + <> + + int32_t mask = 1 << 3; + + const int64_t shell_num = qmckl_get_ao_basis_shell_num(context); + if (shell_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_shell_center", + "shell_num is not set"); + } -***** Requirements + if (ctx->ao_basis.shell_center != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.shell_center); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_shell_center", + NULL); + } + } - - =context= is not 0 - - =n= > 0 - - =X= is allocated with at least $n \times 8$ bytes - - =LMAX= is allocated with at least $n \times 4$ bytes - - =P= is allocated with at least $n \times \max_i \text{LMAX}_i \times 8$ bytes - - =LDP= >= $\max_i$ =LMAX[i]= + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = shell_num * sizeof(int64_t); + int64_t* new_array = (int64_t*) qmckl_malloc(context, mem_info); -***** Header - #+BEGIN_SRC C :tangle qmckl.h -qmckl_exit_code qmckl_ao_power(const qmckl_context context, - const int64_t n, - const double *X, const int32_t *LMAX, - const double *P, const int64_t LDP); - #+END_SRC + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_shell_center", + NULL); + } + + memcpy(new_array, shell_center, mem_info.size); -***** Source - #+BEGIN_SRC f90 :tangle qmckl_ao.f90 + ctx->ao_basis.shell_center = new_array; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_shell_ang_mom(qmckl_context context, const char* shell_ang_mom) { + <> + + int32_t mask = 1 << 4; + + const int64_t shell_num = qmckl_get_ao_basis_shell_num(context); + if (shell_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_shell_ang_mom", + "shell_num is not set"); + } + + if (ctx->ao_basis.shell_ang_mom != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.shell_ang_mom); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_shell_ang_mom", + NULL); + } + } + + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = shell_num * sizeof(char); + char* new_array = (char*) qmckl_malloc(context, mem_info); + + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_shell_ang_mom", + NULL); + } + + memcpy(new_array, shell_ang_mom, mem_info.size); + + ctx->ao_basis.shell_ang_mom = new_array; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_shell_prim_num(qmckl_context context, const int64_t* shell_prim_num) { + <> + + int32_t mask = 1 << 5; + + const int64_t shell_num = qmckl_get_ao_basis_shell_num(context); + if (shell_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_shell_prim_num", + "shell_num is not set"); + } + + if (ctx->ao_basis.shell_prim_num != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.shell_prim_num); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_shell_prim_num", + NULL); + } + } + + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = shell_num * sizeof(int64_t); + int64_t* new_array = (int64_t*) qmckl_malloc(context, mem_info); + + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_shell_prim_num", + NULL); + } + + memcpy(new_array, shell_prim_num, mem_info.size); + + ctx->ao_basis.shell_prim_num = new_array; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_shell_prim_index(qmckl_context context, const int64_t* shell_prim_index) { + <> + + int32_t mask = 1 << 6; + + const int64_t shell_num = qmckl_get_ao_basis_shell_num(context); + if (shell_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_shell_prim_index", + "shell_num is not set"); + } + + if (ctx->ao_basis.shell_prim_index != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.shell_prim_index); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_shell_prim_index", + NULL); + } + } + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = shell_num * sizeof(int64_t); + int64_t* new_array = (int64_t*) qmckl_malloc(context, mem_info); + + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_shell_prim_index", + NULL); + } + + memcpy(new_array, shell_prim_index, mem_info.size); + + ctx->ao_basis.shell_prim_index = new_array; + + <> +} + + +qmckl_exit_code qmckl_set_ao_basis_shell_factor(qmckl_context context, const double* shell_factor) { + <> + + int32_t mask = 1 << 7; + + const int64_t shell_num = qmckl_get_ao_basis_shell_num(context); + if (shell_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_shell_factor", + "shell_num is not set"); + } + + + if (ctx->ao_basis.shell_factor != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.shell_factor); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_shell_factor", + NULL); + } + } + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = shell_num * sizeof(double); + double* new_array = (double*) qmckl_malloc(context, mem_info); + + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_shell_factor", + NULL); + } + + memcpy(new_array, shell_factor, mem_info.size); + + ctx->ao_basis.shell_factor = new_array; + + <> +} + +qmckl_exit_code qmckl_set_ao_basis_exponent(qmckl_context context, const double* exponent) { + <> + + int32_t mask = 1 << 8; + + const int64_t prim_num = qmckl_get_ao_basis_prim_num(context); + if (prim_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_exponent", + "prim_num is not set"); + } + + if (ctx->ao_basis.exponent != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.exponent); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_exponent", + NULL); + } + } + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = prim_num * sizeof(double); + double* new_array = (double*) qmckl_malloc(context, mem_info); + + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_exponent", + NULL); + } + + memcpy(new_array, exponent, mem_info.size); + + ctx->ao_basis.exponent = new_array; + + <> +} + +qmckl_exit_code qmckl_set_ao_basis_coefficient(qmckl_context context, const double* coefficient) { + <> + + int32_t mask = 1 << 9; + + const int64_t prim_num = qmckl_get_ao_basis_prim_num(context); + if (prim_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_ao_basis_coefficient", + "prim_num is not set"); + } + + if (ctx->ao_basis.coefficient != NULL) { + qmckl_exit_code rc = qmckl_free(context, ctx->ao_basis.coefficient); + if (rc != QMCKL_SUCCESS) { + return qmckl_failwith( context, rc, + "qmckl_set_ao_basis_coefficient", + NULL); + } + } + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = prim_num * sizeof(double); + double* new_array = (double*) qmckl_malloc(context, mem_info); + + if (new_array == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_ao_basis_coefficient", + NULL); + } + + memcpy(new_array, coefficient, mem_info.size); + + ctx->ao_basis.coefficient = new_array; + + <> +} + + #+end_src + +** TODO Fortran interfaces + +** Test :noexport: + + #+begin_src c :tangle (eval c_test) :exports none :exports none +/* Reference input data */ + +char typ = 'G'; +#define shell_num ((int64_t) 12) +#define prim_num ((int64_t) 20) + +int64_t shell_center [shell_num] = + { 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2 }; + +char shell_ang_mom [shell_num] = + { 'S', 'S', 'S', 'P', 'P', 'D', 'S', 'S', 'S', 'P', 'P', 'D' }; + +double shell_factor [shell_num] = + { 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1. }; + +int64_t shell_prim_num [shell_num] = + {5, 1, 1, 1, 1, 1, 5, 1, 1, 1, 1, 1}; + +int64_t shell_prim_index [shell_num] = + {1, 6, 7, 8, 9, 10, 11, 16, 17, 18, 19, 20}; + +double exponent [prim_num] = + { 33.87, 5.095, 1.159, 0.3258, 0.1027, 0.3258, 0.1027, + 1.407, 0.388, 1.057, 33.87, 5.095, 1.159, 0.3258, 0.1027, + 0.3258, 0.1027, 1.407, 0.388, 1.057 }; + +double coefficient [prim_num] = + { 0.006068, 0.045308, 0.202822, 0.503903, 0.383421, + 1.0, 1.0, 1.0, 1.0, 1.0, 0.006068, 0.045308, 0.202822, + 0.503903, 0.383421, 1.0, 1.0, 1.0, 1.0, 1.0 }; +/* --- */ + +qmckl_exit_code rc; + +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_type (context, typ); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_num (context, shell_num); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_prim_num (context, prim_num); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_center (context, shell_center); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_ang_mom (context, shell_ang_mom); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_factor (context, shell_factor); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_center (context, shell_prim_num); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_prim_num (context, shell_prim_num); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_shell_prim_index (context, shell_prim_index); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_exponent (context, exponent); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_ao_basis_provided(context)); + +rc = qmckl_set_ao_basis_coefficient (context, coefficient); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(qmckl_ao_basis_provided(context)); + + #+end_src + +* Polynomial part +** Powers of $x-X_i$ + :PROPERTIES: + :Name: qmckl_ao_power + :CRetType: qmckl_exit_code + :FRetType: qmckl_exit_code + :END: + + The ~qmckl_ao_power~ function computes all the powers of the ~n~ + input data up to the given maximum value given in input for each of + the $n$ points: + + \[ P_{ik} = X_i^k \] + + #+NAME: qmckl_ao_power_args + | qmckl_context | context | in | Global state | + | int64_t | n | in | Number of values | + | double | X[n] | in | Array containing the input values | + | int32_t | LMAX[n] | in | Array containing the maximum power for each value | + | double | P[n][ldp] | out | Array containing all the powers of ~X~ | + | int64_t | ldp | in | Leading dimension of array ~P~ | + +*** Requirements + + - ~context~ is not ~QMCKL_NULL_CONTEXT~ + - ~n~ > 0 + - ~X~ is allocated with at least $n \times 8$ bytes + - ~LMAX~ is allocated with at least $n \times 4$ bytes + - ~P~ is allocated with at least $n \times \max_i \text{LMAX}_i \times 8$ bytes + - ~LDP~ >= $\max_i$ ~LMAX[i]~ + +*** C Header + + #+CALL: generate_c_header(table=qmckl_ao_power_args,rettyp=get_value("CRetType"),fname="qmckl_ao_power") + + #+RESULTS: + #+begin_src c :tangle (eval h_func) :comments org + qmckl_exit_code qmckl_ao_power ( + const qmckl_context context, + const int64_t n, + const double* X, + const int32_t* LMAX, + double* const P, + const int64_t ldp ); + #+end_src + +*** Source + + #+begin_src f90 :tangle (eval f) integer function qmckl_ao_power_f(context, n, X, LMAX, P, ldp) result(info) + use qmckl implicit none integer*8 , intent(in) :: context integer*8 , intent(in) :: n @@ -85,93 +927,124 @@ integer function qmckl_ao_power_f(context, n, X, LMAX, P, ldp) result(info) real*8 , intent(out) :: P(ldp,n) integer*8 , intent(in) :: ldp - integer*8 :: i,j + integer*8 :: i,k - info = 0 + info = QMCKL_SUCCESS - if (context == 0_8) then - info = -1 + if (context == QMCKL_NULL_CONTEXT) then + info = QMCKL_INVALID_CONTEXT return endif - - if (LDP < MAXVAL(LMAX)) then - info = -2 + + if (n <= ldp) then + info = QMCKL_INVALID_ARG_2 return endif - - do j=1,n - P(1,j) = X(j) - do i=2,LMAX(j) - P(i,j) = P(i-1,j) * X(j) - end do + + k = MAXVAL(LMAX) + if (LDP < k) then + info = QMCKL_INVALID_ARG_6 + return + endif + + if (k <= 0) then + info = QMCKL_INVALID_ARG_4 + return + endif + + do i=1,n + P(1,i) = X(i) + do k=2,LMAX(i) + P(k,i) = P(k-1,i) * X(i) + end do end do end function qmckl_ao_power_f - #+END_SRC + #+end_src -***** C interface :noexport: - #+BEGIN_SRC f90 :tangle qmckl_ao.f90 -integer(c_int32_t) function qmckl_ao_power(context, n, X, LMAX, P, ldp) & - 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) :: X(n) - integer (c_int32_t) , intent(in) :: LMAX(n) - real (c_double) , intent(out) :: P(ldp,n) - integer (c_int64_t) , intent(in) , value :: ldp - - integer, external :: qmckl_ao_power_f - info = qmckl_ao_power_f(context, n, X, LMAX, P, ldp) -end function qmckl_ao_power - #+END_SRC +*** C interface + #+CALL: generate_c_interface(table=qmckl_ao_power_args,rettyp=get_value("CRetType"),fname="qmckl_ao_power") - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer(c_int32_t) function qmckl_ao_power(context, n, X, LMAX, P, ldp) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t) , intent(in) , value :: context - integer (c_int64_t) , intent(in) , value :: n - integer (c_int64_t) , intent(in) , value :: ldp - real (c_double) , intent(in) :: X(n) - integer (c_int32_t) , intent(in) :: LMAX(n) - real (c_double) , intent(out) :: P(ldp,n) - end function qmckl_ao_power - end interface - #+END_SRC - -***** Test :noexport: - #+BEGIN_SRC f90 :tangle test_qmckl_ao_f.f90 + #+RESULTS: + #+begin_src f90 :tangle (eval f) :comments org :exports none + integer(c_int32_t) function qmckl_ao_power & + (context, n, X, LMAX, P, ldp) & + 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) :: X(n) + integer (c_int32_t) , intent(in) :: LMAX(n) + real (c_double ) , intent(out) :: P(ldp,n) + integer (c_int64_t) , intent(in) , value :: ldp + + integer(c_int32_t), external :: qmckl_ao_power_f + info = qmckl_ao_power_f & + (context, n, X, LMAX, P, ldp) + + end function qmckl_ao_power + #+end_src + +*** Fortran interface + + #+CALL: generate_f_interface(table=qmckl_ao_power_args,rettyp=get_value("CRetType"),fname="qmckl_ao_power") + + #+RESULTS: + #+begin_src f90 :tangle (eval fh_func) :comments org :exports none + interface + integer(c_int32_t) function qmckl_ao_power & + (context, n, X, LMAX, P, ldp) & + bind(C) + use, intrinsic :: iso_c_binding + import + implicit none + + integer (c_int64_t) , intent(in) , value :: context + integer (c_int64_t) , intent(in) , value :: n + real (c_double ) , intent(in) :: X(n) + integer (c_int32_t) , intent(in) :: LMAX(n) + real (c_double ) , intent(out) :: P(ldp,n) + integer (c_int64_t) , intent(in) , value :: ldp + + end function qmckl_ao_power + end interface + #+end_src + +*** Test + + #+begin_src f90 :tangle (eval f_test) integer(c_int32_t) function test_qmckl_ao_power(context) bind(C) use qmckl implicit none - integer(c_int64_t), intent(in), value :: context - + integer(qmckl_context), intent(in), value :: context + integer*8 :: n, LDP integer, allocatable :: LMAX(:) double precision, allocatable :: X(:), P(:,:) integer*8 :: i,j double precision :: epsilon - epsilon = qmckl_context_get_epsilon(context) + epsilon = qmckl_get_numprec_epsilon(context) n = 100; LDP = 10; - + allocate(X(n), P(LDP,n), LMAX(n)) - + do j=1,n X(j) = -5.d0 + 0.1d0 * dble(j) LMAX(j) = 1 + int(mod(j, 5),4) end do - + test_qmckl_ao_power = qmckl_ao_power(context, n, X, LMAX, P, LDP) - if (test_qmckl_ao_power /= 0) return - - test_qmckl_ao_power = -1 - + if (test_qmckl_ao_power /= QMCKL_SUCCESS) return + + test_qmckl_ao_power = QMCKL_FAILURE + do j=1,n do i=1,LMAX(j) if ( X(j)**i == 0.d0 ) then @@ -182,72 +1055,108 @@ integer(c_int32_t) function test_qmckl_ao_power(context) bind(C) end do end do - test_qmckl_ao_power = 0 + test_qmckl_ao_power = QMCKL_SUCCESS deallocate(X,P,LMAX) end function test_qmckl_ao_power - #+END_SRC + #+end_src - #+BEGIN_SRC C :tangle test_qmckl_ao.c + #+begin_src c :tangle (eval c_test) :exports none int test_qmckl_ao_power(qmckl_context context); munit_assert_int(0, ==, test_qmckl_ao_power(context)); - #+END_SRC + #+end_src + +** Value, Gradient and Laplacian of a polynomial + :PROPERTIES: + :Name: qmckl_ao_polynomial_vgl + :CRetType: qmckl_exit_code + :FRetType: qmckl_exit_code + :END: + + A polynomial is centered on a nucleus $\mathbf{R}_i$ + \[ + P_l(\mathbf{r},\mathbf{R}_i) = (x-X_i)^a (y-Y_i)^b (z-Z_i)^c + \] -**** =qmckl_ao_polynomial_vgl= - - Computes the values, gradients and Laplacians at a given point of - all polynomials with an angular momentum up to =lmax=. + The gradients with respect to electron coordinates are + + \begin{eqnarray*} + \frac{\partial }{\partial x} P_l\left(\mathbf{r},\mathbf{R}_i \right) & + = & a (x-X_i)^{a-1} (y-Y_i)^b (z-Z_i)^c \\ + \frac{\partial }{\partial y} P_l\left(\mathbf{r},\mathbf{R}_i \right) & + = & b (x-X_i)^a (y-Y_i)^{b-1} (z-Z_i)^c \\ + \frac{\partial }{\partial z} P_l\left(\mathbf{r},\mathbf{R}_i \right) & + = & c (x-X_i)^a (y-Y_i)^b (z-Z_i)^{c-1} \\ + \end{eqnarray*} -***** Arguments - - | =context= | input | Global state | - | =X(3)= | input | Array containing the coordinates of the points | - | =R(3)= | input | Array containing the x,y,z coordinates of the center | - | =lmax= | input | Maximum angular momentum | - | =n= | output | Number of computed polynomials | - | =L(ldl,n)= | output | Contains a,b,c for all =n= results | - | =ldl= | input | Leading dimension of =L= | - | =VGL(ldv,n)= | output | Value, gradients and Laplacian of the polynomials | - | =ldv= | input | Leading dimension of array =VGL= | + and the Laplacian is -***** Requirements + \begin{eqnarray*} + \left( \frac{\partial }{\partial x^2} + + \frac{\partial }{\partial y^2} + + \frac{\partial }{\partial z^2} \right) P_l + \left(\mathbf{r},\mathbf{R}_i \right) & = & + a(a-1) (x-X_i)^{a-2} (y-Y_i)^b (z-Z_i)^c + \\ + && b(b-1) (x-X_i)^a (y-Y_i)^{b-1} (z-Z_i)^c + \\ + && c(c-1) (x-X_i)^a (y-Y_i)^b (z-Z_i)^{c-1}. + \end{eqnarray*} - - =context= is not 0 - - =n= > 0 - - =lmax= >= 0 - - =ldl= >= 3 - - =ldv= >= 5 - - =X= is allocated with at least $3 \times 8$ bytes - - =R= is allocated with at least $3 \times 8$ bytes - - =n= >= =(lmax+1)(lmax+2)(lmax+3)/6= - - =L= is allocated with at least $3 \times n \times 4$ bytes - - =VGL= is allocated with at least $5 \times n \times 8$ bytes - - On output, =n= should be equal to =(lmax+1)(lmax+2)(lmax+3)/6= - - On output, the powers are given in the following order (l=a+b+c): - - Increase values of =l= - - Within a given value of =l=, alphabetical order of the - string made by a*"x" + b*"y" + c*"z" (in Python notation). - For example, with a=0, b=2 and c=1 the string is "yyz" - -***** Error codes + ~qmckl_ao_polynomial_vgl~ computes the values, gradients and + Laplacians at a given point in space, of all polynomials with an + angular momentum up to ~lmax~. - | -1 | Null context | - | -2 | Inconsistent =ldl= | - | -3 | Inconsistent =ldv= | - | -4 | Inconsistent =lmax= | - -***** Header - #+BEGIN_SRC C :tangle qmckl.h -qmckl_exit_code qmckl_ao_polynomial_vgl(const qmckl_context context, - const double *X, const double *R, - const int32_t lmax, const int64_t *n, - const int32_t *L, const int64_t ldl, - const double *VGL, const int64_t ldv); - #+END_SRC + #+NAME: qmckl_ao_polynomial_vgl_args + | qmckl_context | context | in | Global state | + | double | X[3] | in | Array containing the coordinates of the points | + | double | R[3] | in | Array containing the x,y,z coordinates of the center | + | int32_t | lmax | in | Maximum angular momentum | + | int64_t | n | inout | Number of computed polynomials | + | int32_t | L[n][ldl] | out | Contains a,b,c for all ~n~ results | + | int64_t | ldl | in | Leading dimension of ~L~ | + | double | VGL[n][ldv] | out | Value, gradients and Laplacian of the polynomials | + | int64_t | ldv | in | Leading dimension of array ~VGL~ | -***** Source - #+BEGIN_SRC f90 :tangle qmckl_ao.f90 +*** Requirements + + - ~context~ is not ~QMCKL_NULL_CONTEXT~ + - ~n~ > 0 + - ~lmax~ >= 0 + - ~ldl~ >= 3 + - ~ldv~ >= 5 + - ~X~ is allocated with at least $3 \times 8$ bytes + - ~R~ is allocated with at least $3 \times 8$ bytes + - ~n~ >= ~(lmax+1)(lmax+2)(lmax+3)/6~ + - ~L~ is allocated with at least $3 \times n \times 4$ bytes + - ~VGL~ is allocated with at least $5 \times n \times 8$ bytes + - On output, ~n~ should be equal to ~(lmax+1)(lmax+2)(lmax+3)/6~ + - On output, the powers are given in the following order (l=a+b+c): + - Increasing values of ~l~ + - Within a given value of ~l~, alphabetical order of the + string made by a*"x" + b*"y" + c*"z" (in Python notation). + For example, with a=0, b=2 and c=1 the string is "yyz" + +*** C Header + + #+CALL: generate_c_header(table=qmckl_ao_polynomial_vgl_args,rettyp=get_value("CRetType"),fname=get_value("Name")) + + #+RESULTS: + #+begin_src c :tangle (eval h_func) :comments org + qmckl_exit_code qmckl_ao_polynomial_vgl ( + const qmckl_context context, + const double* X, + const double* R, + const int32_t lmax, + int64_t* n, + int32_t* const L, + const int64_t ldl, + double* const VGL, + const int64_t ldv ); + #+end_src + +*** Source + #+begin_src f90 :tangle (eval f) integer function qmckl_ao_polynomial_vgl_f(context, X, R, lmax, n, L, ldl, VGL, ldv) result(info) + use qmckl implicit none integer*8 , intent(in) :: context real*8 , intent(in) :: X(3), R(3) @@ -266,69 +1175,69 @@ integer function qmckl_ao_polynomial_vgl_f(context, X, R, lmax, n, L, ldl, VGL, integer, external :: qmckl_ao_power_f double precision :: xy, yz, xz double precision :: da, db, dc, dd - + info = 0 - - if (context == 0_8) then - info = -1 + + if (context == QMCKL_NULL_CONTEXT) then + info = QMCKL_INVALID_CONTEXT return endif - + + if (lmax < 0) then + info = QMCKL_INVALID_ARG_4 + return + endif + if (ldl < 3) then - info = -2 + info = QMCKL_INVALID_ARG_7 return endif - + if (ldv < 5) then - info = -3 + info = QMCKL_INVALID_ARG_9 return endif - - if (lmax <= 0) then - info = -4 - return - endif - - + + do i=1,3 Y(i) = X(i) - R(i) end do lmax_array(1:3) = lmax if (lmax == 0) then - VGL(1,1) = 1.d0 - vgL(2:5,1) = 0.d0 - l(1:3,1) = 0 - n=1 + VGL(1,1) = 1.d0 + vgL(2:5,1) = 0.d0 + l(1:3,1) = 0 + n=1 else if (lmax > 0) then - pows(-2:0,1:3) = 1.d0 - do i=1,lmax + pows(-2:0,1:3) = 1.d0 + do i=1,lmax pows(i,1) = pows(i-1,1) * Y(1) pows(i,2) = pows(i-1,2) * Y(2) pows(i,3) = pows(i-1,3) * Y(3) - end do + end do - VGL(1:5,1:4) = 0.d0 - l(1:3,1:4) = 0 + VGL(1:5,1:4) = 0.d0 + l (1:3,1:4) = 0 - VGL(1,1) = 1.d0 - vgl(1:5,2:4) = 0.d0 + VGL(1 ,1 ) = 1.d0 + vgl(1:5,2:4) = 0.d0 - l(1,2) = 1 - vgl(1,2) = pows(1,1) - vgL(2,2) = 1.d0 + l (1,2) = 1 + vgl(1,2) = pows(1,1) + vgL(2,2) = 1.d0 - l(2,3) = 1 - vgl(1,3) = pows(1,2) - vgL(3,3) = 1.d0 + l (2,3) = 1 + vgl(1,3) = pows(1,2) + vgL(3,3) = 1.d0 - l(3,4) = 1 - vgl(1,4) = pows(1,3) - vgL(4,4) = 1.d0 + l (3,4) = 1 + vgl(1,4) = pows(1,3) + vgL(4,4) = 1.d0 - n=4 + n=4 endif - + ! l>=2 dd = 2.d0 do d=2,lmax @@ -343,21 +1252,21 @@ integer function qmckl_ao_polynomial_vgl_f(context, X, R, lmax, n, L, ldl, VGL, l(1,n) = a l(2,n) = b l(3,n) = c - + xy = pows(a,1) * pows(b,2) yz = pows(b,2) * pows(c,3) xz = pows(a,1) * pows(c,3) - + vgl(1,n) = xy * pows(c,3) - + xy = dc * xy xz = db * xz yz = da * yz - + vgl(2,n) = pows(a-1,1) * yz vgl(3,n) = pows(b-1,2) * xz vgl(4,n) = pows(c-1,3) * xy - + vgl(5,n) = & (da-1.d0) * pows(a-2,1) * yz + & (db-1.d0) * pows(b-2,2) * xz + & @@ -370,56 +1279,78 @@ integer function qmckl_ao_polynomial_vgl_f(context, X, R, lmax, n, L, ldl, VGL, dd = dd + 1.d0 end do - info = 0 + info = QMCKL_SUCCESS end function qmckl_ao_polynomial_vgl_f - #+END_SRC + #+end_src + +*** C interface -***** C interface :noexport: - #+BEGIN_SRC f90 :tangle qmckl_ao.f90 -integer(c_int32_t) function qmckl_ao_polynomial_vgl(context, X, R, lmax, n, L, ldl, VGL, ldv) & - bind(C) result(info) - use, intrinsic :: iso_c_binding - implicit none - integer (c_int64_t) , intent(in) , value :: context - real (c_double) , intent(in) :: X(3), R(3) - integer (c_int32_t) , intent(in) , value :: lmax - integer (c_int64_t) , intent(out) :: n - integer (c_int32_t) , intent(out) :: L(ldl,(lmax+1)*(lmax+2)*(lmax+3)/6) - integer (c_int64_t) , intent(in) , value :: ldl - real (c_double) , intent(out) :: VGL(ldv,(lmax+1)*(lmax+2)*(lmax+3)/6) - integer (c_int64_t) , intent(in) , value :: ldv + #+CALL: generate_c_interface(table=qmckl_ao_polynomial_vgl_args,rettyp=get_value("CRetType"),fname=get_value("Name")) - integer, external :: qmckl_ao_polynomial_vgl_f - info = qmckl_ao_polynomial_vgl_f(context, X, R, lmax, n, L, ldl, VGL, ldv) -end function qmckl_ao_polynomial_vgl - #+END_SRC + #+RESULTS: + #+begin_src f90 :tangle (eval f) :comments org :exports none + integer(c_int32_t) function qmckl_ao_polynomial_vgl & + (context, X, R, lmax, n, L, ldl, VGL, ldv) & + bind(C) result(info) -***** Fortran interface :noexport: - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer(c_int32_t) function qmckl_ao_polynomial_vgl(context, X, R, lmax, n, L, ldl, VGL, ldv) & - bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t) , intent(in) , value :: context - integer (c_int32_t) , intent(in) , value :: lmax - integer (c_int64_t) , intent(in) , value :: ldl - integer (c_int64_t) , intent(in) , value :: ldv - real (c_double) , intent(in) :: X(3), R(3) - integer (c_int64_t) , intent(out) :: n - integer (c_int32_t) , intent(out) :: L(ldl,(lmax+1)*(lmax+2)*(lmax+3)/6) - real (c_double) , intent(out) :: VGL(ldv,(lmax+1)*(lmax+2)*(lmax+3)/6) - end function qmckl_ao_polynomial_vgl - end interface - #+END_SRC -***** Test :noexport: - #+BEGIN_SRC f90 :tangle test_qmckl_ao_f.f90 + use, intrinsic :: iso_c_binding + implicit none + + integer (c_int64_t) , intent(in) , value :: context + real (c_double ) , intent(in) :: X(3) + real (c_double ) , intent(in) :: R(3) + integer (c_int32_t) , intent(in) , value :: lmax + integer (c_int64_t) , intent(inout) :: n + integer (c_int32_t) , intent(out) :: L(ldl,n) + integer (c_int64_t) , intent(in) , value :: ldl + real (c_double ) , intent(out) :: VGL(ldv,n) + integer (c_int64_t) , intent(in) , value :: ldv + + integer(c_int32_t), external :: qmckl_ao_polynomial_vgl_f + info = qmckl_ao_polynomial_vgl_f & + (context, X, R, lmax, n, L, ldl, VGL, ldv) + + end function qmckl_ao_polynomial_vgl + #+end_src + +*** Fortran interface + + #+CALL: generate_f_interface(table=qmckl_ao_polynomial_vgl_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_ao_polynomial_vgl & + (context, X, R, lmax, n, L, ldl, VGL, ldv) & + bind(C) + use, intrinsic :: iso_c_binding + import + implicit none + + integer (c_int64_t) , intent(in) , value :: context + real (c_double ) , intent(in) :: X(3) + real (c_double ) , intent(in) :: R(3) + integer (c_int32_t) , intent(in) , value :: lmax + integer (c_int64_t) , intent(inout) :: n + integer (c_int32_t) , intent(out) :: L(ldl,n) + integer (c_int64_t) , intent(in) , value :: ldl + real (c_double ) , intent(out) :: VGL(ldv,n) + integer (c_int64_t) , intent(in) , value :: ldv + + end function qmckl_ao_polynomial_vgl + end interface + #+end_src + +*** Test + + #+begin_src f90 :tangle (eval f_test) integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) use qmckl implicit none integer(c_int64_t), intent(in), value :: context - + integer :: lmax, d, i integer, allocatable :: L(:,:) integer*8 :: n, ldl, ldv, j @@ -428,40 +1359,37 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) double precision :: w double precision :: epsilon - epsilon = qmckl_context_get_epsilon(context) + epsilon = qmckl_get_numprec_epsilon(context) X = (/ 1.1 , 2.2 , 3.3 /) R = (/ 0.1 , 1.2 , -2.3 /) Y(:) = X(:) - R(:) lmax = 4; - n = 0; ldl = 3; ldv = 100; - + d = (lmax+1)*(lmax+2)*(lmax+3)/6 allocate (L(ldl,d), VGL(ldv,d)) test_qmckl_ao_polynomial_vgl = & qmckl_ao_polynomial_vgl(context, X, R, lmax, n, L, ldl, VGL, ldv) - if (test_qmckl_ao_polynomial_vgl /= 0) return - test_qmckl_ao_polynomial_vgl = -1 - - if (n /= d) return + if (test_qmckl_ao_polynomial_vgl /= QMCKL_SUCCESS) return + if (n /= d) return do j=1,n - test_qmckl_ao_polynomial_vgl = -11 + test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE do i=1,3 if (L(i,j) < 0) return end do - test_qmckl_ao_polynomial_vgl = -12 + test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE if (dabs(1.d0 - VGL(1,j) / (& Y(1)**L(1,j) * Y(2)**L(2,j) * Y(3)**L(3,j) & )) > epsilon ) return - test_qmckl_ao_polynomial_vgl = -13 + test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE if (L(1,j) < 1) then if (VGL(2,j) /= 0.d0) return else @@ -470,7 +1398,7 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) )) > epsilon ) return end if - test_qmckl_ao_polynomial_vgl = -14 + test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE if (L(2,j) < 1) then if (VGL(3,j) /= 0.d0) return else @@ -479,7 +1407,7 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) )) > epsilon ) return end if - test_qmckl_ao_polynomial_vgl = -15 + test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE if (L(3,j) < 1) then if (VGL(4,j) /= 0.d0) return else @@ -487,8 +1415,8 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) L(3,j) * Y(1)**L(1,j) * Y(2)**L(2,j) * Y(3)**(L(3,j)-1) & )) > epsilon ) return end if - - test_qmckl_ao_polynomial_vgl = -16 + + test_qmckl_ao_polynomial_vgl = QMCKL_FAILURE w = 0.d0 if (L(1,j) > 1) then w = w + L(1,j) * (L(1,j)-1) * Y(1)**(L(1,j)-2) * Y(2)**L(2,j) * Y(3)**L(3,j) @@ -502,63 +1430,63 @@ integer(c_int32_t) function test_qmckl_ao_polynomial_vgl(context) bind(C) if (dabs(1.d0 - VGL(5,j) / w) > epsilon ) return end do - test_qmckl_ao_polynomial_vgl = 0 - + test_qmckl_ao_polynomial_vgl = QMCKL_SUCCESS + deallocate(L,VGL) end function test_qmckl_ao_polynomial_vgl - #+END_SRC + #+end_src - #+BEGIN_SRC C :tangle test_qmckl_ao.c + #+begin_src c :tangle (eval c_test) int test_qmckl_ao_polynomial_vgl(qmckl_context context); munit_assert_int(0, ==, test_qmckl_ao_polynomial_vgl(context)); - #+END_SRC - #+END_SRC + #+end_src -*** Gaussian basis functions - -**** =qmckl_ao_gaussian_vgl= +* Radial part +** Gaussian basis functions + + ~qmckl_ao_gaussian_vgl~ computes the values, gradients and + Laplacians at a given point of ~n~ Gaussian functions centered at + the same point: - Computes the values, gradients and Laplacians at a given point of - =n= Gaussian functions centered at the same point: - - \[ v_i = exp(-a_i |X-R|^2) \] - \[ \nabla_x v_i = -2 a_i (X_x - R_x) v_i \] - \[ \nabla_y v_i = -2 a_i (X_y - R_y) v_i \] - \[ \nabla_z v_i = -2 a_i (X_z - R_z) v_i \] - \[ \Delta v_i = a_i (4 |X-R|^2 a_i - 6) v_i \] + \[ v_i = \exp(-a_i |X-R|^2) \] + \[ \nabla_x v_i = -2 a_i (X_x - R_x) v_i \] + \[ \nabla_y v_i = -2 a_i (X_y - R_y) v_i \] + \[ \nabla_z v_i = -2 a_i (X_z - R_z) v_i \] + \[ \Delta v_i = a_i (4 |X-R|^2 a_i - 6) v_i \] -***** Arguments - - | =context= | input | Global state | - | =X(3)= | input | Array containing the coordinates of the points | - | =R(3)= | input | Array containing the x,y,z coordinates of the center | - | =n= | input | Number of computed gaussians | - | =A(n)= | input | Exponents of the Gaussians | - | =VGL(ldv,5)= | output | Value, gradients and Laplacian of the Gaussians | - | =ldv= | input | Leading dimension of array =VGL= | + | ~context~ | input | Global state | + | ~X(3)~ | input | Array containing the coordinates of the points | + | ~R(3)~ | input | Array containing the x,y,z coordinates of the center | + | ~n~ | input | Number of computed Gaussians | + | ~A(n)~ | input | Exponents of the Gaussians | + | ~VGL(ldv,5)~ | output | Value, gradients and Laplacian of the Gaussians | + | ~ldv~ | input | Leading dimension of array ~VGL~ | -***** Requirements + Requirements - - =context= is not 0 - - =n= > 0 - - =ldv= >= 5 - - =A(i)= > 0 for all =i= - - =X= is allocated with at least $3 \times 8$ bytes - - =R= is allocated with at least $3 \times 8$ bytes - - =A= is allocated with at least $n \times 8$ bytes - - =VGL= is allocated with at least $n \times 5 \times 8$ bytes + - ~context~ is not 0 + - ~n~ > 0 + - ~ldv~ >= 5 + - ~A(i)~ > 0 for all ~i~ + - ~X~ is allocated with at least $3 \times 8$ bytes + - ~R~ is allocated with at least $3 \times 8$ bytes + - ~A~ is allocated with at least $n \times 8$ bytes + - ~VGL~ is allocated with at least $n \times 5 \times 8$ bytes -***** Header - #+BEGIN_SRC C :tangle qmckl.h -qmckl_exit_code qmckl_ao_gaussian_vgl(const qmckl_context context, - const double *X, const double *R, - const int64_t *n, const int64_t *A, - const double *VGL, const int64_t ldv); - #+END_SRC + #+begin_src c :tangle (eval h_func) +qmckl_exit_code +qmckl_ao_gaussian_vgl(const qmckl_context context, + const double *X, + const double *R, + const int64_t *n, + const int64_t *A, + const double *VGL, + const int64_t ldv); + #+end_src -***** Source - #+BEGIN_SRC f90 :tangle qmckl_ao.f90 + #+begin_src f90 :tangle (eval f) integer function qmckl_ao_gaussian_vgl_f(context, X, R, n, A, VGL, ldv) result(info) + use qmckl implicit none integer*8 , intent(in) :: context real*8 , intent(in) :: X(3), R(3) @@ -570,20 +1498,20 @@ integer function qmckl_ao_gaussian_vgl_f(context, X, R, n, A, VGL, ldv) result(i integer*8 :: i,j real*8 :: Y(3), r2, t, u, v - info = 0 + info = QMCKL_SUCCESS - if (context == 0_8) then - info = -1 + if (context == QMCKL_NULL_CONTEXT) then + info = QMCKL_INVALID_CONTEXT return endif if (n <= 0) then - info = -2 + info = QMCKL_INVALID_ARG_4 return endif if (ldv < n) then - info = -3 + info = QMCKL_INVALID_ARG_7 return endif @@ -617,10 +1545,9 @@ integer function qmckl_ao_gaussian_vgl_f(context, X, R, n, A, VGL, ldv) result(i end do end function qmckl_ao_gaussian_vgl_f - #+END_SRC + #+end_src -***** C interface :noexport: - #+BEGIN_SRC f90 :tangle qmckl_ao.f90 + #+begin_src f90 :tangle (eval f) :exports none integer(c_int32_t) function qmckl_ao_gaussian_vgl(context, X, R, n, A, VGL, ldv) & bind(C) result(info) use, intrinsic :: iso_c_binding @@ -635,9 +1562,9 @@ integer(c_int32_t) function qmckl_ao_gaussian_vgl(context, X, R, n, A, VGL, ldv) integer, external :: qmckl_ao_gaussian_vgl_f info = qmckl_ao_gaussian_vgl_f(context, X, R, n, A, VGL, ldv) end function qmckl_ao_gaussian_vgl - #+END_SRC + #+end_src - #+BEGIN_SRC f90 :tangle qmckl_f.f90 + #+begin_src f90 :tangle (eval fh_func) :exports none interface integer(c_int32_t) function qmckl_ao_gaussian_vgl(context, X, R, n, A, VGL, ldv) & bind(C) @@ -649,9 +1576,10 @@ end function qmckl_ao_gaussian_vgl real (c_double) , intent(out) :: VGL(ldv,5) end function qmckl_ao_gaussian_vgl end interface - #+END_SRC -***** Test :noexport: - #+BEGIN_SRC f90 :tangle test_qmckl_ao_f.f90 + #+end_src + + # Test + #+begin_src f90 :tangle (eval f_test) integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context) bind(C) use qmckl implicit none @@ -663,7 +1591,7 @@ integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context) bind(C) double precision, allocatable :: VGL(:,:), A(:) double precision :: epsilon - epsilon = qmckl_context_get_epsilon(context) + epsilon = qmckl_get_numprec_epsilon(context) X = (/ 1.1 , 2.2 , 3.3 /) R = (/ 0.1 , 1.2 , -2.3 /) @@ -716,27 +1644,59 @@ integer(c_int32_t) function test_qmckl_ao_gaussian_vgl(context) bind(C) deallocate(VGL) end function test_qmckl_ao_gaussian_vgl - #+END_SRC + #+end_src - #+BEGIN_SRC C :tangle test_qmckl_ao.c -int test_qmckl_ao_gaussian_vgl(qmckl_context context); + #+begin_src c :tangle (eval c_test) :exports none +int test_qmckl_ao_gaussian_vgl(qmckl_context context); munit_assert_int(0, ==, test_qmckl_ao_gaussian_vgl(context)); - #+END_SRC + #+end_src - -*** TODO Slater basis functions +** TODO Slater basis functions -*** End of files :noexport: +** TODO Radial functions on a grid +* Combining radial and polynomial parts +* End of files :noexport: -***** Test - #+BEGIN_SRC C :tangle test_qmckl_ao.c + #+begin_src c :tangle (eval h_private_type) +#endif + #+end_src + +*** Test + #+begin_src c :tangle (eval c_test) if (qmckl_context_destroy(context) != QMCKL_SUCCESS) return QMCKL_FAILURE; return MUNIT_OK; } + #+end_src + +**✸ Compute file names + #+begin_src emacs-lisp +; The following is required to compute the file names + +(setq pwd (file-name-directory buffer-file-name)) +(setq name (file-name-nondirectory (substring buffer-file-name 0 -4))) +(setq f (concat pwd name "_f.f90")) +(setq fh (concat pwd name "_fh.f90")) +(setq c (concat pwd name ".c")) +(setq h (concat name ".h")) +(setq h_private (concat name "_private.h")) +(setq c_test (concat pwd "test_" name ".c")) +(setq f_test (concat pwd "test_" name "_f.f90")) + +; Minted +(require 'ox-latex) +(setq org-latex-listings 'minted) +(add-to-list 'org-latex-packages-alist '("" "listings")) +(add-to-list 'org-latex-packages-alist '("" "color")) + + #+end_src - #+END_SRC + #+RESULTS: + | | color | + | | listings | + + +# -*- mode: org -*- +# vim: syntax=c - # -*- mode: org -*- - # vim: syntax=c diff --git a/src/qmckl_context.org b/src/qmckl_context.org index 6ca4894..7aba5cb 100644 --- a/src/qmckl_context.org +++ b/src/qmckl_context.org @@ -1,820 +1,459 @@ -** Context +#+TITLE: Context +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org - This file is written in C because it is more natural to express the - context in C than in Fortran. +* Headers :noexport: - 2 files are produced: - - a source file : =qmckl_context.c= - - a test file : =test_qmckl_context.c= - -*** Headers :noexport: - #+BEGIN_SRC C :tangle qmckl_context.c -#include "qmckl.h" - #+END_SRC - - #+BEGIN_SRC C :tangle test_qmckl_context.c + #+begin_src c :tangle (eval c_test) :noweb yes #include "qmckl.h" #include "munit.h" -MunitResult test_qmckl_context() { - #+END_SRC +MunitResult test_<>() { + #+end_src -*** Context + #+begin_src c :tangle (eval h_private_type) :noweb yes +#ifndef QMCKL_CONTEXT_HPT +#define QMCKL_CONTEXT_HPT - The context variable is a handle for the state of the library, and - is stored in the following data structure, which can't be seen - outside of the library. To simplify compatibility with other - languages, the pointer to the internal data structure is converted - into a 64-bit signed integer, defined in the =qmckl_context= type. - A value of 0 for the context is equivalent to a =NULL= pointer. +#include +#include - # The following code block should be kept to insert comments into - # the qmckl.h file +#include "qmckl_error_private_type.h" +#include "qmckl_memory_private_type.h" +#include "qmckl_numprec_private_type.h" +#include "qmckl_electron_private_type.h" +#include "qmckl_ao_private_type.h" + #+end_src - #+BEGIN_SRC C :comments org :tangle qmckl.h :export none - #+END_SRC + #+begin_src c :tangle (eval c) +#include +#include +#include +#include +#include +#include +#include -**** Basis set data structure +#include "qmckl_error_type.h" +#include "qmckl_context_private_type.h" +#include "qmckl_context_type.h" +#include "qmckl_numprec_type.h" - Data structure for the info related to the atomic orbitals - basis set. +#include "qmckl_memory_private_func.h" +#include "qmckl_context_func.h" - #+BEGIN_SRC C :comments org :tangle qmckl_context.c -typedef struct qmckl_ao_basis_struct { + #+end_src - int64_t shell_num; - int64_t prim_num; - int64_t * shell_center; - int32_t * shell_ang_mom; - double * shell_factor; - double * exponent ; - double * coefficient ; - int64_t * shell_prim_num; - char type; +* Context handling -} qmckl_ao_basis_struct; - #+END_SRC + The context variable is a handle for the state of the library, + and is stored in a data structure which can't be seen outside of + the library. To simplify compatibility with other languages, the + pointer to the internal data structure is converted into a 64-bit + signed integer, defined in the ~qmckl_context~ type. + A value of ~QMCKL_NULL_CONTEXT~ for the context is equivalent to a + ~NULL~ pointer. -**** Source - - The tag is used internally to check if the memory domain pointed - by a pointer is a valid context. + #+NAME: qmckl_context + #+begin_src c :comments org :tangle (eval h_type) +typedef int64_t qmckl_context ; +#define QMCKL_NULL_CONTEXT (qmckl_context) 0 + #+end_src - #+BEGIN_SRC C :comments org :tangle qmckl_context.c + #+begin_src f90 :comments org :tangle (eval fh_type) :exports none + integer , parameter :: qmckl_context = c_int64_t + integer*8, parameter :: QMCKL_NULL_CONTEXT = 0 + #+end_src + + An immutable context would have required to implement a garbage + collector. To keep the library simple, we have chosen to implement + the context as a mutable data structure, so it has to be handled + with care. + + By convention, in this file ~context~ is a ~qmckl_context~ variable + and ~ctx~ is a ~qmckl_context_struct*~ pointer. + +** Data structure + + #+begin_src c :comments org :tangle (eval h_private_type) :noweb yes :exports none typedef struct qmckl_context_struct { + /* -- State of the library -- */ - struct qmckl_context_struct * prev; - - /* Molecular system */ - // struct qmckl_nucleus_struct * nucleus; - // struct qmckl_electron_struct * electron; - struct qmckl_ao_basis_struct * ao_basis; - // struct qmckl_mo_struct * mo; - // struct qmckl_determinant_struct * det; + /* Validity checking */ + uint64_t tag; /* Numerical precision */ - uint32_t tag; - int32_t precision; - int32_t range; + qmckl_numprec_struct numprec; + + /* Thread lock */ + int lock_count; + pthread_mutex_t mutex; + + /* Error handling */ + qmckl_error_struct error; + + /* Memory allocation */ + qmckl_memory_struct memory; + + /* Current date */ + uint64_t date; + + /* -- Molecular system -- */ + qmckl_electron_struct electron; + qmckl_ao_basis_struct ao_basis; + + /* To be implemented: + qmckl_nucleus_struct nucleus; + qmckl_mo_struct mo; + qmckl_determinant_struct det; + ,*/ } qmckl_context_struct; + #+end_src + The context keeps a ``date'' that allows to check which data needs + to be recomputed. The date is incremented when the electron + coordinates are updated. + + When a new element is added to the context, the functions + [[Creation][qmckl_context_create]], [[Destroy][qmckl_context_destroy]] and [[Copy][qmckl_context_copy]] + should be updated inorder to make deep copies. + + + A tag is used internally to check if the memory domain pointed + by a pointer is a valid context. This allows to check that even if + the pointer associated with a context is non-null, we can still + verify that it points to the expected data structure. + + #+begin_src c :comments org :tangle (eval h_private_type) :noweb yes #define VALID_TAG 0xBEEFFACE #define INVALID_TAG 0xDEADBEEF - #+END_SRC + #+end_src -**** Test :noexport: - #+BEGIN_SRC C :tangle test_qmckl_context.c -qmckl_context context; -qmckl_context new_context; - #+END_SRC + The ~qmckl_context_check~ function checks if the domain pointed by + the pointer is a valid context. It returns the input ~qmckl_context~ + if the context is valid, ~QMCKL_NULL_CONTEXT~ otherwise. - -**** =qmckl_context_check= - - Checks if the domain pointed by the pointer is a valid context. - Returns the input =qmckl_context= if the context is valid, 0 - otherwise. - - #+BEGIN_SRC C :comments org :tangle qmckl.h + #+begin_src c :comments org :tangle (eval h_func) :noexport qmckl_context qmckl_context_check(const qmckl_context context) ; - #+END_SRC + #+end_src -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c + #+begin_src c :tangle (eval c) qmckl_context qmckl_context_check(const qmckl_context context) { - if (context == (qmckl_context) 0) return (qmckl_context) 0; + if (context == QMCKL_NULL_CONTEXT) + return QMCKL_NULL_CONTEXT; - const qmckl_context_struct * ctx = (qmckl_context_struct*) context; + const qmckl_context_struct* const ctx = (const qmckl_context_struct* const) context; - if (ctx->tag != VALID_TAG) return (qmckl_context) 0; + /* Try to access memory */ + if (ctx->tag != VALID_TAG) { + return QMCKL_NULL_CONTEXT; + } return context; } - #+END_SRC + #+end_src -**** =qmckl_context_create= +** Creation + + To create a new context, ~qmckl_context_create()~ should be used. + - Upon success, it returns a pointer to a new context with the ~qmckl_context~ type + - It returns ~QMCKL_NULL_CONTEXT~ upon failure to allocate the internal data structure - To create a new context, use =qmckl_context_create()=. - - On success, returns a pointer to a context using the =qmckl_context= type - - Returns 0 upon failure to allocate the internal data structure - - #+BEGIN_SRC C :comments org :tangle qmckl.h + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none qmckl_context qmckl_context_create(); - #+END_SRC + #+end_src -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c + # Source + #+begin_src c :tangle (eval c) qmckl_context qmckl_context_create() { - qmckl_context_struct* context = - (qmckl_context_struct*) qmckl_malloc ((qmckl_context) 0, sizeof(qmckl_context_struct)); - if (context == NULL) { - return (qmckl_context) 0; + qmckl_context_struct* const ctx = + (qmckl_context_struct* const) malloc (sizeof(qmckl_context_struct)); + + if (ctx == NULL) { + return QMCKL_NULL_CONTEXT; } - context->prev = NULL; - context->ao_basis = NULL; - context->precision = QMCKL_DEFAULT_PRECISION; - context->range = QMCKL_DEFAULT_RANGE; - context->tag = VALID_TAG; + /* Set all pointers and values to NULL */ + { + memset(ctx, 0, sizeof(qmckl_context_struct)); + } - return (qmckl_context) context; + /* Initialize lock */ + { + pthread_mutexattr_t attr; + int rc; + + rc = pthread_mutexattr_init(&attr); + assert (rc == 0); + + (void) pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); + + rc = pthread_mutex_init ( &(ctx->mutex), &attr); + assert (rc == 0); + + (void) pthread_mutexattr_destroy(&attr); + } + + /* Initialize data */ + ctx->tag = VALID_TAG; + + const qmckl_context context = (const qmckl_context) ctx; + assert ( qmckl_context_check(context) != QMCKL_NULL_CONTEXT ); + + ctx->numprec.precision = QMCKL_DEFAULT_PRECISION; + ctx->numprec.range = QMCKL_DEFAULT_RANGE; + + ctx->ao_basis.uninitialized = (1 << 10) - 1; + ctx->electron.uninitialized = (1 << 2) - 1; + + /* Allocate qmckl_memory_struct */ + { + const size_t size = 128L; + qmckl_memory_info_struct * new_array = calloc(size, sizeof(qmckl_memory_info_struct)); + if (new_array == NULL) { + free(ctx); + return QMCKL_NULL_CONTEXT; + } + memset( &(new_array[0]), 0, size * sizeof(qmckl_memory_info_struct) ); + + ctx->memory.element = new_array; + ctx->memory.array_size = size; + ctx->memory.n_allocated = (size_t) 0; + } + + return (qmckl_context) ctx; } - #+END_SRC + #+end_src -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) :exports none interface - integer (c_int64_t) function qmckl_context_create() bind(C) + integer (qmckl_context) function qmckl_context_create() bind(C) use, intrinsic :: iso_c_binding + import end function qmckl_context_create end interface - #+END_SRC + #+end_src -***** Test :noexport: - #+BEGIN_SRC C :comments link :tangle test_qmckl_context.c -context = qmckl_context_create(); -munit_assert_int64( context, !=, (qmckl_context) 0); -munit_assert_int64( qmckl_context_check(context), ==, context); - #+END_SRC + # Test + #+begin_src c :comments link :tangle (eval c_test) :exports none +munit_assert_int64( qmckl_context_check(QMCKL_NULL_CONTEXT), ==, QMCKL_NULL_CONTEXT); -**** =qmckl_context_copy= +qmckl_context context = qmckl_context_create(); +munit_assert_int64( context, !=, QMCKL_NULL_CONTEXT ); +munit_assert_int64( qmckl_context_check(context), ==, context ); + #+end_src - This function makes a shallow copy of the current context. - - Copying the 0-valued context returns 0 - - On success, returns a pointer to the new context using the =qmckl_context= type - - Returns 0 upon failure to allocate the internal data structure - for the new context +** Locking - #+BEGIN_SRC C :comments org :tangle qmckl.h + For thread safety, the context may be locked/unlocked. The lock is + initialized with the ~PTHREAD_MUTEX_RECURSIVE~ attribute, and the + number of times the thread has locked it is saved in the + ~lock_count~ attribute. + + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none +void qmckl_lock (qmckl_context context); +void qmckl_unlock(qmckl_context context); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +void qmckl_lock(qmckl_context context) { + if (context == QMCKL_NULL_CONTEXT) + return ; + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + errno = 0; + int rc = pthread_mutex_lock( &(ctx->mutex) ); + if (rc != 0) { + fprintf(stderr, "DEBUG qmckl_lock:%s\n", strerror(rc) ); + fflush(stderr); + } + assert (rc == 0); + ctx->lock_count += 1; +/* + printf(" lock : %d\n", ctx->lock_count); +,*/ +} + +void qmckl_unlock(const qmckl_context context) { + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + int rc = pthread_mutex_unlock( &(ctx->mutex) ); + if (rc != 0) { + fprintf(stderr, "DEBUG qmckl_unlock:%s\n", strerror(rc) ); + fflush(stderr); + } + assert (rc == 0); + ctx->lock_count -= 1; +/* + printf("unlock : %d\n", ctx->lock_count); +,*/ +} + #+end_src + +** TODO Copy + + ~qmckl_context_copy~ makes a deep copy of a context. It returns + ~QMCKL_NULL_CONTEXT~ upon failure. + + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none qmckl_context qmckl_context_copy(const qmckl_context context); - #+END_SRC + #+end_src -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c + + # Source + #+begin_src c :tangle (eval c) qmckl_context qmckl_context_copy(const qmckl_context context) { const qmckl_context checked_context = qmckl_context_check(context); - if (checked_context == (qmckl_context) 0) { - return (qmckl_context) 0; + if (checked_context == QMCKL_NULL_CONTEXT) { + return QMCKL_NULL_CONTEXT; } - qmckl_context_struct* old_context = (qmckl_context_struct*) checked_context; - - qmckl_context_struct* new_context = - (qmckl_context_struct*) qmckl_malloc (context, sizeof(qmckl_context_struct)); - if (new_context == NULL) { - return (qmckl_context) 0; + /* + qmckl_lock(context); + { + + const qmckl_context_struct* const old_ctx = + (qmckl_context_struct* const) checked_context; + + qmckl_context_struct* const new_ctx = + (qmckl_context_struct* const) malloc (context, sizeof(qmckl_context_struct)); + + if (new_ctx == NULL) { + qmckl_unlock(context); + return QMCKL_NULL_CONTEXT; + } + + * Copy the old context on the new one * + * TODO Deep copies should be done here * + memcpy(new_ctx, old_ctx, sizeof(qmckl_context_struct)); + + qmckl_unlock( (qmckl_context) new_ctx ); + + return (qmckl_context) new_ctx; } - - new_context->prev = old_context; - new_context->ao_basis = old_context->ao_basis; - new_context->precision = old_context->precision; - new_context->range = old_context->range; - new_context->tag = VALID_TAG; - - return (qmckl_context) new_context; + qmckl_unlock(context); +*/ + return QMCKL_NULL_CONTEXT; } - #+END_SRC + #+end_src -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) :exports none interface - integer (c_int64_t) function qmckl_context_copy(context) bind(C) + integer (qmckl_context) function qmckl_context_copy(context) bind(C) use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context + import + integer (qmckl_context), intent(in), value :: context end function qmckl_context_copy end interface - #+END_SRC + #+end_src -***** Test :noexport: - #+BEGIN_SRC C :comments link :tangle test_qmckl_context.c -new_context = qmckl_context_copy(context); -munit_assert_int64(new_context, !=, (qmckl_context) 0); + # Test + #+begin_src c :comments link :tangle (eval c_test) :exports none +/* +qmckl_context new_context = qmckl_context_copy(context); +munit_assert_int64(new_context, !=, QMCKL_NULL_CONTEXT); munit_assert_int64(new_context, !=, context); munit_assert_int64(qmckl_context_check(new_context), ==, new_context); - #+END_SRC +*/ + #+end_src -**** =qmckl_context_previous= +** Destroy - Returns the previous context - - On success, returns the ancestor of the current context - - Returns 0 for the initial context - - Returns 0 for the 0-valued context + The context is destroyed with ~qmckl_context_destroy~, leaving the ancestors untouched. + It frees the context, and returns the previous context. - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_context qmckl_context_previous(const qmckl_context context); - #+END_SRC + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none +qmckl_exit_code qmckl_context_destroy(const qmckl_context context); + #+end_src -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_context qmckl_context_previous(const qmckl_context context) { - - const qmckl_context checked_context = qmckl_context_check(context); - if (checked_context == (qmckl_context) 0) { - return (qmckl_context) 0; - } - - const qmckl_context_struct* ctx = (qmckl_context_struct*) checked_context; - return qmckl_context_check((qmckl_context) ctx->prev); -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int64_t) function qmckl_context_previous(context) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - end function qmckl_context_previous - end interface - #+END_SRC - -***** Test :noexport: - #+BEGIN_SRC C :comments link :tangle test_qmckl_context.c -munit_assert_int64(qmckl_context_previous(new_context), !=, (qmckl_context) 0); -munit_assert_int64(qmckl_context_previous(new_context), ==, context); -munit_assert_int64(qmckl_context_previous(context), ==, (qmckl_context) 0); -munit_assert_int64(qmckl_context_previous((qmckl_context) 0), ==, (qmckl_context) 0); - #+END_SRC - -**** =qmckl_context_destroy= - - Destroys the current context, leaving the ancestors untouched. - - Succeeds if the current context is properly destroyed - - Fails otherwise - - Fails if the 0-valued context is given in argument - - Fails if the the pointer is not a valid context - - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_exit_code qmckl_context_destroy(qmckl_context context); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c + # Source + #+begin_src c :tangle (eval c) qmckl_exit_code qmckl_context_destroy(const qmckl_context context) { const qmckl_context checked_context = qmckl_context_check(context); - if (checked_context == (qmckl_context) 0) return QMCKL_FAILURE; + if (checked_context == QMCKL_NULL_CONTEXT) return QMCKL_INVALID_CONTEXT; - qmckl_context_struct* ctx = (qmckl_context_struct*) context; - if (ctx == NULL) return QMCKL_FAILURE; + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); /* Shouldn't be possible because the context is valid */ + + qmckl_lock(context); + { + /* Memory: Remove all allocated data */ + for (size_t pos = (size_t) 0 ; pos < ctx->memory.array_size ; ++pos) { + if (ctx->memory.element[pos].pointer != NULL) { + free(ctx->memory.element[pos].pointer); + memset( &(ctx->memory.element[pos]), 0, sizeof(qmckl_memory_info_struct) ); + ctx->memory.n_allocated -= 1; + } + } + assert (ctx->memory.n_allocated == (size_t) 0); + free(ctx->memory.element); + ctx->memory.element = NULL; + ctx->memory.array_size = (size_t) 0; + } + qmckl_unlock(context); ctx->tag = INVALID_TAG; - qmckl_free(ctx); + + const int rc_destroy = pthread_mutex_destroy( &(ctx->mutex) ); + if (rc_destroy != 0) { +/* DEBUG */ + fprintf(stderr, "qmckl_context_destroy: %s (count = %d)\n", strerror(rc_destroy), ctx->lock_count); + abort(); + } + + free(ctx); + return QMCKL_SUCCESS; } - #+END_SRC + #+end_src -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) :exports none interface - integer (c_int32_t) function qmckl_context_destroy(context) bind(C) + integer (qmckl_exit_code) function qmckl_context_destroy(context) bind(C) use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context + import + integer (qmckl_context), intent(in), value :: context end function qmckl_context_destroy end interface - #+END_SRC + #+end_src -***** Test :noexport: - #+BEGIN_SRC C :tangle test_qmckl_context.c -munit_assert_int64(qmckl_context_check(new_context), ==, new_context); -munit_assert_int64(new_context, !=, (qmckl_context) 0); -munit_assert_int32(qmckl_context_destroy(new_context), ==, QMCKL_SUCCESS); -munit_assert_int64(qmckl_context_check(new_context), !=, new_context); -munit_assert_int64(qmckl_context_check(new_context), ==, (qmckl_context) 0); -munit_assert_int64(qmckl_context_destroy((qmckl_context) 0), ==, QMCKL_FAILURE); - #+END_SRC + # Test + #+begin_src c :tangle (eval c_test) :exports none +/* Destroy valid context */ +munit_assert_int64(qmckl_context_check(context), ==, context); +munit_assert_int32(qmckl_context_destroy(context), ==, QMCKL_SUCCESS); -*** Basis set +/* Check that context is destroyed */ +munit_assert_int64(qmckl_context_check(context), !=, context); +munit_assert_int64(qmckl_context_check(context), ==, QMCKL_NULL_CONTEXT); - For H_2 with the following basis set, +/* Destroy invalid context */ +munit_assert_int32(qmckl_context_destroy(QMCKL_NULL_CONTEXT), ==, QMCKL_INVALID_CONTEXT); + #+end_src - #+BEGIN_EXAMPLE -HYDROGEN -S 5 -1 3.387000E+01 6.068000E-03 -2 5.095000E+00 4.530800E-02 -3 1.159000E+00 2.028220E-01 -4 3.258000E-01 5.039030E-01 -5 1.027000E-01 3.834210E-01 -S 1 -1 3.258000E-01 1.000000E+00 -S 1 -1 1.027000E-01 1.000000E+00 -P 1 -1 1.407000E+00 1.000000E+00 -P 1 -1 3.880000E-01 1.000000E+00 -D 1 -1 1.057000E+00 1.0000000 - #+END_EXAMPLE +* End of files :noexport: - we have: - #+BEGIN_EXAMPLE -type = 'G' -shell_num = 12 -prim_num = 20 -SHELL_CENTER = [1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2] -SHELL_ANG_MOM = ['S', 'S', 'S', 'P', 'P', 'D', 'S', 'S', 'S', 'P', 'P', 'D'] -SHELL_PRIM_NUM = [5, 1, 1, 1, 1, 1, 5, 1, 1, 1, 1, 1] -prim_index = [1, 6, 7, 8, 9, 10, 11, 16, 17, 18, 19, 20] -EXPONENT = [ 33.87, 5.095, 1.159, 0.3258, 0.1027, 0.3258, 0.1027, - 1.407, 0.388, 1.057, 33.87, 5.095, 1.159, 0.3258, 0.1027, - 0.3258, 0.1027, 1.407, 0.388, 1.057] -COEFFICIENT = [ 0.006068, 0.045308, 0.202822, 0.503903, 0.383421, - 1.0, 1.0, 1.0, 1.0, 1.0, 0.006068, 0.045308, 0.202822, - 0.503903, 0.383421, 1.0, 1.0, 1.0, 1.0, 1.0] - #+END_EXAMPLE + #+begin_src c :comments link :tangle (eval h_private_type) +#endif + #+end_src -**** =qmckl_context_update_ao_basis= - - Updates the data describing the AO basis set into the context. - - | =type= | Gaussian or Slater | - | =shell_num= | Number of shells | - | =prim_num= | Total number of primitives | - | =SHELL_CENTER(shell_num)= | Id of the nucleus on which the shell is centered | - | =SHELL_ANG_MOM(shell_num)= | Id of the nucleus on which the shell is centered | - | =SHELL_FACTOR(shell_num)= | Normalization factor for the shell | - | =SHELL_PRIM_NUM(shell_num)= | Number of primitives in the shell | - | =SHELL_PRIM_INDEX(shell_num)= | Address of the first primitive of the shelll in the =EXPONENT= array | - | =EXPONENT(prim_num)= | Array of exponents | - | =COEFFICIENT(prim_num)= | Array of coefficients | - - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_exit_code -qmckl_context_update_ao_basis(qmckl_context context , const char type, - const int64_t shell_num , const int64_t prim_num, - const int64_t * SHELL_CENTER, const int32_t * SHELL_ANG_MOM, - const double * SHELL_FACTOR, const int64_t * SHELL_PRIM_NUM, - const int64_t * SHELL_PRIM_INDEX, - const double * EXPONENT , const double * COEFFICIENT); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_exit_code -qmckl_context_update_ao_basis(qmckl_context context , const char type, - const int64_t shell_num , const int64_t prim_num, - const int64_t * SHELL_CENTER, const int32_t * SHELL_ANG_MOM, - const double * SHELL_FACTOR, const int64_t * SHELL_PRIM_NUM, - const int64_t * SHELL_PRIM_INDEX, - const double * EXPONENT , const double * COEFFICIENT) -{ - - int64_t i; - - /* Check input */ - - if (type != 'G' && type != 'S') return QMCKL_FAILURE; - if (shell_num <= 0) return QMCKL_FAILURE; - if (prim_num <= 0) return QMCKL_FAILURE; - if (prim_num < shell_num) return QMCKL_FAILURE; - - for (i=0 ; ishell_center = (int64_t*) malloc (shell_num * sizeof(int64_t)); - if (basis->shell_center == NULL) { - free(basis); - return QMCKL_FAILURE; - } - - basis->shell_ang_mom = (int32_t*) malloc (shell_num * sizeof(int32_t)); - if (basis->shell_ang_mom == NULL) { - free(basis->shell_center); - free(basis); - return QMCKL_FAILURE; - } - - basis->shell_prim_num= (int64_t*) malloc (shell_num * sizeof(int64_t)); - if (basis->shell_prim_num == NULL) { - free(basis->shell_ang_mom); - free(basis->shell_center); - free(basis); - return QMCKL_FAILURE; - } - - basis->shell_factor = (double *) malloc (shell_num * sizeof(double )); - if (basis->shell_factor == NULL) { - free(basis->shell_prim_num); - free(basis->shell_ang_mom); - free(basis->shell_center); - free(basis); - return QMCKL_FAILURE; - } - - basis->exponent = (double *) malloc (prim_num * sizeof(double )); - if (basis->exponent == NULL) { - free(basis->shell_factor); - free(basis->shell_prim_num); - free(basis->shell_ang_mom); - free(basis->shell_center); - free(basis); - return QMCKL_FAILURE; - } - - basis->coefficient = (double *) malloc (prim_num * sizeof(double )); - if (basis->coefficient == NULL) { - free(basis->exponent); - free(basis->shell_factor); - free(basis->shell_prim_num); - free(basis->shell_ang_mom); - free(basis->shell_center); - free(basis); - return QMCKL_FAILURE; - } - - - /* Assign data */ - - basis->type = type; - basis->shell_num = shell_num; - basis->prim_num = prim_num; - - for (i=0 ; ishell_center [i] = SHELL_CENTER [i]; - basis->shell_ang_mom [i] = SHELL_ANG_MOM [i]; - basis->shell_prim_num[i] = SHELL_PRIM_NUM[i]; - basis->shell_factor [i] = SHELL_FACTOR [i]; - } - - for (i=0 ; iexponent [i] = EXPONENT[i]; - basis->coefficient[i] = COEFFICIENT[i]; - } - - ctx->ao_basis = basis; - return QMCKL_SUCCESS; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int32_t) function qmckl_context_update_ao_basis(context, & - typ, shell_num, prim_num, SHELL_CENTER, SHELL_ANG_MOM, SHELL_FACTOR, & - SHELL_PRIM_NUM, SHELL_PRIM_INDEX, EXPONENT, COEFFICIENT) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - character(c_char) , intent(in), value :: typ - integer (c_int64_t), intent(in), value :: shell_num - integer (c_int64_t), intent(in), value :: prim_num - integer (c_int64_t), intent(in) :: SHELL_CENTER(shell_num) - integer (c_int32_t), intent(in) :: SHELL_ANG_MOM(shell_num) - double precision , intent(in) :: SHELL_FACTOR(shell_num) - integer (c_int64_t), intent(in) :: SHELL_PRIM_NUM(shell_num) - integer (c_int64_t), intent(in) :: SHELL_PRIM_INDEX(shell_num) - double precision , intent(in) :: EXPONENT(prim_num) - double precision , intent(in) :: COEFFICIENT(prim_num) - end function qmckl_context_update_ao_basis - end interface - #+END_SRC - -***** TODO Test - -**** =qmckl_context_set_ao_basis= - - Sets the data describing the AO basis set into the context. - - | =type= | Gaussian or Slater | - | =shell_num= | Number of shells | - | =prim_num= | Total number of primitives | - | =SHELL_CENTER(shell_num)= | Id of the nucleus on which the shell is centered | - | =SHELL_ANG_MOM(shell_num)= | Id of the nucleus on which the shell is centered | - | =SHELL_FACTOR(shell_num)= | Normalization factor for the shell | - | =SHELL_PRIM_NUM(shell_num)= | Number of primitives in the shell | - | =SHELL_PRIM_INDEX(shell_num)= | Address of the first primitive of the shelll in the =EXPONENT= array | - | =EXPONENT(prim_num)= | Array of exponents | - | =COEFFICIENT(prim_num)= | Array of coefficients | - - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_context -qmckl_context_set_ao_basis(const qmckl_context context , const char type, - const int64_t shell_num , const int64_t prim_num, - const int64_t * SHELL_CENTER, const int32_t * SHELL_ANG_MOM, - const double * SHELL_FACTOR, const int64_t * SHELL_PRIM_NUM, - const int64_t * SHELL_PRIM_INDEX, - const double * EXPONENT , const double * COEFFICIENT); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_context -qmckl_context_set_ao_basis(const qmckl_context context , const char type, - const int64_t shell_num , const int64_t prim_num, - const int64_t * SHELL_CENTER, const int32_t * SHELL_ANG_MOM, - const double * SHELL_FACTOR, const int64_t * SHELL_PRIM_NUM, - const int64_t * SHELL_PRIM_INDEX, - const double * EXPONENT , const double * COEFFICIENT) -{ - - qmckl_context new_context = qmckl_context_copy(context); - if (new_context == 0) return 0; - - if (qmckl_context_update_ao_basis(context, type, shell_num, prim_num, - SHELL_CENTER, SHELL_ANG_MOM, SHELL_FACTOR, - SHELL_PRIM_NUM, SHELL_PRIM_INDEX, EXPONENT, - COEFFICIENT - ) == QMCKL_FAILURE) - return 0; - - return new_context; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int64_t) function qmckl_context_set_ao_basis(context, & - typ, shell_num, prim_num, SHELL_CENTER, SHELL_ANG_MOM, SHELL_FACTOR, & - SHELL_PRIM_NUM, SHELL_PRIM_INDEX, EXPONENT, COEFFICIENT) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - character(c_char) , intent(in), value :: typ - integer (c_int64_t), intent(in), value :: shell_num - integer (c_int64_t), intent(in), value :: prim_num - integer (c_int64_t), intent(in) :: SHELL_CENTER(shell_num) - integer (c_int32_t), intent(in) :: SHELL_ANG_MOM(shell_num) - double precision , intent(in) :: SHELL_FACTOR(shell_num) - integer (c_int64_t), intent(in) :: SHELL_PRIM_NUM(shell_num) - integer (c_int64_t), intent(in) :: SHELL_PRIM_INDEX(shell_num) - double precision , intent(in) :: EXPONENT(prim_num) - double precision , intent(in) :: COEFFICIENT(prim_num) - end function qmckl_context_set_ao_basis - end interface - #+END_SRC - -***** TODO Test - -*** Precision - - The following functions set and get the expected required - precision and range. =precision= should be an integer between 2 - and 53, and =range= should be an integer between 2 and 11. - - The setter functions functions return a new context as a 64-bit - integer. The getter functions return the value, as a 32-bit - integer. The update functions return =QMCKL_SUCCESS= or - =QMCKL_FAILURE=. - -**** =qmckl_context_update_precision= - Modifies the parameter for the numerical precision in a given context. - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_exit_code qmckl_context_update_precision(const qmckl_context context, const int precision); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_exit_code qmckl_context_update_precision(const qmckl_context context, const int precision) { - - if (precision < 2) return QMCKL_FAILURE; - if (precision > 53) return QMCKL_FAILURE; - - qmckl_context_struct* ctx = (qmckl_context_struct*) context; - if (ctx == NULL) return QMCKL_FAILURE; - - ctx->precision = precision; - return QMCKL_SUCCESS; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int32_t) function qmckl_context_update_precision(context, precision) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - integer (c_int32_t), intent(in), value :: precision - end function qmckl_context_update_precision - end interface - #+END_SRC - -***** TODO Tests :noexport: -**** =qmckl_context_update_range= - Modifies the parameter for the numerical range in a given context. - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_exit_code qmckl_context_update_range(const qmckl_context context, const int range); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_exit_code qmckl_context_update_range(const qmckl_context context, const int range) { - - if (range < 2) return QMCKL_FAILURE; - if (range > 11) return QMCKL_FAILURE; - - qmckl_context_struct* ctx = (qmckl_context_struct*) context; - if (ctx == NULL) return QMCKL_FAILURE; - - ctx->range = range; - return QMCKL_SUCCESS; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int32_t) function qmckl_context_update_range(context, range) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - integer (c_int32_t), intent(in), value :: range - end function qmckl_context_update_range - end interface - #+END_SRC - -***** TODO Tests :noexport: -**** =qmckl_context_set_precision= - Returns a copy of the context with a different precision parameter. - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_context qmckl_context_set_precision(const qmckl_context context, const int precision); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_context qmckl_context_set_precision(const qmckl_context context, const int precision) { - qmckl_context new_context = qmckl_context_copy(context); - if (new_context == 0) return 0; - - if (qmckl_context_update_precision(context, precision) == QMCKL_FAILURE) return 0; - - return new_context; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int64_t) function qmckl_context_set_precision(context, precision) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - integer (c_int32_t), intent(in), value :: precision - end function qmckl_context_set_precision - end interface - #+END_SRC - -***** TODO Tests :noexport: -**** =qmckl_context_set_range= - Returns a copy of the context with a different precision parameter. - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_context qmckl_context_set_range(const qmckl_context context, const int range); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -qmckl_context qmckl_context_set_range(const qmckl_context context, const int range) { - qmckl_context new_context = qmckl_context_copy(context); - if (new_context == 0) return 0; - - if (qmckl_context_update_range(context, range) == QMCKL_FAILURE) return 0; - - return new_context; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int64_t) function qmckl_context_set_range(context, range) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - integer (c_int32_t), intent(in), value :: range - end function qmckl_context_set_range - end interface - #+END_SRC - -***** TODO Tests :noexport: - -**** =qmckl_context_get_precision= - Returns the value of the numerical precision in the context - #+BEGIN_SRC C :comments org :tangle qmckl.h -int32_t qmckl_context_get_precision(const qmckl_context context); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -int qmckl_context_get_precision(const qmckl_context context) { - const qmckl_context_struct* ctx = (qmckl_context_struct*) context; - return ctx->precision; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int32_t) function qmckl_context_get_precision(context) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - end function qmckl_context_get_precision - end interface - #+END_SRC - -***** TODO Tests :noexport: -**** =qmckl_context_get_range= - Returns the value of the numerical range in the context - #+BEGIN_SRC C :comments org :tangle qmckl.h -int32_t qmckl_context_get_range(const qmckl_context context); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -int qmckl_context_get_range(const qmckl_context context) { - const qmckl_context_struct* ctx = (qmckl_context_struct*) context; - return ctx->range; -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer (c_int32_t) function qmckl_context_get_range(context) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - end function qmckl_context_get_range - end interface - #+END_SRC - -***** TODO Tests :noexport: - -**** =qmckl_context_get_epsilon= - Returns $\epsilon = 2^{1-n}$ where =n= is the precision - #+BEGIN_SRC C :comments org :tangle qmckl.h -double qmckl_context_get_epsilon(const qmckl_context context); - #+END_SRC - -***** Source - #+BEGIN_SRC C :tangle qmckl_context.c -double qmckl_context_get_epsilon(const qmckl_context context) { - const qmckl_context_struct* ctx = (qmckl_context_struct*) context; - return pow(2.0,(double) 1-ctx->precision); -} - #+END_SRC - -***** Fortran interface - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - real (c_double) function qmckl_context_get_epsilon(context) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - end function qmckl_context_get_epsilon - end interface - #+END_SRC - -***** TODO Tests :noexport: - - - -*** End of files :noexport: - -***** Test - #+BEGIN_SRC C :comments link :tangle test_qmckl_context.c +*** Test + #+begin_src c :comments link :tangle (eval c_test) return MUNIT_OK; } - #+END_SRC + #+end_src - - - # -*- mode: org -*- - # vim: syntax=c + diff --git a/src/qmckl_distance.org b/src/qmckl_distance.org index 5eac91d..a4ec5b9 100644 --- a/src/qmckl_distance.org +++ b/src/qmckl_distance.org @@ -1,80 +1,94 @@ -** Computation of distances +#+TITLE: Inter-particle distances +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org - Function for the computation of distances between particles. +Functions for the computation of distances between particles. - 3 files are produced: - - a source file : =qmckl_distance.f90= - - a C test file : =test_qmckl_distance.c= - - a Fortran test file : =test_qmckl_distance_f.f90= +* Headers :noexport: + #+begin_src elisp :noexport :results none +(org-babel-lob-ingest "../tools/lib.org") +#+end_src -**** Headers :noexport: - #+BEGIN_SRC C :comments link :tangle test_qmckl_distance.c + #+begin_src c :comments link :tangle (eval c_test) :noweb yes #include "qmckl.h" #include "munit.h" -MunitResult test_qmckl_distance() { +MunitResult test_<>() { qmckl_context context; context = qmckl_context_create(); - #+END_SRC + #+end_src +* Squared distance -*** Squared distance +** ~qmckl_distance_sq~ + :PROPERTIES: + :Name: qmckl_distance_sq + :CRetType: qmckl_exit_code + :FRetType: qmckl_exit_code + :END: -**** =qmckl_distance_sq= + ~qmckl_distance_sq~ computes the matrix of the squared distances + between all pairs of points in two sets, one point within each set: - Computes the matrix of the squared distances between all pairs of - points in two sets, one point within each set: - \[ - C_{ij} = \sum_{k=1}^3 (A_{k,i}-B_{k,j})^2 - \] + \[ + C_{ij} = \sum_{k=1}^3 (A_{k,i}-B_{k,j})^2 + \] -***** Arguments + #+NAME: qmckl_distance_sq_args + | qmckl_context | context | in | Global state | + | char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed | + | char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed | + | int64_t | m | in | Number of points in the first set | + | int64_t | n | in | Number of points in the second set | + | double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ | + | int64_t | lda | in | Leading dimension of array ~A~ | + | double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ | + | int64_t | ldb | in | Leading dimension of array ~B~ | + | double | C[n][ldc] | out | Array containing the $m \times n$ matrix $C$ | + | int64_t | ldc | in | Leading dimension of array ~C~ | - | =context= | input | Global state | - | =transa= | input | Array =A= is =N=: Normal, =T=: Transposed | - | =transb= | input | Array =B= is =N=: Normal, =T=: Transposed | - | =m= | input | Number of points in the first set | - | =n= | input | Number of points in the second set | - | =A(lda,3)= | input | Array containing the $m \times 3$ matrix $A$ | - | =lda= | input | Leading dimension of array =A= | - | =B(ldb,3)= | input | Array containing the $n \times 3$ matrix $B$ | - | =ldb= | input | Leading dimension of array =B= | - | =C(ldc,n)= | output | Array containing the $m \times n$ matrix $C$ | - | =ldc= | input | Leading dimension of array =C= | +*** Requirements -***** Requirements + - ~context~ is not ~QMCKL_NULL_CONTEXT~ + - ~m > 0~ + - ~n > 0~ + - ~lda >= 3~ if ~transa == 'N'~ + - ~lda >= m~ if ~transa == 'T'~ + - ~ldb >= 3~ if ~transb == 'N'~ + - ~ldb >= n~ if ~transb == 'T'~ + - ~ldc >= m~ + - ~A~ is allocated with at least $3 \times m \times 8$ bytes + - ~B~ is allocated with at least $3 \times n \times 8$ bytes + - ~C~ is allocated with at least $m \times n \times 8$ bytes + +*** C header - - =context= is not 0 - - =m= > 0 - - =n= > 0 - - =lda= >= 3 if =transa= is =N= - - =lda= >= m if =transa= is =T= - - =ldb= >= 3 if =transb= is =N= - - =ldb= >= n if =transb= is =T= - - =ldc= >= m if =transa= is = - - =A= is allocated with at least $3 \times m \times 8$ bytes - - =B= is allocated with at least $3 \times n \times 8$ bytes - - =C= is allocated with at least $m \times n \times 8$ bytes + #+CALL: generate_c_header(table=qmckl_distance_sq_args,rettyp=get_value("CRetType"),fname=get_value("Name")) -***** Performance + #+RESULTS: + #+begin_src c :tangle (eval h_func) :comments org + qmckl_exit_code qmckl_distance_sq ( + const qmckl_context context, + const char transa, + const char transb, + const int64_t m, + const int64_t n, + const double* A, + const int64_t lda, + const double* B, + const int64_t ldb, + double* const C, + const int64_t ldc ); + #+end_src - This function might be more efficient when =A= and =B= are - transposed. - - #+BEGIN_SRC C :comments org :tangle qmckl.h -qmckl_exit_code qmckl_distance_sq(const qmckl_context context, - const char transa, const char transb, - const int64_t m, const int64_t n, - const double *A, const int64_t lda, - const double *B, const int64_t ldb, - const double *C, const int64_t ldc); - #+END_SRC - -***** Source - #+BEGIN_SRC f90 :tangle qmckl_distance.f90 -integer function qmckl_distance_sq_f(context, transa, transb, m, n, A, LDA, B, LDB, C, LDC) result(info) +*** Source + #+begin_src f90 :tangle (eval f) +integer function qmckl_distance_sq_f(context, transa, transb, m, n, & + A, LDA, B, LDB, C, LDC) & + result(info) + use qmckl implicit none - integer*8 , intent(in) :: context + integer(qmckl_context) , intent(in) :: context character , intent(in) :: transa, transb integer*8 , intent(in) :: m, n integer*8 , intent(in) :: lda @@ -88,20 +102,20 @@ integer function qmckl_distance_sq_f(context, transa, transb, m, n, A, LDA, B, L real*8 :: x, y, z integer :: transab - info = 0 + info = QMCKL_SUCCESS - if (context == 0_8) then - info = -1 + if (context == QMCKL_NULL_CONTEXT) then + info = QMCKL_INVALID_CONTEXT return endif if (m <= 0_8) then - info = -2 + info = QMCKL_INVALID_ARG_4 return endif if (n <= 0_8) then - info = -3 + info = QMCKL_INVALID_ARG_5 return endif @@ -122,33 +136,33 @@ integer function qmckl_distance_sq_f(context, transa, transb, m, n, A, LDA, B, L endif if (transab < 0) then - info = -4 + info = QMCKL_INVALID_ARG_1 return endif if (iand(transab,1) == 0 .and. LDA < 3) then - info = -5 + info = QMCKL_INVALID_ARG_7 return endif if (iand(transab,1) == 1 .and. LDA < m) then - info = -6 + info = QMCKL_INVALID_ARG_7 return endif if (iand(transab,2) == 0 .and. LDA < 3) then - info = -6 + info = QMCKL_INVALID_ARG_7 return endif if (iand(transab,2) == 2 .and. LDA < m) then - info = -7 + info = QMCKL_INVALID_ARG_7 return endif select case (transab) - + case(0) do j=1,n @@ -194,56 +208,81 @@ integer function qmckl_distance_sq_f(context, transa, transb, m, n, A, LDA, B, L end do end select - + end function qmckl_distance_sq_f - #+END_SRC + #+end_src + +*** Performance -***** C interface :noexport: - #+BEGIN_SRC f90 :tangle qmckl_distance.f90 -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, transb - integer (c_int64_t) , intent(in) , value :: m, n - integer (c_int64_t) , intent(in) , value :: lda - real (c_double) , intent(in) :: A(lda,3) - integer (c_int64_t) , intent(in) , value :: ldb - real (c_double) , intent(in) :: B(ldb,3) - integer (c_int64_t) , intent(in) , value :: ldc - real (c_double) , intent(out) :: C(ldc,n) + This function might be more efficient when ~A~ and ~B~ are + transposed. - integer, 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 +** C interface :noexport: - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - integer(c_int32_t) function qmckl_distance_sq(context, transa, transb, m, n, A, LDA, B, LDB, C, LDC) & - bind(C) + #+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 , intent(in) , value :: transa + character , 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")) + + #+RESULTS: + #+begin_src f90 :tangle (eval fh_func) :comments org :exports none + interface + integer(c_int32_t) 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, transb - integer (c_int64_t) , intent(in) , value :: m, 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,3) - real (c_double) , intent(in) :: B(ldb,3) - real (c_double) , intent(out) :: C(ldc,n) - end function qmckl_distance_sq - end interface - #+END_SRC -***** Test :noexport: - #+BEGIN_SRC f90 :tangle test_qmckl_distance_f.f90 -integer(c_int32_t) function test_qmckl_distance_sq(context) bind(C) + integer (c_int64_t) , intent(in) , value :: context + character , intent(in) , value :: transa + character , 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 + + end function qmckl_distance_sq + end interface + #+end_src + +*** Test :noexport: + #+begin_src f90 :tangle (eval f_test) +integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C) use qmckl implicit none - integer(c_int64_t), intent(in), value :: context + integer(qmckl_context), intent(in), value :: context double precision, allocatable :: A(:,:), B(:,:), C(:,:) integer*8 :: m, n, LDA, LDB, LDC @@ -269,13 +308,19 @@ integer(c_int32_t) function test_qmckl_distance_sq(context) bind(C) end do end do - test_qmckl_distance_sq = qmckl_distance_sq(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC) + test_qmckl_distance_sq = & + qmckl_distance_sq(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC) + if (test_qmckl_distance_sq == 0) return - test_qmckl_distance_sq = qmckl_distance_sq(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC) + test_qmckl_distance_sq = & + qmckl_distance_sq(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC) + if (test_qmckl_distance_sq == 0) return - test_qmckl_distance_sq = qmckl_distance_sq(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC) + test_qmckl_distance_sq = & + qmckl_distance_sq(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC) + if (test_qmckl_distance_sq /= 0) return test_qmckl_distance_sq = -1 @@ -288,8 +333,10 @@ integer(c_int32_t) function test_qmckl_distance_sq(context) bind(C) if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return end do end do - - test_qmckl_distance_sq = qmckl_distance_sq(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC) + + test_qmckl_distance_sq = & + qmckl_distance_sq(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC) + if (test_qmckl_distance_sq /= 0) return test_qmckl_distance_sq = -1 @@ -303,7 +350,9 @@ integer(c_int32_t) function test_qmckl_distance_sq(context) bind(C) end do end do - test_qmckl_distance_sq = qmckl_distance_sq(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC) + test_qmckl_distance_sq = & + qmckl_distance_sq(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC) + if (test_qmckl_distance_sq /= 0) return test_qmckl_distance_sq = -1 @@ -317,7 +366,9 @@ integer(c_int32_t) function test_qmckl_distance_sq(context) bind(C) end do end do - test_qmckl_distance_sq = qmckl_distance_sq(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC) + test_qmckl_distance_sq = & + qmckl_distance_sq(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC) + if (test_qmckl_distance_sq /= 0) return test_qmckl_distance_sq = -1 @@ -330,27 +381,405 @@ integer(c_int32_t) function test_qmckl_distance_sq(context) bind(C) if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return end do end do - + test_qmckl_distance_sq = 0 - + deallocate(A,B,C) end function test_qmckl_distance_sq - #+END_SRC + #+end_src - #+BEGIN_SRC C :comments link :tangle test_qmckl_distance.c + #+begin_src c :comments link :tangle (eval c_test) int test_qmckl_distance_sq(qmckl_context context); munit_assert_int(0, ==, test_qmckl_distance_sq(context)); - #+END_SRC -*** End of files :noexport: + #+end_src +* Distance - #+BEGIN_SRC C :comments link :tangle test_qmckl_distance.c +** ~qmckl_distance~ + :PROPERTIES: + :Name: qmckl_distance + :CRetType: qmckl_exit_code + :FRetType: qmckl_exit_code + :END: + + ~qmckl_distance~ computes the matrix of the distances between all + pairs of points in two sets, one point within each set: + + \[ + C_{ij} = \sqrt{\sum_{k=1}^3 (A_{k,i}-B_{k,j})^2} + \] + + #+NAME: qmckl_distance_args + | qmckl_context | context | in | Global state | + | char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed | + | char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed | + | int64_t | m | in | Number of points in the first set | + | int64_t | n | in | Number of points in the second set | + | double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ | + | int64_t | lda | in | Leading dimension of array ~A~ | + | double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ | + | int64_t | ldb | in | Leading dimension of array ~B~ | + | double | C[n][ldc] | out | Array containing the $m \times n$ matrix $C$ | + | int64_t | ldc | in | Leading dimension of array ~C~ | + +*** Requirements + + - ~context~ is not ~QMCKL_NULL_CONTEXT~ + - ~m > 0~ + - ~n > 0~ + - ~lda >= 3~ if ~transa == 'N'~ + - ~lda >= m~ if ~transa == 'T'~ + - ~ldb >= 3~ if ~transb == 'N'~ + - ~ldb >= n~ if ~transb == 'T'~ + - ~ldc >= m~ + - ~A~ is allocated with at least $3 \times m \times 8$ bytes + - ~B~ is allocated with at least $3 \times n \times 8$ bytes + - ~C~ is allocated with at least $m \times n \times 8$ bytes + +*** C header + + #+CALL: generate_c_header(table=qmckl_distance_args,rettyp=get_value("CRetType"),fname=get_value("Name")) + + #+RESULTS: + #+begin_src c :tangle (eval h_func) :comments org + qmckl_exit_code qmckl_distance ( + const qmckl_context context, + const char transa, + const char transb, + const int64_t m, + const int64_t n, + const double* A, + const int64_t lda, + const double* B, + const int64_t ldb, + double* const C, + const int64_t ldc ); + #+end_src + +*** Source + #+begin_src f90 :tangle (eval f) +integer function qmckl_distance_f(context, transa, transb, m, n, & + A, LDA, B, LDB, C, LDC) & + result(info) + use qmckl + 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*8 :: i,j + real*8 :: x, y, z + integer :: transab + + info = QMCKL_SUCCESS + + if (context == QMCKL_NULL_CONTEXT) then + info = QMCKL_INVALID_CONTEXT + return + endif + + if (m <= 0_8) then + info = QMCKL_INVALID_ARG_4 + return + endif + + if (n <= 0_8) then + info = QMCKL_INVALID_ARG_5 + return + endif + + if (transa == 'N' .or. transa == 'n') then + transab = 0 + else if (transa == 'T' .or. transa == 't') then + transab = 1 + else + transab = -100 + endif + + if (transb == 'N' .or. transb == 'n') then + continue + else if (transa == 'T' .or. transa == 't') then + transab = transab + 2 + else + transab = -100 + endif + + if (transab < 0) then + info = QMCKL_INVALID_ARG_1 + return + endif + + if (iand(transab,1) == 0 .and. LDA < 3) then + info = QMCKL_INVALID_ARG_7 + return + endif + + if (iand(transab,1) == 1 .and. LDA < m) then + info = QMCKL_INVALID_ARG_7 + return + endif + + if (iand(transab,2) == 0 .and. LDA < 3) then + info = QMCKL_INVALID_ARG_7 + return + endif + + if (iand(transab,2) == 2 .and. LDA < m) then + info = QMCKL_INVALID_ARG_7 + return + endif + + + select case (transab) + + case(0) + + do j=1,n + do i=1,m + x = A(1,i) - B(1,j) + y = A(2,i) - B(2,j) + z = A(3,i) - B(3,j) + C(i,j) = x*x + y*y + z*z + end do + C(:,j) = dsqrt(C(:,j)) + end do + + case(1) + + do j=1,n + do i=1,m + x = A(i,1) - B(1,j) + y = A(i,2) - B(2,j) + z = A(i,3) - B(3,j) + C(i,j) = x*x + y*y + z*z + end do + C(:,j) = dsqrt(C(:,j)) + end do + + case(2) + + do j=1,n + do i=1,m + x = A(1,i) - B(j,1) + y = A(2,i) - B(j,2) + z = A(3,i) - B(j,3) + C(i,j) = x*x + y*y + z*z + end do + C(:,j) = dsqrt(C(:,j)) + end do + + case(3) + + do j=1,n + do i=1,m + x = A(i,1) - B(j,1) + y = A(i,2) - B(j,2) + z = A(i,3) - B(j,3) + C(i,j) = x*x + y*y + z*z + end do + C(:,j) = dsqrt(C(:,j)) + end do + + end select + +end function qmckl_distance_f + #+end_src + +*** Performance + + This function might be 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 , intent(in) , value :: transa + character , 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")) + + #+RESULTS: + #+begin_src f90 :tangle (eval fh_func) :comments org :exports none + interface + integer(c_int32_t) 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 , intent(in) , value :: transa + character , 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 + + end function qmckl_distance + end interface + #+end_src + +*** Test :noexport: + #+begin_src f90 :tangle (eval f_test) +integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C) + use qmckl + implicit none + integer(qmckl_context), intent(in), value :: context + + double precision, allocatable :: A(:,:), B(:,:), C(:,:) + integer*8 :: m, n, LDA, LDB, LDC + double precision :: x + integer*8 :: i,j + + m = 5 + n = 6 + LDA = m + LDB = n + LDC = 5 + + allocate( A(LDA,m), B(LDB,n), C(LDC,n) ) + + do j=1,m + do i=1,m + A(i,j) = -10.d0 + dble(i+j) + end do + end do + do j=1,n + do i=1,n + B(i,j) = -1.d0 + dble(i*j) + end do + end do + + test_qmckl_dist = & + qmckl_distance(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC) + + if (test_qmckl_dist == 0) return + + test_qmckl_dist = & + qmckl_distance(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC) + + if (test_qmckl_dist == 0) return + + test_qmckl_dist = & + qmckl_distance(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC) + + if (test_qmckl_dist /= 0) return + + test_qmckl_dist = -1 + + do j=1,n + do i=1,m + x = dsqrt((A(i,1)-B(j,1))**2 + & + (A(i,2)-B(j,2))**2 + & + (A(i,3)-B(j,3))**2) + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return + end do + end do + + test_qmckl_dist = & + qmckl_distance(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC) + + if (test_qmckl_dist /= 0) return + + test_qmckl_dist = -1 + + do j=1,n + do i=1,m + x = dsqrt((A(1,i)-B(j,1))**2 + & + (A(2,i)-B(j,2))**2 + & + (A(3,i)-B(j,3))**2) + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return + end do + end do + + test_qmckl_dist = & + qmckl_distance(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC) + + if (test_qmckl_dist /= 0) return + + test_qmckl_dist = -1 + + do j=1,n + do i=1,m + x = dsqrt((A(i,1)-B(1,j))**2 + & + (A(i,2)-B(2,j))**2 + & + (A(i,3)-B(3,j))**2) + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return + end do + end do + + test_qmckl_dist = & + qmckl_distance(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC) + + if (test_qmckl_dist /= 0) return + + test_qmckl_dist = -1 + + do j=1,n + do i=1,m + x = dsqrt((A(1,i)-B(1,j))**2 + & + (A(2,i)-B(2,j))**2 + & + (A(3,i)-B(3,j))**2) + if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return + end do + end do + + test_qmckl_dist = 0 + + deallocate(A,B,C) +end function test_qmckl_dist + #+end_src + + #+begin_src c :comments link :tangle (eval c_test) +int test_qmckl_dist(qmckl_context context); +munit_assert_int(0, ==, test_qmckl_dist(context)); + #+end_src +* End of files :noexport: + + #+begin_src c :comments link :tangle (eval c_test) if (qmckl_context_destroy(context) != QMCKL_SUCCESS) return QMCKL_FAILURE; return MUNIT_OK; } - #+END_SRC + #+end_src - # -*- mode: org -*- - # vim: syntax=c +# -*- mode: org -*- +# vim: syntax=c diff --git a/src/qmckl_electron.org b/src/qmckl_electron.org new file mode 100644 index 0000000..9bf5c0e --- /dev/null +++ b/src/qmckl_electron.org @@ -0,0 +1,655 @@ +#+TITLE: Electrons +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org + +In conventional QMC simulations, up-spin and down-spin electrons are +different. The ~electron~ data structure contains the number of +up-spin and down-spin electrons, and the electron coordinates. + +* Headers :noexport: + #+begin_src elisp :noexport :results none +(org-babel-lob-ingest "../tools/lib.org") +#+end_src + + + #+begin_src c :tangle (eval h_private_type) +#ifndef QMCKL_ELECTRON_HPT +#define QMCKL_ELECTRON_HPT +#include + #+end_src + + #+begin_src c :tangle (eval c_test) :noweb yes +#include "qmckl.h" +#include "munit.h" +MunitResult test_<>() { + qmckl_context context; + context = qmckl_context_create(); + #+end_src + + #+begin_src c :tangle (eval c) +#include +#include +#include +#include +#include +#include + +#include + +#include "qmckl_error_type.h" +#include "qmckl_context_type.h" +#include "qmckl_context_private_type.h" +#include "qmckl_memory_private_type.h" + +#include "qmckl_error_func.h" +#include "qmckl_memory_private_func.h" +#include "qmckl_memory_func.h" +#include "qmckl_context_func.h" +#include "qmckl_electron_private_func.h" + #+end_src + +* Context + + The following data stored in the context: + + | ~uninitialized~ | int32_t | Keeps bit set for uninitialized data | + | ~num~ | int64_t | Total number of electrons | + | ~up_num~ | int64_t | Number of up-spin electrons | + | ~down_num~ | int64_t | Number of down-spin electrons | + | ~walk_num~ | int64_t | Number of walkers | + | ~provided~ | bool | If true, ~electron~ is valid | + | ~coord_new~ | double[walk_num][3][num] | New set of electron coordinates | + | ~coord_old~ | double[walk_num][3][num] | Old set of electron coordinates | + | ~coord_new_date~ | uint64_t | Last modification date of the coordinates | + | ~ee_distance~ | double[walk_num][num][num] | Electron-electron distances | + | ~ee_distance_date~ | uint64_t | Last modification date of the electron-electron distances | + +** Data structure + + #+begin_src c :comments org :tangle (eval h_private_type) +typedef struct qmckl_electron_struct { + int64_t num; + int64_t up_num; + int64_t down_num; + int64_t walk_num; + int64_t coord_new_date; + int64_t ee_distance_date; + double* coord_new; + double* coord_old; + double* ee_distance; + int32_t uninitialized; + bool provided; +} qmckl_electron_struct; + #+end_src + + The ~uninitialized~ integer contains one bit set to one for each + initialization function which has not bee called. It becomes equal + to zero after all initialization functions have been called. The + struct is then initialized and ~provided == true~. + +** Access functions + + #+begin_src c :comments org :tangle (eval h_private_func) :exports none +int64_t qmckl_get_electron_num (const qmckl_context context); +int64_t qmckl_get_electron_up_num (const qmckl_context context); +int64_t qmckl_get_electron_down_num (const qmckl_context context); +int64_t qmckl_get_electron_walk_num (const qmckl_context context); +double* qmckl_get_electron_coord_new (const qmckl_context context); +double* qmckl_get_electron_coord_old (const qmckl_context context); + #+end_src + + When all the data relative to electrons have been set, the + following function returns ~true~. + + #+begin_src c :comments org :tangle (eval h_func) +bool qmckl_electron_provided (const qmckl_context context); + #+end_src + + #+NAME:post + #+begin_src c :exports none +if ( (ctx->electron.uninitialized & mask) != 0) { + return NULL; +} + #+end_src + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +int64_t qmckl_get_electron_num (const qmckl_context context) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (char) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1; + + if ( (ctx->electron.uninitialized & mask) != 0) { + return (int64_t) 0; + } + + assert (ctx->electron.num > (int64_t) 0); + return ctx->electron.num; +} + + +int64_t qmckl_get_electron_up_num (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (int64_t) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 1; + + if ( (ctx->electron.uninitialized & mask) != 0) { + return (int64_t) 0; + } + + assert (ctx->electron.up_num > (int64_t) 0); + return ctx->electron.up_num; +} + + +int64_t qmckl_get_electron_down_num (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (int64_t) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 2; + + if ( (ctx->electron.uninitialized & mask) != 0) { + return (int64_t) 0; + } + + assert (ctx->electron.down_num >= (int64_t) 0); + return ctx->electron.down_num; +} + + +int64_t qmckl_get_electron_walk_num (const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (int64_t) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + int32_t mask = 1 << 3; + + if ( (ctx->electron.uninitialized & mask) != 0) { + return (int64_t) 0; + } + + assert (ctx->electron.walk_num > (int64_t) 0); + return ctx->electron.walk_num; +} + + + +bool qmckl_electron_provided(const qmckl_context context) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return false; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + return ctx->electron.provided; +} + #+end_src + +** Initialization functions + + To set the data relative to the electrons in the context, the + following functions need to be called. When the data structure is + initialized, the ~coord_new~ and ~coord_old~ arrays are both allocated. + + #+begin_src c :comments org :tangle (eval h_func) +qmckl_exit_code qmckl_set_electron_num (qmckl_context context, const int64_t up_num, const int64_t down_num); +qmckl_exit_code qmckl_set_electron_walk_num (qmckl_context context, const int64_t walk_num); +qmckl_exit_code qmckl_set_electron_coord (qmckl_context context, const double* coord); + #+end_src + + #+NAME:pre2 + #+begin_src c :exports none +if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return QMCKL_NULL_CONTEXT; + } + +qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + #+end_src + + #+NAME:post2 + #+begin_src c :exports none +ctx->electron.uninitialized &= ~mask; +ctx->electron.provided = (ctx->electron.uninitialized == 0); + +if (ctx->electron.provided) { + if (ctx->electron.coord_new != NULL) { + qmckl_free(context, ctx->electron.coord_new); + ctx->electron.coord_new = NULL; + } + if (ctx->electron.coord_old != NULL) { + qmckl_free(context, ctx->electron.coord_old); + ctx->electron.coord_old = NULL; + } + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = ctx->electron.num * ctx->electron.walk_num * 3 * sizeof(double); + + double* coord_new = (double*) qmckl_malloc(context, mem_info); + if (coord_new == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_electron_num", + NULL); + } + ctx->electron.coord_new = coord_new; + + double* coord_old = (double*) qmckl_malloc(context, mem_info); + if (coord_old == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_set_electron_num", + NULL); + } + ctx->electron.coord_old = coord_old; + + } + +return QMCKL_SUCCESS; + #+end_src + + To set the number of electrons, we give the number of up-spin and + down-spin electrons to the context and we set the number of walkers. + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +qmckl_exit_code qmckl_set_electron_num(qmckl_context context, + const int64_t up_num, + const int64_t down_num) { + <> + + if (up_num <= 0) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_electron_num", + "up_num <= 0"); + } + + if (down_num <= 0) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_3, + "qmckl_set_electron_num", + "down_num <= 0"); + } + + int32_t mask = 1; + + ctx->electron.up_num = up_num; + ctx->electron.down_num = down_num; + ctx->electron.num = up_num + down_num; + + <> +} + #+end_src + + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +qmckl_exit_code qmckl_set_electron_walk_num(qmckl_context context, const int64_t walk_num) { + <> + + if (walk_num <= 0) { + return qmckl_failwith( context, + QMCKL_INVALID_ARG_2, + "qmckl_set_electron_walk_num", + "walk_num <= 0"); + } + + int32_t mask = 2; + ctx->electron.walk_num = walk_num; + + <> +} + #+end_src + + + The following function sets the electron coordinates of all the + walkers. When this is done, the pointers to the old and new sets + of coordinates are swapped, and the new coordinates are + overwritten. This can be done only when the data relative to + electrons have been set. + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +qmckl_exit_code qmckl_set_electron_coord(qmckl_context context, const double* coord) { + <> + + const int64_t num = qmckl_get_electron_num(context); + if (num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_electron_coord", + "num is not set"); + } + + const int64_t walk_num = qmckl_get_electron_walk_num(context); + if (walk_num == 0L) { + return qmckl_failwith( context, + QMCKL_FAILURE, + "qmckl_set_electron_coord", + "walk_num is not set"); + } + + /* If num and walk_num are set, the arrays should be allocated */ + assert (ctx->electron.coord_old != NULL); + assert (ctx->electron.coord_new != NULL); + + /* Increment the date of the context */ + ctx->date += 1UL; + + /* Swap pointers */ + double * swap; + swap = ctx->electron.coord_old; + ctx->electron.coord_old = ctx->electron.coord_new; + ctx->electron.coord_new = swap; + + memcpy(ctx->electron.coord_new, coord, walk_num * num * 3 * sizeof(double)); + ctx->electron.coord_new_date = ctx->date; + + return QMCKL_SUCCESS; + +} + #+end_src + +** Test + + #+begin_src c :tangle (eval c_test) +/* Reference input data */ + +#define up_num ((int64_t) 3) +#define down_num ((int64_t) 2) +#define walk_num ((int64_t) 2) +#define num (up_num+down_num) + +double coord[walk_num*3*num] = + { 7.303633091022677881e+00, 1.375868694453235719e+01, 1.167371490471771217e-01, + 4.547755371567960836e+00, 3.245907105524011182e+00, 2.410764357550297110e-01, + 5.932816068137344523e+00, 1.491671465549257469e+01, 3.825374039119375236e-01, + 7.347336142660052083e+00, 1.341946976062362129e+00, 1.648917914228352322e+00, + 5.735221530102248444e+00, 1.064667491680036271e+01, 4.227201772236627297e-01, + 8.099550978782254163e+00, 6.861498941099086757e+00, 4.015884841159429036e-02, + 1.014757367558326173e+01, 5.219335322173662917e+00, 5.037004126899931322e-02, + 1.484094322159507051e+01, 9.777903829455864226e+00, 5.243007994024882767e-02, + 9.081723054990456845e+00, 5.499568496038920173e+00, 2.910446438899221347e-02, + 2.583154239492383653e+00, 1.442282811294904432e+00, 6.387191629878670451e-02 }; + +/* --- */ + +qmckl_exit_code rc; + +munit_assert(!qmckl_electron_provided(context)); + +rc = qmckl_set_electron_num (context, up_num, down_num); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(!qmckl_electron_provided(context)); + +rc = qmckl_set_electron_walk_num (context, walk_num); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); +munit_assert(qmckl_electron_provided(context)); + +rc = qmckl_set_electron_coord (context, coord); +munit_assert_int64(rc, ==, QMCKL_SUCCESS); + + #+end_src + +* Computation + + The computed data is stored in the context so that it can be reused + by different kernels. To ensure that the data is valid, for each + computed data the date of the context is stored when it is computed. + To know if some data needs to be recomputed, we check if the date of + the dependencies are more recent than the date of the data to + compute. If it is the case, then the data is recomputed and the + current date is stored. + +** Electron-electron distances + +*** Get + + #+begin_src c :comments org :tangle (eval h_func) :noweb yes +qmckl_exit_code qmckl_get_electron_ee_distance(qmckl_context context, double* distance); + #+end_src + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +qmckl_exit_code qmckl_get_electron_ee_distance(qmckl_context context, double* distance) +{ + /* Check input parameters */ + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (char) 0; + } + + qmckl_exit_code rc = qmckl_provide_ee_distance(context); + if (rc != QMCKL_SUCCESS) return rc; + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + size_t sze = ctx->electron.num * ctx->electron.num * ctx->electron.walk_num; + memcpy(distance, ctx->electron.ee_distance, sze * sizeof(double)); + + return QMCKL_SUCCESS; +} + #+end_src +*** Provide :noexport: + + #+begin_src c :comments org :tangle (eval h_private_func) :noweb yes :exports none +qmckl_exit_code qmckl_provide_ee_distance(qmckl_context context); + #+end_src + + #+begin_src c :comments org :tangle (eval c) :noweb yes :exports none +qmckl_exit_code qmckl_provide_ee_distance(qmckl_context context) +{ + /* Check input parameters */ + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return (char) 0; + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); + + + /* Compute if necessary */ + if (ctx->electron.coord_new_date > ctx->electron.ee_distance_date) { + + fprintf(stderr, "%10ld: provide ee_distance", ctx->date); + /* Allocate array */ + if (ctx->electron.ee_distance == NULL) { + + qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero; + mem_info.size = ctx->electron.num * ctx->electron.num * + ctx->electron.walk_num * sizeof(double); + double* ee_distance = (double*) qmckl_malloc(context, mem_info); + + if (ee_distance == NULL) { + return qmckl_failwith( context, + QMCKL_ALLOCATION_FAILED, + "qmckl_ee_distance", + NULL); + } + ctx->electron.ee_distance = ee_distance; + } + + qmckl_exit_code rc = + qmckl_compute_ee_distance(context, + ctx->electron.num, + ctx->electron.walk_num, + ctx->electron.coord_new, + ctx->electron.ee_distance); + if (rc != QMCKL_SUCCESS) { + return rc; + } + + ctx->electron.ee_distance_date = ctx->date; + } + + return QMCKL_SUCCESS; +} + #+end_src + +*** Compute + :PROPERTIES: + :Name: qmckl_compute_ee_distance + :CRetType: qmckl_exit_code + :FRetType: qmckl_exit_code + :END: + + #+NAME: qmckl_ee_distance_args + | qmckl_context | context | in | Global state | + | int64_t | elec_num | in | Number of electrons | + | int64_t | walk_num | in | Number of walkers | + | double | coord[walk_num][3][elec_num] | in | Electron coordinates | + | double | ee_distance[walk_num][elec_num][elec_num] | out | Electron-electron distances | + + #+begin_src f90 :comments org :tangle (eval f) :noweb yes +integer function qmckl_compute_ee_distance_f(context, elec_num, walk_num, coord, ee_distance) & + result(info) + use qmckl + implicit none + integer(qmckl_context), intent(in) :: context + integer*8 , intent(in) :: elec_num + integer*8 , intent(in) :: walk_num + double precision , intent(in) :: coord(elec_num,3,walk_num) + double precision , intent(out) :: ee_distance(elec_num,elec_num,walk_num) + + integer*8 :: k + + info = QMCKL_SUCCESS + + if (context == QMCKL_NULL_CONTEXT) then + info = QMCKL_INVALID_CONTEXT + return + endif + + if (elec_num <= 0) then + info = QMCKL_INVALID_ARG_2 + return + endif + + if (walk_num <= 0) then + info = QMCKL_INVALID_ARG_3 + return + endif + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(elec_num, walk_num, coord, ee_distance) + !$OMP PRIVATE(k) + do k=1,walk_num + info = qmckl_distance(context, 'T', 'T', elec_num, elec_num, & + coord(1,1,k), elec_num, & + coord(1,1,k), elec_num, & + ee_distance(1,1,k), elec_num) + end do + !$OMP END PARALLEL DO + +end function qmckl_compute_ee_distance_f + #+end_src + + #+begin_src c :tangle (eval h_private_func) :comments org :exports none + qmckl_exit_code qmckl_compute_ee_distance ( + const qmckl_context context, + const int64_t elec_num, + const int64_t walk_num, + const double* coord, + double* const ee_distance ); + #+end_src + + #+CALL: generate_c_interface(table=qmckl_ee_distance_args,rettyp=get_value("CRetType"),fname=get_value("Name")) + + #+RESULTS: + #+begin_src f90 :tangle (eval f) :comments org :exports none + integer(c_int32_t) function qmckl_compute_ee_distance & + (context, elec_num, walk_num, coord, ee_distance) & + 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 :: elec_num + integer (c_int64_t) , intent(in) , value :: walk_num + real (c_double ) , intent(in) :: coord(elec_num,3,walk_num) + real (c_double ) , intent(out) :: ee_distance(elec_num,elec_num,walk_num) + + integer(c_int32_t), external :: qmckl_compute_ee_distance_f + info = qmckl_compute_ee_distance_f & + (context, elec_num, walk_num, coord, ee_distance) + + end function qmckl_compute_ee_distance + #+end_src + +*** Test + + #+begin_src c :tangle (eval c_test) +/* Reference input data */ + +munit_assert(qmckl_electron_provided(context)); + +double distance[walk_num*num*num]; +rc = qmckl_get_electron_ee_distance(context, distance); +rc = qmckl_get_electron_ee_distance(context, distance); +munit_assert_double(distance[0], ==, 0.); +munit_assert_double(distance[1], ==, distance[num]); +munit_assert_double_equal(distance[1], 8.6114953086801, 12); + + #+end_src + +* End of files :noexport: + + #+begin_src c :tangle (eval h_private_type) +#endif + #+end_src + +*** Test + #+begin_src c :tangle (eval c_test) + if (qmckl_context_destroy(context) != QMCKL_SUCCESS) + return QMCKL_FAILURE; + return MUNIT_OK; +} + #+end_src + +**✸ Compute file names + #+begin_src emacs-lisp +; The following is required to compute the file names + +(setq pwd (file-name-directory buffer-file-name)) +(setq name (file-name-nondirectory (substring buffer-file-name 0 -4))) +(setq f (concat pwd name "_f.f90")) +(setq fh (concat pwd name "_fh.f90")) +(setq c (concat pwd name ".c")) +(setq h (concat name ".h")) +(setq h_private (concat name "_private.h")) +(setq c_test (concat pwd "test_" name ".c")) +(setq f_test (concat pwd "test_" name "_f.f90")) + +; Minted +(require 'ox-latex) +(setq org-latex-listings 'minted) +(add-to-list 'org-latex-packages-alist '("" "listings")) +(add-to-list 'org-latex-packages-alist '("" "color")) + + #+end_src + + #+RESULTS: + | | color | + | | listings | + + +# -*- mode: org -*- +# vim: syntax=c + + diff --git a/src/qmckl_error.org b/src/qmckl_error.org new file mode 100644 index 0000000..4bfdfad --- /dev/null +++ b/src/qmckl_error.org @@ -0,0 +1,362 @@ +#+TITLE: Error handling +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org + +* Headers :noexport: + + #+begin_src c :tangle (eval h_private_type) +#ifndef QMCKL_ERROR_HPT +#define QMCKL_ERROR_HPT + #+end_src + + #+begin_src c :tangle (eval c) +#include +#include +#include +#include +#include + +#include "qmckl_error_type.h" +#include "qmckl_context_private_type.h" +#include "qmckl_context_type.h" + +#include "qmckl_context_func.h" +#include "qmckl_error_func.h" + #+end_src + + #+begin_src c :tangle (eval c_test) :noweb yes +#include "qmckl.h" +#include "munit.h" +MunitResult test_<>() { + #+end_src + + #+end_src + +* +:PROPERTIES: +:UNNUMBERED: t +:END: + + The library should never make the calling programs abort, nor + perform any input/output operations. This decision has to be taken + by the developer of the code calling the library. + + All the functions return with an exit code, defined as + #+NAME: type-exit-code + #+begin_src c :comments org :tangle (eval h_type) +typedef int32_t qmckl_exit_code; + #+end_src + + + #+begin_src f90 :comments org :tangle (eval fh_type) :exports none + integer , parameter :: qmckl_exit_code = c_int32_t + #+end_src + + The exit code returns the completion status of the function to the + calling program. When a function call completed successfully, + ~QMCKL_SUCCESS~ is returned. If one of the functions of + the library fails to complete the requested task, an appropriate + error code is returned to the program. + + Here is the complete list of exit codes. + + #+NAME: table-exit-codes + | Macro | Code | Description | + |-----------------------------+------+------------------------| + | ~QMCKL_SUCCESS~ | 0 | 'Success' | + | ~QMCKL_INVALID_ARG_1~ | 1 | 'Invalid argument 1' | + | ~QMCKL_INVALID_ARG_2~ | 2 | 'Invalid argument 2' | + | ~QMCKL_INVALID_ARG_3~ | 3 | 'Invalid argument 3' | + | ~QMCKL_INVALID_ARG_4~ | 4 | 'Invalid argument 4' | + | ~QMCKL_INVALID_ARG_5~ | 5 | 'Invalid argument 5' | + | ~QMCKL_INVALID_ARG_6~ | 6 | 'Invalid argument 6' | + | ~QMCKL_INVALID_ARG_7~ | 7 | 'Invalid argument 7' | + | ~QMCKL_INVALID_ARG_8~ | 8 | 'Invalid argument 8' | + | ~QMCKL_INVALID_ARG_9~ | 9 | 'Invalid argument 9' | + | ~QMCKL_INVALID_ARG_10~ | 10 | 'Invalid argument 10' | + | ~QMCKL_FAILURE~ | 101 | 'Failure' | + | ~QMCKL_ERRNO~ | 102 | strerror(errno) | + | ~QMCKL_INVALID_CONTEXT~ | 103 | 'Invalid context' | + | ~QMCKL_ALLOCATION_FAILED~ | 104 | 'Allocation failed' | + | ~QMCKL_DEALLOCATION_FAILED~ | 105 | 'De-allocation failed' | + | ~QMCKL_INVALID_EXIT_CODE~ | 106 | 'Invalid exit code' | + + # We need to force Emacs not to indent the Python code: + # -*- org-src-preserve-indentation: t + + #+begin_src python :var table=table-exit-codes :results drawer :exports none +""" This script generates the C and Fortran constants for the error + codes from the org-mode table. +""" + +result = [ "#+begin_src c :comments org :tangle (eval h_type) :exports none" ] +for (text, code,_) in table: + text=text.replace("~","") + result += [ f"#define {text:30s} ((qmckl_exit_code) {code:d})" ] +result += [ "#+end_src" ] + +result += [ "" ] + +result += [ "#+begin_src f90 :comments org :tangle (eval fh_type) :exports none" ] +for (text, code,_) in table: + text=text.replace("~","") + result += [ f" integer(qmckl_exit_code), parameter :: {text:30s} = {code:d}" ] +result += [ "#+end_src" ] + +return '\n'.join(result) + + #+end_src + + #+RESULTS: + :results: + #+begin_src c :comments org :tangle (eval h_type) :exports none + #define QMCKL_SUCCESS ((qmckl_exit_code) 0) + #define QMCKL_INVALID_ARG_1 ((qmckl_exit_code) 1) + #define QMCKL_INVALID_ARG_2 ((qmckl_exit_code) 2) + #define QMCKL_INVALID_ARG_3 ((qmckl_exit_code) 3) + #define QMCKL_INVALID_ARG_4 ((qmckl_exit_code) 4) + #define QMCKL_INVALID_ARG_5 ((qmckl_exit_code) 5) + #define QMCKL_INVALID_ARG_6 ((qmckl_exit_code) 6) + #define QMCKL_INVALID_ARG_7 ((qmckl_exit_code) 7) + #define QMCKL_INVALID_ARG_8 ((qmckl_exit_code) 8) + #define QMCKL_INVALID_ARG_9 ((qmckl_exit_code) 9) + #define QMCKL_INVALID_ARG_10 ((qmckl_exit_code) 10) + #define QMCKL_FAILURE ((qmckl_exit_code) 101) + #define QMCKL_ERRNO ((qmckl_exit_code) 102) + #define QMCKL_INVALID_CONTEXT ((qmckl_exit_code) 103) + #define QMCKL_ALLOCATION_FAILED ((qmckl_exit_code) 104) + #define QMCKL_DEALLOCATION_FAILED ((qmckl_exit_code) 105) + #define QMCKL_INVALID_EXIT_CODE ((qmckl_exit_code) 106) + #+end_src + + #+begin_src f90 :comments org :tangle (eval fh_type) :exports none + integer(qmckl_exit_code), parameter :: QMCKL_SUCCESS = 0 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_1 = 1 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_2 = 2 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_3 = 3 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_4 = 4 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_5 = 5 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_6 = 6 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_7 = 7 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_8 = 8 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_9 = 9 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_ARG_10 = 10 + integer(qmckl_exit_code), parameter :: QMCKL_FAILURE = 101 + integer(qmckl_exit_code), parameter :: QMCKL_ERRNO = 102 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_CONTEXT = 103 + integer(qmckl_exit_code), parameter :: QMCKL_ALLOCATION_FAILED = 104 + integer(qmckl_exit_code), parameter :: QMCKL_DEALLOCATION_FAILED = 105 + integer(qmckl_exit_code), parameter :: QMCKL_INVALID_EXIT_CODE = 106 + #+end_src + :end: + + The ~qmckl_string_of_error~ converts an exit code into a string. The + string is assumed to be large enough to contain the error message + (typically 128 characters). + +* Decoding errors + + To decode the error messages, ~qmckl_string_of_error~ converts an + error code into a string. + + #+NAME: MAX_STRING_LENGTH + : 128 + + #+begin_src c :comments org :tangle (eval h_func) :exports none :noweb yes +const char* qmckl_string_of_error(const qmckl_exit_code error); +void qmckl_string_of_error_f(const qmckl_exit_code error, + char result[<>]); + #+end_src + + The text strings are extracted from the previous table. + + #+NAME:cases + #+begin_src python :var table=table-exit-codes :exports none :noweb yes +""" This script extracts the text associated with the error codes + from the table. +""" + +result = [] +for (text, code, message) in table: + text = text.replace("~","") + message = message.replace("'",'"') + result += [ f"""case {text}: + return {message}; + break;""" ] +return '\n'.join(result) + + #+end_src + + # Source + #+begin_src c :comments org :tangle (eval c) :noweb yes +const char* qmckl_string_of_error(const qmckl_exit_code error) { + switch (error) { + <> + } + return "Unknown error"; +} + +void qmckl_string_of_error_f(const qmckl_exit_code error, char result[<>]) { + strncpy(result, qmckl_string_of_error(error), <>); +} + #+end_src + + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) :noexport :noweb yes + interface + subroutine qmckl_string_of_error (error, string) bind(C, name='qmckl_string_of_error_f') + use, intrinsic :: iso_c_binding + import + integer (qmckl_exit_code), intent(in), value :: error + character, intent(out) :: string(<>) + end subroutine qmckl_string_of_error + end interface + #+end_src + +* Data structure in context + + The strings are declared with a maximum fixed size to avoid + dynamic memory allocation. + + #+begin_src c :comments org :tangle (eval h_private_type) +#define QMCKL_MAX_FUN_LEN 256 +#define QMCKL_MAX_MSG_LEN 1024 + +typedef struct qmckl_error_struct { + + qmckl_exit_code exit_code; + char function[QMCKL_MAX_FUN_LEN]; + char message [QMCKL_MAX_MSG_LEN]; + +} qmckl_error_struct; + #+end_src + +* Updating errors in the context + + The error is updated in the context using ~qmckl_set_error~. + When the error is set in the context, it is mandatory to specify + from which function the error is triggered, and a message + explaining the error. The exit code can't be ~QMCKL_SUCCESS~. + + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none +qmckl_exit_code +qmckl_set_error(qmckl_context context, + const qmckl_exit_code exit_code, + const char* function_name, + const char* message); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +qmckl_exit_code +qmckl_set_error(qmckl_context context, + const qmckl_exit_code exit_code, + const char* function_name, + const char* message) +{ + /* Passing a function name and a message is mandatory. */ + assert (function_name != NULL); + assert (message != NULL); + + /* Exit codes are assumed valid. */ + assert (exit_code >= 0); + assert (exit_code != QMCKL_SUCCESS); + assert (exit_code < QMCKL_INVALID_EXIT_CODE); + + /* The context is assumed to exist. */ + assert (qmckl_context_check(context) != QMCKL_NULL_CONTEXT); + + qmckl_lock(context); + { + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + assert (ctx != NULL); /* Impossible because the context is valid. */ + + ctx->error.exit_code = exit_code; + strncpy(ctx->error.function, function_name, QMCKL_MAX_FUN_LEN); + strncpy(ctx->error.message, message, QMCKL_MAX_MSG_LEN); + } + qmckl_unlock(context); + + return QMCKL_SUCCESS; +} + #+end_src + +* Failing + + To make a function fail, the ~qmckl_failwith~ function should be + called, such that information about the failure is stored in + the context. The desired exit code is given as an argument, as + well as the name of the function and an error message. If the + message is ~NULL~, then the default message obtained by + ~qmckl_string_of_error~ is used. The return code of the function is + the desired return code. + Upon failure, a ~QMCKL_NULL_CONTEXT~ is returned. + + #+begin_src c :comments org :tangle (eval h_func) :exports none +qmckl_exit_code qmckl_failwith(qmckl_context context, + const qmckl_exit_code exit_code, + const char* function, + const char* message) ; + #+end_src + + #+begin_src c :comments org :tangle (eval c) +qmckl_exit_code qmckl_failwith(qmckl_context context, + const qmckl_exit_code exit_code, + const char* function, + const char* message) { + + assert (exit_code > 0); + assert (exit_code < QMCKL_INVALID_EXIT_CODE); + assert (function != NULL); + assert (strlen(function) < QMCKL_MAX_FUN_LEN); + if (message != NULL) { + assert (strlen(message) < QMCKL_MAX_MSG_LEN); + } + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) + return QMCKL_INVALID_CONTEXT; + + if (message == NULL) { + qmckl_exit_code rc = + qmckl_set_error(context, exit_code, function, qmckl_string_of_error(exit_code)); + assert (rc == QMCKL_SUCCESS); + } else { + qmckl_exit_code rc = + qmckl_set_error(context, exit_code, function, message); + assert (rc == QMCKL_SUCCESS); + } + + return exit_code; +} + + #+end_src + + For example, this function can be used as + #+begin_src c :tangle no +if (x < 0) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "qmckl_function", + "Expected x >= 0"); + } + #+end_src + + +* End of files :noexport: + + #+begin_src c :comments link :tangle (eval h_private_type) +#endif + #+end_src + + +** Test + #+begin_src c :comments link :tangle (eval c_test) +return MUNIT_OK; +} + #+end_src + + # -*- mode: org -*- + # vim: syntax=c + + diff --git a/src/qmckl_footer.org b/src/qmckl_footer.org deleted file mode 100644 index 5ed01c7..0000000 --- a/src/qmckl_footer.org +++ /dev/null @@ -1,18 +0,0 @@ -* Acknowledgments - - [[https://trex-coe.eu/sites/default/files/inline-images/euflag.jpg]] - [[https://trex-coe.eu][TREX: Targeting Real Chemical Accuracy at the Exascale]] project has received funding from the European Union’s Horizon 2020 - Research and Innovation program - under grant agreement no. 952165. The content of this document does not represent the opinion of the European Union, and the European Union is not responsible for any use that might be made of such content. - -* End of header files :noexport: - -#+BEGIN_SRC C :tangle qmckl.h -#endif -#+END_SRC - -#+BEGIN_SRC f90 :tangle qmckl_f.f90 -end module qmckl -#+END_SRC - - -# -*- mode: org -*- - diff --git a/src/qmckl_memory.org b/src/qmckl_memory.org index 7e3ca79..6cef69a 100644 --- a/src/qmckl_memory.org +++ b/src/qmckl_memory.org @@ -1,101 +1,282 @@ -** Memory management +#+TITLE: Memory management +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org - We override the allocation functions to enable the possibility of - optimized libraries to fine-tune the memory allocation. +We override the allocation functions to enable the possibility of +optimized libraries to fine-tune the memory allocation. - 2 files are produced: - - a source file : =qmckl_memory.c= - - a test file : =test_qmckl_memory.c= -*** Headers :noexport: - #+BEGIN_SRC C :tangle qmckl_memory.c -#include "qmckl.h" - #+END_SRC +* Headers :noexport: - #+BEGIN_SRC C :tangle test_qmckl_memory.c + #+begin_src c :tangle (eval c) +#include +#include +#include +#include + +#include "qmckl_error_type.h" +#include "qmckl_memory_private_type.h" +#include "qmckl_context_type.h" +#include "qmckl_context_private_type.h" + +#include "qmckl_memory_private_func.h" +#include "qmckl_memory_func.h" +#include "qmckl_context_func.h" +#include "qmckl_error_func.h" + #+end_src + + #+begin_src c :tangle (eval c_test) :noweb yes #include "qmckl.h" #include "munit.h" -MunitResult test_qmckl_memory() { - #+END_SRC +#include "qmckl_context_private_type.h" +#include "qmckl_memory_private_func.h" +MunitResult test_<>() { + #+end_src -*** =qmckl_malloc= - Memory allocation function, letting the library choose how the - memory will be allocated, and a pointer is returned to the user. + #+begin_src c :tangle (eval h_private_type) :noweb yes +#ifndef QMCKL_MEMORY_HPT +#define QMCKL_MEMORY_HPT - #+BEGIN_SRC C :tangle qmckl.h -void* qmckl_malloc(const qmckl_context ctx, const size_t size); - #+END_SRC +#include +#include + #+end_src - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - type (c_ptr) function qmckl_malloc (context, size) bind(C) - use, intrinsic :: iso_c_binding - integer (c_int64_t), intent(in), value :: context - integer (c_int64_t), intent(in), value :: size - end function qmckl_malloc - end interface - #+END_SRC +* Memory data structure for the context + + Every time a new block of memory is allocated, the information + relative to the allocation is stored in a new ~qmckl_memory_info_struct~. + A ~qmckl_memory_info_struct~ contains the pointer to the memory block, + its size in bytes, and extra implementation-specific information such as + alignment, pinning, if the memory should be allocated on CPU or GPU + /etc/. -**** Source - #+BEGIN_SRC C :tangle qmckl_memory.c -void* qmckl_malloc(const qmckl_context ctx, const size_t size) { - if (ctx == (qmckl_context) 0) { - /* Avoids unused parameter error */ - return malloc( (size_t) size ); + #+begin_src c :tangle (eval h_private_type) :noweb yes +typedef struct qmckl_memory_info_struct { + size_t size; + void* pointer; +} qmckl_memory_info_struct; + +static const qmckl_memory_info_struct qmckl_memory_info_struct_zero = + { + .size = (size_t) 0, + .pointer = NULL + }; + #+end_src + + The ~memory~ element of the context is a data structure which + contains an array of ~qmckl_memory_info_struct~, the size of the + array, and the number of allocated blocks. + + #+begin_src c :tangle (eval h_private_type) :noweb yes +typedef struct qmckl_memory_struct { + size_t n_allocated; + size_t array_size; + qmckl_memory_info_struct* element; +} qmckl_memory_struct; + #+end_src + +* Passing info to allocation routines + + Passing information to the allocation routine should be done by + passing an instance of a ~qmckl_memory_info_struct~. + +* Allocation/deallocation functions + + Memory allocation inside the library should be done with + ~qmckl_malloc~. It lets the library choose how the memory will be + allocated, and a pointer is returned to the user. The context is + passed to let the library store data related to the allocation + inside the context. In this particular implementation of the library, + we store a list of allocated pointers so that all the memory can be + properly freed when the library is de-initialized. + If the allocation failed, the ~NULL~ pointer is returned. + + # Header + #+begin_src c :tangle (eval h_private_func) :noexport +void* qmckl_malloc(qmckl_context context, + const qmckl_memory_info_struct info); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +void* qmckl_malloc(qmckl_context context, const qmckl_memory_info_struct info) { + + assert (qmckl_context_check(context) != QMCKL_NULL_CONTEXT); + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + + /* Allocate memory and zero it */ + void * pointer = malloc(info.size); + if (pointer == NULL) { + return NULL; } - return malloc( (size_t) size ); + memset(pointer, 0, info.size); + + qmckl_lock(context); + { + /* If qmckl_memory_struct is full, reallocate a larger one */ + if (ctx->memory.n_allocated == ctx->memory.array_size) { + const size_t old_size = ctx->memory.array_size; + qmckl_memory_info_struct * new_array = reallocarray(ctx->memory.element, + 2L * old_size, + sizeof(qmckl_memory_info_struct)); + if (new_array == NULL) { + qmckl_unlock(context); + free(pointer); + return NULL; + } + + memset( &(new_array[old_size]), 0, old_size * sizeof(qmckl_memory_info_struct) ); + ctx->memory.element = new_array; + ctx->memory.array_size = 2L * old_size; + } + + /* Find first NULL entry */ + size_t pos = (size_t) 0; + while ( pos < ctx->memory.array_size && ctx->memory.element[pos].size > (size_t) 0) { + pos += (size_t) 1; + } + assert (ctx->memory.element[pos].size == (size_t) 0); + + /* Copy info at the new location */ + ctx->memory.element[pos].size = info.size; + ctx->memory.element[pos].pointer = pointer; + ctx->memory.n_allocated += (size_t) 1; + } + qmckl_unlock(context); + + return pointer; } + #+end_src - #+END_SRC -**** Test :noexport: - #+BEGIN_SRC C :tangle test_qmckl_memory.c -int *a; -a = (int*) qmckl_malloc( (qmckl_context) 1, 3*sizeof(int)); -a[0] = 1; -a[1] = 2; -a[2] = 3; -munit_assert_int(a[0], ==, 1); -munit_assert_int(a[1], ==, 2); -munit_assert_int(a[2], ==, 3); - #+END_SRC + # Test :noexport: + #+begin_src c :tangle (eval c_test) +/* Create a context */ +qmckl_context context = qmckl_context_create(); -*** =qmckl_free= +qmckl_memory_info_struct info = qmckl_memory_info_struct_zero; +info.size = (size_t) 3; - #+BEGIN_SRC C :tangle qmckl.h -void qmckl_free(void *ptr); - #+END_SRC +/* Allocate an array of ints */ +int *a = (int*) qmckl_malloc(context, info); - #+BEGIN_SRC f90 :tangle qmckl_f.f90 - interface - subroutine qmckl_free (ptr) bind(C) - use, intrinsic :: iso_c_binding - type (c_ptr), intent(in), value :: ptr - end subroutine qmckl_free - end interface - #+END_SRC -**** Source - #+BEGIN_SRC C :tangle qmckl_memory.c -void qmckl_free(void *ptr) { - free(ptr); +/* Check that array of ints is OK */ +munit_assert(a != NULL); +a[0] = 1; munit_assert_int(a[0], ==, 1); +a[1] = 2; munit_assert_int(a[1], ==, 2); +a[2] = 3; munit_assert_int(a[2], ==, 3); + +/* Allocate another array of ints */ +int *b = (int*) qmckl_malloc(context, info); + +/* Check that array of ints is OK */ +munit_assert(b != NULL); +b[0] = 1; munit_assert_int(b[0], ==, 1); +b[1] = 2; munit_assert_int(b[1], ==, 2); +b[2] = 3; munit_assert_int(b[2], ==, 3); + #+end_src + + When freeing the memory with ~qmckl_free~, the context is passed, in + case some important information has been stored related to memory + allocation and needs to be updated. + + #+begin_src c :tangle (eval h_func) +qmckl_exit_code qmckl_free(qmckl_context context, + void * const ptr); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +qmckl_exit_code qmckl_free(qmckl_context context, void * const ptr) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return qmckl_failwith(context, + QMCKL_INVALID_CONTEXT, + "qmckl_free", + NULL); + } + + if (ptr == NULL) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "qmckl_free", + "NULL pointer"); + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + + qmckl_lock(context); + { + /* Find pointer in array of saved pointers */ + size_t pos = (size_t) 0; + while ( pos < ctx->memory.array_size && ctx->memory.element[pos].pointer != ptr) { + pos += (size_t) 1; + } + + if (pos >= ctx->memory.array_size) { + /* Not found */ + qmckl_unlock(context); + return qmckl_failwith(context, + QMCKL_FAILURE, + "qmckl_free", + "Pointer not found in context"); + } + + free(ptr); + + memset( &(ctx->memory.element[pos]), 0, sizeof(qmckl_memory_info_struct) ); + ctx->memory.n_allocated -= (size_t) 1; + } + qmckl_unlock(context); + + return QMCKL_SUCCESS; } - #+END_SRC + #+end_src -**** Test :noexport: - #+BEGIN_SRC C :tangle test_qmckl_memory.c -qmckl_free(a); - #+END_SRC + # Test + #+begin_src c :tangle (eval c_test) :exports none +qmckl_exit_code rc; +/* Assert that both arrays are allocated */ +munit_assert(a != NULL); +munit_assert(b != NULL); -*** End of files :noexport: +/* Free in NULL context */ +rc = qmckl_free(QMCKL_NULL_CONTEXT, a); +munit_assert(rc == QMCKL_INVALID_CONTEXT); -**** Test - #+BEGIN_SRC C :comments org :tangle test_qmckl_memory.c +/* Free NULL pointer */ +rc = qmckl_free(context, NULL); +munit_assert(rc == QMCKL_INVALID_ARG_2); + +/* Free for the first time */ +rc = qmckl_free(context, a); +munit_assert(rc == QMCKL_SUCCESS); + +/* Free again */ +rc = qmckl_free(context, a); +munit_assert(rc == QMCKL_FAILURE); + +/* Clean up */ +rc = qmckl_context_destroy(context); +munit_assert(rc == QMCKL_SUCCESS); + + #+end_src + +* End of files :noexport: + + #+begin_src c :comments org :tangle (eval h_private_type) +#endif + + #+end_src +** Test + #+begin_src c :comments org :tangle (eval c_test) return MUNIT_OK; } - #+END_SRC + #+end_src - # -*- mode: org -*- - # vim: syntax=c +# -*- mode: org -*- +# vim: syntax=c diff --git a/src/qmckl_numprec.org b/src/qmckl_numprec.org new file mode 100644 index 0000000..ea082de --- /dev/null +++ b/src/qmckl_numprec.org @@ -0,0 +1,324 @@ +#+TITLE: Numerical precision +#+SETUPFILE: ../docs/theme.setup +#+INCLUDE: ../tools/lib.org + +* Headers :noexport: + + #+begin_src c :tangle (eval c_test) :noweb yes +#include "qmckl.h" +#include "munit.h" +MunitResult test_<>() { + #+end_src + + #+begin_src c :tangle (eval h_private_type) +#ifndef QMCKL_NUMPREC_HPT +#define QMCKL_NUMPREC_HPT + +#include + #+end_src + + #+begin_src c :tangle (eval c) +#include +#include +#include +#include +#include + +#include "qmckl_error_type.h" +#include "qmckl_context_type.h" +#include "qmckl_context_private_type.h" +#include "qmckl_numprec_type.h" + +#include "qmckl_numprec_func.h" +#include "qmckl_error_func.h" +#include "qmckl_context_func.h" + + #+end_src + +* Control of the numerical precision + + Controlling numerical precision enables optimizations. Here, the + 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. + + #+NAME: table-precision + | ~QMCKL_DEFAULT_PRECISION~ | 53 | + | ~QMCKL_DEFAULT_RANGE~ | 11 | + + # We need to force Emacs not to indent the Python code: + # -*- org-src-preserve-indentation: t + +#+begin_src python :var table=table-precision :results drawer :exports results +""" This script generates the C and Fortran constants from the org-mode table. +""" + +result = [ "#+begin_src c :comments org :tangle (eval h_type)" ] +for (text, code) in table: + text=text.replace("~","") + result += [ f"#define {text:30s} {code:d}" ] +result += [ "#+end_src" ] + +result += [ "" ] + +result += [ "#+begin_src f90 :comments org :tangle (eval fh_func) :exports none" ] +for (text, code) in table: + text=text.replace("~","") + result += [ f" integer, parameter :: {text:30s} = {code:d}" ] +result += [ "#+end_src" ] + +return '\n'.join(result) + +#+end_src + +#+RESULTS: +:results: +#+begin_src c :comments org :tangle (eval h_type) +#define QMCKL_DEFAULT_PRECISION 53 +#define QMCKL_DEFAULT_RANGE 11 +#+end_src + +#+begin_src f90 :comments org :tangle (eval fh_func) :exports none + integer, parameter :: QMCKL_DEFAULT_PRECISION = 53 + integer, parameter :: QMCKL_DEFAULT_RANGE = 11 +#+end_src +:end: + + #+begin_src c :comments org :tangle (eval h_private_type) +typedef struct qmckl_numprec_struct { + uint32_t precision; + uint32_t range; +} qmckl_numprec_struct; + #+end_src + + The following functions set and get the required precision and + range. ~precision~ is an integer between 2 and 53, and ~range~ is an + integer between 2 and 11. + + The setter functions functions return a new context as a 64-bit + integer. The getter functions return the value, as a 32-bit + integer. The update functions return ~QMCKL_SUCCESS~ or + ~QMCKL_FAILURE~. + +* Precision + ~qmckl_context_set_numprec_precision~ modifies the parameter for the + numerical precision in the context. + + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none +qmckl_exit_code qmckl_set_numprec_precision(const qmckl_context context, const int precision); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +qmckl_exit_code qmckl_set_numprec_precision(const qmckl_context context, const int precision) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) + return QMCKL_INVALID_CONTEXT; + + if (precision < 2) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "qmckl_update_numprec_precision", + "precision < 2"); + } + + if (precision > 53) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "qmckl_update_numprec_precision", + "precision > 53"); + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + + /* This should be always true because the context is valid */ + assert (ctx != NULL); + + qmckl_lock(context); + { + ctx->numprec.precision = (uint32_t) precision; + } + qmckl_unlock(context); + + return QMCKL_SUCCESS; +} + #+end_src + + # Fortran interface + + #+begin_src f90 :tangle (eval fh_func) + interface + integer (qmckl_exit_code) function qmckl_set_numprec_precision(context, precision) bind(C) + use, intrinsic :: iso_c_binding + import + integer (qmckl_context), intent(in), value :: context + integer (c_int32_t), intent(in), value :: precision + end function qmckl_set_numprec_precision + end interface + #+end_src + + ~qmckl_get_numprec_precision~ returns the value of the numerical precision in the context. + + #+begin_src c :comments org :tangle (eval h_func) :exports none +int32_t qmckl_get_numprec_precision(const qmckl_context context); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +int qmckl_get_numprec_precision(const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return qmckl_failwith(context, + QMCKL_INVALID_CONTEXT, + "qmckl_get_numprec_precision", + ""); + } + + const qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + return ctx->numprec.precision; +} + #+end_src + + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) + interface + integer (qmckl_exit_code) function qmckl_get_numprec_precision(context) bind(C) + use, intrinsic :: iso_c_binding + import + integer (qmckl_context), intent(in), value :: context + end function qmckl_get_numprec_precision + end interface + #+end_src + +* Range + + ~qmckl_set_numprec_range~ modifies the parameter for the numerical + range in a given context. + + # Header + #+begin_src c :comments org :tangle (eval h_func) :exports none +qmckl_exit_code qmckl_set_numprec_range(const qmckl_context context, const int range); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +qmckl_exit_code qmckl_set_numprec_range(const qmckl_context context, const int range) { + + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) + return QMCKL_INVALID_CONTEXT; + + if (range < 2) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "qmckl_set_numprec_range", + "range < 2"); + } + + if (range > 11) { + return qmckl_failwith(context, + QMCKL_INVALID_ARG_2, + "qmckl_set_numprec_range", + "range > 11"); + } + + qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + + /* This should be always true because the context is valid */ + assert (ctx != NULL); + + qmckl_lock(context); + { + ctx->numprec.range = (uint32_t) range; + } + qmckl_unlock(context); + + return QMCKL_SUCCESS; +} + #+end_src + + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) + interface + integer (qmckl_exit_code) function qmckl_numprec_set_range(context, range) bind(C) + use, intrinsic :: iso_c_binding + import + integer (qmckl_context), intent(in), value :: context + integer (c_int32_t), intent(in), value :: range + end function qmckl_numprec_set_range + end interface + #+end_src + + ~qmckl_get_numprec_range~ returns the value of the numerical range in the context. + + #+begin_src c :comments org :tangle (eval h_func) :exports none +int32_t qmckl_context_get_range(const qmckl_context context); + #+end_src + + # Source + #+begin_src c :tangle (eval c) +int qmckl_get_numprec_range(const qmckl_context context) { + if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) { + return qmckl_failwith(context, + QMCKL_INVALID_CONTEXT, + "qmckl_get_numprec_range", + ""); + } + + const qmckl_context_struct* const ctx = (qmckl_context_struct* const) context; + return ctx->numprec.range; +} + #+end_src + + # Fortran interface + #+begin_src f90 :tangle (eval fh_func) :exports none + interface + integer (qmckl_exit_code) function qmckl_get_numprec_range(context) bind(C) + use, intrinsic :: iso_c_binding + import + integer (qmckl_context), intent(in), value :: context + end function qmckl_get_numprec_range + end interface + #+end_src + +* 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. + + #+begin_src c :comments org :tangle (eval h_func) :exports none +double qmckl_get_numprec_epsilon(const qmckl_context context); + #+end_src + + # 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)); +} + #+end_src + + # 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 + import + integer (qmckl_context), intent(in), value :: context + end function qmckl_get_numprec_epsilon + end interface + #+end_src + +* End of files :noexport: + + #+begin_src c :comments link :tangle (eval h_private_type) +#endif + #+end_src + +*** Test + #+begin_src c :comments link :tangle (eval c_test) +return MUNIT_OK; +} + #+end_src + diff --git a/src/table_of_contents b/src/table_of_contents new file mode 100644 index 0000000..4b48cf9 --- /dev/null +++ b/src/table_of_contents @@ -0,0 +1,8 @@ +qmckl.org +qmckl_error.org +qmckl_context.org +qmckl_memory.org +qmckl_electron.org +qmckl_ao.org +qmckl_distance.org +test_qmckl.org diff --git a/src/test_qmckl.org b/src/test_qmckl.org index 1489768..de71b96 100644 --- a/src/test_qmckl.org +++ b/src/test_qmckl.org @@ -1,74 +1,91 @@ +#+TITLE: Testing +#+SETUPFILE: ../docs/theme.setup + * QMCkl test :noexport: This file is the main program of the unit tests. The tests rely on the $\mu$unit framework, which is provided as a git submodule. - First, we use a script to find the list of all the produced test files: + First, we use a script to find the list of all the generated test files: #+NAME: test-files - #+BEGIN_SRC sh :exports none :results value -grep BEGIN_SRC *.org | \ - grep test_qmckl_ | \ - rev | \ - cut -d ' ' -f 1 | \ - rev | \ - sort | \ - uniq - #+END_SRC + #+begin_src sh :exports none +FILES=$(cat table_of_contents) +grep begin_src $FILES \ + | grep c_test \ + | cut -d '.' -f 1 \ + | uniq + #+end_src #+RESULTS: test-files - | test_qmckl_ao.c | - | test_qmckl_context.c | - | test_qmckl_distance.c | - | test_qmckl_memory.c | + | qmckl_error | + | qmckl_context | + | qmckl_memory | + | qmckl_electron | + | qmckl_ao | + | qmckl_distance | We generate the function headers - #+BEGIN_SRC sh :var files=test-files :exports output :results raw + #+begin_src sh :var files=test-files :exports output :results drawer echo "#+NAME: headers" -echo "#+BEGIN_SRC C :tangle no" +echo "#+begin_src c :tangle no" for file in $files do - routine=${file%.c} + routine=test_${file%.c} echo "MunitResult ${routine}();" done -echo "#+END_SRC" - #+END_SRC +echo "#+end_src" + #+end_src #+RESULTS: + :results: #+NAME: headers - #+BEGIN_SRC C :tangle no -MunitResult test_qmckl_ao(); -MunitResult test_qmckl_context(); -MunitResult test_qmckl_distance(); -MunitResult test_qmckl_memory(); - #+END_SRC - + #+begin_src c :tangle no + MunitResult test_qmckl_error(); + MunitResult test_qmckl_context(); + MunitResult test_qmckl_memory(); + MunitResult test_qmckl_electron(); + MunitResult test_qmckl_ao(); + MunitResult test_qmckl_distance(); + #+end_src + :end: + and the required function calls: - #+BEGIN_SRC sh :var files=test-files :exports output :results raw + #+begin_src sh :var files=test-files :exports output :results drawer echo "#+NAME: calls" -echo "#+BEGIN_SRC C :tangle no" +echo "#+begin_src c :tangle no" for file in $files do - routine=${file%.c} + routine=test_${file%.c} echo " { (char*) \"${routine}\", ${routine}, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}," done -echo "#+END_SRC" - #+END_SRC +echo "#+end_src" + #+end_src #+RESULTS: + :results: #+NAME: calls - #+BEGIN_SRC C :tangle no - { (char*) "test_qmckl_ao", test_qmckl_ao, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, - { (char*) "test_qmckl_context", test_qmckl_context, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, - { (char*) "test_qmckl_distance", test_qmckl_distance, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, - { (char*) "test_qmckl_memory", test_qmckl_memory, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, - #+END_SRC + #+begin_src c :tangle no + { (char*) "test_qmckl_error", test_qmckl_error, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, + { (char*) "test_qmckl_context", test_qmckl_context, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, + { (char*) "test_qmckl_memory", test_qmckl_memory, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, + { (char*) "test_qmckl_electron", test_qmckl_electron, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, + { (char*) "test_qmckl_ao", test_qmckl_ao, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, + { (char*) "test_qmckl_distance", test_qmckl_distance, NULL,NULL,MUNIT_TEST_OPTION_NONE,NULL}, + #+end_src + :end: - #+BEGIN_SRC C :comments link :noweb yes :tangle test_qmckl.c + We include the =mcheck.h= header to enable the debugging of + allocations with ~mtrace~. Memory allocations will be traced in the + file specified by the ~MALLOC_TRACE~ environment variable. + + #+begin_src c :comments link :noweb yes :tangle test_qmckl.c #include "qmckl.h" #include "munit.h" +#include "mcheck.h" <> int main(int argc, char* argv[MUNIT_ARRAY_PARAM(argc + 1)]) { + mtrace(); static MunitTest test_suite_tests[] = { <> @@ -80,6 +97,10 @@ int main(int argc, char* argv[MUNIT_ARRAY_PARAM(argc + 1)]) { (char*) "", test_suite_tests, NULL, 1, MUNIT_SUITE_OPTION_NONE }; - return munit_suite_main(&test_suite, (void*) "µnit", argc, argv); + + int result = munit_suite_main(&test_suite, (void*) "µnit", argc, argv); + muntrace(); + return result; } - #+END_SRC + #+end_src + diff --git a/tools/Building.org b/tools/Building.org new file mode 100644 index 0000000..d1042a7 --- /dev/null +++ b/tools/Building.org @@ -0,0 +1,619 @@ +#+TITLE: Building tools + +This file contains all the tools needed to build the QMCkl library. + +* Helper functions + #+NAME: header + #+begin_src sh :tangle no :exports none :output none +echo "This file was created by tools/Building.org" + #+end_src + + #+NAME: check-src + #+begin_src bash +if [[ $(basename ${PWD}) != "src" ]] ; then + echo "This script needs to be run in the src directory" + exit -1 +fi + #+end_src + + #+NAME: url-issues + : https://github.com/trex-coe/qmckl/issues + + #+NAME: url-web + : https://trex-coe.github.io/qmckl + + #+NAME: license + #+begin_example +BSD 3-Clause License + +Copyright (c) 2020, TREX Center of Excellence +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + #+end_example + +* Makefile + :PROPERTIES: + :header-args: :tangle ../src/Makefile :noweb yes :comments org + :END: + + This is the main Makefile invoked by the ~make~ command. + The Makefile compiling the library is =Makefile.generated=, and is + generated by the script detailed in the next section. +** Header :noexport: + + #+begin_src makefile +# <> + +.POSIX: + #+end_src +** Dependencies + + #+begin_src makefile +LIBS=-lpthread + #+end_src + +** Variables + + #+begin_src makefile +QMCKL_ROOT=$(shell dirname $(CURDIR)) + +shared_lib=$(QMCKL_ROOT)/lib/libqmckl.so +static_lib=$(QMCKL_ROOT)/lib/libqmckl.a +qmckl_h=$(QMCKL_ROOT)/include/qmckl.h +qmckl_f=$(QMCKL_ROOT)/share/qmckl/fortran/qmckl_f.f90 + +export CC CFLAGS FC FFLAGS LIBS QMCKL_ROOT + +ORG_SOURCE_FILES=$(wildcard *.org) +C_SOURCE_FILES=$(patsubst %.org,%.c,$(ORG_SOURCE_FILES)) +INCLUDE=-I$(QMCKL_ROOT)/include/ + #+end_src + +** Compiler options + + GNU, Intel and LLVM compilers are supported. Choose here: + + #+begin_src makefile +COMPILER=GNU +#COMPILER=INTEL +#COMPILER=LLVM + #+end_src + +*** GNU + + #+begin_src makefile +ifeq ($(COMPILER),GNU) +#---------------------------------------------------------- +CC=gcc -g +CFLAGS=-fPIC $(INCLUDE) \ + -fexceptions -Wall -Werror -Wpedantic -Wextra -fmax-errors=3 + +FC=gfortran -g +FFLAGS=-fPIC $(INCLUDE) \ + -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising \ + -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation \ + -Wreal-q-constant -Wuninitialized -fbacktrace -finit-real=nan \ + -ffpe-trap=zero,overflow,underflow + +LIBS+=-lgfortran -lm +#---------------------------------------------------------- +endif + #+end_src + +*** Intel + + #+begin_src makefile +ifeq ($(COMPILER),INTEL) +#---------------------------------------------------------- +CC=icc -xHost +CFLAGS=-fPIC -g -O2 $(INCLUDE) + +FC=ifort -xHost +FFLAGS=-fPIC -g -O2 $(INCLUDE) + +LIBS+=-lm -lifcore -lirc +#---------------------------------------------------------- +CC=icc -xHost +endif + #+end_src + +*** LLVM + + #+begin_src makefile +ifeq ($(COMPILER),LLVM) +#---------------------------------------------------------- +CC=clang +CFLAGS=-fPIC -g -O2 $(INCLUDE) + +FC=flang +FFLAGS=fPIC -g -O2 $(INCLUDE) + +LIBS+=-lm +#---------------------------------------------------------- +endif + #+end_src + +** Rules + + The source files are created during the generation of the file ~Makefile.generated~. + The Makefile.generated is the one that will be distributed with the library. + + #+begin_src makefile +.PHONY: clean shared static doc all check install uninstall +.SECONDARY: # Needed to keep the produced C and Fortran files + +$(shared_lib) $(static_lib) install uninstall: $(qmckl_h) $(qmckl_f) Makefile.generated + $(MAKE) -f Makefile.generated $@ + +$(qmckl_f) $(qmckl_h): Makefile.generated + $(QMCKL_ROOT)/tools/build_qmckl_h.sh + +shared: $(shared_lib) +static: $(static_lib) +all: shared static doc check + +check: $(static_lib) + $(MAKE) -f Makefile.generated check + +doc: $(ORG_SOURCE_FILES) + $(QMCKL_ROOT)/tools/build_doc.sh + +clean: + - $(MAKE) -f Makefile.generated clean + - $(RM) test_qmckl_* test_qmckl.c \ + $(qmckl_h) $(qmckl_f) \ + qmckl_*.f90 qmckl_*.c qmckl_*.h \ + Makefile.generated *.html *.txt + +veryclean: clean FORCE + - $(RM) $(QMCKL_ROOT)/docs/*.html \ + $(QMCKL_ROOT)/docs/*.txt + +Makefile.generated: Makefile $(QMCKL_ROOT)/tools/create_makefile.sh $(ORG_SOURCE_FILES) + $(QMCKL_ROOT)/tools/create_makefile.sh + + +.SUFFIXES: .org .c + +.org.c: + $(QMCKL_ROOT)/tools/tangle.sh $< + + #+end_src + +* Script to tangle the org-mode files + :PROPERTIES: + :header-args: :tangle tangle.sh :noweb yes :shebang #!/bin/bash :comments org + :END: + + #+begin_src bash +# <> + +<> + #+end_src + + This file needs to be run from the QMCKL =src= directory. + + It tangles all the files in the directory. It uses the + =config_tangle.el= file, which contains information required to + compute the current file names using for example ~(eval c)~ to get + the name of the produced C file. + + The file is not tangled if the last modification date of the org + file is less recent than one of the tangled files. + + #+begin_src bash +function tangle() +{ + local org_file=$1 + local c_file=${org_file%.org}.c + local f_file=${org_file%.org}.f90 + + if [[ ${org_file} -ot ${c_file} ]] ; then + return + elif [[ ${org_file} -ot ${f_file} ]] ; then + return + fi + emacs --batch ${org_file} --load=../tools/config_tangle.el -f org-babel-tangle +} + +for i in $@ +do + echo "--- ${i} ----" + tangle ${i} +done + #+end_src + +* Script to generate auto-generated Makefile + :PROPERTIES: + :header-args: :tangle create_makefile.sh :noweb yes :shebang #!/bin/bash :comments org + :END: + + This script generates the Makefile that compiles the library. + The ~OUTPUT~ variable contains the name of the generated Makefile,typically + =Makefile.generated=. + + #+begin_src bash +# <> + +<> + +OUTPUT=Makefile.generated + #+end_src + + We start by tangling all the org-mode files. + + #+begin_src bash +${QMCKL_ROOT}/tools/tangle.sh *.org +${QMCKL_ROOT}/tools/build_qmckl_h.sh + #+end_src + + Then we create the list of ~*.o~ files to be created, for library + functions: + + #+begin_src bash +OBJECTS="qmckl_f.o" +for i in $(ls qmckl_*.c qmckl_*f.f90) ; do + FILE=${i%.*} + OBJECTS+=" ${FILE}.o" +done >> $OUTPUT + #+end_src + + for tests in C: + + #+begin_src bash +TESTS="" +for i in $(ls test_qmckl_*.c) ; do + FILE=${i%.c} + TESTS+=" ${FILE}.o" +done >> $OUTPUT + #+end_src + + and for tests in Fortran: + + #+begin_src bash +TESTS_F="" +for i in $(ls test_qmckl_*_f.f90) ; do + FILE=${i%.f90} + TESTS_F+=" ${FILE}.o" +done >> $OUTPUT + #+end_src + + Finally, we append the rules to the Makefile + + #+begin_src bash +cat << EOF > ${OUTPUT} +.POSIX: +.SUFFIXES: + +prefix=/usr/local + +CC=$CC +CFLAGS=$CFLAGS -I../munit/ + +FC=$FC +FFLAGS=$FFLAGS + +OBJECT_FILES=$OBJECTS +TESTS=$TESTS +TESTS_F=$TESTS_F + +LIBS=$LIBS + +QMCKL_ROOT=\$(shell dirname \$(CURDIR)) +shared_lib=\$(QMCKL_ROOT)/lib/libqmckl.so +static_lib=\$(QMCKL_ROOT)/lib/libqmckl.a +qmckl_h=\$(QMCKL_ROOT)/include/qmckl.h +qmckl_f=\$(QMCKL_ROOT)/share/qmckl/fortran/qmckl_f.f90 +munit=\$(QMCKL_ROOT)/munit/munit.c + +shared: \$(shared_lib) +static: \$(static_lib) +all: shared static + +\$(shared_lib): \$(OBJECT_FILES) + \$(CC) -shared \$(OBJECT_FILES) -o \$(shared_lib) + +\$(static_lib): \$(OBJECT_FILES) + \$(AR) rcs \$(static_lib) \$(OBJECT_FILES) + + +# Test + +qmckl_f.o: \$(qmckl_f) + \$(FC) \$(FFLAGS) -c \$(qmckl_f) -o \$@ + +test_qmckl: test_qmckl.c \$(qmckl_h) \$(static_lib) \$(TESTS) \$(TESTS_F) + \$(CC) \$(CFLAGS) \ + \$(munit) \$(TESTS) \$(TESTS_F) \$(static_lib) \$(LIBS) test_qmckl.c -o \$@ + +test_qmckl_shared: test_qmckl.c \$(qmckl_h) \$(shared_lib) \$(TESTS) \$(TESTS_F) + \$(CC) \$(CFLAGS) -Wl,-rpath,\$(QMCKL_ROOT)/lib -L\$(QMCKL_ROOT)/lib \ + \$(munit) \$(TESTS) \$(TESTS_F) -lqmckl \$(LIBS) test_qmckl.c -o \$@ + +check: test_qmckl test_qmckl_shared + ./test_qmckl + +clean: + \$(RM) -- *.o *.mod \$(shared_lib) \$(static_lib) test_qmckl + +install: + install -d \$(prefix)/lib + install -d \$(prefix)/include + install -d \$(prefix)/share/qmckl/fortran + install -d \$(prefix)/man + install \$(shared_lib) \$(prefix)/lib + install \$(static_lib) \$(prefix)/lib + install \$(qmckl_h) \$(prefix)/include + install \$(qmckl_f) \$(prefix)/share/qmckl/fortran + +.SUFFIXES: .c .f90 .o + +.c.o: + \$(CC) \$(CFLAGS) -c \$*.c -o \$*.o + +.f90.o: qmckl_f.o + \$(FC) \$(FFLAGS) -c \$*.f90 -o \$*.o + +.PHONY: check clean all +EOF + + #+end_src + +* Script to build the final qmckl.h file + :PROPERTIES: + :header-args:bash: :tangle build_qmckl_h.sh :noweb yes :shebang #!/bin/bash :comments org + :END: + + #+begin_src bash :noweb yes +# <> + + #+end_src + + #+NAME: qmckl-header + #+begin_src text :noweb yes +------------------------------------------ + QMCkl - Quantum Monte Carlo kernel library + ------------------------------------------ + + Documentation : <> + Issues : <> + + <> + + + #+end_src + + All the produced header files are concatenated in the =qmckl.h= + file, located in the include directory. The =*_private.h= files + are excluded. + + Put =.h= files in the correct order: + + #+begin_src bash +HEADERS="" +for i in $(cat table_of_contents) +do + HEADERS+="${i%.org}_type.h " +done + +for i in $(cat table_of_contents) +do + HEADERS+="${i%.org}_func.h " +done + #+end_src + + Generate C header file + + #+begin_src bash +OUTPUT="../include/qmckl.h" + +cat << EOF > ${OUTPUT} +/* + ,* <> + ,*/ + +#ifndef __QMCKL_H__ +#define __QMCKL_H__ + +#include +#include +#include +EOF + +for i in ${HEADERS} +do + if [[ -f $i ]] ; then + cat $i >> ${OUTPUT} + fi +done + +cat << EOF >> ${OUTPUT} +#endif +EOF + #+end_src + + Generate Fortran interface file from all =qmckl_*_fh.f90= files + + #+begin_src bash +HEADERS_TYPE="qmckl_*_fh_type.f90" +HEADERS="qmckl_*_fh_func.f90" + +OUTPUT="../share/qmckl/fortran/qmckl_f.f90" +cat << EOF > ${OUTPUT} +! +! <> +! +module qmckl + use, intrinsic :: iso_c_binding +EOF + +for i in ${HEADERS_TYPE} +do + cat $i >> ${OUTPUT} +done + +for i in ${HEADERS} +do + cat $i >> ${OUTPUT} +done + +cat << EOF >> ${OUTPUT} +end module qmckl +EOF + #+end_src + +* Script to build the documentation + :PROPERTIES: + :header-args:bash: :tangle build_doc.sh :noweb yes :shebang #!/bin/bash :comments org + :END: + + First define readonly global variables. + + #+begin_src bash :noweb yes +readonly DOCS=${QMCKL_ROOT}/docs/ +readonly SRC=${QMCKL_ROOT}/src/ +readonly HTMLIZE=${DOCS}/htmlize.el +readonly CONFIG_DOC=${QMCKL_ROOT}/tools/config_doc.el +readonly CONFIG_TANGLE=${QMCKL_ROOT}/tools/config_tangle.el + #+end_src + + Check that all the defined global variables correspond to files. + + #+begin_src bash :noweb yes +function check_preconditions() +{ + if [[ -z ${QMCKL_ROOT} ]] + then + print "QMCKL_ROOT is not defined" + exit 1 + fi + + for dir in ${DOCS} ${SRC} + do + if [[ ! -d ${dir} ]] + then + print "${dir} not found" + exit 2 + fi + done + + for file in ${CONFIG_DOC} ${CONFIG_TANGLE} + do + if [[ ! -f ${file} ]] + then + print "${file} not found" + exit 3 + fi + done +} + #+end_src + + ~install_htmlize~ installs the htmlize Emacs plugin if the + =htmlize.el= file is not present. + + #+begin_src bash :noweb yes +function install_htmlize() +{ + local url="https://github.com/hniksic/emacs-htmlize" + local repo="emacs-htmlize" + + [[ -f ${HTMLIZE} ]] || ( + cd ${DOCS} + git clone ${url} \ + && cp ${repo}/htmlize.el ${HTMLIZE} \ + && rm -rf ${repo} + cd - + ) + + # Assert htmlize is installed + [[ -f ${HTMLIZE} ]] \ + || exit 1 +} + #+end_src + + Extract documentation from an org-mode file. + + #+begin_src bash :noweb yes +function extract_doc() +{ + local org=$1 + local local_html=${SRC}/${org%.org}.html + local local_text=${SRC}/${org%.org}.txt + local html=${DOCS}/${org%.org}.html + + if [[ -f ${html} && ${org} -ot ${html} ]] + then + return + fi + emacs --batch \ + --load ${HTMLIZE} \ + --load ${CONFIG_DOC} \ + ${org} \ + --load ${CONFIG_TANGLE} \ + -f org-html-export-to-html \ + -f org-ascii-export-to-ascii + mv ${local_html} ${local_text} ${DOCS} + +} + #+end_src + + The main function of the script. + + #+begin_src bash :noweb yes +function main() { + + check_preconditions || exit 1 + + # Install htmlize if needed + install_htmlize || exit 2 + + # Create documentation + cd ${SRC} \ + || exit 3 + + for i in *.org + do + echo + echo "======= ${i} =======" + extract_doc ${i} + done + + if [[ $? -eq 0 ]] + then + cd ${DOCS} + rm -f index.html + ln README.html index.html + exit 0 + else + exit 3 + fi +} +main + #+end_src + + diff --git a/tools/build_doc.sh b/tools/build_doc.sh new file mode 100755 index 0000000..7de7111 --- /dev/null +++ b/tools/build_doc.sh @@ -0,0 +1,132 @@ +#!/bin/bash +# Script to build the documentation +# :PROPERTIES: +# :header-args:bash: :tangle build_doc.sh :noweb yes :shebang #!/bin/bash :comments org +# :END: + +# First define readonly global variables. + + +readonly DOCS=${QMCKL_ROOT}/docs/ +readonly SRC=${QMCKL_ROOT}/src/ +readonly HTMLIZE=${DOCS}/htmlize.el +readonly CONFIG_DOC=${QMCKL_ROOT}/tools/config_doc.el +readonly CONFIG_TANGLE=${QMCKL_ROOT}/tools/config_tangle.el + + + +# Check that all the defined global variables correspond to files. + + +function check_preconditions() +{ + if [[ -z ${QMCKL_ROOT} ]] + then + print "QMCKL_ROOT is not defined" + exit 1 + fi + + for dir in ${DOCS} ${SRC} + do + if [[ ! -d ${dir} ]] + then + print "${dir} not found" + exit 2 + fi + done + + for file in ${CONFIG_DOC} ${CONFIG_TANGLE} + do + if [[ ! -f ${file} ]] + then + print "${file} not found" + exit 3 + fi + done +} + + + +# ~install_htmlize~ installs the htmlize Emacs plugin if the +# =htmlize.el= file is not present. + + +function install_htmlize() +{ + local url="https://github.com/hniksic/emacs-htmlize" + local repo="emacs-htmlize" + + [[ -f ${HTMLIZE} ]] || ( + cd ${DOCS} + git clone ${url} \ + && cp ${repo}/htmlize.el ${HTMLIZE} \ + && rm -rf ${repo} + cd - + ) + + # Assert htmlize is installed + [[ -f ${HTMLIZE} ]] \ + || exit 1 +} + + + +# Extract documentation from an org-mode file. + + +function extract_doc() +{ + local org=$1 + local local_html=${SRC}/${org%.org}.html + local local_text=${SRC}/${org%.org}.txt + local html=${DOCS}/${org%.org}.html + + if [[ -f ${html} && ${org} -ot ${html} ]] + then + return + fi + emacs --batch \ + --load ${HTMLIZE} \ + --load ${CONFIG_DOC} \ + ${org} \ + --load ${CONFIG_TANGLE} \ + -f org-html-export-to-html \ + -f org-ascii-export-to-ascii + mv ${local_html} ${local_text} ${DOCS} + +} + + + +# The main function of the script. + + +function main() { + + check_preconditions || exit 1 + + # Install htmlize if needed + install_htmlize || exit 2 + + # Create documentation + cd ${SRC} \ + || exit 3 + + for i in *.org + do + echo + echo "======= ${i} =======" + extract_doc ${i} + done + + if [[ $? -eq 0 ]] + then + cd ${DOCS} + rm -f index.html + ln README.html index.html + exit 0 + else + exit 3 + fi +} +main diff --git a/tools/build_qmckl_h.sh b/tools/build_qmckl_h.sh new file mode 100755 index 0000000..ef0458e --- /dev/null +++ b/tools/build_qmckl_h.sh @@ -0,0 +1,168 @@ +#!/bin/bash +# Script to build the final qmckl.h file +# :PROPERTIES: +# :header-args:bash: :tangle build_qmckl_h.sh :noweb yes :shebang #!/bin/bash :comments org +# :END: + + +# This file was created by tools/Building.org + + + +# All the produced header files are concatenated in the =qmckl.h= +# file, located in the include directory. The =*_private.h= files +# are excluded. + +# Put =.h= files in the correct order: + + +HEADERS="" +for i in $(cat table_of_contents) +do + HEADERS+="${i%.org}_type.h " +done + +for i in $(cat table_of_contents) +do + HEADERS+="${i%.org}_func.h " +done + + + +# Generate C header file + + +OUTPUT="../include/qmckl.h" + +cat << EOF > ${OUTPUT} +/* + * ------------------------------------------ + * QMCkl - Quantum Monte Carlo kernel library + * ------------------------------------------ + * + * Documentation : https://trex-coe.github.io/qmckl + * Issues : https://github.com/trex-coe/qmckl/issues + * + * BSD 3-Clause License + * + * Copyright (c) 2020, TREX Center of Excellence + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, this + * list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * 3. Neither the name of the copyright holder nor the names of its + * contributors may be used to endorse or promote products derived from + * this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * + * + * + */ + +#ifndef __QMCKL_H__ +#define __QMCKL_H__ + +#include +#include +#include +EOF + +for i in ${HEADERS} +do + if [[ -f $i ]] ; then + cat $i >> ${OUTPUT} + fi +done + +cat << EOF >> ${OUTPUT} +#endif +EOF + + + +# Generate Fortran interface file from all =qmckl_*_fh.f90= files + + +HEADERS_TYPE="qmckl_*_fh_type.f90" +HEADERS="qmckl_*_fh_func.f90" + +OUTPUT="../share/qmckl/fortran/qmckl_f.f90" +cat << EOF > ${OUTPUT} +! +! ------------------------------------------ +! QMCkl - Quantum Monte Carlo kernel library +! ------------------------------------------ +! +! Documentation : https://trex-coe.github.io/qmckl +! Issues : https://github.com/trex-coe/qmckl/issues +! +! BSD 3-Clause License +! +! Copyright (c) 2020, TREX Center of Excellence +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this +! list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its +! contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! +! +! +! +module qmckl + use, intrinsic :: iso_c_binding +EOF + +for i in ${HEADERS_TYPE} +do + cat $i >> ${OUTPUT} +done + +for i in ${HEADERS} +do + cat $i >> ${OUTPUT} +done + +cat << EOF >> ${OUTPUT} +end module qmckl +EOF diff --git a/docs/config.el b/tools/config_doc.el similarity index 89% rename from docs/config.el rename to tools/config_doc.el index 093ee8c..9501d64 100755 --- a/docs/config.el +++ b/tools/config_doc.el @@ -1,11 +1,22 @@ ;; Thanks to Tobias's answer on Emacs Stack Exchange: ;; https://emacs.stackexchange.com/questions/38437/org-mode-batch-export-missing-syntax-highlighting + (package-initialize) + (require 'htmlize) (require 'font-lock) -(require 'subr-x) ;; for `when-let' +(setq org-confirm-babel-evaluate nil) +(global-font-lock-mode t) +(setq org-src-fontify-natively t) +;(require 'ox-latex) +;(setq org-latex-listings t) +;(add-to-list 'org-latex-packages-alist '("" "listings")) +;(add-to-list 'org-latex-packages-alist '("" "color")) + + +(require 'subr-x) ;; for `when-let' (unless (boundp 'maximal-integer) (defconst maximal-integer (lsh -1 -1) "Maximal integer value representable natively in emacs lisp.")) @@ -65,7 +76,10 @@ with class 'color and highest min-color value." (when (and inherited-face (null (eq inherited-face 'unspecified))) (setq val (my-face-attribute inherited-face attribute))))) - ;; (message "face: %S attribute: %S display-attr: %S, val: %S" face attribute display-attr val) ;; for debugging + ;;(message "face: %S attribute: %S display-attr: %S, val: %S" face attribute display-attr val) ;; for debugging (or val 'unspecified))) (advice-add 'face-attribute :override #'my-face-attribute) + + + diff --git a/tools/config_tangle.el b/tools/config_tangle.el new file mode 100755 index 0000000..91c122f --- /dev/null +++ b/tools/config_tangle.el @@ -0,0 +1,49 @@ +;; Thanks to Tobias's answer on Emacs Stack Exchange: +;; https://emacs.stackexchange.com/questions/38437/org-mode-batch-export-missing-syntax-highlighting + + +(package-initialize) +(add-to-list 'package-archives + '("gnu" . "https://elpa.gnu.org/packages/")) +(add-to-list 'package-archives + '("melpa-stable" . "https://stable.melpa.org/packages/")) +(add-to-list 'package-archives + '("melpa" . "https://melpa.org/packages/")) +(setq package-archive-priorities '(("melpa-stable" . 100) + ("melpa" . 50) + ("gnu" . 10))) + + +(require 'font-lock) +(setq org-confirm-babel-evaluate nil) +(global-font-lock-mode t) +(setq org-src-fontify-natively t) + +(org-babel-do-load-languages + 'org-babel-load-languages + '( + (emacs-lisp . t) + (shell . t) + (python . t) + (fortran . t) + (C . t) + (org . t) + (makefile . t) + )) + + +; The following is required to compute the file names +(setq pwd (file-name-directory buffer-file-name)) +(setq name (file-name-nondirectory (substring buffer-file-name 0 -4))) +(setq f (concat pwd name "_f.f90")) +(setq fh_func (concat pwd name "_fh_func.f90")) +(setq fh_type (concat pwd name "_fh_type.f90")) +(setq c (concat pwd name ".c")) +(setq h_func (concat name "_func.h")) +(setq h_type (concat name "_type.h")) +(setq h_private_type (concat name "_private_type.h")) +(setq h_private_func (concat name "_private_func.h")) +(setq c_test (concat pwd "test_" name ".c")) +(setq f_test (concat pwd "test_" name "_f.f90")) +(org-babel-lob-ingest "../tools/lib.org") + diff --git a/tools/create_makefile.sh b/tools/create_makefile.sh new file mode 100755 index 0000000..7c15a48 --- /dev/null +++ b/tools/create_makefile.sh @@ -0,0 +1,139 @@ +#!/bin/bash +# Script to generate auto-generated Makefile +# :PROPERTIES: +# :header-args: :tangle create_makefile.sh :noweb yes :shebang #!/bin/bash :comments org +# :END: + +# This script generates the Makefile that compiles the library. +# The ~OUTPUT~ variable contains the name of the generated Makefile,typically +# =Makefile.generated=. + + +# This file was created by tools/Building.org + + + +OUTPUT=Makefile.generated + + + +# We start by tangling all the org-mode files. + + +${QMCKL_ROOT}/tools/tangle.sh *.org +${QMCKL_ROOT}/tools/build_qmckl_h.sh + + + +# Then we create the list of ~*.o~ files to be created, for library +# functions: + + +OBJECTS="qmckl_f.o" +for i in $(ls qmckl_*.c qmckl_*f.f90) ; do + FILE=${i%.*} + OBJECTS+=" ${FILE}.o" +done >> $OUTPUT + + + +# for tests in C: + + +TESTS="" +for i in $(ls test_qmckl_*.c) ; do + FILE=${i%.c} + TESTS+=" ${FILE}.o" +done >> $OUTPUT + + + +# and for tests in Fortran: + + +TESTS_F="" +for i in $(ls test_qmckl_*_f.f90) ; do + FILE=${i%.f90} + TESTS_F+=" ${FILE}.o" +done >> $OUTPUT + + + +# Finally, we append the rules to the Makefile + + +cat << EOF > ${OUTPUT} +.POSIX: +.SUFFIXES: + +prefix=/usr/local + +CC=$CC +CFLAGS=$CFLAGS -I../munit/ + +FC=$FC +FFLAGS=$FFLAGS + +OBJECT_FILES=$OBJECTS +TESTS=$TESTS +TESTS_F=$TESTS_F + +LIBS=$LIBS + +QMCKL_ROOT=\$(shell dirname \$(CURDIR)) +shared_lib=\$(QMCKL_ROOT)/lib/libqmckl.so +static_lib=\$(QMCKL_ROOT)/lib/libqmckl.a +qmckl_h=\$(QMCKL_ROOT)/include/qmckl.h +qmckl_f=\$(QMCKL_ROOT)/share/qmckl/fortran/qmckl_f.f90 +munit=\$(QMCKL_ROOT)/munit/munit.c + +shared: \$(shared_lib) +static: \$(static_lib) +all: shared static + +\$(shared_lib): \$(OBJECT_FILES) + \$(CC) -shared \$(OBJECT_FILES) -o \$(shared_lib) + +\$(static_lib): \$(OBJECT_FILES) + \$(AR) rcs \$(static_lib) \$(OBJECT_FILES) + + +# Test + +qmckl_f.o: \$(qmckl_f) + \$(FC) \$(FFLAGS) -c \$(qmckl_f) -o \$@ + +test_qmckl: test_qmckl.c \$(qmckl_h) \$(static_lib) \$(TESTS) \$(TESTS_F) + \$(CC) \$(CFLAGS) \ + \$(munit) \$(TESTS) \$(TESTS_F) \$(static_lib) \$(LIBS) test_qmckl.c -o \$@ + +test_qmckl_shared: test_qmckl.c \$(qmckl_h) \$(shared_lib) \$(TESTS) \$(TESTS_F) + \$(CC) \$(CFLAGS) -Wl,-rpath,\$(QMCKL_ROOT)/lib -L\$(QMCKL_ROOT)/lib \ + \$(munit) \$(TESTS) \$(TESTS_F) -lqmckl \$(LIBS) test_qmckl.c -o \$@ + +check: test_qmckl test_qmckl_shared + ./test_qmckl + +clean: + \$(RM) -- *.o *.mod \$(shared_lib) \$(static_lib) test_qmckl + +install: + install -d \$(prefix)/lib + install -d \$(prefix)/include + install -d \$(prefix)/share/qmckl/fortran + install -d \$(prefix)/man + install \$(shared_lib) \$(prefix)/lib + install \$(static_lib) \$(prefix)/lib + install \$(qmckl_h) \$(prefix)/include + install \$(qmckl_f) \$(prefix)/share/qmckl/fortran + +.SUFFIXES: .c .f90 .o + +.c.o: + \$(CC) \$(CFLAGS) -c \$*.c -o \$*.o + +.f90.o: qmckl_f.o + \$(FC) \$(FFLAGS) -c \$*.f90 -o \$*.o + +.PHONY: check clean all +EOF diff --git a/tools/init.el b/tools/init.el new file mode 100644 index 0000000..fae4d20 --- /dev/null +++ b/tools/init.el @@ -0,0 +1,80 @@ +(package-initialize) +(add-to-list 'package-archives + '("gnu" . "https://elpa.gnu.org/packages/")) +(add-to-list 'package-archives + '("melpa-stable" . "https://stable.melpa.org/packages/")) +(add-to-list 'package-archives + '("melpa" . "https://melpa.org/packages/")) +(setq package-archive-priorities '(("melpa-stable" . 100) + ("melpa" . 50) + ("gnu" . 10))) + +(require 'cl) +(let* ((required-packages + '(htmlize + evil + org-evil + org-bullets + )) + (missing-packages (remove-if #'package-installed-p required-packages))) + (when missing-packages + (message "Missing packages: %s" missing-packages) + (package-refresh-contents) + (dolist (pkg missing-packages) + (package-install pkg) + (message "Package %s has been installed" pkg)))) + +(setq backup-directory-alist + `(("." . ,(concat user-emacs-directory "backups")))) +(setq backup-by-copying t) + +(require 'org) +(setq org-format-latex-options (plist-put org-format-latex-options :scale 1.6)) + +(setq org-hide-leading-stars t) +(setq org-alphabetical-lists t) +(setq org-src-fontify-natively t) +(setq org-src-tab-acts-natively t) +(setq org-src-preserve-indentation t) +(setq org-hide-emphasis-markers nil) +(setq org-pretty-entities nil) +(setq org-confirm-babel-evaluate nil) ;; Do not ask for confirmation all the time!! + +(org-babel-do-load-languages + 'org-babel-load-languages + '( + (emacs-lisp . t) + (shell . t) + (python . t) + (C . t) + (org . t) + (makefile . t) + )) + +(add-hook 'org-babel-after-execute-hook 'org-display-inline-images) +'(indent-tabs-mode nil) + +(require 'evil) +(setq evil-want-C-i-jump nil) +(evil-mode 1) +(global-font-lock-mode t) +(global-superword-mode 1) + +(setq line-number-mode 1) +(setq column-number-mode 1) + +(evil-select-search-module 'evil-search-module 'evil-search) + +(global-set-key (kbd "C-+") 'text-scale-increase) +(global-set-key (kbd "C--") 'text-scale-decrease) + + +(custom-set-variables + ;; custom-set-variables was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(ansi-color-faces-vector + [default default default italic underline success warning error]) + '(custom-enabled-themes (quote (leuven))) +) diff --git a/tools/lib.org b/tools/lib.org new file mode 100644 index 0000000..4dbe7dc --- /dev/null +++ b/tools/lib.org @@ -0,0 +1,287 @@ +# -*- mode: org -*- + +* Library of org-mode functions :noexport: +** Defines the name of the current file + + #+NAME: filename + #+begin_src elisp :tangle no +(file-name-nondirectory (substring buffer-file-name 0 -4)) + #+end_src + +** Function to get the value of a property. + #+NAME: get_value + #+begin_src elisp :var key="Type" +(setq x (org-property-values key)) +(pop x) + #+end_src + + #+RESULTS: get_value + +** Table of function arguments + + #+NAME: test + | qmckl_context | context | in | Global state | + | char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed | + | char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed | + | int64_t | m | in | Number of points in the first set | + | int64_t | n | in | Number of points in the second set | + | double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ | + | int64_t | lda | in | Leading dimension of array ~A~ | + | double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ | + | int64_t | ldb | in | Leading dimension of array ~B~ | + | double | C[n][ldc] | out | Array containing the $m \times n$ matrix $C$ | + | int64_t | ldc | in | Leading dimension of array ~C~ | + + +*** 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" +f_of_c_d = { '' : '' + , 'qmckl_context' : 'integer (c_int64_t)' + , 'qmckl_exit_code' : 'integer (c_int32_t)' + , 'int32_t' : 'integer (c_int32_t)' + , 'int64_t' : 'integer (c_int64_t)' + , 'float' : 'real (c_float )' + , 'double' : 'real (c_double )' + , 'char' : 'character' + } + #+END_SRC + + #+RESULTS: f_of_c + #+begin_src f90 :tangle (eval f) :comments org :exports none + None + #+end_src + + #+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)' + , 'integer' : 'integer(c_int32_t)' + , 'integer*8' : 'integer(c_int64_t)' + , 'real' : 'real(c_float)' + , 'real*8' : 'real(c_double)' + , 'character' : 'character(c_char)' + } + #+END_SRC + + #+RESULTS: c_of_f + #+begin_src f90 :tangle (eval f) :comments org :exports none + None + #+end_src + +*** Parse the table + + #+NAME: parse_table + #+BEGIN_SRC python :results none :noweb yes :exports none +def parse_table(table): + result = [] + + for line in table: + d = { "c_type" : line[0], + "inout" : line[2].lower(), + "name" : line[1], + "comment" : line[3] } + + # Handle inout + if d["inout"] in ["input", "in"]: + d["inout"] == "in" + elif d["inout"] in ["output", "out"]: + d["inout"] == "out" + elif d["inout"] in ["input/output", "inout"]: + d["inout"] == "inout" + + # Find dimensions (replace [] by [*] to get * in Fortran dimensions) + dims = d["name"].replace("[]","[*]").split('[') + d["rank"] = len(dims) - 1 + if d["rank"] == 0: + d["dims"] = [] + else: + d["name"] = d["name"].split('[')[0].strip() + d["dims"] = [ x.replace(']','').strip() for x in dims[1:] ] + + result.append(d) + + return result + #+END_SRC + +*** Generates a C header + + #+NAME: generate_c_header + #+BEGIN_SRC python :var table=[] :var rettyp=[] :var fname=[] :results drawer :noweb yes :wrap "src c :tangle (eval h_func) :comments org" +<> + +results = [] +for d in parse_table(table): + name = d["name"] + c_type = d["c_type"] + + # Add star for arrays + if d["rank"] > 0 or d["inout"] in ["out", "inout"]: + c_type += "*" + + if d["inout"] == "out": + c_type += " const" + + # Only inputs are const + if d["inout"] == "in": + const = "const " + else: + const = "" + + results += [ f" {const}{c_type} {name}" ] + +results=',\n'.join(results) +template = f"""{rettyp} {fname} ( +{results} ); """ +return template + + #+END_SRC + + #+RESULTS: generate_c_header + #+begin_src c :tangle (eval h_func) :comments org + [] [] ( + const qmckl_context context, + const char transa, + const char transb, + const int64_t m, + const int64_t n, + const double* const A, + const int64_t lda, + const double* const B, + const int64_t ldb, + double* const C, + const int64_t ldc ); + #+end_src + +*** 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" +<> +<> +<> +d = parse_table(table) + +args = ", ".join([ x["name"] for x in d ]) + +rettyp_c = ctypeid_d[rettyp.lower()] + +results = [ f"{rettyp_c} function {fname} &" +, f" ({args}) &" +, " bind(C) result(info)" +, "" +, " use, intrinsic :: iso_c_binding" +, " implicit none" +, "" +] + +for d in parse_table(table): + f_type = f_of_c_d[d["c_type"]] + inout = "intent("+d["inout"]+")" + name = d["name"] + + # Input scalars are passed by value + if d["rank"] == 0 and d["inout"] == "in": + value = ", value" + else: + value = " " + + # Append dimensions to the name + if d["rank"] == 0: + dims = "" + else: + d["dims"].reverse() + dims = "(" + ",".join(d["dims"]) + ")" + + results += [ f" {f_type:20}, {inout:12}{value} :: {name}{dims}" ] + +results += [ "" +, f" {rettyp_c}, external :: {fname}_f" +, f" info = {fname}_f &" +, f" ({args})" +, "" +, f"end function {fname}" +] +results='\n'.join(results) +return results + #+END_SRC + +*** 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" +<> +<> +<> +d = parse_table(table) + +args = ", ".join([ x["name"] for x in d ]) + +rettyp_c = ctypeid_d[rettyp.lower()] + +results = [ f"interface" +, f" {rettyp_c} function {fname} &" +, f" ({args}) &" +, " bind(C)" +, " use, intrinsic :: iso_c_binding" +, " import" +, " implicit none" +, "" +] + +for d in parse_table(table): + f_type = f_of_c_d[d["c_type"]] + inout = "intent("+d["inout"]+")" + name = d["name"] + + # Input scalars are passed by value + if d["rank"] == 0 and d["inout"] == "in": + value = ", value" + else: + value = " " + + # Append dimensions to the name + if d["rank"] == 0: + dims = "" + else: + d["dims"].reverse() + dims = "(" + ",".join(d["dims"]) + ")" + + results += [ f" {f_type:20}, {inout:12}{value} :: {name}{dims}" ] + +results += [ "" +, f" end function {fname}" +, f"end interface" +] +results='\n'.join(results) +return results + #+END_SRC + + #+RESULTS: generate_f_interface + #+begin_src f90 :tangle (eval fh_func) :comments org :exports none + interface + integer(c_int32_t) function [] & + (context, transa, transb, m, n, A, lda, B, ldb, C, ldc) & + bind(C) + use, intrinsic :: iso_c_binding + import + implicit none + + integer (qmckl_context), intent(in) , value :: context + character , intent(in) , value :: transa + character , 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,3) + integer (c_int64_t) , intent(in) , value :: lda + real (c_double ) , intent(in) :: B(ldb,3) + integer (c_int64_t) , intent(in) , value :: ldb + real (c_double ) , intent(out) :: C(ldc,n) + integer (c_int64_t) , intent(in) , value :: ldc + + end function [] + end interface + #+end_src + diff --git a/tools/merge_org.sh b/tools/merge_org.sh new file mode 100755 index 0000000..97b749a --- /dev/null +++ b/tools/merge_org.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +OUTPUT=$1 + +for i in README.org $(cat $QMCKL_ROOT/src/table_of_contents) +do + cat $i >> $1 +done diff --git a/tools/nb_to_org.sh b/tools/nb_to_org.sh new file mode 100755 index 0000000..ab80ebe --- /dev/null +++ b/tools/nb_to_org.sh @@ -0,0 +1,11 @@ +#!/bin/bash +# $ nb_to_org.sh notebook.ipynb +# produces the org-mode file notebook.org + +set -e + +nb=$(basename $1 .ipynb) +jupyter nbconvert --to markdown ${nb}.ipynb --output ${nb}.md +pandoc ${nb}.md -o ${nb}.org +rm ${nb}.md + diff --git a/tools/rename.py b/tools/rename.py new file mode 100755 index 0000000..51bb421 --- /dev/null +++ b/tools/rename.py @@ -0,0 +1,44 @@ +#!/usr/bin/env python + +""" +Changes the name of a function into all the org files. +This script should be run in the src directory. +""" + +import sys +import os + + +def help(): + print("Syntax : {0} OLD_FUNC_NAME NEW_FUNC_NAME".format(sys.argv[0])) + + + +def replace_in_file(filename, old_func_name, new_func_name): + with open(filename,'r') as f: + text = f.read() + + new_text = text.replace(old_func_name, new_func_name) + + with open(filename,'w') as f: + f.write(new_text) + + +def main(): + if len(sys.argv) != 3: + help() + sys.exit(-1) + old_func_name = sys.argv[1] + new_func_name = sys.argv[2] + + for filename in os.listdir(os.getcwd()): + if filename.endswith(".org"): + replace_in_file(filename, old_func_name, new_func_name) + + print("Done. run git diff to check what has been changed.") + + + + +if __name__ == "__main__": + main() diff --git a/tools/tangle.sh b/tools/tangle.sh new file mode 100755 index 0000000..1615465 --- /dev/null +++ b/tools/tangle.sh @@ -0,0 +1,41 @@ +#!/bin/bash +# Script to tangle the org-mode files +# :PROPERTIES: +# :header-args: :tangle tangle.sh :noweb yes :shebang #!/bin/bash :comments org +# :END: + + +# This file was created by tools/Building.org + + + +# This file needs to be run from the QMCKL =src= directory. + +# It tangles all the files in the directory. It uses the +# =config_tangle.el= file, which contains information required to +# compute the current file names using for example ~(eval c)~ to get +# the name of the produced C file. + +# The file is not tangled if the last modification date of the org +# file is less recent than one of the tangled files. + + +function tangle() +{ + local org_file=$1 + local c_file=${org_file%.org}.c + local f_file=${org_file%.org}.f90 + + if [[ ${org_file} -ot ${c_file} ]] ; then + return + elif [[ ${org_file} -ot ${f_file} ]] ; then + return + fi + emacs --batch ${org_file} --load=../tools/config_tangle.el -f org-babel-tangle +} + +for i in $@ +do + echo "--- ${i} ----" + tangle ${i} +done