Fortraneries/BloubWorld/mergebloubs.f90

program mergebloubs

  use bloubspace
  implicit none

  integer, parameter       :: NB_MAX_BLOUBS = 20000

  character(200)           :: infile, outfile
  type(t_bloubs)           :: bloub, newbloub
  integer                  :: inu, outu, errcode

  type(t_bloubs), dimension(:), allocatable  :: les_bloubs
  integer                                    :: i, idx, nbr_merge
  real                                       :: rval
  logical                                    :: merged

! --------------- check command line parameters
  if (IARGC() .ne. 2) then
    STOP ": NEED IN AND OUT FILENAME"
  endif
  call getarg(1, infile)
  call getarg(2, outfile)

  write(0, '(2A20, I8)') trim(infile), trim(outfile), NB_MAX_BLOUBS

! --------------- allocate memory for the people

  allocate (les_bloubs(NB_MAX_BLOUBS), stat=errcode)
  if (0 .NE. errcode) then
    STOP " : NO ENOUGH MEMORY"
  endif

  do i = 1, NB_MAX_BLOUBS
    les_bloubs(i)%alive = .FALSE.
  enddo

! --------------- open / creat the files

  open(newunit=inu,                                          &
                  file=trim(infile), form='unformatted',     &
                  iostat=errcode,                            &
                  action='read', status='old')
  if (0 .ne. errcode) then
    STOP " : CAN'T OPEN FILE " // trim(infile)
  endif

  open(newunit=outu,                                         &
                  file=trim(outfile), form='unformatted',    &
                  iostat=errcode,                            &
                  action='write', status='replace')
  if (0 .ne. errcode) then
    STOP " : CAN'T OPEN " // trim(outfile) // "FOR WRITE"
  endif

! --------------- read the first bloub

  idx = 1

  read (unit=inu, iostat=errcode) bloub
    if (0 .ne. errcode) then
      STOP " : ERR READING FIRST BLOUB"
    endif
  call display_bloub (bloub, "first bloub")
  les_bloubs(idx) = bloub
  idx = idx + 1

! --------------- loop over the other bloubs
  nbr_merge = 0

  do                 ! infinite loop

    print *, "============ PASS ", idx
    if (idx .EQ. NB_MAX_BLOUBS) then
      write(0, '(I8, A)') idx, " max number of bloubs reached"
      exit
    endif

    ! read the next bloub from input file
    read (unit=inu, iostat=errcode) bloub
      if (0 .ne. errcode) then
        exit
      endif
    !! call display_bloub (bloub, "next bloub")

    if (.NOT. bloub%alive) then
      STOP " : I HAVE READ A DEAD BLOUB"
    endif

    ! check with all the previuous blobs
    merged = .FALSE.
    do i = 1, idx-1
      if (.NOT. les_bloubs(i)%alive) then
        ! print *, "dead bloub at ", i, " on ", idx
        ! call display_bloub(les_bloubs(i), "DEAD ? WTF ?")
        cycle
      endif
      rval = distance_of_bloubs(les_bloubs(i), bloub)
      if (rval .LT. (les_bloubs(i)%radius + bloub%radius)) then
        print *, "contact : ", i, idx, rval
        call merge_two_bloubs(les_bloubs(i), bloub, newbloub)
        les_bloubs(i)%alive = .FALSE.
        nbr_merge = nbr_merge + 1
        merged = .TRUE.
      endif
    enddo

    if (merged) then
      les_bloubs(idx) = newbloub
      bloub = newbloub
    else
      ! put old bloub in the list
      les_bloubs(idx) = bloub
    endif

    write(outu, iostat=errcode) bloub     ! no error control ?
    if (0 .ne. errcode) then
      STOP " : WRITE ERROR TO " // trim(outfile)
    endif

    idx = idx + 1

    ! print *, "idx = ", idx

  enddo              ! end of infinit... WHAT?

! --------------- is the job done ?

  close(inu)    ;    close(outu)

  write(0, '()')
  write(0, '(I5, A)') nbr_merge, " merges"
  write(0, '(A)') "--- mergebloubs . . . . . . .  [done]"

! --------------------------------------------------------------
contains

  subroutine merge_two_bloubs(bla, blb, blr)
      type(t_bloubs), intent(in)   :: bla, blb
      type(t_bloubs), intent(out)  :: blr

      blr%nick     = "newbie  "
      blr%num      = 0                !    ???

      blr%px = (bla%px + blb%px) / 2.0
      blr%py = (bla%py + blb%py) / 2.0
      blr%pz = (bla%pz + blb%pz) / 2.0

      blr%vx = (bla%vx + blb%vx) / 2.0
      blr%vy = (bla%vy + blb%vy) / 2.0
      blr%vz = (bla%vz + blb%vz) / 2.0

      blr%radius = (bla%radius + blb%radius) / 1.414
      blr%age = min(bla%age, blb%age)

      ! bring it to life !
      blr%alive    = .TRUE.

  end subroutine

end program