AoC 2019 Day6 FORTRAN

PROGRAM DAY6
  IMPLICIT NONE
  TYPE OBJPTR
     TYPE(OBJ), POINTER :: P
  END TYPE OBJPTR
  TYPE OBJ
     TYPE(OBJPTR), ALLOCATABLE :: P(:)
     CHARACTER(LEN=3) :: NAME
  END TYPE OBJ
  CHARACTER(LEN=7), ALLOCATABLE :: ORBITS(:)
  CHARACTER(LEN=3), ALLOCATABLE :: ORBITED(:)
  CHARACTER(LEN=3), ALLOCATABLE :: OBJECTNAMES(:)
  TYPE(OBJ), ALLOCATABLE, TARGET :: OBJECTS(:)
  INTEGER :: I,J,K,N,IERR,DEPTH,PART1,NORBS

  ! Input
  OPEN(1,FILE="input.txt")
  N=0
  DO
     READ(1,*,IOSTAT=IERR)
     IF(IERR.NE.0)EXIT
     N=N+1
  END DO
  ALLOCATE(ORBITS(N),ORBITED(N),OBJECTNAMES(0:N),OBJECTS(0:N))
  REWIND(1)
  READ(1,*)ORBITS
  CLOSE(1)

  ! Setup tree
  OBJECTNAMES(0)="COM"
  DO I=1,N
     OBJECTNAMES(I)=ORBITS(I)(5:)
     ORBITED(I)=ORBITS(I)(1:3)
  END DO
  DO I=0,N
     OBJECTS(I)%NAME=OBJECTNAMES(I)
     NORBS=COUNT(ORBITED.EQ.OBJECTNAMES(I))
     IF(NORBS>0)THEN
        ALLOCATE(OBJECTS(I)%P(NORBS))
        J=1
        DO K=1,N
           IF(ORBITED(K).EQ.OBJECTNAMES(I))THEN
              OBJECTS(I)%P(J)%P => OBJECTS(K)
              J=J+1
           END IF
        END DO
     END IF
  END DO

  WRITE(*,'("Part 1: ",I0)') COUNTORBS(OBJECTS(0),0)
  WRITE(*,'("Part 2: ",I0)') DISTBETWEEN(OBJECTS(0),"YOU","SAN")

CONTAINS
  RECURSIVE FUNCTION COUNTORBS(ORBITED, DEPTH) RESULT(PART1)
    INTEGER :: DEPTH, PART1,I
    TYPE(OBJ) :: ORBITED

    PART1=DEPTH
    IF(ALLOCATED(ORBITED%P))THEN
       DO I=1,SIZE(ORBITED%P)
          PART1=PART1+COUNTORBS(ORBITED%P(I)%P,DEPTH+1)
       END DO
    END IF
  END FUNCTION COUNTORBS

  RECURSIVE FUNCTION DISTTO(ORBITED, TARG) RESULT(DIST)
    INTEGER :: DIST,I,J
    TYPE(OBJ) :: ORBITED
    CHARACTER(LEN=3) :: TARG

    DIST=-999
    IF(ALLOCATED(ORBITED%P))THEN
       DO I=1,SIZE(ORBITED%P)
          IF(ORBITED%P(I)%P%NAME.EQ.TARG)THEN
             DIST=0
             RETURN
          END IF
          J=DISTTO(ORBITED%P(I)%P, TARG)
          IF(J.GE.0)THEN
             DIST=J+1
             RETURN
          END IF
       END DO
    END IF
  END FUNCTION DISTTO

  RECURSIVE FUNCTION DISTBETWEEN(ORBITED, TARG1, TARG2) RESULT(PART2)
    INTEGER :: PART2, I, J, K
    TYPE(OBJ) :: ORBITED
    CHARACTER(LEN=3) :: TARG1,TARG2

    PART2=-999

    IF(ALLOCATED(ORBITED%P))THEN
       DO I=1,SIZE(ORBITED%P)
          PART2=DISTBETWEEN(ORBITED%P(I)%P,TARG1,TARG2)
          IF(PART2.GE.0)RETURN
       END DO
       J=DISTTO(ORBITED,TARG1)
       K=DISTTO(ORBITED,TARG2)
       IF(ANY((/J,K/).LT.0))RETURN
       PART2=J+K
    END IF
  END FUNCTION DISTBETWEEN
END PROGRAM DAY6