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

Two parts:
1. Tcl code
2. Fortran code. Compile this with CFV to make a dll.
in the example it is called FtnTcl.dll

Be careful with truncated lines.

Have fun !

PART 1 Tcl

 ########################################
##############
namespace eval Fortran {

 ########################################
#########
# Provides simplified call to CV Fortran DLL for strings and
arrays
# Works with Compaq Visual Fortran 6.1A
# See also "Programming with Mixed Languages" chapter in CVF
Reference Manual
# ffidl can be found here http://www.elf.org/ffidl/
 ########################################
#########

proc DirectCall {DLLname routineName varType var} {
# varType is a, i, f or d
#    a means CHARACTER(LEN=*) in Compaq Visual Fortran
#    f means REAL, DIMENSION(*) in Compaq Visual Fortran
#    d means DOUBLE PRECISION, DIMENSION(*) in Compaq Visual
Fortran
#    i means INTEGER, DIMENSION(*) in Compaq Visual Fortran,
#
#      array size shall be defined as argument in fortran
#      see fortran source code
#

upvar $var x
if {$varType == "a"} {
eval [subst {ffidl::callout TclCallName {pointer-var int}
void [ffidl::symbol $DLLname $routineName]}]
set x [binary format a* $x]
TclCallName x [string length $x]
binary scan $x a* x
} else {
eval [subst {ffidl::callout TclCallName {pointer-var} void
[ffidl::symbol $DLLname $routineName]}]
set formatString $varType[llength $x]
set x [binary format $formatString $x]
TclCallName x
binary scan $x $formatString x
}
};#End proc DirectCall

proc DefineCallout {DLLname routineName argDef returnDef} {
# The callout will be inside Fortran namespace ( e.g
Fortran::scalarproduct )
eval [subst {ffidl::callout ::Fortran::$routineName {$argDef}
$returnDef [ffidl::symbol $DLLname $routineName]}]
};#End proc DefineCallout

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 de-binarize {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 a* $x x}
}
}
};#End proc de-binarize


};#End namespace Fortran


proc runTest {} {

# Example starts here
load ffidl05.dll

# Call routines using Fortran::DirectCall
# Example with strings
puts "Test 1"
set line ABCDE***
puts $line
Fortran::DirectCall FtnTcl.dll string a line
puts $line

# Example with integers
puts "Test 2"
set x {1 2 3 4}
puts $x
Fortran::DirectCall FtnTcl.dll integervector i x
puts $x

# Example with floating points
puts "Test 3"

set x {1 2 3 4}
puts $x
Fortran::DirectCall FtnTcl.dll realvector f x
puts $x

# Example with double precisions
puts "Test 4"
set x {1 2 3 4}
puts $x
Fortran::DirectCall FtnTcl.dll doublevector d x
puts $x

# Define Callout using Fortran::DefineCallout and then call the
routine
puts "Test 5"
Fortran::DefineCallout FtnTcl.dll scalarproduct {pointer-var
pointer-var pointer-var} float

set l 4
set x {1 1 1 1}
set y {2 2 2 2}
Fortran::binarize i l
Fortran::binarize f x y
puts [Fortran::scalarproduct x y l]

puts "Test 6"
set x {1 2 3 4}
set y {0 0 0 0}
Fortran::binarize f x y
puts [Fortran::scalarproduct x y l]

# More  examples
# define the callout using ffidl
puts "More examples"
ffidl::callout scalarProduct {pointer-var pointer-var pointer-var}
float [ffidl::symbol FtnTcl.dll scalarproduct]
ffidl::callout doubleVectorSum {pointer-var pointer-var
pointer-var pointer-var} float [ffidl::symbol FtnTcl.dll
doublevectorsum]

set x {1 2 3 4}
set y {1 2 3 4}
set l 4
Fortran::binarize f x y
Fortran::binarize i l
puts [scalarProduct x y l]

set y {10 10 10 10}
Fortran::binarize f y
puts [scalarProduct x y l]

set x {1 2 3 4}
set y {10 10 10 10}
set z $x
Fortran::binarize d x y z
doubleVectorSum x y z l
Fortran::de-binarize d x y z
puts $x
puts $y
puts $z
};#Endproc runTest

###########
#EXECUTE IT
###########
runTest
 ########################################
##############


PART 2 Fortran

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!
MODULE tcl


CONTAINS


SUBROUTINE doublevector(vector)
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'doublevector' ::doublevector
DOUBLE PRECISION , DIMENSION(*) :: vector
vector(3)=3333.
END SUBROUTINE doublevector

SUBROUTINE realvector(vector)
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'realvector' ::realvector
REAL , DIMENSION(*) :: vector
vector(2)=2222.
END SUBROUTINE realvector


SUBROUTINE integervector(vector)
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'integervector' ::integervector
INTEGER , DIMENSION(*) :: vector
vector(1)=1111
END SUBROUTINE integervector


SUBROUTINE string(line)
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'string'::string
CHARACTER(LEN=*) :: line
line='QWERTY'
END SUBROUTINE string

FUNCTION scalarproduct(x,y,n) RESULT (z)
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'scalarproduct'::scalarproduct
INTEGER ::n
REAL, DIMENSION(n) :: x, y
REAL :: z
z=sum(x*y)
END FUNCTION scalarproduct

SUBROUTINE doublevectorsum(x,y,z,n)
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS:
'doublevectorsum'::doublevectorsum
INTEGER ::n
DOUBLE PRECISION, DIMENSION(n) :: x, y, z
z=x+y
END SUBROUTINE doublevectorsum

END MODULE tcl
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!

Gustav Ivanovic wrote:
>
> Two parts:
> 1. Tcl code
> 2. Fortran code. Compile this with CFV to make a dll.
>    in the example it is called FtnTcl.dll
>
> Be careful with truncated lines.
>
> Have fun !
>

This is cute.

Do you know my "Ftcl" library? (It is available on
the Internet at various places)

The philosophy there is to have a Fortran program
that can use a Tcl interpreter - it tries to make
the interface as transparant as possible.

But, I must say, this looks like a nice solution too :)

Regards.

Arjen