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