Again - Mixed language programming Tcl/Tk and Fortran (Windows)

From: Gustav Ivanovic (gustav_ivanovic_at_yahoo.com)
Date: 12/23/04 

Date: 23 Dec 2004 14:10:16 -0800

Arjen, I know you will love this one.

I improved the concept I posted two days ago.
Calling fortran routines stored in a DLL becomes extremely easy.

Be careful with wrapped lines.

Have fun !

namespace eval Fortran {
    ##############################################################
    # Provide simplified declarations to call fortran routines in
    # a DLL built using Compaq Visual Fortran
    # Please use as you wish, but there is no guarantee whatsoever.
    #
    # Please report bugs. Thank you.
    # gustav_ivanovic@yahoo.com
    ###############################################################
    catch {package require Ffidl}
    
    proc Binarize {varType args} {
        foreach var $args {
            upvar $var x
            if {$varType == "a"} {
                set x [binary format a* $x]
            } else {
                set x [binary format $varType[llength $x] $x]
            }
        }
    };#End proc Binarize
    
    proc deBinarize {varType args} {
        foreach var $args {
            
            upvar $var x
            switch $varType {
                i {binary scan $x i[expr {[string length $x]/4}] x}
                f {binary scan $x f[expr {[string length $x]/4}] x}
                d {binary scan $x d[expr {[string length $x]/8}] x}
                default {binary scan $x a* x}
            }
        }
    };#End proc deBinarize
    
    proc declareRoutine {DLLname routineName argDef {tclName
{$routineName}} {returnType {0}}} {
        ####################
        # usage:
        # Fortran::declareRoutine dllName routineName argDef
tclName returnType
        # e.g Fortran::declareRoutine FtnTcl.dll scalarproduct {f f
i} SCAPROD f
        ##########################
        # argument definition is
        # a or A string of charaters
        # I or i integer or array of integers
        # F or f or R or r real or array of reals
        # D or d double precision or array of double precision reals
        #
        # if no tclName specified, a command routineName is created.
        # However, I recommend to specify a tclName
        # Example
        # a. Fortran::declareRoutine FtnTcl.dll doublevectorsum {D D
D i}
        # a new command named doublevectorsum is created
        # b. Fortran::declareRoutine FtnTcl.dll doublevectorsum {D D
D i} doublSum
        # a new command named doublSum is created
        ##########################
        
        if {$tclName == {}} {
            set tclName $routineName
        }
        
        set ffidlDecl {}
        set argTypeList {}
        set argList {}
        set argCount 0
        
        # store argument type as a list
        foreach i $argDef {
            lappend argList arg$argCount
            lappend ffidlDecl pointer-var
            set varType [string index $i 0]
            switch -regexp $varType {
                [iI] {lappend argTypeList i}
                [rRfF] {lappend argTypeList f}
                [dD] {lappend argTypeList d}
                default { ;# if it is not integer or a real then it is
a string
                    lappend ffidlDecl int
                    lappend argTypeList a
                }
            }
            incr argCount
        }
        
        # define return value type. Only void, integer, real and
double
        set retType [string index $returnType 0]
        switch -regexp $retType {
            [iI] {set retType int}
            [rRfF] {set retType float}
            [dD] {set retType double}
            default {set retType void}
        }
        
        eval [subst {ffidl::callout ::Fortran::ffidl-$routineName
{$ffidlDecl} $retType [ffidl::symbol $DLLname $routineName]}]
        # DEBUG
        # puts [subst {ffidl::callout ::Fortran::ffidl-$routineName
{$ffidlDecl} $retType [ffidl::symbol $DLLname $routineName]}]
        
        # Define a procedure that Binarizes, call the entry in the DLL
and deBinarizes (stored in cmd and to be eval'ed)
        set cmd {}
        append cmd {proc ::} $tclName " \{$argList\} \{"
        for {set i 0} {$i < $argCount} {incr i} {
            append cmd "\n upvar \$[lindex $argList $i] x$i"
        }
        for {set i 0} {$i < $argCount} {incr i} {
            append cmd "\n ::Fortran::Binarize [lindex $argTypeList
$i] x$i"
        }
        set ffidlArgs {}
        for {set i 0} {$i < $argCount} {incr i} {
            append ffidlArgs " x$i"
            if {[lindex $argTypeList $i] == "a"} {
                append ffidlArgs { [string length $} "x$i" {]}
            }
        }
        append cmd "\n set retval \[ ::Fortran::ffidl-$routineName
$ffidlArgs \]"
        for {set i 0} {$i < $argCount} {incr i} {
            append cmd "\n ::Fortran::deBinarize [lindex
$argTypeList $i] x$i"
        }
        append cmd "\n return \$retval\n" \}
        # make that new command
        eval $cmd
        # DEBUG
        # puts $cmd
    };#End proc declareRoutine
    
};#End namespace Fortran

proc test {} {
    load ffidl05
    
    # Declare all routines
    ####################
    # usage
    # Fortran::declareRoutine dllName routineName argDef tclName
returnType
    # e.g Fortran::declareRoutine FtnTcl.dll scalarproduct {f f i}
SCAPROD f
    ####################
    
    Fortran::declareRoutine FtnTcl.dll string a STRING
    # in the above example
    # if no tclName is specified, then it creates confusion with
"string"
    
    Fortran::declareRoutine FtnTcl.dll realvector f
    Fortran::declareRoutine FtnTcl.dll integervector i
    Fortran::declareRoutine FtnTcl.dll scalarproduct {f f i} SCAPROD f
    # we defined a new name and the return value type as a real
    
    Fortran::declareRoutine FtnTcl.dll doublevectorsum {d d d i}
    
    # Use of the declared functions starts here
    puts "Test 1"
    set a {1 2 3}
    puts "a was $a"
    integervector a
    puts "a is now "
    puts $a
    puts "\n\nTest 2"
    set a {1 2 3}
    set b {10 20 30}
    set c {0 0 0}
    set l 3
    puts "a is $a"
    puts "b is $b"
    puts "c is $c"
    doublevectorsum a b c l
    puts "after"
    puts "a is now $a"
    puts "b is now $b"
    puts "c is now $c"
    
    puts "\n\nTest 3 scalar product <a,b>"
    puts [SCAPROD a b l]
    
    puts "a is +$a+"
    STRING a
    puts "a is now +$a+"
}
# Run the test
test

Relevant Pages