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