tem_point_module.f90 Source File

Source Code

! Copyright (c) 2019 Kannan Masilamani <kannan.masilamani@uni-siegen.de>
! Copyright (c) 2019 Harald Klimach <harald.klimach@uni-siegen.de>
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
! list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! *******************************************************************************!
!> summary: This module contains \ref points description and growing array
!! author: Kannan Masilamani
!! description for points.

! Copyright (c) 2012-2013 Simon Zimny <s.zimny@grs-sim.de>
! Copyright (c) 2012 Manuel Hasert <m.hasert@grs-sim.de>
! Copyright (c) 2012-2016 Harald Klimach <harald.klimach@uni-siegen.de>
! Copyright (c) 2012, 2015-2016 Kannan Masilamani <kannan.masilamani@uni-siegen.de>
! Copyright (c) 2013 Daniel Harlacher <d.harlacher@grs-sim.de>
! Copyright (c) 2014 Kartik Jain <kartik.jain@uni-siegen.de>
! Copyright (c) 2014 Verena Krupp <verena.krupp@uni-siegen.de>
! Copyright (c) 2015-2017 Jiaxing Qi <jiaxing.qi@uni-siegen.de>
! Copyright (c) 2015-2016 Peter Vitt <peter.vitt2@uni-siegen.de>
! Copyright (c) 2016 Daniel Fleischer <daniel.fleischer@student.uni-siegen.de>
! Copyright (c) 2016 Tobias Schneider <tobias1.schneider@student.uni-siegen.de>
! Copyright (c) 2017 Daniel Petró <daniel.petro@student.uni-siegen.de>
!
! Parts of this file were written by Harald Klimach, Simon Zimny and Manuel
! Hasert for German Research School for Simulation Sciences GmbH.
!
! Parts of this file were written by Harald Klimach, Kannan Masilamani,
! Daniel Harlacher, Kartik Jain, Verena Krupp, Jiaxing Qi, Peter Vitt,
! Daniel Fleischer, Tobias Girresser and Daniel Petró for University Siegen.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
! list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

! This file contains the source code for growing and dynamic arrays.
! This is used for arrays of primitives (int, long_int, real, ...) as well as
! for arrays of derived datatypes (tem_variable_type,...).
!
! To use these macros include the following to your source file.
!
! Smart growing array (GA) for ?tstring?
! Growing Arrays:
!
! declaration
!
!
! implementation
!

! -----------------------------------------------------------------
! 2d Array, which can grow in second dimension only (GA2d)
! tname ... indicates type of dynamic array (long, int, real, ...)

!
!------------------------------------------------------------------------------
!
! dynamic Arrays:
!
! declaration
!
!
! implementation
!

module tem_point_module
use env_module,         only: rk, minLength, zeroLength
use tem_cube_module,    only: tem_cube_type
use tem_logging_module, only: tem_toStr, logUnit

implicit none

private

public :: grw_pointArray_type
public :: tem_point_type
public :: init, append, truncate
public :: tem_pointCubeOverlap

!> This type contains coordinate of a point
type tem_point_type
real(kind=rk) :: coord(3) !< real world coordinate of a point
end type tem_point_type

!> growing array type for type(tem_point_type)
type grw_pointarray_type
integer :: nvals = 0
integer :: containersize = 0
type(tem_point_type), allocatable :: val(:)
end type

!> initialize the dynamic array
interface init
module procedure init_ga_point
end interface

!> truncate the array, meaning
!! cut off the trailing empty entries
interface truncate
module procedure truncate_ga_point
end interface

!> empty the entries  without changing arrays
interface empty
module procedure empty_ga_point
end interface

!> destroy the dynamic array
interface destroy
module procedure destroy_ga_point
end interface

!> insert an element at a given position
interface placeat
module procedure placeat_ga_point
module procedure placeat_ga_point_vec
end interface

!> append a value to the dynamic array
!! and return its position.
interface append
module procedure append_ga_point
module procedure append_ga_point_vec
end interface

!> increase the size of the container
!! for the array.
interface expand
module procedure expand_ga_point
end interface

