! 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.htm).
!  Note that some interfaces are merely a front-end for the
!  actual C routines.
!
! ENDDOC
!
!  $Author$
!  $Date$
!  $Source$
!  $Log$
!
! --------------------------------------------------------------------
!   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
!
! Interface for the ftcl_start() routine
!
   interface

      subroutine ftcl_start( filename, exename )
         CHARACTER*(*) filename
         CHARACTER*(*) exename
      end subroutine ftcl_start

   end interface

!
! All private variables are defined here
!
   ! private

   ! None currently

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

!