subroutine aptdeld (ks, atab, nrows, ncols, nrowmx, ncomp, ncomps,
& nreds, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTDELD
c
c call aptdeld (ks, atab, nrows, ncols, nrowmx, ncomp, ncomps,
c & nreds, nerr)
c
c Version: aptdeld Updated 1991 October 7 13:00.
c aptdeld Originated 1990 October 7 13:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To delete all rows (first subscript, dimension nrowmx) of the
c 2-D array atab, which has ncols columns (second subscript) and
c nrows rows, for which column(s) ncomp(n) (n = 1, ncomps) are
c each duplicates of the same column(s) in any preceding row
c (ks = 0), or in the immediately preceding row only (ks = 1).
c Flag nerr indicates any input errors.
c
c Note: Use aptdels to find unique values in a 1-D array which
c has been previously sorted.
c
c Input: ks, atab, nrows, ncols, nrowmx, ncomp, ncomps.
c
c Output: atab, nreds, 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. Final number of rows will be nreds.
c
c ks Input Indicates the tests for duplicate column values will be
c done in all preceding unique rows (ks = 0), or only
c in the immediately preceding unique row (ks = 1).
c If table atab has been previously sequentially sorted
c in columns ncomp(n) (n = 1, ncomps), so that all rows
c that are duplicates in those columns are adjacent,
c the later option (ks = 1) will be much faster.
c
c ncols Input Number of columns in atab.
c Must be at least 1.
c
c ncomp Input Indices of columns to be tested for duplicates.
c Size = ncomps.
c Must be in the range from 1 to ncols.
c
c ncomps Input Number of columns to be tested for duplicates.
c
c nerr Output Indicates an input error, if not 0:
c 1 if nrows is less than 1, or more than nrowmx.
c 2 if ncols is less than 1.
c 3 if ncomps is less than 1 or greater than ncols.
c 4 if any ncomp is less than 1 or more than ncols.
c
c nreds Output Final number of rows in reduced array atab.
c
c nrowmx Input First dimension in size specification of array atab.
c The increment between successive memory locations of
c two adjacent column values in the same row of atab.
c
c nrows Input Initial number of rows in atab.
c Must be in the range from 1 to nrowmx.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
dimension atab (nrowmx,1) ! Table to be reduced.
dimension ncomp (1) ! Column(s) to be tested.
c.... Local variables.
common /laptdeld/ n ! Index in array ncomp.
common /laptdeld/ nbeg ! Starting index for row tests.
common /laptdeld/ ncol ! Index of an atab column.
common /laptdeld/ nred ! Index of a final atab row.
common /laptdeld/ nrow ! Index of an initial atab row.
cbugc***DEBUG begins.
cbug common /ltsor/ aformr(10)
cbug common /ltsor/ ncolxx
cbug 9901 format (/ 'aptdeld removing duplicates from table.' /
cbug & ' nrows=',i5,' ncols=',i3,' nrowmx=',i5)
cbug 9902 format (' ncomp=',20i3)
cbug write ( 3, 9901) nrows, ncols, nrowmx
cbug if ((ncomps .ge. 1) .and. (ncomps .le. ncols)) then
cbug write ( 3, 9902) (ncomp(n), n = 1, ncomps)
cbug endif
cbug if ((nrows .ge. 1) .and. (nrows .le. nrowmx)) then
cbug do 981 nrow = 1, nrows
cbug write ( 3, aformr) (atab(nrow,ncol), ncol = 1, ncolxx)
cbug 981 continue
cbug endif
cbugc***DEBUG ends.
c.... Test for input errors.
nerr = 0
if ((nrows .lt. 1) .or. (nrows .gt. nrowmx)) then
nerr = 1
go to 210
endif
if (ncols .lt. 1) then
nerr = 2
go to 210
endif
if ((ncomps .lt. 1) .or. (ncomps .gt. ncols)) then
nerr = 3
go to 210
endif
do 110 n = 1, ncomps
if ((ncomp(n) .gt. ncols) .or. (ncomp(n) .le. 0)) then
nerr = 4
go to 210
endif
110 continue
c.... Delete rows with duplicates in table columns ncomp(n) (n = 1, ncomps).
nreds = 1 ! Keep row 1.
if (nrows .eq. 1) go to 210
nbeg = 1
do 150 nrow = 2, nrows ! Loop over rest of initial rows.
do 130 nred = nbeg, nreds ! Loop over reduced rows.
do 120 n = 1, ncomps ! Loop over test columns.
ncol = ncomp(n)
if (atab(nrow,ncol) .ne. atab(nred,ncol)) go to 130 ! Different.
120 continue ! End of loop over test columns.
go to 150 ! Test columns same. Delete row.
130 continue ! End of loop over reduced rows.
nreds = nreds + 1 ! Test columns different. Keep row.
if (ks .ne. 0) nbeg = nreds
do 140 ncol = 1, ncols ! Loop over columns.
atab(nreds,ncol) = atab(nrow,ncol)
140 continue ! End of loop over columns.
150 continue ! End of loop over initial rows.
cbugc***DEBUG begins.
cbug 9904 format (/ 'aptdeld results:')
cbug write ( 3, 9904)
cbug do 982 nrow = 1, nreds
cbug write ( 3, aformr) (atab(nrow,ncol), ncol = 1, ncolxx)
cbug 982 continue
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptdeld. (+1 line.)
end
UCRL-WEB-209832