* Bug #11405 fixed - Core: added hypermatrix support for extraction
[scilab.git] / scilab / modules / core / src / fortran / indxg.f
index a798f1b..7651ec2 100644 (file)
@@ -1,25 +1,33 @@
+c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
+c Copyright (C) INRIA
+c
+c This file must be used under the terms of the CeCILL.
+c This source file is licensed as described in the file COPYING, which
+c you should have received as part of this distribution.  The terms
+c are also available at
+c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt
+
       subroutine indxg(il,siz,ilr,mi,mx,lw,iopt1)
 c!Purpose
 c     Converts a scilab index variable to a vector of indices
 c!Calling sequence
 c     subroutine indxg(il,siz,ilr,mi,lw,iopt)
-c     il    : beginning of a  a scilab variable structure. 
+c     il    : beginning of a  a scilab variable structure.
 c     siz   : integer, matrix size, used for implicits index descriptions
 c     ilr   : adress of first elment of resulting vector of indices in
 c            istk
-c     mi    : size of resulting vector of indices 
+c     mi    : size of resulting vector of indices
 c     mx    : maximum value of resulting vector of indices
 c     lw    : pointer to free space in stk (modified by execution)
 c     iopt1 : flag with decimal form n+10*i
 c            if n==0 null indices are accepted
 c            else null indices are rejected
-c            if i==0 
+c            if i==0
 c               implicit indices ":" gives a vector istk(ilr)=1:siz, mi=siz,mx=siz
-c            else 
+c            else
 c               implicit indice ":" gives mi=-1,mx=siz
 c!
 
-c     Copyright INRIA
       include 'stack.h'
       integer siz,iopt1,iopt
       double precision e1,v(3)
@@ -29,7 +37,7 @@ c
       sadr(l)=(l/2)+1
 
 c
-c     
+c
       impl=iopt1/10
       iopt=iopt1-10*impl
 c
@@ -39,7 +47,7 @@ c
 c     Index is a vector of scalars
          m=istk(il+1)
          n=istk(il+2)
+
          if(m.ge.1) then
 c     .     general case
             l=sadr(il+4)
@@ -51,7 +59,7 @@ c     .     general case
                return
             endif
             if (istk(il).eq.1) then
-               if(istk(il+3).ne.0) then 
+               if(istk(il+3).ne.0) then
                   call error(21)
                   return
                endif
@@ -75,7 +83,7 @@ c     .     index is []
             mi=0
             mx=0
          elseif(m.eq.-1) then
-c     .     index is : 
+c     .     index is :
             ilr=iadr(lw)
             if(impl.eq.0) then
                if(siz.gt.0) then
@@ -99,7 +107,7 @@ c     .     index is :
 c     .  Index is a vector of polynomial
          m=istk(il+1)
          n=istk(il+2)
-         if(istk(il+3).ne.0) then 
+         if(istk(il+3).ne.0) then
             call error(21)
             return
          endif
@@ -131,7 +139,7 @@ c     .  evaluate it for siz
 c     .  Index is an implicit polynomial vector (beg:step:end)
          e1=siz
          l=sadr(il+12)
-         
+
          call ddmpev(stk(l),istk(il+8),1,e1,v,1,1,3)
          ideb=v(1)
          ipas=v(2)
@@ -170,7 +178,7 @@ c     sign used to avoid integer overflow
 c     .  index is a boolean vector
          m=istk(il+1)
          n=istk(il+2)
-c         if(m*n.ne.siz) then 
+c         if(m*n.ne.siz) then
 c            call error(21)
 c            return
 c         endif
@@ -226,6 +234,45 @@ c     .  index is a boolean vector
             call isort1(istk(ilr),nel,istk(ilw),1)
          endif
          lw=sadr(ilr+nel)
+      elseif (istk(il).eq.17) then
+         if(istk(il).lt.0) il=iadr(istk(il+1))
+         if(istk(il+1).gt.3) then
+c           Only support 3D hypermatrices for the moment
+            call error(21)
+            return
+         endif
+c        Get the pointer to the data field
+         ildf=sadr(il+6)+istk(il+4)-1
+         ildf=iadr(ildf)
+         if(istk(ildf).ne.1.or.istk(ildf+3).ne.0) then
+c           Real hypermatrix
+            call error(52)
+            return
+         endif
+         m=istk(ildf+1)
+c        mi is the output vector size
+         mi=m
+         n=1
+         ilr=iadr(lw)
+         lw=sadr(ilr+m)
+c        Checking if the stack is sufficient
+         err=lw-lstk(bot)
+         if(err.gt.0) then
+            call error(17)
+            return
+         endif
+c        Copy the hypermatrix elements to the stack
+         call entier(m,stk(sadr(ildf+4)),istk(ilr))
+c        Extract and output in mx the maximum value of the hypermatrix
+         mx=0
+         do 40 i=0,m-1
+            if(iopt.eq.1.and.istk(ilr+i).le.0) then
+               call error(21)
+               return
+            else
+               mx=max(mx,istk(ilr+i))
+            endif
+ 40      continue
       else
          call error(21)
          return
@@ -239,11 +286,11 @@ c!Purpose
 c     Converts a scilab index variable to the complementary vector of indices
 c!Calling sequence
 c     subroutine indxg(il,siz,ilr,mi,lw)
-c     il   : beginning of a scilab variable structure. 
+c     il   : beginning of a scilab variable structure.
 c     siz  : integer, matrix size, used for implicits index descriptions
 c     ilr  : adress of first elment of resulting vector of indices in
 c            istk
-c     mi   : size of resulting vector of indices 
+c     mi   : size of resulting vector of indices
 c     mx   : maximum value of resulting vector of indices
 c     lw   : pointer to free space in stk (modified by execution)
 c!
@@ -255,7 +302,7 @@ c!
       integer il, siz, ilr, mi, mx, lw
 
       integer i, k, ilc
-      
+
       integer l, iadr,sadr
 c
       iadr(l)=l+l-1
@@ -280,7 +327,7 @@ c
 
 *     computes complement (part of the code modified by Bruno)
 *
-*     given 
+*     given
 *       1/ a "vector" w of mi indices stored from istk(ilr)
 *          so that w=[istk(ilr), ....., istk(ilr+mi-1)] is this vector
 *       2/ the "vector" v of indices v=[1,2,..., siz]
@@ -297,7 +344,7 @@ c
             k = istk(ilr+i)
             if (k .le. siz) istk(ilc+k-1) = 0
          end do
-            
+
          k = 0
          do i = 1, siz
             if (istk(ilc+i-1) .eq. 1) then
@@ -305,7 +352,7 @@ c
                k = k+1
             end if
          end do
-         
+
          mi = k
          mx=istk(ilc-1+k)
       endif