subroutine aptperm (nset, nper, nperm, iper, nout, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTPERM c c call aptperm (nset, nper, nperm, iper, nout, nerr) c c Version: aptperm Updated 1993 April 30 13:10. c aptperm Originated 1993 April 30 13:10. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To generate all possible permutations of the integers from 1 to c nset, taken nper at a time, storing the results in the 2-D array c iper, which has a first (row) dimension of nperm. The number of c permutations nout equals nset! / (nset - nper)!. c Flag nerr indicates any input errors. c c Note: For combinations, see aptcomb. c c Input: nset, nper, nperm c c Output: iper, nerr. c c Glossary: c c iper Output The nout subsets of permuted integers. c A 2-D array, iper(nperm,noutm), where noutm must be c at least as large as nout = nset! / (nset - nper)!. c The first subscript is the position within the c subset. The second subscript is the index of the c subset. The value of each iper is an integer between c 1 and nset. No integer may be used more than once c in a subset. c c nerr Output Indicates an input error, if not 0. c 1 if nset is less than 1. c 2 if nper is less than 1, or exceeds nset. c 3 if nperm is less than nper. c c nout Output The number of subsets of permuted integers. c Should equal nset! / (nset - nper)!. c c nper Input The number of integers in each subset of integers. c Each subset will be a unique permutation of integers. c The current upper limit is 9. Must not be less than c 1, or greater than nset. c c nperm Input The row size of 2-D array iper. Must not be less than c nper. c c nset Input Total number of integers. Must not be less than 1, or c less than nper. The integer values range from 1 to c nset. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. c---- Subsets of permuted integers. dimension iper (nperm,1) c.... Local variables. c---- Trial integer. common /laptperm/ iperx(9) c---- Position index in a subset of integers. common /laptperm/ n c---- Position index in a subset of integers. common /laptperm/ nn c---- Trial integer for position 1. common /laptperm/ n1 c---- Trial integer for position 2. common /laptperm/ n2 c---- Trial integer for position 3. common /laptperm/ n3 c---- Trial integer for position 4. common /laptperm/ n4 c---- Trial integer for position 5. common /laptperm/ n5 c---- Trial integer for position 6. common /laptperm/ n6 c---- Trial integer for position 7. common /laptperm/ n7 c---- Trial integer for position 8. common /laptperm/ n8 c---- Trial integer for position 9. common /laptperm/ n9 cbugc***DEBUG begins. cbug 9901 format (/ 'aptperm finding permutations of integers' / cbug & ' nset=',i5,' nper=',i4,' nperm=',i4) cbug write ( 3, 9901) nset, nper, nperm cbugc***DEBUG ends. c.... initialize. nerr = 0 nout = 0 c.... Test for input errors. if (nset .le. 0) then nerr = 1 go to 210 endif if ((nper .le. 0) .or. (nper .gt. nset)) then nerr = 2 go to 210 endif if (nperm .lt. nper) then nerr = 3 go to 210 endif c.... Generate all of the subsets of integers. c.... Select object 1. do 501 n1 = 1, nset n = 1 iperx(n) = n1 if (n .eq. nper) then nout = nout + 1 do 301 nn = 1, nper iper(nn,nout) = iperx(nn) 301 continue go to 501 endif c.... Select object 2. do 502 n2 = 1, nset n = 2 iperx(n) = n2 do 402 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 502 402 continue if (n .eq. nper) then nout = nout + 1 do 302 nn = 1, nper iper(nn,nout) = iperx(nn) 302 continue go to 502 endif c.... Select object 3. do 503 n3 = 1, nset n = 3 iperx(n) = n3 do 403 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 503 403 continue if (n .eq. nper) then nout = nout + 1 do 303 nn = 1, nper iper(nn,nout) = iperx(nn) 303 continue go to 503 endif c.... Select object 4. do 504 n4 = 1, nset n = 4 iperx(n) = n4 do 404 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 504 404 continue if (n .eq. nper) then nout = nout + 1 do 304 nn = 1, nper iper(nn,nout) = iperx(nn) 304 continue go to 504 endif c.... Select object 5. do 505 n5 = 1, nset n = 5 iperx(n) = n5 do 405 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 505 405 continue if (n .eq. nper) then nout = nout + 1 do 305 nn = 1, nper iper(nn,nout) = iperx(nn) 305 continue go to 505 endif c.... Select object 6. do 506 n6 = 1, nset n = 6 iperx(n) = n6 do 406 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 506 406 continue if (n .eq. nper) then nout = nout + 1 do 306 nn = 1, nper iper(nn,nout) = iperx(nn) 306 continue go to 506 endif c.... Select object 7. do 507 n7 = 1, nset n = 7 iperx(n) = n7 do 407 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 507 407 continue if (n .eq. nper) then nout = nout + 1 do 307 nn = 1, nper iper(nn,nout) = iperx(nn) 307 continue go to 507 endif c.... Select object 8. do 508 n8 = 1, nset n = 8 iperx(n) = n8 do 408 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 508 408 continue if (n .eq. nper) then nout = nout + 1 do 308 nn = 1, nper iper(nn,nout) = iperx(nn) 308 continue go to 508 endif c.... Select object 9. do 509 n9 = 1, nset n = 9 iperx(n) = n9 do 409 nn = 1, n - 1 if (iperx(n) .eq. iperx(nn)) go to 509 409 continue if (n .eq. nper) then nout = nout + 1 do 309 nn = 1, nper iper(nn,nout) = iperx(nn) 309 continue go to 509 endif 509 continue 508 continue 507 continue 506 continue 505 continue 504 continue 503 continue 502 continue 501 continue 210 continue cbugc***DEBUG begins. cbug 9902 format (/ 'aptperm results. nerr=',i3) cbug 9903 format (i6,3x,9i3) cbug write ( 3, 9902) nerr cbug if (nerr .ne. 0) return cbug do 710 n2 = 1, nout cbug write ( 3, 9903) n2, (iper(n1,n2), n1 = 1, nper) cbug 710 continue cbugc***DEBUG ends. return c.... End of subroutine aptperm. (+1 line.) end UCRL-WEB-209832