contains

! **************************************************************************** !
!> This function checks whether the given point is found inside given cube.
!!
!! Point is inside the cube only if the point is >= cube origin and
!! < cube max. Point lying on the cube max is not part of the cube
function tem_pointCubeOverlap(point, cube) result(overlap)
! --------------------------------------------------------------------------!
!> Coordinate of the point to check for intersection.
type(tem_point_type) :: point
!> Cube to intersect with.
type(tem_cube_type) :: cube
logical :: overlap !< true if point lies inside else false
! --------------------------------------------------------------------------!
logical :: dirrange(3)

! Check interval in all 3 directions.
dirrange = (point%coord >= cube%origin) &
&        .and. (point%coord < cube%origin + cube%extent)

! Overlap depends on all 3 intervals.
overlap = all(dirrange)

end function tem_pointCubeOverlap
! **************************************************************************** !

subroutine init_ga_point(me, length)
type(grw_pointarray_type), intent(out) :: me !< dynamic array to init
integer, intent(in), optional :: length !< initial length of the container

if (present(length)) then
me%containersize = length
else
me%containersize = zerolength
end if
! deallocate ...
if( allocated( me%val ))     &
deallocate(me%val)
! ... and reallocate
allocate(me%val(me%containersize))
me%nvals = 0

end subroutine init_ga_point

subroutine destroy_ga_point(me)
type(grw_pointarray_type), intent(inout) :: me !< dynamic array to destroy

me%containersize = 0
me%nvals = 0
if( allocated( me%val ) ) deallocate(me%val)

end subroutine destroy_ga_point

subroutine truncate_ga_point(me)
!------------------------------------------------------------------------
type(grw_pointarray_type) :: me !< array to truncate
!------------------------------------------------------------------------
type(tem_point_type), allocatable :: tarray(:)
!------------------------------------------------------------------------
integer :: ii
!------------------------------------------------------------------------

! nothing to do if container size is not larger than the number of values
! in the array.
if (me%containersize > me%nvals) then
allocate(tarray(me%nvals))
do ii = 1, me%nvals
tarray(ii) = me%val(ii)
end do
call move_alloc(tarray, me%val)
me%containersize = me%nvals
end if

end subroutine truncate_ga_point

subroutine empty_ga_point(me)
!------------------------------------------------------------------------
type(grw_pointarray_type) :: me !< array to sorttruncate
!------------------------------------------------------------------------

me%nvals = 0

end subroutine empty_ga_point

!> adds the value to a given position inside the growing array.
!!
!! if the requested position is outside the current array bounds, the array
!! will be resized accordingly. if it is inside the current array bounds, the
!! element at the requested position will be replaced.
subroutine placeat_ga_point(me, val, pos, length)
type(grw_pointarray_type) :: me !< array to place the value into
type(tem_point_type), intent(in) :: val !< value to place at the given position
integer, intent(in) :: pos !< predefined position
!> optional length to expand the array
integer, intent(in), optional :: length

! value to append is larger than all existing ones,
! just put it to the end of the list, this captures
! also the case of empty lists.
! in this case foundpos = me%nvals + 1 holds.
if (pos > me%containersize) then
! expand the array, if its boundary is reached
call expand(me = me, pos = pos, length = length)
end if

me%nvals = max( pos, me%nvals )
me%val(pos) = val

end subroutine placeat_ga_point

!> adds the values starting from a given position inside the growing array.
!!
!! if the requested position is outside the current array bounds, the array
!! will be resized accordingly. if it is inside the current array bounds, the
!! elements starting from the requested position will be replaced up to
!! the element at position pos + size(val) - 1.
subroutine placeat_ga_point_vec(me, val, pos, length)
type(grw_pointarray_type) :: me !< array to append the value to
type(tem_point_type), intent(in) :: val(:) !< values to append
integer, intent(in) :: pos !< predefined position
!> optional length to expand the array
integer, intent(in), optional :: length

integer :: ub, ii

if (me%nvals == huge(me%nvals)) then
write(*,*) "reached end of integer range for growing array!"
write(*,*) "aborting!!"
stop
end if

