      PROGRAM ca2
      IMPLICIT NONE
      INTEGER L, cell(50,50), update(0:511), IR_, k
      CHARACTER flag*80
      LOGICAL Ltmp1_, Ltmp2_, TBkeyinput
      CALL GWopen(IR_, 0)
      CALL setrule(update,L)
      flag = ''
      Ltmp1_ = .TRUE.
      DO WHILE(Ltmp1_)
         CALL initial(cell,L)
         Ltmp2_ = .TRUE.
         DO WHILE(Ltmp2_)
            CALL iterate(cell,update,L)
            IF(TBkeyinput()) THEN
               CALL TBgetkey(k)
               IF((k .EQ. ICHAR('s')) .OR. (k .EQ. ICHAR('S')))
     +            flag = 'stop'
            END IF
            Ltmp2_ = k .EQ. 0
         END DO
         k = 0
         Ltmp1_ = (flag .NE. 'stop')
      END DO
      CALL GWquit(IR_)
      END
C
      SUBROUTINE setrule(update,L)
*     rule for Game of Life
      IMPLICIT NONE
      CHARACTER Stmp1_*80
      REAL xwin, ywin
      INTEGER nn1, nn2, nn3, update(0:511), L
      INTEGER IR_, i, index
      DO i = 0, 511
         update(i) = 0
      END DO
*     three neighbors alive
      DO nn1 = 0, 5
         DO nn2 = nn1+1, 6
            DO nn3 = nn2+1, 7
               index = 2**nn1 + 2**nn2 + 2**nn3
               update(index) = 1            ! center dead
               update(index+256) = 1        ! center alive
            END DO
         END DO
      END DO
*     two neighbors and center alive
      DO nn1 = 0, 6
         DO nn2 = nn1+1, 7
            index = 256 + 2**nn1 + 2**nn2
            update(index) = 1
         END DO
      END DO
      CALL GWcolor(IR_, 0, 2)
      CALL GWcolor(IR_, 19, 7)
      CALL GWinput(IR_, 'lattice size = ', Stmp1_)
      IF(IR_ .NE. 0) THEN
         READ(Stmp1_,*) L
      ELSE
         L = 20
      ENDIF
      CALL compute_aspect_ratio(REAL(L),xwin,ywin)
      CALL GWindow(IR_, -0.2*xwin, -0.2*ywin, 1.2*xwin, 1.2*ywin)
      END
C
      SUBROUTINE initial(cell,L)
      IMPLICIT NONE
      REAL x, y
      INTEGER IR_, i, j, cell(50,50), L, YELLOW, BLUE
      LOGICAL Ltmp1_
      PARAMETER(YELLOW = 15, BLUE = 16)
      CALL GWclear(IR_, -1)
      CALL GWsetpen(IR_, 0, -1, -1, 4)
      CALL GWcmbmrk(IR_, 1, 5, 1.0, YELLOW, -1, 4);
      CALL GWcmbmrk(IR_, 2, 5, 1.0, BLUE, -1, 4);
      DO i = 1, L
         DO j = 1, L
            cell(i,j) = 0
            CALL GWsetogn(IR_, 0, j*L+i);
            CALL GWputcmb(IR_, 1, REAL(i), REAL(j), 1.0, 1.0, 0);
         END DO
      END DO
*     SET CURSOR 1,1
*     click on cell to change its state or outside of lattice
*     to update cells
      Ltmp1_ = .TRUE.
      DO WHILE(Ltmp1_)
         CALL GWcappnt(IR_, x, y, 
     +   'click on cell to toggle or outside of lattice to continue.')
         IF(x .GT. 0.5 .AND. x .LT. L + 0.5 .AND. y .GT. 0.5 .AND. 
     +      y .LT. L + 0.5) THEN
            i = int(x + 0.5)
            j = int(y + 0.5)
            CALL GWerase(IR_, j*L+i, 0);
            CALL GWsetogn(IR_, 0, j*L+i);
            IF(cell(i,j) .EQ. 0) THEN
               CALL GWputcmb(IR_, 2, REAL(i), REAL(j), 1.0, 1.0, 0);
               cell(i,j) = 1
            ELSE
               CALL GWputcmb(IR_, 1, REAL(i), REAL(j), 1.0, 1.0, 0);
               cell(i,j) = 0
            END IF
         END IF
         Ltmp1_ = 
     +      .NOT.(x .LT. 1 .OR. x .GT. L .OR. y .LT. 1 .OR. y .GT. L)
      END DO
      CALL GWsetmsg(IR_, 'Hit any key for new lattice, ''s'' to stop')
      END
C
      SUBROUTINE iterate(cell,update,L)
      IMPLICIT NONE
      INTEGER cellnew(50,50), cell(50,50), update(0:511), L
      INTEGER IR_, i, j, k, sum
      DATA sum/0/
      DO i = 1, L
         DO j = 1, L
            cellnew(i, j) = 0
         END DO
      END DO
      DO i = 1, L
         DO j = 1, L
            CALL neighborhood(cell,i,j,sum,L)
            cellnew(i,j) = update(sum)
            IF(cell(i,j) .EQ. 1 .AND. cellnew(i,j) .EQ. 0) THEN
               k = 1
            ELSE IF(cell(i,j) .EQ. 0 .AND. cellnew(i,j) .EQ. 1) THEN
               k = 2
            ELSE
               k = 0
            END IF
            IF(k .GT. 0) THEN
               CALL GWerase(IR_, j*L+i, 0);
               CALL GWsetogn(IR_, 0, j*L+i);
               CALL GWputcmb(IR_, k, REAL(i), REAL(j), 1.0, 1.0, 0);
            END IF
         END DO
      END DO
      DO i = 1, L
         DO j = 1, L
            cell(i, j) = cellnew(i, j)
         END DO
      END DO
      END
C
      SUBROUTINE neighborhood(cell,i,j,sum,L)
      IMPLICIT NONE
      INTEGER cell(50,50), L
      INTEGER im, ip, jm, jp, i, j, sum
      ip = i + 1
      im = i - 1
      jp = j + 1
      jm = j - 1
      IF(i .EQ. 1) THEN
         im = L
      ELSE IF(i .EQ. L) THEN
         ip = 1
      END IF
      IF(j .EQ. 1) THEN
         jm = L
      ELSE IF(j .EQ. L) THEN
         jp = 1
      END IF
      sum = cell(i,jp) + 2*cell(i,jm) + 4*cell(im,j)
      sum = sum + 8*cell(ip,j)+ 16*cell(ip,jp) + 32*cell(ip,jm)
      sum = sum + 64*cell(im,jp) + 128*cell(im,jm) + 256*cell(i,j)
      END
