add configs.f

configs.f

@@ -0,0 +1,407 @@
+      PROGRAM OUTLET
+      IMPLICIT NONE
+      INTEGER NMMAX,NMAX
+      PARAMETER (NMMAX=50000,NMAX=100)
+      DOUBLE PRECISION X(NMAX)
+      INTEGER I, J, N, M, NM, IT
+      INTEGER IPERM(NMAX)
+      INTEGER L1(NMAX), L2(NMAX)
+      INTEGER PATTERNS ( NMMAX, NMAX )
+      INTEGER CONF(NMAX,6), FREQ(NMMAX), IPAT
+      DOUBLE PRECISION DFREQ(NMMAX)
+      INTEGER PERM ( NMAX, 6), P1(NMAX), P2(NMAX), P(NMAX)
+      LOGICAL ISOMORPHICQ
+      INTEGER NITER
+      CHARACTER (LEN=10) STR
+      CHARACTER (LEN=20) ARGV
+      INTEGER NARG
+      REAL      TSTART, TEND
+
+
+      CALL GETARG(1, ARGV)
+      READ (ARGV,*) N
+      CALL GETARG(2, ARGV)
+      READ (ARGV,*) M
+      CALL GETARG(3, ARGV)
+      READ (ARGV,*) NITER
+
+    
+C     NITER = 1000
+C     N = 4
+C     M = 3
+      NM = N * M
+
+C      CALL PERMUTATIONS ( N, 100, PERM )
+C      DO 12, I = 1, NM
+C12    PRINT * , ( PERM ( I , J ), J = 1 , N )
+C
+C
+C      DO 10, J = 1, 100
+C      CALL GENER ( N, M, P1 )
+C      PRINT *,  (P1(I), I=1,NM)
+C
+C      CALL GENER ( N, M, P2 )
+C      PRINT *,  (P2(I), I=1,NM)
+C
+C      PRINT*, ISOMORPHICQ ( N, M, P1, P2, PERM )
+C 10   CONTINUE
+
+      DFREQ = 0.D0
+      FREQ  = 0
+      CALL CPU_TIME(TSTART)
+      CALL GRAPHS (N,M,PATTERNS,IPAT,FREQ,NITER)
+      CALL CPU_TIME(TEND)
+C     PRINT*, IPAT
+      PRINT '("TIME = ",F10.3," SECONDS.")',TEND-TSTART
+      PRINT*, N, M, IPAT
+      DO 10, I = 1, IPAT
+      DFREQ ( I ) = DBLE( FREQ(I) ) / DBLE(NITER) * 100.D0 
+      WRITE(STR,'(I5)') NM
+10    WRITE(6, "(I5,F8.2," // ADJUSTL(STR) // "I5)" )  
+     &                 I, DFREQ( I ), (PATTERNS(I,J), J=1,NM)
+C     PRINT '("TIME = ",F10.3," SECONDS.")',TEND-TSTART
+
+C     IT = 1
+C     CONF(IT, 1) = 1
+C     CONF(IT, 2) = 1
+C     CONF(IT, 3) = 2
+C     CONF(IT, 4) = 2
+C     CONF(IT, 5) = 3
+C     CONF(IT, 6) = 3
+
+C     CALL PATTERNS ( CONF, NMAX, N, IT, DIST )
+C      PRINT *
+C     L1(1) = 1
+C     L1(2) = 1
+C     L1(3) = 3
+C     L1(4) = 2
+C     L1(5) = 3
+C     L1(6) = 2
+C     L2(1) = 1
+C     L2(2) = 1
+C     L2(3) = 2
+C     L2(4) = 3
+C     L2(5) = 2
+C     L2(6) = 3
+C     PRINT *,  (L1(I), I=1,NM)
+C     PRINT *,  (L2(I), I=1,NM)
+C     PRINT*, ISOMORPHICQ ( N, M, L1, L2, PERM )
+
+
+
+
+
+C     DO 1, I=1, N
+C 1   L1(I) = I
+C     L1(1)=1
+C     L1(2)=1
+C     L1(3)=2
+C     L1(4)=2
+C     L1(5)=3
+C     L1(6)=3
+
+
+C     CALL PADLIST( L1, L2, N,  1)
+C     DO 2, I = 1, N
+C2    PRINT '(2I5)', L1(I), L2(I)
+
+ 
+
+      END
+
+
+
+      SUBROUTINE GRAPHS ( N, M, PATTERNS, IPAT, FREQ, ITMAX )
+      IMPLICIT NONE
+      INTEGER NMMAX,NMAX
+      PARAMETER (NMMAX=50000,NMAX=100)
+      INTEGER N, M, NM, IPAT, ITMAX
+      INTEGER PATTERNS ( NMMAX, NMAX )
+      INTEGER FREQ (NMAX)
+      INTEGER I, J, K, IT
+      INTEGER PERM ( NMAX, 6), P1(NMAX), P2(NMAX), P(NMAX)
+      LOGICAL ISOMORPHICQ
+      LOGICAL Q
+
+      NM = N * M
+
+      CALL PERMUTATIONS ( N, 100, PERM )
+C      DO 1, I = 1, NM
+C1     PRINT * , ( PERM ( I , J ), J = 1 , N )
+
+      CALL GENER ( N, M, P1 )
+C     PRINT *,  (P1(I), I=1,NM)
+
+      DO 2, J = 1, NM
+2     PATTERNS(1,J) = P1(J)
+
+      FREQ    = 0
+
+      IPAT    = 1
+      FREQ(1) = 1
+
+
+C MAIN LOOP
+      IT = 1
+10    CONTINUE
+
+      Q = .FALSE.
+
+      CALL GENER ( N, M, P2 )
+
+C Check isomorphy against all existing patterns
+      K = 0
+20    CONTINUE
+      K = K + 1
+
+      DO 12, J = 1, NM
+ 12   P1(J) = PATTERNS(K,J)
+
+
+      IF (ISOMORPHICQ(N,M,P1,P2,PERM)) THEN
+         Q = .TRUE.
+         FREQ ( K ) = FREQ ( K ) + 1
+         IT = IT + 1
+C        PRINT*, (P2(J), J=1,NM)
+         IF (IT.LT.ITMAX) GOTO 10
+      ELSE
+         IF (K.LT.IPAT) GOTO 20
+      ENDIF
+
+C If it doesn't match any existing pattern add it
+      IF (.NOT. Q) THEN
+        IPAT = IPAT + 1
+        FREQ(IPAT) = 1
+        DO 14, J=1, NM
+ 14     PATTERNS(IPAT,J) = P2(J)
+C       WRITE(*,'(1H+,A,I5,A)') 'PROGRESS: ', IPAT, '%' 
+C       PRINT*, (P2(J), J=1,NM)
+      ENDIF
+      IT = IT + 1
+C     IF (ISOMORPHICQ(N,M,P1,P2,PERM)) THEN
+C       FREQ(K) = FREQ(K)+1
+C       IT = IT + 1
+C       IF (IT.LT.ITMAX) GOTO 10
+C       GOTO 60
+C     ENDIF
+C50   CONTINUE
+
+      IF (IT.LT.ITMAX) GOTO 10
+
+C55   CONTINUE
+
+C     IF ( Q ) THEN 
+C       IPAT = IPAT + 1
+C       FREQ(IPAT) = 1
+C       DO 14, J=1, NM
+C14     PATTERNS(IPAT,J) = P2(J)
+C       PRINT*, (P2(J), J=1,NM)
+C     ELSE
+
+
+C     IT = IT + 1
+
+C     IF (IT.LT.ITMAX) GOTO 10 
+
+C60   CONTINUE
+
+      RETURN
+
+      END
+
+
+
+      FUNCTION ISOMORPHICQ (N, M, P1, P2, PERM)
+      IMPLICIT NONE
+      LOGICAL ISOMORPHICQ, Q
+      INTEGER N, M
+      INTEGER P1( N*M ), P2( N*M ), P3( N*M ), P4( N*M ), P11( N*M )
+      INTEGER PERM ( 100, N * M )
+      INTEGER I, J, K,  NM, FACT, DIFF1, DIFF11
+
+      Q = .FALSE.
+
+      NM = N * M
+
+      FACT = 1
+      DO 1, I = 1, N
+ 1    FACT = I * FACT
+
+      P11 (1) = P1 (1)
+      DO 10, I = 2, NM
+ 10   P11(I) = P1(NM+2-I) 
+
+
+      DO 2, I = 1, FACT
+
+      DO 3, J = 1, NM    
+ 3    P3 ( J ) = PERM ( I , P2 ( J ) )
+C     PRINT *, "P3 -> " , (P3(K), K=1,NM) 
+
+      DO 2, J = 0, NM - 1
+      CALL PADLIST ( P3, P4, NM, J )
+      DIFF1  = 0
+      DIFF11 = 0
+      DO 4, K = 1, NM
+      DIFF1  = DIFF1  + ABS ( P4 ( K ) - P1  ( K ) )
+ 4    DIFF11 = DIFF11 + ABS ( P4 ( K ) - P11 ( K ) )
+C     PRINT *,  (P4(K), K=1,NM), DIFF
+      
+      IF ((DIFF1.EQ.0).OR.(DIFF11.EQ.0)) THEN
+        Q = .TRUE.
+        GOTO 100
+      ENDIF 
+
+ 2    CONTINUE 
+
+ 100  CONTINUE
+      ISOMORPHICQ = Q
+
+      RETURN
+      END
+
+
+      SUBROUTINE GENER ( N, M, P )
+      IMPLICIT NONE
+      INTEGER NMAX
+      PARAMETER (NMAX=100)
+      INTEGER N, M, NM
+      INTEGER P ( * )
+      DOUBLE PRECISION X ( NMAX )
+      INTEGER IPERM (NMAX) , IER
+      INTEGER I
+
+      NM = N * M 
+
+      DO 1, I=1, NM
+ 1    X(I) = RAND() 
+
+      CALL DPSORT(X, NM, IPERM, 1, IER) 
+
+      DO 2, I = 1, NM
+ 2    P ( I ) = ( IPERM ( I ) - 1 ) / M + 1
+
+
+      RETURN
+      END
+
+
+
+      SUBROUTINE PERMUTATIONS ( M, MMAX, PERM )
+      IMPLICIT NONE
+      INTEGER M, MMAX, MFAC
+      INTEGER PERM ( MMAX, M )
+      INTEGER I, J, A ( M )
+      LOGICAL NEXTP
+      EXTERNAL NEXTP
+
+      MFAC = 1
+      DO 1, I = 1, M
+      A ( I ) = I
+      PERM ( 1, I ) = A ( I )
+      MFAC = MFAC * I
+  1   CONTINUE
+
+      DO 2, I = 2, MFAC
+      IF(NEXTP(M, A)) THEN
+        DO 3, J = 1, M
+  3     PERM ( I, J ) = A ( J )
+      ENDIF
+  2   CONTINUE
+
+      RETURN
+      END
+
+
+C     SUBROUTINE PATTERNS ( CONF, NMAX, N, M, IT, DIST )
+C     IMPLICIT NONE
+C     INTEGER NMAX, N, M,  IT
+C     INTEGER CONF ( NMAX, N ), DIST ( NMAX )
+C     INTEGER A(M)
+C     DOUBLE PRECISION X ( N )
+C     INTEGER PERMUT ( NMAX, N )
+C     INTEGER I, J
+
+C     DO 1, I=1, M
+C     A(I) = I
+C 1   CONTINUE
+
+C     DO 2, I = 1, M
+
+
+C     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
+
+
+
+      FUNCTION NEXTP(N,A)
+      INTEGER N,A,I,J,K,T
+      LOGICAL NEXTP
+      DIMENSION A(N)
+      I=N-1
+   10 IF(A(I).LT.A(I+1)) GO TO 20
+      I=I-1
+      IF(I.EQ.0) GO TO 20
+      GO TO 10
+   20 J=I+1
+      K=N
+   30 T=A(J)
+      A(J)=A(K)
+      A(K)=T
+      J=J+1
+      K=K-1
+      IF(J.LT.K) GO TO 30
+      J=I
+      IF(J.NE.0) GO TO 40
+      NEXTP=.FALSE.
+      RETURN
+   40 J=J+1
+      IF(A(J).LT.A(I)) GO TO 40
+      T=A(I)
+      A(I)=A(J)
+      A(J)=T
+      NEXTP=.TRUE.
+      END
+
+