Fortraneries/BloubWorld/mergebloubs.f90

106 lines
2.8 KiB
Fortran

program mergebloubs
!-------------------------------------------!
! THIS IS A BIG MESS OF BUGS !
!-------------------------------------------!
use bloubspace
implicit none
integer, parameter :: NB_MAX_BLOUBS = 250000
character(200) :: infile, outfile
! type(t_bloubs) :: bloub, newbloub
integer :: errcode, nbgot
type(t_bloubs), dimension(:), allocatable :: bloubs
integer :: ia, ib, contacts
real :: dist,radd
type(t_bloubs) :: 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, '(A, 2A15, I8)') "### mergebloubs ", &
trim(infile), trim(outfile), NB_MAX_BLOUBS
allocate (bloubs(NB_MAX_BLOUBS), stat=errcode)
if (0 .NE. errcode) then
STOP " : NO ENOUGH MEMORY"
endif
call slurp_bloubs_file_in_array(trim(infile), bloubs, nbgot)
write(0, '(A,I0,1X,A)') " slurped ", nbgot, "bloubs"
contacts = 0
do ia = 1, nbgot
! print *, ia, " = ", les_bloubs(ia)%nick, les_bloubs(ia)%num
do ib = ia+1, nbgot
dist = distance_of_bloubs(bloubs(ia), bloubs(ib))
radd = bloubs(ia)%radius + bloubs(ib)%radius
if (dist .LT. radd) then
contacts = contacts + 1
call merge_two_bloubs(bloubs(ia), bloubs(ib), merged)
bloubs(ia) = merged
bloubs(ia)%nick = "marged"
bloubs(ia)%state = 1;
bloubs(ib)%alive = .FALSE.
write(0, *) " *** merged ", ia, " and ", ib, &
" new r = ", merged%radius
endif
enddo
enddo
call spit_bloubs_to_file (outfile, bloubs, nbgot)
if (contacts .GT. 0) then
write(0, '(A,I0,A,I0,A)') &
" merge: ", contacts, " contacts pour ", nbgot, " bloubs"
endif
! STOP 'mergebloubs [done]'
! ==============================================================
contains
subroutine merge_two_bloubs(bla, blb, blr)
type(t_bloubs), intent(in) :: bla, blb
type(t_bloubs), intent(out) :: blr
real :: va, vb
!-
! XXX please insert here a static counter for the 'num' id
!-
blr%nick = "merged "
blr%num = 0 ! ???
va = bla%radius * bla%radius * bla%radius
vb = blb%radius * blb%radius * blb%radius
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 = (va + vb) ** 0.33333333333
blr%age = min(bla%age, blb%age)
! bring it to life !
blr%alive = .TRUE.
end subroutine
end program