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