| [sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nmax,a,aa,as,b,bb,bs,ct,g,c]=schk33(sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nmax,a,aa,as,b,bb,bs,ct,g,c); |
function [sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nmax,a,aa,as,b,bb,bs,ct,g,c]=schk33(sname,eps,thresh,nout,kprint,fatal,nidim,idim_v,nalf,alf,nmax,a,aa,as,b,bb,bs,ct,g,c);
persistent alpha als diag diags err errmax firstCall ftl i ia icd ichd ichs icht ichu ics ict icu im in isame j laa lbb lda ldas ldb ldbs left m ms n na nc nerr ns null one reset side sides tranas transa uplo uplos 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(err), err=0; end;
if isempty(errmax), errmax=0; end;
if isempty(i), i=0; end;
if isempty(ia), ia=0; end;
if isempty(icd), icd=0; end;
if isempty(ics), ics=0; end;
if isempty(ict), ict=0; end;
if isempty(icu), icu=0; end;
if isempty(im), im=0; end;
if isempty(in), in=0; end;
if isempty(j), j=0; end;
if isempty(laa), laa=0; end;
if isempty(lbb), lbb=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(m), m=0; end;
if isempty(ms), ms=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(ftl), ftl=false; end;
if isempty(null), null=false; end;
if isempty(reset), reset=false; end;
if isempty(left), left=false; end;
if isempty(side), side=repmat(' ',1,1); end;
if isempty(sides), sides=repmat(' ',1,1); end;
if isempty(uplo), uplo=repmat(' ',1,1); end;
if isempty(uplos), uplos=repmat(' ',1,1); end;
if isempty(tranas), tranas=repmat(' ',1,1); end;
if isempty(transa), transa=repmat(' ',1,1); end;
if isempty(diag), diag=repmat(' ',1,1); end;
if isempty(diags), diags=repmat(' ',1,1); end;
if isempty(ichs), ichs=repmat(' ',1,2); end;
if isempty(ichu), ichu=repmat(' ',1,2); end;
if isempty(ichd), ichd=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;
if firstCall, ichd=['UN']; end;
if firstCall, ichs=['LR']; end;
firstCall=0;
nargs = 11;
nc = 0;
reset = true;
errmax = zero;
for j = 1 : nmax;
for i = 1 : nmax;
c(i,j) = zero;
end; i = fix(nmax+1);
end; j = fix(nmax+1);
for im = 1 : nidim;
m = fix(idim_v(im));
for in = 1 : nidim;
n = fix(idim_v(in));
ldb = fix(m);
if( ldb<nmax )
ldb = fix(ldb + 1);
end;
if( ldb<=nmax )
lbb = fix(ldb.*n);
null = m<=0 | n<=0;
for ics = 1 : 2;
side = ichs([ics:ics]);
left = strcmp(deblank(side),deblank('L'));
if( left )
na = fix(m);
else;
na = fix(n);
end;
lda = fix(na);
if( lda<nmax )
lda = fix(lda + 1);
end;
if( lda>nmax )
break;
end;
laa = fix(lda.*na);
for icu = 1 : 2;
uplo = ichu([icu:icu]);
for ict = 1 : 3;
transa = icht([ict:ict]);
for icd = 1 : 2;
diag = ichd([icd:icd]);
for ia = 1 : nalf;
alpha = alf(ia);
na_orig=na; [dumvar1,uplo,diag,na,dumvar5,a,nmax,aa,lda,reset,zero]=smake3('TR',uplo,diag,na,na,a,nmax,aa,lda,reset,zero); na(dumvar5~=na_orig)=dumvar5(dumvar5~=na_orig);
[dumvar1,dumvar2,dumvar3,m,n,b,nmax,bb,ldb,reset,zero]=smake3('GE',' ',' ',m,n,b,nmax,bb,ldb,reset,zero);
nc = fix(nc + 1);
sides = side;
uplos = uplo;
tranas = transa;
diags = diag;
ms = fix(m);
ns = fix(n);
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);
if( strcmp(deblank(sname([4:min(length(sname),5)])),deblank('MM')) )
[side,uplo,transa,diag,m,n,alpha,aa,lda,bb,ldb]=strmm(side,uplo,transa,diag,m,n,alpha,aa,lda,bb,ldb);
elseif ( strcmp(deblank(sname([4:min(length(sname),5)])),deblank('SM')) ) ;
[side,uplo,transa,diag,m,n,alpha,aa,lda,bb,ldb]=strsm(side,uplo,transa,diag,m,n,alpha,aa,lda,bb,ldb);
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(sides),deblank(side));
isame(2) = strcmp(deblank(uplos),deblank(uplo));
isame(3) = strcmp(deblank(tranas),deblank(transa));
isame(4) = strcmp(deblank(diags),deblank(diag));
isame(5) = ms==m;
isame(6) = ns==n;
isame(7) = als==alpha;
[isame(8) ,as,aa,laa]=lse(as,aa,laa);
isame(9) = ldas==lda;
if( null )
[isame(10) ,bs,bb,lbb]=lse(bs,bb,lbb);
else;
[isame(10) ,dumvar2,dumvar3,m,n,bs,bb,ldb]=lseres('GE',' ',m,n,bs,bb,ldb);
end;
isame(11) = ldbs==ldb;
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( strcmp(deblank(sname([4:min(length(sname),5)])),deblank('MM')) )
if( left )
m_orig=m; nmax_orig=nmax; nmax_orig=nmax; [transa,dumvar2,m,n,dumvar5,alpha,a,nmax,b,dumvar10,zero,c,dumvar13,ct,g,bb,ldb,eps,err,ftl,nout,dumvar22,kprint]=smmch(transa,'N',m,n,m,alpha,a,nmax,b,nmax,zero,c,nmax,ct,g,bb,ldb,eps,err,ftl,nout,true,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig); m(dumvar5~=m_orig)=dumvar5(dumvar5~=m_orig);
else;
n_orig=n; nmax_orig=nmax; nmax_orig=nmax; [dumvar1,transa,m,n,dumvar5,alpha,b,nmax,a,dumvar10,zero,c,dumvar13,ct,g,bb,ldb,eps,err,ftl,nout,dumvar22,kprint]=smmch('N',transa,m,n,n,alpha,b,nmax,a,nmax,zero,c,nmax,ct,g,bb,ldb,eps,err,ftl,nout,true,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig); n(dumvar5~=n_orig)=dumvar5(dumvar5~=n_orig);
end;
elseif ( strcmp(deblank(sname([4:min(length(sname),5)])),deblank('SM')) ) ;
for j = 1 : n;
for i = 1 : m;
c(i,j) = bb(i+(j-1).*ldb);
bb(i+(j-1).*ldb) = alpha.*b(i,j);
end; i = fix(m+1);
end; j = fix(n+1);
if( left )
m_orig=m; nmax_orig=nmax; nmax_orig=nmax; [transa,dumvar2,m,n,dumvar5,one,a,nmax,c,dumvar10,zero,b,dumvar13,ct,g,bb,ldb,eps,err,ftl,nout,dumvar22,kprint]=smmch(transa,'N',m,n,m,one,a,nmax,c,nmax,zero,b,nmax,ct,g,bb,ldb,eps,err,ftl,nout,false,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig); m(dumvar5~=m_orig)=dumvar5(dumvar5~=m_orig);
else;
n_orig=n; nmax_orig=nmax; nmax_orig=nmax; [dumvar1,transa,m,n,dumvar5,one,c,nmax,a,dumvar10,zero,b,dumvar13,ct,g,bb,ldb,eps,err,ftl,nout,dumvar22,kprint]=smmch('N',transa,m,n,n,one,c,nmax,a,nmax,zero,b,nmax,ct,g,bb,ldb,eps,err,ftl,nout,false,kprint); nmax(dumvar13~=nmax_orig)=dumvar13(dumvar13~=nmax_orig); nmax(dumvar10~=nmax_orig)=dumvar10(dumvar10~=nmax_orig); n(dumvar5~=n_orig)=dumvar5(dumvar5~=n_orig);
end;
end;
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','(',repmat(['''','%1s',''','] ,1,4),repmat(['%3i',','] ,1,2),'%4.1f',', A,','%3i',', B,','%3i',') .' ' \n'], nc , sname , side , uplo ,transa , diag , m , n , alpha ,lda , ldb);
end;
end;
end; ia = fix(nalf+1);
end; icd = fix(2+1);
end; ict = fix(3+1);
end; icu = fix(2+1);
end;
end;
end;
end;
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,'(',4('''',a1,''','),2(i3,','),f4.1,', A,',i3,', B,',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 schk33
|
|