box.F90

Go to the documentation of this file.

!! Copyright (C) 2021 M. Oliveira, K. Lively, A. Obzhirov, I. Albar
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module box_oct_m
  use basis_vectors_oct_m
  use debug_oct_m
  use global_oct_m
  use, intrinsic :: iso_fortran_env
  use linked_list_oct_m
  use messages_oct_m
  use namespace_oct_m
 
  implicit none
 
  private
  public ::        &
    box_t,         &
    box_list_t,    &
    box_iterator_t
 
  integer, parameter, public :: BOX_INFO_LEN=200
  real(real64), parameter, public :: BOX_BOUNDARY_DELTA = 1e-12_real64
 
  type, abstract :: box_t
    private
    integer, public :: dim
    logical :: inside_out = .false.                 
    real(real64), allocatable, public :: bounding_box_l(:)
  contains
    procedure(box_contains_points),        deferred :: contains_points
    procedure(box_bounds),                 deferred :: bounds
    procedure(box_write_info),             deferred :: write_info
    procedure(box_short_info),             deferred :: short_info
    procedure :: get_surface_points => box_get_surface_points
    procedure :: get_surface_point_info => box_get_surface_point_info
    procedure, non_overridable :: contains_point => box_contains_point
    procedure, non_overridable :: is_inside_out => box_is_inside_out
    procedure, non_overridable :: turn_inside_out => box_turn_inside_out
  end type box_t
 
  abstract interface
 
    recursive function box_contains_points(this, nn, xx) result(contained)
      import :: box_t
      import :: real64
      class(box_t),      intent(in) :: this
      integer,           intent(in) :: nn
      real(real64), contiguous, intent(in) :: xx(:,:)
      logical :: contained(1:nn)
    end function box_contains_points
 
    function box_bounds(this, axes) result(bounds)
      import :: box_t
      import :: basis_vectors_t
      import :: real64
      class(box_t),                     intent(in)  :: this
      class(basis_vectors_t), optional, intent(in)  :: axes
      real(real64)                                  :: bounds(2, this%dim)
    end function box_bounds
 
    subroutine box_write_info(this, iunit, namespace)
      import :: box_t
      import :: namespace_t
      class(box_t),                intent(in) :: this
      integer,           optional, intent(in) :: iunit
      type(namespace_t), optional, intent(in) :: namespace
    end subroutine box_write_info
 
    function box_short_info(this, unit_length)
      use unit_oct_m
      import :: box_t
      import :: box_info_len
      class(box_t), intent(in) :: this
      type(unit_t), intent(in) :: unit_length
      character(len=BOX_INFO_LEN) :: box_short_info
    end function box_short_info
  end interface
 
  type, extends(linked_list_t) :: box_list_t
    private
  contains
    procedure :: add => box_list_add_node
  end type box_list_t
 
  type, extends(linked_list_iterator_t) :: box_iterator_t
    private
  contains
    procedure :: get_next => box_iterator_get_next
  end type box_iterator_t
 
contains
 
  !!--------------------------------------------------------------
  subroutine box_turn_inside_out(this)
    class(box_t), intent(inout) :: this
 
    this%inside_out = .not. this%inside_out
 
  end subroutine box_turn_inside_out
 
  !!--------------------------------------------------------------
  logical function box_is_inside_out(this)
    class(box_t), intent(in) :: this
 
    box_is_inside_out = this%inside_out
 
  end function box_is_inside_out
 
  !!---------------------------------------------------------------
  recursive logical function box_contains_point(this, xx) result(contained)
    class(box_t),   intent(in) :: this
    real(real64), target,  intent(in) :: xx(1:this%dim)
 
    real(real64), pointer, contiguous :: xx_ptr(:,:)
    logical :: points_contained(1)
 
    xx_ptr(1:1, 1:this%dim) => xx(1:this%dim)
    points_contained = this%contains_points(1, xx_ptr)
    contained = points_contained(1)
 
  end function box_contains_point
 
  !--------------------------------------------------------------
  function box_get_surface_points(this, namespace, mesh_spacing, nn, xx, number_of_layers) result(surface_points)
    class(box_t),         intent(in)  :: this
    type(namespace_t),    intent(in)  :: namespace
    real(real64),         intent(in)  :: mesh_spacing(:)
    integer,              intent(in)  :: nn
    real(real64),         intent(in)  :: xx(:,:)
    integer, optional,    intent(in)  :: number_of_layers
    logical :: surface_points(1:nn)
 
    surface_points = .false.
    call messages_not_implemented("get_surface_points for box shape")
 
  end function box_get_surface_points
 
  !--------------------------------------------------------------
  subroutine box_get_surface_point_info(this, point_coordinates, mesh_spacing, normal_vector, surface_element)
    class(box_t), intent(in)  :: this
    real(real64), intent(in)  :: point_coordinates(:)
    real(real64), intent(in)  :: mesh_spacing(:)
    real(real64), intent(out) :: normal_vector(:)
    real(real64), intent(out) :: surface_element
 
    push_sub(box_get_surface_point_info)
 
    call messages_not_implemented("get_surface_point_info for box shape")
 
    pop_sub(box_get_surface_point_info)
  end subroutine box_get_surface_point_info
 
  ! ---------------------------------------------------------
  subroutine box_list_add_node(this, box)
    class(box_list_t)    :: this
    class(box_t), target :: box
 
    select type (box)
    class is (box_t)
      call this%add_ptr(box)
    class default
      assert(.false.)
    end select
 
  end subroutine box_list_add_node
 
  ! ---------------------------------------------------------
  function box_iterator_get_next(this) result(box)
    class(box_iterator_t), intent(inout) :: this
    class(box_t),          pointer       :: box
 
    select type (ptr => this%get_next_ptr())
    class is (box_t)
      box => ptr
    class default
      assert(.false.)
    end select
 
  end function box_iterator_get_next
 
end module box_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: