436 lines
12 KiB
Fortran
436 lines
12 KiB
Fortran
module types
|
|
|
|
use const_and_precisions, only : wp_
|
|
|
|
implicit none
|
|
|
|
type item
|
|
! An item is the building block of a queue
|
|
class(*), allocatable :: value ! the actual content
|
|
type(item), pointer :: next => null() ! pointer to the next item
|
|
end type
|
|
|
|
|
|
type queue
|
|
! A queue is a list of items with O(1) insertion and extraction.
|
|
! The first item inserted (`put` operation) is the first to be
|
|
! extracted (`get` operation).
|
|
|
|
! References to the first and last items in the queue
|
|
type(item), pointer :: first => null(), last => null()
|
|
|
|
contains
|
|
procedure :: put => queue_put ! inserts an item at the end of the queue
|
|
procedure :: get => queue_get ! extracts the first item in the queue
|
|
procedure :: empty => queue_empty ! checks whether the queue is empty
|
|
end type
|
|
|
|
|
|
type table
|
|
! A type for storing tabular data before serialisation
|
|
integer :: id ! the table unique ID
|
|
logical :: active ! whether to process the table
|
|
character(64) :: title ! title of the table
|
|
character(64), allocatable :: labels(:) ! labels for each column
|
|
type(queue), allocatable :: columns(:) ! values for each column
|
|
|
|
contains
|
|
procedure :: init => table_init ! creates an empty table
|
|
procedure :: append => table_append ! appends an extra row to the table
|
|
procedure :: empty => table_empty ! checks whether the queue is empty
|
|
procedure :: save => table_save ! processes and writes the table to file
|
|
end type
|
|
|
|
|
|
type wrap
|
|
! A wrapper type for storing (references of) heterogeneous
|
|
! values in an array or other homogeneuous container type
|
|
class(*), pointer :: value
|
|
end type
|
|
|
|
! Interface for custom type constructor
|
|
interface wrap
|
|
procedure :: wrap_init
|
|
end interface
|
|
|
|
|
|
type contour
|
|
! A closed contour in the (R,z) plane
|
|
real(wp_), allocatable :: R(:)
|
|
real(wp_), allocatable :: z(:)
|
|
contains
|
|
procedure :: contains => contour_contains ! test if contour contains a point
|
|
end type
|
|
|
|
! Interface for custom type constructor
|
|
interface contour
|
|
procedure :: contour_init
|
|
procedure :: contour_init_rect
|
|
end interface
|
|
|
|
contains
|
|
|
|
pure subroutine queue_put(self, val)
|
|
! Inserts an item of value `val` at the end of the `self` queue
|
|
class(queue), intent(inout) :: self
|
|
class(*), intent(in) :: val
|
|
|
|
type(item), pointer :: i
|
|
|
|
! set up the item and copy the value
|
|
allocate(i)
|
|
allocate(i%value, source=val)
|
|
|
|
if (self%empty()) then
|
|
! first item received, store it separately
|
|
self%first => i
|
|
else
|
|
! otherwise, link the last item to the new one
|
|
self%last%next => i
|
|
end if
|
|
|
|
! update the last item
|
|
self%last => i
|
|
end subroutine queue_put
|
|
|
|
|
|
subroutine queue_get(self, val)
|
|
! Extracts the item from the front of the queue.
|
|
! Notes:
|
|
! - this assumes the queue is not empty.
|
|
! - this should be converted to a function once
|
|
! gcc bug 115072 is fixed.
|
|
class(queue), intent(inout) :: self
|
|
class(*), allocatable, intent(out) :: val
|
|
|
|
type(item), pointer :: tmp
|
|
|
|
! extract the value
|
|
allocate(val, source=self%first%value)
|
|
|
|
tmp => self%first ! get a grip
|
|
self%first => tmp%next ! shift the reference
|
|
deallocate(tmp) ! clear the item
|
|
end subroutine queue_get
|
|
|
|
|
|
pure function queue_empty(self)
|
|
! Whether the `self` queue is empty
|
|
class(queue), intent(in) :: self
|
|
logical :: queue_empty
|
|
|
|
queue_empty = .not. associated(self%first)
|
|
end function
|
|
|
|
|
|
function wrap_init(val)
|
|
! Initialise a `wrap` value
|
|
!
|
|
! Note: this is needed because, apparently, gfortran can't handle
|
|
! unlimited polymorphic arguments in the default constructor.
|
|
class(*), target, intent(in) :: val
|
|
type(wrap) :: wrap_init
|
|
wrap_init%value => val
|
|
end function wrap_init
|
|
|
|
|
|
subroutine table_init(self, id, title, labels, active)
|
|
! Initialises the table
|
|
class(table), intent(out) :: self
|
|
integer, intent(in) :: id
|
|
character(*), intent(in) :: title
|
|
character(*), intent(in) :: labels(:)
|
|
|
|
logical, intent(in), optional :: active
|
|
|
|
integer :: i
|
|
|
|
self%id = id
|
|
self%title = title
|
|
self%labels = labels
|
|
self%columns = [(queue(), i=1,size(labels))]
|
|
|
|
if (present(active)) self%active = active
|
|
end subroutine table_init
|
|
|
|
|
|
pure function table_empty(self)
|
|
! Checks whether the table is empty
|
|
class(table), intent(in) :: self
|
|
logical :: table_empty
|
|
|
|
table_empty = self%columns(1)%empty()
|
|
end function table_empty
|
|
|
|
|
|
subroutine table_append(self, row)
|
|
! Appends an extra row to the table
|
|
!
|
|
! Heterogenous values are supported, provided they
|
|
! are wrapped in a `wrap` type.
|
|
|
|
class(table), intent(inout) :: self
|
|
class(*), intent(in) :: row(:)
|
|
|
|
integer :: i
|
|
|
|
do i = 1, size(self%columns)
|
|
select type (row)
|
|
type is (wrap)
|
|
call self%columns(i)%put(row(i)%value)
|
|
class default
|
|
call self%columns(i)%put(row(i))
|
|
end select
|
|
end do
|
|
|
|
end subroutine table_append
|
|
|
|
|
|
subroutine table_save(self, error, filepath, header)
|
|
! Save the table to a file
|
|
!
|
|
! Note: this operation consumes the table
|
|
use utils, only : digits
|
|
|
|
! suborutine arguments
|
|
class(table), intent(inout) :: self
|
|
integer, intent(out) :: error
|
|
character(*), intent(in), optional :: filepath
|
|
character(*), optional :: header
|
|
|
|
! local variables
|
|
integer :: i, file
|
|
class(*), allocatable :: val
|
|
character(len=len(self%title) + 4) :: filepath_
|
|
character(len=10) :: fmt
|
|
|
|
error = 0
|
|
if (self%empty()) return
|
|
|
|
! set default file name
|
|
if (present(filepath)) then
|
|
filepath_ = filepath
|
|
else
|
|
write(filepath_, '(a,".",i0,".txt")') trim(self%title), self%id
|
|
end if
|
|
|
|
! open output file
|
|
open(newunit=file, file=filepath_, action='write', iostat=error)
|
|
if (error /= 0) return
|
|
|
|
! write a custom file header
|
|
if (present(header)) write(file, '(a)') trim(header)
|
|
|
|
! write table header
|
|
write(file, '(a)', advance='no') '#'
|
|
do i = 1, size(self%columns)
|
|
write(file, '(x,a)', advance='no') trim(self%labels(i))
|
|
end do
|
|
write(file, '(x)')
|
|
|
|
! iterate the table
|
|
do while (.not. self%empty())
|
|
|
|
! write a row
|
|
do i = 1, size(self%columns)
|
|
call self%columns(i)%get(val)
|
|
|
|
! format a record
|
|
select type (val)
|
|
type is (integer)
|
|
write(fmt, '("(i",i0,")")') max(5, 1 + digits(val))
|
|
write(file, fmt, advance='no') val
|
|
type is (real(wp_))
|
|
write(file, '(es16.8e3)', advance='no') val
|
|
type is (logical)
|
|
write(file, '(l1)', advance='no') val
|
|
type is (character(len=*))
|
|
write(file, '(a)', advance='no') trim(val)
|
|
end select
|
|
|
|
! add space between values
|
|
if (i < size(self%columns)) write(file, '(x)', advance='no')
|
|
end do
|
|
|
|
! start newline
|
|
write(file, '(x)')
|
|
end do
|
|
|
|
end subroutine table_save
|
|
|
|
|
|
pure function contour_init(R, z) result(self)
|
|
! Creates a contour
|
|
|
|
! functions arguments
|
|
real(wp_), intent(in) :: R(:), z(:)
|
|
type(contour) :: self
|
|
|
|
! local variables
|
|
integer :: n
|
|
|
|
! Ensure the first and last point are the same
|
|
n = size(R)
|
|
self%R = [R, R(1)]
|
|
self%z = [z, z(1)]
|
|
end function contour_init
|
|
|
|
|
|
pure function contour_init_rect(Rmin, Rmax, zmin, zmax) result(self)
|
|
! Given two ranges [Rmin, Rmax], [zmin, zmax] creates a
|
|
! rectangular contour as follows:
|
|
!
|
|
! (Rmin, zmax)╔═════╗(Rmax, zmax)
|
|
! ║4 3║
|
|
! ║ ║
|
|
! ║1 2║
|
|
! (Rmin, zmin)╚═════╝(Rmax, zmax)
|
|
!
|
|
|
|
! subroutine arguments
|
|
real(wp_), intent(in) :: Rmin, Rmax, zmin, zmax
|
|
type(contour) :: self
|
|
|
|
self = contour_init([Rmin, Rmax, Rmax, Rmin], [zmin, zmin, zmax, zmax])
|
|
end function contour_init_rect
|
|
|
|
|
|
pure function contour_contains(self, R0, z0) result(inside)
|
|
! Tests whether the point (`R`, `z`) lies inside the 2D contour
|
|
|
|
use utils, only : linear_interp, locate_unord
|
|
|
|
! subroutine arguments
|
|
class(contour), intent(in) :: self
|
|
real(wp_), intent(in) :: R0, z0
|
|
logical :: inside
|
|
|
|
! local variables
|
|
integer :: seg(size(self%R)), i, nsegs
|
|
real(wp_) :: R
|
|
|
|
inside = .false.
|
|
|
|
! Find the `nsegs` segments that intersect the horizontal
|
|
! line z=z0, i.e. `self%z(seg(i)) < z0 < self%z(seg(i)+1)`
|
|
call locate_unord(self%z, z0, seg, size(self%R), nsegs)
|
|
|
|
! No intersections, it must be outside (above or below)
|
|
if (nsegs == 0) return
|
|
|
|
! Count the number of intersections that lie to the left
|
|
! (equivalently, to the right) of the point. An even number
|
|
! means that the point is outside the polygon.
|
|
do i = 1, nsegs
|
|
! coordinate of the intersection between segment and z=z0
|
|
R = linear_interp(self%z(seg(i)), self%R(seg(i)), &
|
|
self%z(seg(i)+1), self%R(seg(i)+1), z0)
|
|
if (R < R0) inside = .not. inside
|
|
end do
|
|
end function contour_contains
|
|
|
|
|
|
subroutine test_queue()
|
|
integer, target :: x=1, y=2
|
|
real, target :: z = 1.231
|
|
logical, target :: p=.false.
|
|
character(len=4) :: s='ciao'
|
|
type(queue) :: q
|
|
class(*), allocatable :: c
|
|
|
|
call assert(q%empty(), 'queue is empty')
|
|
|
|
! put some items in
|
|
call q%put(x)
|
|
call q%put(y)
|
|
call q%put(z)
|
|
call q%put(p)
|
|
call q%put(s)
|
|
|
|
call assert(.not. q%empty(), 'queue is not empty')
|
|
|
|
! get them out and check them
|
|
call q%get(c)
|
|
call assert(transfer(c, x) == x, 'got back an integer')
|
|
call q%get(c)
|
|
call assert(transfer(c, y) == y, 'got back another integer')
|
|
call q%get(c)
|
|
call assert(transfer(c, z) == z, 'got back a real')
|
|
call q%get(c)
|
|
call assert(transfer(c, p) .eqv. p, 'got back a logical')
|
|
call q%get(c)
|
|
call assert(cast_char(c, 4) == s, 'got back a string')
|
|
|
|
call assert(q%empty(), 'queue is empty again')
|
|
|
|
! this should be finalised
|
|
call q%put(s)
|
|
|
|
contains
|
|
|
|
subroutine assert(p, msg)
|
|
logical, intent(in) :: p
|
|
character(len=*), intent(in) :: msg
|
|
|
|
if (.not. p) then
|
|
print '(a, a)', 'assertion failed: ', msg
|
|
stop
|
|
end if
|
|
end subroutine
|
|
|
|
pure function cast_char(x, n) result(y)
|
|
class(*), intent(in) :: x
|
|
integer, intent(in) :: n
|
|
character(len=n) :: y
|
|
|
|
select type (x)
|
|
type is (character(len=*))
|
|
y = x
|
|
class default
|
|
error stop 'invalid cast to character'
|
|
end select
|
|
end function
|
|
|
|
end subroutine test_queue
|
|
|
|
|
|
subroutine test_table()
|
|
type(table) :: tbl
|
|
integer :: i
|
|
class(*), allocatable :: x, y
|
|
|
|
call tbl%init(title='testing table', id=0, labels=['x', 'y'])
|
|
|
|
! fill in some values
|
|
call assert(tbl%empty(), 'table is empty')
|
|
do i = 1, 4
|
|
call tbl%append([0.2*i, (0.2*i)**2])
|
|
end do
|
|
call assert(.not. tbl%empty(), 'table is not empty')
|
|
|
|
! get them back
|
|
do i = 1, 4
|
|
call tbl%columns(1)%get(x)
|
|
call tbl%columns(2)%get(y)
|
|
call assert(transfer(x, 1.0) == (0.2*i), 'got correct x')
|
|
call assert(transfer(y, 1.0) == (0.2*i)**2, 'got correct y')
|
|
end do
|
|
|
|
call assert(tbl%empty(), 'table is empty again')
|
|
|
|
contains
|
|
|
|
subroutine assert(p, msg)
|
|
logical, intent(in) :: p
|
|
character(len=*), intent(in) :: msg
|
|
|
|
if (.not. p) then
|
|
print '(a, a)', 'assertion failed: ', msg
|
|
stop
|
|
end if
|
|
end subroutine
|
|
|
|
end subroutine test_table
|
|
|
|
end module types
|