AoC 2019 Day9 FORTRAN (intcode)

PROGRAM INTCODE
  USE MPI
  TYPE NODE
     INTEGER(8) :: VAL
     INTEGER(8) :: LOCATION
     TYPE(NODE),POINTER :: NEXT
  END TYPE NODE
  TYPE OP
     PROCEDURE(), POINTER, NOPASS :: OP
     INTEGER :: NARGS
  END TYPE OP
  INTEGER(8) :: I,IERR,MODES,OPCODE,A,B,C,D,E,PART1,PART2,RES,J
  INTEGER :: N
  INTEGER(8) :: LASTOUT,INSTR
  CHARACTER(LEN=1) CHAR
  TYPE(NODE),TARGET,ALLOCATABLE :: PROG(:)
  INTEGER, ALLOCATABLE :: STOREDPROG(:)
  TYPE(OP) :: OPS(9)
  INTEGER :: IERROR, NPROC, ICOMM, IRANK,PARENT,REQUEST
  INTEGER(8) :: RELBASE
  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)
  CALL MPI_COMM_GET_PARENT(PARENT, IERROR)
  AMROOT = IRANK.EQ.0
  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
  OPS(9)%NARGS=1
  OPS(9)%OP => UPDATE_RELATIVE_BASE

  CALL MPI_RECV(N,1,MPI_INTEGER,0,0,PARENT,STATUS,IERROR)
  ALLOCATE(STOREDPROG(0:N))
  CALL MPI_RECV(STOREDPROG,N,MPI_INTEGER,0,1,PARENT,STATUS,IERROR)

  RUNNING=.TRUE.
  OUTER:DO
     RELBASE=0
     FIRST=.TRUE.
     IF(ALLOCATED(PROG))DEALLOCATE(PROG)
     ALLOCATE(PROG(0:N))
     DO I=0,N
        PROG(I)%VAL=STOREDPROG(I)
        PROG(I)%LOCATION=I
     END DO
     SETUP=.TRUE.
     I=0
     DO
        IF(.NOT.RUNNING)EXIT OUTER
        INSTR = GETVAL(I)
        MODES=INSTR/100
        OPCODE=MODULO(INSTR,100)
        IF(OPCODE.EQ.99)EXIT
        CALL OPS(OPCODE)%OP(MODES,(/(GETVAL(J),J=I+1,I+OPS(OPCODE)%NARGS)/),I)
     END DO
     IF(AMROOT) THEN
        CALL MPI_RECV(LASTOUT,1,MPI_DOUBLE_PRECISION,NPROC-1,3,ICOMM,STATUS,IERROR)
        CALL MPI_SEND(LASTOUT,1,MPI_DOUBLE_PRECISION,0,999,PARENT,IERROR)
     END IF
  END DO OUTER
  DEALLOCATE(PROG,STOREDPROG)
  CALL MPI_FINALIZE(IERROR)


