← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to examples/interface-tour/intex8f.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/interface-tour/intex8f.f
 
1
      subroutine intex8f(fname)
 
2
      character*(*) fname
 
3
C     --------------------------------------------
 
4
      include 'stack.h'
 
5
c
 
6
c   An example of an hand written interface 
 
7
c   passing a Scilab function as input of function ex8f
 
8
 
 
9
c    call in Scilab:-->ex8f(x1,x2,a_function)
 
10
c     x1<->1    (double array)
 
11
c     x2<->2    (double array) 
 
12
c     a_function <-> 3    (a scilab function).
 
13
c     a_function is the function "myfunction" defined 
 
14
c     in ex8f.sce. It has mlhs=2 inputs and mrhs=3 outputs.
 
15
 
 
16
      logical getrhsvar,createvar,scifunction
 
17
      logical checklhs,checkrhs
 
18
      common/  ierfeval / iero
 
19
 
 
20
      if(.not.checkrhs(fname,3,3)) return
 
21
      if(.not.checklhs(fname,1,3)) return
 
22
c
 
23
c     get adress of x1
 
24
      if (.not.getrhsvar(1,'d',m1,n1,l1))  return
 
25
c     get adress of x2
 
26
      if (.not.getrhsvar(2,'d',m2,n2,l2))  return
 
27
c     lf is the adress of a_function 
 
28
c     mlhs (resp. mrhs) is its number of outputs (resp. inputs)
 
29
c     3 and 'f' are inputs of getrhsvar
 
30
c     mlhs,mrhs,lf are outputs of getrhsvar
 
31
 
 
32
      if (.not.getrhsvar(3,'f',mlhs,mrhs,lf))  return
 
33
 
 
34
      if(mrhs.ne.2) then
 
35
         buf='invalid rhs for Scilab function'
 
36
         call error(998)
 
37
         return
 
38
      endif
 
39
c     To call a_function it is required that its input arguments are
 
40
c     stored in the last positions of the variables stack. NOTE that when 
 
41
c     called, the function destroys its input variables and replaces them by 
 
42
c     the output variables. so in this  case we need to make a copy of
 
43
c     them.
 
44
c     Remark: if the calling sequence of geval had been geval(a_function,x1,x2)
 
45
c     the following two copies would be un-necessary.
 
46
 
 
47
c     make a copy of x1
 
48
      if(.not.createvar(3+1,'d',m1,n1,l4)) return
 
49
      call dcopy(m1*n1,stk(l1),1,stk(l4),1)
 
50
c      ....
 
51
c     make a copy of x2
 
52
      if(.not.createvar(3+mrhs,'d',m2,n2,l5)) return
 
53
      call dcopy(m2*n2,stk(l2),1,stk(l5),1)
 
54
c
 
55
c     Here a_function  takes  variables 4 and 5 as inputs and generates output
 
56
c     variables at positions 4 to 4-1+mlhs
 
57
 
 
58
c     ibegin must be the index of the first input variable of a_function
 
59
      ibegin=3+1
 
60
 
 
61
c     execute a_function
 
62
      if(.not.scifunction(ibegin,lf,mlhs,mrhs)) return
 
63
 
 
64
c     check if an error has occured while running a_function
 
65
      if(err.gt.0) return
 
66
 
 
67
c     output variables: 4 and 5 (created by a_function) and possibly 6
 
68
c                       if a_function has 3 output parameters
 
69
 
 
70
c     select index of variables to return
 
71
      lhsvar(1)=4
 
72
      lhsvar(2)=5
 
73
      if(mlhs.eq.3) lhsvar(3)=6
 
74
      return
 
75
      end
 
76
       
 
77
 
 
78