[Arjen Markus] This page is meant to elaborate the management of interactive [Fortran] programs via [Tcl].

''Note:'' Very sketchy right now - I want to get the information available

----
Below is a simple example:
   * Tcl asks for a string and puts it to an executable program written in Fortran.
   * This program reads the string and writes it out, until the string is "q", then it exits.
   * At this moment, Tcl must exit too.

The trick is to use file events to handle the buffering and broken pipe issues correctly 
and to use the non-standard Fortran routine flush() to flush the output buffers.
----
The Tcl code:

   global inout
   set inout [open "|copy_inp" "w+"]
   fconfigure $inout -buffering none

   puts "Input:"
   fileevent $inout readable {
      gets $::inout copied
      puts $copied
      if { [eof $inout] } { close $inout; set forever 1 }
   }
   fileevent stdin readable {
      gets stdin line
      puts $::inout $line
      puts "Input:"
   }
   vwait forever

----
The Fortran code:

   !  copy_inp.f90 --
   !     Copy stdin to stdout - IPC test
   !
   program copy_inp
      ! Compaq Visual Fortran requires:
      ! use dflib

      character(len=60) :: string

      do
         read(*,*)  string
         write(*,*) 'Copied: ', string
         call flush( 6 )

         ! On SGI use:
         ! call flush( 101 )

         if ( string .eq. 'q' ) stop
      enddo
   end program

''Notes:''

   * Standard output is usually unit 6, but on SGI it is unit 101
   * As FLUSH() is non-standard, you may need to add a USE statement, or link with a special library

----
See also: [open], [exec], [Inventory of IPC methods]
----
[Peter K��¤mpf] I needed to make Tcl work together with Fortran ''without'' having a C compiler at hand,
and Arjen was so kind to supply me with an object file which just needs to be linked to a Ftcl interface
and the Fortran stuff. To show how it works I have put together an example:

This has been compiled using Compaq Visual Fortran 6.5 on Windows, and I had no other
compiler to test it with, so all the rest just refers to CVF. Normally I work with Macs as they
are much more fun to program, but this had to be don on Windoze. Hated it!!!

First, create a new Workspace for a Dynamic Link Library, name it as you want and specify an empty
DLL application on the next page. Click Finish.

Next, load the two source files "Ftcl_mod.f90" and "ftcl_exm.f90" (listing to be found below) by right-
clicking the folder icon "Source Files" and selecting "Add files to folder". If you don't see it first,
click on the "+" sign below the workspace icon in the workspace file view.

Then, add the object file "Ftcl_c.obj" by selecting Project/Add to Project. Do the same for the Tcl stubs
library "tcl83stubs.lib" (in the lib subfolder of your Tcl folder).
Then, go to Project/Settings, select the Link tab and check "Link incrementally".

Now build the DLL. Depending on whether you specified a Debug or a Release version, the DLL is now in
an appropriately named subfolder. To make it easier for Tcl to find it, just drag it over to your
Tcl/bin directory and add the Tcl script "Caesar.tcl" (also listed below) to that folder as well.
Make sure that you use your workspace name when you call your DLL from Tcl! For this, open the file "Caesar.tcl"
and put your workspace name where it now says "Test" in the line {load Test.dll ftcl}.

Now fire up "wish83" and select the script "Caesar.tcl" via the File/Source menu in the console. 
What happens next should be quite obvious: Either it works, or you blame me for anything that went wrong ...

You can reach me at [mailto:Peter.Kaempf@fbmev.de] for further questioning and to get the object file. In the
meantime I try to figure out how to upload binary stuff to the wiki.

