      PROGRAM test
      IMPLICIT NONE
        INTEGER n, i
        INTEGER, ALLOCATABLE :: a (:)
        INTERFACE
          SUBROUTINE permutations (a, op)
          INTEGER, INTENT (IN) :: a (:)
          INTERFACE
            SUBROUTINE op (v)
            INTEGER, INTENT (IN) :: v (:)
            ENDSUBROUTINE
          ENDINTERFACE
          ENDSUBROUTINE

          SUBROUTINE output (a)
            INTEGER, INTENT (IN) :: a (:)
          ENDSUBROUTINE
        ENDINTERFACE

        WRITE (6, *) 'n?:'
        READ  (5, *) n
        ALLOCATE (a (n))
        a = (/ (i, i = 1, n) /)
        CALL permutations (a, output)
      ENDPROGRAM

      SUBROUTINE permutations (a, op)
      IMPLICIT NONE
      INTEGER, INTENT (IN) :: a (:)
      INTERFACE
        SUBROUTINE op (v)
        INTEGER, INTENT (IN) :: v (:)
        ENDSUBROUTINE
      ENDINTERFACE

      ! Apply `op' to all permutations of `a', in some order.
      !
      ! This is an iterative transcription of ``op (a); perms (1, a)'':
      !
      !     perms (r, a) =
      !       for i = r, n
      !         if (i > r)
      !           swap (a (r), a (i))
      !           op (a)
      !         perms (r + 1, a)
      !         if (i > r)
      !           swap (a (r), a (i))

        INTEGER n, r
        INTEGER, DIMENSION (0 : SIZE (a) + 1) :: i, t  ! Note sentinels.

        n     = SIZE (a)
        t (1 : n) = a
        CALL op (t (1 : n))
        i (0) = 0
        r     = 1                ! call `perms (1, a)'
        i (1) = 1                ! start `for' loop
        DO WHILE (r > 0)
          IF (i (r) <= n) THEN   ! still in `for' loop
            IF (i (r) > r) THEN
              CALL swap (t (r), t (i (r)))
              CALL op (t (1 : n))
            ENDIF
            r     = r + 1        ! call `perms (r + 1, a)'
            i (r) = r            ! start `for' loop

          ELSE                   ! `for' loop done
            r     = r - 1        ! return from `perms'
            IF (i (r) > r) THEN
              CALL swap (t (r), t (i (r)))
            ENDIF
            i (r) = i (r) + 1
          ENDIF
        ENDDO

      CONTAINS

        SUBROUTINE swap (x, y)
        IMPLICIT NONE
        INTEGER x, y
          INTEGER t
          t = x
          x = y
          y = t
        ENDSUBROUTINE

      ENDSUBROUTINE
           
      SUBROUTINE output (a)
      IMPLICIT NONE
        INTEGER, INTENT (IN) :: a (:)
        
        WRITE (6, *) a
      ENDSUBROUTINE

