| [sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nbet,bet,nmax,a,aa,as,b,bb,bs,c,cc,cs,ct,g]=schk43(sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nbet,bet,nmax,a,aa,as,b,bb,bs,c,cc,cs,ct,g); |
function [sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nbet,bet,nmax,a,aa,as,b,bb,bs,c,cc,cs,ct,g]=schk43(sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nbet,bet,nmax,a,aa,as,b,bb,bs,c,cc,cs,ct,g);
persistent alpha als beta bets err errmax firstCall ftl i ia ib icht ichu ict icu ik in isame j jc jj k ks laa lcc lda ldas ldc ldcs lj ma n na nc nerr ns null one reset tran trans transs uplo uplos uppermlv zero ; if isempty(firstCall),firstCall=1;end;
if isempty(zero), zero=0.0; end;
if isempty(one), one=1.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);
b_orig=b;b_shape=[nmax,nmax];b=reshape([b_orig(1:min(prod(b_shape),numel(b_orig))),zeros(1,max(0,prod(b_shape)-numel(b_orig)))],b_shape);
c_orig=c;c_shape=[nmax,nmax];c=reshape([c_orig(1:min(prod(c_shape),numel(c_orig))),zeros(1,max(0,prod(c_shape)-numel(c_orig)))],c_shape);
if isempty(alpha), alpha=0; end;
if isempty(als), als=0; end;
if isempty(beta), beta=0; end;
if isempty(bets), bets=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(ib), ib=0; end;
if isempty(ict), ict=0; end;
if isempty(icu), icu=0; end;
if isempty(ik), ik=0; end;
if isempty(in), in=0; end;
if isempty(j), j=0; end;
if isempty(jc), jc=0; end;
if isempty(jj), jj=0; end;
if isempty(k), k=0; end;
if isempty(laa), laa=0; end;
if isempty(lcc), lcc=0; end;
if isempty(lda), lda=0; end;
if isempty(ldas), ldas=0; end;
if isempty(ldc), ldc=0; end;
if isempty(ldcs), ldcs=0; end;
if isempty(n), n=0; end;
if isempty(na), na=0; end;
% integer :: nargs ;
if isempty(nc), nc=0; end;
if isempty(nerr), nerr=0; end;
if isempty(ns), ns=0; end;
if isempty(ks), ks=0; end;
if isempty(lj), lj=0; end;
if isempty(ma), ma=0; end;
if isempty(ftl), ftl=false; end;
if isempty(null), null=false; end;
if isempty(reset), reset=false; end;
if isempty(tran), tran=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(trans), trans=repmat(' ',1,1); end;
if isempty(transs), transs=repmat(' ',1,1); end;
if isempty(ichu), ichu=repmat(' ',1,2); end;
if isempty(icht), icht=repmat(' ',1,3); end;
if isempty(isame), isame=zeros(1,13); end;
if firstCall, icht=['NTC']; end;
if firstCall, ichu=['UL']; end;
firstCall=0;
nargs = 10;
nc = 0;
reset = true;
errmax = zero;
for in = 1 : nidim;
n = fix(idim_v(in));
ldc = fix(n);
if( ldc<nmax )
ldc = fix(ldc + 1);
end;
if( ldc<=nmax )
lcc = fix(ldc.*n);
null = n<=0;
for ik = 1 : nidim;
k = fix(idim_v(ik));
for ict = 1 : 3;
trans = icht([ict:ict]);
tran = strcmp(deblank(trans),deblank('T')) | strcmp(deblank(trans),deblank('C'));
if( tran )
ma = fix(k);
na = fix(n);
else;
ma = fix(n);
na = fix(k);
end;
lda = fix(ma);
if( lda<nmax )
lda = fix(lda + 1);
end;
if( lda<=nmax )
laa = fix(lda.*na);
[dumvar1,dumvar2,dumvar3,ma,na,a,nmax,aa,lda,reset,zero]=smake3('GE',' ',' ',ma,na,a,nmax,aa,lda,reset,zero);
for icu = 1 : 2;
uplo = ichu([icu:icu]);
uppermlv = strcmp(deblank(uplo),deblank('U'));
for ia = 1 : nalf;
alpha = alf(ia);
for ib = 1 : nbet;
beta = bet(ib);
n_orig=n; [dumvar1,uplo,dumvar3,n,dumvar5,c,nmax,cc,ldc,reset,zero]=smake3('SY',uplo,' ',n,n,c,nmax,cc,ldc,reset,zero); n(dumvar5~=n_orig)=dumvar5(dumvar5~=n_orig);
nc = fix(nc + 1);
uplos = uplo;
transs = trans;
ns = fix(n);
ks = fix(k);
als = alpha;
for i = 1 : laa;
as(i) = aa(i);
end; i = fix(laa+1);
ldas = fix(lda);
bets = beta;
for i = 1 : lcc;
cs(i) = cc(i);
end; i = fix(lcc+1);
ldcs = fix(ldc);
[uplo,trans,n,k,alpha,aa,lda,beta,cc,ldc]=ssyrk(uplo,trans,n,k,alpha,aa,lda,beta,cc,ldc);
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(uplos),deblank(uplo));
isame(2) = strcmp(deblank(transs),deblank(trans));
isame(3) = ns==n;
isame(4) = ks==k;
isame(5) = als==alpha;
[isame(6) ,as,aa,laa]=lse(as,aa,laa);
isame(7) = ldas==lda;
isame(8) = bets==beta;
if( null )
[isame(9) ,cs,cc,lcc]=lse(cs,cc,lcc);
else;
n_orig=n; [isame(9) ,dumvar2,uplo,n,dumvar5,cs,cc,ldc]=lseres('SY',uplo,n,n,cs,cc,ldc); n(dumvar5~=n_orig)=dumvar5(dumvar5~=n_orig);
end;
isame(10) = ldcs==ldc;
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 )
jc = 1;
for j = 1 : n;
if( uppermlv )
jj = 1;
lj = fix(j);
else;
jj = fix(j);
lj = fix(n - j + 1);
end;
if( tran )
nmax_orig=nmax; nmax_orig=nmax; [dumvar1,dumvar2,lj,dumvar4,k,alpha,dumvar7,nmax,dumvar9,dumvar10,beta,c(sub2ind(size(c),jj,j):end),dumvar13,ct,g,cc(sub2ind(size(cc),max(jc,1)):end),ldc,eps,err,ftl,nout,dumvar22,kprint]=smmch('T','N',lj,1,k,alpha,a(sub2ind(size(a),1,jj):end),nmax,a(sub2ind(size(a),1,j):end),nmax,beta,c(sub2ind(size(c),jj,j):end),nmax,ct,g,cc(sub2ind(size(cc),max(jc,1)):end),ldc,eps,err,ftl,nout,true,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig); a(sub2ind(size(a),1,jj):end)=dumvar7; a(sub2ind(size(a),1,j):end)=dumvar9;
else;
nmax_orig=nmax; nmax_orig=nmax; [dumvar1,dumvar2,lj,dumvar4,k,alpha,dumvar7,nmax,dumvar9,dumvar10,beta,c(sub2ind(size(c),jj,j):end),dumvar13,ct,g,cc(sub2ind(size(cc),max(jc,1)):end),ldc,eps,err,ftl,nout,dumvar22,kprint]=smmch('N','T',lj,1,k,alpha,a(sub2ind(size(a),jj,1):end),nmax,a(sub2ind(size(a),j,1):end),nmax,beta,c(sub2ind(size(c),jj,j):end),nmax,ct,g,cc(sub2ind(size(cc),max(jc,1)):end),ldc,eps,err,ftl,nout,true,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig); a(sub2ind(size(a),jj,1):end)=dumvar7; a(sub2ind(size(a),j,1):end)=dumvar9;
end;
if( uppermlv )
jc = fix(jc + ldc);
else;
jc = fix(jc + ldc + 1);
end;
errmax = max(errmax,err);
end; j = fix(n+1);
end;
if( ftl )
fatal = true;
if( kprint>=3 )
writef(nout,[' ** ','%6s',' FAILED ON call NUMBER:' ' \n'], sname);
writef(nout,[repmat(' ',1,1),'%6i',': ','%6s','(',repmat(['''','%1s',''','] ,1,2),repmat(['%3i',','] ,1,2),'%4.1f',', A,','%3i',',','%4.1f',', C,','%3i',') .' ' \n'], nc , sname , uplo , trans , n ,k , alpha , lda , beta , ldc);
end;
end;
end; ib = fix(nbet+1);
end; ia = fix(nalf+1);
end; icu = fix(2+1);
end;
end; ict = fix(3+1);
end; ik = fix(nidim+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;
b_orig(1:prod(b_shape))=b;b=b_orig;
c_orig(1:prod(c_shape))=c;c=c_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 (1X,i6,': ',a6,'(',2('''',a1,''','),2(i3,','),f4.1,', A,',i3,',',f4.1,', C,',i3,') .');
%format (' ** FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *','*');
a_orig(1:prod(a_shape))=a;a=a_orig;
b_orig(1:prod(b_shape))=b;b=b_orig;
c_orig(1:prod(c_shape))=c;c=c_orig;
end %subroutine schk43
|
|