Code covered by the BSD License  

Highlights from
slatec

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

[sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,ninc,inc,nmax,incmax,a,aa,as,x,xx,xs,y,yy,ys,yt,g,z]=cchk62(sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,ninc,inc,nmax,incmax,a,aa,as,x,xx,xs,y,yy,ys,yt,g,z);
function [sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,ninc,inc,nmax,incmax,a,aa,as,x,xx,xs,y,yy,ys,yt,g,z]=cchk62(sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,ninc,inc,nmax,incmax,a,aa,as,x,xx,xs,y,yy,ys,yt,g,z);
persistent alpha als err errmax firstCall ftl full half i ia ic ich in incx incxs incy incys isame ix iy j ja jj laa lda ldas lj lx ly n nc nerr ns null one packed reset rzero transl uplo uplos uppermlv w zero ; if isempty(firstCall),firstCall=1;end; 

if isempty(zero), zero=complex(0.0,0.0); end;
if isempty(half), half=complex(0.5,0.0); end;
if isempty(one), one=complex(1.0,0.0) ; end;
if isempty(rzero), rzero=0.0 ; end;
a_orig=a;a_shape=[nmax,nmax];a=reshape([a_orig(1:min(prod(a_shape),numel(a_orig))),zeros(1,max(0,prod(a_shape)-numel(a_orig)))],a_shape);
z_orig=z;z_shape=[nmax,2];z=reshape([z_orig(1:min(prod(z_shape),numel(z_orig))),zeros(1,max(0,prod(z_shape)-numel(z_orig)))],z_shape);
if isempty(alpha), alpha=0; end;
if isempty(als), als=0; end;
if isempty(transl), transl=0; end;
if isempty(err), err=0; end;
if isempty(errmax), errmax=0; end;
if isempty(i), i=0; end;
if isempty(ia), ia=0; end;
if isempty(ic), ic=0; end;
if isempty(in), in=0; end;
if isempty(incx), incx=0; end;
if isempty(incxs), incxs=0; end;
if isempty(incy), incy=0; end;
if isempty(incys), incys=0; end;
if isempty(ix), ix=0; end;
if isempty(iy), iy=0; end;
if isempty(j), j=0; end;
if isempty(ja), ja=0; end;
if isempty(jj), jj=0; end;
if isempty(laa), laa=0; end;
if isempty(lda), lda=0; end;
if isempty(ldas), ldas=0; end;
if isempty(lj), lj=0; end;
if isempty(lx), lx=0; end;
if isempty(ly), ly=0; end;
if isempty(n), n=0; end;
% integer ::nargs ;
if isempty(nc), nc=0; end;
if isempty(nerr), nerr=0; end;
if isempty(ns), ns=0; end;
if isempty(ftl), ftl=false; end;
if isempty(full), full=false; end;
if isempty(null), null=false; end;
if isempty(packed), packed=false; end;
if isempty(reset), reset=false; end;
if isempty(uppermlv), uppermlv=false; end;
if isempty(uplo), uplo=repmat(' ',1,1); end;
if isempty(uplos), uplos=repmat(' ',1,1); end;
if isempty(ich), ich=repmat(' ',1,2); end;
if isempty(w), w=zeros(1,2); end;
if isempty(isame), isame=zeros(1,13); end;
if firstCall,   ich=['UL'];  end;
firstCall=0;
full = strcmp(deblank(sname([3:3])),deblank('E'));
packed = strcmp(deblank(sname([3:3])),deblank('P'));
if( full )
nargs = 9;
elseif( packed ) ;
nargs = 8;
end;
nc = 0;
reset = true;
errmax = rzero;
for in = 1 : nidim;
n = fix(idim_v(in));
lda = fix(n);
if( lda<nmax )
lda = fix(lda + 1);
end;
if( lda<=nmax )

if( packed )
laa =fix(fix((n.*(n+1))./2));
else;
laa = fix(lda.*n);
end;

for ic = 1 : 2;
uplo = ich([ic:ic]);

