outlets/sort.f

      PROGRAM PARTITION
      IMPLICIT NONE
      INTEGER NMAX
      PARAMETER (NMAX = 10000)
      INTEGER N, NP, PART (NMAX, NMAX)
      INTEGER PATTERNS(NMAX,NMAX)
      INTEGER PATT(NMAX), CONF(NMAX)
      INTEGER LST(NMAX)
      INTEGER NCONFIG ( NMAX ), PCONFIG ( NMAX ), OCC, POW, VAL
      INTEGER TAB( NMAX ) , NTAB ( NMAX )
      INTEGER CODE, IY(NMAX), CONFCODE
      INTEGER CODES ( NMAX ), IPERM( NMAX ), IER
      CHARACTER (LEN = 10) STR 
      INTEGER IARG
      INTEGER I,J,K, INC
      DOUBLE PRECISION X (NMAX)
      INTEGER NFIRM,NOUTLET,NNOUTLET, NM
      INTEGER OCCUR
      INTEGER ITEN
      CHARACTER (LEN=16) FFILE
      CHARACTER (LEN=25) FOMT

      COMMON /IVAR/ ITEN

      CALL GETARG (1, FFILE) 

      OPEN ( UNIT = 1 , FILE = FFILE )
      READ (1,*)
      READ (1,*) NFIRM, NOUTLET, NNOUTLET
      NM = NFIRM * NOUTLET
C     PRINT*, NFIRM, NOUTLET, NM

      WRITE(STR,'(I5)') NM
      FOMT = "(I5,F8.2,"//ADJUSTR(STR)//"I5)"
C     PRINT*, STR,FOMT,NNOUTLET

      DO 10, I = 1, NNOUTLET
      READ( 1, FOMT )
     &   K, X(I), (PATTERNS(I,J), J=1,NM) 
