f9f087673af4bca24d6ed34e27e4a8d0710fa044
[scilab.git] / scilab / modules / core / src / fortran / inisci.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 inisci( ini1, vsizr, ierr)
11 c!Purpose 
12 c     scilab initialisation
13 c!Parameters
14 c     ini1 :
15 c     = -1  for silent initialization
16 c     = -3  for special io initialization 
17 c     vsizr: initial stack size
18 c     ierr : return error flag
19 c!   
20 c====================================================================
21       integer        ierr,ini1,vsizr
22       include 'stack.h'
23       parameter (nz1=nsiz-1,nz2=nsiz-2)
24 c     
25 c     common for Control-C interruptions
26       logical iflag,interruptible
27 cDEC$ IF DEFINED (FORDLL)
28 cDEC$ ATTRIBUTES DLLIMPORT:: /basbrk/
29 cDEC$ ENDIF            
30       common /basbrk/ iflag,interruptible
31 c     scilab function protection mode
32       integer macprt
33 cDEC$ IF DEFINED (FORDLL)
34 cDEC$ ATTRIBUTES DLLIMPORT:: /mprot/
35 cDEC$ ENDIF            
36       common /mprot/ macprt
37 c     mmode : matlab ops compatibilty mode
38 cDEC$ IF DEFINED (FORDLL)
39 cDEC$ ATTRIBUTES DLLIMPORT:: /mtlbc/
40 cDEC$ ENDIF            
41       common /mtlbc/ mmode
42 c     
43 c     simpmd : rational fraction simplification mode
44       integer simpmd
45 cDEC$ IF DEFINED (FORDLL)
46 cDEC$ ATTRIBUTES DLLIMPORT:: /csimp/
47 cDEC$ ENDIF            
48       common /csimp/  simpmd
49 c     ippty: interfaces properties
50       parameter (mxbyptr=40)
51       integer byptr(mxbyptr),nbyptr
52 cDEC$ IF DEFINED (FORDLL)
53 cDEC$ ATTRIBUTES DLLIMPORT:: /ippty/
54 cDEC$ ENDIF            
55       common /ippty/ byptr,nbyptr
56
57       logical first
58       double precision dlamch
59       integer k,l,mode(2),vsizg,stacksize
60       integer eps(nsiz),im(nsiz),exp(nsiz),pi(nsiz),bl(nsiz),io(nsiz)
61       integer true(nsiz),false(nsiz),dollar(nsiz)
62       integer idloc(nsiz)
63       integer offset,goffset
64       integer iadr,sadr
65       
66       character bufcomp*(bsiz)
67       character bufsci*(bsiz)
68       character bufscihome*(bsiz)
69       character buftmp*(bsiz)
70
71 c     
72       double precision  iov(2)
73       character*(nlgh) vname 
74 c  
75       data im/673714744,nz1*673720360/,exp/673713720,nz1*673720360/
76       data pi/672274744,nz1*673720360/,bl/nsiz*673720360/
77       data eps/471404088,nz1*673720360/,io/672666168,nz1*673720360/
78       data dollar/673720359,nz1*673720360/
79       data first/.true./
80       data true/673717560,nz1*673720360/,false/673713976,nz1*673720360/
81       
82 c     
83 c     mprot used to protect function see funcprot.c
84       save /basbrk/,/mprot/
85
86 c     
87
88       iadr(l)=l+l-1
89       sadr(l)=(l/2)+1
90
91       ierr=0
92       mode(2)=0
93       ieee=0
94
95 c     initialization call
96 c     -------------------
97
98 c     initialization C environment
99       call initscilab
100 c     
101 c     .  scilab function protection mode
102 c     .  ------------------------------
103       call initfuncprot
104 c     
105 c     .  standard i/o initialization
106 c     .  ----------------------------
107 c     .  rte = unit number for terminal input
108       err=0
109       if(ini1.ne.-3) then
110          rte = 5
111          mode(1)=0
112          call clunit(rte,buf,mode)
113          if(err.gt.0) then
114             call error(241)
115             ierr=err
116             return
117          endif
118       else
119          rte=9999
120       endif
121       rio = rte
122 c     .  wte = unit number for terminal output
123       if(ini1.ne.-3) then
124          wte = 6
125          mode(1)=1
126          call clunit(wte,buf,mode)
127          if(err.gt.0) then
128             call error(240)
129             ierr=err
130             return
131          endif
132       else
133          wte=9999
134       endif
135 c     
136       rio=rte
137 c     
138 c     .  Control-C recovery
139 c     .  ------------------
140       if (first) then
141          interruptible=.true.
142          first=.false.
143       endif
144 c     
145 c     .  random number seed
146 c     .  ------------------
147       ran(1) =  0
148       ran(2) =  0
149 c     
150 c     .  initial format for number display
151 c     .  ---------------------------------
152       lct(6) =  1
153       lct(7) = 10
154 c     
155 c     .  initial debug mode
156 c     .  ------------------
157       ddt = 0
158
159 c     .  initial type names
160 c     .  ------------------
161       call inittypenames()
162       if(err.gt.0) then
163          ierr=err
164          return
165       endif
166 c     .  initial interface properties
167 c     .  ----------------------------
168       call setippty(0)
169 c      ier= graphicsmodels()
170 c     
171 c     .  Stack
172 c     .  -----
173 c     
174 c     . initial values for number of local and global variables
175 c @TODO : What is 768 (512 + 256) ?
176       isiz=isizt-768
177
178 c     .  memory allocation
179 c     get default stackize from c
180       call getdefaultstacksize(stacksize)
181       offset=0
182       call scimem(vsizr,offset)
183       stk(1) = stacksize
184       lstk(1) =   offset+1
185 c     . hard predefined variables
186       goffset=0
187 c     get default global stackize from c      
188       call getdefaultgstacksize(vsizg)
189       call scigmem(vsizg,goffset)
190
191       gtop=isiz+1
192       lstk(gtop+1)=goffset+1
193       gbot=isizt
194       lstk(gbot)=lstk(gtop+1)+vsizg-1
195 c
196 c     13 is the number of predefined variables 
197 c     14 - 1 blank not include
198       bot = isiz - 13
199       bbot = bot
200       bot0 = bot
201 c     memory requested for predefined variables 
202 c     mxn bmat -> size : sadr(2+m*n+2)
203 c     $        -> size : sadr(10-1) + 2 
204 c     mxn mat  -> size : sadr(3)+m*n*(it+1)
205 c     string   -> size : sadr(6+nchar)+1
206 c     3 strings
207 c     4 booleans
208       call getsci(bufsci,nbsci)
209       call getscihome(bufscihome,nbscihome)
210       call gettmpdir(buftmp,nbtmpdir)
211       lpvar = (sadr(10-1) + 2) 
212      $     + 4*sadr(5) 
213      $     + 3*(sadr(3)+1)
214      $     + 2*(sadr(3)+2)
215      $     + 1*(sadr(6+nbsci)+1)
216      $     + 1*(sadr(6+nbscihome)+1)
217      $     + 1*(sadr(6+nbtmpdir)+1)
218
219       l=vsizr-lpvar
220       k=bot
221       lstk(k)=lstk(1)-1+l
222 c     . SCI
223       vname = ' '
224       vname(1:3) =  "SCI"
225       call cvname(idloc,vname,0)
226       call cresmatvar(idloc,k,bufsci,nbsci)
227       k=k+1
228 c     . SCIHOME
229       vname = ' '
230       vname(1:7) =  "SCIHOME"
231       call cvname(idloc,vname,0)
232       call cresmatvar(idloc,k,bufscihome,nbscihome)
233       k=k+1      
234 c     . TMPDIR
235       vname = ' '
236       vname(1:6) = "TMPDIR"
237       call cvname(idloc,vname,0)
238       call cresmatvar(idloc,k,buftmp,nbtmpdir)
239       k=k+1
240 c     . %gui
241       vname = ' '
242       vname(1:4) = "%gui"
243       call withgui(irep)
244       call cvname(idloc,vname,0)
245       call crebmatvar(idloc,k,1,1,irep)
246       k=k+1
247 c     . %fftw 
248       vname = ' '
249       vname(1:5) = "%fftw"
250       call withfftw(irep)
251       call cvname(idloc,vname,0)
252       call crebmatvar(idloc,k,1,1,irep)
253       k=k+1
254 c     .  $    : formal index
255       call putid(idstk(1,k),dollar)
256       il=iadr(lstk(k))
257 c @TODO: What is 2 ?
258       istk(il)=2
259 c @TODO: What is 1 ?
260       istk(il+1)=1
261 c @TODO: What is 1 ?
262       istk(il+2)=1
263 c @TODO: Why is 0 ?
264       istk(il+3)=0
265 c @TODO: What is 39 ?
266       istk(il+4)=39
267 c @TODO: What is 40 ?
268       istk(il+5)=40
269 c @TODO: What is 40 ?
270       istk(il+6)=40
271 c @TODO: What is 40 ?
272       istk(il+7)=40
273 c @TODO: What is 1 ?
274       istk(il+8)=1
275 c @TODO: What is 3 ?
276       istk(il+9)=3
277 c @TODO: Why 10 ?
278       lw=sadr(il+10)
279       stk(lw)=0.0d0
280       stk(lw+1)=1.0d0
281       lstk(k+1)=lw+2
282       k=k+1
283 c     .  %t   : True boolean
284       call crebmatvar(true,k,1,1,1)
285       k=k+1
286 c     .  %f   : False boolean
287       call crebmatvar(false,k,1,1,0)
288       k=k+1
289 c     .  %eps : machine precision 
290       call crematvar(eps,k,0,1,1,dlamch('p'),0.0d0)
291       leps=sadr( iadr(lstk(k)) +4)
292       k=k+1
293 c     .  %io : standard input&output
294       iov(1)=dble(rte)
295       iov(2)=dble(wte)
296       call crematvar(io,k,0,1,2,iov,0.0d0)
297       k=k+1
298 c     .  %i : sqrt(-1)
299       call crematvar(im,k,1,1,1,0.0d0,1.0d0)
300       k=k+1
301 c     .  %e : exp(1)
302       call crematvar(exp,k,0,1,1,2.71828182845904530d+0,0.0d0)
303       k=k+1
304 c     .  %pi 
305       call crematvar(pi,k,0,1,1,3.14159265358979320d+0,0.0d0)
306       k=k+1
307 c     .  blanc. Memory used by getsym to store parsed number
308 C     .  then by getnum.f and macro.f to retreive it (stk(lstk(isiz) -))
309
310       call crematvar(bl,k,0,1,1,0.0d0,0.0d0)
311       k=k+1
312 c     
313 c
314 c     --------------
315 c     initialize
316 c     --------------
317 c
318 c     compilation flag
319       comp(1) =   0
320       comp(2) =   0
321       comp(3) =   0
322 c     error indicators
323       err     =   0
324       errct   =   -1
325       err1    =   0
326       err2    =   0
327       catch   =   0 
328 c     recursion
329       fun     =   0
330       macr    =   0
331       niv     =   0
332       paus    =   0
333       pt      =   0
334 c     stack variable
335       top     =   0
336 c     debug mode
337       lcntr   =   0
338       nmacs   =   0
339       lgptrs(1)=  1
340       wmac    =   0
341       mmode   =   0
342       simpmd  =   1
343
344       return
345       end
346