! Last change: DOS 3 Aug 2000 6:15 pm ! *** copyright 2000 *** ! *** filename permnx.f95 *** John F. Monahan ** ! ********************** PROGRAM PPERMNX ! TEST PROGRAM FOR PERMNX -- COMPUTES THE NEXT PERMUTATION OF A VECTOR ! IMPLICIT NONE INTEGER, DIMENSION(10) :: M,MCOPY,IVTABL INTEGER I,J,ISTOP,KNTPRM,N INTEGER KPERM ! 20 FORMAT(' DEMONSTRATION OF PERMNX FOR COMPUTING PERMUTATIONS ' & & /2X,'STEP, INDEX, DONE=0',3X,'PERMUTATION',4X,'INVERSION TABLE',& & 3X,'INVERSE OF INDEX') 21 FORMAT(3X,3I4,8X,4I3,6X,3I3,8X,4I3) ! OPEN( UNIT=6, FILE='permnx.out' ) N = 4 ! SET UP FIRST PERMUTATION AND ISTOP = 0 TO START ISTOP = 0 DO I = 1,N M( I ) = I IVTABL( I ) = I END DO ! LOOP ON I WRITE(6,20) ! RUN THROUGH 30 TO SEE WHAT HAPPENS DO I = 1,30 ! COPY VECTOR SINCE KPERM REORDERS VECTOR M DO J = 1,N MCOPY(J) = M(J) END DO ! LOOP ON J ! GET NUMBER OF PERMUTATION KNTPRM = KPERM(MCOPY,N) !W WRITE(6,21) I,KNTPRM,ISTOP,(MCOPY(J),J=1,N) ! INVERT NUMBER TO GET PERMUTATION CALL IPERM(KNTPRM,MCOPY,N) !W WRITE(6,21) I,KNTPRM,ISTOP,(MCOPY(J),J=1,N) ! WRITE IT OUT WRITE(6,21) I,KNTPRM,ISTOP,(M(J),J=1,N),(IVTABL(J),J=2,N), & & (MCOPY(J),J=1,N) ! GET NEW ONE CALL PERMNX(M,IVTABL,N,ISTOP) END DO ! LOOP ON I STOP END PROGRAM PPERMNX SUBROUTINE PERMNX(M,D,N,RT) ! SUBROUTINE PERMNX -- COMPUTES THE NEXT PERMUTATION OF N ITEMS ! FORTRAN TRANSLATION OF ALGOL PROCEDURE VECTORPERM (WELLS' METHOD) ! J. BOOTHROYD (1967) ALGORITHM 29: PERMUTATION OF THE ELEMENTS OF A ! VECTOR, THE COMPUTER JOURNAL, VOL. 10, P. 311 ! MARK B. WELLS (1961) GENERATION OF PERMUTATIONS BY TRANSPOSITION, ! MATH. COMP., VOL. 15, PP. 192-195. ! ! J F MONAHAN (DEC,1984) DEPT OF STAT, N C S U, RALEIGH, N C 27695-8203 ! RECODED MARCH 2000 FOR FORTRAN 95 ! ! M INTEGER VECTOR IN/OUT VECTOR OF ITEMS TO BE PERMUTED ! D INTEGER VECTOR AUX INVERSION TABLE TO RUN ALGORITHM ! N INTEGER IN LENGTH OF VECTOR TO BE PERMUTED ! RT INTEGER IN RT = 0 START PERMUTATIONS ! OUT RT = 0 DONE WITH PERMUTATIONS ! IN/OUT RT = 1 CONTINUING, GENERATE NEXT ! IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN OUT) :: RT INTEGER, DIMENSION(N), INTENT(IN OUT) :: M,D INTEGER DK,T,K,J,KL ! BRANCH TO 2 IF WE ARE IN THE MIDDLE OF THINGS IF( RT .EQ. 0 ) THEN ! INITIALIZE INVERSION TABLE DO K = 1,N D( K ) = 0 END DO ! LOOP ON K END IF ! ( RT .EQ. 0 ) ! START MAIN PART OF CODE RT = 0 J = -1 KL = 1 DO K = 2,N DK = D( K ) IF( DK .NE. KL ) THEN ! SET FLAG AND BREAK FROM LOOP RT = 1 EXIT END IF ! ( DK .NE. KL ) D( K ) = 0 J = -J KL = K END DO ! LOOP ON K ! IF WE COMPLETE THE LOOP, DONE PERMUTING IF( RT .EQ. 0 ) RETURN D( K ) = DK + 1 DK = D( K ) IF( J .NE. 1 .AND. DK .GT. 2 ) KL = K - D( K ) ! ! SWITCH THESE TWO ELEMENTS T = M( K ) M( K ) = M( KL ) M( KL ) = T RETURN END SUBROUTINE PERMNX INTEGER FUNCTION KPERM(M,N) ! ASSIGNS A NUMBER TO THE PERMUTATION GIVEN IN VECTOR M ! WHICH IS UNIQUE TO PERMUTATION, 0 LE KPERM LT N! ! ! M INTEGER VECTOR IN VECTOR OF PERMUTED ITEMS ! OUT VECTOR IN INCREASING ORDER ! ! N INTEGER IN LENGTH OF ITEMS ! ! FOLLOWS ALGORITHM P IN ! D E KNUTH (1981) THE ART OF COMPUTER PROGRAMMING, VOLUME 2: ! SEMINUMERICAL ALGORITHMS, ADDISON-WESLEY, P. 64. ! ! ** NOTE THAT M NEED NOT BE A PERMUTATION VECTOR, JUST A LIST ! OF UNIQUE ORDERABLE ITEMS ** IT IS ORDERED ON EXIT ** ! IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, DIMENSION(N) :: M INTEGER I,MAX,R,S ! INITIALIZE R = N KPERM = 0 ! RESTART HERE DO WHILE ( R .GT. 1 ) ! FIND MAX S = 1 MAX = M(1) DO I = 1,R IF( M(I) .GT. MAX ) THEN S = I MAX = M(I) END IF ! ( M(I) .GT. MAX ) END DO ! LOOP ON I ! UPDATE FUNCTION KPERM = KPERM * R + S - 1 ! INTERCHANGE M(S) = M(R) M(R) = MAX ! DECREMENT R = R - 1 ! DONE? END DO ! WHILE ( R .GT. 1 ) RETURN END FUNCTION KPERM SUBROUTINE IPERM(KPERM,M,N) ! PERMUTES THE LIST OF ITEMS IN M ACCORDING TO THE PERMUTATION ! GIVEN BY THE PERMUTATION INDEX KPERM, 0 LE KPERM LT N! ! ! KPERM INTEGER IN PERMUTATION INDEX FROM 0 TO N!-1 ! ! M INTEGER VECTOR IN VECTOR OF ITEMS ! OUT VECTOR OF ITEMS IN PERMUTED ORDER ! ! N INTEGER IN LENGTH OF ITEMS ! ! INVERSE OF ALGORITHM P IN ! D E KNUTH (1981) THE ART OF COMPUTER PROGRAMMING, VOLUME 2: ! SEMINUMERICAL ALGORITHMS, ADDISON-WESLEY, P. 64. ! ! ** NOTE THAT M NEED NOT BE A PERMUTATION VECTOR, JUST A LIST ! OF UNIQUE ORDERABLE ITEMS ** IT IS ORDERED ON EXIT ** ! IMPLICIT NONE INTEGER, INTENT(IN) :: KPERM,N INTEGER, DIMENSION(N), INTENT(IN OUT) :: M INTEGER J,K,CJ,MM ! SAVE PERMUTATION INDEX K = KPERM DO J = 2,N ! GET DIGIT CJ = MOD(K,J) ! GET READY FOR NEXT K = (K - CJ) / J ! INTERCHANGE J AND CJ+1 MM = M(J) M(J) = M(CJ+1) M(CJ+1) = MM END DO ! LOOP ON J RETURN END SUBROUTINE IPERM ! *** end of filename permnx.f95 *********************