Fortraneries/BloubWorld/bloubspace.f90

269 lines
7.4 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
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
! 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 random_pv (blb)
type(t_bloubs), intent (out) :: blb
blb%px = 4.33 * (rand() - 0.50)
blb%py = 3.70 * (rand() - 0.50)
blb%pz = 4.51 * (rand() - 0.50)
blb%vx = (rand()) / 2.000
if (blb%px .LT. 0.0) blb%vx = -blb%vx
blb%vy = (rand()) / 3.200
if (blb%py .LT. 0.0) blb%vy = -blb%vx
blb%vz = (rand()) / 2.000
if (blb%pz .LT. 0.0) blb%vz = -blb%vz
blb%state = 0
blb%alive = .TRUE.
blb%age = 0
blb%agemax = 500
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
write (0, '(" spiting", (I6), "bloubs to", (A), "file")') &
towrite, trim(fname)
STOP ' : NOT IMPLEMENTED'
end subroutine
! ----------------------------------------------------------------
! 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
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
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
enddo
close(input) ! no error checking ?
write(0, '(" read ", (I8), " bloubs")') nbread
end subroutine
! ----------------------------------------------------------------
! 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_blob (blb)
type(t_bloubs), intent (inout) :: blb
if ( 5.0 .lt. (blb%px + blb%radius)) then
blb%vx = -1.0 * blb%vx
blb%px = 5.0
blb%age = blb%age + 1
endif
if (-5.0 .gt. (blb%px + blb%radius)) then
blb%vx = -1.0 * blb%vx
blb%px = -5.0
blb%age = blb%age + 1
endif
! vertical axe
if (-4.99 .gt. (blb%py + blb%radius)) then
blb%vy = -1.0 * blb%vy
blb%py = blb%radius
blb%age = blb%age + 1
endif
if ( 4.99 .lt. (blb%py + blb%radius)) then ! overshoot ?
blb%vy = -1.0 * blb%vy
blb%age = blb%age + 1
blb%py = 5.0 - blb%radius !!
endif
if ( 5.0 .lt. (blb%pz + blb%radius)) then
blb%vz = -1.0 * blb%vz
blb%age = blb%age + 1
blb%pz = 5.0
endif
if (-5.0 .gt. (blb%pz + blb%radius)) then
blb%vz = -1.0 * blb%vz
blb%age = blb%age + 1
blb%pz = -5.0
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. 18) 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