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