fix prod : variables that are returned are binding link with outType
[scilab.git] / scilab / modules / integer / src / fortran / i_prod.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.txt
9
10       subroutine i_prod(id)
11 c     WARNING : argument of this interface may be passed by reference
12       INCLUDE 'stack.h'
13       integer id(nsiz)
14       logical ref
15       integer sel,tops
16       integer type
17       integer native
18       parameter (native=0)
19
20       integer iadr,sadr
21
22       external memused,mtlbsel
23       integer memused,mtlbsel
24 c     
25       iadr(l)=l+l-1
26       sadr(l)=(l/2)+1
27 c
28       if(rhs.gt.3) then
29          call error(42)
30          return
31       endif
32       if(lhs.ne.1) then
33          call error(41)
34          return
35       endif
36 c
37       tops=top
38       sel=0
39 c     
40       il0=iadr(lstk(tops-rhs+1))
41       ilr=il0
42       if(istk(il0).lt.0) il0=iadr(istk(il0+1))
43       ref=ilr.ne.il0
44 c     
45       call  orientandtype(sel,type)
46       if (err.gt.0.or.err1.gt.0) return
47       if(sel.eq.-1) sel=mtlbsel(istk(il0+1),2)
48
49       m=istk(il0+1)
50       n=istk(il0+2)
51       it=istk(il0+3)
52       mn=m*n
53       l1=ilr+4
54       l=il0+4
55       if(mn.eq.0) then
56 c     .  as the only empty matrices have a double type this part of code
57 c     .  should never be used.
58
59          if(ref) then
60             err=sadr(l1+1)-lstk(bot)
61             if(err.gt.0) then
62                call error(17)
63                return
64             endif
65          endif
66          if(sel.eq.0) then
67             istk(ilr)=8
68             istk(ilr+1)=1
69             istk(ilr+2)=1
70             istk(ilr+3)=it
71             call tpconv(4,it,1,0,1,is2,1)
72             call gencopy(1,is2,1,istk(l1),1)
73             lstk(top+1)=sadr(l1+1)
74          else
75             istk(ilr)=1
76             istk(ilr+1)=0
77             istk(ilr+2)=0
78             istk(ilr+3)=0
79             lstk(top+1)=l1
80          endif
81          return
82       endif
83       if (sel.gt.2) then
84 c     prod(a,sel)-->a
85          if(type.ne.native) then
86             lr=sadr(il0+4)
87             err=lr+mn-lstk(bot)
88             if(err.gt.0) then
89                call error(17)
90                return
91             endif
92             call tpconv(it,0, mn,istk(l1),-1,stk(lr),-1)
93             istk(ilr)=1
94             istk(ilr+1)=m
95             istk(ilr+2)=n
96             istk(ilr+3)=0
97             lstk(top+1)=lr+mn
98             return
99          else
100             mr=m
101             nr=n
102          endif
103       elseif(sel.eq.0) then
104          mr=1
105          nr=1
106       elseif(sel.eq.1) then
107          mr=1
108          nr=n
109       else
110          mr=m
111          nr=1
112       endif
113       if(type.eq.native) then
114 c     .  return an array of integers
115
116          if(ref) then
117             err=sadr(l1+memused(it,mr*nr))-lstk(bot)
118             if(err.gt.0) then
119                call error(17)
120                return
121             endif
122          endif
123          istk(ilr)=8
124          istk(ilr+1)=mr
125          istk(ilr+2)=nr
126          istk(ilr+3)=it
127          l1=ilr+4
128
129          call genmprod(it,sel,istk(l),m,m,n,istk(l1),1)
130
131          lstk(top+1)=sadr(l1+memused(it,mr*nr))
132       else
133 c     .  return an array of doubles
134          if(ref) then
135             lr=sadr(ilr+4)
136          else
137             lr=lstk(top+1)
138          endif
139          err=lr+mr*nr-lstk(bot)
140          if(err.gt.0) then
141             call error(17)
142             return
143          endif
144          call genmprodasdouble(it,sel,istk(l),m,m,n,stk(lr),1)
145          if (.not.ref) then
146             call dcopy(mr*nr,stk(lr),1,stk(sadr(ilr+4)),1)
147             lr=sadr(ilr+4)
148          endif
149          istk(ilr)=1
150          istk(ilr+1)=mr
151          istk(ilr+2)=nr
152          istk(ilr+3)=0
153          lstk(top+1)=lr+mr*nr
154       endif
155       return
156       end
157