AoC 2019 Day11 FORTRAN

PROGRAM DAY11
  USE MPI
  TYPE NODE
     INTEGER :: LOC(2)
     LOGICAL :: WHITE
     INTEGER :: VISITED
     TYPE(NODE),POINTER :: NEXT
  END TYPE NODE
  INTEGER :: I,IERR,A,B,C,D,E,N,LOC(2),DIR(2),P
  INTEGER(8) :: PART1,PART2,TURN,COLOUR
  CHARACTER(LEN=1) CHAR
  INTEGER(8), ALLOCATABLE :: PROG(:)
  INTEGER :: IERROR, NPROC, ICOMM, IRANK ,INTERCOMM ,ERRCODES(1)
  LOGICAL :: AMROOT,RUNNING,SETUP,FIRST
  INTEGER :: STATUS(MPI_STATUS_SIZE),MINX,MINY,MAXX,MAXY
  TYPE(NODE),TARGET :: ROOT
  TYPE(NODE),POINTER :: NODEPTR
  CHARACTER(LEN=1),ALLOCATABLE :: PRNT(:,:)
  CHARACTER(LEN=20) :: FMT
  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_SPAWN("./intcode",MPI_ARGV_NULL,1,MPI_INFO_NULL,0,ICOMM,INTERCOMM,ERRCODES,IERROR)

  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
  CALL MPI_SEND(N,1,MPI_INTEGER,0,0,INTERCOMM,IERROR)
  CALL MPI_SEND(PROG,N,MPI_DOUBLE_PRECISION,0,1,INTERCOMM,IERROR)

  DO P=1,2
     ROOT%LOC=(0,0)
     ROOT%WHITE=P.EQ.2
     ROOT%VISITED=1
     ROOT%NEXT=>NULL()
     DIR=(/0,1/)
     LOC=(/0,0/)
     CALL MPI_SEND(0_8,1,MPI_DOUBLE_PRECISION,0,2,INTERCOMM,IERROR)
     DO
        COLOUR=GETCOLOUR(LOC,ROOT)
        CALL MPI_SEND(COLOUR,1,MPI_DOUBLE_PRECISION,0,2,INTERCOMM,IERROR)
        CALL MPI_RECV(COLOUR,1,MPI_DOUBLE_PRECISION,0,999,INTERCOMM,STATUS,IERROR)
        IF(COLOUR.EQ.999)EXIT
        CALL MPI_RECV(TURN,1,MPI_DOUBLE_PRECISION,0,999,INTERCOMM,STATUS,IERROR)
        CALL PAINT(LOC,COLOUR,ROOT)
        CALL DOTURN(DIR,TURN)
        LOC=LOC+DIR
     END DO
     IF(P.EQ.1)THEN
        PART1=0
        NODEPTR => ROOT
        MINX=0
        MINY=0
        MAXX=0
        MAXY=0
        DO
           PART1=PART1+1
           IF(.NOT.ASSOCIATED(NODEPTR%NEXT))EXIT
           NODEPTR => NODEPTR%NEXT
        END DO
        WRITE(*,'("Part 1: ",I0)') PART1
     ELSE
        NODEPTR => ROOT
        MINX=0
        MINY=0
        MAXX=0
        MAXY=0
        DO
           MINX=MIN(MINX,NODEPTR%LOC(1))
           MINY=MIN(MINY,NODEPTR%LOC(2))
           MAXX=MAX(MAXX,NODEPTR%LOC(1))
           MAXY=MAX(MAXY,NODEPTR%LOC(1))
           IF(.NOT.ASSOCIATED(NODEPTR%NEXT))EXIT
           NODEPTR => NODEPTR%NEXT
        END DO
        ALLOCATE(PRNT(MINX:MAXX,MINY:MAXY))
        PRNT="."
        NODEPTR => ROOT
        DO
           IF(NODEPTR%WHITE)PRNT(NODEPTR%LOC(1),NODEPTR%LOC(2))="#"
           IF(.NOT.ASSOCIATED(NODEPTR%NEXT))EXIT
           NODEPTR => NODEPTR%NEXT
        END DO
        WRITE(*,'(A)') "Part 2:"
        DO I=MAXY,MINY,-1
           IF(COUNT(PRNT(:,I).EQ."#").EQ.0)CYCLE
           WRITE(FMT,'(A,I0,A)') "(",MAXX-MINX+1,"A)"
           WRITE(*,FMT)PRNT(:,I)
        END DO
     END IF
  END DO

  CALL MPI_SEND(-1_8,1,MPI_DOUBLE_PRECISION,0,2,INTERCOMM,IERROR)
  CALL MPI_FINALIZE(IERROR)

CONTAINS
  SUBROUTINE DOTURN(DIR,TURN)
    INTEGER,INTENT(INOUT) :: DIR(2)
    INTEGER(8) :: TURN
    IF(TURN.EQ.0)THEN
       DIR=(/-DIR(2),DIR(1)/)
    ELSE
       DIR=(/DIR(2),-DIR(1)/)
    END IF
  END SUBROUTINE DOTURN

  SUBROUTINE PAINT(LOC,COLOUR,ROOT)
    INTEGER,INTENT(IN) :: LOC(2)
    INTEGER(8),INTENT(IN) :: COLOUR
    TYPE(NODE),INTENT(INOUT),TARGET :: ROOT
    TYPE(NODE), POINTER :: A
    A => ROOT
    DO
       IF(ALL(LOC.EQ.A%LOC))EXIT
       IF(.NOT.ASSOCIATED(A%NEXT))THEN
          ALLOCATE(A%NEXT)
          A => A%NEXT
          A%LOC=LOC
          A%VISITED=0
          A%NEXT => NULL()
          EXIT
       END IF
       A => A%NEXT
    END DO
    A%VISITED=A%VISITED+1
    A%WHITE=COLOUR.EQ.1
  END SUBROUTINE PAINT

  FUNCTION GETCOLOUR(LOC,ROOT) RESULT(COLOUR)
    INTEGER :: LOC(2)
    TYPE(NODE),TARGET :: ROOT
    INTEGER(8) :: COLOUR
    TYPE(NODE), POINTER :: A
    COLOUR=0
    A => ROOT
    DO
       IF(ALL(LOC.EQ.A%LOC))THEN
          IF(A%WHITE)COLOUR=1
          EXIT
       END IF
       IF(.NOT.ASSOCIATED(A%NEXT))EXIT

       A => A%NEXT

    END DO
  END FUNCTION GETCOLOUR

END PROGRAM DAY11