* Bug #11405 fixed - Core: added hypermatrix support for extraction
[scilab.git] / scilab / modules / core / src / fortran / indxg.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) 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.1-en.txt
9
10       subroutine indxg(il,siz,ilr,mi,mx,lw,iopt1)
11 c!Purpose
12 c     Converts a scilab index variable to a vector of indices
13 c!Calling sequence
14 c     subroutine indxg(il,siz,ilr,mi,lw,iopt)
15 c     il    : beginning of a  a scilab variable structure.
16 c     siz   : integer, matrix size, used for implicits index descriptions
17 c     ilr   : adress of first elment of resulting vector of indices in
18 c            istk
19 c     mi    : size of resulting vector of indices
20 c     mx    : maximum value of resulting vector of indices
21 c     lw    : pointer to free space in stk (modified by execution)
22 c     iopt1 : flag with decimal form n+10*i
23 c            if n==0 null indices are accepted
24 c            else null indices are rejected
25 c            if i==0
26 c               implicit indices ":" gives a vector istk(ilr)=1:siz, mi=siz,mx=siz
27 c            else
28 c               implicit indice ":" gives mi=-1,mx=siz
29 c!
30
31       include 'stack.h'
32       integer siz,iopt1,iopt
33       double precision e1,v(3)
34       integer iadr,sadr
35 c
36       iadr(l)=l+l-1
37       sadr(l)=(l/2)+1
38
39 c
40 c
41       impl=iopt1/10
42       iopt=iopt1-10*impl
43 c
44       if(istk(il).lt.0) il=istk(il+1)
45
46       if(istk(il).eq.1.or.istk(il).eq.8) then
47 c     Index is a vector of scalars
48          m=istk(il+1)
49          n=istk(il+2)
50
51          if(m.ge.1) then
52 c     .     general case
53             l=sadr(il+4)
54             ilr=iadr(lw)
55             lw=sadr(ilr+m*n)
56             err=lw-lstk(bot)
57             if(err.gt.0) then
58                call error(17)
59                return
60             endif
61             if (istk(il).eq.1) then
62                if(istk(il+3).ne.0) then
63                   call error(21)
64                   return
65                endif
66                call entier(m*n,stk(l),istk(ilr))
67             else
68                call tpconv(istk(il+3),4,m*n,istk(il+4),1,istk(ilr),1)
69             endif
70             mi=m*n
71             mx=0
72             do 05 i=0,m*n-1
73                if(iopt.eq.1.and.istk(ilr+i).le.0) then
74                   call error(21)
75                   return
76                else
77                   mx=max(mx,istk(ilr+i))
78                endif
79  05         continue
80          elseif(m.eq.0) then
81 c     .     index is []
82             ilr=il
83             mi=0
84             mx=0
85          elseif(m.eq.-1) then
86 c     .     index is :
87             ilr=iadr(lw)
88             if(impl.eq.0) then
89                if(siz.gt.0) then
90                   lw=sadr(ilr+siz)
91                   err=lw-lstk(bot)
92                   if(err.gt.0) then
93                      call error(17)
94                      return
95                   endif
96                   do 10 i=1,siz
97                      istk(ilr-1+i)=i
98  10               continue
99                endif
100                mi=siz
101             else
102                mi=-1
103             endif
104             mx=siz
105          endif
106       elseif (istk(il).eq.2) then
107 c     .  Index is a vector of polynomial
108          m=istk(il+1)
109          n=istk(il+2)
110          if(istk(il+3).ne.0) then
111             call error(21)
112             return
113          endif
114          mi=m*n
115          l=sadr(il+9+mi)
116          lr=lw
117          ilr=iadr(lr)
118          lw=lr+mi
119          err=lw-lstk(bot)
120          if(err.gt.0) then
121             call error(17)
122             return
123          endif
124 c     .  evaluate it for siz
125          e1=siz
126          call ddmpev(stk(l),istk(il+8),1,e1,stk(lr),1,1,mi)
127          call entier(mi,stk(lr),istk(ilr))
128          lw=sadr(ilr+mi)
129          mx=0
130          do 15 i=0,mi-1
131             if(istk(ilr+i).le.0) then
132                call error(21)
133                return
134             else
135                mx=max(mx,istk(ilr+i))
136             endif
137  15      continue
138       elseif (istk(il).eq.129) then
139 c     .  Index is an implicit polynomial vector (beg:step:end)
140          e1=siz
141          l=sadr(il+12)
142
143          call ddmpev(stk(l),istk(il+8),1,e1,v,1,1,3)
144          ideb=v(1)
145          ipas=v(2)
146          ifin=v(3)
147 c     sign used to avoid integer overflow
148          if(ipas.eq.0.or.(ifin-ideb)*sign(1,ipas).lt.0) then
149             mi=0
150             mx=0
151          else
152             if(ipas.lt.0.and.ifin.le.0.or.ipas.gt.0.and.ideb.le.0) then
153                call error(21)
154                return
155             endif
156             mi=int((abs(ifin-ideb)+1)/abs(ipas))
157
158             ilr=iadr(lw)
159             lw=sadr(ilr+mi+1)
160             err=lw-lstk(bot)
161             if(err.gt.0) then
162                call error(17)
163                return
164             endif
165             k=0
166             do 20 i=ideb,ifin,ipas
167                istk(ilr+k)=i
168                k=k+1
169  20         continue
170             mi=k
171             if(ipas.gt.0) then
172                mx=istk(ilr-1+mi)
173             else
174                mx=istk(ilr)
175             endif
176          endif
177       elseif (istk(il).eq.4) then
178 c     .  index is a boolean vector
179          m=istk(il+1)
180          n=istk(il+2)
181 c         if(m*n.ne.siz) then
182 c            call error(21)
183 c            return
184 c         endif
185          ilr=iadr(lw)
186          lw=sadr(ilr+m*n)
187          err=lw-lstk(bot)
188          if(err.gt.0) then
189             call error(17)
190             return
191          endif
192          mi=0
193          do 30 i=1,m*n
194             if(istk(il+2+i).eq.1) then
195                istk(ilr+mi)=i
196                mi=mi+1
197             endif
198  30      continue
199          if(mi.eq.0) then
200             mx=0
201          else
202             mx=istk(ilr-1+mi)
203          endif
204          lw=sadr(ilr+mi)
205       elseif (istk(il).eq.6) then
206 c     .  index is a boolean vector
207          m=istk(il+1)
208          n=istk(il+2)
209          nel=istk(il+4)
210
211          ir=il+5
212          ic=ir+m
213          ilr=iadr(lw)
214          ilw=ilr+nel
215          mx=nel
216          mi=0
217          if (nel.gt.0) then
218             lw=sadr(ilw+nel)
219             err=lw-lstk(bot)
220             if(err.gt.0) then
221                call error(17)
222                return
223             endif
224             do 35 i=0,m-1
225                if(istk(ir).gt.0) then
226                   do 31 kk=0,istk(ir)-1
227                      istk(ilr+mi)=1+i+(istk(ic+kk)-1)*m
228                      mi=mi+1
229  31               continue
230                   ic=ic+istk(ir)
231                endif
232                ir=ir+1
233  35         continue
234             call isort1(istk(ilr),nel,istk(ilw),1)
235          endif
236          lw=sadr(ilr+nel)
237       elseif (istk(il).eq.17) then
238          if(istk(il).lt.0) il=iadr(istk(il+1))
239          if(istk(il+1).gt.3) then
240 c           Only support 3D hypermatrices for the moment
241             call error(21)
242             return
243          endif
244 c        Get the pointer to the data field
245          ildf=sadr(il+6)+istk(il+4)-1
246          ildf=iadr(ildf)
247          if(istk(ildf).ne.1.or.istk(ildf+3).ne.0) then
248 c           Real hypermatrix
249             call error(52)
250             return
251          endif
252          m=istk(ildf+1)
253 c        mi is the output vector size
254          mi=m
255          n=1
256          ilr=iadr(lw)
257          lw=sadr(ilr+m)
258 c        Checking if the stack is sufficient
259          err=lw-lstk(bot)
260          if(err.gt.0) then
261             call error(17)
262             return
263          endif
264 c        Copy the hypermatrix elements to the stack
265          call entier(m,stk(sadr(ildf+4)),istk(ilr))
266 c        Extract and output in mx the maximum value of the hypermatrix
267          mx=0
268          do 40 i=0,m-1
269             if(iopt.eq.1.and.istk(ilr+i).le.0) then
270                call error(21)
271                return
272             else
273                mx=max(mx,istk(ilr+i))
274             endif
275  40      continue
276       else
277          call error(21)
278          return
279       endif
280       return
281       end
282
283
284       subroutine indxgc(il,siz,ilr,mi,mx,lw)
285 c!Purpose
286 c     Converts a scilab index variable to the complementary vector of indices
287 c!Calling sequence
288 c     subroutine indxg(il,siz,ilr,mi,lw)
289 c     il   : beginning of a scilab variable structure.
290 c     siz  : integer, matrix size, used for implicits index descriptions
291 c     ilr  : adress of first elment of resulting vector of indices in
292 c            istk
293 c     mi   : size of resulting vector of indices
294 c     mx   : maximum value of resulting vector of indices
295 c     lw   : pointer to free space in stk (modified by execution)
296 c!
297
298 *     modification by Bruno so as to use a faster algorithm (7 May 2002)
299
300       implicit none
301       include 'stack.h'
302       integer il, siz, ilr, mi, mx, lw
303
304       integer i, k, ilc
305
306       integer l, iadr,sadr
307 c
308       iadr(l)=l+l-1
309       sadr(l)=(l/2)+1
310
311       call indxg(il,siz,ilr,mi,mx,lw,1)
312       if(err.gt.0) return
313       ilc=iadr(lw)
314       lw=sadr(ilc+siz)
315       err=lw-lstk(bot)
316       if(err.gt.0) then
317          call error(17)
318          return
319       endif
320       if(mi.eq.0) then
321          do i=1,siz
322             istk(ilc+i-1)=i
323          enddo
324          mx=istk(ilc+siz-1)
325          mi=siz
326       else
327
328 *     computes complement (part of the code modified by Bruno)
329 *
330 *     given
331 *       1/ a "vector" w of mi indices stored from istk(ilr)
332 *          so that w=[istk(ilr), ....., istk(ilr+mi-1)] is this vector
333 *       2/ the "vector" v of indices v=[1,2,..., siz]
334 *
335 *     computes the vector v minus w
336 *     this new vector is stored from istk(ilc) and its final number of
337 *     components will be stored in mi
338
339          do i = 0, siz-1
340             istk(ilc+i) = 1
341          end do
342
343          do i = 0, mi-1
344             k = istk(ilr+i)
345             if (k .le. siz) istk(ilc+k-1) = 0
346          end do
347
348          k = 0
349          do i = 1, siz
350             if (istk(ilc+i-1) .eq. 1) then
351                istk(ilc+k) = i
352                k = k+1
353             end if
354          end do
355
356          mi = k
357          mx=istk(ilc-1+k)
358       endif
359       ilr=ilc
360       lw=sadr(ilr+mi)
361
362       return
363       end