c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
c Copyright (C) INRIA
-c
+c
c This file must be used under the terms of the CeCILL.
c This source file is licensed as described in the file COPYING, which
c you should have received as part of this distribution. The terms
-c are also available at
+c are also available at
c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt
-
+
subroutine intsave
include 'stack.h'
logical opened,ptover,cremat
logical eqid
integer iadr,sadr
data bl/nsiz*673720360/
-c
+c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
top0=top-rhs
- call v2cunit(top0+1,'wb',fd,opened,ierr)
+ call v2cunit(top0+1,'wb',fd,opened,ierr)
if(ierr.gt.0) return
if(ierr.lt.0) then
c file has been opened by fortran, oldsave (return a error)
c *call* parse
24 continue
ilrec=pstk(pt)
- lstk(top+1)= istk(ilrec)
+ lstk(top+1)= istk(ilrec)
fd = istk(ilrec+1)
kmin = istk(ilrec+2)
kmax = istk(ilrec+3)
top0 = istk(ilrec+5)
vol = istk(ilrec+6)
opened = (istk(ilrec+7).eq.1)
- pt=pt-1
+ pt=pt-1
if(rstk(pt).eq.911) goto 21
25 if(k.lt.kmax) goto 20
double precision res,offset
integer iadr,sadr
data semi/43/,blank/40/
-c
+c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
endif
top0=top
top=top-rhs+1
-
+
call v2cunit(top,'rb',fd,opened,ierr)
if(ierr.gt.0) return
if(ierr.lt.0) then
call error(43)
return
else
- call mseek(fd,int(offset),'set'//char(0),ierr)
+ call mseek(fd,offset,'set'//char(0),ierr)
endif
-
+
if(rhs.gt.1) then
ilt=iadr(lstk(top0+1))
err=sadr(ilt+nsiz*rhs-1)-lstk(bot)
ids(2,pt)=ilv
c preserve variable type
ids(3,pt)=istk(ilv)
-c set the end of the variable temporarily
+c set the end of the variable temporarily
lstk(top+1)=sadr(ilv)
c preserve value of top
ids(5,pt)=top
endif
ilv=ids(2,pt)
istk(ilv)=ids(3,pt)
- pt=pt-1
+ pt=pt-1
ilt=pstk(pt)
call putid(id,ids(1,pt))
pt=pt-1
c . yes, remove it out of the table and save it
istk(ilt+(i-1)*nsiz)=0
c . rewind the file
- if(.not.opened) call mseek(fd,0,'set'//char(0),ierr)
+ if(.not.opened) then
+ call mseek(fd,0.0,'set'//char(0),ierr)
+ endif
goto 30
endif
27 continue
c . no skip it
goto 10
- endif
+ endif
30 ssym=sym
sym = semi
call savefun(fd,il1,ierr)
elseif(istk(il1).eq.13) then
call savecfun(fd,il1,ierr)
- elseif(istk(il1).eq.14) then
+ elseif(istk(il1).eq.14) then
call savelib(fd,il1,ierr)
elseif(istk(il1).ge.15.and.istk(il1).le.17) then
10 call savelist(fd,il1,ierr)
- elseif(istk(il1).eq.128) then
+ elseif(istk(il1).eq.128) then
call saveptr(fd,il1,ierr)
- elseif(istk(il1).eq.130) then
+ elseif(istk(il1).eq.130) then
call savefptr(fd,il1,ierr)
else
c . call an external function
call loadfun(fd,il1,nn,ierr)
elseif(istk(il1).eq.13) then
call loadcfun(fd,il1,nn,ierr)
- elseif(istk(il1).eq.14) then
+ elseif(istk(il1).eq.14) then
call loadlib(fd,il1,nn,ierr)
- elseif(istk(il1).ge.15.and.istk(il1).le.17) then
+ elseif(istk(il1).ge.15.and.istk(il1).le.17) then
call loadlist(fd,il1,nn,ierr)
- elseif(istk(il1).eq.128) then
+ elseif(istk(il1).eq.128) then
call loadptr(fd,il1,nn,ierr)
- elseif(istk(il1).eq.130) then
+ elseif(istk(il1).eq.130) then
call loadfptr(fd,il1,nn,ierr)
else
fun=-il1
call savefun(fd,il1,ierr)
elseif(istk(il1).eq.13) then
call savecfun(fd,il1,ierr)
- elseif(istk(il1).eq.14) then
+ elseif(istk(il1).eq.14) then
call savelib(fd,il1,ierr)
- elseif(istk(il1).ge.15.and.istk(il1).le.17) then
+ elseif(istk(il1).ge.15.and.istk(il1).le.17) then
c . a sublist
if(istk(il1).lt.0) il1=iadr(istk(il1+1))
if (ptover(1,psiz)) return
ids(3,pt)=i
il=il1
goto 10
- elseif(istk(il1).eq.128) then
+ elseif(istk(il1).eq.128) then
call saveptr(fd,il1,ierr)
- elseif(istk(il1).eq.130) then
+ elseif(istk(il1).eq.130) then
call savefptr(fd,il1,ierr)
else
c . call an external function
endif
if(ierr.ne.0) return
goto 20
-c
+c
30 continue
c end of current list reached
if(rstk(pt).ne.408) goto 40
top=top-1
goto 20
endif
-
+
10 il0=il
c read list header without type
err=sadr(il+3)-lstk(bot)
call loadfun(fd,il1,nne,ierr)
elseif(istk(il1).eq.13) then
call loadcfun(fd,il1,nne,ierr)
- elseif(istk(il1).eq.14) then
+ elseif(istk(il1).eq.14) then
call loadlib(fd,il1,nne,ierr)
- elseif(istk(il1).ge.15.and.istk(il1).le.17) then
-c . a sublist
+ elseif(istk(il1).ge.15.and.istk(il1).le.17) then
+c . a sublist
if (ptover(1,psiz)) return
rstk(pt)=408
ids(1,pt)=n
ids(4,pt)=il0
il=il1
goto 10
- elseif(istk(il1).eq.128) then
+ elseif(istk(il1).eq.128) then
call loadptr(fd,il1,nne,ierr)
- elseif(istk(il1).eq.130) then
+ elseif(istk(il1).eq.130) then
call loadfptr(fd,il1,nne,ierr)
else
c . call an external function
if(err.gt.0) ierr=1
if(ierr.ne.0) return
goto 20
-c
+c
30 continue
c end of current list reached
if(rstk(pt).ne.408) goto 40
integer fd
character*3 fmti,fmtd
integer sadr
-
+
double precision dblNaN
-
+
integer isanan
external isanan
-
+
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
call returnananfortran(dblNaN)
-
+
fmti='il'//char(0)
fmtd='dl'//char(0)
endif
l=sadr(il+4)
call mgetnc(fd,istk(il+4),mn,fmtd,ierr)
-
+
c convert all NaN to Signaling NaN
do 10 i = 0, mn-1
if(isanan(stk(l+i)).eq.1) then
stk(l+i) = dblNaN
endif
-10 continue
-
+10 continue
+
c call mgetnc(fd,stk(l),mn,fmtd,ierr)
n=iadr(l+mn)-il
c n=4+2*mn
character*3 fmti,fmtd
integer sadr
double precision dblNaN
-
+
integer isanan
external isanan
-
+
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
call returnananfortran(dblNaN)
-
+
fmti='il'//char(0)
fmtd='dl'//char(0)
endif
l=sadr(il+9+mn)
call mgetnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
-
+
c convert all NaN to Signaling NaN
do 10 i = 0, mn1-1
if(isanan(stk(l+i)).eq.1) then
stk(l+i) = dblNaN
endif
-10 continue
-
+10 continue
+
n=iadr(l+mn1)-il
c n=9+mn+2*mn1
return
sadr(l)=(l/2)+1
c
fmti='il'//char(0)
-c
+c
c read matrix header without type
err=sadr(il+4)-lstk(bot)
if(err.gt.0) then
include 'stack.h'
integer fd
character*3 fmti,fmtd
- integer sadr
+ integer sadr
c
c iadr(l)=l+l-1
c
integer fd
character*3 fmti,fmtd
-c
+c
fmti='il'//char(0)
fmtd='dl'//char(0)
c
c n=4+2*1
return
end
-
+
subroutine savefptr(fd,il,ierr)
c Copyright INRIA
c Save a pointer on a primitive