| [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]=cchk13(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]=cchk13(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 bls err errmax firstCall ftl i ia ib ica icb ich ik im in isame k ks laa lbb lcc lda ldas ldb ldbs ldc ldcs m ma mb ms n na nb nc nerr ns null reset rzero trana tranas tranb tranbs transa transb zero ; if isempty(firstCall),firstCall=1;end;
if isempty(zero), zero=complex(0.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);
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(bls), bls=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(ica), ica=0; end;
if isempty(icb), icb=0; end;
if isempty(ik), ik=0; end;
if isempty(im), im=0; end;
if isempty(in), in=0; end;
if isempty(k), k=0; end;
if isempty(ks), ks=0; end;
if isempty(laa), laa=0; end;
if isempty(lbb), lbb=0; end;
if isempty(lcc), lcc=0; end;
if isempty(lda), lda=0; end;
if isempty(ldas), ldas=0; end;
if isempty(ldb), ldb=0; end;
if isempty(ldbs), ldbs=0; end;
if isempty(ldc), ldc=0; end;
if isempty(ldcs), ldcs=0; end;
if isempty(m), m=0; end;
if isempty(ma), ma=0; end;
if isempty(mb), mb=0; end;
if isempty(ms), ms=0; end;
if isempty(n), n=0; end;
if isempty(na), na=0; end;
% integer :: nargs ;
if isempty(nb), nb=0; end;
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(null), null=false; end;
if isempty(reset), reset=false; end;
if isempty(trana), trana=false; end;
if isempty(tranb), tranb=false; end;
if isempty(tranas), tranas=repmat(' ',1,1); end;
if isempty(tranbs), tranbs=repmat(' ',1,1); end;
if isempty(transa), transa=repmat(' ',1,1); end;
if isempty(transb), transb=repmat(' ',1,1); end;
if isempty(ich), ich=repmat(' ',1,3); end;
if isempty(isame), isame=zeros(1,13); end;
if firstCall, ich=['NTC']; end;
firstCall=0;
nargs = 13;
nc = 0;
reset = true;
errmax = rzero;
for im = 1 : nidim;
m = fix(idim_v(im));
for in = 1 : nidim;
n = fix(idim_v(in));
ldc = fix(m);
if( ldc<nmax )
ldc = fix(ldc + 1);
end;
if( ldc<=nmax )
lcc = fix(ldc.*n);
null = n<=0 | m<=0;
for ik = 1 : nidim;
k = fix(idim_v(ik));
for ica = 1 : 3;
transa = ich([ica:ica]);
trana = strcmp(deblank(transa),deblank('T')) | strcmp(deblank(transa),deblank('C'));
if( trana )
ma = fix(k);
na = fix(m);
else;
ma = fix(m);
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]=cmake3('GE',' ',' ',ma,na,a,nmax,aa,lda,reset,zero);
for icb = 1 : 3;
transb = ich([icb:icb]);
tranb = strcmp(deblank(transb),deblank('T')) | strcmp(deblank(transb),deblank('C'));
if( tranb )
mb = fix(n);
nb = fix(k);
else;
mb = fix(k);
nb = fix(n);
end;
ldb = fix(mb);
if( ldb<nmax )
ldb = fix(ldb + 1);
end;
if( ldb<=nmax )
lbb = fix(ldb.*nb);
[dumvar1,dumvar2,dumvar3,mb,nb,b,nmax,bb,ldb,reset,zero]=cmake3('GE',' ',' ',mb,nb,b,nmax,bb,ldb,reset,zero);
for ia = 1 : nalf;
alpha = alf(ia);
for ib = 1 : nbet;
beta = bet(ib);
[dumvar1,dumvar2,dumvar3,m,n,c,nmax,cc,ldc,reset,zero]=cmake3('GE',' ',' ',m,n,c,nmax,cc,ldc,reset,zero);
nc = fix(nc + 1);
tranas = transa;
tranbs = transb;
ms = fix(m);
ns = fix(n);
ks = fix(k);
als = alpha;
for i = 1 : laa;
as(i) = aa(i);
end; i = fix(laa+1);
ldas = fix(lda);
for i = 1 : lbb;
bs(i) = bb(i);
end; i = fix(lbb+1);
ldbs = fix(ldb);
bls = beta;
for i = 1 : lcc;
cs(i) = cc(i);
end; i = fix(lcc+1);
ldcs = fix(ldc);
[transa,transb,m,n,k,alpha,aa,lda,bb,ldb,beta,cc,ldc]=cgemm(transa,transb,m,n,k,alpha,aa,lda,bb,ldb,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(transa),deblank(tranas));
isame(2) = strcmp(deblank(transb),deblank(tranbs));
isame(3) = ms==m;
isame(4) = ns==n;
isame(5) = ks==k;
isame(6) = als==alpha;
[isame(7) ,as,aa,laa]=lce(as,aa,laa);
isame(8) = ldas==lda;
[isame(9) ,bs,bb,lbb]=lce(bs,bb,lbb);
isame(10) = ldbs==ldb;
isame(11) = bls==beta;
if( null )
[isame(12) ,cs,cc,lcc]=lce(cs,cc,lcc);
else;
[isame(12) ,dumvar2,dumvar3,m,n,cs,cc,ldc]=lceres('GE',' ',m,n,cs,cc,ldc);
end;
isame(13) = 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 )
nmax_orig=nmax; nmax_orig=nmax; [transa,transb,m,n,k,alpha,a,nmax,b,dumvar10,beta,c,dumvar13,ct,g,cc,ldc,eps,err,ftl,nout,dumvar22,kprint]=cmmch(transa,transb,m,n,k,alpha,a,nmax,b,nmax,beta,c,nmax,ct,g,cc,ldc,eps,err,ftl,nout,true,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig);
errmax = max(errmax,err);
end;
if( ftl )
fatal = true;
if( kprint>=3 )
writef(nout,[' ** ','%6s',' FAILED ON call NUMBER:' ' \n'], sname);
writef(nout,[repmat(' ',1,1),'%6i',': ','%6s','(''','%1s',''',''','%1s',''',',repmat(['%3i',','] ,1,3),'(','%4.1f',',','%4.1f','), A,','%3i',', B,','%3i',',(','%4.1f',',','%4.1f','), C,','%3i',').' ' \n'], nc , sname , transa , transb ,m , n , k , alpha , lda , ldb , beta , ldc);
end;
end;
end; ib = fix(nbet+1);
end; ia = fix(nalf+1);
end;
end; icb = fix(3+1);
end;
end; ica = fix(3+1);
end; ik = fix(nidim+1);
end;
end; in = fix(nidim+1);
end; im = 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,'(''',a1,''',''',a1,''',',3(i3,','),'(',f4.1,',',f4.1,'), A,',i3,', B,',i3,',(',f4.1,',',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 cchk13
|
|