SHARE
TWEET

AoC 2019 Day11 FORTRAN

autid Dec 11th, 2019 125 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. PROGRAM DAY11  
  2.   USE MPI
  3.   TYPE NODE
  4.      INTEGER :: LOC(2)
  5.      LOGICAL :: WHITE
  6.      INTEGER :: VISITED
  7.      TYPE(NODE),POINTER :: NEXT
  8.   END TYPE NODE
  9.   INTEGER :: I,IERR,A,B,C,D,E,N,LOC(2),DIR(2),P
  10.   INTEGER(8) :: PART1,PART2,TURN,COLOUR
  11.   CHARACTER(LEN=1) CHAR
  12.   INTEGER(8), ALLOCATABLE :: PROG(:)
  13.   INTEGER :: IERROR, NPROC, ICOMM, IRANK ,INTERCOMM ,ERRCODES(1)
  14.   LOGICAL :: AMROOT,RUNNING,SETUP,FIRST
  15.   INTEGER :: STATUS(MPI_STATUS_SIZE),MINX,MINY,MAXX,MAXY
  16.   TYPE(NODE),TARGET :: ROOT
  17.   TYPE(NODE),POINTER :: NODEPTR
  18.   CHARACTER(LEN=1),ALLOCATABLE :: PRNT(:,:)
  19.   CHARACTER(LEN=20) :: FMT
  20.   CALL MPI_INIT(IERROR)
  21.   ICOMM = MPI_COMM_WORLD
  22.   CALL MPI_COMM_SIZE(ICOMM,NPROC,IERROR)
  23.   CALL MPI_COMM_RANK(ICOMM, IRANK, IERROR)
  24.   CALL MPI_COMM_SPAWN("./intcode",MPI_ARGV_NULL,1,MPI_INFO_NULL,0,ICOMM,INTERCOMM,ERRCODES,IERROR)
  25.  
  26.   OPEN(1,FILE="input.txt")
  27.   N=1
  28.   DO
  29.      READ(1,'(A1)',IOSTAT=IERR,ADVANCE="NO")CHAR
  30.      IF(IERR.NE.0)EXIT
  31.      IF(CHAR.EQ.",")N=N+1
  32.   END DO
  33.   REWIND(1)
  34.   ALLOCATE(PROG(0:N-1))
  35.   READ(1,*)PROG
  36.   CALL MPI_SEND(N,1,MPI_INTEGER,0,0,INTERCOMM,IERROR)
  37.   CALL MPI_SEND(PROG,N,MPI_DOUBLE_PRECISION,0,1,INTERCOMM,IERROR)
  38.  
  39.   DO P=1,2
  40.      ROOT%LOC=(0,0)
  41.      ROOT%WHITE=P.EQ.2
  42.      ROOT%VISITED=1
  43.      ROOT%NEXT=>NULL()
  44.      DIR=(/0,1/)
  45.      LOC=(/0,0/)
  46.      CALL MPI_SEND(0_8,1,MPI_DOUBLE_PRECISION,0,2,INTERCOMM,IERROR)
  47.      DO
  48.         COLOUR=GETCOLOUR(LOC,ROOT)
  49.         CALL MPI_SEND(COLOUR,1,MPI_DOUBLE_PRECISION,0,2,INTERCOMM,IERROR)
  50.         CALL MPI_RECV(COLOUR,1,MPI_DOUBLE_PRECISION,0,999,INTERCOMM,STATUS,IERROR)
  51.         IF(COLOUR.EQ.999)EXIT
  52.         CALL MPI_RECV(TURN,1,MPI_DOUBLE_PRECISION,0,999,INTERCOMM,STATUS,IERROR)
  53.         CALL PAINT(LOC,COLOUR,ROOT)
  54.         CALL DOTURN(DIR,TURN)
  55.         LOC=LOC+DIR
  56.      END DO
  57.      IF(P.EQ.1)THEN
  58.         PART1=0
  59.         NODEPTR => ROOT
  60.         MINX=0
  61.         MINY=0
  62.         MAXX=0
  63.         MAXY=0
  64.         DO
  65.            PART1=PART1+1
  66.            IF(.NOT.ASSOCIATED(NODEPTR%NEXT))EXIT
  67.            NODEPTR => NODEPTR%NEXT
  68.         END DO
  69.         WRITE(*,'("Part 1: ",I0)') PART1
  70.      ELSE
  71.         NODEPTR => ROOT
  72.         MINX=0
  73.         MINY=0
  74.         MAXX=0
  75.         MAXY=0
  76.         DO
  77.            MINX=MIN(MINX,NODEPTR%LOC(1))
  78.            MINY=MIN(MINY,NODEPTR%LOC(2))
  79.            MAXX=MAX(MAXX,NODEPTR%LOC(1))
  80.            MAXY=MAX(MAXY,NODEPTR%LOC(1))
  81.            IF(.NOT.ASSOCIATED(NODEPTR%NEXT))EXIT
  82.            NODEPTR => NODEPTR%NEXT
  83.         END DO
  84.         ALLOCATE(PRNT(MINX:MAXX,MINY:MAXY))
  85.         PRNT="."
  86.         NODEPTR => ROOT
  87.         DO
  88.            IF(NODEPTR%WHITE)PRNT(NODEPTR%LOC(1),NODEPTR%LOC(2))="#"
  89.            IF(.NOT.ASSOCIATED(NODEPTR%NEXT))EXIT
  90.            NODEPTR => NODEPTR%NEXT
  91.         END DO
  92.         WRITE(*,'(A)') "Part 2:"
  93.         DO I=MAXY,MINY,-1
  94.            IF(COUNT(PRNT(:,I).EQ."#").EQ.0)CYCLE
  95.            WRITE(FMT,'(A,I0,A)') "(",MAXX-MINX+1,"A)"
  96.            WRITE(*,FMT)PRNT(:,I)
  97.         END DO
  98.      END IF
  99.   END DO
  100.  
  101.   CALL MPI_SEND(-1_8,1,MPI_DOUBLE_PRECISION,0,2,INTERCOMM,IERROR)
  102.   CALL MPI_FINALIZE(IERROR)
  103.  
  104. CONTAINS
  105.   SUBROUTINE DOTURN(DIR,TURN)
  106.     INTEGER,INTENT(INOUT) :: DIR(2)
  107.     INTEGER(8) :: TURN
  108.     IF(TURN.EQ.0)THEN
  109.        DIR=(/-DIR(2),DIR(1)/)
  110.     ELSE
  111.        DIR=(/DIR(2),-DIR(1)/)
  112.     END IF
  113.   END SUBROUTINE DOTURN
  114.  
  115.   SUBROUTINE PAINT(LOC,COLOUR,ROOT)
  116.     INTEGER,INTENT(IN) :: LOC(2)
  117.     INTEGER(8),INTENT(IN) :: COLOUR
  118.     TYPE(NODE),INTENT(INOUT),TARGET :: ROOT
  119.     TYPE(NODE), POINTER :: A
  120.     A => ROOT
  121.     DO
  122.        IF(ALL(LOC.EQ.A%LOC))EXIT
  123.        IF(.NOT.ASSOCIATED(A%NEXT))THEN
  124.           ALLOCATE(A%NEXT)
  125.           A => A%NEXT
  126.           A%LOC=LOC
  127.           A%VISITED=0
  128.           A%NEXT => NULL()
  129.           EXIT
  130.        END IF
  131.        A => A%NEXT
  132.     END DO
  133.     A%VISITED=A%VISITED+1
  134.     A%WHITE=COLOUR.EQ.1
  135.   END SUBROUTINE PAINT
  136.  
  137.   FUNCTION GETCOLOUR(LOC,ROOT) RESULT(COLOUR)
  138.     INTEGER :: LOC(2)
  139.     TYPE(NODE),TARGET :: ROOT
  140.     INTEGER(8) :: COLOUR
  141.     TYPE(NODE), POINTER :: A
  142.     COLOUR=0
  143.     A => ROOT
  144.     DO
  145.        IF(ALL(LOC.EQ.A%LOC))THEN
  146.           IF(A%WHITE)COLOUR=1
  147.           EXIT
  148.        END IF
  149.        IF(.NOT.ASSOCIATED(A%NEXT))EXIT
  150.    
  151.        A => A%NEXT
  152.    
  153.     END DO
  154.   END FUNCTION GETCOLOUR
  155.  
  156. END PROGRAM DAY11
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top