Allright now, first the (lengthy) Fortran interface file Ftcl_mod.f90:

  ! DOC
  !
  !  ftcl_mod.f90 - module for interacting with Tcl/Tk
  !
  !  Copyright (C) 1999 Arjen Markus
  !
  !  Arjen Markus
  !
  !
  !  General information:
  !  This module contains routines to interface with Tcl/Tk as
  !  described in the documentation (ftcl.html).
  !  Note that some interfaces are merely a front-end for the
  !  actual C routines.
  !
  ! ENDDOC
  !
  ! --------------------------------------------------------------------
  !   Module:   FTCL
  !   Author:   Arjen Markus
  !   Purpose:  Interaction with Tcl/Tk
  !   Context:  Used by application programs
  !   Summary:
  !             Defines interfaces and some actual routines for
  !             interacting with Tcl/Tk.
  !   Note:
  !             We have not included the INTENT attributes for those
  !             routines that are implemented in C
  ! --------------------------------------------------------------------
  !
  module FTCL

   implicit none

  !
  ! All public interfaces are defined after this:
  !
   public
  !
  ! Interface for the generic ftcl_get() routines
  !
   interface ftcl_get

      subroutine ftcl_get_int( varname, int_value )
         CHARACTER*(*) varname
         INTEGER       int_value
      end subroutine ftcl_get_int

      subroutine ftcl_get_real( varname, real_value )
         CHARACTER*(*) varname
         REAL          real_value
      end subroutine ftcl_get_real

      subroutine ftcl_get_log( varname, log_value )
         CHARACTER*(*) varname
         LOGICAL       log_value
      end subroutine ftcl_get_log

      subroutine ftcl_get_double( varname, double_value )
         CHARACTER*(*)    varname
         DOUBLE PRECISION double_value
      end subroutine ftcl_get_double

      subroutine ftcl_get_string( varname, string )
         CHARACTER*(*) varname
         CHARACTER*(*) string
      end subroutine ftcl_get_string

      module procedure ftcl_get_int_array
      module procedure ftcl_get_real_array

   end interface
  !
  ! Interface for the generic ftcl_put() routines
  !
   interface ftcl_put

      subroutine ftcl_put_int( varname, int_value )
         CHARACTER*(*) varname
         INTEGER       int_value
      end subroutine ftcl_put_int

      subroutine ftcl_put_real( varname, real_value )
         CHARACTER*(*) varname
         REAL          real_value
      end subroutine ftcl_put_real

      subroutine ftcl_put_double( varname, double_value )
         CHARACTER*(*)    varname
         DOUBLE PRECISION double_value
      end subroutine ftcl_put_double

      subroutine ftcl_put_log( varname, log_value )
         CHARACTER*(*) varname
         LOGICAL       log_value
      end subroutine ftcl_put_log

      subroutine ftcl_put_string( varname, string )
         CHARACTER*(*) varname
         CHARACTER*(*) string
      end subroutine ftcl_put_string

      module procedure ftcl_put_int_array
      module procedure ftcl_put_real_array

   end interface
  !
  ! Interface for the ftcl_script() routine
  ! (The result, if any, is copied into the "ftcl_result" variable)
  !
   interface

      subroutine ftcl_script( script )
         CHARACTER*(*) script
      end subroutine ftcl_script

   end interface
  !
  ! All private variables are defined here
  !
  contains
  !
  ! Administrative routines - for C interface
  !
  subroutine ftcl_init_log( true_value, false_value )
   LOGICAL       true_value
   LOGICAL       false_value

   true_value  = .true.
   false_value = .false.

   return
  end subroutine ftcl_init_log
  !
  ! Subroutines for transferring an entire array
  !
  subroutine ftcl_get_int_array( varname, int_array )
   CHARACTER*(*)            :: varname
   INTEGER, dimension(:)    :: int_array

   integer                  :: idx
   integer                  :: no_elems
   character(len=5)         :: elid
   character(len=40)        :: element

   no_elems = size( int_array )

   do idx = 1,no_elems
      write( elid, '(i5)' ) idx
      element = trim( varname ) // '(' // trim( elid ) // ')'
      call ftcl_get( element, int_array(idx) )
   enddo

  end subroutine ftcl_get_int_array

  subroutine ftcl_get_real_array( varname, real_array )
   CHARACTER*(*)            :: varname
   REAL, dimension(:)       :: real_array

   integer                  :: idx
   integer                  :: no_elems
   character(len=5)         :: elid
   character(len=40)        :: element

   no_elems = size( real_array )

   do idx = 1,no_elems
      write( elid, '(i5)' ) idx
      element = trim( varname ) // '(' // trim( elid ) // ')'
      call ftcl_get( element, real_array(idx) )
   enddo

  end subroutine ftcl_get_real_array

  subroutine ftcl_put_int_array( varname, int_array )
   CHARACTER*(*)            :: varname
   INTEGER, dimension(:)    :: int_array

   integer                  :: idx
   integer                  :: no_elems
   character(len=5)         :: elid
   character(len=40)        :: element

   no_elems = size( int_array )

   do idx = 1,no_elems
      write( elid, '(i5)' ) idx
      element = trim( varname ) // '(' // trim( elid ) // ')'
      call ftcl_put( element, int_array(idx) )
   enddo

  end subroutine ftcl_put_int_array

  subroutine ftcl_put_real_array( varname, real_array )
   CHARACTER*(*)            :: varname
   REAL, dimension(:)       :: real_array

   integer                  :: idx
   integer                  :: no_elems
   character(len=5)         :: elid
   character(len=40)        :: element

   no_elems = size( real_array )

   do idx = 1,no_elems
      write( elid, '(i5)' ) idx
      element = trim( varname ) // '(' // trim( elid ) // ')'
      call ftcl_put( element, real_array(idx) )
   enddo

  end subroutine ftcl_put_real_array

  end module FTCL

  ! -------------------------------------------------------------------------
  ! Routines outside the module:
  ! Administrative routines - for C interface
  ! -------------------------------------------------------------------------
  !
  subroutine ftcl_init_log( true_value, false_value )
   LOGICAL       true_value
   LOGICAL       false_value

   true_value  = .true.
   false_value = .false.

   return
  end subroutine ftcl_init_log
  !
