AoC 2018 Day16 FORTRAN

PROGRAM DAY16
  IMPLICIT NONE
  TYPE OP
     PROCEDURE(), POINTER, NOPASS :: P
  END TYPE OP
  INTEGER :: REGISTERS(0:3)=0,MAP(0:15)
  INTEGER :: I,J,K,L,M,N,O,IERR
  CHARACTER(LEN=20) :: INLINE
  TYPE(OP) :: OPS(0:15)
  INTEGER, ALLOCATABLE :: PART1(:,:,:),PART2(:,:)
  LOGICAL :: OPCODES(0:15,0:15)
  OPS(0)%P=>ADDR
  OPS(1)%P=>ADDI
  OPS(2)%P=>MULR
  OPS(3)%P=>MULI
  OPS(4)%P=>BANR
  OPS(5)%P=>BANI
  OPS(6)%P=>BORR
  OPS(7)%P=>BORI
  OPS(8)%P=>SETR
  OPS(9)%P=>SETI
  OPS(10)%P=>GTIR
  OPS(11)%P=>GTRI
  OPS(12)%P=>GTRR
  OPS(13)%P=>EQIR
  OPS(14)%P=>EQRI
  OPS(15)%P=>EQRR

  OPEN(1,FILE='input.txt')
  I=0
  J=0
  DO
     READ(1,'(A)')INLINE
     IF(TRIM(INLINE).EQ.'')EXIT
     READ(1,*)
     READ(1,*)
     READ(1,*)
     I=I+1
  END DO
  READ(1,*)
  DO
     READ(1,*,IOSTAT=IERR)
     IF(IERR.NE.0)EXIT
     J=J+1
  END DO
  REWIND(1)
  ALLOCATE(PART1(4,3,I),PART2(4,J))
  PART1=0
  PART2=0
  DO K=1,I
     READ(1,'(A)')INLINE
     READ(INLINE(10:19),*)PART1(:,1,K)
     READ(1,*)PART1(:,2,K)
     READ(1,'(A)')INLINE
     READ(INLINE(10:19),*)PART1(:,3,K)
     READ(1,*)
  END DO
  READ(1,*)
  READ(1,*)
  READ(1,*)PART2

  N=0
  OPCODES=.TRUE.
  DO K=1,I
     L=0
     DO M=0,15
        REGISTERS=PART1(:,1,K)
        CALL OPS(M)%P(PART1(2,2,K),PART1(3,2,K),PART1(4,2,K))
        IF(ALL(REGISTERS-PART1(:,3,K).EQ.0))THEN
           L=L+1
        ELSE
           OPCODES(PART1(1,2,K),M)=.FALSE.
        END IF
     END DO
     IF(L.GE.3)N=N+1
  END DO
  WRITE(*,'("Part 1: ",I0)')N

  DO
     DO K=0,15
        DO L=0,15
           IF(.NOT.OPCODES(L,K))CYCLE
           IF(COUNT(OPCODES(:,K)).EQ.1)OPCODES(L,:)=.FALSE.
           OPCODES(L,K)=.TRUE.
           IF(COUNT(OPCODES(L,:)).EQ.1)OPCODES(:,K)=.FALSE.
           OPCODES(L,K)=.TRUE.
        END DO
     END DO
     IF(COUNT(OPCODES).EQ.16)EXIT
  END DO
  DO K=0,15
     DO L=0,15
        IF(OPCODES(L,K))MAP(L)=K
     END DO
  END DO

  REGISTERS=0
  DO I=1,J
     CALL OPS(MAP(PART2(1,I)))%P(PART2(2:,I),PART2(3,I),PART2(4,I))
  END DO
  WRITE(*,'("Part 2: ",I0)')REGISTERS(0)

CONTAINS
  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 DAY16