subroutine aptsort (ltab, nrows, ncols, nrowmx, ncord, mods, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSORT
c
c call aptsort (ltab, nrows, ncols, nrowmx, ncord, mods, nerr)
c
c Version: aptsort Updated 1991 August 22 12:40.
c aptsort 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 column ncord of the 2-D array ltab, which has nrows rows
c and ncols columns, in ascending (ncord positive) or descending
c (ncord negative) order. The mode of the sorted column is
c specified by mods: 0 for alphanumeric or character, 1 for
c integer, and 2 for floating point.
c Flag nerr indicates any input errors.
c
c Note: Subroutine aptsorm may be used for sequential sorting of more
c than one table column.
c
c Input: ltab, nrows, ncols, nrowmx, ncord, mods.
c
c Output: ltab, nerr.
c
c Glossary:
c
c ltab In/Out A two-dimensional array, with nrows rows and ncols
c columns. Memory size is ltab(nrowmx,ncolmx), where
c nrowmx is no less than nrows, and ncolmx is no less
c than ncols.
c
c mods Input Mode of column to be sorted:
c 0 = alphanumeric or character.
c 1 = integer.
c 2 = floating point.
c
c ncols Input Number of columns actually used in ltab.
c Must be at least 1.
c
c ncord Input Index of column to be sorted.
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 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 ncord has a magnitude greater than ncols,
c or equal to zero.
c
c nrowmx Input First dimension in size specification of array ltab.
c
c nrows Input Number of rows in ltab.
c Must be in the range from 2 to nrowmx.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Table to be sorted.
dimension ltab (nrowmx,ncols)
c.... Local variables.
c---- Difference between row values.
common /laptsort/ diff
c---- Floating point sorting direction.
common /laptsort/ esign
c---- Difference between row values.
common /laptsort/ ldiff
c---- Current extreme value in column nsort.
common /laptsort/ 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 /laptsort/ lsign
c---- Temporary ltab value.
common /laptsort/ ltemp
c---- Value to be compared with lext.
common /laptsort/ 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 ltab column.
common /laptsort/ ncol
c---- Index in array ncord.
common /laptsort/ nord
c---- Index of an ltab row.
common /laptsort/ nrow
c---- Equal to nrows - 1.
common /laptsort/ nrowm
c---- Index of an ltab row, nrow + 1.
common /laptsort/ next
c---- Index of an ltab row.
common /laptsort/ nn
c---- Index of column being sorted.
common /laptsort/ nsort
c---- Index of row to exchange with nrow.
common /laptsort/ nrowx
cbugc***DEBUG begins.
cbug common /ltsor/ aformr(10)
cbug 9901 format (/ 'aptsort sorting table.' /
cbug & ' nrows=',i5,' ncols=',i3,' nrowmx=',i5,' mods=',i3)
cbug 9902 format (' ncord=',i3)
cbug write ( 3, 9901) nrows, ncols, nrowmx, mods
cbug write ( 3, 9902) ncord
cbug do 981 nrow = 1, nrows
cbug write ( 3, aformr) (ltab(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
nsort = iabs (ncord)
if ((nsort .gt. ncols) .or. (nsort .eq. 0)) then
nerr = 4
go to 210
endif
c.... Find the direction of sorting.
if (ncord .lt. 0) then
lsign = -1
esign = -1.0
else
lsign = 1
esign = 1.0
endif
c.... Sort table column ncord.
nrowm = nrows - 1
c---- Loop over ltab rows.
do 170 nrow = 1, nrowm
nrowx = nrow
next = nrow + 1
lext = ltab(nrow,nsort)
c.... Search for a more extreme value.
c---- Loop over rest of group rows.
do 140 nn = next, nrows
ltry = ltab(nn,nsort)
c.... Select the mode of column to be sorted, make comparison.
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---- 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---- 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.... A more extreme value has been found. Reset lext, save row index.
130 lext = ltry
nrowx = nn
c---- End of loop over rest of group rows.
140 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 ltab columns.
do 160 ncol = 1, ncols
ltemp = ltab(nrow,ncol)
ltab(nrow,ncol) = ltab(nrowx,ncol)
ltab(nrowx,ncol) = ltemp
c---- End of loop over ltab columns.
160 continue
c---- Exchanged rows.
endif
c---- End of loop over ltab rows.
170 continue
cbugc***DEBUG begins.
cbug 9904 format (/ 'aptsort results:')
cbug write ( 3, 9904)
cbug do 982 nrow = 1, nrows
cbug write ( 3, aformr) (ltab(nrow,ncol), ncol = 1, ncols)
cbug 982 continue
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptsort. (+1 line.)
end
UCRL-WEB-209832