mseek parameter offset passed as double for file size more than 2GB.
[scilab.git] / scilab / modules / io / src / fortran / newsave.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 intsave
11       include 'stack.h'
12       logical opened,ptover,cremat
13       integer fd,vol,top0,bl(nsiz)
14       double precision res
15       logical eqid
16       integer iadr,sadr
17       data bl/nsiz*673720360/
18 c
19       iadr(l)=l+l-1
20       sadr(l)=(l/2)+1
21 c
22       if(rstk(pt).eq.905) goto 24
23       if(rhs.lt.1) then
24          call error(42)
25          return
26       endif
27       if(lhs.gt.1) then
28          call error(41)
29          return
30       endif
31       top0=top-rhs
32
33
34       call v2cunit(top0+1,'wb',fd,opened,ierr)
35       if(ierr.gt.0) return
36       if(ierr.lt.0) then
37 c     file has been opened by fortran, oldsave (return a error)
38          call error(43)
39          return
40       endif
41
42       if(rhs.eq.1) then
43 c     .  save all variables
44          if(bot.gt.bbot-1) goto 40
45          kmin=bot
46          kmax=bbot-1
47       else
48          kmin=top0+2
49          kmax=top
50       endif
51
52 c     loop on variables to save
53       k=kmin-1
54  20   k=k+1
55       il=iadr(lstk(k))
56       vol=lstk(k+1)-lstk(k)
57  21   continue
58
59       if(eqid(idstk(1,k),bl)) then
60          err=k
61          call error(248)
62          if (.not.opened) call mclose (fd,res)
63          return
64       endif
65       call savevar(fd,idstk(1,k),il,vol,ierr)
66       if(ierr.ne.0.and.err.le.0.and.err1.lt.0) then
67          call error(263)
68          if (.not.opened) call mclose (fd,res)
69          return
70       endif
71       if(fun.ge.0) goto 25
72 c     overloaded save function
73       if ( ptover(1,psiz)) return
74       ilrec         = iadr(lstk(top+1))
75       err=sadr(ilrec+8)-lstk(bot)
76       if(err.gt.0) then
77          call error(17)
78          return
79       endif
80       istk(ilrec)   = lstk(top+1)
81       istk(ilrec+1) = fd
82       istk(ilrec+2) = kmin
83       istk(ilrec+3) = kmax
84       istk(ilrec+4) = k
85       istk(ilrec+5) = top0
86       istk(ilrec+6) = vol
87       if(opened) then
88          istk(ilrec+7) = 1
89       else
90          istk(ilrec+7) = 0
91       endif
92       lstk(top+1)=sadr(ilrec+7)
93       rstk(pt)=905
94       pstk(pt)=ilrec
95       ilv=-fun
96       vol=fin
97       call funnam(ids(1,pt+1),'save',ilv)
98       call copyvar(ilv,vol)
99 c     create a variable with fd
100       top=top+1
101       if(.not.cremat('save',top,0,1,1,lr,lc)) return
102       stk(lr)=fd
103       rhs=2
104       fun=-1
105       return
106 c     *call* parse
107  24   continue
108       ilrec=pstk(pt)
109       lstk(top+1)= istk(ilrec)
110       fd         = istk(ilrec+1)
111       kmin       = istk(ilrec+2)
112       kmax       = istk(ilrec+3)
113       k          = istk(ilrec+4)
114       top0       = istk(ilrec+5)
115       vol        = istk(ilrec+6)
116       opened     = (istk(ilrec+7).eq.1)
117       pt=pt-1
118       if(rstk(pt).eq.911) goto 21
119
120  25   if(k.lt.kmax) goto 20
121
122
123  40   if (.not.opened) then
124          call mclose (fd,res)
125       endif
126 c     return a nul variable
127       top=top0+1
128       il=iadr(lstk(top))
129       istk(il)=0
130       lstk(top+1)=lstk(top)+1
131       return
132       end
133
134       subroutine intload(id1,k1)
135 c     Copyright INRIA
136 c     Loads variables stored in a file. if id1 is a valid variable name
137 c     (id1(1).ne.blank) and if this variable if loaded k1 ist set to its
138 c     index in the stack
139 c
140       include 'stack.h'
141       integer id1(nsiz),k1
142       logical opened,cremat,ptover,eqid
143       integer fd,id(nsiz),semi,blank,top0,endian,getendian,it,ssym
144       double precision res,offset
145       integer iadr,sadr
146       data semi/43/,blank/40/
147 c
148       iadr(l)=l+l-1
149       sadr(l)=(l/2)+1
150 c
151       if (rstk(pt).eq.906) goto 24
152       k1=0
153 c
154       if(rhs.lt.1) then
155          call error(42)
156          return
157       endif
158       if(lhs.gt.1) then
159          call error(41)
160          return
161       endif
162       top0=top
163       top=top-rhs+1
164
165       call v2cunit(top,'rb',fd,opened,ierr)
166       if(ierr.gt.0) return
167       if(ierr.lt.0) then
168 c     oldload (file opened by fortran returns a error)
169          top=top0
170          k1=fin
171          call error(43)
172          return
173       endif
174 c     test for compatibility
175       endian=getendian()
176       call mtell(fd,offset,ierr)
177       call mgetnc (fd,it,1,'il'//char(0),ierr)
178       if(endian.eq.1.and.it.eq.28.or.
179      $     endian.eq.0.and.it.eq.469762048) then
180 c     .  old mode (returns a error)
181          if(.not.opened)  call mclose (fd,res)
182          k1=fin
183          call error(43)
184          return
185       else
186          call mseek(fd,offset,'set'//char(0),ierr)
187       endif
188
189
190       if(rhs.gt.1) then
191          ilt=iadr(lstk(top0+1))
192          err=sadr(ilt+nsiz*rhs-1)-lstk(bot)
193          if(err.gt.0) then
194             call error(17)
195             return
196          endif
197 c     .  get table of requested variable names
198          do 01 i=1,rhs-1
199             il=iadr(lstk(top+i))
200             if(istk(il).lt.0) il=iadr(istk(il+1))
201             if(istk(il).ne.10) then
202                err=i+1
203                call error(55)
204                return
205             endif
206             lc=il+5+istk(il+1)*istk(il+2)
207             nc=min(nlgh,istk(il+5)-1)
208             call namstr(istk(ilt+(i-1)*nsiz),istk(lc),nc,0)
209  01      continue
210          il=iadr(lstk(top))
211          call icopy(nsiz*rhs,istk(ilt),1,istk(il),1)
212          lstk(top+1)=sadr(il+nsiz*rhs)
213          ilt=il
214       endif
215
216       top=top+1
217
218 c     load all variables stored in a file
219       kvar=0
220  10   continue
221       il=iadr(lstk(top))
222  21   call loadvar(fd,id,il,nn,ierr)
223       if(ierr.gt.0) return
224       if(ierr.lt.0) goto 50
225       if(fun.ge.0) then
226          lstk(top+1)=sadr(il+nn)
227          goto 26
228       endif
229 c     overloaded save function
230
231 c     preserve context
232       if ( ptover(1,psiz)) return
233       rstk(pt)=0
234       pstk(pt)=ilt
235       call putid(ids(1,pt),id)
236       if ( ptover(1,psiz)) return
237       rstk(pt)=906
238       pstk(pt)=rhs
239       ids(1,pt)=kvar
240       ilv=-fun
241 c     ilv points to the beginning of the variable to load
242 c     store it into ids (used by the function called)
243       ids(2,pt)=ilv
244 c     preserve variable type
245       ids(3,pt)=istk(ilv)
246 c     set the end of the variable temporarily
247       lstk(top+1)=sadr(ilv)
248 c     preserve value of top
249       ids(5,pt)=top
250       if(opened) then
251          ids(6,pt)=fd
252       else
253          ids(6,pt)=-fd
254       endif
255
256 c     form name of the function to call
257       call funnam(ids(1,pt+1),'load',ilv)
258 c     create a variable with fd
259       top=top+1
260       if(.not.cremat('load',top,0,1,1,lr,lc)) return
261       stk(lr)=fd
262       rhs=1
263       fun=-1
264       return
265 c     *call* parse
266  24   continue
267 c
268 c     restore context
269       rhs=pstk(pt)
270       kvar=ids(1,pt)
271       if (ids(6,pt).gt.0) then
272          opened=.true.
273          fd=ids(6,pt)
274       else
275          opened=.false.
276          fd=-ids(6,pt)
277       endif
278       if(ids(5,pt).eq.top) then
279 c     .  load has been done by a primitive
280          nn1=ids(4,pt)
281       else
282 c     .  load has been done by a scilab function
283          nn1=iadr(lstk(top+1))-iadr(lstk(top))
284          top=top-1
285       endif
286       ilv=ids(2,pt)
287       istk(ilv)=ids(3,pt)
288       pt=pt-1
289       ilt=pstk(pt)
290       call putid(id,ids(1,pt))
291       pt=pt-1
292       if(rstk(pt).eq.912) then
293 c     .  a sublist
294          ids(5,pt)=nn1
295          goto 21
296       else
297 c     .   a simple variable set the end
298          lstk(top+1)=sadr(ilv+nn1)
299          goto 26
300       endif
301  26   continue
302       if(rhs.gt.1) then
303 c     .  check if loaded variable is required
304          do 27 i=1,rhs-1
305             if(eqid(id,istk(ilt+(i-1)*nsiz))) then
306 c     .        yes, remove it out of the table and save it
307                istk(ilt+(i-1)*nsiz)=0
308 c     .        rewind the file
309                if(.not.opened) then
310                  call mseek(fd,0.0,'set'//char(0),ierr)
311                endif
312                goto 30
313             endif
314  27      continue
315 c     .  no skip it
316          goto 10
317       endif
318
319  30   ssym=sym
320       sym = semi
321       srhs=rhs
322       rhs = 0
323       call stackp(id,1)
324       if (id1(1).ne.blank) then
325          if(eqid(id,id1)) k1=fin
326       endif
327       rhs=srhs
328       sym=ssym
329       kvar=kvar+1
330       top = top + 1
331       if(kvar.eq.rhs-1) goto 50
332       goto 10
333
334 c     close the file if necessary
335  50   if (.not.opened) then
336          call mclose (fd,res)
337       endif
338       top=top-1
339 c     return a nul variable
340       il=iadr(lstk(top))
341       istk(il)=0
342       lstk(top+1)=lstk(top)+1
343       return
344       end
345
346       subroutine savevar(fd,id,il,vol,ierr)
347 c     Copyright INRIA
348       include 'stack.h'
349 c
350       integer fd,id(nsiz),vol
351       integer iadr
352       character*3 fmti,fmtd
353 c
354 c
355       iadr(l)=l+l-1
356 c      sadr(l)=(l/2)+1
357 c
358
359       fmti='il'//char(0)
360       fmtd='dl'//char(0)
361 c
362       if(rstk(pt).eq.911) then
363          il1=il
364          if(istk(il1).lt.0) il1=iadr(istk(il1+1))
365          call savelist(fd,il1,ierr)
366          return
367       endif
368
369       il1=il
370       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
371
372 c     write id and type
373       call mputnc (fd,id,nsiz,fmti,ierr)
374       if(ierr.ne.0) return
375       call mputnc (fd,istk(il1),1,fmti,ierr)
376       if(ierr.ne.0) return
377
378       if(istk(il1).eq.1) then
379          call savemat(fd,il1,ierr)
380       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
381          call savepol(fd,il1,ierr)
382       elseif(istk(il1).eq.4) then
383          call savebool(fd,il1,ierr)
384       elseif(istk(il1).eq.5) then
385          call savesparse(fd,il1,ierr)
386       elseif(istk(il1).eq.6) then
387          call savespb(fd,il1,ierr)
388       elseif(istk(il1).eq.7) then
389          call savemsp(fd,il1,ierr)
390       elseif(istk(il1).eq.8) then
391          call saveint(fd,il1,ierr)
392       elseif(istk(il1).eq.10) then
393          call savestr(fd,il1,ierr)
394       elseif(istk(il1).eq.11) then
395          call savefun(fd,il1,ierr)
396       elseif(istk(il1).eq.13) then
397          call savecfun(fd,il1,ierr)
398       elseif(istk(il1).eq.14) then
399          call savelib(fd,il1,ierr)
400       elseif(istk(il1).ge.15.and.istk(il1).le.17) then
401  10      call savelist(fd,il1,ierr)
402       elseif(istk(il1).eq.128) then
403          call saveptr(fd,il1,ierr)
404       elseif(istk(il1).eq.130) then
405          call savefptr(fd,il1,ierr)
406       else
407 c     .  call an external function
408          fun=-il1
409          fin=vol
410       endif
411       return
412       end
413
414       subroutine loadvar(fd,id,il,nn,ierr)
415 c     Copyright INRIA
416       include 'stack.h'
417 c
418       integer fd,id(nsiz)
419       character*3 fmti,fmtd
420 c
421 c
422       sadr(l)=(l/2)+1
423 c
424
425       fmti='il'//char(0)
426       fmtd='dl'//char(0)
427 c
428       if(rstk(pt).eq.912) then
429          call loadlist(fd,il,nn,ierr)
430          return
431       endif
432 c
433
434       il1=il
435 c     read id and type
436       call mgetnc (fd,id,nsiz,fmti,ierr)
437       if(ierr.ne.0) return
438       call mgetnc (fd,istk(il1),1,fmti,ierr)
439       if(ierr.ne.0) return
440       if(istk(il1).eq.1) then
441          call loadmat(fd,il1,nn,ierr)
442       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
443          call loadpol(fd,il1,nn,ierr)
444       elseif(istk(il1).eq.4) then
445          call loadbool(fd,il1,nn,ierr)
446       elseif(istk(il1).eq.5) then
447          call loadsparse(fd,il1,nn,ierr)
448       elseif(istk(il1).eq.6) then
449          call loadspb(fd,il1,nn,ierr)
450       elseif(istk(il1).eq.7) then
451          call loadmsp(fd,il1,nn,ierr)
452       elseif(istk(il1).eq.8) then
453          call loadint(fd,il1,nn,ierr)
454       elseif(istk(il1).eq.10) then
455          call loadstr(fd,il1,nn,ierr)
456       elseif(istk(il1).eq.11) then
457          call loadfun(fd,il1,nn,ierr)
458       elseif(istk(il1).eq.13) then
459          call loadcfun(fd,il1,nn,ierr)
460       elseif(istk(il1).eq.14) then
461          call loadlib(fd,il1,nn,ierr)
462       elseif(istk(il1).ge.15.and.istk(il1).le.17) then
463          call loadlist(fd,il1,nn,ierr)
464       elseif(istk(il1).eq.128) then
465          call loadptr(fd,il1,nn,ierr)
466       elseif(istk(il1).eq.130) then
467          call loadfptr(fd,il1,nn,ierr)
468       else
469          fun=-il1
470          lstk(top+1)=sadr(il1)
471       endif
472       if(err.gt.0) ierr=1
473       return
474       end
475
476       subroutine savelist(fd,il,ierr)
477 c     Copyright INRIA
478 c     Save a matrix of numbers
479       include 'stack.h'
480 c
481       integer fd
482       logical ptover
483       integer iadr,sadr
484       character*3 fmti,fmtd
485 c
486       iadr(l)=l+l-1
487       sadr(l)=(l/2)+1
488 c
489       fmti='il'//char(0)
490       fmtd='dl'//char(0)
491       if(rstk(pt).eq.911) then
492 c     .  manage recursion
493          n=ids(1,pt)
494          il=ids(2,pt)
495          i=ids(3,pt)
496          pt=pt-1
497          l=sadr(il+n+3)
498          il1=iadr(l-1+istk(il+1+i))
499          if(istk(il1).lt.0) il1=iadr(istk(il1+1))
500          goto 20
501       endif
502 c
503  10   n=istk(il+1)
504 c     write list header
505       call mputnc (fd,istk(il+1),n+2,fmti,ierr)
506       if(ierr.ne.0) return
507 c     write the elements
508       l=sadr(il+n+3)
509       i=0
510  20   continue
511       i=i+1
512       if(i.gt.n) goto 30
513       if(istk(il+2+i)-istk(il+1+i).eq.0) goto 20
514       il1=iadr(l-1+istk(il+1+i))
515       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
516 c     write type
517       call mputnc (fd,istk(il1),1,fmti,ierr)
518       if(ierr.ne.0) return
519
520       if(istk(il1).eq.1) then
521          call savemat(fd,il1,ierr)
522       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
523          call savepol(fd,il1,ierr)
524       elseif(istk(il1).eq.4) then
525          call savebool(fd,il1,ierr)
526       elseif(istk(il1).eq.5) then
527          call savesparse(fd,il1,ierr)
528       elseif(istk(il1).eq.6) then
529          call savespb(fd,il1,ierr)
530       elseif(istk(il1).eq.7) then
531          call savemsp(fd,il1,ierr)
532       elseif(istk(il1).eq.8) then
533          call saveint(fd,il1,ierr)
534       elseif(istk(il1).eq.10) then
535          call savestr(fd,il1,ierr)
536       elseif(istk(il1).eq.11) then
537          call savefun(fd,il1,ierr)
538       elseif(istk(il1).eq.13) then
539          call savecfun(fd,il1,ierr)
540       elseif(istk(il1).eq.14) then
541          call savelib(fd,il1,ierr)
542       elseif(istk(il1).ge.15.and.istk(il1).le.17) then
543 c     .  a sublist
544          if(istk(il1).lt.0) il1=iadr(istk(il1+1))
545          if (ptover(1,psiz)) return
546          rstk(pt)=408
547          ids(1,pt)=n
548          ids(2,pt)=il
549          ids(3,pt)=i
550          il=il1
551          goto 10
552       elseif(istk(il1).eq.128) then
553          call saveptr(fd,il1,ierr)
554       elseif(istk(il1).eq.130) then
555          call savefptr(fd,il1,ierr)
556       else
557 c     .  call an external function
558          if (ptover(1,psiz)) return
559          rstk(pt)=911
560          ids(1,pt)=n
561          ids(2,pt)=il
562          ids(3,pt)=i
563
564          fun=-il1
565          fin=istk(il+2+i)-istk(il+1+i)
566          return
567       endif
568       if(ierr.ne.0) return
569       goto 20
570 c
571  30   continue
572 c     end of current list reached
573       if(rstk(pt).ne.408) goto 40
574       n=ids(1,pt)
575       il=ids(2,pt)
576       i=ids(3,pt)
577       pt=pt-1
578       l=sadr(il+n+3)
579       il1=iadr(l-1+istk(il+1+i))
580       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
581       goto 20
582  40   continue
583 c     finish
584       return
585       end
586
587       subroutine loadlist(fd,il,nn,ierr)
588 c     Copyright INRIA
589 c     Save a matrix of numbers
590       include 'stack.h'
591 c
592       integer fd
593       logical ptover
594       integer iadr,sadr
595       character*3 fmti,fmtd
596 c
597       iadr(l)=l+l-1
598       sadr(l)=(l/2)+1
599 c
600       fmti='il'//char(0)
601       fmtd='dl'//char(0)
602       ierr=0
603 c
604       il1=il
605       if(rstk(pt).eq.912) then
606 c     .  manage recursion
607          n=ids(1,pt)
608          il=ids(2,pt)
609          i=ids(3,pt)
610          il0=ids(4,pt)
611          nne=ids(5,pt)
612          pt=pt-1
613          l=sadr(il+n+3)
614          il1=iadr(lstk(top))
615          istk(il+2+i)=istk(il+1+i)+lstk(top+1)-lstk(top)
616          top=top-1
617          goto 20
618       endif
619
620  10   il0=il
621 c     read list header without type
622       err=sadr(il+3)-lstk(bot)
623       if(err.gt.0) then
624          call error(17)
625          return
626       endif
627       call mgetnc (fd,istk(il+1),2,fmti,ierr)
628       if(ierr.ne.0) return
629       n=istk(il+1)
630       err=sadr(il+3+n)-lstk(bot)
631       if(err.gt.0) then
632          call error(17)
633          return
634       endif
635       call mgetnc (fd,istk(il+3),n,fmti,ierr)
636       if(ierr.ne.0) return
637       il1=il+3+n
638 c     read the elements
639       l=sadr(il1)
640       nne=0
641       i=0
642  20   continue
643       i=i+1
644
645       if(i.gt.n) goto 30
646       if(istk(il+2+i)-istk(il+1+i).eq.0) goto 20
647       il1=iadr(l-1+istk(il+1+i))
648 c     read  type
649       call mgetnc (fd,istk(il1),1,fmti,ierr)
650       if(ierr.ne.0) return
651
652       if(istk(il1).eq.1) then
653          call loadmat(fd,il1,nne,ierr)
654       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
655          call loadpol(fd,il1,nne,ierr)
656       elseif(istk(il1).eq.4) then
657          call loadbool(fd,il1,nne,ierr)
658       elseif(istk(il1).eq.5) then
659          call loadsparse(fd,il1,nne,ierr)
660       elseif(istk(il1).eq.6) then
661          call loadspb(fd,il1,nne,ierr)
662       elseif(istk(il1).eq.7) then
663          call loadmsp(fd,il1,nne,ierr)
664       elseif(istk(il1).eq.8) then
665          call loadint(fd,il1,nne,ierr)
666       elseif(istk(il1).eq.10) then
667          call loadstr(fd,il1,nne,ierr)
668       elseif(istk(il1).eq.11) then
669          call loadfun(fd,il1,nne,ierr)
670       elseif(istk(il1).eq.13) then
671          call loadcfun(fd,il1,nne,ierr)
672       elseif(istk(il1).eq.14) then
673          call loadlib(fd,il1,nne,ierr)
674       elseif(istk(il1).ge.15.and.istk(il1).le.17) then
675 c     .  a sublist
676          if (ptover(1,psiz)) return
677          rstk(pt)=408
678          ids(1,pt)=n
679          ids(2,pt)=il
680          ids(3,pt)=i
681          ids(4,pt)=il0
682          il=il1
683          goto 10
684       elseif(istk(il1).eq.128) then
685          call loadptr(fd,il1,nne,ierr)
686       elseif(istk(il1).eq.130) then
687          call loadfptr(fd,il1,nne,ierr)
688       else
689 c     .  call an external function
690          if (ptover(1,psiz)) return
691          rstk(pt)=912
692          ids(1,pt)=n
693          ids(2,pt)=il
694          ids(3,pt)=i
695          ids(4,pt)=il0
696          lstk(top+1)=sadr(il1)
697          top=top+1
698          lstk(top+1)=lstk(top)
699          fun=-il1
700 c     *call* parse
701          return
702       endif
703       istk(il+2+i)=sadr(il1+nne)-l+1
704       if(err.gt.0) ierr=1
705       if(ierr.ne.0) return
706       goto 20
707 c
708  30   continue
709 c     end of current list reached
710       if(rstk(pt).ne.408) goto 40
711       ll=sadr(il+n+3)
712       nne=iadr(ll-1+istk(il+2+n))-il
713 c
714       n=ids(1,pt)
715       il=ids(2,pt)
716       i=ids(3,pt)
717       il0=ids(4,pt)
718       pt=pt-1
719       l=sadr(il+n+3)
720       goto 20
721
722  40   continue
723 c     finish
724       nn=il1+nne-il0
725       il=il0
726       return
727       end
728
729       subroutine savemat(fd,il,ierr)
730 c     Copyright INRIA
731 c     Save a matrix of numbers
732       include 'stack.h'
733 c
734       integer fd
735       character*3 fmti,fmtd
736       integer sadr
737 c
738       iadr(l)=l+l-1
739       sadr(l)=(l/2)+1
740 c
741       fmti='il'//char(0)
742       fmtd='dl'//char(0)
743 c
744 c     write matrix header type excluded
745       call mputnc (fd,istk(il+1),3,fmti,ierr)
746       if(ierr.ne.0) return
747 c     write matrix elements
748       mn=istk(il+1)*istk(il+2)*(istk(il+3)+1)
749       l=sadr(il+4)
750       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
751       return
752       end
753
754       subroutine loadmat(fd,il,n,ierr)
755 c     Copyright INRIA
756 c     Save a matrix of numbers
757       include 'stack.h'
758       integer fd
759       character*3 fmti,fmtd
760       integer sadr
761
762       double precision dblNaN
763
764       integer isanan
765       external isanan
766
767 c
768       iadr(l)=l+l-1
769       sadr(l)=(l/2)+1
770 c
771       call returnananfortran(dblNaN)
772
773       fmti='il'//char(0)
774       fmtd='dl'//char(0)
775
776 c     read matrix header without type
777       err=sadr(il+4)-lstk(bot)
778       if(err.gt.0) then
779          call error(17)
780          return
781       endif
782       call mgetnc (fd,istk(il+1),3,fmti,ierr)
783       if(ierr.ne.0) return
784 c     read matrix elements
785       mn=istk(il+1)*istk(il+2)*(istk(il+3)+1)
786       err=sadr(il+4)+mn-lstk(bot)
787       if(err.gt.0) then
788          call error(17)
789          return
790       endif
791       l=sadr(il+4)
792       call mgetnc(fd,istk(il+4),mn,fmtd,ierr)
793
794 c     convert all NaN to Signaling NaN
795       do 10 i = 0, mn-1
796           if(isanan(stk(l+i)).eq.1) then
797               stk(l+i) = dblNaN
798           endif
799 10    continue
800
801 c      call mgetnc(fd,stk(l),mn,fmtd,ierr)
802       n=iadr(l+mn)-il
803 c      n=4+2*mn
804       return
805       end
806
807       subroutine savepol(fd,il,ierr)
808 c     Copyright INRIA
809 c     Save a matrix of polynomials
810       include 'stack.h'
811 c
812       integer fd
813       character*3 fmti,fmtd
814       integer sadr
815 c
816       iadr(l)=l+l-1
817       sadr(l)=(l/2)+1
818 c
819       fmti='il'//char(0)
820       fmtd='dl'//char(0)
821 c
822 c     write matrix header without type
823       mn=istk(il+1)*istk(il+2)
824       call mputnc (fd,istk(il+1),8+mn,fmti,ierr)
825       if(ierr.ne.0) return
826 c     write polynomials coefficients
827       mn1=(istk(il+8+mn)-1)*(istk(il+3)+1)
828       l=sadr(il+9+mn)
829       call mputnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
830       return
831       end
832
833       subroutine loadpol(fd,il,n,ierr)
834 c     Copyright INRIA
835 c     Load a matrix of polynomials
836       include 'stack.h'
837       integer fd
838       character*3 fmti,fmtd
839       integer sadr
840       double precision dblNaN
841
842       integer isanan
843       external isanan
844
845 c
846       iadr(l)=l+l-1
847       sadr(l)=(l/2)+1
848 c
849       call returnananfortran(dblNaN)
850
851       fmti='il'//char(0)
852       fmtd='dl'//char(0)
853
854 c     read matrix header without type
855       err=sadr(il+7)-lstk(bot)
856       if(err.gt.0) then
857          call error(17)
858          return
859       endif
860
861       call mgetnc (fd,istk(il+1),7,fmti,ierr)
862       if(ierr.ne.0) return
863 c
864       mn=istk(il+1)*istk(il+2)
865       err=sadr(il+8+mn)-lstk(bot)
866       if(err.gt.0) then
867          call error(17)
868          return
869       endif
870       call mgetnc (fd,istk(il+8),1+mn,fmti,ierr)
871       if(ierr.ne.0) return
872
873 c     read polynomials coefficients
874       mn1=(istk(il+8+mn)-1)*(istk(il+3)+1)
875       err=sadr(il+9+mn)+mn1-lstk(bot)
876       if(err.gt.0) then
877          call error(17)
878          return
879       endif
880       l=sadr(il+9+mn)
881       call mgetnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
882
883 c     convert all NaN to Signaling NaN
884       do 10 i = 0, mn1-1
885           if(isanan(stk(l+i)).eq.1) then
886               stk(l+i) = dblNaN
887           endif
888 10    continue
889
890       n=iadr(l+mn1)-il
891 c      n=9+mn+2*mn1
892       return
893       end
894
895
896       subroutine savestr(fd,il,ierr)
897 c     Copyright INRIA
898 c     Save a matrix of strings
899       include 'stack.h'
900 c
901       integer fd
902
903       character*3 fmti,fmtc
904 c
905 c      iadr(l)=l+l-1
906 c      sadr(l)=(l/2)+1
907 c
908       fmti='il'//char(0)
909       fmtc='c'//char(0)
910 c
911 c     write matrix header  without type
912       mn=istk(il+1)*istk(il+2)
913       call mputnc (fd,istk(il+1),4+mn,fmti,ierr)
914       if(ierr.ne.0) return
915 c     write characters
916       mn1=istk(il+4+mn)-1
917       call mputnc(fd,istk(il+5+mn),mn1,fmti,ierr)
918       return
919       end
920
921       subroutine loadstr(fd,il,n,ierr)
922 c     Copyright INRIA
923 c     Load a matrix of strings
924       include 'stack.h'
925       integer fd
926       character*3 fmti
927       integer sadr
928 c
929 c      iadr(l)=l+l-1
930       sadr(l)=(l/2)+1
931 c
932       fmti='il'//char(0)
933 c
934 c     read matrix header without type
935       err=sadr(il+4)-lstk(bot)
936       if(err.gt.0) then
937          call error(17)
938          return
939       endif
940       call mgetnc (fd,istk(il+1),3,fmti,ierr)
941       if(ierr.ne.0) return
942
943       mn=istk(il+1)*istk(il+2)
944       err=sadr(il+5+mn)-lstk(bot)
945       if(err.gt.0) then
946          call error(17)
947          return
948       endif
949       call mgetnc (fd,istk(il+4),mn+1,fmti,ierr)
950       if(ierr.ne.0) return
951
952 c     read characters
953       mn1=istk(il+4+mn)-1
954       err=sadr(il+5+mn+mn1)-lstk(bot)
955       if(err.gt.0) then
956          call error(17)
957          return
958       endif
959       call mgetnc(fd,istk(il+5+mn),mn1,fmti,ierr)
960       n=5+mn+mn1
961       return
962       end
963
964       subroutine savebool(fd,il,ierr)
965 c     Copyright INRIA
966 c     Save a matrix of boolean
967       include 'stack.h'
968 c
969       integer fd
970       character*3 fmti
971 c
972 c      iadr(l)=l+l-1
973 c      sadr(l)=(l/2)+1
974 c
975       fmti='il'//char(0)
976 c
977 c     write matrix header without type
978       call mputnc (fd,istk(il+1),2,fmti,ierr)
979       if(ierr.ne.0) return
980 c     write matrix elements
981       mn=istk(il+1)*istk(il+2)
982       call mputnc(fd,istk(il+3),mn,fmti,ierr)
983       return
984       end
985
986       subroutine loadbool(fd,il,n,ierr)
987 c     Copyright INRIA
988 c     Load a matrix of boolean
989       include 'stack.h'
990       integer fd
991       character*3 fmti
992       integer sadr
993 c
994 c      iadr(l)=l+l-1
995       sadr(l)=(l/2)+1
996 c
997       fmti='il'//char(0)
998
999 c     read matrix header without type
1000       err=sadr(il+3)-lstk(bot)
1001       if(err.gt.0) then
1002          call error(17)
1003          return
1004       endif
1005       call mgetnc (fd,istk(il+1),2,fmti,ierr)
1006       if(ierr.ne.0) return
1007
1008 c     read matrix elements
1009       mn=istk(il+1)*istk(il+2)
1010       err=sadr(il+3+mn)-lstk(bot)
1011       if(err.gt.0) then
1012          call error(17)
1013          return
1014       endif
1015       call mgetnc(fd,istk(il+3),mn,fmti,ierr)
1016       n=3+mn
1017       return
1018       end
1019
1020
1021       subroutine savefun(fd,il,ierr)
1022 c     Copyright INRIA
1023 c     Save  a function
1024       include 'stack.h'
1025 c
1026       integer fd
1027       character*3 fmti
1028 c
1029 c      iadr(l)=l+l-1
1030 c      sadr(l)=(l/2)+1
1031 c
1032       fmti='il'//char(0)
1033 c
1034 c     write function header without type
1035       il1=il
1036       nout=istk(il1+1)
1037       il1=il1+1+nout*nsiz
1038       nin=istk(il1+1)
1039       il1=il1+1+nin*nsiz
1040       n=istk(il1+1)
1041       call mputnc (fd,istk(il+1),3+(nout+nin)*nsiz+n,fmti,ierr)
1042       if(ierr.ne.0) return
1043       return
1044       end
1045
1046       subroutine loadfun(fd,il,n,ierr)
1047 c     Copyright INRIA
1048 c     Load a function
1049       include 'stack.h'
1050 c
1051       integer fd
1052       character*3 fmti
1053       integer sadr
1054 c
1055 c      iadr(l)=l+l-1
1056       sadr(l)=(l/2)+1
1057 c
1058       fmti='il'//char(0)
1059 c
1060 c     read function  without type
1061       il1=il
1062       err=sadr(il1+2)-lstk(bot)
1063       if(err.gt.0) then
1064          call error(17)
1065          return
1066       endif
1067       call mgetnc (fd,istk(il1+1),1,fmti,ierr)
1068       if(ierr.ne.0) return
1069
1070       nout=istk(il1+1)
1071       il1=il1+2
1072       err=sadr(il1+nout*nsiz+1)-lstk(bot)
1073       if(err.gt.0) then
1074          call error(17)
1075          return
1076       endif
1077       call mgetnc (fd,istk(il1),nout*nsiz+1,fmti,ierr)
1078       if(ierr.ne.0) return
1079
1080       nin=istk(il1+nout*nsiz)
1081       il1=il1+nout*nsiz+1
1082       err=sadr(il1+nin*nsiz+1)-lstk(bot)
1083       if(err.gt.0) then
1084          call error(17)
1085          return
1086       endif
1087       call mgetnc (fd,istk(il1),nin*nsiz+1,fmti,ierr)
1088       if(ierr.ne.0) return
1089
1090       n=istk(il1+nin*nsiz)
1091       il1=il1+nin*nsiz+1
1092       err=sadr(il1+n)-lstk(bot)
1093       if(err.gt.0) then
1094          call error(17)
1095          return
1096       endif
1097       call mgetnc (fd,istk(il1),n,fmti,ierr)
1098       if(ierr.ne.0) return
1099       n=4+(nout+nin)*nsiz+n
1100       return
1101       end
1102
1103       subroutine savecfun(fd,il,ierr)
1104 c     Copyright INRIA
1105 c     Save a compiled function
1106       include 'stack.h'
1107 c
1108       integer fd
1109       character*3 fmti
1110 c
1111 c      iadr(l)=l+l-1
1112 c      sadr(l)=(l/2)+1
1113 c
1114       fmti='il'//char(0)
1115 c
1116 c     write function header without type
1117       il1=il
1118       nout=istk(il1+1)
1119       il1=il1+1+nout*nsiz
1120       nin=istk(il1+1)
1121       il1=il1+1+nin*nsiz
1122       n=istk(il1+1)
1123       call mputnc (fd,istk(il+1),3+(nout+nin)*nsiz+n,fmti,ierr)
1124       if(ierr.ne.0) return
1125       return
1126       end
1127
1128       subroutine loadcfun(fd,il,n,ierr)
1129 c     Copyright INRIA
1130 c     Load a compiled function
1131       include 'stack.h'
1132 c
1133       integer fd
1134       integer sadr
1135       character*3 fmti
1136 c
1137 c      iadr(l)=l+l-1
1138       sadr(l)=(l/2)+1
1139 c
1140       fmti='il'//char(0)
1141 c
1142 c     read function  without type
1143       il1=il
1144       err=sadr(il1+2)-lstk(bot)
1145       if(err.gt.0) then
1146          call error(17)
1147          return
1148       endif
1149       call mgetnc (fd,istk(il1+1),1,fmti,ierr)
1150       if(ierr.ne.0) return
1151
1152       nout=istk(il1+1)
1153       il1=il1+2
1154       err=sadr(il1+nout*nsiz+1)-lstk(bot)
1155       if(err.gt.0) then
1156          call error(17)
1157          return
1158       endif
1159       call mgetnc (fd,istk(il1),nout*nsiz+1,fmti,ierr)
1160       if(ierr.ne.0) return
1161
1162       nin=istk(il1+nout*nsiz)
1163       il1=il1+nout*nsiz+1
1164       err=sadr(il1+nin*nsiz+1)-lstk(bot)
1165       if(err.gt.0) then
1166          call error(17)
1167          return
1168       endif
1169       call mgetnc (fd,istk(il1),nin*nsiz+1,fmti,ierr)
1170       if(ierr.ne.0) return
1171
1172       n=istk(il1+nin*nsiz)
1173       il1=il1+nin*nsiz+1
1174       err=sadr(il1+n)-lstk(bot)
1175       if(err.gt.0) then
1176          call error(17)
1177          return
1178       endif
1179       call mgetnc (fd,istk(il1),n,fmti,ierr)
1180       if(ierr.ne.0) return
1181       n=4+(nout+nin)*nsiz+n
1182       return
1183       end
1184
1185
1186       subroutine savesparse(fd,il,ierr)
1187 c     Copyright INRIA
1188 c     Save a sparse matrix of numbers
1189       include 'stack.h'
1190 c
1191       integer fd
1192       character*3 fmti,fmtd
1193       integer sadr
1194 c
1195       iadr(l)=l+l-1
1196       sadr(l)=(l/2)+1
1197 c
1198       fmti='il'//char(0)
1199       fmtd='dl'//char(0)
1200 c
1201 c     write matrix header type excluded
1202       call mputnc (fd,istk(il+1),4,fmti,ierr)
1203       if(ierr.ne.0) return
1204       m=istk(il+1)
1205       nel=istk(il+4)
1206 c     write matrix elements
1207       call mputnc(fd,istk(il+5),m+nel,fmti,ierr)
1208       if(ierr.ne.0) return
1209       mn=nel*(istk(il+3)+1)
1210       l=sadr(il+5+m+nel)
1211       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1212       return
1213       end
1214
1215       subroutine loadsparse(fd,il,n,ierr)
1216 c     Copyright INRIA
1217 c     load a sparse matrix of numbers
1218       include 'stack.h'
1219       integer fd
1220       character*3 fmti,fmtd
1221       integer sadr
1222 c
1223       iadr(l)=l+l-1
1224       sadr(l)=(l/2)+1
1225 c
1226       fmti='il'//char(0)
1227       fmtd='dl'//char(0)
1228
1229 c     read matrix header without type
1230       err=sadr(il+5)-lstk(bot)
1231       if(err.gt.0) then
1232          call error(17)
1233          return
1234       endif
1235       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1236       if(ierr.ne.0) return
1237
1238       m=istk(il+1)
1239       nel=istk(il+4)
1240 c     read matrix elements
1241       il1=il+5
1242       err=sadr(il1+m+nel)-lstk(bot)
1243       if(err.gt.0) then
1244          call error(17)
1245          return
1246       endif
1247       call mgetnc(fd,istk(il1),m+nel,fmti,ierr)
1248       if(ierr.ne.0) return
1249
1250       il1=il1+m+nel
1251       mn=nel*(istk(il+3)+1)
1252       err=sadr(il1)+mn-lstk(bot)
1253       if(err.gt.0) then
1254          call error(17)
1255          return
1256       endif
1257       l=sadr(il+5+m+nel)
1258       call mgetnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1259       n=iadr(l+mn)-il
1260 c      n=5+m+nel+2*mn
1261       return
1262       end
1263
1264       subroutine savespb(fd,il,ierr)
1265 c     Copyright INRIA
1266 c     Save a sparse matrix of boolean
1267       include 'stack.h'
1268 c
1269       integer fd
1270       character*3 fmti,fmtd
1271 c
1272       fmti='il'//char(0)
1273       fmtd='dl'//char(0)
1274 c
1275 c     write matrix header type excluded
1276       call mputnc (fd,istk(il+1),4,fmti,ierr)
1277       if(ierr.ne.0) return
1278       m=istk(il+1)
1279       nel=istk(il+4)
1280 c     write matrix elements
1281       call mputnc(fd,istk(il+5),m+nel,fmti,ierr)
1282       return
1283       end
1284
1285       subroutine loadspb(fd,il,n,ierr)
1286 c     Copyright INRIA
1287 c     Load a sparse matrix of boolean
1288       include 'stack.h'
1289       integer fd
1290       character*3 fmti,fmtd
1291       integer sadr
1292
1293 c
1294 c      iadr(l)=l+l-1
1295       sadr(l)=(l/2)+1
1296 c
1297       fmti='il'//char(0)
1298       fmtd='dl'//char(0)
1299
1300 c     read matrix header without type
1301       err=sadr(il+5)-lstk(bot)
1302       if(err.gt.0) then
1303          call error(17)
1304          return
1305       endif
1306       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1307       if(ierr.ne.0) return
1308
1309       m=istk(il+1)
1310       nel=istk(il+4)
1311 c     read matrix elements
1312       err=sadr(il+5+m+nel)-lstk(bot)
1313       if(err.gt.0) then
1314          call error(17)
1315          return
1316       endif
1317       call mgetnc(fd,istk(il+5),m+nel,fmti,ierr)
1318       n=5+m+nel
1319       return
1320       end
1321
1322       subroutine savelib(fd,il,ierr)
1323 c     [14,n,codagedupath(n),nombre-de-nom,nclas+1 cases,suite des noms]
1324 c     Copyright INRIA
1325 c     Save a sparse matrix of numbers
1326       include 'stack.h'
1327 c
1328       integer fd
1329       character*3 fmti,fmtd
1330       data nclas/29/
1331 c
1332       fmti='il'//char(0)
1333       fmtd='dl'//char(0)
1334 c
1335       np=istk(il+1)
1336       nn=istk(il+2+np)
1337       call mputnc (fd,istk(il+1),3+np+nclas+nn*nsiz,fmti,ierr)
1338       return
1339       end
1340
1341       subroutine loadlib(fd,il,n,ierr)
1342 c     [14,n,codagedupath(n),nombre-de-nom,nclas+1 cases,suite des noms]
1343 c     Copyright INRIA
1344 c     Save a sparse matrix of numbers
1345       include 'stack.h'
1346 c
1347       integer fd
1348       character*3 fmti,fmtd
1349       integer sadr
1350       data nclas/29/
1351 c
1352 c      iadr(l)=l+l-1
1353       sadr(l)=(l/2)+1
1354 c
1355       fmti='il'//char(0)
1356       fmtd='dl'//char(0)
1357 c
1358       il1=il+1
1359       err=sadr(il1+1)-lstk(bot)
1360       if(err.gt.0) then
1361          call error(17)
1362          return
1363       endif
1364       call mgetnc (fd,istk(il1),1,fmti,ierr)
1365       if(ierr.ne.0) return
1366
1367       np=istk(il1)
1368       il1=il1+1
1369       err=sadr(il1+np+1+nclas+1)-lstk(bot)
1370       if(err.gt.0) then
1371          call error(17)
1372          return
1373       endif
1374       call mgetnc (fd,istk(il1),np+1+nclas+1,fmti,ierr)
1375       if(ierr.ne.0) return
1376
1377       il1=il1+np+1+nclas+1
1378       nn=istk(il+2+np)
1379       err=sadr(il1+nn*nsiz)-lstk(bot)
1380       if(err.gt.0) then
1381          call error(17)
1382          return
1383       endif
1384       call mgetnc (fd,istk(il1),nn*nsiz,fmti,ierr)
1385       n=il1+nn*nsiz-il
1386       return
1387       end
1388
1389       subroutine savemsp(fd,il,ierr)
1390 c     Copyright INRIA
1391 c     Save a sparse matrix of numbers
1392       include 'stack.h'
1393 c
1394       integer fd
1395       character*3 fmti,fmtd
1396       integer sadr
1397 c
1398       iadr(l)=l+l-1
1399       sadr(l)=(l/2)+1
1400 c
1401       fmti='il'//char(0)
1402       fmtd='dl'//char(0)
1403 c
1404 c     write matrix header type excluded
1405       call mputnc (fd,istk(il+1),4,fmti,ierr)
1406       if(ierr.ne.0) return
1407       n=istk(il+2)
1408       nel=istk(il+4)
1409 c     write matrix elements
1410       call mputnc(fd,istk(il+5),n+nel+1,fmti,ierr)
1411       if(ierr.ne.0) return
1412       mn=nel*(istk(il+3)+1)
1413       l=sadr(il+6+n+nel)
1414       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1415       return
1416       end
1417
1418       subroutine loadmsp(fd,il,n,ierr)
1419 c     Copyright INRIA
1420 c     load a sparse matrix of numbers
1421       include 'stack.h'
1422       integer fd
1423       character*3 fmti,fmtd
1424       integer sadr
1425 c
1426       iadr(l)=l+l-1
1427       sadr(l)=(l/2)+1
1428 c
1429       fmti='il'//char(0)
1430       fmtd='dl'//char(0)
1431
1432 c     read matrix header without type
1433       err=sadr(il+5)-lstk(bot)
1434       if(err.gt.0) then
1435          call error(17)
1436          return
1437       endif
1438
1439       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1440       if(ierr.ne.0) return
1441
1442       n=istk(il+2)
1443       nel=istk(il+4)
1444 c     read matrix elements
1445       il1=il+5
1446       err=sadr(il1+n+nel)-lstk(bot)
1447       if(err.gt.0) then
1448          call error(17)
1449          return
1450       endif
1451       call mgetnc(fd,istk(il1),n+nel+1,fmti,ierr)
1452       if(ierr.ne.0) return
1453
1454       il1=il1+n+nel+1
1455       mn=nel*(istk(il+3)+1)
1456       err=sadr(il1)+mn-lstk(bot)
1457       if(err.gt.0) then
1458          call error(17)
1459          return
1460       endif
1461       l=sadr(il1)
1462       call mgetnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1463       n=iadr(l+mn)-il
1464 c      n=5+n+nel+2*mn
1465       return
1466       end
1467
1468       subroutine saveptr(fd,il,ierr)
1469 c     Copyright INRIA
1470 c     Save a pointer on sparse lu factorization
1471       include 'stack.h'
1472 c
1473       integer fd
1474       character*3 fmti,fmtd
1475 c
1476       fmti='il'//char(0)
1477       fmtd='dl'//char(0)
1478 c
1479       buf='handle to sparse lu factors cannot be saved yet'
1480 c      call error(997)
1481       ierr=997
1482       return
1483       end
1484
1485       subroutine loadptr(fd,il,n,ierr)
1486 c     Copyright INRIA
1487 c     Save a pointer on sparse lu factorization
1488       include 'stack.h'
1489       integer fd
1490       character*3 fmti,fmtd
1491       integer sadr
1492 c
1493       iadr(l)=l+l-1
1494       sadr(l)=(l/2)+1
1495 c
1496       fmti='il'//char(0)
1497       fmtd='dl'//char(0)
1498
1499 c     read matrix header without type
1500       err=sadr(il+4)+1-lstk(bot)
1501       if(err.gt.0) then
1502          call error(17)
1503          return
1504       endif
1505       call mgetnc (fd,istk(il+1),3,fmti,ierr)
1506       if(ierr.ne.0) return
1507 c     read pointer
1508       l=sadr(il+4)
1509       call mgetnc(fd,istk(iadr(l)),1,fmtd,ierr)
1510       n=iadr(l+1)-il
1511 c      n=4+2*1
1512       return
1513       end
1514
1515       subroutine savefptr(fd,il,ierr)
1516 c     Copyright INRIA
1517 c     Save a pointer on  a primitive
1518       include 'stack.h'
1519 c
1520       integer fd
1521       character*3 fmti,fmtd
1522 c
1523       fmti='il'//char(0)
1524       fmtd='dl'//char(0)
1525
1526 c     write matrix header type excluded
1527       call mputnc (fd,istk(il+1),2+nsiz,fmti,ierr)
1528
1529       end
1530
1531       subroutine loadfptr(fd,il,n,ierr)
1532 c     Copyright INRIA
1533 c     load a pointer on a primitive
1534       include 'stack.h'
1535 c
1536       integer fd
1537       character*3 fmti,fmtd
1538       integer sadr
1539 c
1540       sadr(l)=(l/2)+1
1541
1542       fmti='il'//char(0)
1543       fmtd='dl'//char(0)
1544
1545       err=sadr(il+3+nsiz)-lstk(bot)
1546       if(err.gt.0) then
1547          call error(17)
1548          return
1549       endif
1550       call mgetnc (fd,istk(il+1),2+nsiz,fmti,ierr)
1551       if(ierr.ne.0) return
1552       n=3+nsiz
1553       end
1554
1555       subroutine saveint(fd,il,ierr)
1556 c     Copyright INRIA
1557 c     Save a pointer on sparse lu factorization
1558       include 'stack.h'
1559 c
1560       integer fd
1561       character*3 fmti,fmtd
1562
1563       fmti='il'//char(0)
1564       fmtd='dl'//char(0)
1565 c
1566 c     write  header type excluded
1567       call mputnc (fd,istk(il+1),3,fmti,ierr)
1568       if(ierr.ne.0) return
1569       mn=istk(il+1)*istk(il+2)
1570       it=istk(il+3)
1571
1572       if(it.eq.4) then
1573          call mputnc(fd,istk(il+4),mn,fmti,ierr)
1574       elseif(it.eq.2) then
1575          call mputnc(fd,istk(il+4),mn,'sl'//char(0),ierr)
1576       elseif(it.eq.1) then
1577          call mputnc(fd,istk(il+4),mn,'c'//char(0),ierr)
1578       elseif(it.eq.14) then
1579          call mputnc(fd,istk(il+4),mn,'uil'//char(0),ierr)
1580       elseif(it.eq.12) then
1581          call mputnc(fd,istk(il+4),mn,'usl'//char(0),ierr)
1582       elseif(it.eq.11) then
1583          call mputnc(fd,istk(il+4),mn,'uc'//char(0),ierr)
1584       endif
1585       return
1586       end
1587
1588       subroutine loadint(fd,il,n,ierr)
1589 c     Copyright INRIA
1590 c     Save a pointer on sparse lu factorization
1591       include 'stack.h'
1592       integer fd
1593       external memused
1594       integer memused
1595       character*3 fmti,fmtd
1596       integer sadr
1597 c
1598       sadr(l)=(l/2)+1
1599 c
1600       fmti='il'//char(0)
1601       fmtd='dl'//char(0)
1602
1603 c     read matrix header without type
1604       err=sadr(il+4)+1-lstk(bot)
1605       if(err.gt.0) then
1606          call error(17)
1607          return
1608       endif
1609       call mgetnc (fd,istk(il+1),3,fmti,ierr)
1610       if(ierr.ne.0) return
1611       mn=istk(il+1)*istk(il+2)
1612       it=istk(il+3)
1613       err=sadr(il+4+memused(it,mn))-lstk(bot)
1614       if(err.gt.0) then
1615          call error(17)
1616          return
1617       endif
1618       if(it.eq.4) then
1619          call mgetnc(fd,istk(il+4),mn,fmti,ierr)
1620       elseif(it.eq.2) then
1621          call mgetnc(fd,istk(il+4),mn,'sl'//char(0),ierr)
1622       elseif(it.eq.1) then
1623          call mgetnc(fd,istk(il+4),mn,'c'//char(0),ierr)
1624       elseif(it.eq.14) then
1625          call mgetnc(fd,istk(il+4),mn,'uil'//char(0),ierr)
1626       elseif(it.eq.12) then
1627          call mgetnc(fd,istk(il+4),mn,'usl'//char(0),ierr)
1628       elseif(it.eq.11) then
1629          call mgetnc(fd,istk(il+4),mn,'uc'//char(0),ierr)
1630       endif
1631       n=4+memused(it,mn)
1632       return
1633       end
1634
1635