AoC 2018 Day21 FORTRAN

PROGRAM DAY21
  IMPLICIT NONE
  TYPE OP
     PROCEDURE(), POINTER, NOPASS :: P
     INTEGER(8) :: ARGS(3)
  END TYPE OP
  INTEGER(8), TARGET :: REGISTERS(0:5)=0
  INTEGER :: I,J,K,IERR,ANSWER
  INTEGER(8), POINTER :: INSTRUCTION
  CHARACTER(LEN=4) :: INLINE
  TYPE(OP), ALLOCATABLE :: PROG(:)
  INTEGER(8),ALLOCATABLE:: PREVIOUS(:,:)
  OPEN(1,FILE='input.txt')
  I=-1
  DO
     READ(1,*,IOSTAT=IERR)
     IF(IERR.NE.0)EXIT
     I=I+1
  END DO
  REWIND(1)
  READ(1,*)INLINE,J
  INSTRUCTION=>REGISTERS(J)
  ALLOCATE(PROG(0:I-1))
  DO J=0,I-1
     READ(1,*)INLINE,PROG(J)%ARGS
     SELECT CASE(INLINE)
     CASE('addr')
        PROG(J)%P=>ADDR
     CASE('addi')
        PROG(J)%P=>ADDI
     CASE('mulr')
        PROG(J)%P=>MULR
     CASE('muli')
        PROG(J)%P=>MULI
     CASE('banr')
        PROG(J)%P=>BANR
     CASE('bani')
        PROG(J)%P=>BANI
     CASE('borr')
        PROG(J)%P=>BORR
     CASE('bori')
        PROG(J)%P=>BORI
     CASE('setr')
        PROG(J)%P=>SETR
     CASE('seti')
        PROG(J)%P=>SETI
     CASE('gtir')
        PROG(J)%P=>GTIR
     CASE('gtri')
        PROG(J)%P=>GTRI
     CASE('gtrr')
        PROG(J)%P=>GTRR
     CASE('eqir')
        PROG(J)%P=>EQIR
     CASE('eqri')
        PROG(J)%P=>EQRI
     CASE('eqrr')
        PROG(J)%P=>EQRR
     END SELECT
  END DO
  REGISTERS=0
  I=2
  ALLOCATE(PREVIOUS(0:5,15000))
  ANSWER=PROG(28)%ARGS(1)
  PREVIOUS=0
  DO
     IF(INSTRUCTION.EQ.28)THEN
        IF(I.EQ.2)WRITE(*,'("Part 1: ",I0)')REGISTERS(ANSWER)
        IF(I>SIZE(PREVIOUS,DIM=2))CALL EXTEND()
        IF(ANY((/(ALL(PREVIOUS(:,J).EQ.REGISTERS),J=1,I-1)/)))EXIT
        PREVIOUS(:,I)=REGISTERS
        I=I+1
     END IF
     CALL PROG(INSTRUCTION)%P(PROG(INSTRUCTION)%ARGS(1),PROG(INSTRUCTION)%ARGS(2),PROG(INSTRUCTION)%ARGS(3))
     INSTRUCTION=INSTRUCTION+1
  END DO
  DO
     I=I-1
     IF(ANY(PREVIOUS(ANSWER,1:I-1).EQ.PREVIOUS(ANSWER,I)))CYCLE
     WRITE(*,'("Part 2: ",I0)')PREVIOUS(ANSWER,I)
     EXIT
  END DO

CONTAINS
  SUBROUTINE EXTEND()
    INTEGER(8),ALLOCATABLE :: BACKUP(:,:)
    ALLOCATE(BACKUP(5,SIZE(PREVIOUS,DIM=2)+1000))
    BACKUP=0
    BACKUP(:,1:SIZE(PREVIOUS,DIM=2))=PREVIOUS
    DEALLOCATE(PREVIOUS)
    ALLOCATE(PREVIOUS(0:5,SIZE(BACKUP,DIM=2)))
    PREVIOUS=BACKUP
    DEALLOCATE(BACKUP)
  END SUBROUTINE EXTEND
  SUBROUTINE ADDR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=REGISTERS(A)+REGISTERS(B)
  END SUBROUTINE ADDR
  SUBROUTINE ADDI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=REGISTERS(A)+B
  END SUBROUTINE ADDI
  SUBROUTINE MULR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=REGISTERS(A)*REGISTERS(B)
  END SUBROUTINE MULR
  SUBROUTINE MULI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=REGISTERS(A)*B
  END SUBROUTINE MULI
  SUBROUTINE BANR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=IAND(REGISTERS(A),REGISTERS(B))
  END SUBROUTINE BANR
  SUBROUTINE BANI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=IAND(REGISTERS(A),B)
  END SUBROUTINE BANI
  SUBROUTINE BORR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=IOR(REGISTERS(A),REGISTERS(B))
  END SUBROUTINE BORR
  SUBROUTINE BORI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=IOR(REGISTERS(A),B)
  END SUBROUTINE BORI
  SUBROUTINE SETR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=REGISTERS(A)
  END SUBROUTINE SETR
  SUBROUTINE SETI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=A
  END SUBROUTINE SETI
  SUBROUTINE GTIR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    REGISTERS(C)=0
    IF(A>REGISTERS(B))THEN
       REGISTERS(C)=1
    ELSE
       REGISTERS(C)=0
    END IF
  END SUBROUTINE GTIR
  SUBROUTINE GTRI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    IF(REGISTERS(A)>B)THEN
       REGISTERS(C)=1
    ELSE
       REGISTERS(C)=0
    END IF
  END SUBROUTINE GTRI
  SUBROUTINE GTRR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    IF(REGISTERS(A)>REGISTERS(B))THEN
       REGISTERS(C)=1
    ELSE
       REGISTERS(C)=0
    END IF
  END SUBROUTINE GTRR
  SUBROUTINE EQIR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    IF(A.EQ.REGISTERS(B))THEN
       REGISTERS(C)=1
    ELSE
       REGISTERS(C)=0
    END IF
  END SUBROUTINE EQIR
  SUBROUTINE EQRI(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    IF(REGISTERS(A).EQ.B)THEN
       REGISTERS(C)=1
    ELSE
       REGISTERS(C)=0
    END IF
  END SUBROUTINE EQRI
  SUBROUTINE EQRR(A,B,C)
    INTEGER, INTENT(IN) :: A,B,C
    IF(REGISTERS(A).EQ.REGISTERS(B))THEN
       REGISTERS(C)=1
    ELSE
       REGISTERS(C)=0
    END IF
  END SUBROUTINE EQRR
END PROGRAM DAY21