----
Now the Fortran interface (which is called ftcl_exm.f90):

  ! DOC
  !
  !  ftcl_exm.f   - example of usage of FTCL
  !
  !  Copyright (C) 1999 Arjen Markus
  !
  !  Arjen Markus
  !
  !
  !  General information:
  !  This file contains a sample implementation of FTCL's ftcl_exec
  !  routine as described in the documentation (ftcl.html).
  !  It is used for demonstration and testing purposes. 
  ! 
  ! ENDDOC
  ! --------------------------------------------------------------------
  !   Routine:  ftcl_exec
  !   Author:   Arjen Markus, adapted for CAESAR by Peter Kmpf
  !   Purpose:  Provide services to Tcl/Tk
  !   Context:  Used by ftn_exec() in the C library for FTCL
  !   Summary:
  !             Determine which service to call and call its routine.
  !   Note:
  !             We have not included the INTENT attributes for those
  !             routines that are implemented in C
  ! --------------------------------------------------------------------
  !
       subroutine ftcl_exec (service, noargs, ierror)
       USE FTCL

       implicit none

       character*(*) service
       integer       noargs, Laenge, Shift
       integer       ierror
       character*256 Input
       character*256 Output

       ierror = 0

  !
  ! Activate the subroutine specified by service
  !
       IF (TRIM(service) .EQ. 'CAESAR') THEN
         CALL ftcl_get_int ('Verschiebung', Shift)
         CALL ftcl_get_string ('Eingabe', Input)
         Laenge = LEN(TRIM(Input))
  !
         CALL CAESAR (Shift, Laenge, Input, Output)
  !
         CALL ftcl_put_string ('Ausgabe', Output)
  !
        ELSE
         ierror = 1
       END IF

       return
       end
  !
  !***********************************************************************
  !
       SUBROUTINE CAESAR (Shift, Length, Input, Output)
  !
  ! Simple encryption by letter-shifting (G. J. Caesar)
  !
  ! Author     : Peter Kmpf
  ! Last change: 24-03-2003
  !
       IMPLICIT NONE
  !
       INTEGER ::  I, ASCII
       INTEGER, INTENT(IN)    :: Shift
       INTEGER, INTENT(INOUT) :: Length
       CHARACTER(LEN=256), INTENT(IN)  :: Input
       CHARACTER(LEN=256), INTENT(OUT) :: Output
  !
       IF (Length .GT. 256) THEN
         Output = 'Only < 256 letters allowed!'
         Length = 27
 
        ELSE
         DO I = 1,Length
           ASCII = ICHAR(Input(I:I))
           IF (ASCII .LE. 64) THEN
             Output(I:I) = Input(I:I)
            ELSE IF (ASCII .LE. 90) THEN
             IF ((ASCII + Shift) .GT. 90) ASCII = ASCII - 26
             IF ((ASCII + Shift) .LT. 65) ASCII = ASCII + 26
             Output(I:I) = CHAR (ASCII + Shift)
            ELSE IF (ASCII .LE. 122) THEN
             IF ((ASCII + Shift) .GT. 122) ASCII = ASCII - 26
             IF ((ASCII + Shift) .LT. 97)  ASCII = ASCII + 26
             Output(I:I) = CHAR (ASCII + Shift)
            ELSE
             Output(I:I) = Input(I:I)
           END IF
         END DO
       END IF
  !
       RETURN
       END SUBROUTINE CAESAR
