301 行
8.6 KiB
Fortran
301 行
8.6 KiB
Fortran
!
|
|
! fonctions de base de gestion des bloubs
|
|
!
|
|
|
|
module bloubspace
|
|
|
|
implicit none
|
|
|
|
! ----------------------------------------------------------------
|
|
|
|
type t_bloubs
|
|
character(8) :: nick
|
|
logical :: alive
|
|
integer :: state
|
|
integer :: num ! ???
|
|
real :: px, py, pz
|
|
real :: vx, vy, vz
|
|
real :: radius
|
|
integer :: age, agemax
|
|
integer :: red, green, blue
|
|
end type t_bloubs
|
|
|
|
type t_boundingbox
|
|
character(8) :: id
|
|
real :: xm, ym, zm
|
|
real :: xp, yp, zp
|
|
end type t_boundingbox
|
|
|
|
contains ! -----------------------------------------
|
|
|
|
! ----------------------------------------------------------------
|
|
|
|
subroutine load_boundingbox(infile, where, name)
|
|
character(*), intent(in) :: infile
|
|
type(t_boundingbox), intent (out) :: where
|
|
character(8), intent(in) :: name
|
|
|
|
integer :: fd, errcode
|
|
character(200) :: message
|
|
|
|
print *, "try to load ", infile, " name ", name
|
|
|
|
! put some default values
|
|
where%id = "default"
|
|
where%xm = -5.0 ; where%ym = -5.0 ; where%zm = -5.0
|
|
where%xp = 5.0 ; where%yp = 5.0 ; where%zp = 5.0
|
|
|
|
! and now, try to read the file
|
|
open (newunit=fd, file=trim(infile), &
|
|
status='old', action='read', &
|
|
iostat=errcode, iomsg=message)
|
|
if (errcode .NE. 0) then
|
|
stop 'OPEN ERROR ' // message
|
|
endif
|
|
|
|
do
|
|
read(unit=fd, iostat=errcode, iomsg=message, &
|
|
fmt='(A,6F8.3)') where
|
|
if (errcode .NE. 0) then
|
|
! print *, "errcode ", errcode
|
|
print *, "message: ", message
|
|
exit
|
|
endif
|
|
enddo
|
|
|
|
close(fd)
|
|
|
|
end subroutine load_boundingbox
|
|
|
|
! ----------------------------------------------------------------
|
|
|
|
subroutine make_a_random_bloub(blb)
|
|
type(t_bloubs), intent (out) :: blb
|
|
|
|
blb%px = 3.57 * (rand() - 0.50)
|
|
blb%py = 2.66 * (rand() - 0.50)
|
|
blb%pz = 3.57 * (rand() - 0.50)
|
|
|
|
blb%vx = (rand()) / 2.500
|
|
if (blb%px .LT. 0.0) blb%vx = -blb%vx
|
|
|
|
blb%vy = (rand()) / 4.000
|
|
if (blb%py .LT. 0.0) blb%vy = -blb%vx
|
|
|
|
blb%vz = (rand()) / 2.500
|
|
if (blb%pz .LT. 0.0) blb%vz = -blb%vz
|
|
|
|
blb%state = 0
|
|
blb%alive = .TRUE.
|
|
blb%age = 0
|
|
blb%agemax = 300
|
|
|
|
end subroutine
|
|
! ----------------------------------------------------------------
|
|
! Load a blbs file into an array of bloubs
|
|
subroutine spit_bloubs_to_file (fname, blbarray, towrite)
|
|
character(*), intent(in) :: fname
|
|
type(t_bloubs), dimension(:) :: blbarray
|
|
integer, intent(in) :: towrite
|
|
|
|
integer :: errcode, output, foo, spitted
|
|
character(200) :: chaine
|
|
|
|
write (0, '(" spitting", (I6), " bloubs to ", (A), " file")') &
|
|
towrite, trim(fname)
|
|
|
|
open( newunit=output, &
|
|
file=trim(fname), form='unformatted', &
|
|
iostat=errcode, iomsg=chaine, &
|
|
action='write', status='replace')
|
|
if (0 .ne. errcode) then
|
|
write(0, '(" errcode ", I8, 2X, A)') errcode, chaine
|
|
STOP " : CAN'T OPEN FILE " // trim(fname)
|
|
endif
|
|
|
|
spitted = 0
|
|
do foo=1, towrite
|
|
if (blbarray(foo)%alive) then
|
|
write(output, iostat=errcode) blbarray(foo)
|
|
if (0 .ne. errcode) then
|
|
STOP " : WRITE ERROR TO " // trim(fname)
|
|
endif
|
|
spitted = spitted + 1
|
|
endif
|
|
enddo
|
|
|
|
close(output)
|
|
write(0, '(1X, "spitted ", I6, " bloubs")') spitted
|
|
|
|
end subroutine spit_bloubs_to_file
|
|
! ----------------------------------------------------------------
|
|
! Dump an array of bloubs to a blbs file.
|
|
!
|
|
subroutine slurp_bloubs_file_in_array (infile, blbarray, nbread)
|
|
character(*), intent(in) :: infile
|
|
type(t_bloubs), dimension(:), intent(out) :: blbarray
|
|
integer, intent(out) :: nbread
|
|
|
|
character(200) :: chaine
|
|
integer :: input, errcode, idx
|
|
integer :: capacity
|
|
type(t_bloubs) :: bloub
|
|
|
|
write(0, '(" slurping from file [", (A), "]")') trim(infile)
|
|
|
|
open( newunit=input, &
|
|
file=trim(infile), form='unformatted', &
|
|
iostat=errcode, iomsg=chaine, &
|
|
action='read', status='old')
|
|
if (0 .ne. errcode) then
|
|
write(0, '(" errcode ", I8, 2X, A)') errcode, chaine
|
|
STOP " : CAN'T OPEN FILE " // trim(infile)
|
|
endif
|
|
! write(0, '((A, I3))') " slurping from unit ", input
|
|
|
|
capacity = ubound(blbarray, 1)
|
|
nbread = 0
|
|
idx = 1;
|
|
do
|
|
read (unit=input, iostat=errcode, iomsg=chaine) bloub
|
|
if (0 .ne. errcode) then
|
|
! may be we got an EOF ?
|
|
! write(0, '(" got errcode on read ", (I8,1X,A))') errcode, chaine
|
|
exit
|
|
endif
|
|
nbread = nbread + 1
|
|
! print *, bloub%nick, bloub%radius
|
|
if (bloub%alive) then
|
|
blbarray(idx) = bloub
|
|
idx = idx + 1
|
|
endif
|
|
if (idx .GT. capacity) then
|
|
exit
|
|
endif
|
|
enddo
|
|
|
|
close(input) ! no error checking ?
|
|
! write(0, '(" have read ", (I8), " bloubs")') nbread
|
|
|
|
end subroutine slurp_bloubs_file_in_array
|
|
! ----------------------------------------------------------------
|
|
! Display a bloub content to stderr
|
|
|
|
subroutine display_bloub (blb, message)
|
|
type(t_bloubs), intent (in) :: blb
|
|
character(*), intent (in) :: message
|
|
|
|
character(5) :: life
|
|
|
|
if (blb%alive) then
|
|
life = "alive"
|
|
else
|
|
life = "dead "
|
|
endif
|
|
write (0, '(4X, A)') '+--------------- ' // message // " -------"
|
|
write (0, '(4X,A3,A8,2X,I6,4X,A5,4X,I5)') '| ', &
|
|
blb%nick, blb%num, life, blb%age
|
|
write (0, '(4X,A3,3X,3(F8.3, 4X))') '| P', blb%px, blb%py, blb%pz
|
|
write (0, '(4X,A3,3X,3(F8.3, 4X))') '| V', blb%vx, blb%vy, blb%vz
|
|
write (0, '()')
|
|
|
|
end subroutine
|
|
! ----------------------------------------------------------------
|
|
|
|
subroutine move_bloub (blb, coef)
|
|
type(t_bloubs), intent (inout) :: blb
|
|
real, intent (in) :: coef
|
|
|
|
! we must check that this bloub is alive ?
|
|
blb%px = blb%px + (blb%vx * coef)
|
|
blb%py = blb%py + (blb%vy * coef)
|
|
blb%pz = blb%pz + (blb%vz * coef)
|
|
|
|
end subroutine
|
|
! ----------------------------------------------------------------
|
|
!
|
|
! detection des collisions avec les parois de la boite
|
|
! laquelle boite gagnerais beaucoup a etre parametrable.
|
|
!
|
|
subroutine bound_a_bloub (blb)
|
|
type(t_bloubs), intent (inout) :: blb
|
|
|
|
real, parameter :: SH = 6.0
|
|
real, parameter :: SV = 4.0
|
|
|
|
! X axis
|
|
if ((blb%px + blb%radius) .GT. SH) then
|
|
blb%vx = -1.0 * blb%vx
|
|
blb%px = SH- blb%radius
|
|
blb%age = blb%age + 1
|
|
endif
|
|
if ((blb%px - blb%radius) .LT. -SH) then
|
|
blb%vx = -1.0 * blb%vx
|
|
blb%px = -SH + blb%radius
|
|
blb%age = blb%age + 1
|
|
endif
|
|
|
|
! vertical axe Y
|
|
if ((blb%py - blb%radius) .LT. -SV) then
|
|
blb%vy = -1.0 * blb%vy
|
|
blb%py = -SV + blb%radius
|
|
blb%age = blb%age + 1
|
|
endif
|
|
if ((blb%py + blb%radius) .GT. SV) then ! overshoot ?
|
|
blb%vy = -1.0 * blb%vy
|
|
blb%age = blb%age + 1
|
|
blb%py = SV - blb%radius
|
|
endif
|
|
|
|
! Z axis
|
|
if ((blb%pz + blb%radius) .GT. SH) then
|
|
blb%vz = -1.0 * blb%vz
|
|
blb%age = blb%age + 1
|
|
blb%pz = SH - blb%radius
|
|
endif
|
|
if ((blb%pz + blb%radius) .LT. -SH) then
|
|
blb%vz = -1.0 * blb%vz
|
|
blb%age = blb%age + 1
|
|
blb%pz = -SH + blb%radius
|
|
endif
|
|
|
|
end subroutine
|
|
|
|
! ----------------------------------------------------------------
|
|
function distance_of_bloubs(bla, blb)
|
|
type(t_bloubs), intent(in) :: bla, blb
|
|
real :: distance_of_bloubs
|
|
|
|
real :: dx, dy, dz
|
|
|
|
dx = (bla%px-blb%px)**2
|
|
dy = (bla%py-blb%py)**2
|
|
dz = (bla%pz-blb%pz)**2
|
|
|
|
distance_of_bloubs = sqrt(dx + dy +dz)
|
|
|
|
end function
|
|
|
|
! ----------------------------------------------------------------
|
|
! kill a bloub under condition(s)
|
|
|
|
subroutine green_soylent (blb)
|
|
type(t_bloubs), intent (inout) :: blb
|
|
|
|
if (blb%age .gt. 24) then
|
|
blb%alive = .FALSE.
|
|
endif
|
|
|
|
! this is juste a molly-guard, don't worry
|
|
!
|
|
if (blb%radius .GT. 2.0) then
|
|
blb%alive = .FALSE.
|
|
endif
|
|
end subroutine
|
|
! ----------------------------------------------------------------
|
|
|
|
end module
|
|
|
|
|
|
|