Code covered by the BSD License  

Highlights from
slatec

from slatec by Ben Barrowes
The slatec library converted into matlab functions.

[lun,kprint,nerr]=dqck(lun,kprint,nerr);
function [lun,kprint,nerr]=dqck(lun,kprint,nerr);
persistent a abe abet at b bt c delmax delx firstCall i ind iwork j j1 j2 jd k kcase kprog lda list ml mlp mu n r signmlv work ; if isempty(list),list={};end; if isempty(firstCall),firstCall=1;end; 

if isempty(a), a=zeros(4,4); end;
if isempty(at), at=zeros(5,4); end;
if isempty(abe), abe=zeros(5,7); end;
if isempty(abet), abet=zeros(5,7); end;
if isempty(b), b=zeros(1,4); end;
if isempty(bt), bt=zeros(1,4); end;
if isempty(c), c=zeros(1,4); end;
if isempty(work), work=zeros(1,35); end;
if isempty(signmlv), signmlv=0; end;
if isempty(r), r=0; end;
if isempty(delx), delx=0; end;
if isempty(delmax), delmax=0; end;
if isempty(list), list=cell(1,2); end;
if isempty(lda), lda=0; end;
if isempty(n), n=0; end;
if isempty(ml), ml=0; end;
if isempty(mu), mu=0; end;
if isempty(ind), ind=0; end;
if isempty(iwork), iwork=zeros(1,4); end;
if isempty(i), i=0; end;
if isempty(j), j=0; end;
if isempty(j1), j1=0; end;
if isempty(j2), j2=0; end;
if isempty(jd), jd=0; end;
if isempty(mlp), mlp=0; end;
if isempty(k), k=0; end;
if isempty(kcase), kcase=0; end;
if isempty(kprog), kprog=0; end;
if firstCall,   a=[5.0d0,4.0d0,1.0d0,1.0d0,4.0d0,5.0d0,1.0d0,1.0d0,1.0d0,1.0d0,4.0d0,2.0d0,1.0d0,1.0d0,2.0d0,4.0d0];  end;
if firstCall,   list={'POFS','NBFS'};  end;a=reshape(a,[4,4]);
firstCall=0;
if( kprint>=3 )
writef(lun,[ '\n ' ,' *    DQCK - QUICK CHECK FOR  DPOFS AND DNBFS', '\n '  ' \n']);
end;
%format [' *    DQCK - QUICK CHECK FOR  DPOFS AND DNBFS'];
lda = 5;
n = 4;
ml = 2;
mu = 1;
jd = fix(2.*ml + mu + 1);
nerr = 0;
r = d1mach(4).^0.8e0;
signmlv = 1.0d0;
for i = 1 : n;
c(i) = signmlv./i;
signmlv = -signmlv;
end; i = fix(n+1);
for kcase = 1 : 2;
for kprog = 1 : 2;
for i = 1 : n;
b(i) = 0.0d0;
end; i = fix(n+1);
if( kprog==1 )
for i = 1 : n;
for j = 1 : n;
b(i) = b(i) + a(i,j).*c(j);
end; j = fix(n+1);
end; i = fix(n+1);
else;
for j = 1 : jd;
for i = 1 : n;
abe(i,j) = 0.0d0;
end; i = fix(n+1);
end; j = fix(jd+1);
mlp = fix(ml + 1);
for i = 1 : n;
j1 = fix(max(1,i-ml));
j2 = fix(min(n,i+mu));
for j = j1 : j2;
k = fix(j - i + mlp);
abe(i,k) = a(i,j);
b(i) = b(i) +(a(i,j).*c(j));
end; j = fix(j2+1);
end; i = fix(n+1);
end;
for i = 1 : n;
bt(i) = b(i);
for j = 1 : n;
at(i,j) = a(i,j);
end; j = fix(n+1);
end; i = fix(n+1);
for j = 1 : jd;
for i = 1 : n;
abet(i,j) = abe(i,j);
end; i = fix(n+1);
end; j = fix(jd+1);
if( kcase==2 )
for j = 1 : n;
at(1,j) = 0.0d0;
end; j = fix(n+1);
for j = 1 : jd;
abet(1,j) = 0.0d0;
end; j = fix(jd+1);
end;
if( kprog==1 )
[at,lda,n,bt,dumvar5,ind,work]=dpofs(at,lda,n,bt,1,ind,work);
end;
if( kprog==2 )
[abet,lda,n,ml,mu,bt,dumvar7,ind,work,iwork]=dnbfs(abet,lda,n,ml,mu,bt,1,ind,work,iwork);
end;
if( kcase==1 )
delmax = 0.0e0;
for i = 1 : n;
delx = abs(bt(i)-c(i));
delmax = max(delmax,delx);
end; i = fix(n+1);
if( r<=delmax )
nerr = fix(nerr + 1);
writef(lun,['   PROBLEM WITH D','%s',', CASE ','%1i','.  MAX ABS ERROR OF','%11.4f', '\n '  ' \n'], list{kprog} , kcase , delmax);
%format ('   PROBLEM WITH D',a,', CASE ',i1,'.  MAX ABS ERROR OF',e11.4];
end;
elseif( ind~=-4 ) ;
nerr = fix(nerr + 1);
writef(lun,['   PROBLEM WITH D','%s',', CASE ','%1i','.  IND = ','%2i',' INSTEAD OF -4', '\n '  ' \n'], list{kprog} , kcase , ind);
%format ('   PROBLEM WITH D',a,', CASE ',i1,'.  IND = ',i2,' INSTEAD OF -4'];
end;
end; kprog = fix(2+1);
end; kcase = fix(2+1);
if( nerr~=0 )
writef(lun,[ '\n ' ,' **** DQCK DETECTED A TOTAL OF ','%2i',' PROBLEMS. ****', '\n '  ' \n'], nerr);
end;
%format [' **** DQCK DETECTED A TOTAL OF ',i2,' PROBLEMS. ****'];
if( kprint>=2 && nerr==0 )
writef(lun,['     DQCK DETECTED NO PROBLEMS.', '\n '  ' \n']);
end;
%format ('     DQCK DETECTED NO PROBLEMS.'];
return;
end %subroutine dqck

Contact us at files@mathworks.com