       PROGRAM PERMPROG2

C   R IS THE NUMBER OF COLORS:  1,2,...,R ARE THE COLORS
C   NUMCOLOR(J) IS THE NUMBER OF INTEGERS OF COLOR J
C   IN THE CURRENT COLORING
C   K IS LENGTH OF PROGRESSION (1 MORE THAN PATTERN LENGTH)

       IMPLICIT NONE  
       INTEGER*2  R,K,MAXLENGTH,NUMBSURV
       PARAMETER (R=4,NUMBSURV=30000,MAXLENGTH=90,K=4)
     
       CHARACTER*16 FILENUM      
       INTEGER*2  ADDPOINT,MAXL,I,J,FLG4444,T,NUMMAXCOLS,X
       INTEGER*2  COLORING(R,MAXLENGTH),NUMUSEDCOLOR(MAXLENGTH)
       INTEGER*2  MAXCOLS(R,MAXLENGTH,NUMBSURV),NUMCOLOR(R)
       INTEGER*2  USEDCOLOR(R,MAXLENGTH),NUMCOLMAX(R,NUMBSURV)
       INTEGER*2  PROG,COLOR,MEMBER,ADDPNTCOLOR(MAXLENGTH)
       INTEGER*2  PATTERN(K-1),ORD(K-1)

       
       FILENUM='4PROG123'

       PATTERN(1)=1
       PATTERN(2)=2
       PATTERN(3)=3
C       PATTERN(4)=3
C       PATTERN(5)=5

       DO I=1,K-1
         DO J=1,K-1
           IF (PATTERN(J).EQ.I) THEN
             ORD(I)=J
           END IF
         END DO
       END DO


       DO J=1,R
          NUMCOLOR(J)=0
       END DO      

       ADDPOINT=1

       MAXL=0


 1111  NUMUSEDCOLOR(ADDPOINT)=0
C       WRITE(0,*) 'ADDPOINT IS' , ADDPOINT

 2222  CALL NEWCOL(COLORING,ADDPOINT,R,MAXLENGTH,K,ORD,
     *USEDCOLOR,NUMUSEDCOLOR,FLG4444,FILENUM,
     *NUMCOLOR,ADDPNTCOLOR)

       IF (FLG4444.EQ.1) THEN
C          WRITE(0,*) 'GOT FLAG4444' 
          GO TO 4444
       END IF

 3333  CALL ACCEPT(COLORING,NUMCOLOR,ADDPOINT,MAXL,MAXCOLS,
     *NUMMAXCOLS,MAXLENGTH,NUMBSURV,FILENUM,R,NUMCOLMAX)

       GO TO 1111

 4444  ADDPOINT=ADDPOINT-1

C       WRITE(0,*) 'JUST DECREASED ADDPOINT TO',ADDPOINT 
C       WRITE(0,*) 'COLORING WAS:', (ADDPNTCOLOR(I),I=1,ADDPOINT+1)
C       WRITE(0,*) 'NUMUSEDCOLORS:' , (NUMUSEDCOLOR(I),I=1,ADDPOINT+1)
C       WRITE(0,*) 'NUMCOLORS: ', (NUMCOLOR(I),I=1,R) 