C     PRINT '(I5,F6.2,15I4)',  I, X(I), (PATTERNS(I,J), J=1,NM) 
C      DO 5, J=1, NM
C5     PATT(J) = PATTERNS(I,J)
C      DO 6, J = 1, N
C      CONF(J) = OCCUR(NM, PATT,J 
C     PRINT '(I5,A3,9I5)', I," | ",(PATTERNS(I,J),J=1,NM)
 10   CONTINUE

      CLOSE(1)


C get the unique partitions of NM
      CALL AUP (NOUTLET, PART, NP)
C     PRINT*, "------"
      PRINT*, NM, NP, NNOUTLET
      DO 20, I = 1, NP
      NCONFIG(I) = 0
      DO 22, J = 1, NOUTLET
22    NCONFIG(I) = NCONFIG(I) + PART(I,J) * 10 ** (NOUTLET-J) 
C20    PRINT*, (PART(I,J), J=1,NOUTLET), NCONFIG(I)
20    CONTINUE
C     PRINT*, "------"

      ITEN = 1
25    CONTINUE
      ITEN = ITEN * 10
      IF(ITEN.LT.NP) GOTO 25
      PRINT*, ITEN

      DO 30, I = 1, NNOUTLET

      DO 31, J = 1, NM
 31   LST(J) = PATTERNS(I,J)
      DO 32, J = 1, NFIRM
      DO 33, K = 1, NOUTLET
      OCC = OCCUR(NM,LST,J,K) 
      TAB(K) = OCC
 33   CONTINUE
      NTAB(J) = CODE(NOUTLET, TAB, NCONFIG, NP)
 32   CONTINUE
      CALL ISORT ( NTAB, IY, NFIRM, -1)
C     PRINT*, "----->",(NTAB(J), J=1, NFIRM) 
C     PRINT*, 
      CODES (I) = CONFCODE(NTAB,NFIRM)
C     PRINT '(I5,A3,9I5,A3,I7)', I," | ",(PATTERNS(I,J),J=1,NM), 
C    &         " | ", CODES ( I )
C     PRINT *

30    CONTINUE

      CALL IPSORT(CODES, NNOUTLET, IPERM, 1, IER)
      DO 50, I = 1 , NNOUTLET
      PRINT '(I5,F8.2,A3,'//ADJUSTL(STR)//'I5,A3,I7)', I, X(IPERM(I)), 
     & " | ", (PATTERNS(IPERM(I),J),J=1,NM),  " | ", CODES ( IPERM(I) )
50    CONTINUE 

      END 


      FUNCTION CONFCODE ( LST, N )
      IMPLICIT NONE
      INTEGER CONFCODE 
      INTEGER N
      INTEGER LST(N)
      INTEGER I, VAL
      INTEGER ITEN

      COMMON /IVAR/ ITEN

      VAL = 0
      DO 10, I = 1, N
10    VAL = VAL + LST(I) * ITEN ** ( N - I )

      CONFCODE = VAL

      RETURN
      END 


      FUNCTION CODE ( N, TAB , NCONFIG, NP)
      IMPLICIT NONE
      INTEGER CODE
      INTEGER N, NP
      INTEGER TAB ( N ), NCONFIG( NP )
      INTEGER I, J, K, VAL, POW 

      VAL = 0
      POW = 0

      DO 10, I = 1, N
      DO 10, J = 1, TAB(I)

      VAL = VAL + I * 10 ** POW 
      POW = POW + 1 

 10   CONTINUE

 11   IF ( VAL.LT.10**(N-1) ) THEN
        VAL = 10 * VAL
        GOTO 11
      ENDIF 

      I = 0
 20   CONTINUE
      I = I + 1
      IF ( VAL.NE.NCONFIG(I).AND.I.LE.NP ) GOTO 20

      CODE = NP - I + 1 

      RETURN 
      END 


      FUNCTION OCCUR ( N, P, F, K)
C Compute the number of occurence of pattern PAT in
C list P
C INPUT
C   N  : length of configuration P
C   P  : the configuration to be examined
C   F  : the number identifying the firm
C   K  : the number of adjacent outlets
C OUTPUT
C   OCCUR : the number of time the pattern is observed in P
      INTEGER OCCUR
      INTEGER N, F, K, L
      INTEGER P(N), PP(N)
      INTEGER BLIST(N), I, J, IDX
      INTEGER INC

      INC = 0

 1    CONTINUE
      CALL PADLIST ( P, PP, N, INC )
      INC = INC + 1
      IF ( PP(N).EQ.F ) GOTO 1 

      L = 0

      I = 0
10    CONTINUE
      I = I + 1
      IF ( PP(I).NE.F.AND.I.LE.N ) GOTO 10

      IF(I.GT.N) GOTO 30

      J=I
20    CONTINUE
      J = J + 1
      IF ( PP(J).EQ.F.AND.J.LT.N ) GOTO 20

      IF (J - I .EQ. K ) L = L + 1

      I = J

      IF( I.LT.N ) GOTO 10 

30    CONTINUE

      OCCUR = L

      RETURN
      END

      SUBROUTINE PADLIST ( L1, L2, N, INC )
      IMPLICIT NONE
      INTEGER N, INC, I
      INTEGER L1 ( N ), L2 ( N ) 

      IF (INC.LE.-1) GOTO 50

      IF (ABS(INC).GE.N) THEN
        PRINT*, "Incorrect value of INC, try smaller value"
        GOTO 100
      ENDIF

      DO 10, I=1, N
      IF(I+INC.LE.N) THEN
        L2(I+INC) = L1(I)
      ELSE
        L2(I+INC-N) = L1(I)
      ENDIF 
 10   CONTINUE

      GOTO 100 

 50   CONTINUE

      DO 11, I=1, N
      IF(I+INC.GE.1) THEN
        L2(I+INC) = L1(I)
      ELSE
        L2(I+INC+N) = L1(I)
      ENDIF 
 11   CONTINUE

100   CONTINUE

      RETURN
      END


      SUBROUTINE AUP ( N , PART, NP )
      IMPLICIT NONE
      INTEGER NMAX
      PARAMETER (NMAX = 10000)
      INTEGER P (NMAX)
      INTEGER N, NP
      INTEGER PART(NMAX,NMAX)
      INTEGER K, I
      INTEGER R
      INTEGER IT

      NP = 0

      K = 1

      P(K) = N

 1    CONTINUE

      NP = NP + 1

      DO 5, I=1, K
 5    PART(NP,I) = P(I)

C     PRINT*,  (P(I), I=1,K) 
      R = 0

 2    CONTINUE
      IF ( K .GE. 1 .AND. P(K).EQ.1 ) THEN
        R = R + P(K)
        K = K - 1
        GOTO 2
      ENDIF

      IF ( K .LT. 1 ) GOTO 10 

      P(K) = P(K) - 1
      R = R + 1 

 3    CONTINUE
      IF ( R.GT.P(K) ) THEN
        P(K+1) = P(K)
        R = R - P(K)
        K = K + 1
        GOTO 3
      ENDIF

      P(K+1) = R
      K = K + 1

C     PRINT* , K, R

      GOTO 1
 10   CONTINUE

      RETURN
      END