1 function mtlb_save(mtlb_thefile,varargin)
2 //save variable under  matlab 4.x .mat binary format files
3 //see: www.mathworks.com/access/helpdesk/help/pdf_doc/matlab/matfile_format.pdf
5 warning(msprintf(gettext("messages","compatibility_functions_message_22"),"savematfile"));
7 // Verify that all inputs are character strings
8 for k=1:size(varargin)
9   if type(varargin(k))<>10 then
10     error(gettext("messages","compatibility_functions_message_59"));
11   end
12 end
14 [lhs,rhs]=argn(0)
15 mtlb_opts=[]
16 if rhs==1 then
17   mtlb_names=who('get')
18   mtlb_names(1:6)=[] // clear functions variables
19   mtlb_names(\$-predef()+1:\$)=[] // clear predefined variables
20   funcprot(0)
21   for k=size(mtlb_names,'*'):-1:1
22     execstr('x='+mtlb_names(k))
23     select type(x)
24     case 1 then
25     case 4 then
26     case 5 then
27     case 6 then
28     case 10 then
29     else
30       mtlb_names(k)=[]
31     end
32   end
33 else
34   for k=size(varargin):-1:1
35     vk=varargin(k)
36     if part(vk,1)=='-' then
37       mtlb_opts=[convstr(vk),mtlb_opts],
38     else
39       kk=k
40       break
41     end
42   end
43   mtlb_names=[]
44   for k=1:kk
45     mtlb_names=[mtlb_names, varargin(k)]
46   end
47 end
49 k=strindex(mtlb_thefile,'.')
50 if k==[] then  //no extension given
51   if find(mtlb_opts=='-ascii')==[] then
52     mtlb_thefile=mtlb_thefile+'.mat'
53   end
54 end
57 if mtlb_names==[] then return,end
58 if mtlb_opts==[] then //binary save
59   [mtlb_fd,err]=mopen(mtlb_thefile,'wb',0)
60   // check name conflicts
61   for k=['mtlb_thefile','varargin','mtlb_names','mtlb_opts','mtlb_fd']
62     if or(mtlb_names==k) then
63       error(msprintf(gettext("errors","compatibility_functions_error_60"),k));
64     end
65   end
66   // clear variable wich are no more used to avoid name conflicts
67   clear('rhs','lhs','kk','k','err','mtlb_thefile');
69   for mtlb_k=1:size(mtlb_names,'*')
70     // perform changes on variables
71     execstr('x='+mtlb_names(mtlb_k))
72     it=0
73     select type(x)
74     case 1 then
75       P=0
76       T=0
77       if norm(imag(x),1)<>0 then it=1,end
78     case 4 then
79       x=bool2s(x)
80       P=5
81       T=0
82     case 5 then
83       if norm(imag(x),1)<>0 then it1=1,else it1=0,end
84       P=0
85       T=2
86       [x,v,mn]=spget(x);
87       if it1==0 then
88         x=[x real(v);[mn 0]]
89       else
90         x=[x real(v) imag(v);[mn 0 0]]
91       end
92     case 6 then
93       x=bool2s(x)
94       P=0
95       T=2
96       [x,v,mn]=spget(x);
97       x=[x v;[mn 0]]
98     case 8 then
99       T=0
100       select inttype(x)
101         case 4 then P=2,
102         case 14 then P=2,
103         case 2 then P=3
104         case 12 then P=4
105         case 1 then P=5,
106         case 11 then P=5,
107       end
108       x=double(x)
109     case 10 then
110       x1=part(x(:),1:max(length(x)))
111       x=[]
112       for l=1:size(x1,1)
113         x=[x;ascii(x1(l))]
114       end
115       P=5
116       T=1
117     else
118       error(gettext("errors","compatibility_functions_error_61"))
119     end
120     [m,n]=size(x)
123     M = 0 //little endian
124     O = 0
125     MOPT=[M O P T]
127     [m,n]=size(x)
131     mput([ascii(mtlb_names(mtlb_k)) 0],"c",mtlb_fd);
132     select P
133     case 0 then
134       flag='dl'
135     case 1 then
136       flag='fl'
137     case 2 then
138       flag='il'
139     case 3 then
140       flag='sl'
141     case 4 then
142       flag='usl'
143     case 5 then
144       flag='uc'
145     end
146     if T==0 then
147       if x<>[] then
148         mput(real(x(:).'),flag,mtlb_fd);
149         if it==1
150           mput(imag(x(:).'),flag,mtlb_fd);
151         end
152       end
153     elseif T==1
154       v=mput(x(:).',flag,mtlb_fd);
155     elseif T==2 then  //sparse
156       mput(x(:).',flag,mtlb_fd);
157     end
158   end
159   mclose(mtlb_fd);
160 else //ascii save
162   if convstr(mtlb_opts(1))<>'-ascii' then
163     error(msprintf(gettext("errors","compatibility_functions_error_62"),mtlb_opts(1)));
164   end
165     if size(mtlb_opts,'*')==3 then
166     sep=str2code(-40)
167   else
168     sep=' '
169   end
170   if size(mtlb_opts,'*')==1 then //8 digits save
171     mtlb_fmt='(1pe14.7'+sep+')'
172   else
173     mtlb_fmt='(1pe23.15'+sep+')'
174   end
176   mtlb_fd=file('open',mtlb_thefile,'unknown')
177   // clear variable wich are no more used to avoid name conflicts
178   for k=['mtlb_thefile','varargin','mtlb_names','mtlb_fmt','mtlb_fd']
179     if or(mtlb_names==k) then
180       error(msprintf(gettext("errors","compatibility_functions_error_60"),k));
181     end
182   end
183   clear('rhs','lhs','kk','err','sep');
184   for mtlb_k=1:size(mtlb_names,'*')
185     // perform changes on variables
186     execstr('x='+mtlb_names(mtlb_k))
187     select type(x)
188     case 1 then
189       write(mtlb_fd,real(x),'('+string(size(x,2))+mtlb_fmt+')')
190     case 4 then
191       write(mtlb_fd,bool2s(x),'('+string(size(x,2))+mtlb_fmt+')')
192     case 5 then
193       [ij,x]=spget(real(x));x=[ij x];
194       write(mtlb_fd,real(x),'(2f8.0,1x'+string(size(x,2))+mtlb_fmt+')')
195     case 6 then
196       [ij,x]=spget(bool2s(x));x=[ij x];
197       write(mtlb_fd,real(x),'(2f8.0,1x'+string(size(x,2))+mtlb_fmt+')')
198     case 10 then
199       x=part(x(:),1:max(length(x)))
200       x1=[]
201       for l=1:size(x,1)
202         x1=[x1;ascii(x(l))]
203       end
204       write(mtlb_fd,x1,'('+string(size(x1,2))+mtlb_fmt+')')
205     end
206   end
207   file('close',mtlb_fd)
208 end
212 endfunction