* Bug #11996 fixed - Extend eye() to hypermatrix.
[scilab.git] / scilab / modules / elementary_functions / sci_gateway / fortran / sci_f_eye.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) INRIA
3
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.txtc     -------------------------------
9 c
10       subroutine inteye(id)
11       INCLUDE 'stack.h'
12       integer id(nsiz)
13       logical  getmat
14
15       integer tops, u1, v1
16       double precision s
17       integer iadr,sadr, mattyp1, areadr1, aimadr1
18 c
19       iadr(l)=l+l-1
20       sadr(l)=(l/2)+1
21 c
22       if (lhs .gt. 1) then
23          call error(41)
24          return
25       endif
26       if(rhs.gt.2) then
27          call setfunnam(ids(1,pt+1),'%hm_eye',7)
28          fun=-1
29          return
30       endif
31
32       tops=top
33 c
34       if(rhs.le.0) then
35 c     eye sans argument
36          top=top+1
37          m=-1
38          n=-1
39       elseif(rhs.eq.1) then
40          il=iadr(lstk(top))
41          
42          if(abs(istk(il)).gt.10.or.abs(istk(il)).eq.5.
43      1    or.abs(istk(il)).eq.6) then
44             call funnam(ids(1,pt+1),'eye',il)
45             fun=-1
46             return
47          endif
48          if(istk(il).lt.0) il=iadr(istk(il+1))
49          m=istk(il+1)
50          n=istk(il+2)
51          if(m.eq.-1.and.n.eq.-1) then !To avoid eye(:)
52             call error(21)
53             return
54          endif
55 c     eye(matrice)
56       elseif(rhs.eq.2) then
57 c     eye(m,n)
58          call getdimfromvar(top,2,n)
59          if(err.gt.0.or.err1.gt.0) return
60          il=iadr(lstk(top))
61          if(istk(il).eq.1.or.istk(il).eq.-1) then
62             if (.not.getmat('eye', tops, top, 
63      +            mattyp1, u1, v1, areadr1, aimadr1)) return !To have the dimensions of argument #2 
64             if(u1.eq.-1.or.v1.eq.-1) then !detect ':' or eye
65                call error(21)
66                return
67             endif
68          endif
69          
70          top=top-1
71          call getdimfromvar(top,1,m)
72          if(err.gt.0.or.err1.gt.0) return
73          il=iadr(lstk(top))
74          if(istk(il).eq.1.or.istk(il).eq.-1) then
75             if (.not.getmat('eye', tops, top, 
76      +            mattyp1, u1, v1, areadr1, aimadr1)) return !To have the dimensions of argument #1 
77             if(u1.eq.-1.or.v1.eq.-1) then !detect ':' or eye
78                call error(21)
79                return
80             endif
81          endif
82       endif
83 c
84       mn=m*n
85       if(m.eq.0) n=0
86       if(n.eq.0) m=0
87
88       il=iadr(lstk(top))
89       l=sadr(il+4)
90
91 c     to avoid integer overflow
92       s=l+dble(m)*dble(n)- lstk(bot)
93       if(s.gt.0.0d0) then
94          err=s
95          call error(17)
96          return
97       endif
98       istk(il)=1
99       istk(il+1)=m
100       istk(il+2)=n
101       istk(il+3)=0
102       lstk(top+1)=l+mn
103       if(mn.ne.0) then
104          m=abs(m)
105          call dset(mn,0.0d+0,stk(l),1)
106          call dset(min(m,abs(n)),1.0d+0,stk(l),m+1)
107       endif
108       return
109       end
110 c     -------------------------------
111