uppermlv = strcmp(deblank(uplo),deblank('U'));
for ix = 1 : ninc;
incx = fix(inc(ix));
lx = fix(abs(incx).*n);
transl = half;
[dumvar1,dumvar2,dumvar3,dumvar4,n,x,dumvar7,xx,dumvar9,dumvar10,dumvar11,reset,transl]=cmake2('GE',' ',' ',1,n,x,1,xx,abs(incx),0,n-1,reset,transl);
if( n>1 )
x(fix(n./2)) = zero;
xx(1+(abs(incx).*(fix(n./2)-1))) = zero;

end;
for iy = 1 : ninc;
incy = fix(inc(iy));
ly = fix(abs(incy).*n);
transl = zero;
[dumvar1,dumvar2,dumvar3,dumvar4,n,y,dumvar7,yy,dumvar9,dumvar10,dumvar11,reset,transl]=cmake2('GE',' ',' ',1,n,y,1,yy,abs(incy),0,n-1,reset,transl);
if( n>1 )
y(fix(n./2)) = zero;
yy(1+(abs(incy).*(fix(n./2)-1))) = zero;
end;
for ia = 1 : nalf;
alpha = alf(ia);
null = n<=0 | alpha==zero;
transl = zero;
n_orig=n;    [sname([2:min(length(sname),3)]),uplo,dumvar3,n,dumvar5,a,nmax,aa,lda,dumvar10,dumvar11,reset,transl]=cmake2(sname([2:min(length(sname),3)]),uplo,' ',n,n,a,nmax,aa,lda,n-1,n-1,reset,transl);    n(dumvar5~=n_orig)=dumvar5(dumvar5~=n_orig);
nc = fix(nc + 1);
uplos = uplo;
ns = fix(n);
als = alpha;
for i = 1 : laa;
as(i) = aa(i);
end; i = fix(laa+1);
ldas = fix(lda);
for i = 1 : lx;
xs(i) = xx(i);
end; i = fix(lx+1);
incxs = fix(incx);
for i = 1 : ly;
ys(i) = yy(i);
end; i = fix(ly+1);
incys = fix(incy);
if( full )
[uplo,n,alpha,xx,incx,yy,incy,aa,lda]=cher2(uplo,n,alpha,xx,incx,yy,incy,aa,lda);
elseif( packed ) ;
[uplo,n,alpha,xx,incx,yy,incy,aa]=chpr2(uplo,n,alpha,xx,incx,yy,incy,aa);
end;
if( numxer(nerr)~=0 )
if( kprint>=2 )
writef(nout,[' ** FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *','*' ' \n']);
end;
fatal = true;
end;
isame(1) = strcmp(deblank(uplo),deblank(uplos));
isame(2) = ns==n;
isame(3) = als==alpha;
[isame(4) ,xs,xx,lx]=lce(xs,xx,lx);
isame(5) = incxs==incx;
[isame(6) ,ys,yy,ly]=lce(ys,yy,ly);
isame(7) = incys==incy;
if( null )
[isame(8) ,as,aa,laa]=lce(as,aa,laa);
else;
n_orig=n;    [isame(8) ,sname([2:min(length(sname),3)]),uplo,n,dumvar5,as,aa,lda]=lceres(sname([2:min(length(sname),3)]),uplo,n,n,as,aa,lda);    n(dumvar5~=n_orig)=dumvar5(dumvar5~=n_orig);
end;
if( ~packed )
isame(9) = ldas==lda;
end;
for i = 1 : nargs;
if( ~isame(i) )
fatal = true;
if( kprint>=2 )
writef(nout,[' ** FATAL ERROR - PARAMETER NUMBER ','%2i',' WAS CH','ANGED INCORRECTLY **' ' \n'], i);
end;
end;
end; i = fix(nargs+1);
ftl = false;
if( ~null )
if( incx>0 )
for i = 1 : n;
z(i,1) = x(i);
end; i = fix(n+1);
else;
for i = 1 : n;
z(i,1) = x(n-i+1);
end; i = fix(n+1);
end;
if( incy>0 )
z([1:n],2) = y([1:n]);
else;
for i = 1 : n;
z(i,2) = y(n-i+1);
end; i = fix(n+1);
end;
ja = 1;
for j = 1 : n;
w(1) = alpha.*conj(z(j,2));
w(2) = conj(alpha).*conj(z(j,1));
if( uppermlv )
jj = 1;
lj = fix(j);
else;
jj = fix(j);
lj = fix(n - j + 1);
end;
one_orig=one;    [dumvar1,lj,dumvar3,one,z(sub2ind(size(z),jj,1):end),nmax,w,dumvar8,dumvar9,a(sub2ind(size(a),jj,j):end),dumvar11,yt,g,aa(sub2ind(size(aa),max(ja,1)):end),eps,err,ftl,nout,dumvar19,kprint]=cmvch('N',lj,2,one,z(sub2ind(size(z),jj,1):end),nmax,w,1,one,a(sub2ind(size(a),jj,j):end),1,yt,g,aa(sub2ind(size(aa),max(ja,1)):end),eps,err,ftl,nout,true,kprint);    one(dumvar9~=one_orig)=dumvar9(dumvar9~=one_orig);
if( ~(full) )
ja = fix(ja + lj);
elseif( uppermlv ) ;
ja = fix(ja + lda);
else;
ja = fix(ja + lda + 1);
end;
errmax = max(errmax,err);
end; j = fix(n+1);
end;
if( ftl )
fatal = true;
if( kprint>=3 )
writef(nout,['      THESE ARE THE RESULTS FOR COLUMN ','%3i' ' \n'], j);
writef(nout,[' ** ','%6s',' FAILED ON call NUMBER:' ' \n'], sname);
if( full )
writef(nout,[repmat(' ',1,1),'%6i',': ','%6s','(''','%1s',''',','%3i',',(','%4.1f',',','%4.1f','), X,','%2i',', Y,','%2i',', A,','%3i',')             ','            .' ' \n'], nc , sname , uplo , n , alpha ,incx , incy , lda);
elseif( packed ) ;
writef(nout,[repmat(' ',1,1),'%6i',': ','%6s','(''','%1s',''',','%3i',',(','%4.1f',',','%4.1f','), X,','%2i',', Y,','%2i',', AP)                     ','       .' ' \n'], nc , sname , uplo , n , alpha ,incx , incy);
end;
end;
end;
end; ia = fix(nalf+1);
end; iy = fix(ninc+1);
end; ix = fix(ninc+1);
end; ic = fix(2+1);
end;
end; in = fix(nidim+1);
if( ~fatal )
if( kprint>=3 )
if( errmax<thresh )
writef(nout,[' ','%6s',' PASSED THE COMPUTATIONAL TESTS (','%6i',' CALL','S)' ' \n'], sname , nc);
else;
writef(nout,[' ','%6s',' COMPLETED THE COMPUTATIONAL TESTS (','%6i',' C','ALLS)', '\n ' ,' ** BUT WITH MAXIMUM TEST RATIO','%8.2f',' - SUSPECT **' ' \n'], sname , nc , errmax);
end;
end;
end;
a_orig(1:prod(a_shape))=a;a=a_orig;
z_orig(1:prod(z_shape))=z;z=z_orig;
return;
%format (' ',a6,' PASSED THE COMPUTATIONAL TESTS (',i6,' CALL','S)');
%format (' ** FATAL ERROR - PARAMETER NUMBER ',i2,' WAS CH','ANGED INCORRECTLY **');
%format (' ',a6,' COMPLETED THE COMPUTATIONAL TESTS (',i6,' C','ALLS)',/' ** BUT WITH MAXIMUM TEST RATIO',f8.2,' - SUSPECT **');
%format (' ** ',a6,' FAILED ON call NUMBER:');
%format ('      THESE ARE THE RESULTS FOR COLUMN ',i3);
%format (1X,i6,': ',a6,'(''',a1,''',',i3,',(',f4.1,',',f4.1,'), X,',i2,', Y,',i2,', AP)                     ','       .');
%format (1X,i6,': ',a6,'(''',a1,''',',i3,',(',f4.1,',',f4.1,'), X,',i2,', Y,',i2,', A,',i3,')             ','            .');
%format (' ** FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *','*');
a_orig(1:prod(a_shape))=a;a=a_orig;
z_orig(1:prod(z_shape))=z;z=z_orig;
end %subroutine cchk62

Contact us