C   BELOW IF STATEMENT FOR SYMMETRIC PROBLEMS

       IF (ADDPOINT.EQ.1.AND.NUMUSEDCOLOR(1).EQ.1) THEN
          ADDPOINT=0
       END IF

       IF (ADDPOINT.EQ.0) THEN
          OPEN(UNIT=10,FILE=FILENUM)
          WRITE(10,*) 'ANSWER IS F(', K , ')=' , MAXL+1
          WRITE(10,*) 'NUM MAX VALID COLORINGS =' , NUMMAXCOLS
          DO J=1,NUMMAXCOLS
            WRITE(10,*) 'VALID COLORING NUMBER' , J , ': '
            DO X=1,R
              WRITE(10,*) 'COLOR' , X ,': ',(MAXCOLS(X,I,J),I=1,
     *NUMCOLMAX(X,J))
            END DO
            WRITE(10,*) ' '
          END DO
       ELSE
         IF (NUMCOLOR(ADDPNTCOLOR(ADDPOINT)).GE.1) THEN
          NUMCOLOR(ADDPNTCOLOR(ADDPOINT))=
     *NUMCOLOR(ADDPNTCOLOR(ADDPOINT))-1
         END IF
         GO TO 2222
       END IF
       STOP
       END

       SUBROUTINE NEWCOL(COLORING,ADDPOINT,R,MAXLENGTH,K,ORD,
     *USEDCOLOR,NUMUSEDCOLOR,FLG4444,FILENUM,
     *NUMCOLOR,ADDPNTCOLOR)
       IMPLICIT NONE
       INTEGER*2  ADDPOINT,R,MAXLENGTH,J,K,D,L,ORD(K-1)
       INTEGER*2  COLORING(R,MAXLENGTH)
       INTEGER*2  COLOR,PROG,UC(R),I,FLG4444
       INTEGER*2  USEDCOLOR(R,MAXLENGTH),NUMUSEDCOLOR(MAXLENGTH)
       INTEGER*2  MEMBER,NUMCOLOR(R),N
       INTEGER*2  CCLASS(MAXLENGTH),ADDPNTCOLOR(MAXLENGTH)
       CHARACTER*8 FILENUM

  55   N=NUMUSEDCOLOR(ADDPOINT)
       
       IF (N.EQ.R) THEN
         FLG4444=1
         RETURN
       END IF

       IF (N.EQ.0) THEN
          J=1
          GO TO 77
       END IF

       DO I=1,N
          UC(I)=USEDCOLOR(I,ADDPOINT)
       END DO  

       FLG4444=0
       
       J=-1
       DO I=1,R
          IF (MEMBER(I,UC,N).EQ.0) THEN
             J=I
             GO TO 77
          END IF
       END DO
      
  77   IF (J.EQ.-1) THEN
          FLG4444=1
          RETURN
       ELSE
          NUMUSEDCOLOR(ADDPOINT)=N+1
          USEDCOLOR(N+1,ADDPOINT)=J

          DO I=1,NUMCOLOR(J)
            CCLASS(I)=COLORING(J,I)
          END DO

          IF (NUMCOLOR(J).GE.K) THEN
            D=PROG(CCLASS,K,ADDPOINT,R,MAXLENGTH,NUMCOLOR(J),
     *ORD)
          ELSE
            D=0
          END IF
       END IF

       IF (D.EQ.1) THEN
          GO TO 55
       ELSE
          NUMCOLOR(J)=NUMCOLOR(J)+1
          COLORING(J,NUMCOLOR(J))=ADDPOINT
          ADDPNTCOLOR(ADDPOINT)=J
       END IF 
       END

       SUBROUTINE ACCEPT(COLORING,NUMCOLOR,ADDPOINT,MAXL,MAXCOLS,
     *NUMMAXCOLS,MAXLENGTH,NUMBSURV,FILENUM,R,NUMCOLMAX)
       IMPLICIT NONE
       INTEGER*2 ADDPOINT,MAXL,NUMMAXCOLS,MAXLENGTH,NUMBSURV,R
       INTEGER*2 COLORING(R,MAXLENGTH),MAXCOLS(R,MAXLENGTH,NUMBSURV)
       INTEGER*2 J,L,NUMCOLOR(R),NUMCOLMAX(R,NUMBSURV)
       CHARACTER*8 FILENUM

       IF (ADDPOINT.GT.MAXL) THEN
          MAXL=ADDPOINT
          NUMMAXCOLS=1
          DO J=1,R
             NUMCOLMAX(J,1)=NUMCOLOR(J)
             DO L=1,NUMCOLOR(J)
               MAXCOLS(J,L,1)=COLORING(J,L)
             END DO
          END DO
          WRITE(0,*) 'MAXL UP TO' , MAXL
       ELSE
          IF (ADDPOINT.EQ.MAXL) THEN
             IF (NUMMAXCOLS.GE.NUMBSURV) THEN
               WRITE(0,*) 'ERROR:  NUMMAXCOLS TOO BIG'
             END IF 
             NUMMAXCOLS=NUMMAXCOLS+1
             DO J=1,R
               NUMCOLMAX(J,NUMMAXCOLS)=NUMCOLOR(J)
               DO L=1,NUMCOLOR(J)
                 MAXCOLS(J,L,NUMMAXCOLS)=COLORING(J,L)
               END DO
             END DO
          END IF
       END IF

       ADDPOINT=ADDPOINT+1
       END


       INTEGER*2 FUNCTION MEMBER(ELT,LST,LNGTH)
       IMPLICIT NONE
       INTEGER*2 LNGTH,F,ELT,LST(LNGTH)

       DO F=1,LNGTH
            IF (ELT.EQ.LST(F)) THEN
              MEMBER=1
              RETURN
            END IF
       END DO
       MEMBER=0
       RETURN
       END


       INTEGER*2 FUNCTION PROG(CCLASS,K,ADDPOINT,
     *R,MAXLENGTH,NUMCCLASS,ORD)
       IMPLICIT NONE
       INTEGER*2 NUMCCLASS,K,ADDPOINT,R,MAXLENGTH,I1,I2,I3,I4,I5 
       INTEGER*2 CCLASS(MAXLENGTH),G(K-1),ORD(K-1)
       INTEGER*2 I,J

