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