ftnlf

Check-in [72408ec7a9]
Login

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

Overview
Comment:Beginning index for apack/aunpack.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:72408ec7a9be66e04b41fdf5543d6787aa42afa5
User & Date: vadim 2018-05-14 10:12:47
Context
2018-05-14
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
2018-05-09
13:01
Subroutine to copy slices to/from Fortran array. check-in: d0293b60c0 user: vadim tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to CMakeLists.txt.

60
61
62
63
64
65
66

67

68
69
70
71
72
73
74

set (src_test
	test.f90
	)

add_library(ftnlf STATIC ${src_lib})
set_target_properties(ftnlf PROPERTIES COMPILE_FLAGS "${FCFLAGS} ${FCFLAGS90}")

set_target_properties(ftnlf PROPERTIES INTERPROCEDURAL_OPTIMIZATION 1)


add_executable(ftnlf_test ${src_test})
# Link static
target_link_libraries(ftnlf_test ftnlf ${LUA_STATIC_LIB} ${CMAKE_DL_LIBS})
# Link dynamic
# target_link_libraries(ftnlf ${LUA_LIBRARIES})
set_target_properties(ftnlf_test PROPERTIES COMPILE_FLAGS "${FCFLAGS} ${FCFLAGS90}")







>
|
>







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

set (src_test
	test.f90
	)

add_library(ftnlf STATIC ${src_lib})
set_target_properties(ftnlf PROPERTIES COMPILE_FLAGS "${FCFLAGS} ${FCFLAGS90}")
if(CMAKE_BUILD_TYPE STREQUAL "Release")
	set_target_properties(ftnlf PROPERTIES INTERPROCEDURAL_OPTIMIZATION 1)
endif()

add_executable(ftnlf_test ${src_test})
# Link static
target_link_libraries(ftnlf_test ftnlf ${LUA_STATIC_LIB} ${CMAKE_DL_LIBS})
# Link dynamic
# target_link_libraries(ftnlf ${LUA_LIBRARIES})
set_target_properties(ftnlf_test PROPERTIES COMPILE_FLAGS "${FCFLAGS} ${FCFLAGS90}")

Changes to ftnlf_fxcore.f90.

178
179
180
181
182
183
184
185
186
187
188
189
190



191
192
193
194
195
196
197
198
199
200
201
202
203

204


205













206


207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261