C    ALREADY CHECKED THAT NUMBER OF COLORS IS SUFFICIENT



       IF (K.EQ.3) THEN
         DO I1=1,NUMCCLASS-1
         DO I2=I1+1,NUMCCLASS
           G(1)=CCLASS(I2)-CCLASS(I1)
           G(2)=ADDPOINT-CCLASS(I2)
           IF (G(ORD(1)).LT.G(ORD(2))) THEN
              PROG=1
              RETURN
           END IF
         END DO
         END DO
         PROG=0
         RETURN
       END IF

       IF (K.EQ.4) THEN
         DO I1=1,NUMCCLASS-2
         DO I2=I1+1,NUMCCLASS-1
         DO I3=I2+1,NUMCCLASS
           G(1)=CCLASS(I2)-CCLASS(I1)
           G(2)=CCLASS(I3)-CCLASS(I2)
           G(3)=ADDPOINT-CCLASS(I3)
           IF (G(ORD(1)).LT.G(ORD(2)).AND.
     *G(ORD(2)).LT.G(ORD(3))) THEN
              PROG=1
              RETURN
           END IF
         END DO
         END DO
         END DO
         PROG=0
         RETURN
       END IF

       IF (K.EQ.5) THEN
         DO I1=1,NUMCCLASS-3
         DO I2=I1+1,NUMCCLASS-2
         DO I3=I2+1,NUMCCLASS-1
         DO I4=I3+1,NUMCCLASS
           G(1)=CCLASS(I2)-CCLASS(I1)
           G(2)=CCLASS(I3)-CCLASS(I2)
           G(3)=CCLASS(I4)-CCLASS(I3)
           G(4)=ADDPOINT-CCLASS(I4)      
           IF (G(ORD(1)).LT.G(ORD(2)).AND.
     *G(ORD(2)).LT.G(ORD(3)).AND.
     *G(ORD(3)).LT.G(ORD(4))) THEN
              PROG=1
              RETURN
           END IF
         END DO
         END DO
         END DO
         END DO
         PROG=0
         RETURN
       END IF

       IF (K.EQ.6) THEN
         DO I1=1,NUMCCLASS-4
         DO I2=I1+1,NUMCCLASS-3
         DO I3=I2+1,NUMCCLASS-2
         DO I4=I3+1,NUMCCLASS-1
         DO I5=I4+1,NUMCCLASS
           G(1)=CCLASS(I2)-CCLASS(I1)
           G(2)=CCLASS(I3)-CCLASS(I2)
           G(3)=CCLASS(I4)-CCLASS(I3)
           G(4)=CCLASS(I5)-CCLASS(I4)
           G(5)=ADDPOINT-CCLASS(I5)      
           IF (G(ORD(1)).LT.G(ORD(2)).AND.
     *G(ORD(2)).LT.G(ORD(3)).AND.
     *G(ORD(3)).LT.G(ORD(4)).AND.
     *G(ORD(4)).LT.G(ORD(5))) THEN
              PROG=1
              RETURN
           END IF
         END DO
         END DO
         END DO
         END DO
         END DO
         PROG=0
         RETURN
       END IF


       RETURN
       END
