AoC 2019 Day7 FORTRAN

PROGRAM DAY7
  ! Run with mpirun -np 6 ./day7
  USE MPI
  TYPE OP
     PROCEDURE(), POINTER, NOPASS :: OP
     INTEGER :: NARGS
  END TYPE OP
  INTEGER :: I,N,IERR,MODES,OPCODE,A,B,C,D,E,PART1,PART2,RES
  INTEGER :: LASTOUT
  CHARACTER(LEN=1) CHAR
  INTEGER, ALLOCATABLE :: PROG(:),STOREDPROG(:)
  TYPE(OP) :: OPS(8)
  INTEGER :: IERROR, NPROC, ICOMM, IRANK,SENDTO(5),RECVFROM(5)
  LOGICAL :: AMROOT,RUNNING,SETUP,FIRST
  INTEGER :: STATUS(MPI_STATUS_SIZE)

  CALL MPI_INIT(IERROR)
  ICOMM = MPI_COMM_WORLD
  CALL MPI_COMM_SIZE(ICOMM,NPROC,IERROR)
  CALL MPI_COMM_RANK(ICOMM, IRANK, IERROR)
  AMROOT = IRANK.EQ.0

  IF(AMROOT)THEN
     OPEN(1,FILE="input.txt")
     N=1
     DO
        READ(1,'(A1)',IOSTAT=IERR,ADVANCE="NO")CHAR
        IF(IERR.NE.0)EXIT
        IF(CHAR.EQ.",")N=N+1
     END DO
     REWIND(1)
     ALLOCATE(PROG(0:N-1))
     READ(1,*)PROG
     DO I=1,NPROC-1
        CALL MPI_SEND(N,1,MPI_INTEGER,I,0,ICOMM,IERROR)
        CALL MPI_SEND(PROG,N,MPI_INTEGER,I,1,ICOMM,IERROR)
     END DO
     PART1=0
     DO A=0,4
        DO B=0,4
           IF(B.EQ.A)CYCLE
           DO C=0,4
              IF(ANY((/A,B/).EQ.C))CYCLE
              DO D=0,4
                 IF(ANY((/A,B,C/).EQ.D))CYCLE
                 DO E=0,4
                    IF(ANY((/A,B,C,D/).EQ.E))CYCLE
                    CALL MPI_SEND(A,1,MPI_INTEGER,1,2,ICOMM,IERROR)
                    CALL MPI_SEND(0,1,MPI_INTEGER,1,3,ICOMM,IERROR)
                    CALL MPI_SEND(B,1,MPI_INTEGER,2,2,ICOMM,IERROR)
                    CALL MPI_SEND(C,1,MPI_INTEGER,3,2,ICOMM,IERROR)
                    CALL MPI_SEND(D,1,MPI_INTEGER,4,2,ICOMM,IERROR)
                    CALL MPI_SEND(E,1,MPI_INTEGER,5,2,ICOMM,IERROR)
                    CALL MPI_RECV(RES,1,MPI_INTEGER,5,999,ICOMM,STATUS,IERROR)
                    PART1=MAX(PART1,RES)
                 END DO
              END DO
           END DO
        END DO
     END DO
     PART2=0
     DO A=5,9
        DO B=5,9
           IF(B.EQ.A)CYCLE
           DO C=5,9
              IF(ANY((/A,B/).EQ.C))CYCLE
              DO D=5,9
                 IF(ANY((/A,B,C/).EQ.D))CYCLE
                 DO E=5,9
                    IF(ANY((/A,B,C,D/).EQ.E))CYCLE
                    CALL MPI_SEND(A,1,MPI_INTEGER,1,2,ICOMM,IERROR)
                    CALL MPI_SEND(0,1,MPI_INTEGER,1,3,ICOMM,IERROR)
                    CALL MPI_SEND(B,1,MPI_INTEGER,2,2,ICOMM,IERROR)
                    CALL MPI_SEND(C,1,MPI_INTEGER,3,2,ICOMM,IERROR)
                    CALL MPI_SEND(D,1,MPI_INTEGER,4,2,ICOMM,IERROR)
                    CALL MPI_SEND(E,1,MPI_INTEGER,5,2,ICOMM,IERROR)
                    CALL MPI_RECV(RES,1,MPI_INTEGER,5,999,ICOMM,STATUS,IERROR)
                    PART2=MAX(PART2,RES)
                 END DO
              END DO
           END DO
        END DO
     END DO
     WRITE(*,'("Part 1: ",I0)') PART1
     WRITE(*,'("Part 2: ",I0)') PART2
     CALL MPI_SEND(-1,1,MPI_INTEGER,1,2,ICOMM,IERROR)
     CALL MPI_SEND(-1,1,MPI_INTEGER,2,2,ICOMM,IERROR)
     CALL MPI_SEND(-1,1,MPI_INTEGER,3,2,ICOMM,IERROR)
     CALL MPI_SEND(-1,1,MPI_INTEGER,4,2,ICOMM,IERROR)
     CALL MPI_SEND(-1,1,MPI_INTEGER,5,2,ICOMM,IERROR)
  ELSE
     OPS(1)%NARGS=3
     OPS(1)%OP => ADD
     OPS(2)%NARGS=3
     OPS(2)%OP => MULTIPLY
     OPS(3)%NARGS=1
     OPS(3)%OP => INPUT
     OPS(4)%NARGS=1
     OPS(4)%OP => OUTPUT
     OPS(5)%NARGS=2
     OPS(5)%OP => JUMP_IF_TRUE
     OPS(6)%NARGS=2
     OPS(6)%OP => JUMP_IF_FALSE
     OPS(7)%NARGS=3
     OPS(7)%OP => LESS_THAN
     OPS(8)%NARGS=3
     OPS(8)%OP => EQUALS
     SENDTO=(/2,3,4,5,1/)
     RECVFROM=(/5,1,2,3,4/)
     CALL MPI_RECV(N,1,MPI_INTEGER,0,0,ICOMM,STATUS,IERROR)
     ALLOCATE(PROG(0:N),STOREDPROG(0:N))
     CALL MPI_RECV(STOREDPROG,N,MPI_INTEGER,0,1,ICOMM,STATUS,IERROR)
     RUNNING=.TRUE.
     OUTER:DO
        FIRST=.TRUE.
        PROG=STOREDPROG
        SETUP=.TRUE.
        I=0
        DO
           IF(.NOT.RUNNING)EXIT OUTER
           MODES=PROG(I)/100
           OPCODE=MODULO(PROG(I),100)
           IF(OPCODE.EQ.99)EXIT
           CALL OPS(OPCODE)%OP(MODES,PROG(I+1:I+OPS(OPCODE)%NARGS),I)
        END DO
        IF(IRANK.EQ.5) CALL MPI_SEND(LASTOUT,1,MPI_INTEGER,0,999,ICOMM,IERROR)
        IF(IRANK.EQ.1) CALL MPI_RECV(LASTOUT,1,MPI_INTEGER,5,3,ICOMM,STATUS,IERROR)
     END DO OUTER
  END IF
  CALL MPI_FINALIZE(IERROR)

