6bbb3d39735a297d523f3b3918598e7e1b71ad4b
[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          lr=sadr(il0+4)
86          err=lr+mn-lstk(bot)
87          if(err.gt.0) then
88             call error(17)
89             return
90          endif
91          call tpconv(it,0, mn,istk(l1),-1,stk(lr),-1)
92          istk(ilr)=1
93          istk(ilr+1)=m
94          istk(ilr+2)=n
95          istk(ilr+3)=0
96          lstk(top+1)=lr+mn
97          return
98       endif
99       if(sel.eq.0) then
100          mr=1
101          nr=1
102       elseif(sel.eq.1) then
103          mr=1
104          nr=n
105       else
106          mr=m
107          nr=1
108       endif
109       if(type.eq.native) then
110 c     .  return an array of integers
111
112          if(ref) then
113             err=sadr(l1+memused(it,mr*nr))-lstk(bot)
114             if(err.gt.0) then
115                call error(17)
116                return
117             endif
118          endif
119          istk(ilr)=8
120          istk(ilr+1)=mr
121          istk(ilr+2)=nr
122          istk(ilr+3)=it
123          l1=ilr+4
124
125          call genmprod(it,sel,istk(l),m,m,n,istk(l1),1)
126
127          lstk(top+1)=sadr(l1+memused(it,mr*nr))
128       else
129 c     .  return an array of doubles
130          if(ref) then
131             lr=sadr(ilr+4)
132          else
133             lr=lstk(top+1)
134          endif
135          err=lr+mr*nr-lstk(bot)
136          if(err.gt.0) then
137             call error(17)
138             return
139          endif
140          call genmprodasdouble(it,sel,istk(l),m,m,n,stk(lr),1)
141          if (.not.ref) then
142             call dcopy(mr*nr,stk(lr),1,stk(sadr(ilr+4)),1)
143             lr=sadr(ilr+4)
144          endif
145          istk(ilr)=1
146          istk(ilr+1)=mr
147          istk(ilr+2)=nr
148          istk(ilr+3)=0
149          lstk(top+1)=lr+mr*nr
150       endif
151       return
152       end
153