PROGRAM HJSQR

C   HJS(K) = MIN INTEGER SUCH THAT EVERY 2-COLORING
C   ADMITS A MONOCHROMATIC K-TERM PROGRESSION OF
C   FORM A + X^2 I + (K-1-X)^2 J, FOR X=0...K-1
C   SOME I,J WITH I ≥ 1, J ≥0 

C   RED is first color
C   BLUE is second color

C   NUMCOLOR(J) IS THE NUMBER OF INTEGERS OF COLOR J
C   IN THE CURRENT COLORING

       IMPLICIT NONE  
       INTEGER*2  K,MAXLENGTH
       INTEGER*4  NUMBSURV
       PARAMETER (K=6,NUMBSURV=1000,MAXLENGTH=500)
     
       CHARACTER*8 FILENUM      
       INTEGER*2  ADDPOINT,MAXL,I,J,FLG4444,NUMMAXCOLS,X
       INTEGER*2  COLORING(2,MAXLENGTH),NUMUSEDCOLOR(MAXLENGTH)
       INTEGER*2  MAXCOLS(2,MAXLENGTH,NUMBSURV),NUMCOLOR(2)
       INTEGER*2  NUMCOLMAX(2,NUMBSURV),PROGTEST,MEMBER
       INTEGER*2  ADDPNTCOLOR(MAXLENGTH),DIFFTEST
       
       FILENUM='HJ6'

       DO J=1,2
          NUMCOLOR(J)=0
       END DO      
       ADDPOINT=1
       MAXL=0

 1111  NUMUSEDCOLOR(ADDPOINT)=0

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

C   FLAG4444=1 MEANS NO COLOR LEFT TO TRY FOR ADDPOINT SO BACKUP

       IF (FLG4444.EQ.1) THEN
          GO TO 4444
       END IF

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

       GO TO 1111

 4444  ADDPOINT=ADDPOINT-1

       IF (ADDPOINT.EQ.0) THEN
          OPEN(UNIT=10,FILE=FILENUM)
          WRITE(10,*) 'ANSWER IS M(',K,')=' , MAXL+1
          WRITE(10,*) 'NUM MAX VALID COLORINGS =' , NUMMAXCOLS
          DO J=1,NUMMAXCOLS
            WRITE(10,*) 'VALID COLORING NUMBER' , J , ': '
               DO X=1,2
                 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,MAXLENGTH,K,
     *NUMUSEDCOLOR,FLG4444,FILENUM,NUMCOLOR,ADDPNTCOLOR)

       IMPLICIT NONE
       INTEGER*2  ADDPOINT,MAXLENGTH,J,NC,K,D,N
       INTEGER*2  COLORING(2,MAXLENGTH),DIFFTEST
       INTEGER*2  I,FLG4444,NUMUSEDCOLOR(MAXLENGTH) 
       INTEGER*2  CCLASS(MAXLENGTH),MEMBER,NUMCOLOR(2)
       INTEGER*2  ADDPNTCOLOR(MAXLENGTH),PROGTEST
       CHARACTER*8 FILENUM

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

       FLG4444=0

       J=N+1
       NUMUSEDCOLOR(ADDPOINT)=J

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

C          OPEN(UNIT=10,FILE=FILENUM)
C          WRITE(10,*) 'J AND ADDPOINT:' , J, ADDPOINT 
     
       D=PROGTEST(CCLASS,ADDPOINT,MAXLENGTH,NUMCOLOR(J),K)
         
         OPEN(UNIT=10,FILE=FILENUM)
C          WRITE(10,*) 'NUMCOLOR(J):', NUMCOLOR(J)
C          WRITE(10,*) 'CCLASS' , (CCLASS(I),I=1,NUMCOLOR(J)) 

       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,NUMCOLMAX)
       IMPLICIT NONE
       INTEGER*4 NUMBSURV
       INTEGER*2 ADDPOINT,MAXL,NUMMAXCOLS,MAXLENGTH
       INTEGER*2 COLORING(2,MAXLENGTH),MAXCOLS(2,MAXLENGTH,NUMBSURV)
       INTEGER*2 J,L,NUMCOLOR(2),NUMCOLMAX(2,NUMBSURV)
       CHARACTER*8 FILENUM

       IF (ADDPOINT.GT.MAXL) THEN
          MAXL=ADDPOINT
          NUMMAXCOLS=1
          DO J=1,2
             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,2
               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

C      MEMBER FUNCTION ASSUMES LST IS AN INCREASING LIST
       INTEGER*2 FUNCTION MEMBER(ELT,LST,LNGTH)
       IMPLICIT NONE
       INTEGER*2 LNGTH,F,ELT,LST(LNGTH)

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





       INTEGER*2 FUNCTION PROGTEST(CCLASS,ADDPOINT,
     *MAXLENGTH,NUMCCLASS,K)
       IMPLICIT NONE
       INTEGER*2 NUMCCLASS,ADDPOINT,MAXLENGTH,MEMBER,I,J,D 
       INTEGER*2 CCLASS(MAXLENGTH),E,K,CRNT,CNT,FLG,A,X,B

       IF (NUMCCLASS.LT.K-1) THEN
          PROGTEST=0
          RETURN 
       END IF

       B=ADDPOINT/((K-1)**2)

       IF (B.LT.1) THEN
          PROGTEST=0
          RETURN
       END IF
 
       DO I=1,B
         DO J=0,B-I
           A=-1
             IF (I.LE.J) THEN
               IF (ADDPOINT.GT.J*(K-1)**2) THEN
                 A=ADDPOINT-J*(K-1)**2
               END IF
             ELSE
               IF (ADDPOINT.GT.I*(K-1)**2) THEN
                 A=ADDPOINT-I*(K-1)**2
               END IF
             END IF

          IF (A.GT.0) THEN

          FLG=0
          X=0 
          CNT=1 
          DO WHILE(FLG.EQ.0)
            IF (X.LT.K) THEN 
              CRNT=A+I*X**2+J*(K-1-X)**2
              IF (MEMBER(CRNT,CCLASS,NUMCCLASS).EQ.1) THEN
                CNT=CNT+1
                X=X+1
              ELSE
                FLG=1
              END IF
          
              IF (CNT.EQ.K) THEN
                PROGTEST=1
                RETURN
              END IF
            ELSE
              FLG=1
            END IF
          END DO
                  
          END IF

         END DO
       END DO

       PROGTEST=0
       RETURN
       END