Fortraneries/BloubWorld/bloubspace.f90

! 
!          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

  ! ----------------------------------------------------------------
  !-
  !    coefxyz :
  !             dispersion de la position autour de l'origine
  !-
  subroutine make_a_random_bloub(blb, coefxyz)
    type(t_bloubs), intent (out)     :: blb
    real, intent(in)                 :: coefxyz

    ! write(0, *) "coef xyz = ", coefxyz
    blb%px = coefxyz * (rand() - 0.50)
    blb%py = coefxyz * (rand() - 0.50)
    blb%pz = coefxyz * (rand() - 0.50)

    blb%vx = (rand()) / 5.000
    if (blb%px .LT. 0.0) blb%vx = -blb%vx

    blb%vy = 0.2 + (rand()) / 8.000
    if (blb%py .LT. 0.0) blb%vy = -blb%vy

    blb%vz = (rand()) / 5.000
    if (blb%pz .LT. 0.0) blb%vz = -blb%vz

    blb%state  = 0
    blb%alive  = .TRUE.
    blb%age    = 0
    blb%agemax = 100

  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 ", I0, " 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
  ! ----------------------------------------------------------------
  !-
  !		Deplacement d'un bloub
  !-
  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,
  !     ainsi qu'un éventuel coefficient de réduction de la
  !     vitesse. XXX
  ! 
  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. 240) then
      blb%alive = .FALSE.
    endif

    ! this is juste a molly-guard, don't worry
    ! 
    if (blb%radius .GT. 4.0) then
      blb%alive = .FALSE.
    endif
  end subroutine
  ! ----------------------------------------------------------------

end module