262
263
264
265
266
267
268
269
270
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
        r = lua_setmetatable(L, -2)
        
        ! Return userdata
        r = 1
    end function l_fa_new

    ! Pack numeric arguments into existing or new Fortran array
    ! Usage: v = apack(arg1, arg2, ...., argn, arr)
    ! n >= 0
    ! where arr is:
    !  - existing Fortran array where to pack (#arr >= n)
    !  - N => create new array of length N (N >= n)
    !  - nil => create new array of length n



    function l_fa_pack(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) :: nlast, nargs, typ, k

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check args
        nlast = lua_gettop(L)

        nargs = nlast - 1


        typ = lua_type(L, -1)
















        if (typ == LUA_TUSERDATA) then
            ! Now stack is: arg1 ... argn ud
            ud = luaL_checkudata(L, nlast, F_C_STR(mt_FA))
            
            ! obtain length
            ! (bytes to double)
            s = lua_objlen(L, -1)/8
        else
            if (typ == LUA_TNIL) then
                ! default size
                ! pop nil
                call lua_pop(L, 1)
                s = nargs
                ! push size
                call lua_pushinteger(L, s)
            elseif (typ == LUA_TNUMBER) then
                s = lua_tointeger(L, -1)
            else
                s = 0
                r = luaL_argerror(L, nlast, F_C_STR('invalid value'))
            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) then
            r = luaL_argerror(L, 2, F_C_STR('too many arguments'))
        end if

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Fill array
        do k = 1, nargs
            arr(k) = luaL_checknumber(L, k)
        end do

        ! 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, n)
    ! where n is:
    !  - number (0 <= n <= #arr)
    !  - nil or none => unpack all (n == #arr)






    function l_fa_unpack(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(c_int) :: nvals, k

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check 1st arg, get length
        ud = luaL_checkudata(L, 1, F_C_STR(mt_FA))
        ! bytes to double
        s = lua_objlen(L, 1)/8

        ! Check 2nd arg
        if (lua_isnoneornil(L, 2)) then
            ! Default

            nvals = int(s, c_int)
        else
            ! Get number of output values

            nvals = luaL_checkint(L, 2)











            ! check bounds
            if (s < nvals) then

                r = luaL_argerror(L, 2, F_C_STR('too many output values'))
            end if



        end if


        ! Provide stack
        call luaL_checkstack(L, nvals, F_C_STR('too many output values'))

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Push elements of array
        do k = 1, nvals
            call lua_pushnumber(L, arr(k))
        end do

        ! Disassociate
        arr => NULL()

        ! Return output arguments, discard everything else







|


|
|
|
>
>
>





|






|
>
|
>
>

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

>
>


|









|






|












|
|






|










|
|
|
|
>
>
>
>
>
>





|













>
|

<
>
|
>

>
>
>
>
>
>
>
>
>
|
<
>
|
|
>
>
>


>






|







178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
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
        r = lua_setmetatable(L, -2)
        
        ! Return userdata
        r = 1
    end function l_fa_new

    ! Pack numeric arguments into existing or new Fortran array
    ! Usage: v = apack(arg1, arg2, ...., argn, arr, ix)
    ! n >= 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 => create new array of length (n+ix-1)
    ! where ix is:
    !  - i => start index 
    !  - nil => start index 1
    function l_fa_pack(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) :: nlast1, nlast2, nargs, typ, k, ix

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check args
        nlast2 = lua_gettop(L)
        nlast1 = nlast2 - 1
        nargs = nlast1 - 1

        ! Obtain start index
        typ = lua_type(L, -1)
        if (typ == LUA_TNUMBER) then
            ix = int(lua_tointeger(L, nlast2), 4)
        else
            if (typ == LUA_TNIL) then
                ! default start index
                ix = 1
            else
                ix = 0
                r = luaL_argerror(L, nlast2, F_C_STR('invalid value'))
            end if
        end if
        ! pop index
        call lua_pop(L, 1)

        ! deal with array
        typ = lua_type(L, -1)
        if (typ == LUA_TUSERDATA) then
            ! Now stack is: arg1 ... argn ud
            ud = luaL_checkudata(L, nlast1, F_C_STR(mt_FA))
            
            ! obtain length
            ! (bytes to double)
            s = lua_objlen(L, -1)/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)
            elseif (typ == LUA_TNUMBER) then
                s = lua_tointeger(L, -1)
            else
                s = 0
                r = luaL_argerror(L, nlast1, F_C_STR('invalid value'))
            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, nlast1, F_C_STR('too many arguments'))
        end if

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Fill array
        do k = 1, nargs
            arr(ix-1+k) = luaL_checknumber(L, k)
        end do

        ! 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:
    !  - number (1 <= ix2 <= #arr)
    !  - nil or none => ix2 = #arr
    ! unpacks from ix1 to ix2 (ix1:ix2)
    ! if ix2 < ix1, then length is 0

    function l_fa_unpack(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(c_int) :: k, ix1, ix2, nvals

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check 1st arg, get length
        ud = luaL_checkudata(L, 1, F_C_STR(mt_FA))
        ! 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
            ! Default
            ix2 = int(s, c_int)
        else
            ! Get end index
            ix2 = luaL_checkint(L, 3)
        end if

        ! check bounds

        if (ix1 <= 0) then
            r = luaL_argerror(L, 2, F_C_STR('invalid start index'))
        end if

        if (ix2 > s) then
            r = luaL_argerror(L, 3, F_C_STR('invalid end index'))
        end if

        nvals = max(1+ix2-ix1, 0)
        ! Provide stack
        call luaL_checkstack(L, nvals, F_C_STR('too many output values'))

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Push elements of array
        do k = ix1, ix2
            call lua_pushnumber(L, arr(k))
        end do

        ! Disassociate
        arr => NULL()

        ! Return output arguments, discard everything else

Changes to testdb.lua.

28
29
30
31
32
33
34
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





















A[1] = 0.1
print(A[1])

local jjj = FXC.interp({0,1,10,0,15,-3})
print('[] ',jjj[4])
print('() ',jjj(4))

local A = FXC.apack(11,22,33,nil)
print(A[1], A[2], A[3])
local B = FXC.apack(4,5,A)
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,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




























|

|







|







 








>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
28
29
30
31
32
33
34
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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
A[1] = 0.1
print(A[1])

local jjj = FXC.interp({0,1,10,0,15,-3})
print('[] ',jjj[4])
print('() ',jjj(4))

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')
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

print('pack shift:')
A = FXC.apack(41,42,43,nil,2)
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