0e939e8656b6a8fae6ef26abdbea9dadc1fde133
[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 error(42)
28          return
29       endif
30
31       tops=top
32 c
33       if(rhs.le.0) then
34 c     eye sans argument
35          top=top+1
36          m=-1
37          n=-1
38       elseif(rhs.eq.1) then
39          il=iadr(lstk(top))
40          
41          if(abs(istk(il)).gt.10.or.abs(istk(il)).eq.5.
42      1    or.abs(istk(il)).eq.6) then
43             call funnam(ids(1,pt+1),'eye',il)
44             fun=-1
45             return
46          endif
47          if(istk(il).lt.0) il=iadr(istk(il+1))
48          m=istk(il+1)
49          n=istk(il+2)
50          if(m.eq.-1.and.n.eq.-1) then !To avoid eye(:)
51             call error(21)
52             return
53          endif
54 c     eye(matrice)
55       elseif(rhs.eq.2) then
56 c     eye(m,n)
57          call getdimfromvar(top,2,n)
58          if(err.gt.0.or.err1.gt.0) return
59          il=iadr(lstk(top))
60          if(istk(il).eq.1.or.istk(il).eq.-1) then
61             if (.not.getmat('eye', tops, top, 
62      +            mattyp1, u1, v1, areadr1, aimadr1)) return !To have the dimensions of argument #2 
63             if(u1.eq.-1.or.v1.eq.-1) then !detect ':' or eye
64                call error(21)
65                return
66             endif
67          endif
68          
69          top=top-1
70          call getdimfromvar(top,1,m)
71          if(err.gt.0.or.err1.gt.0) return
72          il=iadr(lstk(top))
73          if(istk(il).eq.1.or.istk(il).eq.-1) then
74             if (.not.getmat('eye', tops, top, 
75      +            mattyp1, u1, v1, areadr1, aimadr1)) return !To have the dimensions of argument #1 
76             if(u1.eq.-1.or.v1.eq.-1) then !detect ':' or eye
77                call error(21)
78                return
79             endif
80          endif
81       endif
82 c
83       mn=m*n
84       if(m.eq.0) n=0
85       if(n.eq.0) m=0
86
87       il=iadr(lstk(top))
88       l=sadr(il+4)
89
90 c     to avoid integer overflow
91       s=l+dble(m)*dble(n)- lstk(bot)
92       if(s.gt.0.0d0) then
93          err=s
94          call error(17)
95          return
96       endif
97       istk(il)=1
98       istk(il+1)=m
99       istk(il+2)=n
100       istk(il+3)=0
101       lstk(top+1)=l+mn
102       if(mn.ne.0) then
103          m=abs(m)
104          call dset(mn,0.0d+0,stk(l),1)
105          call dset(min(m,abs(n)),1.0d+0,stk(l),m+1)
106       endif
107       return
108       end
109 c     -------------------------------
110