bug 6792 fix
[scilab.git] / scilab / modules / data_structures / src / fortran / followpath.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) ????-2008 - INRIA
3 c
4 c This file must be used under the terms of the CeCILL.
5 c This source file is licensed as described in the file COPYING, which
6 c you should have received as part of this distribution.  The terms
7 c are also available at
8 c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
9       subroutine followpath(indtop,listtop,ilindi,voli,ilp,voll,ind,
10      $     count,info,lwork)
11 c =============================================================
12 c     given
13 c     - a path stored in a "linear" index list ind stored in the
14 c     variable number indtop
15 c     and
16 c     - a list L begining at position stored in the
17 c     variable number listtop
18
19 c     - a current pointer on index list entries count
20
21 c     returns:
22 c     - the pointer ilp on the deapest sublist of L on the path indtop
23 c       available just by following the list structure of L.
24 c       i.e. ilp is the pointer on the sublist of L pointed to by
25 c       the path indtop(1:count)
26 c     - the vector of numerical indexes corresponding to indtop(1:count)
27
28 c     - voll (in stk worlds) of the designed sublist,
29 c      and the size (in stk worlds) voli of the designed subindex
30 c
31 c     lw is a pointer on the beginning of the free area in stk
32 c     info
33 c         1 : unknown named field
34 c         2 : current index is a matrix index of an mlist
35 c         3 : current index is not a single number
36 c         4 : current index points to a leaf of the  L list
37 c         5 : end of index list reached
38 c         6 : current index is 0 or greater than current sublist # of fields
39 c =============================================================
40 c
41       include 'stack.h'
42 c
43       integer indtop,listtop,ind(*)
44       integer typi,count,oldcount,voll,voli
45
46       integer strpos
47       external strpos
48       integer iadr,sadr
49 c
50       iadr(l)=l+l-1
51       sadr(l)=(l/2)+1
52 c
53       oldcount=count
54 c
55       ilind=iadr(lstk(indtop))
56       if(istk(ilind).lt.0) then
57          itop=istk(ilind+2)
58          voli=istk(ilind+3)
59          ilind=iadr(istk(ilind+1))
60       else
61          itop=indtop
62          voli=lstk(itop+1)-lstk(itop)
63       endif
64 c
65       illist=iadr(lstk(listtop))
66 c      if(istk(illist).lt.0) illist=iadr(istk(illist+1))
67 c
68       if(istk(ilind).ne.15) then
69 c     .  special case if ind is not a list
70          nlist=1
71          count=1
72          ilindi=ilind
73          ilindir=ilindi
74 c        voli=lstk(itop+1)-lstk(itop)
75
76          illistir=illist
77          if(istk(illist).lt.0) illist=iadr(istk(illist+1))
78          illisti=illist
79          goto 12
80
81       endif
82
83       nlist=istk(ilind+1)
84       ll=sadr(ilind+3+nlist)
85
86       illistir=illist
87       illisti=illistir
88       if(istk(illisti).lt.0)  illisti=iadr(istk(illisti+1))
89 c
90  10   continue
91 c     next index
92       count=count+1
93 c     move pointer to next entry in index list
94       ilindi=iadr(ll+istk(ilind+1+count)-1)
95       voli=istk(ilind+2+count)-istk(ilind+1+count)
96       ilindir=ilindi
97       if(istk(ilindi).lt.0) ilindi=iadr(istk(ilindi+1))
98 c     extract infos out of the current sublist
99  12   typi=istk(illisti)
100       mi=istk(illisti+1)
101       llisti=sadr(illisti+mi+3)
102       voll=istk(illisti+mi+2)-1+sadr(3+mi)
103 c     go ahead along the path
104
105       if(typi.eq.13.or.typi.eq.11) then
106 c     .  not an extraction but a function call
107          info=2
108          goto 50
109       endif
110
111 c
112       if(istk(ilindi).eq.10) then
113 c     .  current element index is a name
114          if (istk(ilindi+1)*istk(ilindi+2).ne.1) then
115             info=3
116             goto 50
117 c            call error(21)
118 c            return
119          endif
120          ilname=ilindi+6
121          nname=istk(ilindi+5)-istk(ilindi+4)
122 c     .  check if it is an explicit field name
123          if  (typi.ne.16.and.typi.ne.17) then
124 c     .     list with no explicit fields names
125             info=1
126             goto 50
127          else
128 c     .     first field may contain the fields names
129             ilfn=iadr(llisti)
130             nn=istk(ilfn+1)*istk(ilfn+2)
131             ilptr=ilfn+5
132             lfn=ilptr+nn
133 c     .     look for corresponding index if any
134             n=strpos(istk(ilptr),nn-1,istk(lfn),istk(ilname),nname)
135
136             if(n.le.0) then
137 c     .        no such name in the field names
138                info=1
139                goto 50
140             endif
141             n=n+1
142          endif
143       elseif(istk(ilindi).eq.15) then
144 c     .  current index is a multi dimensional matrix index
145          info=2
146          goto 50
147       else
148 c     .  current index is a standard index
149          if(typi.eq.17.or.(typi.ne.15.and.typi.ne.16)) then
150 c     .     matrix index
151 c     .     can be improved for some special mlist types for which
152 c     .     matrix entry addressing is predefined
153             info=2
154             goto 50
155          endif
156          lw=lwork
157          call indxg(ilindi,mi,ili,nl,mx,lw,10)
158          if(err.gt.0) return
159          if(nl.ne.1) then
160 c     .     index is a vector or []
161             info=3
162             goto 50
163          endif
164          n=istk(ili)
165          if(n.lt.0) then
166             call error(21)
167             return
168          endif
169       endif
170 c     n is the numerical index of the  sublist
171
172       if(n.eq.0.or.n.gt.mi) then
173          if (typi.eq.15.and.count.lt.nlist) then
174 c     .    current index is out of definable list indices and is not the
175 C     .    last of the index list
176             call error(21)
177             return
178          endif
179          ind(count)=n
180          info=6
181          goto 50
182       endif
183
184 c     move pointer to indexed sub-list of L
185       lti=sadr(illisti+3+mi)+istk(illisti+1+n)-1
186       voll=istk(illisti+2+n)-istk(illisti+n+1)
187       illisti=iadr(lti)
188       illistir=illisti
189 c      if(voll.eq.0) then
190 c     .  undefined field found
191 c         info=7
192 c         goto 50
193 c
194 c     endif
195       if(istk(illisti).lt.0) then
196          kk=istk(illisti+2)
197 c         voll=lstk(kk+1)-lstk(kk)
198          illisti=iadr(istk(illisti+1))
199       endif
200 c
201       ind(count)=n
202       if(count+1.gt.nlist) then
203 c     .   end of index list reached
204          info=5
205          goto 50
206       endif
207       if(istk(illisti).ge.15.and.istk(illisti).le.17) goto 10
208
209 c     a leaf of L has been found
210 c     move pointer to next entry in index list
211       count=count+1
212       ilindi=iadr(ll+istk(ilind+1+count)-1)
213       voli=istk(ilind+2+count)-istk(ilind+1+count)
214       ilindir=ilindi
215       if(istk(ilindi).lt.0) ilindi=iadr(istk(ilindi+1))
216       typi=istk(illisti)
217       info=4
218       goto 50
219
220
221  50   continue
222 c     end
223       ilp=illistir
224       ilindi=ilindir
225
226       return
227       end