5cd50027ab2b7df9735f7c8b4a730e8198c3e385
[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-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 c
760       iadr(l)=l+l-1
761       sadr(l)=(l/2)+1
762 c
763       fmti='il'//char(0)
764       fmtd='dl'//char(0)
765
766 c     read matrix header without type
767       err=sadr(il+4)-lstk(bot)
768       if(err.gt.0) then
769          call error(17)
770          return
771       endif
772       call mgetnc (fd,istk(il+1),3,fmti,ierr)
773       if(ierr.ne.0) return
774 c     read matrix elements
775       mn=istk(il+1)*istk(il+2)*(istk(il+3)+1)
776       err=sadr(il+4)+mn-lstk(bot)
777       if(err.gt.0) then
778          call error(17)
779          return
780       endif
781       l=sadr(il+4)
782       call mgetnc(fd,istk(il+4),mn,fmtd,ierr)
783 c      call mgetnc(fd,stk(l),mn,fmtd,ierr)
784       n=iadr(l+mn)-il
785 c      n=4+2*mn
786       return
787       end
788
789       subroutine savepol(fd,il,ierr)
790 c     Copyright INRIA
791 c     Save a matrix of polynomials
792       include 'stack.h'
793 c
794       integer fd
795       character*3 fmti,fmtd
796       integer sadr
797 c
798       iadr(l)=l+l-1
799       sadr(l)=(l/2)+1
800 c
801       fmti='il'//char(0)
802       fmtd='dl'//char(0)
803 c
804 c     write matrix header without type
805       mn=istk(il+1)*istk(il+2)
806       call mputnc (fd,istk(il+1),8+mn,fmti,ierr)
807       if(ierr.ne.0) return
808 c     write polynomials coefficients
809       mn1=(istk(il+8+mn)-1)*(istk(il+3)+1)
810       l=sadr(il+9+mn)
811       call mputnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
812       return
813       end
814
815       subroutine loadpol(fd,il,n,ierr)
816 c     Copyright INRIA
817 c     Load a matrix of polynomials
818       include 'stack.h'
819       integer fd
820       character*3 fmti,fmtd
821       integer sadr
822 c
823       iadr(l)=l+l-1
824       sadr(l)=(l/2)+1
825 c
826       fmti='il'//char(0)
827       fmtd='dl'//char(0)
828
829 c     read matrix header without type
830       err=sadr(il+7)-lstk(bot)
831       if(err.gt.0) then
832          call error(17)
833          return
834       endif
835
836       call mgetnc (fd,istk(il+1),7,fmti,ierr)
837       if(ierr.ne.0) return
838 c
839       mn=istk(il+1)*istk(il+2)
840       err=sadr(il+8+mn)-lstk(bot)
841       if(err.gt.0) then
842          call error(17)
843          return
844       endif
845       call mgetnc (fd,istk(il+8),1+mn,fmti,ierr)
846       if(ierr.ne.0) return
847
848 c     read polynomials coefficients
849       mn1=(istk(il+8+mn)-1)*(istk(il+3)+1)
850       err=sadr(il+9+mn)+mn1-lstk(bot)
851       if(err.gt.0) then
852          call error(17)
853          return
854       endif
855       l=sadr(il+9+mn)
856       call mgetnc(fd,istk(iadr(l)),mn1,fmtd,ierr)
857       n=iadr(l+mn1)-il
858 c      n=9+mn+2*mn1
859       return
860       end
861
862
863       subroutine savestr(fd,il,ierr)
864 c     Copyright INRIA
865 c     Save a matrix of strings
866       include 'stack.h'
867 c
868       integer fd
869
870       character*2 fmti,fmtc
871 c
872 c      iadr(l)=l+l-1
873 c      sadr(l)=(l/2)+1
874 c
875       fmti='il'//char(0)
876       fmtc='c'//char(0)
877 c
878 c     write matrix header  without type
879       mn=istk(il+1)*istk(il+2)
880       call mputnc (fd,istk(il+1),4+mn,fmti,ierr)
881       if(ierr.ne.0) return
882 c     write characters
883       mn1=istk(il+4+mn)-1
884       call mputnc(fd,istk(il+5+mn),mn1,fmti,ierr)
885       return
886       end
887
888       subroutine loadstr(fd,il,n,ierr)
889 c     Copyright INRIA
890 c     Load a matrix of strings
891       include 'stack.h'
892       integer fd
893       character*2 fmti
894       integer sadr
895 c
896 c      iadr(l)=l+l-1
897       sadr(l)=(l/2)+1
898 c
899       fmti='il'//char(0)
900 c     
901 c     read matrix header without type
902       err=sadr(il+4)-lstk(bot)
903       if(err.gt.0) then
904          call error(17)
905          return
906       endif
907       call mgetnc (fd,istk(il+1),3,fmti,ierr)
908       if(ierr.ne.0) return
909
910       mn=istk(il+1)*istk(il+2)
911       err=sadr(il+5+mn)-lstk(bot)
912       if(err.gt.0) then
913          call error(17)
914          return
915       endif
916       call mgetnc (fd,istk(il+4),mn+1,fmti,ierr)
917       if(ierr.ne.0) return
918
919 c     read characters
920       mn1=istk(il+4+mn)-1
921       err=sadr(il+5+mn+mn1)-lstk(bot)
922       if(err.gt.0) then
923          call error(17)
924          return
925       endif
926       call mgetnc(fd,istk(il+5+mn),mn1,fmti,ierr)
927       n=5+mn+mn1
928       return
929       end
930
931       subroutine savebool(fd,il,ierr)
932 c     Copyright INRIA
933 c     Save a matrix of boolean
934       include 'stack.h'
935 c
936       integer fd
937       character*2 fmti
938 c
939 c      iadr(l)=l+l-1
940 c      sadr(l)=(l/2)+1
941 c
942       fmti='il'//char(0)
943 c
944 c     write matrix header without type
945       call mputnc (fd,istk(il+1),2,fmti,ierr)
946       if(ierr.ne.0) return
947 c     write matrix elements
948       mn=istk(il+1)*istk(il+2)
949       call mputnc(fd,istk(il+3),mn,fmti,ierr)
950       return
951       end
952
953       subroutine loadbool(fd,il,n,ierr)
954 c     Copyright INRIA
955 c     Load a matrix of boolean
956       include 'stack.h'
957       integer fd
958       character*2 fmti
959       integer sadr
960 c
961 c      iadr(l)=l+l-1
962       sadr(l)=(l/2)+1
963 c
964       fmti='il'//char(0)
965
966 c     read matrix header without type
967       err=sadr(il+3)-lstk(bot)
968       if(err.gt.0) then
969          call error(17)
970          return
971       endif
972       call mgetnc (fd,istk(il+1),2,fmti,ierr)
973       if(ierr.ne.0) return
974
975 c     read matrix elements
976       mn=istk(il+1)*istk(il+2)
977       err=sadr(il+3+mn)-lstk(bot)
978       if(err.gt.0) then
979          call error(17)
980          return
981       endif
982       call mgetnc(fd,istk(il+3),mn,fmti,ierr)
983       n=3+mn
984       return
985       end
986
987
988       subroutine savefun(fd,il,ierr)
989 c     Copyright INRIA
990 c     Save  a function
991       include 'stack.h'
992 c
993       integer fd
994       character*2 fmti
995 c
996 c      iadr(l)=l+l-1
997 c      sadr(l)=(l/2)+1
998 c
999       fmti='il'//char(0)
1000 c
1001 c     write function header without type
1002       il1=il
1003       nout=istk(il1+1)
1004       il1=il1+1+nout*nsiz
1005       nin=istk(il1+1)
1006       il1=il1+1+nin*nsiz
1007       n=istk(il1+1)
1008       call mputnc (fd,istk(il+1),3+(nout+nin)*nsiz+n,fmti,ierr)
1009       if(ierr.ne.0) return
1010       return
1011       end
1012
1013       subroutine loadfun(fd,il,n,ierr)
1014 c     Copyright INRIA
1015 c     Load a function
1016       include 'stack.h'
1017 c
1018       integer fd
1019       character*2 fmti
1020       integer sadr
1021 c
1022 c      iadr(l)=l+l-1
1023       sadr(l)=(l/2)+1
1024 c
1025       fmti='il'//char(0)
1026 c
1027 c     read function  without type
1028       il1=il
1029       err=sadr(il1+2)-lstk(bot)
1030       if(err.gt.0) then
1031          call error(17)
1032          return
1033       endif
1034       call mgetnc (fd,istk(il1+1),1,fmti,ierr)
1035       if(ierr.ne.0) return
1036
1037       nout=istk(il1+1)
1038       il1=il1+2
1039       err=sadr(il1+nout*nsiz+1)-lstk(bot)
1040       if(err.gt.0) then
1041          call error(17)
1042          return
1043       endif
1044       call mgetnc (fd,istk(il1),nout*nsiz+1,fmti,ierr)
1045       if(ierr.ne.0) return
1046
1047       nin=istk(il1+nout*nsiz)
1048       il1=il1+nout*nsiz+1
1049       err=sadr(il1+nin*nsiz+1)-lstk(bot)
1050       if(err.gt.0) then
1051          call error(17)
1052          return
1053       endif
1054       call mgetnc (fd,istk(il1),nin*nsiz+1,fmti,ierr)
1055       if(ierr.ne.0) return
1056
1057       n=istk(il1+nin*nsiz)
1058       il1=il1+nin*nsiz+1
1059       err=sadr(il1+n)-lstk(bot)
1060       if(err.gt.0) then
1061          call error(17)
1062          return
1063       endif
1064       call mgetnc (fd,istk(il1),n,fmti,ierr)
1065       if(ierr.ne.0) return
1066       n=4+(nout+nin)*nsiz+n
1067       return
1068       end
1069
1070       subroutine savecfun(fd,il,ierr)
1071 c     Copyright INRIA
1072 c     Save a compiled function
1073       include 'stack.h'
1074 c
1075       integer fd
1076       character*2 fmti
1077 c
1078 c      iadr(l)=l+l-1
1079 c      sadr(l)=(l/2)+1
1080 c
1081       fmti='il'//char(0)
1082 c
1083 c     write function header without type
1084       il1=il
1085       nout=istk(il1+1)
1086       il1=il1+1+nout*nsiz
1087       nin=istk(il1+1)
1088       il1=il1+1+nin*nsiz
1089       n=istk(il1+1)
1090       call mputnc (fd,istk(il+1),3+(nout+nin)*nsiz+n,fmti,ierr)
1091       if(ierr.ne.0) return
1092       return
1093       end
1094
1095       subroutine loadcfun(fd,il,n,ierr)
1096 c     Copyright INRIA
1097 c     Load a compiled function
1098       include 'stack.h'
1099 c
1100       integer fd
1101       integer sadr
1102       character*2 fmti
1103 c
1104 c      iadr(l)=l+l-1
1105       sadr(l)=(l/2)+1
1106 c
1107       fmti='il'//char(0)
1108 c
1109 c     read function  without type
1110       il1=il
1111       err=sadr(il1+2)-lstk(bot)
1112       if(err.gt.0) then
1113          call error(17)
1114          return
1115       endif
1116       call mgetnc (fd,istk(il1+1),1,fmti,ierr)
1117       if(ierr.ne.0) return
1118
1119       nout=istk(il1+1)
1120       il1=il1+2
1121       err=sadr(il1+nout*nsiz+1)-lstk(bot)
1122       if(err.gt.0) then
1123          call error(17)
1124          return
1125       endif
1126       call mgetnc (fd,istk(il1),nout*nsiz+1,fmti,ierr)
1127       if(ierr.ne.0) return
1128
1129       nin=istk(il1+nout*nsiz)
1130       il1=il1+nout*nsiz+1
1131       err=sadr(il1+nin*nsiz+1)-lstk(bot)
1132       if(err.gt.0) then
1133          call error(17)
1134          return
1135       endif
1136       call mgetnc (fd,istk(il1),nin*nsiz+1,fmti,ierr)
1137       if(ierr.ne.0) return
1138
1139       n=istk(il1+nin*nsiz)
1140       il1=il1+nin*nsiz+1
1141       err=sadr(il1+n)-lstk(bot)
1142       if(err.gt.0) then
1143          call error(17)
1144          return
1145       endif
1146       call mgetnc (fd,istk(il1),n,fmti,ierr)
1147       if(ierr.ne.0) return
1148       n=4+(nout+nin)*nsiz+n
1149       return
1150       end
1151
1152
1153       subroutine savesparse(fd,il,ierr)
1154 c     Copyright INRIA
1155 c     Save a sparse matrix of numbers
1156       include 'stack.h'
1157 c
1158       integer fd
1159       character*3 fmti,fmtd
1160       integer sadr
1161 c
1162       iadr(l)=l+l-1
1163       sadr(l)=(l/2)+1
1164 c
1165       fmti='il'//char(0)
1166       fmtd='dl'//char(0)
1167 c
1168 c     write matrix header type excluded
1169       call mputnc (fd,istk(il+1),4,fmti,ierr)
1170       if(ierr.ne.0) return
1171       m=istk(il+1)
1172       nel=istk(il+4)
1173 c     write matrix elements
1174       call mputnc(fd,istk(il+5),m+nel,fmti,ierr)
1175       if(ierr.ne.0) return
1176       mn=nel*(istk(il+3)+1)
1177       l=sadr(il+5+m+nel)
1178       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1179       return
1180       end
1181
1182       subroutine loadsparse(fd,il,n,ierr)
1183 c     Copyright INRIA
1184 c     load a sparse matrix of numbers
1185       include 'stack.h'
1186       integer fd
1187       character*3 fmti,fmtd
1188       integer sadr
1189 c
1190       iadr(l)=l+l-1
1191       sadr(l)=(l/2)+1
1192 c
1193       fmti='il'//char(0)
1194       fmtd='dl'//char(0)
1195
1196 c     read matrix header without type
1197       err=sadr(il+5)-lstk(bot)
1198       if(err.gt.0) then
1199          call error(17)
1200          return
1201       endif
1202       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1203       if(ierr.ne.0) return
1204
1205       m=istk(il+1)
1206       nel=istk(il+4)
1207 c     read matrix elements
1208       il1=il+5
1209       err=sadr(il1+m+nel)-lstk(bot)
1210       if(err.gt.0) then
1211          call error(17)
1212          return
1213       endif
1214       call mgetnc(fd,istk(il1),m+nel,fmti,ierr)
1215       if(ierr.ne.0) return
1216
1217       il1=il1+m+nel
1218       mn=nel*(istk(il+3)+1)
1219       err=sadr(il1)+mn-lstk(bot)
1220       if(err.gt.0) then
1221          call error(17)
1222          return
1223       endif
1224       l=sadr(il+5+m+nel)
1225       call mgetnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1226       n=iadr(l+mn)-il
1227 c      n=5+m+nel+2*mn
1228       return
1229       end
1230
1231       subroutine savespb(fd,il,ierr)
1232 c     Copyright INRIA
1233 c     Save a sparse matrix of boolean
1234       include 'stack.h'
1235 c
1236       integer fd
1237       character*3 fmti,fmtd
1238 c
1239       fmti='il'//char(0)
1240       fmtd='dl'//char(0)
1241 c
1242 c     write matrix header type excluded
1243       call mputnc (fd,istk(il+1),4,fmti,ierr)
1244       if(ierr.ne.0) return
1245       m=istk(il+1)
1246       nel=istk(il+4)
1247 c     write matrix elements
1248       call mputnc(fd,istk(il+5),m+nel,fmti,ierr)
1249       return
1250       end
1251
1252       subroutine loadspb(fd,il,n,ierr)
1253 c     Copyright INRIA
1254 c     Load a sparse matrix of boolean
1255       include 'stack.h'
1256       integer fd
1257       character*3 fmti,fmtd
1258       integer sadr 
1259
1260 c
1261 c      iadr(l)=l+l-1
1262       sadr(l)=(l/2)+1
1263 c
1264       fmti='il'//char(0)
1265       fmtd='dl'//char(0)
1266
1267 c     read matrix header without type
1268       err=sadr(il+5)-lstk(bot)
1269       if(err.gt.0) then
1270          call error(17)
1271          return
1272       endif
1273       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1274       if(ierr.ne.0) return
1275
1276       m=istk(il+1)
1277       nel=istk(il+4)
1278 c     read matrix elements
1279       err=sadr(il+5+m+nel)-lstk(bot)
1280       if(err.gt.0) then
1281          call error(17)
1282          return
1283       endif
1284       call mgetnc(fd,istk(il+5),m+nel,fmti,ierr)
1285       n=5+m+nel
1286       return
1287       end
1288
1289       subroutine savelib(fd,il,ierr)
1290 c     [14,n,codagedupath(n),nombre-de-nom,nclas+1 cases,suite des noms]
1291 c     Copyright INRIA
1292 c     Save a sparse matrix of numbers
1293       include 'stack.h'
1294 c
1295       integer fd
1296       character*3 fmti,fmtd
1297       data nclas/29/
1298 c
1299       fmti='il'//char(0)
1300       fmtd='dl'//char(0)
1301 c
1302       np=istk(il+1)
1303       nn=istk(il+2+np)
1304       call mputnc (fd,istk(il+1),3+np+nclas+nn*nsiz,fmti,ierr)
1305       return
1306       end
1307
1308       subroutine loadlib(fd,il,n,ierr)
1309 c     [14,n,codagedupath(n),nombre-de-nom,nclas+1 cases,suite des noms]
1310 c     Copyright INRIA
1311 c     Save a sparse matrix of numbers
1312       include 'stack.h'
1313 c
1314       integer fd
1315       character*3 fmti,fmtd
1316       integer sadr
1317       data nclas/29/
1318 c
1319 c      iadr(l)=l+l-1
1320       sadr(l)=(l/2)+1
1321 c
1322       fmti='il'//char(0)
1323       fmtd='dl'//char(0)
1324 c
1325       il1=il+1
1326       err=sadr(il1+1)-lstk(bot)
1327       if(err.gt.0) then
1328          call error(17)
1329          return
1330       endif
1331       call mgetnc (fd,istk(il1),1,fmti,ierr)
1332       if(ierr.ne.0) return
1333
1334       np=istk(il1)
1335       il1=il1+1
1336       err=sadr(il1+np+1+nclas+1)-lstk(bot)
1337       if(err.gt.0) then
1338          call error(17)
1339          return
1340       endif
1341       call mgetnc (fd,istk(il1),np+1+nclas+1,fmti,ierr)
1342       if(ierr.ne.0) return
1343
1344       il1=il1+np+1+nclas+1
1345       nn=istk(il+2+np)
1346       err=sadr(il1+nn*nsiz)-lstk(bot)
1347       if(err.gt.0) then
1348          call error(17)
1349          return
1350       endif
1351       call mgetnc (fd,istk(il1),nn*nsiz,fmti,ierr)
1352       n=il1+nn*nsiz-il
1353       return
1354       end
1355
1356       subroutine savemsp(fd,il,ierr)
1357 c     Copyright INRIA
1358 c     Save a sparse matrix of numbers
1359       include 'stack.h'
1360 c
1361       integer fd
1362       character*3 fmti,fmtd
1363       integer sadr
1364 c
1365       iadr(l)=l+l-1
1366       sadr(l)=(l/2)+1
1367 c
1368       fmti='il'//char(0)
1369       fmtd='dl'//char(0)
1370 c
1371 c     write matrix header type excluded
1372       call mputnc (fd,istk(il+1),4,fmti,ierr)
1373       if(ierr.ne.0) return
1374       n=istk(il+2)
1375       nel=istk(il+4)
1376 c     write matrix elements
1377       call mputnc(fd,istk(il+5),n+nel+1,fmti,ierr)
1378       if(ierr.ne.0) return
1379       mn=nel*(istk(il+3)+1)
1380       l=sadr(il+6+n+nel)
1381       call mputnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1382       return
1383       end
1384
1385       subroutine loadmsp(fd,il,n,ierr)
1386 c     Copyright INRIA
1387 c     load a sparse matrix of numbers
1388       include 'stack.h'
1389       integer fd
1390       character*3 fmti,fmtd
1391       integer sadr
1392 c
1393       iadr(l)=l+l-1
1394       sadr(l)=(l/2)+1
1395 c
1396       fmti='il'//char(0)
1397       fmtd='dl'//char(0)
1398
1399 c     read matrix header without type
1400       err=sadr(il+5)-lstk(bot)
1401       if(err.gt.0) then
1402          call error(17)
1403          return
1404       endif
1405
1406       call mgetnc (fd,istk(il+1),4,fmti,ierr)
1407       if(ierr.ne.0) return
1408
1409       n=istk(il+2)
1410       nel=istk(il+4)
1411 c     read matrix elements
1412       il1=il+5
1413       err=sadr(il1+n+nel)-lstk(bot)
1414       if(err.gt.0) then
1415          call error(17)
1416          return
1417       endif
1418       call mgetnc(fd,istk(il1),n+nel+1,fmti,ierr)
1419       if(ierr.ne.0) return
1420
1421       il1=il1+n+nel+1
1422       mn=nel*(istk(il+3)+1)
1423       err=sadr(il1)+mn-lstk(bot)
1424       if(err.gt.0) then
1425          call error(17)
1426          return
1427       endif
1428       l=sadr(il1)
1429       call mgetnc(fd,istk(iadr(l)),mn,fmtd,ierr)
1430       n=iadr(l+mn)-il
1431 c      n=5+n+nel+2*mn
1432       return
1433       end
1434
1435       subroutine saveptr(fd,il,ierr)
1436 c     Copyright INRIA
1437 c     Save a pointer on sparse lu factorization
1438       include 'stack.h'
1439 c
1440       integer fd
1441       character*3 fmti,fmtd
1442 c      
1443       fmti='il'//char(0)
1444       fmtd='dl'//char(0)
1445 c
1446       buf='handle to sparse lu factors cannot be saved yet'
1447 c      call error(997)
1448       ierr=997
1449       return
1450       end
1451
1452       subroutine loadptr(fd,il,n,ierr)
1453 c     Copyright INRIA
1454 c     Save a pointer on sparse lu factorization
1455       include 'stack.h'
1456       integer fd
1457       character*3 fmti,fmtd
1458       integer sadr
1459 c
1460       iadr(l)=l+l-1
1461       sadr(l)=(l/2)+1
1462 c
1463       fmti='il'//char(0)
1464       fmtd='dl'//char(0)
1465
1466 c     read matrix header without type
1467       err=sadr(il+4)+1-lstk(bot)
1468       if(err.gt.0) then
1469          call error(17)
1470          return
1471       endif
1472       call mgetnc (fd,istk(il+1),3,fmti,ierr)
1473       if(ierr.ne.0) return
1474 c     read pointer
1475       l=sadr(il+4)
1476       call mgetnc(fd,istk(iadr(l)),1,fmtd,ierr)
1477       n=iadr(l+1)-il
1478 c      n=4+2*1
1479       return
1480       end
1481       
1482       subroutine savefptr(fd,il,ierr)
1483 c     Copyright INRIA
1484 c     Save a pointer on  a primitive
1485       include 'stack.h'
1486 c
1487       integer fd
1488       character*3 fmti,fmtd
1489 c
1490       fmti='il'//char(0)
1491       fmtd='dl'//char(0)
1492
1493 c     write matrix header type excluded
1494       call mputnc (fd,istk(il+1),2+nsiz,fmti,ierr)
1495
1496       end
1497
1498       subroutine loadfptr(fd,il,n,ierr)
1499 c     Copyright INRIA
1500 c     load a pointer on a primitive
1501       include 'stack.h'
1502 c
1503       integer fd
1504       character*3 fmti,fmtd
1505       integer sadr
1506 c
1507       sadr(l)=(l/2)+1
1508
1509       fmti='il'//char(0)
1510       fmtd='dl'//char(0)
1511
1512       err=sadr(il+3+nsiz)-lstk(bot)
1513       if(err.gt.0) then
1514          call error(17)
1515          return
1516       endif
1517       call mgetnc (fd,istk(il+1),2+nsiz,fmti,ierr)
1518       if(ierr.ne.0) return
1519       n=3+nsiz
1520       end
1521
1522       subroutine saveint(fd,il,ierr)
1523 c     Copyright INRIA
1524 c     Save a pointer on sparse lu factorization
1525       include 'stack.h'
1526 c
1527       integer fd
1528       character*3 fmti,fmtd
1529
1530       fmti='il'//char(0)
1531       fmtd='dl'//char(0)
1532 c
1533 c     write  header type excluded
1534       call mputnc (fd,istk(il+1),3,fmti,ierr)
1535       if(ierr.ne.0) return
1536       mn=istk(il+1)*istk(il+2)
1537       it=istk(il+3)
1538
1539       if(it.eq.4) then
1540          call mputnc(fd,istk(il+4),mn,fmti,ierr)
1541       elseif(it.eq.2) then
1542          call mputnc(fd,istk(il+4),mn,'sl'//char(0),ierr)
1543       elseif(it.eq.1) then
1544          call mputnc(fd,istk(il+4),mn,'c'//char(0),ierr)
1545       elseif(it.eq.14) then
1546          call mputnc(fd,istk(il+4),mn,'uil'//char(0),ierr)
1547       elseif(it.eq.12) then
1548          call mputnc(fd,istk(il+4),mn,'usl'//char(0),ierr)
1549       elseif(it.eq.11) then
1550          call mputnc(fd,istk(il+4),mn,'uc'//char(0),ierr)
1551       endif
1552       return
1553       end
1554
1555       subroutine loadint(fd,il,n,ierr)
1556 c     Copyright INRIA
1557 c     Save a pointer on sparse lu factorization
1558       include 'stack.h'
1559       integer fd
1560       external memused
1561       integer memused
1562       character*3 fmti,fmtd
1563       integer sadr
1564 c
1565       sadr(l)=(l/2)+1
1566 c
1567       fmti='il'//char(0)
1568       fmtd='dl'//char(0)
1569
1570 c     read matrix header without type
1571       err=sadr(il+4)+1-lstk(bot)
1572       if(err.gt.0) then
1573          call error(17)
1574          return
1575       endif
1576       call mgetnc (fd,istk(il+1),3,fmti,ierr)
1577       if(ierr.ne.0) return
1578       mn=istk(il+1)*istk(il+2)
1579       it=istk(il+3)
1580       err=sadr(il+4+memused(it,mn))-lstk(bot)
1581       if(err.gt.0) then
1582          call error(17)
1583          return
1584       endif
1585       if(it.eq.4) then
1586          call mgetnc(fd,istk(il+4),mn,fmti,ierr)
1587       elseif(it.eq.2) then
1588          call mgetnc(fd,istk(il+4),mn,'sl'//char(0),ierr)
1589       elseif(it.eq.1) then
1590          call mgetnc(fd,istk(il+4),mn,'c'//char(0),ierr)
1591       elseif(it.eq.14) then
1592          call mgetnc(fd,istk(il+4),mn,'uil'//char(0),ierr)
1593       elseif(it.eq.12) then
1594          call mgetnc(fd,istk(il+4),mn,'usl'//char(0),ierr)
1595       elseif(it.eq.11) then
1596          call mgetnc(fd,istk(il+4),mn,'uc'//char(0),ierr)
1597       endif
1598       n=4+memused(it,mn)
1599       return
1600       end
1601
1602