----
And now the fun part - I mean the Tcl GUI to it all. If you haven't noticed yet -- I just enjoyed to
have Fortran manipulate strings for a Tcl routine. As you can see in the interface definitions above,
you can transfer any data type (well, excluding COMPLEX, since this is no generic type in C). with Ftcl.

  #################################
  # Visual Tcl v1.20 Project
  #
  #################################
  # GLOBAL VARIABLES
  #
  global widget
  global inout
  global tcl_platform
    switch $tcl_platform(platform) {
        unix      {}
        macintosh {load Caesar.shlb Caesar}
        windows   {load Test.dll ftcl}
    }
  #

  proc {main} {argc argv} {

  }

  #################################
  # VTCL GENERATED GUI PROCEDURES
  #

  proc vTclWindow. {base} {
    if {$base == ""} {
        set base .
    }
    wm focusmodel $base passive
    wm geometry $base 1x1+25+65
    wm maxsize $base 817 594
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm withdraw $base
    wm title $base "Wish"
  }

  proc {Window} {args} {
  global vTcl
    set cmd [lindex $args 0]
    set name [lindex $args 1]
    set newname [lindex $args 2]
    set rest [lrange $args 3 end]
    if {$name == "" || $cmd == ""} {return}
    if {$newname == ""} {
        set newname $name
    }
    set exists [winfo exists $newname]
    switch $cmd {
        show {
            if {$exists == "1" && $name != "."} {wm deiconify $name; return}
            if {[info procs vTclWindow(pre)$name] != ""} {
                eval "vTclWindow(pre)$name $newname $rest"
            }
            if {[info procs vTclWindow$name] != ""} {
                eval "vTclWindow$name $newname $rest"
            }
            if {[info procs vTclWindow(post)$name] != ""} {
                eval "vTclWindow(post)$name $newname $rest"
            }
        }
        hide    { if $exists {wm withdraw $newname; return} }
        iconify { if $exists {wm iconify $newname; return} }
        destroy { if $exists {destroy $newname; return} }
    }
  }

  #################################
  # USER DEFINED PROCEDURES
  #
  proc vTclWindow.dialog {base} {
  global Verschiebung
  global Eingabe
  global Ausgabe
  #
    if {$base == ""} {
        set base .dialog
    }
    if {[winfo exists $base]} {
        wm deiconify $base; return
    }
  ###################
  # CREATING WIDGETS
  ###################
    toplevel $base -class Toplevel \
        -relief groove
    wm focusmodel $base passive
    wm geometry $base 417x282+101+123
    wm maxsize $base 817 594
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm deiconify $base
    wm title $base "Caesar"
    set Verschiebung 1
  #
    frame $base.eingabe \
        -borderwidth 1 -height 30 -relief ridge -width 30
    entry $base.eingabe.03 \
        -font -Adobe-Helvetica-Medium-R-Normal-*-*-140-*-*-*-*-*-* \
        -textvariable Eingabe -justify center -width 8 -state normal
    label $base.lab1 \
        -borderwidth 1 -text {Text to be (de/en)coded:}
    scale $base.schieber \
        -variable Verschiebung -from -26.0 -to 26.0 -digits 0 \
        -label {Shift by} -length 104 -showvalue 1 \
        -tickinterval 13.0 -orient horizontal
    label $base.lab3 \
        -borderwidth 1 -text letters
    button $base.okBut -command {Kodiere; update} \
        -text "Do it!" -default active
    frame $base.ausgabe \
        -borderwidth 1 -height 30 -relief ridge -width 30
    entry $base.ausgabe.03 \
        -font -Adobe-Helvetica-Medium-R-Normal-*-*-140-*-*-*-*-*-* \
        -textvariable Ausgabe -justify center -width 8 -state disabled
    bind $base <Return> {Kodiere; update}
  ###################
  # SETTING GEOMETRY
  ###################
    place $base.eingabe \
        -x 5 -y 45 -width 408 -height 36 -anchor nw
    grid columnconf $base.eingabe 0 -weight 1
    grid rowconf $base.eingabe 0 -weight 1
    grid $base.eingabe.03 \
        -in .dialog.eingabe -column 0 -row 0 -columnspan 1 -rowspan 1 \
        -sticky nesw
    place $base.lab1 \
        -x 10 -y 20 -width 211 -height 19 -anchor nw -bordermode ignore
    place $base.schieber \
        -x 30 -y 85 -width 357 -height 129 -bordermode ignore
    place $base.lab3 \
        -x 30 -y 165 -width 91 -height 19 -anchor nw -bordermode ignore
    place $base.okBut \
        -x 320 -y 166 -width 73 -height 29 -anchor nw -bordermode ignore
    place $base.ausgabe \
        -x 5 -y 215 -width 408 -height 36 -anchor nw
    grid columnconf $base.ausgabe 0 -weight 1
    grid rowconf $base.ausgabe 0 -weight 1
    grid $base.ausgabe.03 \
        -in .dialog.ausgabe -column 0 -row 0 -columnspan 1 -rowspan 1 \
        -sticky nesw
  }

  proc Kodiere {} {
  global Eingabe
  global Ausgabe
  global Verschiebung
  #
    set Ausgabe leer
    puts stdout "Shift $Eingabe by $Verschiebung letters"
    ftn_exec CAESAR
    puts stdout "Result: $Ausgabe"
  }

  Window show .
  Window show .dialog
  main $argc $argv

----
[Category Language]