2021-03-09 01:16:23 +01:00
|
|
|
#+TITLE: Context
|
|
|
|
#+SETUPFILE: ../docs/theme.setup
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2020-10-14 01:43:13 +02:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
The context variable is a handle for the state of the library,
|
2021-03-10 12:58:38 +01:00
|
|
|
and is stored in a data structure which can't be seen outside of
|
2021-03-09 01:16:23 +01:00
|
|
|
the library. To simplify compatibility with other languages, the
|
|
|
|
pointer to the internal data structure is converted into a 64-bit
|
2021-03-10 12:58:38 +01:00
|
|
|
signed integer, defined in the ~qmckl_context~ type.
|
|
|
|
A value of ~QMCKL_NULL_CONTEXT~ for the context is equivalent to a
|
|
|
|
~NULL~ pointer.
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :comments org :tangle (eval h)
|
2021-03-05 03:45:30 +01:00
|
|
|
typedef int64_t qmckl_context ;
|
2021-03-10 12:58:38 +01:00
|
|
|
#define QMCKL_NULL_CONTEXT (qmckl_context) 0
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+begin_src f90 :comments org :tangle (eval fh) :exports none
|
|
|
|
integer*8, parameter :: QMCKL_NULL_CONTEXT = 0
|
|
|
|
#+end_src
|
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
* Headers :noexport:
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+NAME: filename
|
|
|
|
#+begin_src elisp tangle: no
|
|
|
|
(file-name-nondirectory (substring buffer-file-name 0 -4))
|
|
|
|
#+end_src
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-11-05 15:27:25 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :tangle (eval c_test) :noweb yes
|
|
|
|
#include "qmckl.h"
|
|
|
|
#include "munit.h"
|
|
|
|
MunitResult test_<<filename()>>() {
|
|
|
|
#+end_src
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :tangle (eval h_private)
|
|
|
|
#ifndef __QMCKL_CONTEXT__
|
|
|
|
#define __QMCKL_CONTEXT__
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#include <stdint.h>
|
2021-03-10 12:58:38 +01:00
|
|
|
#include <pthread.h>
|
2021-03-09 01:16:23 +01:00
|
|
|
#include "qmckl_error.h"
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
#include <stdint.h>
|
|
|
|
#include <assert.h>
|
|
|
|
#include <math.h>
|
|
|
|
#include <stdlib.h>
|
|
|
|
#include <string.h>
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#include "qmckl_error.h"
|
|
|
|
#include "qmckl_context.h"
|
2021-03-10 12:58:38 +01:00
|
|
|
#include "qmckl_context_private.h"
|
2021-03-09 01:16:23 +01:00
|
|
|
#include "qmckl_memory.h"
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
|
|
|
|
|
|
|
* Context handling
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
The context appears as an immutable data structure: modifying a
|
|
|
|
context returns a new context with the modifications. Therefore, it
|
|
|
|
is necessary to store a pointer to the old version of context so
|
|
|
|
that it can be freed when necessary.
|
|
|
|
Note that we also provide a possibility to mutate the context, but
|
|
|
|
this should be done with caution, only when it is justified.
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
By convention, in this file ~context~ is a ~qmckl_context~ variable
|
|
|
|
and ~ctx~ is a ~qmckl_context_struct*~ pointer.
|
2020-11-05 15:27:25 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** Data structure
|
|
|
|
|
|
|
|
The main data structure contains pointers to other data structures,
|
|
|
|
containing the data specific to each given domain, such that the
|
|
|
|
modified contexts don't need to duplicate the data but only the
|
|
|
|
pointers.
|
|
|
|
|
|
|
|
#+NAME: qmckl_context_struct
|
|
|
|
#+begin_src c :comments org :tangle none :noweb yes
|
2020-10-16 13:58:05 +02:00
|
|
|
typedef struct qmckl_context_struct {
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
/* Pointer to the previous context, before modification */
|
2020-10-16 13:58:05 +02:00
|
|
|
struct qmckl_context_struct * prev;
|
2020-11-14 18:27:38 +01:00
|
|
|
|
|
|
|
/* Molecular system */
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_ao_basis_struct * ao_basis;
|
|
|
|
|
|
|
|
/* To be implemented:
|
|
|
|
qmckl_nucleus_struct * nucleus;
|
|
|
|
qmckl_electron_struct * electron;
|
|
|
|
qmckl_mo_struct * mo;
|
|
|
|
qmckl_determinant_struct * det;
|
|
|
|
,*/
|
2020-11-14 18:27:38 +01:00
|
|
|
|
|
|
|
/* Numerical precision */
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_precision_struct * fp;
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-05 03:45:30 +01:00
|
|
|
/* Error handling */
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_error_struct * error;
|
|
|
|
|
|
|
|
/* Memory allocation */
|
|
|
|
qmckl_memory_struct * alloc;
|
|
|
|
|
|
|
|
/* Thread lock */
|
|
|
|
pthread_mutex_t mutex;
|
|
|
|
|
|
|
|
/* Validity checking */
|
|
|
|
uint32_t tag;
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-10-14 00:52:50 +02:00
|
|
|
} qmckl_context_struct;
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-16 23:38:35 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
#+begin_src c :comments org :tangle (eval h_private) :noweb yes :exports none
|
|
|
|
<<qmckl_error_struct>>
|
|
|
|
|
|
|
|
<<qmckl_memory_struct>>
|
|
|
|
|
|
|
|
<<qmckl_precision_struct>>
|
|
|
|
|
|
|
|
<<qmckl_ao_basis_struct>>
|
|
|
|
|
|
|
|
<<qmckl_context_struct>>
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
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) :noweb yes
|
2020-10-16 23:38:35 +02:00
|
|
|
#define VALID_TAG 0xBEEFFACE
|
|
|
|
#define INVALID_TAG 0xDEADBEEF
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
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.
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+begin_src c :comments org :tangle (eval h) :noexport
|
2020-10-22 00:50:07 +02:00
|
|
|
qmckl_context qmckl_context_check(const qmckl_context context) ;
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+begin_src c :tangle (eval c)
|
2020-10-22 00:50:07 +02:00
|
|
|
qmckl_context qmckl_context_check(const qmckl_context context) {
|
2020-10-16 23:38:35 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
if (context == QMCKL_NULL_CONTEXT)
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
const qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
2020-11-05 00:46:19 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
if (ctx->tag != VALID_TAG)
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
2020-10-16 23:38:35 +02:00
|
|
|
|
2020-10-22 00:50:07 +02:00
|
|
|
return context;
|
2020-10-16 23:38:35 +02:00
|
|
|
}
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** 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
|
2020-10-14 09:54:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
2020-10-14 00:52:50 +02:00
|
|
|
qmckl_context qmckl_context_create();
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
2020-10-14 00:52:50 +02:00
|
|
|
qmckl_context qmckl_context_create() {
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_context_struct* ctx =
|
|
|
|
(qmckl_context_struct*) qmckl_malloc (QMCKL_NULL_CONTEXT, sizeof(qmckl_context_struct));
|
|
|
|
|
|
|
|
if (ctx == NULL) {
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
2020-10-14 00:52:50 +02:00
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
/* Set all pointers to NULL */
|
|
|
|
memset(ctx, 0, sizeof(qmckl_context_struct));
|
|
|
|
|
|
|
|
/* Initialize lock */
|
|
|
|
pthread_mutexattr_t attr;
|
|
|
|
int rc;
|
|
|
|
|
|
|
|
rc = pthread_mutexattr_init(&attr);
|
|
|
|
assert (rc == 0);
|
|
|
|
|
|
|
|
(void) pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK);
|
|
|
|
|
|
|
|
rc = pthread_mutex_init ( &(ctx->mutex), &attr);
|
|
|
|
assert (rc == 0);
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
(void)pthread_mutexattr_destroy(&attr);
|
|
|
|
|
|
|
|
/* Initialize data */
|
|
|
|
ctx->tag = VALID_TAG;
|
|
|
|
|
|
|
|
const qmckl_context context = (qmckl_context) ctx;
|
|
|
|
assert ( qmckl_context_check(context) != QMCKL_NULL_CONTEXT );
|
|
|
|
|
|
|
|
return context;
|
2020-10-14 00:52:50 +02:00
|
|
|
}
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
2020-11-05 00:46:19 +01:00
|
|
|
interface
|
|
|
|
integer (c_int64_t) function qmckl_context_create() bind(C)
|
|
|
|
use, intrinsic :: iso_c_binding
|
|
|
|
end function qmckl_context_create
|
|
|
|
end interface
|
2021-03-10 12:58:38 +01:00
|
|
|
#+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);
|
|
|
|
munit_assert_int64( qmckl_context_check(0x12345), ==, QMCKL_NULL_CONTEXT);
|
2020-11-05 00:46:19 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
qmckl_context context = qmckl_context_create();
|
2021-03-10 12:58:38 +01:00
|
|
|
munit_assert_int64( context, !=, QMCKL_NULL_CONTEXT );
|
|
|
|
munit_assert_int64( qmckl_context_check(context), ==, context );
|
|
|
|
#+end_src
|
2020-10-14 01:43:13 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** Locking
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
For thread safety, the context may be locked/unlocked. The lock is
|
|
|
|
initialized with the ~PTHREAD_MUTEX_ERRORCHECK~, so it is a bit
|
|
|
|
slower than a usual mutex but safer.
|
2020-10-16 19:42:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :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 *ctx = (qmckl_context_struct*) context;
|
|
|
|
int rc = pthread_mutex_lock( &(ctx->mutex) );
|
|
|
|
assert (rc == 0);
|
|
|
|
}
|
|
|
|
|
|
|
|
void qmckl_unlock(qmckl_context context) {
|
|
|
|
qmckl_context_struct *ctx = (qmckl_context_struct*) context;
|
|
|
|
int rc = pthread_mutex_unlock( &(ctx->mutex) );
|
|
|
|
assert (rc == 0);
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
** Copy
|
|
|
|
|
|
|
|
~qmckl_context_copy~ makes a shallow copy of a context. It returns
|
|
|
|
~QMCKL_NULL_CONTEXT~ upon failure.
|
|
|
|
|
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
2020-10-15 09:22:24 +02:00
|
|
|
qmckl_context qmckl_context_copy(const qmckl_context context);
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
2020-10-15 09:22:24 +02:00
|
|
|
qmckl_context qmckl_context_copy(const qmckl_context context) {
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_lock(context);
|
|
|
|
|
2020-11-05 00:46:19 +01:00
|
|
|
const qmckl_context checked_context = qmckl_context_check(context);
|
2020-10-16 23:38:35 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
if (checked_context == QMCKL_NULL_CONTEXT) {
|
|
|
|
qmckl_unlock(context);
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
2020-10-16 19:42:12 +02:00
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
qmckl_context_struct* old_ctx =
|
|
|
|
(qmckl_context_struct*) checked_context;
|
2020-11-05 00:46:19 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_context_struct* new_ctx =
|
2020-11-05 00:46:19 +01:00
|
|
|
(qmckl_context_struct*) qmckl_malloc (context, sizeof(qmckl_context_struct));
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
if (new_ctx == NULL) {
|
|
|
|
qmckl_unlock(context);
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
2020-10-14 00:52:50 +02:00
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
/* Copy the old context on the new one */
|
|
|
|
memcpy(new_ctx, old_ctx, sizeof(qmckl_context_struct));
|
|
|
|
|
|
|
|
qmckl_unlock(context);
|
|
|
|
|
|
|
|
new_ctx->prev = old_ctx;
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
return (qmckl_context) new_ctx;
|
2020-10-14 00:52:50 +02:00
|
|
|
}
|
2020-10-16 23:38:35 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-14 01:43:13 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
2020-11-05 00:46:19 +01:00
|
|
|
interface
|
|
|
|
integer (c_int64_t) function qmckl_context_copy(context) bind(C)
|
|
|
|
use, intrinsic :: iso_c_binding
|
|
|
|
integer (c_int64_t), intent(in), value :: context
|
|
|
|
end function qmckl_context_copy
|
|
|
|
end interface
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-11-05 00:46:19 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Test
|
|
|
|
#+begin_src c :comments link :tangle (eval c_test) :exports none
|
2021-03-09 01:16:23 +01:00
|
|
|
qmckl_context new_context = qmckl_context_copy(context);
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
munit_assert_int64(new_context, !=, QMCKL_NULL_CONTEXT);
|
2020-11-05 15:27:25 +01:00
|
|
|
munit_assert_int64(new_context, !=, context);
|
|
|
|
munit_assert_int64(qmckl_context_check(new_context), ==, new_context);
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
|
|
|
|
|
|
|
** Destroy
|
|
|
|
|
|
|
|
The context is destroyed with ~qmckl_context_destroy~, leaving the ancestors untouched.
|
|
|
|
It frees the context, and returns the previous context.
|
|
|
|
|
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
qmckl_context qmckl_context_destroy(qmckl_context context);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
qmckl_context qmckl_context_destroy(const qmckl_context context) {
|
|
|
|
|
|
|
|
qmckl_lock(context);
|
|
|
|
|
|
|
|
const qmckl_context checked_context = qmckl_context_check(context);
|
|
|
|
if (checked_context == QMCKL_NULL_CONTEXT) return QMCKL_NULL_CONTEXT;
|
|
|
|
|
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
assert (ctx != NULL); /* Shouldn't be true because the context is valid */
|
|
|
|
|
|
|
|
const qmckl_context prev_context = (qmckl_context) ctx->prev;
|
|
|
|
memset(ctx, 0, sizeof(qmckl_context_struct));
|
|
|
|
ctx->tag = INVALID_TAG;
|
|
|
|
|
|
|
|
const qmckl_exit_code rc = qmckl_free(context,ctx);
|
|
|
|
assert (rc == QMCKL_SUCCESS);
|
|
|
|
|
|
|
|
if (prev_context == QMCKL_NULL_CONTEXT) {
|
|
|
|
/* This is the first context, free all memory. */
|
|
|
|
while (ctx->alloc != NULL) {
|
|
|
|
free(ctx->alloc->pointer);
|
|
|
|
ctx->alloc = ctx->alloc->prev;
|
|
|
|
}
|
|
|
|
int rc = pthread_mutex_destroy( &(ctx->mutex) );
|
|
|
|
assert (rc == 0);
|
|
|
|
}
|
|
|
|
|
|
|
|
qmckl_unlock(context);
|
|
|
|
|
|
|
|
return prev_context;
|
|
|
|
}
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-15 07:56:43 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
|
|
|
interface
|
|
|
|
integer (c_int64_t) function qmckl_context_destroy(context) bind(C)
|
|
|
|
use, intrinsic :: iso_c_binding
|
|
|
|
integer (c_int64_t), intent(in), value :: context
|
|
|
|
end function qmckl_context_destroy
|
|
|
|
end interface
|
|
|
|
#+end_src
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Test
|
|
|
|
#+begin_src c :tangle (eval c_test) :exports none
|
|
|
|
munit_assert_int64(qmckl_context_check(new_context), ==, new_context);
|
|
|
|
munit_assert_int64(new_context, !=, QMCKL_NULL_CONTEXT);
|
|
|
|
munit_assert_int64(qmckl_context_destroy(new_context), ==, context);
|
|
|
|
munit_assert_int64(qmckl_context_check(new_context), !=, new_context);
|
|
|
|
munit_assert_int64(qmckl_context_check(new_context), ==, QMCKL_NULL_CONTEXT);
|
|
|
|
munit_assert_int64(qmckl_context_destroy(context), ==, QMCKL_NULL_CONTEXT);
|
|
|
|
munit_assert_int64(qmckl_context_destroy(QMCKL_NULL_CONTEXT), ==, QMCKL_NULL_CONTEXT);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
** Access to the previous context
|
|
|
|
|
|
|
|
~qmckl_context_previous~ returns the previous context. It returns
|
|
|
|
~QMCKL_NULL_CONTEXT~ for the initial context and for the ~NULL~ context.
|
2020-10-15 07:56:43 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
2020-10-16 19:42:12 +02:00
|
|
|
qmckl_context qmckl_context_previous(const qmckl_context context);
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-15 07:56:43 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :tangle (eval c)
|
2020-10-16 19:42:12 +02:00
|
|
|
qmckl_context qmckl_context_previous(const qmckl_context context) {
|
2020-10-15 07:56:43 +02:00
|
|
|
|
2020-11-05 00:46:19 +01:00
|
|
|
const qmckl_context checked_context = qmckl_context_check(context);
|
2020-10-16 23:38:35 +02:00
|
|
|
if (checked_context == (qmckl_context) 0) {
|
2020-10-16 19:42:12 +02:00
|
|
|
return (qmckl_context) 0;
|
|
|
|
}
|
|
|
|
|
2020-11-05 00:46:19 +01:00
|
|
|
const qmckl_context_struct* ctx = (qmckl_context_struct*) checked_context;
|
2020-10-16 23:38:35 +02:00
|
|
|
return qmckl_context_check((qmckl_context) ctx->prev);
|
2020-10-16 19:42:12 +02:00
|
|
|
}
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-16 19:42:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
2020-11-05 00:46:19 +01:00
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-05 00:46:19 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Test
|
|
|
|
#+begin_src c :comments link :tangle (eval c_test) :exports none
|
|
|
|
munit_assert_int64(qmckl_context_previous(new_context), !=, QMCKL_NULL_CONTEXT);
|
2020-11-05 15:27:25 +01:00
|
|
|
munit_assert_int64(qmckl_context_previous(new_context), ==, context);
|
2021-03-10 12:58:38 +01:00
|
|
|
munit_assert_int64(qmckl_context_previous(context), ==, QMCKL_NULL_CONTEXT);
|
|
|
|
munit_assert_int64(qmckl_context_previous(QMCKL_NULL_CONTEXT), ==, QMCKL_NULL_CONTEXT);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-16 19:42:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
* Memory allocation handling
|
|
|
|
|
|
|
|
** Data structure
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
Pointers to all allocated memory domains are stored in the context,
|
|
|
|
in a linked list. The size is also stored, to enable the
|
|
|
|
computation of the amount of currently used memory by the library.
|
|
|
|
|
|
|
|
#+NAME: qmckl_memory_struct
|
|
|
|
#+begin_src c :comments org :tangle no
|
|
|
|
typedef struct qmckl_memory_struct {
|
|
|
|
struct qmckl_memory_struct * prev ;
|
|
|
|
void * pointer ;
|
|
|
|
size_t size ;
|
|
|
|
} qmckl_memory_struct;
|
|
|
|
#+end_src
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** Append memory
|
|
|
|
|
|
|
|
The following function, called in [[./qmckl_memory.html][=qmckl_memory.c=]], appends a new
|
|
|
|
pair (pointer, size) to the data structure.
|
|
|
|
It is forbidden to pass the ~NULL~ pointer, or a zero size.
|
|
|
|
If the context is ~QMCKL_NULL_CONTEXT~, the function returns
|
|
|
|
immediately with ~QMCKL_SUCCESS~.
|
|
|
|
|
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h_private) :exports none
|
|
|
|
qmckl_exit_code qmckl_context_append_memory(qmckl_context context,
|
|
|
|
void* pointer,
|
|
|
|
const size_t size);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-16 19:42:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
|
|
|
#+begin_src c :comments org :tangle (eval c)
|
|
|
|
qmckl_exit_code qmckl_context_append_memory(qmckl_context context,
|
|
|
|
void* pointer,
|
|
|
|
const size_t size) {
|
|
|
|
assert (pointer != NULL);
|
|
|
|
assert (size > 0L);
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_lock(context);
|
2020-10-16 19:42:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
if ( qmckl_context_check(context) == QMCKL_NULL_CONTEXT ) {
|
|
|
|
qmckl_unlock(context);
|
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
|
|
|
|
qmckl_memory_struct* alloc = (qmckl_memory_struct*)
|
|
|
|
malloc(sizeof(qmckl_memory_struct));
|
|
|
|
|
|
|
|
if (alloc == NULL) {
|
|
|
|
qmckl_unlock(context);
|
|
|
|
return QMCKL_ALLOCATION_FAILED;
|
|
|
|
}
|
|
|
|
|
|
|
|
alloc->prev = ctx->alloc;
|
|
|
|
alloc->pointer = pointer;
|
|
|
|
alloc->size = size;
|
|
|
|
|
|
|
|
ctx->alloc = alloc;
|
|
|
|
|
|
|
|
qmckl_unlock(context);
|
|
|
|
|
|
|
|
return QMCKL_SUCCESS;
|
2020-10-15 07:56:43 +02:00
|
|
|
|
|
|
|
}
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2020-10-14 00:52:50 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** Remove memory
|
|
|
|
|
|
|
|
The following function, called in [[./qmckl_memory.html][=qmckl_memory.c=]], removes a
|
|
|
|
pointer from the data structure.
|
|
|
|
It is forbidden to pass the ~NULL~ pointer.
|
|
|
|
If the context is ~QMCKL_NULL_CONTEXT~, the function returns
|
|
|
|
immediately with ~QMCKL_SUCCESS~.
|
|
|
|
|
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h_private) :exports none
|
|
|
|
qmckl_exit_code qmckl_context_remove_memory(qmckl_context context,
|
|
|
|
const void* pointer);
|
|
|
|
#+end_src
|
2020-11-05 00:46:19 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
|
|
|
#+begin_src c :comments org :tangle (eval c)
|
|
|
|
qmckl_exit_code qmckl_context_remove_memory(qmckl_context context,
|
|
|
|
const void* pointer) {
|
|
|
|
assert (pointer != NULL);
|
|
|
|
|
|
|
|
qmckl_lock(context);
|
|
|
|
|
|
|
|
if ( qmckl_context_check(context) == QMCKL_NULL_CONTEXT ) {
|
|
|
|
qmckl_unlock(context);
|
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
|
|
|
|
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
|
|
|
|
qmckl_memory_struct* alloc;
|
|
|
|
qmckl_memory_struct* next;
|
|
|
|
|
|
|
|
if (ctx->alloc->pointer == pointer) {
|
|
|
|
|
|
|
|
alloc = ctx->alloc->prev;
|
|
|
|
free(ctx->alloc);
|
|
|
|
ctx->alloc = alloc;
|
|
|
|
|
|
|
|
} else {
|
|
|
|
|
|
|
|
next = ctx->alloc;
|
|
|
|
alloc = next->prev;
|
|
|
|
|
|
|
|
while (alloc != NULL) {
|
|
|
|
if (alloc->pointer == pointer) {
|
|
|
|
next->prev = alloc->prev;
|
|
|
|
free(alloc);
|
|
|
|
alloc = NULL;
|
|
|
|
} else {
|
|
|
|
next = alloc;
|
|
|
|
alloc = alloc->prev;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
qmckl_unlock(context);
|
|
|
|
|
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
|
|
|
#+end_src
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+RESULTS:
|
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
* Error handling
|
2021-03-10 12:58:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
** Data structure
|
|
|
|
|
|
|
|
#+NAME: qmckl_error_struct
|
2021-03-10 12:58:38 +01:00
|
|
|
#+begin_src c :comments org :tangle no
|
|
|
|
#define QMCKL_MAX_FUN_LEN 256
|
2021-03-09 01:16:23 +01:00
|
|
|
#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
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** Updating errors
|
|
|
|
|
|
|
|
The error is updated in the context using
|
|
|
|
~qmckl_context_update_error~, although it is recommended to use
|
|
|
|
~qmckl_context_set_error~ for the immutable variant.
|
|
|
|
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) :exports none
|
2021-03-09 01:16:23 +01:00
|
|
|
qmckl_exit_code
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_context_update_error(qmckl_context context,
|
|
|
|
const qmckl_exit_code exit_code,
|
|
|
|
const char* function_name,
|
|
|
|
const char* message);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
2021-03-09 01:16:23 +01:00
|
|
|
qmckl_exit_code
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_context_update_error(qmckl_context context,
|
|
|
|
const qmckl_exit_code exit_code,
|
|
|
|
const char* function_name,
|
|
|
|
const char* message)
|
2021-03-09 01:16:23 +01:00
|
|
|
{
|
2021-03-10 12:58:38 +01:00
|
|
|
/* Passing a function name and a message is mandatory. */
|
|
|
|
assert (function_name != NULL);
|
2021-03-09 01:16:23 +01:00
|
|
|
assert (message != NULL);
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
/* Exit codes are assumed valid. */
|
|
|
|
assert (exit_code >= 0);
|
|
|
|
assert (exit_code != QMCKL_SUCCESS);
|
2021-03-09 01:16:23 +01:00
|
|
|
assert (exit_code < QMCKL_INVALID_EXIT_CODE);
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_lock(context);
|
|
|
|
|
|
|
|
/* The context is assumed to exist. */
|
|
|
|
assert (qmckl_context_check(context) != QMCKL_NULL_CONTEXT);
|
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
2021-03-10 12:58:38 +01:00
|
|
|
assert (ctx != NULL); /* Impossible because the context is valid. */
|
2021-03-09 01:16:23 +01:00
|
|
|
|
|
|
|
if (ctx->error != NULL) {
|
|
|
|
free(ctx->error);
|
|
|
|
ctx->error = NULL;
|
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_error_struct* error =
|
|
|
|
(qmckl_error_struct*) qmckl_malloc (context, sizeof(qmckl_error_struct));
|
2021-03-09 01:16:23 +01:00
|
|
|
error->exit_code = exit_code;
|
2021-03-10 12:58:38 +01:00
|
|
|
strcpy(error->function, function_name);
|
2021-03-09 01:16:23 +01:00
|
|
|
strcpy(error->message, message);
|
|
|
|
|
|
|
|
ctx->error = error;
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_unlock(context);
|
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
The ~qmckl_context_set_error~ function returns a new context with
|
|
|
|
the error domain updated.
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
2021-03-09 01:16:23 +01:00
|
|
|
qmckl_context
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_context_set_error(qmckl_context context,
|
|
|
|
const qmckl_exit_code exit_code,
|
|
|
|
const char* function_name,
|
|
|
|
const char* message);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-16 19:42:12 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
qmckl_context
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_context_set_error(qmckl_context context,
|
|
|
|
const qmckl_exit_code exit_code,
|
|
|
|
const char* function_name,
|
|
|
|
const char* message)
|
2021-03-09 01:16:23 +01:00
|
|
|
{
|
2021-03-10 12:58:38 +01:00
|
|
|
/* Passing a function name and a message is mandatory. */
|
|
|
|
assert (function_name != NULL);
|
2021-03-09 01:16:23 +01:00
|
|
|
assert (message != NULL);
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
/* 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 be valid */
|
|
|
|
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT)
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
|
|
|
|
|
|
|
qmckl_context new_context = qmckl_context_copy(context);
|
|
|
|
|
|
|
|
/* Should be impossible because the context is valid */
|
|
|
|
assert (new_context != QMCKL_NULL_CONTEXT);
|
|
|
|
|
|
|
|
if (qmckl_context_update_error(new_context,
|
|
|
|
exit_code,
|
|
|
|
function_name,
|
|
|
|
message) != QMCKL_SUCCESS) {
|
|
|
|
return context;
|
|
|
|
}
|
|
|
|
|
|
|
|
return new_context;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
|
|
|
|
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. The return
|
|
|
|
code of the function is the desired return code.
|
|
|
|
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :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) {
|
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
assert (exit_code > 0);
|
|
|
|
assert (exit_code < QMCKL_INVALID_EXIT_CODE);
|
2021-03-10 12:58:38 +01:00
|
|
|
assert (function != NULL);
|
|
|
|
assert (message != NULL);
|
|
|
|
assert (strlen(function) < QMCKL_MAX_FUN_LEN);
|
|
|
|
assert (strlen(message) < QMCKL_MAX_MSG_LEN);
|
|
|
|
|
|
|
|
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT)
|
|
|
|
return QMCKL_NULL_CONTEXT;
|
|
|
|
|
|
|
|
const qmckl_exit_code rc =
|
|
|
|
qmckl_context_update_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
|
|
|
|
|
|
|
|
# To decode the error messages, ~qmckl_strerror~ converts an
|
|
|
|
# error code into a string.
|
|
|
|
|
|
|
|
* Control of the numerical precision
|
|
|
|
|
|
|
|
Controlling numerical precision enables optimizations. Here, the
|
|
|
|
default parameters determining the target numerical precision and
|
|
|
|
range are defined.
|
|
|
|
|
|
|
|
#+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 result
|
|
|
|
""" 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)" ]
|
|
|
|
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) :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)
|
|
|
|
#define QMCKL_DEFAULT_PRECISION 53
|
|
|
|
#define QMCKL_DEFAULT_RANGE 11
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
#+begin_src f90 :comments org :tangle (eval fh) :exports none
|
|
|
|
integer, parameter :: QMCKL_DEFAULT_PRECISION = 53
|
|
|
|
integer, parameter :: QMCKL_DEFAULT_RANGE = 11
|
|
|
|
#+end_src
|
|
|
|
:end:
|
|
|
|
|
|
|
|
#+NAME: qmckl_precision_struct
|
|
|
|
#+begin_src c :comments org :tangle no
|
|
|
|
typedef struct qmckl_precision_struct {
|
|
|
|
int precision;
|
|
|
|
int range;
|
|
|
|
} qmckl_precision_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_update_precision~ modifies the parameter for the
|
|
|
|
numerical precision in a context. If the context doesn't have any
|
|
|
|
precision set yet, the default values are used.
|
|
|
|
|
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
qmckl_exit_code qmckl_context_update_precision(const qmckl_context context, const int precision);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
qmckl_exit_code qmckl_context_update_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_context_update_precision",
|
|
|
|
"precision < 2");
|
|
|
|
}
|
|
|
|
|
|
|
|
if (precision > 53) {
|
|
|
|
return qmckl_failwith(context,
|
|
|
|
QMCKL_INVALID_ARG_2,
|
|
|
|
"qmckl_context_update_precision",
|
|
|
|
"precision > 53");
|
|
|
|
}
|
|
|
|
|
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
|
|
|
|
/* This should be always true */
|
|
|
|
assert (ctx != NULL);
|
|
|
|
|
|
|
|
qmckl_lock(context);
|
|
|
|
|
|
|
|
if (ctx->fp == NULL) {
|
|
|
|
|
|
|
|
ctx->fp = (qmckl_precision_struct*)
|
|
|
|
qmckl_malloc(context, sizeof(qmckl_precision_struct));
|
|
|
|
|
|
|
|
if (ctx->fp == NULL) {
|
|
|
|
return qmckl_failwith(context,
|
|
|
|
QMCKL_ALLOCATION_FAILED,
|
|
|
|
"qmckl_context_update_precision",
|
|
|
|
"ctx->fp");
|
|
|
|
}
|
|
|
|
|
|
|
|
ctx->fp->precision = QMCKL_DEFAULT_PRECISION;
|
|
|
|
ctx->fp->range = QMCKL_DEFAULT_RANGE;
|
|
|
|
}
|
|
|
|
|
|
|
|
ctx->fp->precision = precision;
|
|
|
|
|
|
|
|
qmckl_unlock(context);
|
|
|
|
|
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Fortran interface
|
|
|
|
|
|
|
|
#+begin_src f90 :tangle (eval fh)
|
|
|
|
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
|
|
|
|
|
|
|
|
~qmckl_context_set_precision~ returns a copy of the context with a
|
|
|
|
different precision parameter.
|
|
|
|
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
qmckl_context qmckl_context_set_precision(const qmckl_context context, const int precision);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval 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(new_context, precision) == QMCKL_FAILURE) return 0;
|
|
|
|
|
|
|
|
return new_context;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
|
|
|
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
|
|
|
|
|
|
|
|
~qmckl_context_get_precision~ returns the value of the numerical precision in the context.
|
|
|
|
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
int32_t qmckl_context_get_precision(const qmckl_context context);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
int qmckl_context_get_precision(const qmckl_context context) {
|
|
|
|
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
|
|
|
return qmckl_failwith(context,
|
|
|
|
QMCKL_INVALID_CONTEXT,
|
|
|
|
"qmckl_context_get_precision",
|
|
|
|
"");
|
|
|
|
}
|
|
|
|
|
|
|
|
const qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
if (ctx->fp != NULL)
|
|
|
|
return ctx->fp->precision;
|
|
|
|
else
|
|
|
|
return QMCKL_DEFAULT_PRECISION;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh)
|
|
|
|
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
|
|
|
|
|
|
|
|
** Range
|
|
|
|
|
|
|
|
~qmckl_context_update_range~ modifies the parameter for the numerical range in a given context.
|
|
|
|
|
|
|
|
# Header
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
qmckl_exit_code qmckl_context_update_range(const qmckl_context context, const int range);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
qmckl_exit_code qmckl_context_update_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_context_update_range",
|
|
|
|
"range < 2");
|
|
|
|
}
|
|
|
|
|
|
|
|
if (range > 11) {
|
|
|
|
return qmckl_failwith(context,
|
|
|
|
QMCKL_INVALID_ARG_2,
|
|
|
|
"qmckl_context_update_range",
|
|
|
|
"range > 11");
|
|
|
|
}
|
|
|
|
|
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
|
|
|
|
/* This should be always true */
|
|
|
|
assert (ctx != NULL);
|
|
|
|
|
|
|
|
qmckl_lock(context);
|
|
|
|
|
|
|
|
if (ctx->fp == NULL) {
|
|
|
|
|
|
|
|
ctx->fp = (qmckl_precision_struct*)
|
|
|
|
qmckl_malloc(context, sizeof(qmckl_precision_struct));
|
|
|
|
|
|
|
|
if (ctx->fp == NULL) {
|
|
|
|
return qmckl_failwith(context,
|
|
|
|
QMCKL_ALLOCATION_FAILED,
|
|
|
|
"qmckl_context_update_range",
|
|
|
|
"ctx->fp");
|
|
|
|
}
|
|
|
|
|
|
|
|
ctx->fp->precision = QMCKL_DEFAULT_PRECISION;
|
|
|
|
ctx->fp->range = QMCKL_DEFAULT_RANGE;
|
|
|
|
}
|
|
|
|
|
|
|
|
ctx->fp->range = range;
|
|
|
|
|
|
|
|
qmckl_unlock(context);
|
|
|
|
|
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh)
|
|
|
|
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
|
|
|
|
|
|
|
|
~qmckl_context_set_range~ returns a copy of the context with a different precision parameter.
|
|
|
|
|
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
qmckl_context qmckl_context_set_range(const qmckl_context context, const int range);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
|
|
|
|
#+begin_src c :tangle (eval 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(new_context, range) == QMCKL_FAILURE) return 0;
|
|
|
|
|
|
|
|
return new_context;
|
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
~qmckl_context_get_range~ returns the value of the numerical range in the context.
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
int32_t qmckl_context_get_range(const qmckl_context context);
|
|
|
|
#+end_src
|
|
|
|
|
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
int qmckl_context_get_range(const qmckl_context context) {
|
|
|
|
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
|
|
|
return qmckl_failwith(context,
|
|
|
|
QMCKL_INVALID_CONTEXT,
|
|
|
|
"qmckl_context_get_range",
|
|
|
|
"");
|
2021-03-09 01:16:23 +01:00
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
const qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
if (ctx->fp != NULL)
|
|
|
|
return ctx->fp->range;
|
|
|
|
else
|
|
|
|
return QMCKL_DEFAULT_RANGE;
|
2021-03-09 01:16:23 +01:00
|
|
|
}
|
2021-03-10 12:58:38 +01:00
|
|
|
#+end_src
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
** Helper functions
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
~qmckl_context_get_epsilon~ returns $\epsilon = 2^{1-n}$ where ~n~ is the precision.
|
2021-03-09 01:16:23 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+begin_src c :comments org :tangle (eval h) :exports none
|
|
|
|
double qmckl_context_get_epsilon(const qmckl_context context);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
|
|
|
double qmckl_context_get_epsilon(const qmckl_context context) {
|
|
|
|
const qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
return 1. / (double) (1 << (1 - ctx->fp->precision));
|
2021-03-09 01:16:23 +01:00
|
|
|
}
|
|
|
|
#+end_src
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
# Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh) :exports none
|
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2021-03-10 12:58:38 +01:00
|
|
|
|
|
|
|
|
|
|
|
* TODO Basis set
|
2021-03-09 01:16:23 +01:00
|
|
|
|
|
|
|
For H_2 with the following basis set,
|
|
|
|
|
|
|
|
#+BEGIN_EXAMPLE
|
2020-11-14 18:27:38 +01:00
|
|
|
HYDROGEN
|
|
|
|
S 5
|
|
|
|
1 3.387000E+01 6.068000E-03
|
|
|
|
2 5.095000E+00 4.530800E-02
|
2021-03-05 03:45:30 +01:00
|
|
|
3 1.159000E+00 2.028220E-01
|
2020-11-14 18:27:38 +01:00
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
#+END_EXAMPLE
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
we have:
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+BEGIN_EXAMPLE
|
2020-11-14 18:27:38 +01:00
|
|
|
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]
|
2021-03-09 01:16:23 +01:00
|
|
|
#+END_EXAMPLE
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
** Data structure
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+NAME: qmckl_ao_basis_struct
|
|
|
|
#+begin_src c :comments org :tangle no
|
|
|
|
typedef struct qmckl_ao_basis_struct {
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
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;
|
|
|
|
|
|
|
|
} qmckl_ao_basis_struct;
|
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
** ~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 (eval h)
|
2020-11-14 18:27:38 +01:00
|
|
|
qmckl_exit_code
|
2021-03-10 12:58:38 +01:00
|
|
|
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 ,
|
2020-11-14 18:27:38 +01:00
|
|
|
const int64_t * SHELL_PRIM_INDEX,
|
2021-03-10 12:58:38 +01:00
|
|
|
const double * EXPONENT ,
|
|
|
|
const double * COEFFICIENT);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
2020-11-14 18:27:38 +01:00
|
|
|
qmckl_exit_code
|
|
|
|
qmckl_context_update_ao_basis(qmckl_context context , const char type,
|
2021-03-05 03:45:30 +01:00
|
|
|
const int64_t shell_num , const int64_t prim_num,
|
2020-11-14 18:27:38 +01:00
|
|
|
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;
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-11-14 18:27:38 +01:00
|
|
|
for (i=0 ; i<shell_num ; i++) {
|
|
|
|
if (SHELL_CENTER[i] <= 0) return QMCKL_FAILURE;
|
|
|
|
if (SHELL_PRIM_NUM[i] <= 0) return QMCKL_FAILURE;
|
|
|
|
if (SHELL_ANG_MOM[i] < 0) return QMCKL_FAILURE;
|
|
|
|
if (SHELL_PRIM_INDEX[i] < 0) return QMCKL_FAILURE;
|
|
|
|
}
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-11-14 18:27:38 +01:00
|
|
|
for (i=0 ; i<prim_num ; i++) {
|
|
|
|
if (EXPONENT[i] <= 0) return QMCKL_FAILURE;
|
|
|
|
}
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-11-14 18:27:38 +01:00
|
|
|
qmckl_context_struct* ctx = (qmckl_context_struct*) context;
|
|
|
|
if (ctx == NULL) return QMCKL_FAILURE;
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
qmckl_ao_basis_struct* basis =
|
|
|
|
(qmckl_ao_basis_struct*) qmckl_malloc (context, sizeof(qmckl_ao_basis_struct));
|
|
|
|
if (basis == NULL) return QMCKL_ALLOCATION_FAILED;
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-11-14 18:27:38 +01:00
|
|
|
|
|
|
|
/* Memory allocations */
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
basis->shell_center = (int64_t*) qmckl_malloc (context, shell_num * sizeof(int64_t));
|
2020-11-14 18:27:38 +01:00
|
|
|
if (basis->shell_center == NULL) {
|
2021-03-05 03:45:30 +01:00
|
|
|
qmckl_free(context, basis);
|
2020-11-14 18:27:38 +01:00
|
|
|
return QMCKL_FAILURE;
|
|
|
|
}
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
basis->shell_ang_mom = (int32_t*) qmckl_malloc (context, shell_num * sizeof(int32_t));
|
2020-11-14 18:27:38 +01:00
|
|
|
if (basis->shell_ang_mom == NULL) {
|
2021-03-05 03:45:30 +01:00
|
|
|
qmckl_free(context, basis->shell_center);
|
|
|
|
qmckl_free(context, basis);
|
2020-11-14 18:27:38 +01:00
|
|
|
return QMCKL_FAILURE;
|
|
|
|
}
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
basis->shell_prim_num= (int64_t*) qmckl_malloc (context, shell_num * sizeof(int64_t));
|
2020-11-14 18:27:38 +01:00
|
|
|
if (basis->shell_prim_num == NULL) {
|
2021-03-05 03:45:30 +01:00
|
|
|
qmckl_free(context, basis->shell_ang_mom);
|
|
|
|
qmckl_free(context, basis->shell_center);
|
|
|
|
qmckl_free(context, basis);
|
2020-11-14 18:27:38 +01:00
|
|
|
return QMCKL_FAILURE;
|
|
|
|
}
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
basis->shell_factor = (double *) qmckl_malloc (context, shell_num * sizeof(double ));
|
2020-11-14 18:27:38 +01:00
|
|
|
if (basis->shell_factor == NULL) {
|
2021-03-05 03:45:30 +01:00
|
|
|
qmckl_free(context, basis->shell_prim_num);
|
|
|
|
qmckl_free(context, basis->shell_ang_mom);
|
|
|
|
qmckl_free(context, basis->shell_center);
|
|
|
|
qmckl_free(context, basis);
|
2020-11-14 18:27:38 +01:00
|
|
|
return QMCKL_FAILURE;
|
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
basis->exponent = (double *) qmckl_malloc (context, prim_num * sizeof(double ));
|
2020-11-14 18:27:38 +01:00
|
|
|
if (basis->exponent == NULL) {
|
2021-03-05 03:45:30 +01:00
|
|
|
qmckl_free(context, basis->shell_factor);
|
|
|
|
qmckl_free(context, basis->shell_prim_num);
|
|
|
|
qmckl_free(context, basis->shell_ang_mom);
|
|
|
|
qmckl_free(context, basis->shell_center);
|
|
|
|
qmckl_free(context, basis);
|
2020-11-14 18:27:38 +01:00
|
|
|
return QMCKL_FAILURE;
|
|
|
|
}
|
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
basis->coefficient = (double *) qmckl_malloc (context, prim_num * sizeof(double ));
|
2020-11-14 18:27:38 +01:00
|
|
|
if (basis->coefficient == NULL) {
|
2021-03-05 03:45:30 +01:00
|
|
|
qmckl_free(context, basis->exponent);
|
|
|
|
qmckl_free(context, basis->shell_factor);
|
|
|
|
qmckl_free(context, basis->shell_prim_num);
|
|
|
|
qmckl_free(context, basis->shell_ang_mom);
|
|
|
|
qmckl_free(context, basis->shell_center);
|
|
|
|
qmckl_free(context, basis);
|
2020-11-14 18:27:38 +01:00
|
|
|
return QMCKL_FAILURE;
|
|
|
|
}
|
|
|
|
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2020-11-14 18:27:38 +01:00
|
|
|
/* Assign data */
|
|
|
|
|
|
|
|
basis->type = type;
|
|
|
|
basis->shell_num = shell_num;
|
2021-03-05 03:45:30 +01:00
|
|
|
basis->prim_num = prim_num;
|
2020-11-14 18:27:38 +01:00
|
|
|
|
|
|
|
for (i=0 ; i<shell_num ; i++) {
|
|
|
|
basis->shell_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 ; i<prim_num ; i++) {
|
|
|
|
basis->exponent [i] = EXPONENT[i];
|
|
|
|
basis->coefficient[i] = COEFFICIENT[i];
|
|
|
|
}
|
|
|
|
|
|
|
|
ctx->ao_basis = basis;
|
|
|
|
return QMCKL_SUCCESS;
|
|
|
|
}
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh)
|
2020-11-14 18:27:38 +01:00
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** TODO Test
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
** ~qmckl_context_set_ao_basis~
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
Sets the data describing the AO basis set into the context.
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
| ~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 |
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :comments org :tangle (eval h)
|
2020-11-14 18:27:38 +01:00
|
|
|
qmckl_context
|
|
|
|
qmckl_context_set_ao_basis(const qmckl_context context , const char type,
|
2021-03-05 03:45:30 +01:00
|
|
|
const int64_t shell_num , const int64_t prim_num,
|
2020-11-14 18:27:38 +01:00
|
|
|
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);
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** Source
|
|
|
|
#+begin_src c :tangle (eval c)
|
2020-11-14 18:27:38 +01:00
|
|
|
qmckl_context
|
|
|
|
qmckl_context_set_ao_basis(const qmckl_context context , const char type,
|
2021-03-05 03:45:30 +01:00
|
|
|
const int64_t shell_num , const int64_t prim_num,
|
2020-11-14 18:27:38 +01:00
|
|
|
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;
|
|
|
|
|
2021-03-05 03:45:30 +01:00
|
|
|
if (qmckl_context_update_ao_basis(new_context, type, shell_num, prim_num,
|
|
|
|
SHELL_CENTER, SHELL_ANG_MOM, SHELL_FACTOR,
|
2020-11-14 18:27:38 +01:00
|
|
|
SHELL_PRIM_NUM, SHELL_PRIM_INDEX, EXPONENT,
|
|
|
|
COEFFICIENT
|
|
|
|
) == QMCKL_FAILURE)
|
|
|
|
return 0;
|
|
|
|
|
|
|
|
return new_context;
|
|
|
|
}
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** Fortran interface
|
|
|
|
#+begin_src f90 :tangle (eval fh)
|
2020-11-14 18:27:38 +01:00
|
|
|
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
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-11-14 18:27:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** TODO Test
|
2020-10-22 00:50:07 +02:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
* End of files :noexport:
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#+begin_src c :comments link :tangle (eval h_private)
|
2020-10-16 13:58:05 +02:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
#endif
|
|
|
|
#+end_src
|
2021-03-10 12:58:38 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
*** Test
|
|
|
|
#+begin_src c :comments link :tangle (eval c_test)
|
2020-11-05 15:27:25 +01:00
|
|
|
return MUNIT_OK;
|
2020-10-22 00:50:07 +02:00
|
|
|
}
|
2021-03-09 01:16:23 +01:00
|
|
|
#+end_src
|
2020-10-16 13:58:05 +02:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
*** 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
|
2021-03-05 03:45:30 +01:00
|
|
|
|
2021-03-10 12:58:38 +01:00
|
|
|
#+RESULTS:
|
|
|
|
| | color |
|
|
|
|
| | listings |
|
2020-11-05 15:27:25 +01:00
|
|
|
|
2021-03-09 01:16:23 +01:00
|
|
|
# -*- mode: org -*-
|
|
|
|
# vim: syntax=c
|
2021-03-10 12:58:38 +01:00
|
|
|
|