CONTAINS
  SUBROUTINE SETVAL(LOC,VAL)
    INTEGER(8),INTENT(IN) :: LOC,VAL
    INTEGER(8) :: KEY
    TYPE(NODE),POINTER :: A
    KEY=MODULO(LOC,SIZE(PROG))
    A => PROG(KEY)
    DO
       IF(A%LOCATION.EQ.LOC)THEN
          A%VAL=VAL
          RETURN
       END IF
       IF(.NOT.ASSOCIATED(A%NEXT))THEN
          ALLOCATE(A%NEXT)
          A => A%NEXT
          A%VAL=VAL
          A%LOCATION=LOC
          RETURN
       END IF
       A => A%NEXT
    END DO
  END SUBROUTINE SETVAL

  FUNCTION GETVAL(LOC) RESULT(VAL)
    INTEGER(8) :: LOC,VAL
    INTEGER (8) :: KEY
    TYPE(NODE), POINTER :: A
    KEY=MODULO(LOC,SIZE(PROG))
    A=>PROG(KEY)
    VAL=0
    DO
       IF(A%LOCATION.EQ.LOC)THEN
          VAL=A%VAL
          RETURN
       ELSE IF(.NOT.ASSOCIATED(A%NEXT))THEN
          RETURN
       END IF
       A => A%NEXT
    END DO
  END FUNCTION GETVAL

  FUNCTION RESOLVEPARAMS(MODES,PARAMS) RESULT(NEWPARAMS)
    INTEGER(8) :: MODES
    INTEGER(8) :: PARAMS(:), NEWPARAMS(SIZE(PARAMS))
    INTEGER :: MODE(3)
    INTEGER :: I
    MODE(1)=MODULO(MODES,10)
    MODE(2)=MODULO(MODES/10,10)
    MODE(3)=MODES/100
    DO I=1,SIZE(PARAMS)
       SELECT CASE (MODE(I))
       CASE (0)
          IF(I.EQ.3)THEN
             NEWPARAMS(I)=PARAMS(I)
          ELSE
             NEWPARAMS(I)=GETVAL(PARAMS(I))
          END IF
       CASE (1)
          NEWPARAMS(I)=PARAMS(I)
       CASE(2)
          IF(I.EQ.3)THEN
             NEWPARAMS(I)=PARAMS(I)+RELBASE
          ELSE
             NEWPARAMS(I)=GETVAL(PARAMS(I)+RELBASE)
          END IF
       END SELECT
    END DO
  END FUNCTION RESOLVEPARAMS

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

    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    CALL SETVAL(PARAMS(3),PARAMS(1)+PARAMS(2))
  END SUBROUTINE ADD

  SUBROUTINE MULTIPLY(MODES,PARAMS,I)
    INTEGER(8), INTENT(INOUT) :: MODES, PARAMS(3)
    INTEGER(8) :: A,B
    INTEGER(8), INTENT(INOUT) :: I
    I=I+4
    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    CALL SETVAL(PARAMS(3),PARAMS(1)*PARAMS(2))
  END SUBROUTINE MULTIPLY

  SUBROUTINE INPUT(MODES,PARAMS,I)
    INTEGER(8), INTENT(INOUT) :: MODES, PARAMS(1)
    INTEGER(8) :: A
    INTEGER(8), INTENT(INOUT) :: I
    I=I+2
    IF(MODULO(MODES,10).EQ.2)THEN
       PARAMS(1)=PARAMS(1)+RELBASE
    END IF
    IF(SETUP)THEN
       CALL MPI_RECV(A,1,MPI_DOUBLE_PRECISION,0,2,PARENT,STATUS,IERROR)
       IF(A<0)RUNNING=.FALSE.
       SETUP=.FALSE.
    ELSE
       IF(FIRST.AND.AMROOT)THEN
          CALL MPI_RECV(A,1,MPI_DOUBLE_PRECISION,0,3,PARENT,STATUS,IERROR)
          FIRST=.FALSE.
       ELSE
          CALL MPI_RECV(A,1,MPI_DOUBLE_PRECISION,MODULO(IRANK-1,NPROC),3,ICOMM,STATUS,IERROR)
       END IF
    END IF
    CALL SETVAL(PARAMS(1),A)
  END SUBROUTINE INPUT

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

    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    A=PARAMS(1)
    CALL MPI_ISEND(A,1,MPI_DOUBLE_PRECISION,MODULO(IRANK+1,NPROC),3,ICOMM,REQUEST,IERROR)
    LASTOUT=PARAMS(1)
  END SUBROUTINE OUTPUT

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

    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    IF(PARAMS(1).NE.0)THEN
       I=PARAMS(2)
    ELSE
       I=I+3
    END IF
  END SUBROUTINE JUMP_IF_TRUE

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

    PARAMS =  RESOLVEPARAMS(MODES,PARAMS)
    IF(PARAMS(1).EQ.0)THEN
       I=PARAMS(2)
    ELSE
       I=I+3
    END IF
  END SUBROUTINE JUMP_IF_FALSE

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

    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    IF(PARAMS(1)<PARAMS(2))THEN
       A=1
       CALL SETVAL(PARAMS(3),A)
    ELSE
       A=0
       CALL SETVAL(PARAMS(3),A)
    END IF
  END SUBROUTINE LESS_THAN

  SUBROUTINE EQUALS(MODES,PARAMS,I)
    INTEGER(8), INTENT(INOUT) :: MODES, PARAMS(3)
    INTEGER(8) :: A,B
    INTEGER(8), INTENT(INOUT) :: I
    I=I+4
    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    IF(PARAMS(1).EQ.PARAMS(2))THEN
       A=1
       CALL SETVAL(PARAMS(3),A)
    ELSE
       A=0
       CALL SETVAL(PARAMS(3),A)
    END IF
  END SUBROUTINE EQUALS

  SUBROUTINE UPDATE_RELATIVE_BASE(MODES,PARAMS,I)
    INTEGER(8), INTENT(INOUT) :: MODES, PARAMS(1)
    INTEGER(8) :: A
    INTEGER(8), INTENT(INOUT) :: I
    I=I+2
    PARAMS = RESOLVEPARAMS(MODES,PARAMS)
    RELBASE = RELBASE + PARAMS(1)
  END SUBROUTINE UPDATE_RELATIVE_BASE

END PROGRAM INTCODE