AoC 2018 Day19 FORTRAN

PROGRAM DAY19
  IMPLICIT NONE
  TYPE OP
     PROCEDURE(), POINTER, NOPASS :: P
     INTEGER :: ARGS(3)
  END TYPE OP
  INTEGER, TARGET :: REGISTERS(0:5)=0
  INTEGER :: I,J,K,IERR
  INTEGER, POINTER :: INSTRUCTION
  CHARACTER(LEN=4) :: INLINE
  TYPE(OP), ALLOCATABLE :: PROG(:)

  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
  DO
     IF((INSTRUCTION.LT.0).OR.(INSTRUCTION.GT.UBOUND(PROG,DIM=1)))EXIT
     IF(INSTRUCTION.EQ.1)EXIT
     CALL PROG(INSTRUCTION)%P(PROG(INSTRUCTION)%ARGS(1),PROG(INSTRUCTION)%ARGS(2),PROG(INSTRUCTION)%ARGS(3))
     INSTRUCTION=INSTRUCTION+1
  END DO
  I=REGISTERS(PROG(4)%ARGS(2))
  K=0
  DO J=1,FLOOR(SQRT(REAL(I)))
     IF(MODULO(I,J).EQ.0)K=K+J+I/J
  END DO
  WRITE(*,'("Part 1: ",i0)')K
  REGISTERS=0
  REGISTERS(0)=1
  DO
     IF((INSTRUCTION.LT.0).OR.(INSTRUCTION.GT.UBOUND(PROG,DIM=1)))EXIT
     IF(INSTRUCTION.EQ.1)EXIT
     CALL PROG(INSTRUCTION)%P(PROG(INSTRUCTION)%ARGS(1),PROG(INSTRUCTION)%ARGS(2),PROG(INSTRUCTION)%ARGS(3))
     INSTRUCTION=INSTRUCTION+1
  END DO
  I=REGISTERS(PROG(4)%ARGS(2))
  K=0
  DO J=1,FLOOR(SQRT(REAL(I)))
     IF(MODULO(I,J).EQ.0)K=K+J+I/J
  END DO
  WRITE(*,'("Part 2: ",i0)')K
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
    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 DAY19