ftnlf

Check-in [9baf4464d3]
Login

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

Overview
Comment:Version of apack with input table.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:9baf4464d38fbb115ea218a7b4561ea26081c419
User & Date: vadim 2018-05-14 11:43:39
Context
2018-05-14
11:47
Extra test. check-in: e6f10e8262 user: vadim tags: trunk, caller-allocates
11:43
Version of apack with input table. check-in: 9baf4464d3 user: vadim tags: trunk
10:12
Beginning index for apack/aunpack. check-in: 72408ec7a9 user: vadim tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ftnlf_fxcore.f90.

24
25
26
27
28
29
30

31
32
33
34
35
36
37
...
270
271
272
273
274
275
276




























































































277
278
279
280
281
282
283
...
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

        ! Pop package name
        call lua_pop(L, 1)

        call lua_newtable(L)
        call luaFE_register(L, 'array', l_fa_new)
        call luaFE_register(L, 'apack', l_fa_pack)

        call luaFE_register(L, 'aunpack', l_fa_unpack)
        call luaFE_register(L, 'interp', l_interp_new)

        r = 1
    end function ldr_fx_core

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

        ! Disassociate
        arr => NULL()

        ! Return userdata (on the stack top), throw away arguments
        r = 1
    end function l_fa_pack





























































































    ! Unpack numeric arguments from existing Fortran array
    ! Usage: v1, v2, ..., vn = aunpack(arr, ix1, ix2)
    ! where ix1 is:
    !  - number (1 <= ix1 <= #arr)
    !  - nil or none => ix1 = 1
    ! where ix2 is:
................................................................................
        ! bytes to double
        s = lua_objlen(L, 1)/8

        ! Check 2nd arg
        if (lua_isnoneornil(L, 2)) then
            ! Default
            ix1 = 1_c_int
            !nvals = int(s, c_int)
        else
            ! Get start index
            ix1 = luaL_checkint(L, 2)
        end if

        ! Check 3rd arg
        if (lua_isnoneornil(L, 3)) then







>







 







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







 







<







24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
...
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
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
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
...
395
396
397
398
399
400
401

402
403
404
405
406
407
408

        ! Pop package name
        call lua_pop(L, 1)

        call lua_newtable(L)
        call luaFE_register(L, 'array', l_fa_new)
        call luaFE_register(L, 'apack', l_fa_pack)
        call luaFE_register(L, 'apackt', l_fa_packt)
        call luaFE_register(L, 'aunpack', l_fa_unpack)
        call luaFE_register(L, 'interp', l_interp_new)

        r = 1
    end function ldr_fx_core

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

        ! Disassociate
        arr => NULL()

        ! Return userdata (on the stack top), throw away arguments
        r = 1
    end function l_fa_pack

    ! Pack numeric arguments into existing or new Fortran array
    ! Usage: v = apack({arg1, arg2, ...., argn}, arr, ix)
    ! n = #ARG >= 0
    ! where arr is:
    !  - existing Fortran array where to pack (#arr >= n+ix-1)
    !  - N => create new array of length N (N >= n+ix-1)
    !  - nil or none => create new array of length (n+ix-1)
    ! where ix is:
    !  - i => start index 
    !  - nil or none => start index 1
    function l_fa_packt(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_intptr_t, c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(4) :: nargs, typ, k, ix

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check args
        call luaL_checktype(L, 1, LUA_TTABLE)
        ! #ARG
        nargs = int(lua_objlen(L, 1), 4)

        ! Adjust stack top; fill missing args with nil
        call lua_settop(L, 3)

        ! Obtain start index
        if (lua_isnil(L, 3)) then
            ! Default
            ix = 1
        else
            ! Get start index
            ix = luaL_checkint(L, 3)
        end if
        ! Pop start index
        call lua_pop(L, 1)

        ! deal with array
        typ = lua_type(L, 2)
        if (typ == LUA_TUSERDATA) then
            ! Now stack is: {arg1 ... argn} ud
            ud = luaL_checkudata(L, 2, F_C_STR(mt_FA))
            
            ! obtain length
            ! (bytes to double)
            s = lua_objlen(L, 2)/8
        else
            if (typ == LUA_TNIL) then
                ! default size
                ! pop nil
                call lua_pop(L, 1)
                s = nargs+ix-1
                ! push size
                call lua_pushinteger(L, s)
            else
                ! expect number
                s = luaL_checkinteger(L, 2)
            end if
            
            ! create new Fortran array of requested size
            call lua_pushcfunction(L, c_funloc(l_fa_new))
            call lua_insert(L, -2)
            call lua_call(L, 1, 1)

            ! Now stack is: {arg1 ... argn} ud
            ud = lua_touserdata(L, -1)
        end if

        ! check bounds
        if (s < nargs+ix-1) then
            r = luaL_argerror(L, 1, F_C_STR('too many arguments'))
        end if

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Fill array
        do k = 1, nargs
            call lua_rawgeti(L, 1, k)
            arr(ix-1+k) = luaFE_checkdouble(L, -1, 'table element')
            call lua_pop(L, 1)
        end do

        ! Disassociate
        arr => NULL()

        ! Return userdata (on the stack top), throw away arguments
        r = 1
    end function l_fa_packt

    ! Unpack numeric arguments from existing Fortran array
    ! Usage: v1, v2, ..., vn = aunpack(arr, ix1, ix2)
    ! where ix1 is:
    !  - number (1 <= ix1 <= #arr)
    !  - nil or none => ix1 = 1
    ! where ix2 is:
................................................................................
        ! bytes to double
        s = lua_objlen(L, 1)/8

        ! Check 2nd arg
        if (lua_isnoneornil(L, 2)) then
            ! Default
            ix1 = 1_c_int

        else
            ! Get start index
            ix1 = luaL_checkint(L, 2)
        end if

        ! Check 3rd arg
        if (lua_isnoneornil(L, 3)) then

Changes to testdb.lua.

34
35
36
37
38
39
40









41
42
43
44
45
46
47
..
63
64
65
66
67
68
69










70
71
72
73
74
75
76
..
77
78
79
80
81
82
83










84
85
86

local A = FXC.apack(11,22,33,nil,nil)
print(A[1], A[2], A[3])
local B = FXC.apack(4,5,A,nil)
print(A[1], A[2], A[3])
print(#B)
print(B[1], B[2], B[3])










print(FXC.aunpack(B))

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

local T = require('FX.Test')
................................................................................
for k = 1, #A do
   print(A[k])
end
local B = FXC.apack(55,66,A,3)
for k = 1, #A do
   print(A[k],B[k])
end











print('Unpack test')
local ttt = { FXC.aunpack(A,1,0) }
print(#ttt)
local ttt = { FXC.aunpack(A,nil,3) }
for i,v in ipairs(ttt) do print(i,v) end
print('---')
................................................................................
local ttt = { FXC.aunpack(A,4,nil) }
for i,v in ipairs(ttt) do print(i,v) end

print('Special test of pack')
A = FXC.apack(nil,6)
for k = 1, #A do
   print(A[k])










end

end







>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>



34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
..
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
..
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

local A = FXC.apack(11,22,33,nil,nil)
print(A[1], A[2], A[3])
local B = FXC.apack(4,5,A,nil)
print(A[1], A[2], A[3])
print(#B)
print(B[1], B[2], B[3])

print('COPY:<<')
local A = FXC.apackt({11,22,33})
print(A[1], A[2], A[3])
local B = FXC.apackt({4,5},A)
print(A[1], A[2], A[3])
print(#B)
print(B[1], B[2], B[3])
print('>>')

print(FXC.aunpack(B))

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

local T = require('FX.Test')
................................................................................
for k = 1, #A do
   print(A[k])
end
local B = FXC.apack(55,66,A,3)
for k = 1, #A do
   print(A[k],B[k])
end
print('COPY:<<')
A = FXC.apackt({41,42,43},nil,2)
for k = 1, #A do
   print(A[k])
end
local B = FXC.apackt({55,66},A,3)
for k = 1, #A do
   print(A[k],B[k])
end
print('>>')

print('Unpack test')
local ttt = { FXC.aunpack(A,1,0) }
print(#ttt)
local ttt = { FXC.aunpack(A,nil,3) }
for i,v in ipairs(ttt) do print(i,v) end
print('---')
................................................................................
local ttt = { FXC.aunpack(A,4,nil) }
for i,v in ipairs(ttt) do print(i,v) end

print('Special test of pack')
A = FXC.apack(nil,6)
for k = 1, #A do
   print(A[k])
end
print('Special test of packt')
A = FXC.apackt({},3)
for k = 1, #A do
   print(A[k])
end
print('Special test of packt/2')
A = FXC.apackt({},nil,6)
for k = 1, #A do
   print(A[k])
end

end