subroutine aptsorm (atab, nrows, ncols, nrowmx, ncord, ncords,
& mods, nsave, ngroup, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSORM
c
c call aptsorm (atab, nrows, ncols, nrowmx, ncord, ncords,
c & mods, nsave, ngroup, nerr)
c
c Version: aptsorm Updated 1991 December 29 11:20.
c aptsorm Originated 1990 July 25 13:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To sort columns ncord(n), n = 1, ncords, of the 2-D array atab,
c which has nrows rows and ncols columns, each in ascending
c (ncord positive) or descending (ncord negative) order, in
c alphanumeric (mods = 0), integer (mods = 1), or floating point
c (mods = 2) mode. Each sequential sort only reorders the rows
c within groups of rows for which the column values of the
c previously sorted column are the same. The first row of each
c such group of rows is flagged with the sorting level, ngroup.
c The first nsave sorting levels from previous calls to aptsorm
c may be retained, allowing columns of different mode to be
c sequentially sorted.
c Flag nerr indicates any input errors.
c
c Note: Subroutine aptsort may be used for single-column sorting.
c
c Input: atab, nrows, ncols, nrowmx, ncord, ncords, mods, nsave, ngroup.
c
c Output: atab, nsave, ngroup, nerr.
c
c Glossary:
c
c atab In/Out A two-dimensional array, with nrows rows and ncols
c columns. Memory size is atab(nrowmx,ncolmx), where
c nrowmx is no less than nrows, and ncolmx is no less
c than ncols.
c
c mods Input Mode of columns to be sorted:
c 0 = alphanumeric or character.
c 1 = integer.
c 2 = floating point.
c For sequential sorting of columns with different
c modes, make more than one call to aptsorm.
c
c ncols Input Number of columns actually used in atab, to be
c reordered by the sorting.
c Must be at least 1.
c
c ncord Input Indices of columns to be sorted. Size ncords.
c Positive for sorting in increasing order.
c Negative for sorting in decreasing order.
c The magnitude must be in the range from 1 to ncols.
c
c ncords Input The number of columns to be sequentially sorted.
c Size of array ncord. Each sort will not change any
c of the nsave columns previously sorted.
c
c nerr Output Indicates an input error, if not 0:
c 1 if nrows is less than 2, or more than nrowmx.
c 2 if ncols is less than 1.
c 3 if mods is less than 0 or more than 2.
c 4 if any ncord has a magnitude greater than ncols,
c or equal to zero.
c 5 if nsave is less than 0.
c
c ngroup In/Out Sequential number of a preceding sort, for which the
c row is the first of a group of rows with the same
c value in the column sorted. Size nrows.
c Should be initialized to zero before the first sort,
c unless the first call to aptsorm is with nsave = 0.
c May be an otherwise unused table column larger than
c ncols.
c
c nrowmx Input First dimension in size specification of array atab.
c
c nrows Input Number of rows in atab. Size of array ngroup.
c Must be in the range from 2 to nrowmx.
c
c nsave In/Out Number of saved sorts to retain, up to a maximum
c of the sum of nsave and ncords on the preceding
c call to aptsorm. Should be zero for the first
c call to aptsorm. Refers to the first of the
c saved sorts, not the last.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Table to be sorted.
dimension atab (nrowmx,ncols)
character*8 atab
c---- Index of column to be sorted.
dimension ncord (1)
c---- Sorting group flag for row.
dimension ngroup (1)
c.... Local variables.
c---- Difference between row values.
common /laptsorm/ diff
c---- Floating point sorting direction.
common /laptsorm/ esign
c---- Difference between row values.
common /laptsorm/ ldiff
c---- Current extreme value in column nsort.
common /laptsorm/ lext
c---- ASCII string form of lext.
character*8 aext
c---- ASCII string form of lext.
equivalence (lext, aext)
c---- Floating point form of lext.
equivalence (lext, eext)
c---- Integer sorting direction, -1 or 1.
common /laptsorm/ lsign
c---- Temporary atab value.
common /laptsorm/ atemp
character*8 atemp
c---- Value to be compared with lext.
common /laptsorm/ ltry
c---- ASCII string form of ltry.
character*8 atry
c---- ASCII string form of ltry.
equivalence (ltry, atry)
c---- Floating point form of ltry.
equivalence (ltry, etry)
c---- Index of an atab column.
common /laptsorm/ ncol
c---- Index in array ncord.
common /laptsorm/ nord
c---- Index of an atab row.
common /laptsorm/ nrow
c---- Equal to nrows - 1.
common /laptsorm/ nrowm
c---- Index of an atab row, nrow + 1.
common /laptsorm/ next
c---- Index of an atab row.
common /laptsorm/ nn
c---- Index of column being sorted.
common /laptsorm/ nsort
c---- Index of row to exchange with nrow.
common /laptsorm/ nrowx
cbugc***DEBUG begins.
cbug common /ltsor/ aformr(10)
cbug 9901 format (/ 'aptsorm sorting table.' /
cbug & ' nrows=',i5,' ncols=',i3,' nrowmx=',i5,' mods=',i3,
cbug & ' nsave=',i3)
cbug 9902 format (' ncord=',20i3)
cbug 9903 format ('----------nrow=',i5,' ngroup=',i3,'----------')
cbug write ( 3, 9901) nrows, ncols, nrowmx, mods, nsave
cbug write ( 3, 9902) (ncord(nord), nord = 1, ncords)
cbug do 981 nrow = 1, nrows
cbug if ((ngroup(nrow) .ge. 1) .and.
cbug & (ngroup(nrow) .le. nsave)) then
cbug write ( 3, 9903) nrow, ngroup(nrow)
cbug endif
cbug write ( 3, aformr) (atab(nrow,ncol), ncol = 1, ncols)
cbug 981 continue
cbugc***DEBUG ends.
c.... Test for input errors.
nerr = 0
if ((nrows .lt. 2) .or. (nrows .gt. nrowmx)) then
nerr = 1
go to 210
endif
if (ncols .lt. 1) then
nerr = 2
go to 210
endif
if ((mods .lt. 0) .or. (mods .gt. 2)) then
nerr = 3
go to 210
endif
do 110 nord = 1, ncords
nsort = iabs (ncord(nord))
if ((nsort .gt. ncols) .or. (nsort .eq. 0)) then
nerr = 4
go to 210
endif
110 continue
if (nsave .lt. 0) then
nerr = 5
go to 210
endif
c.... Initialize the row group flags.
c---- Loop over atab rows.
do 120 nrow = 1, nrows
if (ngroup(nrow) .gt. nsave) then
ngroup(nrow) = 0
endif
c---- End of loop over atab rows.
120 continue
ngroup(1) = 1
c.... Sort table atab.
c---- Loop over columns to be sorted.
do 180 nord = 1, ncords
nsave = nsave + 1
c.... Find the direction of sorting.
if (ncord(nord) .lt. 0) then
nsort = -ncord(nord)
lsign = -1
esign = -1.0
else
nsort = ncord(nord)
lsign = 1
esign = 1.0
endif
c.... Sort within each fixed group of rows in atab.
nrowm = nrows - 1
c---- Loop over atab rows.
do 170 nrow = 1, nrowm
nrowx = nrow
next = nrow + 1
aext = atab(nrow,nsort)
c.... Search for a more extreme value in same group of rows.
c---- Loop over rest of group rows.
do 140 nn = next, nrows
if ((ngroup(nn) .ge. 1) .and.
& (ngroup(nn) .lt. nsave)) then
c---- Starting a new group.
go to 150
endif
atry = atab(nn,nsort)
c.... Select the mode of column to be sorted, make comparison.
c===============================================================================
c---- Alphanumeric comparison.
if (mods .eq. 0) then
if (lsign .eq. -1) then
if (atry .gt. aext) then
go to 130
else
go to 140
endif
else
if (atry .lt. aext) then
go to 130
else
go to 140
endif
endif
c---- End of alphanumeric comparison.
endif
c===============================================================================
c---- Integer comparison.
if (mods .eq. 1) then
ldiff = lsign * (ltry - lext)
if (ldiff .lt. 0) then
go to 130
else
go to 140
endif
c---- End of integer comparison.
endif
c===============================================================================
c---- Floating point comparison.
if (mods .eq. 2) then
diff = esign * (etry - eext)
if (diff .lt. 0.0) then
go to 130
else
go to 140
endif
c---- End of floating point comparison.
endif
c===============================================================================
c.... A more extreme value has been found. Reset lext, save index.
130 aext = atry
nrowx = nn
c---- End of loop over rest of group rows.
140 continue
c---- Reached end of group.
150 continue
c.... End of search. See if row nrow should be replaced.
c---- Exchange rows nrow and nrowx.
if (nrowx .ne. nrow) then
c---- Loop over atab columns.
do 160 ncol = 1, ncols
atemp = atab(nrow,ncol)
atab(nrow,ncol) = atab(nrowx,ncol)
atab(nrowx,ncol) = atemp
c---- End of loop over atab columns.
160 continue
c---- Exchanged rows.
endif
c.... See if this row is the beginning of a new group.
if (nrow .eq. 1) then
go to 170
endif
c++++ A new group.
if (atab(nrow,nsort) .ne. atab(nrow-1,nsort)) then
if ((ngroup(nrow) .eq. 0) .or.
& (ngroup(nrow) .gt. nsave)) then
ngroup(nrow) = nsave
endif
c---- Started a new group.
endif
c---- End of loop over atab rows.
170 continue
c.... See if final row is the beginning of a new group.
c++++ A new group.
if (atab(nrows,nsort) .ne. atab(nrowm,nsort)) then
if ((ngroup(nrows) .eq. 0) .or.
& (ngroup(nrows) .gt. nsave)) then
ngroup(nrows) = nsave
endif
c---- Started a new group.
endif
c---- End of loop over columns to be sorted.
180 continue
cbugc***DEBUG begins.
cbug 9904 format (/ 'aptsorm results:')
cbug write ( 3, 9904)
cbug do 982 nrow = 1, nrows
cbug if ((ngroup(nrow) .ge. 1) .and.
cbug & (ngroup(nrow) .le. nsave)) then
cbug write ( 3, 9903) nrow, ngroup(nrow)
cbug endif
cbug write ( 3, aformr) (atab(nrow,ncol), ncol = 1, ncols)
cbug 982 continue
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptsorm. (+1 line.)
end
UCRL-WEB-209832