summaryrefslogtreecommitdiffstats
path: root/scilab/modules/elementaries_functions/sci_gateway/fortran/sci_f_eye.f
blob: 4500e5f0c4fdfed6ba9aab01eee958d3acbdfc4e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
c     -------------------------------
c			INRIA
c     -------------------------------
      subroutine inteye(id)
      INCLUDE 'stack.h'
      integer id(nsiz)

      integer tops,speye(nsiz)
      double precision s
      integer iadr,sadr
      data speye/571349276,673720334,4*673720360/
c
      iadr(l)=l+l-1
      sadr(l)=(l/2)+1
c
      if (lhs .ne. 1) then
         call error(41)
         return
      endif
      if(rhs.gt.2) then
         call error(42)
         return
      endif

      tops=top
c
      if(rhs.le.0) then
c     eye sans argument
         top=top+1
         m=-1
         n=-1
      elseif(rhs.eq.1) then
         il=iadr(lstk(top))
         
         if(abs(istk(il)).gt.10) then
            call funnam(ids(1,pt+1),'eye',il)
            fun=-1
            return
         endif
         if(abs(istk(il)).eq.5.or.abs(istk(il)).eq.6) then
            call putid(ids(1,pt+1),speye)
            fun=-1
            return
         endif
         if(istk(il).lt.0) il=iadr(istk(il+1))
         m=istk(il+1)
         n=istk(il+2)
c     eye(matrice)
      elseif(rhs.eq.2) then
c     eye(m,n)
         call getdimfromvar(top,2,n)
         if(err.gt.0.or.err1.gt.0) return
         top=top-1
         call getdimfromvar(top,1,m)
         if(err.gt.0.or.err1.gt.0) return
      endif
c
      mn=m*n
      if(m.eq.0) n=0
      if(n.eq.0) m=0

      il=iadr(lstk(top))
      l=sadr(il+4)

c     to avoid integer overflow
      s=l+dble(m)*dble(n)- lstk(bot)
      if(s.gt.0.0d0) then
         err=s
         call error(17)
         return
      endif
      istk(il)=1
      istk(il+1)=m
      istk(il+2)=n
      istk(il+3)=0
      lstk(top+1)=l+mn
      if(mn.ne.0) then
         m=abs(m)
         call dset(mn,0.0d+0,stk(l),1)
         call dset(min(m,abs(n)),1.0d+0,stk(l),m+1)
      endif
      return
      end
c     -------------------------------