← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/interf/feval.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:
routines/interf/feval.f
 
1
      subroutine feval
 
2
C     --------------------------------------------
 
3
C     feval(x1,x2,external) -> external(x1(i),x2(j))
 
4
C     feval(x1,external)    -> external(x1(i))
 
5
c      implicit undefined (a-z)
 
6
c     Copyright ENPC (Jean-Philippe Chancelier 
 
7
      include '../stack.h'
 
8
      character*(5) fname
 
9
      character*(nlgh+1)   ename
 
10
      integer m1,n1,lb,m2,n2,la,i,j,nn,lr,lc,lb1,lbc1,lrr,lcr
 
11
      integer topk,itype,kx1top,kx2top,lr1,iero,kfeval,gettype
 
12
      double precision x1,x2,fval(2)
 
13
      external setfeval 
 
14
      logical type,getexternal,getrmat,cremat
 
15
C     External names (colname), Position in stack (coladr), type (coltyp)
 
16
      common / fevalname / ename
 
17
      common / fevaladr / kfeval,kx1top,kx2top
 
18
      common / fevaltyp / itfeval
 
19
      common/  ierfeval / iero
 
20
      fname='feval'
 
21
      if(rhs.lt.2) then
 
22
         call error(39)
 
23
         return
 
24
      endif
 
25
      itype=0
 
26
      type=.false.
 
27
      kfeval=top
 
28
      topk=top
 
29
      if (.not.getexternal(fname,topk,top,ename,type,
 
30
     $     setfeval)) return
 
31
      itfeval=gettype(top)
 
32
      top=top-1
 
33
      if (.not.getrmat(fname,topk,top,m1,n1,lb))  return
 
34
      x2=stk(lb)
 
35
      nn=1
 
36
      if (rhs.eq.3) then 
 
37
         nn=2
 
38
         top=top-1
 
39
         if (.not.getrmat(fname,topk,top,m2,n2,la))  return
 
40
         x1=stk(la)
 
41
      endif
 
42
C     place pour le resultat si on a deux arguments 
 
43
      top=topk+1
 
44
      if (nn.eq.2) then 
 
45
         if (.not.cremat(fname,top,1,m1*n1,m2*n2,lr,lc)) return
 
46
      else
 
47
         if (.not.cremat(fname,top,0,m1,n1,lb1,lbc1)) return
 
48
      endif
 
49
c     external scilab
 
50
C     une variable de taille 1 qui permet de gerer le type d'argument
 
51
      top=top+1
 
52
      kx1top=top
 
53
      if (.not.cremat(fname,top,0,1,1,lrr,lcr)) return
 
54
      if (nn.eq.2) then 
 
55
         top=top+1
 
56
         kx2top=top
 
57
         if (.not.cremat(fname,top,0,1,1,lrr,lcr)) return
 
58
      endif
 
59
      iero=0
 
60
      if(type) then 
 
61
         if (nn.eq.2) then 
 
62
            do 182 i=1,m2*n2
 
63
               do 192 j=1,m1*n1
 
64
                  call ffeval(nn,stk(la+i-1),stk(lb+j-1),
 
65
     $                 fval,itype,ename)
 
66
                  if(err.gt.0) return
 
67
                  stk(lr+i-1+m2*n2*(j-1))=fval(1)
 
68
                  if (itype.eq.1) stk(lc+i-1+m2*n2*(j-1))=fval(2)
 
69
 192           continue
 
70
 182        continue
 
71
         else
 
72
            do 183 i=1,m1*n1
 
73
               call ffeval(nn,stk(lb+i-1),1.0d0,fval,itype,ename)
 
74
               if(err.gt.0) return
 
75
               stk(lb+i-1)=fval(1)
 
76
               if (itype.eq.1) stk(lb1+i-1)=fval(2)
 
77
 183        continue
 
78
         endif
 
79
      else
 
80
         if (nn.eq.2) then 
 
81
            do 172 i=1,m2*n2
 
82
               do 174 j=1,m1*n1
 
83
                  call bfeval(nn,stk(la+i-1),stk(lb+j-1),
 
84
     $                 fval,itype,ename)
 
85
                  if(err.gt.0) return
 
86
                  if(iero.gt.0) then
 
87
                     call error(24)
 
88
                     Return
 
89
                  endif
 
90
                  stk(lr+i-1+m2*n2*(j-1))=fval(1)
 
91
                  if (itype.eq.1) stk(lc+i-1+m2*n2*(j-1))=fval(2)
 
92
 174           continue
 
93
 172        continue
 
94
         else
 
95
            do 173 i=1,m1*n1
 
96
               call bfeval(nn,stk(lb+i-1),1.0D0,fval,itype,ename)
 
97
               if(err.gt.0) return
 
98
               if(iero.gt.0) then
 
99
                  call error(24)
 
100
                  Return
 
101
               endif
 
102
               stk(lb+i-1)=fval(1)
 
103
               if (itype.eq.1) stk(lb1+i-1)=fval(2)
 
104
 173        continue
 
105
         endif
 
106
      endif
 
107
 162  continue
 
108
      top=topk-rhs+1
 
109
      if (nn.eq.2) then 
 
110
         if (.not.cremat(fname,top,itype,m2*n2,m1*n1,lr1,lc)) return
 
111
         call unsfdcopy(m1*n1*m2*n2*(itype+1),stk(lr),1,stk(lr1),1)
 
112
      else
 
113
         if (itype.eq.1)then 
 
114
            if (.not.cremat(fname,top,itype,m1,n1,lr,lc)) return
 
115
            call unsfdcopy(m1*n1,stk(lb1),1,stk(lc),1)
 
116
         endif
 
117
      endif
 
118
      return
 
119
      end