Fortraneries/BloubWorld/bloubspace.f90

301 lines
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