| [hx,n,strbeg,strend,iperm,kflag,work,ier]=hpsort(hx,n,strbeg,strend,iperm,kflag,work,ier); |
function [hx,n,strbeg,strend,iperm,kflag,work,ier]=hpsort(hx,n,strbeg,strend,iperm,kflag,work,ier);
%***BEGIN PROLOGUE HPSORT
%***PURPOSE Return the permutation vector generated by sorting a
% substring within a character array and, optionally,
% rearrange the elements of the array. The array may be
% sorted in forward or reverse lexicographical order. A
% slightly modified quicksort algorithm is used.
%***LIBRARY SLATEC
%***CATEGORY N6A1C, N6A2C
%***TYPE CHARACTER (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H)
%***KEYWORDS PASSIVE SORTING, SINGLETON QUICKSORT, SORT, STRING SORTING
%***AUTHOR Jones, R. E., (SNLA)
% Rhoads, G. S., (NBS)
% Sullivan, F. E., (NBS)
% Wisniewski, J. A., (SNLA)
%***DESCRIPTION
%
% HPSORT returns the permutation vector IPERM generated by sorting
% the substrings beginning with the character STRBEG and ending with
% the character STREND within the strings in array HX and, optionally,
% rearranges the strings in HX. HX may be sorted in increasing or
% decreasing lexicographical order. A slightly modified quicksort
% algorithm is used.
%
% IPERM is such that HX(IPERM(I)) is the Ith value in the
% rearrangement of HX. IPERM may be applied to another array by
% calling IPPERM, SPPERM, DPPERM or HPPERM.
%
% An active sort of numerical data is expected to execute somewhat
% more quickly than a passive sort because there is no need to use
% indirect references. But for the character data in HPSORT, integers
% in the IPERM vector are manipulated rather than the strings in HX.
% Moving integers may be enough faster than moving character strings
% to more than offset the penalty of indirect referencing.
%
% Description of Parameters
% HX - input/output -- array of type character to be sorted.
% For example, to sort a 80 element array of names,
% each of length 6, declare HX as character HX(100)*6.
% If ABS(KFLAG) = 2, then the values in HX will be
% rearranged on output; otherwise, they are unchanged.
% N - input -- number of values in array HX to be sorted.
% STRBEG - input -- the index of the initial character in
% the string HX that is to be sorted.
% STREND - input -- the index of the final character in
% the string HX that is to be sorted.
% IPERM - output -- permutation array such that IPERM(I) is the
% index of the string in the original order of the
% HX array that is in the Ith location in the sorted
% order.
% KFLAG - input -- control parameter:
% = 2 means return the permutation vector resulting from
% sorting HX in lexicographical order and sort HX also.
% = 1 means return the permutation vector resulting from
% sorting HX in lexicographical order and do not sort
% HX.
% = -1 means return the permutation vector resulting from
% sorting HX in reverse lexicographical order and do
% not sort HX.
% = -2 means return the permutation vector resulting from
% sorting HX in reverse lexicographical order and sort
% HX also.
% WORK - character variable which must have a length specification
% at least as great as that of HX.
% IER - output -- error indicator:
% = 0 if no error,
% = 1 if N is zero or negative,
% = 2 if KFLAG is not 2, 1, -1, or -2,
% = 3 if work array is not long enough,
% = 4 if string beginning is beyond its end,
% = 5 if string beginning is out-of-range,
% = 6 if string end is out-of-range.
%
% E X A M P L E O F U S E
%
% CHARACTER*2 HX, W
% INTEGER STRBEG, STREND
% DIMENSION HX(10), IPERM(10)
% DATA (HX(I),I=1,10)/ '05','I ',' I',' ','Rs','9R','R9','89',
% 1 ',*','N"'/
% DATA STRBEG, STREND / 1, 2 /
% CALL HPSORT (HX,10,STRBEG,STREND,IPERM,1,W)
% PRINT 100, (HX(IPERM(I)),I=1,10)
% 100 FORMAT (2X, A2)
% STOP
% end
%
%***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm
% for sorting with minimal storage, Communications of
% the ACM, 12, 3 (1969), pp. 185-187.
%***ROUTINES CALLED XERMSG
%***REVISION HISTORY (YYMMDD)
% 761101 DATE WRITTEN
% 761118 Modified by John A. Wisniewski to use the Singleton
% quicksort algorithm.
% 811001 Modified by Francis Sullivan for string data.
% 850326 Documentation slightly modified by D. Kahaner.
% 870423 Modified by Gregory S. Rhoads for passive sorting with the
% option for the rearrangement of the original data.
% 890620 Algorithm for rearranging the data vector corrected by R.
% Boisvert.
% 890622 Prologue upgraded to Version 4.0 style by D. Lozier.
% 920507 Modified by M. McClain to revise prologue text.
% 920818 Declarations section rebuilt and code restructured to use
% IF-THEN-ELSE-ENDIF. (SMR, WRB)
%***end PROLOGUE HPSORT
% .. Scalar Arguments ..
persistent gt i ij il indx indx0 ir istrt iu j k kk l lm lmt m nn nn2 r ;
if isempty(gt), gt=zeros(1,3); end;
% .. Array Arguments ..
iperm_shape=size(iperm);iperm=reshape(iperm,1,[]);
hx_shape=size(hx);hx=reshape(hx,1,[]);
% .. Local Scalars ..
if isempty(r), r=0; end;
if isempty(i), i=0; end;
if isempty(ij), ij=0; end;
if isempty(indx), indx=0; end;
if isempty(indx0), indx0=0; end;
if isempty(ir), ir=0; end;
if isempty(istrt), istrt=0; end;
if isempty(j), j=0; end;
if isempty(k), k=0; end;
if isempty(kk), kk=0; end;
if isempty(l), l=0; end;
if isempty(lm), lm=0; end;
if isempty(lmt), lmt=0; end;
if isempty(m), m=0; end;
if isempty(nn), nn=0; end;
if isempty(nn2), nn2=0; end;
% .. Local Arrays ..
if isempty(il), il=zeros(1,21); end;
if isempty(iu), iu=zeros(1,21); end;
% .. External Subroutines ..
% .. Intrinsic Functions ..
%***FIRST EXECUTABLE STATEMENT HPSORT
ier = 0;
nn = fix(n);
if( nn<1 )
ier = 1;
[dumvar1,dumvar2,dumvar3,ier]=xermsg('SLATEC','HPSORT','The number of values to be sorted, N, is not positive.',ier,1);
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
else;
kk = fix(abs(kflag));
if( kk~=1 && kk~=2 )
ier = 2;
[dumvar1,dumvar2,dumvar3,ier]=xermsg('SLATEC','HPSORT','The sort control parameter, KFLAG, is not 2, 1, -1, or -2.',ier,1);
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
%
elseif( length(work)<length(hx{1}) ) ;
ier = 3;
[dumvar1,dumvar2,dumvar3,ier]=xermsg('SLATEC',' HPSORT','The length of the work variable, WORK, is too short.',ier,1);
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
elseif( strbeg>strend ) ;
ier = 4;
[dumvar1,dumvar2,dumvar3,ier]=xermsg('SLATEC','HPSORT','The string beginning, STRBEG, is beyond its end, STREND.',ier,1);
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
elseif( strbeg<1 || strbeg>length(hx{1}) ) ;
ier = 5;
[dumvar1,dumvar2,dumvar3,ier]=xermsg('SLATEC','HPSORT','The string beginning, STRBEG, is out-of-range.',ier,1);
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
elseif( strend<1 || strend>length(hx{1}) ) ;
ier = 6;
[dumvar1,dumvar2,dumvar3,ier]=xermsg('SLATEC','HPSORT','The string end, STREND, is out-of-range.',ier,1);
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
else;
%
% Initialize permutation vector
%
for i = 1 : nn;
iperm(i) = fix(i);
end; i = fix(nn+1);
%
% Return if only one value is to be sorted
%
if( nn==1 )
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
return;
end;
%
% Sort HX only
%
m = 1;
i = 1;
j = fix(nn);
r = .375e0;
end;
end;
%
gt(:)=0;
while( true );
if(gt(3)==0)
if(gt(2)==0)
if(gt(1)==0)
if( i==j )
gt(3)=1;
continue;
end;
if( r<=0.5898437e0 )
r = r + 3.90625e-2;
else;
r = r - 0.21875e0;
end;
%
end;
gt(1)=0;
k = fix(i);
%
% Select a central element of the array and savemlv it in location L
%
ij = fix(i + fix((j-i).*r));
lm = fix(iperm(ij));
%
% If first element of array is greater than LM, interchange with LM
%
if( strrel(hx{iperm(i)}(strbeg:strend),hx{lm}(strbeg:strend),'>') )
iperm(ij) = fix(iperm(i));
iperm(i) = fix(lm);
lm = fix(iperm(ij));
end;
l = fix(j);
%
% If last element of array is less than LM, interchange with LM
%
if( strrel(hx{iperm(j)}(strbeg:strend),hx{lm}(strbeg:strend),'<') )
iperm(ij) = fix(iperm(j));
iperm(j) = fix(lm);
lm = fix(iperm(ij));
%
% If first element of array is greater than LM, interchange
% with LM
%
if( strrel(hx{iperm(i)}(strbeg:strend),hx{lm}(strbeg:strend),'>') )
iperm(ij) = fix(iperm(i));
iperm(i) = fix(lm);
lm = fix(iperm(ij));
end;
end;
%
% Find an element in the second half of the array which is smaller
% than LM
%
while( true );
l = fix(l - 1);
if( strrel(hx{iperm(l)}(strbeg:strend),hx{lm}(strbeg:strend),'<=') )
%
% Find an element in the first half of the array which is greater
% than LM
%
while( true );
k = fix(k + 1);
if( strrel(hx{iperm(k)}(strbeg:strend),hx{lm}(strbeg:strend),'>=') )
break;
end;
end;
%
% Interchange these elements
%
if( k>l )
break;
end;
lmt = fix(iperm(l));
iperm(l) = fix(iperm(k));
iperm(k) = fix(lmt);
end;
end;
%
% Save upper and lower subscripts of the array yet to be sorted
%
if( l-i>j-k )
il(m) = fix(i);
iu(m) = fix(l);
i = fix(k);
m = fix(m + 1);
else;
il(m) = fix(k);
iu(m) = fix(j);
j = fix(l);
m = fix(m + 1);
end;
%
end;
gt(2)=0;
if( j-i>=1 )
gt(1)=1;
continue;
end;
if( i==1 )
continue;
end;
i = fix(i - 1);
%
while( true );
i = fix(i + 1);
if( i==j )
break;
end;
writef(1,['%s %0.15g \n'], 'i=',i);
lm = fix(iperm(i+1));
if( strrel(hx{iperm(i)}(strbeg:strend),hx{lm}(strbeg:strend),'>') )
k = fix(i);
%
while( true );
iperm(k+1) = fix(iperm(k));
k = fix(k - 1);
%
if( strrel(hx{lm}(strbeg:strend),hx{iperm(k)}(strbeg:strend),'>=') )
break;
end;
end;
iperm(k+1) = fix(lm);
end;
end;
%
% Begin again on another portion of the unsorted array
%
end;
gt(3)=0;
m = fix(m - 1);
if( m==0 )
break;
end;
i = fix(il(m));
j = fix(iu(m));
gt(2)=1;
continue;
end;
%
% Clean up
%
if( kflag<=-1 )
%
% Alter array to get reverse order, if necessary
%
nn2 = fix(fix(nn./2));
for i = 1 : nn2;
ir = fix(nn - i + 1);
lm = fix(iperm(i));
iperm(i) = fix(iperm(ir));
iperm(ir) = fix(lm);
end; i = fix(nn2+1);
end;
%
% Rearrange the values of HX if desired
%
if( kk==2 )
%
% use the IPERM vector as a flag.
% If IPERM(I) < 0, then the I-th value is in correct location
%
for istrt = 1 : nn;
if( iperm(istrt)>=0 )
indx = fix(istrt);
indx0 = fix(indx);
work = hx{istrt};
while( iperm(indx)>0 );
hx{indx} = hx{iperm(indx)};
indx0 = fix(indx);
iperm(indx) = fix(-iperm(indx));
indx = fix(abs(iperm(indx)));
end;
hx{indx0} = work;
end;
end; istrt = fix(nn+1);
%
% Revert the signs of the IPERM values
%
for i = 1 : nn;
%
iperm(i) = fix(-iperm(i));
end; i = fix(nn+1);
end;
%
iperm_shape=zeros(iperm_shape);iperm_shape(:)=iperm(1:numel(iperm_shape));iperm=iperm_shape;
hx_shape=cell(hx_shape);hx_shape(:)=hx(1:numel(hx_shape));hx=hx_shape;
end %subroutine hpsort
%DECK HQR2
|
|
