ftnlf

Check-in [d0293b60c0]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Subroutine to copy slices to/from Fortran array.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d0293b60c0b32a24832974f6d672dc24ef329840
User & Date: vadim 2018-05-09 13:01:55
Context
2018-05-14
10:12
Beginning index for apack/aunpack. check-in: 72408ec7a9 user: vadim tags: trunk
2018-05-09
13:01
Subroutine to copy slices to/from Fortran array. check-in: d0293b60c0 user: vadim tags: trunk
2018-05-08
15:47
Make public FA metatable id. check-in: 9fe618515b user: vadim tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ftnlf_fxcore.f90.

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
301
302
303
304
305
306
307















































308
309
310
311
312
313
314
! (Fortran arrayas, linear interpolation, ...)
module ftnlf_fxcore
    use LuaF
    use LuaFE
    use, intrinsic :: iso_c_binding, only: c_int, c_ptr
    implicit none
    private
    ! Public API: loader function, userdata ids,
    ! C functions to operate with Fortran arrays
    public ldr_fx_core
    public l_fa_new, l_fa_pack, l_fa_unpack
    public mt_FA, mt_interp

    character(*), parameter :: mt_FA = 'ftnlf.fx.fa'
    character(*), parameter :: mt_interp = 'ftnlf.fx.interp'

contains

    ! FX.Core module loader
................................................................................

        ! Disassociate
        arr => NULL()

        ! Return output arguments, discard everything else
        r = nvals
    end function l_fa_unpack
















































    ! ======= Fortran Arrays =======


    ! ======= Interpolation Objects =======

    ! Interpolation of the 0th and 1st order







|


|
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
! (Fortran arrayas, linear interpolation, ...)
module ftnlf_fxcore
    use LuaF
    use LuaFE
    use, intrinsic :: iso_c_binding, only: c_int, c_ptr
    implicit none
    private
    ! Public API: loader function, userdata id for interp objects,
    ! C functions to operate with Fortran arrays
    public ldr_fx_core
    public l_fa_new, l_fa_pack, l_fa_unpack, fx_fa_copy
    public mt_interp

    character(*), parameter :: mt_FA = 'ftnlf.fx.fa'
    character(*), parameter :: mt_interp = 'ftnlf.fx.interp'

contains

    ! FX.Core module loader
................................................................................

        ! Disassociate
        arr => NULL()

        ! Return output arguments, discard everything else
        r = nvals
    end function l_fa_unpack

    ! ---- Some useful Fortran API to work with FA
    ! Copy values from/to Fortran Array
    ! WARNING: unprotected Lua API calls. Use inside pcall.
    subroutine fx_fa_copy(L, ix, kbeg, from, to)
        use, intrinsic :: iso_c_binding, only: c_f_pointer
        type(c_ptr), intent(in) :: L
        integer(4), intent(in) :: ix, kbeg
        real(8), optional, intent(in) :: from(:)
        real(8), optional, intent(inout) :: to(:)

        type(c_ptr) :: ud
        integer(4) :: s, kend
        integer(c_int) :: r
        real(8), pointer :: arr(:)
        
        ! Check arg, get length
        ud = luaL_checkudata(L, ix, F_C_STR(mt_FA))
        ! bytes to double
        s = INT(lua_objlen(L, ix)/8, 4)

        ! Associate
        call c_f_pointer(ud, arr, [s])
        
        if (present(from)) then
            ! Copy to userdata object
            ! Check bounds
            kend = kbeg-1+size(from)
            if (kbeg < 1 .or.  kend > s) then
                r = luaL_argerror(L, ix, F_C_STR('out of bounds'))
            endif
            arr(kbeg:kend) = from(:)
        elseif (present(to)) then
            ! Copy from userdata object
            ! Check bounds
            kend = kbeg-1+size(to)
            if (kbeg < 1 .or.  kend > s) then
                r = luaL_argerror(L, ix, F_C_STR('out of bounds'))
            endif
            to(:) = arr(kbeg:kend)
        end if

        ! Disassociate
        arr => NULL()

    end subroutine fx_fa_copy


    ! ======= Fortran Arrays =======


    ! ======= Interpolation Objects =======

    ! Interpolation of the 0th and 1st order

Changes to test.f90.

15
16
17
18
19
20
21

22
23
24
25
26
27
28
..
34
35
36
37
38
39
40














41
42
43
44
45
46
47
        integer(c_int) :: r

        ! Pop package name
        call lua_pop(L, 1)

        call lua_newtable(L)
        call luaFE_register(L, 'testfun', l_test)


        r = 1
    end function ldr_fx_test

    function l_test(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r
................................................................................
        
        v = v + sqrt(2.d0)

        call lua_pushnumber(L, v)
        
        r = 1
    end function l_test















end module testmod

program test
    ! Mockup for ftnlf
    use ftnlf
    use luaFE, only: luaFE_FunctionEntry







>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
        integer(c_int) :: r

        ! Pop package name
        call lua_pop(L, 1)

        call lua_newtable(L)
        call luaFE_register(L, 'testfun', l_test)
        call luaFE_register(L, 'test2', l_test2)

        r = 1
    end function ldr_fx_test

    function l_test(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r
................................................................................
        
        v = v + sqrt(2.d0)

        call lua_pushnumber(L, v)
        
        r = 1
    end function l_test

    function l_test2(L) bind(C) result(r)
        use ftnlf_fxcore, only: fx_fa_copy
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r
        real(8) :: a(5)

        call fx_fa_copy(L, 1, 3, to=a(2:3))
        a = a + 0.5d0
        call fx_fa_copy(L, 1, 4, from=a)
        print *, 'IN: ', a

        r = 0
    end function l_test2

end module testmod

program test
    ! Mockup for ftnlf
    use ftnlf
    use luaFE, only: luaFE_FunctionEntry

Changes to testdb.lua.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
42
43
44
45
46
47
48
49



50









dir1 = {
   tbl1 = { v5 = function(x,y) return x-y end },
   tbl2 = { v6 = FXC.interp({-10,1,10,70}), v7 = -29.3e-4},

}

if false then
local A = FXC.array(4)
print(#A)
print(A[1])
A[1] = 96.7
print(A[1])
A[1] = 0.1
print(A[1])
................................................................................
print(FXC.aunpack(B))

local Z = FXC.array(9000)
print(FXC.aunpack(Z,5))

local T = require('FX.Test')
print(T.testfun(-1.4))




end















|







 








>
>
>

>
>
>
>
>
>
>
>
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

dir1 = {
   tbl1 = { v5 = function(x,y) return x-y end },
   tbl2 = { v6 = FXC.interp({-10,1,10,70}), v7 = -29.3e-4},

}

if true then
local A = FXC.array(4)
print(#A)
print(A[1])
A[1] = 96.7
print(A[1])
A[1] = 0.1
print(A[1])
................................................................................
print(FXC.aunpack(B))

local Z = FXC.array(9000)
print(FXC.aunpack(Z,5))

local T = require('FX.Test')
print(T.testfun(-1.4))

A = FXC.array(10)
for k = 1, #A do
   A[k] = k
end

T.test2(A)
print('OUT: ')
for k = 1, #A do
   print(A[k])
end

end