mirror of
https://github.com/TREX-CoE/qmckl.git
synced 2024-08-18 03:11:44 +02:00
424 lines
13 KiB
Org Mode
424 lines
13 KiB
Org Mode
# -*- 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"
|
|
(org-with-point-at org-babel-current-src-block-location
|
|
(org-entry-get nil key t))
|
|
#+end_src
|
|
|
|
** Table of function arguments
|
|
|
|
#+NAME: test
|
|
| Variable | Type | In/Out | Description |
|
|
|-----------+------------------+--------+-----------------------------------------------|
|
|
| ~context~ | ~qmckl_context~ | in | Global state |
|
|
| ~transa~ | ~char~ | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed |
|
|
| ~transb~ | ~char~ | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed |
|
|
| ~m~ | ~int64_t~ | in | Number of points in the first set |
|
|
| ~n~ | ~int64_t~ | in | Number of points in the second set |
|
|
| ~A~ | ~double[][lda]~ | in | Array containing the $m \times 3$ matrix $A$ |
|
|
| ~lda~ | ~int64_t~ | in | Leading dimension of array ~A~ |
|
|
| ~B~ | ~double[][ldb]~ | in | Array containing the $n \times 3$ matrix $B$ |
|
|
| ~ldb~ | ~int64_t~ | in | Leading dimension of array ~B~ |
|
|
| ~C~ | ~double[n][ldc]~ | out | Array containing the $m \times n$ matrix $C$ |
|
|
| ~ldc~ | ~int64_t~ | 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)'
|
|
, 'bool' : 'logical*8'
|
|
, 'int32_t' : 'integer (c_int32_t)'
|
|
, 'int64_t' : 'integer (c_int64_t)'
|
|
, 'uint32_t' : 'integer (c_int32_t)'
|
|
, 'uint64_t' : 'integer (c_int64_t)'
|
|
, 'float' : 'real (c_float )'
|
|
, 'double' : 'real (c_double )'
|
|
, 'char' : 'character'
|
|
}
|
|
#+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)'
|
|
, 'character' : 'character(c_char)'
|
|
}
|
|
#+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 [ [x.replace('~','') for x in y] for y in table]:
|
|
d = { "name" : line[0],
|
|
"c_type" : line[1],
|
|
"inout" : line[2].lower(),
|
|
"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["c_type"].replace("[]","[*]").split('[')
|
|
d["rank"] = len(dims) - 1
|
|
if d["rank"] == 0:
|
|
d["dims"] = []
|
|
else:
|
|
d["c_type"] = d["c_type"].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=test :var rettyp="qmckl_exit_code" :var fname=[] :results drawer :noweb yes :wrap "src c :tangle (eval h_func) :comments org"
|
|
<<parse_table>>
|
|
|
|
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} (\n{results} ); """
|
|
return template
|
|
|
|
#+END_SRC
|
|
|
|
#+RESULTS: generate_c_header
|
|
#+begin_src c :tangle (eval h_func) :comments org
|
|
qmckl_exit_code [] (
|
|
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
|
|
|
|
*** 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"
|
|
<<c_of_f>>
|
|
<<f_of_c>>
|
|
<<parse_table>>
|
|
d = parse_table(table)
|
|
|
|
args = ", ".join([ x["name"] for x in d ])
|
|
if len(args) > 100:
|
|
args = args.replace(",",""", &
|
|
""")
|
|
|
|
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"
|
|
<<c_of_f>>
|
|
<<f_of_c>>
|
|
<<parse_table>>
|
|
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
|
|
|
|
|
|
|
|
** Creating provide functions
|
|
|
|
#+NAME: write_provider_header
|
|
#+BEGIN_SRC python :var group="GROUP" :var data="DATA" :results drawer :noweb yes :wrap "src c :comments org :tangle (eval h_private_func) :noweb yes :export none"
|
|
template = "qmckl_exit_code qmckl_provide_{{ group }}_{{ data }}(qmckl_context context);"
|
|
|
|
msg = template.replace("{{ group }}", group) \
|
|
.replace("{{ data }}", data)
|
|
return msg
|
|
#+END_SRC
|
|
|
|
#+RESULTS: write_provider_header
|
|
#+begin_src c :comments org :tangle (eval h_private_func) :noweb yes :export none
|
|
qmckl_exit_code qmckl_provide_GROUP_DATA(qmckl_context context);
|
|
#+end_src
|
|
|
|
#+NAME: write_provider_pre
|
|
#+BEGIN_SRC python :var group="GROUP" :var data="DATA" :var dimension="DIMENSION" :results drawer :noweb yes :wrap "src c :comments org :tangle (eval c) :noweb yes :export none"
|
|
template = """qmckl_exit_code qmckl_provide_{{ group }}_{{ data }}(qmckl_context context)
|
|
{
|
|
|
|
qmckl_exit_code rc = QMCKL_SUCCESS;
|
|
|
|
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
|
return qmckl_failwith( context,
|
|
QMCKL_INVALID_CONTEXT,
|
|
"qmckl_provide_{{ group }}_{{ data }}",
|
|
NULL);
|
|
}
|
|
|
|
qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
|
|
assert (ctx != NULL);
|
|
|
|
if (!ctx->{{ group }}.provided) {
|
|
return qmckl_failwith( context,
|
|
QMCKL_NOT_PROVIDED,
|
|
"qmckl_provide_{{ group }}_{{ data }}",
|
|
NULL);
|
|
}
|
|
|
|
/* Compute if necessary */
|
|
if (ctx->point.date > ctx->{{ group }}.{{ data }}_date) {
|
|
|
|
qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero;
|
|
mem_info.size = {{ dimension }} * sizeof(double);
|
|
|
|
if (ctx->{{ group }}.{{ data }} != NULL) {
|
|
qmckl_memory_info_struct mem_info_test = qmckl_memory_info_struct_zero;
|
|
rc = qmckl_get_malloc_info(context, ctx->{{ group }}.{{ data }}, &mem_info_test);
|
|
|
|
/* if rc != QMCKL_SUCCESS, we are maybe in an _inplace function because the
|
|
memory was not allocated with qmckl_malloc */
|
|
|
|
if ((rc == QMCKL_SUCCESS) && (mem_info_test.size != mem_info.size)) {
|
|
rc = qmckl_free(context, ctx->{{ group }}.{{ data }});
|
|
assert (rc == QMCKL_SUCCESS);
|
|
ctx->{{ group }}.{{ data }} = NULL;
|
|
}
|
|
}
|
|
|
|
/* Allocate array */
|
|
if (ctx->{{ group }}.{{ data }} == NULL) {
|
|
|
|
double* {{ data }} = (double*) qmckl_malloc(context, mem_info);
|
|
|
|
if ({{ data }} == NULL) {
|
|
return qmckl_failwith( context,
|
|
QMCKL_ALLOCATION_FAILED,
|
|
"qmckl_{{ group }}_{{ data }}",
|
|
NULL);
|
|
}
|
|
ctx->{{ group }}.{{ data }} = {{ data }};
|
|
}
|
|
|
|
"""
|
|
|
|
msg = template.replace("{{ group }}", group) \
|
|
.replace("{{ data }}", data) \
|
|
.replace("{{ dimension }}", dimension)
|
|
return msg
|
|
#+END_SRC
|
|
|
|
#+RESULTS: write_provider_pre
|
|
#+begin_src c :comments org :tangle (eval c) :noweb yes :export none
|
|
qmckl_exit_code qmckl_provide_GROUP_DATA(qmckl_context context)
|
|
{
|
|
|
|
qmckl_exit_code rc;
|
|
|
|
if (qmckl_context_check(context) == QMCKL_NULL_CONTEXT) {
|
|
return qmckl_failwith( context,
|
|
QMCKL_INVALID_CONTEXT,
|
|
"qmckl_provide_GROUP_DATA",
|
|
NULL);
|
|
}
|
|
|
|
qmckl_context_struct* const ctx = (qmckl_context_struct*) context;
|
|
assert (ctx != NULL);
|
|
|
|
if (!ctx->GROUP.provided) {
|
|
return qmckl_failwith( context,
|
|
QMCKL_NOT_PROVIDED,
|
|
"qmckl_provide_GROUP_DATA",
|
|
NULL);
|
|
}
|
|
|
|
/* Compute if necessary */
|
|
if (ctx->point.date > ctx->GROUP.DATA_date) {
|
|
|
|
if (ctx->point.alloc_date > ctx->GROUP.DATA_date) {
|
|
rc = qmckl_free(context, ctx->GROUP.DATA);
|
|
assert (rc == QMCKL_SUCCESS);
|
|
ctx->GROUP.DATA = NULL;
|
|
}
|
|
|
|
/* Allocate array */
|
|
if (ctx->GROUP.DATA == NULL) {
|
|
|
|
qmckl_memory_info_struct mem_info = qmckl_memory_info_struct_zero;
|
|
mem_info.size = DIMENSION * sizeof(double);
|
|
double* DATA = (double*) qmckl_malloc(context, mem_info);
|
|
|
|
if (DATA == NULL) {
|
|
return qmckl_failwith( context,
|
|
QMCKL_ALLOCATION_FAILED,
|
|
"qmckl_GROUP_DATA",
|
|
NULL);
|
|
}
|
|
ctx->GROUP.DATA = DATA;
|
|
}
|
|
|
|
#+end_src
|
|
|
|
#+NAME: write_provider_post
|
|
#+BEGIN_SRC python :var group="BASIS" :var data="DATA" :results drawer :noweb yes :wrap "src c :comments org :tangle (eval c) :noweb yes :export none"
|
|
template = """ if (rc != QMCKL_SUCCESS) {
|
|
return rc;
|
|
}
|
|
|
|
ctx->{{ group }}.{{ data }}_date = ctx->date;
|
|
}
|
|
|
|
return QMCKL_SUCCESS;
|
|
}
|
|
"""
|
|
|
|
msg = template.replace("{{ group }}", group) \
|
|
.replace("{{ data }}", data)
|
|
|
|
return msg
|
|
#+END_SRC
|
|
|
|
#+RESULTS: write_provider_post
|
|
#+begin_src c :comments org :tangle (eval c) :noweb yes :export none
|
|
if (rc != QMCKL_SUCCESS) {
|
|
return rc;
|
|
}
|
|
|
|
ctx->BASIS.DATA_date = ctx->date;
|
|
}
|
|
|
|
return QMCKL_SUCCESS;
|
|
}
|
|
#+end_src
|