← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/system2/bj2.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/system2/bj2.f
 
1
      subroutine bj2(n,t,y,s,ml,mu,jac,nrowj)
 
2
c
 
3
c ======================================================================
 
4
c     Gestion des macros externals pour la primitive IMPL
 
5
c ======================================================================
 
6
c
 
7
c     Copyright INRIA
 
8
      INCLUDE '../stack.h'
 
9
      integer iadr,sadr
 
10
c     
 
11
      double precision y(n),s(n),jac(nrowj,n),t(*)
 
12
      common/ierode/iero
 
13
c     
 
14
      logical allowptr
 
15
      integer vol,tops,nordre
 
16
      data nordre/3/,mlhs/1/
 
17
c
 
18
      iadr(l)=l+l-1
 
19
      sadr(l)=(l/2)+1
 
20
c     
 
21
c     nordre est le numero d'ordre de cet external dans la structure
 
22
c     de donnee,
 
23
c     mlhs (mrhs) est le nombre de parametres de sortie (entree)
 
24
c     du simulateur 
 
25
c     
 
26
      iero=0
 
27
      mrhs=3
 
28
c     
 
29
      ilp=iadr(lstk(top))
 
30
      il=istk(ilp+nordre)
 
31
c     
 
32
c     transfert des arguments d'entree minimaux du simulateur
 
33
c     la valeur de ces arguments vient du contexte fortran (liste d'appel)
 
34
c     la structure vient du contexte 
 
35
c+    
 
36
      call ftob(t,1,istk(il+1))
 
37
      if(err.gt.0) goto 9999
 
38
      call ftob(y,n,istk(il+2))
 
39
      if(err.gt.0) goto 9999
 
40
      call ftob(s,n,istk(il+3))
 
41
      if(err.gt.0) goto 9999
 
42
c+    
 
43
c     
 
44
      tops=istk(il)
 
45
      ils=iadr(lstk(tops))
 
46
      if(istk(ils).eq.15) goto 10
 
47
c     
 
48
c     recuperation de l'adresse du simulateur
 
49
      fin=lstk(tops)
 
50
c     
 
51
      goto 40
 
52
c     cas ou le simulateur est decrit par une liste
 
53
 10   nelt=istk(ils+1)
 
54
      l=sadr(ils+3+nelt)
 
55
      ils=ils+2
 
56
c     
 
57
c     recuperation de l'adresse du simulateur
 
58
      fin=l
 
59
c     
 
60
c     gestion des parametres supplementaires du simulateur
 
61
c     proviennent du contexte  (elements de la liste
 
62
c     decrivant le simulateur
 
63
c     
 
64
      nelt=nelt-1
 
65
      if(nelt.eq.0) goto 40
 
66
      l=l+istk(ils+1)-istk(ils)
 
67
      vol=istk(ils+nelt+1)-istk(ils+1)
 
68
      if(top+1+nelt.ge.bot) then
 
69
         call error(18)
 
70
         if(err.gt.0) goto 9999
 
71
      endif
 
72
      err=lstk(top+1)+vol-lstk(bot)
 
73
      if(err.gt.0) then
 
74
         call error(17)
 
75
         if(err.gt.0) goto 9999
 
76
      endif
 
77
      call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
 
78
      do 11 i=1,nelt
 
79
         top=top+1
 
80
         lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
 
81
 11   continue
 
82
      mrhs=mrhs+nelt
 
83
 40   continue
 
84
c     
 
85
c     execution de la macro definissant le simulateur
 
86
c     
 
87
      iero=0
 
88
      pt=pt+1
 
89
      if(pt.gt.psiz) then
 
90
         call error(26)
 
91
         goto 9999
 
92
      endif
 
93
      ids(1,pt)=lhs
 
94
      ids(2,pt)=rhs
 
95
      rstk(pt)=1001
 
96
      lhs=mlhs
 
97
      rhs=mrhs
 
98
      niv=niv+1
 
99
      fun=0
 
100
c     
 
101
      icall=5
 
102
      krec=12
 
103
      include '../callinter.h'
 
104
c     
 
105
 200  lhs=ids(1,pt)
 
106
      rhs=ids(2,pt)
 
107
      pt=pt-1
 
108
      
 
109
c+    
 
110
c     transfert des variables  de sortie vers fortran
 
111
      call btof(jac,n*n)
 
112
      if(err.gt.0) goto 9999
 
113
c+    
 
114
      niv=niv-1
 
115
      return
 
116
c     
 
117
 9999 continue
 
118
      iero=1
 
119
      niv=niv-1
 
120
      return
 
121
      end