ub = pos + size(val) - 1

if (ub > me%containersize) then
! expand the array, if its boundary is reached
call expand(me = me, pos = ub, length = length)
end if

me%nvals = max( ub, me%nvals )
do ii = pos, ub
me%val(ii) = val(1+ii-pos)
end do

end subroutine placeat_ga_point_vec

subroutine append_ga_point(me, val, length)
type(grw_pointarray_type) :: me !< array to append the value to
type(tem_point_type), intent(in) :: val !< value to append
!> optional length to expand the array
integer, intent(in), optional :: length

! value to append is larger than all existing ones,
! just put it to the end of the list, this captures
! also the case of empty lists.
! in this case foundpos = me%nvals + 1 holds.
if (me%nvals+1 > me%containersize) then
! expand the array, if its boundary is reached
call expand(me = me, length = length)
end if

me%nvals = me%nvals+1
me%val(me%nvals) = val

end subroutine append_ga_point

subroutine append_ga_point_vec(me, val, length)
type(grw_pointarray_type) :: me !< array to append the value to
type(tem_point_type), intent(in) :: val(:) !< values to append
!> optional length to expand the array
integer, intent(in), optional :: length

integer :: lb, ub, ii

if (me%nvals == huge(me%nvals)) then
write(*,*) "reached end of integer range for growing array!"
write(*,*) "aborting!!"
stop
end if

lb = me%nvals + 1
ub = lb + size(val) - 1

if (ub > me%containersize) then
! expand the array, if its boundary is reached
call expand(me = me, pos = ub, length = length)
end if

me%nvals = max( ub, me%nvals )
do ii = lb, ub
me%val(ii) = val(1+ii-lb)
end do

end subroutine append_ga_point_vec

subroutine expand_ga_point(me, pos, length)
type(grw_pointarray_type) :: me !< array to resize
integer, intent(in), optional :: pos !< optional predefined position
!> optional length to expand the array
integer, intent(in), optional :: length

type(tem_point_type), allocatable :: swpval(:)
integer :: explen, ii

explen = 0
! increase the container by the requested length of double it
if( present(length) ) then
explen = max( length, minlength )
else
! set the global minimum length, if doubling would be smaller than that
explen = max(me%containersize, minlength)
end if

! if a position is given, increase the container to at least the size to
! fit the position.
if( present(pos) ) explen = max(explen, pos-me%containersize)

! if the current size plus explen exceeds the max container size,
! reduce the size to the max container size.
if( (huge(me%containersize) - explen) <= me%containersize) then
! set max container size
me%containersize = huge(me%containersize)
else
! set the new container size
me%containersize = me%containersize + explen
end if

if ( me%nvals > 0 ) then
allocate(swpval(me%containersize))
do ii = 1, me%nvals
swpval(ii) = me%val(ii)
end do
call move_alloc( swpval, me%val )
else ! me%nvals == 0
if ( allocated(me%val) ) deallocate( me%val )
allocate( me%val(me%containersize) )
end if

end subroutine expand_ga_point

end module tem_point_module

!> \page point Points
!! Points are defined in the configuration file through canonoical
!! geometry kind with an origin.\n
!! Valid definition:
!! \li Single point
!! \verbatim
!! geometry = {
!!   kind = 'canoND',
!!   object = {
!!     origin = { 0.0,0.0,0.0 }
!!   }
!! }
!! \endverbatim
!! \li Multiple point
!! \verbatim
!! geometry = {
!!   kind = 'canoND',
!!   object = {
!!     {
!!     origin = { 0.0,0.0,0.0 }
!!     },
!!     {
!!     origin = { 1.0,0.0,0.0 }
!!     },
!!   }
!! }
!! \endverbatim
!!\n\n
!! Seeder file to generate the mesh with multiple point obstacle is given below:
!! \include testsuite/point/seeder.lua
!! \n\n
!! The image generated with multiple point obstacles from the above code:
!! \image html tem_point.png
!! Example lua file is available at \link testsuite/point/seeder.lua
!! \example testsuite/point/seeder.lua