cbabfea4a7a54dcd4884439cf60bd5682d5ee56b
[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
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,int(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)  call mseek(fd,0,'set'//char(0),ierr)
310                goto 30
311             endif
312  27      continue
313 c     .  no skip it
314          goto 10
315       endif  
316
317  30   ssym=sym
318       sym = semi
319       srhs=rhs
320       rhs = 0
321       call stackp(id,1)
322       if (id1(1).ne.blank) then
323          if(eqid(id,id1)) k1=fin
324       endif
325       rhs=srhs
326       sym=ssym
327       kvar=kvar+1
328       top = top + 1
329       if(kvar.eq.rhs-1) goto 50
330       goto 10
331
332 c     close the file if necessary
333  50   if (.not.opened) then
334          call mclose (fd,res)
335       endif
336       top=top-1
337 c     return a nul variable
338       il=iadr(lstk(top))
339       istk(il)=0
340       lstk(top+1)=lstk(top)+1
341       return
342       end
343
344       subroutine savevar(fd,id,il,vol,ierr)
345 c     Copyright INRIA
346       include 'stack.h'
347 c
348       integer fd,id(nsiz),vol
349       integer iadr
350       character*3 fmti,fmtd
351 c
352 c
353       iadr(l)=l+l-1
354 c      sadr(l)=(l/2)+1
355 c
356
357       fmti='il'//char(0)
358       fmtd='dl'//char(0)
359 c
360       if(rstk(pt).eq.911) then
361          il1=il
362          if(istk(il1).lt.0) il1=iadr(istk(il1+1))
363          call savelist(fd,il1,ierr)
364          return
365       endif
366
367       il1=il
368       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
369
370 c     write id and type
371       call mputnc (fd,id,nsiz,fmti,ierr)
372       if(ierr.ne.0) return
373       call mputnc (fd,istk(il1),1,fmti,ierr)
374       if(ierr.ne.0) return
375
376       if(istk(il1).eq.1) then
377          call savemat(fd,il1,ierr)
378       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
379          call savepol(fd,il1,ierr)
380       elseif(istk(il1).eq.4) then
381          call savebool(fd,il1,ierr)
382       elseif(istk(il1).eq.5) then
383          call savesparse(fd,il1,ierr)
384       elseif(istk(il1).eq.6) then
385          call savespb(fd,il1,ierr)
386       elseif(istk(il1).eq.7) then
387          call savemsp(fd,il1,ierr)
388       elseif(istk(il1).eq.8) then
389          call saveint(fd,il1,ierr)
390       elseif(istk(il1).eq.10) then
391          call savestr(fd,il1,ierr)
392       elseif(istk(il1).eq.11) then
393          call savefun(fd,il1,ierr)
394       elseif(istk(il1).eq.13) then
395          call savecfun(fd,il1,ierr)
396       elseif(istk(il1).eq.14) then 
397          call savelib(fd,il1,ierr)
398       elseif(istk(il1).ge.15.and.istk(il1).le.17) then
399  10      call savelist(fd,il1,ierr)
400       elseif(istk(il1).eq.128) then 
401          call saveptr(fd,il1,ierr)
402       elseif(istk(il1).eq.130) then 
403          call savefptr(fd,il1,ierr)
404       else
405 c     .  call an external function
406          fun=-il1
407          fin=vol
408       endif
409       return
410       end
411
412       subroutine loadvar(fd,id,il,nn,ierr)
413 c     Copyright INRIA
414       include 'stack.h'
415 c
416       integer fd,id(nsiz)
417       character*3 fmti,fmtd
418 c
419 c
420       sadr(l)=(l/2)+1
421 c
422
423       fmti='il'//char(0)
424       fmtd='dl'//char(0)
425 c
426       if(rstk(pt).eq.912) then
427          call loadlist(fd,il,nn,ierr)
428          return
429       endif
430 c
431
432       il1=il
433 c     read id and type
434       call mgetnc (fd,id,nsiz,fmti,ierr)
435       if(ierr.ne.0) return
436       call mgetnc (fd,istk(il1),1,fmti,ierr)
437       if(ierr.ne.0) return
438       if(istk(il1).eq.1) then
439          call loadmat(fd,il1,nn,ierr)
440       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
441          call loadpol(fd,il1,nn,ierr)
442       elseif(istk(il1).eq.4) then
443          call loadbool(fd,il1,nn,ierr)
444       elseif(istk(il1).eq.5) then
445          call loadsparse(fd,il1,nn,ierr)
446       elseif(istk(il1).eq.6) then
447          call loadspb(fd,il1,nn,ierr)
448       elseif(istk(il1).eq.7) then
449          call loadmsp(fd,il1,nn,ierr)
450       elseif(istk(il1).eq.8) then
451          call loadint(fd,il1,nn,ierr)
452       elseif(istk(il1).eq.10) then
453          call loadstr(fd,il1,nn,ierr)
454       elseif(istk(il1).eq.11) then
455          call loadfun(fd,il1,nn,ierr)
456       elseif(istk(il1).eq.13) then
457          call loadcfun(fd,il1,nn,ierr)
458       elseif(istk(il1).eq.14) then 
459          call loadlib(fd,il1,nn,ierr)
460       elseif(istk(il1).ge.15.and.istk(il1).le.17) then   
461          call loadlist(fd,il1,nn,ierr)
462       elseif(istk(il1).eq.128) then 
463          call loadptr(fd,il1,nn,ierr)
464       elseif(istk(il1).eq.130) then 
465          call loadfptr(fd,il1,nn,ierr)
466       else
467          fun=-il1
468          lstk(top+1)=sadr(il1)
469       endif
470       if(err.gt.0) ierr=1
471       return
472       end
473
474       subroutine savelist(fd,il,ierr)
475 c     Copyright INRIA
476 c     Save a matrix of numbers
477       include 'stack.h'
478 c
479       integer fd
480       logical ptover
481       integer iadr,sadr
482       character*3 fmti,fmtd
483 c
484       iadr(l)=l+l-1
485       sadr(l)=(l/2)+1
486 c
487       fmti='il'//char(0)
488       fmtd='dl'//char(0)
489       if(rstk(pt).eq.911) then
490 c     .  manage recursion
491          n=ids(1,pt)
492          il=ids(2,pt)
493          i=ids(3,pt)
494          pt=pt-1
495          l=sadr(il+n+3)
496          il1=iadr(l-1+istk(il+1+i))
497          if(istk(il1).lt.0) il1=iadr(istk(il1+1))
498          goto 20
499       endif
500 c
501  10   n=istk(il+1)
502 c     write list header
503       call mputnc (fd,istk(il+1),n+2,fmti,ierr)
504       if(ierr.ne.0) return
505 c     write the elements
506       l=sadr(il+n+3)
507       i=0
508  20   continue
509       i=i+1
510       if(i.gt.n) goto 30
511       if(istk(il+2+i)-istk(il+1+i).eq.0) goto 20
512       il1=iadr(l-1+istk(il+1+i))
513       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
514 c     write type
515       call mputnc (fd,istk(il1),1,fmti,ierr)
516       if(ierr.ne.0) return
517
518       if(istk(il1).eq.1) then
519          call savemat(fd,il1,ierr)
520       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
521          call savepol(fd,il1,ierr)
522       elseif(istk(il1).eq.4) then
523          call savebool(fd,il1,ierr)
524       elseif(istk(il1).eq.5) then
525          call savesparse(fd,il1,ierr)
526       elseif(istk(il1).eq.6) then
527          call savespb(fd,il1,ierr)
528       elseif(istk(il1).eq.7) then
529          call savemsp(fd,il1,ierr)
530       elseif(istk(il1).eq.8) then
531          call saveint(fd,il1,ierr)
532       elseif(istk(il1).eq.10) then
533          call savestr(fd,il1,ierr)
534       elseif(istk(il1).eq.11) then
535          call savefun(fd,il1,ierr)
536       elseif(istk(il1).eq.13) then
537          call savecfun(fd,il1,ierr)
538       elseif(istk(il1).eq.14) then 
539          call savelib(fd,il1,ierr)
540       elseif(istk(il1).ge.15.and.istk(il1).le.17) then   
541 c     .  a sublist
542          if(istk(il1).lt.0) il1=iadr(istk(il1+1))
543          if (ptover(1,psiz)) return
544          rstk(pt)=408
545          ids(1,pt)=n
546          ids(2,pt)=il
547          ids(3,pt)=i
548          il=il1
549          goto 10
550       elseif(istk(il1).eq.128) then 
551          call saveptr(fd,il1,ierr)
552       elseif(istk(il1).eq.130) then 
553          call savefptr(fd,il1,ierr)
554       else
555 c     .  call an external function
556          if (ptover(1,psiz)) return
557          rstk(pt)=911
558          ids(1,pt)=n
559          ids(2,pt)=il
560          ids(3,pt)=i
561
562          fun=-il1
563          fin=istk(il+2+i)-istk(il+1+i)
564          return
565       endif
566       if(ierr.ne.0) return
567       goto 20
568 c     
569  30   continue
570 c     end of current list reached
571       if(rstk(pt).ne.408) goto 40
572       n=ids(1,pt)
573       il=ids(2,pt)
574       i=ids(3,pt)
575       pt=pt-1
576       l=sadr(il+n+3)
577       il1=iadr(l-1+istk(il+1+i))
578       if(istk(il1).lt.0) il1=iadr(istk(il1+1))
579       goto 20
580  40   continue
581 c     finish
582       return
583       end
584
585       subroutine loadlist(fd,il,nn,ierr)
586 c     Copyright INRIA
587 c     Save a matrix of numbers
588       include 'stack.h'
589 c
590       integer fd
591       logical ptover
592       integer iadr,sadr
593       character*3 fmti,fmtd
594 c
595       iadr(l)=l+l-1
596       sadr(l)=(l/2)+1
597 c
598       fmti='il'//char(0)
599       fmtd='dl'//char(0)
600       ierr=0
601 c
602       il1=il
603       if(rstk(pt).eq.912) then
604 c     .  manage recursion
605          n=ids(1,pt)
606          il=ids(2,pt)
607          i=ids(3,pt)
608          il0=ids(4,pt)
609          nne=ids(5,pt)
610          pt=pt-1
611          l=sadr(il+n+3)
612          il1=iadr(lstk(top))
613          istk(il+2+i)=istk(il+1+i)+lstk(top+1)-lstk(top)
614          top=top-1
615          goto 20
616       endif
617       
618  10   il0=il
619 c     read list header without type
620       err=sadr(il+3)-lstk(bot)
621       if(err.gt.0) then
622          call error(17)
623          return
624       endif
625       call mgetnc (fd,istk(il+1),2,fmti,ierr)
626       if(ierr.ne.0) return
627       n=istk(il+1)
628       err=sadr(il+3+n)-lstk(bot)
629       if(err.gt.0) then
630          call error(17)
631          return
632       endif
633       call mgetnc (fd,istk(il+3),n,fmti,ierr)
634       if(ierr.ne.0) return
635       il1=il+3+n
636 c     read the elements
637       l=sadr(il1)
638       nne=0
639       i=0
640  20   continue
641       i=i+1
642
643       if(i.gt.n) goto 30
644       if(istk(il+2+i)-istk(il+1+i).eq.0) goto 20
645       il1=iadr(l-1+istk(il+1+i))
646 c     read  type
647       call mgetnc (fd,istk(il1),1,fmti,ierr)
648       if(ierr.ne.0) return
649
650       if(istk(il1).eq.1) then
651          call loadmat(fd,il1,nne,ierr)
652       elseif(istk(il1).eq.2.or.istk(il1).eq.129) then
653          call loadpol(fd,il1,nne,ierr)
654       elseif(istk(il1).eq.4) then
655          call loadbool(fd,il1,nne,ierr)
656       elseif(istk(il1).eq.5) then
657          call loadsparse(fd,il1,nne,ierr)
658       elseif(istk(il1).eq.6) then
659          call loadspb(fd,il1,nne,ierr)
660       elseif(istk(il1).eq.7) then
661          call loadmsp(fd,il1,nne,ierr)
662       elseif(istk(il1).eq.8) then
663          call loadint(fd,il1,nne,ierr)
664       elseif(istk(il1).eq.10) then
665          call loadstr(fd,il1,nne,ierr)
666       elseif(istk(il1).eq.11) then
667          call loadfun(fd,il1,nne,ierr)
668       elseif(istk(il1).eq.13) then
669          call loadcfun(fd,il1,nne,ierr)
670       elseif(istk(il1).eq.14) then 
671          call loadlib(fd,il1,nne,ierr)
672       elseif(istk(il1).ge.15.and.istk(il1).le.17) then   
673 c     .  a sublist 
674          if (ptover(1,psiz)) return
675          rstk(pt)=408
676          ids(1,pt)=n
677          ids(2,pt)=il
678          ids(3,pt)=i
679          ids(4,pt)=il0
680          il=il1
681          goto 10
682       elseif(istk(il1).eq.128) then 
683          call loadptr(fd,il1,nne,ierr)
684       elseif(istk(il1).eq.130) then 
685          call loadfptr(fd,il1,nne,ierr)
686       else
687 c     .  call an external function
688          if (ptover(1,psiz)) return
689          rstk(pt)=912
690          ids(1,pt)=n
691          ids(2,pt)=il
692          ids(3,pt)=i
693          ids(4,pt)=il0
694          lstk(top+1)=sadr(il1)
695          top=top+1
696          lstk(top+1)=lstk(top)
697          fun=-il1
698 c     *call* parse
699          return
700       endif
701       istk(il+2+i)=sadr(il1+nne)-l+1
702       if(err.gt.0) ierr=1
703       if(ierr.ne.0) return
704       goto 20
705 c     
706  30   continue
707 c     end of current list reached
708       if(rstk(pt).ne.408) goto 40
709       ll=sadr(il+n+3)
710       nne=iadr(ll-1+istk(il+2+n))-il
711 c
712       n=ids(1,pt)
713       il=ids(2,pt)
714       i=ids(3,pt)
715       il0=ids(4,pt)
716       pt=pt-1
717       l=sadr(il+n+3)
718       goto 20
719
720  40   continue
721 c     finish
722       nn=il1+nne-il0
723       il=il0
724       return
725       end
726
727       subroutine savemat(fd,il,ierr)
728 c     Copyright INRIA
729 c     Save a matrix of numbers
730       include 'stack.h'
731 c
732       integer fd
733       character*3 fmti,fmtd
734       integer sadr
735 c
736       iadr(l)=l+l-1
737       sadr(l)=(l/2)+1
738 c
739       fmti='il'//char(0)
740       fmtd='dl'//char(0)
741 c
742 c     write matrix header type excluded
743       call mputnc (fd,istk(il+1),3,fmti,ierr)
744       if(ierr.ne.0) return
745 c     write matrix elements
746       mn=istk(il+1)*istk(il+2)*(istk(il+3)+1)
747       l=sadr(il+4)
748       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
749       return
750       end
751
752       subroutine loadmat(fd,il,n,ierr)
753 c     Copyright INRIA
754 c     Save a matrix of numbers
755       include 'stack.h'
756       integer fd
757       character*3 fmti,fmtd
758       integer sadr
759       
760       double precision dblNaN
761       
762       integer isanan
763       external isanan
764       
765 c
766       iadr(l)=l+l-1
767       sadr(l)=(l/2)+1
768 c
769       call returnananfortran(dblNaN)
770       
771       fmti='il'//char(0)
772       fmtd='dl'//char(0)
773
774 c     read matrix header without type
775       err=sadr(il+4)-lstk(bot)
776       if(err.gt.0) then
777          call error(17)
778          return
779       endif
780       call mgetnc (fd,istk(il+1),3,fmti,ierr)
781       if(ierr.ne.0) return
782 c     read matrix elements
783       mn=istk(il+1)*istk(il+2)*(istk(il+3)+1)
784       err=sadr(il+4)+mn-lstk(bot)
785       if(err.gt.0) then
786          call error(17)
787          return
788       endif
789       l=sadr(il+4)
790       call mgetnc(fd,istk(il+4),mn,fmtd,ierr)
791       
792 c     convert all NaN to Signaling NaN
793       do 10 i = 0, mn-1
794           if(isanan(stk(l+i)).eq.1) then
795               stk(l+i) = dblNaN
796           endif
797 10    continue        
798       
799 c      call mgetnc(fd,stk(l),mn,fmtd,ierr)
800       n=iadr(l+mn)-il
801 c      n=4+2*mn
802       return
803       end
804
805       subroutine savepol(fd,il,ierr)
806 c     Copyright INRIA
807 c     Save a matrix of polynomials
808       include 'stack.h'
809 c
810       integer fd
811       character*3 fmti,fmtd
812       integer sadr
813 c
814       iadr(l)=l+l-1
815       sadr(l)=(l/2)+1
816 c
817       fmti='il'//char(0)
818       fmtd='dl'//char(0)
819 c
820 c     write matrix header without type
821       mn=istk(il+1)*istk(il+2)
822       call mputnc (fd,istk(il+1),8+mn,fmti,ierr)
823       if(ierr.ne.0) return
824 c     write polynomials coefficients
825       mn1=(istk(il+8+mn)-1)*(istk(il+3)+1)
826       l=sadr(il+9+mn)
827       call mputnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
828       return
829       end
830
831       subroutine loadpol(fd,il,n,ierr)
832 c     Copyright INRIA
833 c     Load a matrix of polynomials
834       include 'stack.h'
835       integer fd
836       character*3 fmti,fmtd
837       integer sadr
838       double precision dblNaN
839       
840       integer isanan
841       external isanan
842       
843 c
844       iadr(l)=l+l-1
845       sadr(l)=(l/2)+1
846 c
847       call returnananfortran(dblNaN)
848       
849       fmti='il'//char(0)
850       fmtd='dl'//char(0)
851
852 c     read matrix header without type
853       err=sadr(il+7)-lstk(bot)
854       if(err.gt.0) then
855          call error(17)
856          return
857       endif
858
859       call mgetnc (fd,istk(il+1),7,fmti,ierr)
860       if(ierr.ne.0) return
861 c
862       mn=istk(il+1)*istk(il+2)
863       err=sadr(il+8+mn)-lstk(bot)
864       if(err.gt.0) then
865          call error(17)
866          return
867       endif
868       call mgetnc (fd,istk(il+8),1+mn,fmti,ierr)
869       if(ierr.ne.0) return
870
871 c     read polynomials coefficients
872       mn1=(istk(il+8+mn)-1)*(istk(il+3)+1)
873       err=sadr(il+9+mn)+mn1-lstk(bot)
874       if(err.gt.0) then
875          call error(17)
876          return
877       endif
878       l=sadr(il+9+mn)
879       call mgetnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
880       
881 c     convert all NaN to Signaling NaN
882       do 10 i = 0, mn1-1
883           if(isanan(stk(l+i)).eq.1) then
884               stk(l+i) = dblNaN
885           endif
886 10    continue        
887       
888       n=iadr(l+mn1)-il
889 c      n=9+mn+2*mn1
890       return
891       end
892
893
894       subroutine savestr(fd,il,ierr)
895 c     Copyright INRIA
896 c     Save a matrix of strings
897       include 'stack.h'
898 c
899       integer fd
900
901       character*3 fmti,fmtc
902 c
903 c      iadr(l)=l+l-1
904 c      sadr(l)=(l/2)+1
905 c
906       fmti='il'//char(0)
907       fmtc='c'//char(0)
908 c
909 c     write matrix header  without type
910       mn=istk(il+1)*istk(il+2)
911       call mputnc (fd,istk(il+1),4+mn,fmti,ierr)
912       if(ierr.ne.0) return
913 c     write characters
914       mn1=istk(il+4+mn)-1
915       call mputnc(fd,istk(il+5+mn),mn1,fmti,ierr)
916       return
917       end
918
919       subroutine loadstr(fd,il,n,ierr)
920 c     Copyright INRIA
921 c     Load a matrix of strings
922       include 'stack.h'
923       integer fd
924       character*3 fmti
925       integer sadr
926 c
927 c      iadr(l)=l+l-1
928       sadr(l)=(l/2)+1
929 c
930       fmti='il'//char(0)
931 c     
932 c     read matrix header without type
933       err=sadr(il+4)-lstk(bot)
934       if(err.gt.0) then
935          call error(17)
936          return
937       endif
938       call mgetnc (fd,istk(il+1),3,fmti,ierr)
939       if(ierr.ne.0) return
940
941       mn=istk(il+1)*istk(il+2)
942       err=sadr(il+5+mn)-lstk(bot)
943       if(err.gt.0) then
944          call error(17)
945          return
946       endif
947       call mgetnc (fd,istk(il+4),mn+1,fmti,ierr)
948       if(ierr.ne.0) return
949
950 c     read characters
951       mn1=istk(il+4+mn)-1
952       err=sadr(il+5+mn+mn1)-lstk(bot)
953       if(err.gt.0) then
954          call error(17)
955          return
956       endif
957       call mgetnc(fd,istk(il+5+mn),mn1,fmti,ierr)
958       n=5+mn+mn1
959       return
960       end
961
962       subroutine savebool(fd,il,ierr)
963 c     Copyright INRIA
964 c     Save a matrix of boolean
965       include 'stack.h'
966 c
967       integer fd
968       character*3 fmti
969 c
970 c      iadr(l)=l+l-1
971 c      sadr(l)=(l/2)+1
972 c
973       fmti='il'//char(0)
974 c
975 c     write matrix header without type
976       call mputnc (fd,istk(il+1),2,fmti,ierr)
977       if(ierr.ne.0) return
978 c     write matrix elements
979       mn=istk(il+1)*istk(il+2)
980       call mputnc(fd,istk(il+3),mn,fmti,ierr)
981       return
982       end
983
984       subroutine loadbool(fd,il,n,ierr)
985 c     Copyright INRIA
986 c     Load a matrix of boolean
987       include 'stack.h'
988       integer fd
989       character*3 fmti
990       integer sadr
991 c
992 c      iadr(l)=l+l-1
993       sadr(l)=(l/2)+1
994 c
995       fmti='il'//char(0)
996
997 c     read matrix header without type
998       err=sadr(il+3)-lstk(bot)
999       if(err.gt.0) then
1000          call error(17)
1001          return
1002       endif
1003       call mgetnc (fd,istk(il+1),2,fmti,ierr)
1004       if(ierr.ne.0) return
1005
1006 c     read matrix elements
1007       mn=istk(il+1)*istk(il+2)
1008       err=sadr(il+3+mn)-lstk(bot)
1009       if(err.gt.0) then
1010          call error(17)
1011          return
1012       endif
1013       call mgetnc(fd,istk(il+3),mn,fmti,ierr)
1014       n=3+mn
1015       return
1016       end
1017
1018
1019       subroutine savefun(fd,il,ierr)
1020 c     Copyright INRIA
1021 c     Save  a function
1022       include 'stack.h'
1023 c
1024       integer fd
1025       character*3 fmti
1026 c
1027 c      iadr(l)=l+l-1
1028 c      sadr(l)=(l/2)+1
1029 c
1030       fmti='il'//char(0)
1031 c
1032 c     write function header without type
1033       il1=il
1034       nout=istk(il1+1)
1035       il1=il1+1+nout*nsiz
1036       nin=istk(il1+1)
1037       il1=il1+1+nin*nsiz
1038       n=istk(il1+1)
1039       call mputnc (fd,istk(il+1),3+(nout+nin)*nsiz+n,fmti,ierr)
1040       if(ierr.ne.0) return
1041       return
1042       end
1043
1044       subroutine loadfun(fd,il,n,ierr)
1045 c     Copyright INRIA
1046 c     Load a function
1047       include 'stack.h'
1048 c
1049       integer fd
1050       character*3 fmti
1051       integer sadr
1052 c
1053 c      iadr(l)=l+l-1
1054       sadr(l)=(l/2)+1
1055 c
1056       fmti='il'//char(0)
1057 c
1058 c     read function  without type
1059       il1=il
1060       err=sadr(il1+2)-lstk(bot)
1061       if(err.gt.0) then
1062          call error(17)
1063          return
1064       endif
1065       call mgetnc (fd,istk(il1+1),1,fmti,ierr)
1066       if(ierr.ne.0) return
1067
1068       nout=istk(il1+1)
1069       il1=il1+2
1070       err=sadr(il1+nout*nsiz+1)-lstk(bot)
1071       if(err.gt.0) then
1072          call error(17)
1073          return
1074       endif
1075       call mgetnc (fd,istk(il1),nout*nsiz+1,fmti,ierr)
1076       if(ierr.ne.0) return
1077
1078       nin=istk(il1+nout*nsiz)
1079       il1=il1+nout*nsiz+1
1080       err=sadr(il1+nin*nsiz+1)-lstk(bot)
1081       if(err.gt.0) then
1082          call error(17)
1083          return
1084       endif
1085       call mgetnc (fd,istk(il1),nin*nsiz+1,fmti,ierr)
1086       if(ierr.ne.0) return
1087
1088       n=istk(il1+nin*nsiz)
1089       il1=il1+nin*nsiz+1
1090       err=sadr(il1+n)-lstk(bot)
1091       if(err.gt.0) then
1092          call error(17)
1093          return
1094       endif
1095       call mgetnc (fd,istk(il1),n,fmti,ierr)
1096       if(ierr.ne.0) return
1097       n=4+(nout+nin)*nsiz+n
1098       return
1099       end
1100
1101       subroutine savecfun(fd,il,ierr)
1102 c     Copyright INRIA
1103 c     Save a compiled function
1104       include 'stack.h'
1105 c
1106       integer fd
1107       character*3 fmti
1108 c
1109 c      iadr(l)=l+l-1
1110 c      sadr(l)=(l/2)+1
1111 c
1112       fmti='il'//char(0)
1113 c
1114 c     write function header without type
1115       il1=il
1116       nout=istk(il1+1)
1117       il1=il1+1+nout*nsiz
1118       nin=istk(il1+1)
1119       il1=il1+1+nin*nsiz
1120       n=istk(il1+1)
1121       call mputnc (fd,istk(il+1),3+(nout+nin)*nsiz+n,fmti,ierr)
1122       if(ierr.ne.0) return
1123       return
1124       end
1125
1126       subroutine loadcfun(fd,il,n,ierr)
1127 c     Copyright INRIA
1128 c     Load a compiled function
1129       include 'stack.h'
1130 c
1131       integer fd
1132       integer sadr
1133       character*3 fmti
1134 c
1135 c      iadr(l)=l+l-1
1136       sadr(l)=(l/2)+1
1137 c
1138       fmti='il'//char(0)
1139 c
1140 c     read function  without type
1141       il1=il
1142       err=sadr(il1+2)-lstk(bot)
1143       if(err.gt.0) then
1144          call error(17)
1145          return
1146       endif
1147       call mgetnc (fd,istk(il1+1),1,fmti,ierr)
1148       if(ierr.ne.0) return
1149
1150       nout=istk(il1+1)
1151       il1=il1+2
1152       err=sadr(il1+nout*nsiz+1)-lstk(bot)
1153       if(err.gt.0) then
1154          call error(17)
1155          return
1156       endif
1157       call mgetnc (fd,istk(il1),nout*nsiz+1,fmti,ierr)
1158       if(ierr.ne.0) return
1159
1160       nin=istk(il1+nout*nsiz)
1161       il1=il1+nout*nsiz+1
1162       err=sadr(il1+nin*nsiz+1)-lstk(bot)
1163       if(err.gt.0) then
1164          call error(17)
1165          return
1166       endif
1167       call mgetnc (fd,istk(il1),nin*nsiz+1,fmti,ierr)
1168       if(ierr.ne.0) return
1169
1170       n=istk(il1+nin*nsiz)
1171       il1=il1+nin*nsiz+1
1172       err=sadr(il1+n)-lstk(bot)
1173       if(err.gt.0) then
1174          call error(17)
1175          return
1176       endif
1177       call mgetnc (fd,istk(il1),n,fmti,ierr)
1178       if(ierr.ne.0) return
1179       n=4+(nout+nin)*nsiz+n
1180       return
1181       end
1182
1183
1184       subroutine savesparse(fd,il,ierr)
1185 c     Copyright INRIA
1186 c     Save a sparse matrix of numbers
1187       include 'stack.h'
1188 c
1189       integer fd
1190       character*3 fmti,fmtd
1191       integer sadr
1192 c
1193       iadr(l)=l+l-1
1194       sadr(l)=(l/2)+1
1195 c
1196       fmti='il'//char(0)
1197       fmtd='dl'//char(0)
1198 c
1199 c     write matrix header type excluded
1200       call mputnc (fd,istk(il+1),4,fmti,ierr)
1201       if(ierr.ne.0) return
1202       m=istk(il+1)
1203       nel=istk(il+4)
1204 c     write matrix elements
1205       call mputnc(fd,istk(il+5),m+nel,fmti,ierr)
1206       if(ierr.ne.0) return
1207       mn=nel*(istk(il+3)+1)
1208       l=sadr(il+5+m+nel)
1209       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1210       return
1211       end
1212
1213       subroutine loadsparse(fd,il,n,ierr)
1214 c     Copyright INRIA
1215 c     load a sparse matrix of numbers
1216       include 'stack.h'
1217       integer fd
1218       character*3 fmti,fmtd
1219       integer sadr
1220 c
1221       iadr(l)=l+l-1
1222       sadr(l)=(l/2)+1
1223 c
1224       fmti='il'//char(0)
1225       fmtd='dl'//char(0)
1226
1227 c     read matrix header without type
1228       err=sadr(il+5)-lstk(bot)
1229       if(err.gt.0) then
1230          call error(17)
1231          return
1232       endif
1233       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1234       if(ierr.ne.0) return
1235
1236       m=istk(il+1)
1237       nel=istk(il+4)
1238 c     read matrix elements
1239       il1=il+5
1240       err=sadr(il1+m+nel)-lstk(bot)
1241       if(err.gt.0) then
1242          call error(17)
1243          return
1244       endif
1245       call mgetnc(fd,istk(il1),m+nel,fmti,ierr)
1246       if(ierr.ne.0) return
1247
1248       il1=il1+m+nel
1249       mn=nel*(istk(il+3)+1)
1250       err=sadr(il1)+mn-lstk(bot)
1251       if(err.gt.0) then
1252          call error(17)
1253          return
1254       endif
1255       l=sadr(il+5+m+nel)
1256       call mgetnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1257       n=iadr(l+mn)-il
1258 c      n=5+m+nel+2*mn
1259       return
1260       end
1261
1262       subroutine savespb(fd,il,ierr)
1263 c     Copyright INRIA
1264 c     Save a sparse matrix of boolean
1265       include 'stack.h'
1266 c
1267       integer fd
1268       character*3 fmti,fmtd
1269 c
1270       fmti='il'//char(0)
1271       fmtd='dl'//char(0)
1272 c
1273 c     write matrix header type excluded
1274       call mputnc (fd,istk(il+1),4,fmti,ierr)
1275       if(ierr.ne.0) return
1276       m=istk(il+1)
1277       nel=istk(il+4)
1278 c     write matrix elements
1279       call mputnc(fd,istk(il+5),m+nel,fmti,ierr)
1280       return
1281       end
1282
1283       subroutine loadspb(fd,il,n,ierr)
1284 c     Copyright INRIA
1285 c     Load a sparse matrix of boolean
1286       include 'stack.h'
1287       integer fd
1288       character*3 fmti,fmtd
1289       integer sadr 
1290
1291 c
1292 c      iadr(l)=l+l-1
1293       sadr(l)=(l/2)+1
1294 c
1295       fmti='il'//char(0)
1296       fmtd='dl'//char(0)
1297
1298 c     read matrix header without type
1299       err=sadr(il+5)-lstk(bot)
1300       if(err.gt.0) then
1301          call error(17)
1302          return
1303       endif
1304       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1305       if(ierr.ne.0) return
1306
1307       m=istk(il+1)
1308       nel=istk(il+4)
1309 c     read matrix elements
1310       err=sadr(il+5+m+nel)-lstk(bot)
1311       if(err.gt.0) then
1312          call error(17)
1313          return
1314       endif
1315       call mgetnc(fd,istk(il+5),m+nel,fmti,ierr)
1316       n=5+m+nel
1317       return
1318       end
1319
1320       subroutine savelib(fd,il,ierr)
1321 c     [14,n,codagedupath(n),nombre-de-nom,nclas+1 cases,suite des noms]
1322 c     Copyright INRIA
1323 c     Save a sparse matrix of numbers
1324       include 'stack.h'
1325 c
1326       integer fd
1327       character*3 fmti,fmtd
1328       data nclas/29/
1329 c
1330       fmti='il'//char(0)
1331       fmtd='dl'//char(0)
1332 c
1333       np=istk(il+1)
1334       nn=istk(il+2+np)
1335       call mputnc (fd,istk(il+1),3+np+nclas+nn*nsiz,fmti,ierr)
1336       return
1337       end
1338
1339       subroutine loadlib(fd,il,n,ierr)
1340 c     [14,n,codagedupath(n),nombre-de-nom,nclas+1 cases,suite des noms]
1341 c     Copyright INRIA
1342 c     Save a sparse matrix of numbers
1343       include 'stack.h'
1344 c
1345       integer fd
1346       character*3 fmti,fmtd
1347       integer sadr
1348       data nclas/29/
1349 c
1350 c      iadr(l)=l+l-1
1351       sadr(l)=(l/2)+1
1352 c
1353       fmti='il'//char(0)
1354       fmtd='dl'//char(0)
1355 c
1356       il1=il+1
1357       err=sadr(il1+1)-lstk(bot)
1358       if(err.gt.0) then
1359          call error(17)
1360          return
1361       endif
1362       call mgetnc (fd,istk(il1),1,fmti,ierr)
1363       if(ierr.ne.0) return
1364
1365       np=istk(il1)
1366       il1=il1+1
1367       err=sadr(il1+np+1+nclas+1)-lstk(bot)
1368       if(err.gt.0) then
1369          call error(17)
1370          return
1371       endif
1372       call mgetnc (fd,istk(il1),np+1+nclas+1,fmti,ierr)
1373       if(ierr.ne.0) return
1374
1375       il1=il1+np+1+nclas+1
1376       nn=istk(il+2+np)
1377       err=sadr(il1+nn*nsiz)-lstk(bot)
1378       if(err.gt.0) then
1379          call error(17)
1380          return
1381       endif
1382       call mgetnc (fd,istk(il1),nn*nsiz,fmti,ierr)
1383       n=il1+nn*nsiz-il
1384       return
1385       end
1386
1387       subroutine savemsp(fd,il,ierr)
1388 c     Copyright INRIA
1389 c     Save a sparse matrix of numbers
1390       include 'stack.h'
1391 c
1392       integer fd
1393       character*3 fmti,fmtd
1394       integer sadr
1395 c
1396       iadr(l)=l+l-1
1397       sadr(l)=(l/2)+1
1398 c
1399       fmti='il'//char(0)
1400       fmtd='dl'//char(0)
1401 c
1402 c     write matrix header type excluded
1403       call mputnc (fd,istk(il+1),4,fmti,ierr)
1404       if(ierr.ne.0) return
1405       n=istk(il+2)
1406       nel=istk(il+4)
1407 c     write matrix elements
1408       call mputnc(fd,istk(il+5),n+nel+1,fmti,ierr)
1409       if(ierr.ne.0) return
1410       mn=nel*(istk(il+3)+1)
1411       l=sadr(il+6+n+nel)
1412       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1413       return
1414       end
1415
1416       subroutine loadmsp(fd,il,n,ierr)
1417 c     Copyright INRIA
1418 c     load a sparse matrix of numbers
1419       include 'stack.h'
1420       integer fd
1421       character*3 fmti,fmtd
1422       integer sadr
1423 c
1424       iadr(l)=l+l-1
1425       sadr(l)=(l/2)+1
1426 c
1427       fmti='il'//char(0)
1428       fmtd='dl'//char(0)
1429
1430 c     read matrix header without type
1431       err=sadr(il+5)-lstk(bot)
1432       if(err.gt.0) then
1433          call error(17)
1434          return
1435       endif
1436
1437       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1438       if(ierr.ne.0) return
1439
1440       n=istk(il+2)
1441       nel=istk(il+4)
1442 c     read matrix elements
1443       il1=il+5
1444       err=sadr(il1+n+nel)-lstk(bot)
1445       if(err.gt.0) then
1446          call error(17)
1447          return
1448       endif
1449       call mgetnc(fd,istk(il1),n+nel+1,fmti,ierr)
1450       if(ierr.ne.0) return
1451
1452       il1=il1+n+nel+1
1453       mn=nel*(istk(il+3)+1)
1454       err=sadr(il1)+mn-lstk(bot)
1455       if(err.gt.0) then
1456          call error(17)
1457          return
1458       endif
1459       l=sadr(il1)
1460       call mgetnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1461       n=iadr(l+mn)-il
1462 c      n=5+n+nel+2*mn
1463       return
1464       end
1465
1466       subroutine saveptr(fd,il,ierr)
1467 c     Copyright INRIA
1468 c     Save a pointer on sparse lu factorization
1469       include 'stack.h'
1470 c
1471       integer fd
1472       character*3 fmti,fmtd
1473 c      
1474       fmti='il'//char(0)
1475       fmtd='dl'//char(0)
1476 c
1477       buf='handle to sparse lu factors cannot be saved yet'
1478 c      call error(997)
1479       ierr=997
1480       return
1481       end
1482
1483       subroutine loadptr(fd,il,n,ierr)
1484 c     Copyright INRIA
1485 c     Save a pointer on sparse lu factorization
1486       include 'stack.h'
1487       integer fd
1488       character*3 fmti,fmtd
1489       integer sadr
1490 c
1491       iadr(l)=l+l-1
1492       sadr(l)=(l/2)+1
1493 c
1494       fmti='il'//char(0)
1495       fmtd='dl'//char(0)
1496
1497 c     read matrix header without type
1498       err=sadr(il+4)+1-lstk(bot)
1499       if(err.gt.0) then
1500          call error(17)
1501          return
1502       endif
1503       call mgetnc (fd,istk(il+1),3,fmti,ierr)
1504       if(ierr.ne.0) return
1505 c     read pointer
1506       l=sadr(il+4)
1507       call mgetnc(fd,istk(iadr(l)),1,fmtd,ierr)
1508       n=iadr(l+1)-il
1509 c      n=4+2*1
1510       return
1511       end
1512       
1513       subroutine savefptr(fd,il,ierr)
1514 c     Copyright INRIA
1515 c     Save a pointer on  a primitive
1516       include 'stack.h'
1517 c
1518       integer fd
1519       character*3 fmti,fmtd
1520 c
1521       fmti='il'//char(0)
1522       fmtd='dl'//char(0)
1523
1524 c     write matrix header type excluded
1525       call mputnc (fd,istk(il+1),2+nsiz,fmti,ierr)
1526
1527       end
1528
1529       subroutine loadfptr(fd,il,n,ierr)
1530 c     Copyright INRIA
1531 c     load a pointer on a primitive
1532       include 'stack.h'
1533 c
1534       integer fd
1535       character*3 fmti,fmtd
1536       integer sadr
1537 c
1538       sadr(l)=(l/2)+1
1539
1540       fmti='il'//char(0)
1541       fmtd='dl'//char(0)
1542
1543       err=sadr(il+3+nsiz)-lstk(bot)
1544       if(err.gt.0) then
1545          call error(17)
1546          return
1547       endif
1548       call mgetnc (fd,istk(il+1),2+nsiz,fmti,ierr)
1549       if(ierr.ne.0) return
1550       n=3+nsiz
1551       end
1552
1553       subroutine saveint(fd,il,ierr)
1554 c     Copyright INRIA
1555 c     Save a pointer on sparse lu factorization
1556       include 'stack.h'
1557 c
1558       integer fd
1559       character*3 fmti,fmtd
1560
1561       fmti='il'//char(0)
1562       fmtd='dl'//char(0)
1563 c
1564 c     write  header type excluded
1565       call mputnc (fd,istk(il+1),3,fmti,ierr)
1566       if(ierr.ne.0) return
1567       mn=istk(il+1)*istk(il+2)
1568       it=istk(il+3)
1569
1570       if(it.eq.4) then
1571          call mputnc(fd,istk(il+4),mn,fmti,ierr)
1572       elseif(it.eq.2) then
1573          call mputnc(fd,istk(il+4),mn,'sl'//char(0),ierr)
1574       elseif(it.eq.1) then
1575          call mputnc(fd,istk(il+4),mn,'c'//char(0),ierr)
1576       elseif(it.eq.14) then
1577          call mputnc(fd,istk(il+4),mn,'uil'//char(0),ierr)
1578       elseif(it.eq.12) then
1579          call mputnc(fd,istk(il+4),mn,'usl'//char(0),ierr)
1580       elseif(it.eq.11) then
1581          call mputnc(fd,istk(il+4),mn,'uc'//char(0),ierr)
1582       endif
1583       return
1584       end
1585
1586       subroutine loadint(fd,il,n,ierr)
1587 c     Copyright INRIA
1588 c     Save a pointer on sparse lu factorization
1589       include 'stack.h'
1590       integer fd
1591       external memused
1592       integer memused
1593       character*3 fmti,fmtd
1594       integer sadr
1595 c
1596       sadr(l)=(l/2)+1
1597 c
1598       fmti='il'//char(0)
1599       fmtd='dl'//char(0)
1600
1601 c     read matrix header without type
1602       err=sadr(il+4)+1-lstk(bot)
1603       if(err.gt.0) then
1604          call error(17)
1605          return
1606       endif
1607       call mgetnc (fd,istk(il+1),3,fmti,ierr)
1608       if(ierr.ne.0) return
1609       mn=istk(il+1)*istk(il+2)
1610       it=istk(il+3)
1611       err=sadr(il+4+memused(it,mn))-lstk(bot)
1612       if(err.gt.0) then
1613          call error(17)
1614          return
1615       endif
1616       if(it.eq.4) then
1617          call mgetnc(fd,istk(il+4),mn,fmti,ierr)
1618       elseif(it.eq.2) then
1619          call mgetnc(fd,istk(il+4),mn,'sl'//char(0),ierr)
1620       elseif(it.eq.1) then
1621          call mgetnc(fd,istk(il+4),mn,'c'//char(0),ierr)
1622       elseif(it.eq.14) then
1623          call mgetnc(fd,istk(il+4),mn,'uil'//char(0),ierr)
1624       elseif(it.eq.12) then
1625          call mgetnc(fd,istk(il+4),mn,'usl'//char(0),ierr)
1626       elseif(it.eq.11) then
1627          call mgetnc(fd,istk(il+4),mn,'uc'//char(0),ierr)
1628       endif
1629       n=4+memused(it,mn)
1630       return
1631       end
1632
1633