CONTAINS
  SUBROUTINE ADD(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(3)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I
    I=I+4

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    PROG(PARAMS(3))=A+B
  END SUBROUTINE ADD

  SUBROUTINE MULTIPLY(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(3)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I
    I=I+4

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    PROG(PARAMS(3))=A*B
  END SUBROUTINE MULTIPLY

  SUBROUTINE INPUT(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(3)
    INTEGER :: A
    INTEGER, INTENT(INOUT) :: I
    I=I+2
    IF(SETUP)THEN
       CALL MPI_RECV(A,1,MPI_INTEGER,0,2,ICOMM,STATUS,IERROR)
       IF(A<0)RUNNING=.FALSE.
       SETUP=.FALSE.
    ELSE
       IF(FIRST.AND.IRANK.EQ.1)THEN
          CALL MPI_RECV(A,1,MPI_INTEGER,0,3,ICOMM,STATUS,IERROR)
          FIRST=.FALSE.
       ELSE
          CALL MPI_RECV(A,1,MPI_INTEGER,RECVFROM(IRANK),3,ICOMM,STATUS,IERROR)
       END IF
    END IF
    PROG(PARAMS(1))=A
  END SUBROUTINE INPUT

  SUBROUTINE OUTPUT(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(3)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I
    I=I+2

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    CALL MPI_SEND(A,1,MPI_INTEGER,SENDTO(IRANK),3,ICOMM,IERROR)
    LASTOUT=A
  END SUBROUTINE OUTPUT

  SUBROUTINE JUMP_IF_TRUE(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(2)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    IF(A.NE.0)THEN
       I=B
    ELSE
       I=I+3
    END IF
  END SUBROUTINE JUMP_IF_TRUE

  SUBROUTINE JUMP_IF_FALSE(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(2)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    IF(A.EQ.0)THEN
       I=B
    ELSE
       I=I+3
    END IF
  END SUBROUTINE JUMP_IF_FALSE

  SUBROUTINE LESS_THAN(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(3)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I
    I=I+4

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    IF(A<B)THEN
       PROG(PARAMS(3))=1
    ELSE
       PROG(PARAMS(3))=0
    END IF
  END SUBROUTINE LESS_THAN

  SUBROUTINE EQUALS(MODES,PARAMS,I)
    INTEGER, INTENT(IN) :: MODES, PARAMS(3)
    INTEGER :: A,B
    INTEGER, INTENT(INOUT) :: I
    I=I+4

    IF(MODULO(MODES,10).EQ.0)THEN
       A=PROG(PARAMS(1))
    ELSE
       A=PARAMS(1)
    END IF
    IF(MODULO(MODES,100)/10.EQ.0)THEN
       B=PROG(PARAMS(2))
    ELSE
       B=PARAMS(2)
    END IF
    IF(A.EQ.B)THEN
       PROG(PARAMS(3))=1
    ELSE
       PROG(PARAMS(3))=0
    END IF
  END SUBROUTINE EQUALS

END PROGRAM DAY7