196 lines
6.1 KiB
Fortran
196 lines
6.1 KiB
Fortran
! Associative map string -> real(8)
|
|
module amap
|
|
implicit none
|
|
|
|
! The key
|
|
type key_t
|
|
private
|
|
character(len=16) :: k = '-'
|
|
contains
|
|
procedure, private :: equals_key_t
|
|
generic, public :: operator(==) => equals_key_t
|
|
procedure, private :: write_key_t
|
|
generic, public :: write(formatted) => write_key_t
|
|
procedure, private :: set_to_key_t
|
|
generic, public :: assignment(=) => set_to_key_t
|
|
end type key_t
|
|
|
|
! The value
|
|
type value_t
|
|
private
|
|
real(8) :: v = huge(0.0d0) ! An out-of-band value
|
|
contains
|
|
procedure, private :: write_value_t
|
|
generic, public :: write(formatted) => write_value_t
|
|
procedure, private :: set_to_value_t
|
|
generic, public :: assignment(=) => set_to_value_t
|
|
end type value_t
|
|
|
|
! Map elements are (key,value) pairs
|
|
type pair_t
|
|
type(key_t) :: k = key_t()
|
|
type(value_t) :: v = value_t()
|
|
end type pair_t
|
|
|
|
! The map
|
|
type amap_t
|
|
private
|
|
type(pair_t), allocatable :: pairs(:)
|
|
integer, private :: extent = 10
|
|
integer, private :: high_water = 0
|
|
contains
|
|
procedure, public :: get => get_amap_t
|
|
procedure, public :: get_value => get_value_amap_t
|
|
procedure, public :: set => set_amap_t
|
|
procedure, public :: find => find_amap_t
|
|
procedure, public :: print => print_amap_t
|
|
procedure, public :: clear => clear_amap_t
|
|
procedure, private :: is_key_kt
|
|
procedure, private :: is_key_kvt
|
|
generic, public :: contains => is_key_kt, is_key_kvt
|
|
end type amap_t
|
|
|
|
contains
|
|
|
|
subroutine clear_amap_t(this)
|
|
class(amap_t), intent(inout) :: this
|
|
if (allocated(this%pairs)) then
|
|
deallocate(this%pairs)
|
|
end if
|
|
this%high_water = 0
|
|
end subroutine clear_amap_t
|
|
|
|
subroutine set_to_key_t(this, k)
|
|
class(key_t), intent(inout) :: this
|
|
character(len=*), intent(in) :: k
|
|
this%k = adjustl(k)
|
|
end subroutine set_to_key_t
|
|
|
|
subroutine set_to_value_t(this, v)
|
|
class(value_t), intent(inout) :: this
|
|
real(8), intent(in) :: v
|
|
this%v = v
|
|
end subroutine set_to_value_t
|
|
|
|
subroutine print_amap_t(this)
|
|
class(amap_t), intent(in) :: this
|
|
integer :: i
|
|
write(6,'(a,i0,a)') 'Map has ',this%high_water,' elements'
|
|
do i=1,this%high_water
|
|
write(6,'(4x,dt,a,dt)') this%pairs(i)%k,' -> ',this%pairs(i)%v
|
|
end do
|
|
end subroutine print_amap_t
|
|
|
|
subroutine set_amap_t(this,kv,vv)
|
|
class(amap_t), intent(inout) :: this
|
|
character(len=*), intent(in) :: kv
|
|
real(8), intent(in) :: vv
|
|
type(pair_t), allocatable :: tmp_pairs(:)
|
|
type(key_t) :: k
|
|
type(value_t) :: v
|
|
integer :: idx
|
|
|
|
k = kv
|
|
v = vv
|
|
if (.not. allocated(this%pairs)) then
|
|
allocate(this%pairs(this%extent))
|
|
end if
|
|
|
|
idx = this%find(k)
|
|
if (idx > 0) then
|
|
this%pairs(idx) = pair_t(k,v)
|
|
return
|
|
end if
|
|
|
|
if (this%high_water == size(this%pairs)) then
|
|
allocate(tmp_pairs(size(this%pairs)+this%extent))
|
|
tmp_pairs(1:this%high_water) = this%pairs
|
|
call move_alloc(tmp_pairs, this%pairs)
|
|
end if
|
|
this%high_water = this%high_water + 1
|
|
this%pairs(this%high_water) = pair_t(k,v)
|
|
|
|
end subroutine set_amap_t
|
|
|
|
function find_amap_t(this, k) result(r)
|
|
class(amap_t), intent(in) :: this
|
|
type(key_t), intent(in) :: k
|
|
integer :: r
|
|
do r = 1, this%high_water
|
|
if (this%pairs(r)%k == k) then
|
|
return
|
|
end if
|
|
end do
|
|
r = 0
|
|
end function find_amap_t
|
|
|
|
function get_amap_t(this, kv) result(r)
|
|
class(amap_t), intent(in) :: this
|
|
character(len=*), intent(in) :: kv
|
|
type(value_t) :: r
|
|
type(key_t) :: k
|
|
integer :: idx
|
|
k = kv
|
|
idx = this%find(k)
|
|
if (idx > 0) then
|
|
r = this%pairs(idx)%v
|
|
else
|
|
r = value_t()
|
|
end if
|
|
end function get_amap_t
|
|
|
|
function get_value_amap_t(this, kv) result(r)
|
|
class(amap_t), intent(in) :: this
|
|
character(len=*), intent(in) :: kv
|
|
real(8) :: r
|
|
type(value_t) :: s
|
|
s = this%get(kv)
|
|
r = s%v
|
|
end function get_value_amap_t
|
|
|
|
function is_key_kt(this, k) result(r)
|
|
class(amap_t), intent(in) :: this
|
|
type(key_t), intent(in) :: k
|
|
logical :: r
|
|
r = this%find(k) > 0
|
|
end function is_key_kt
|
|
|
|
function is_key_kvt(this, kv) result(r)
|
|
class(amap_t), intent(in) :: this
|
|
character(len=*), intent(in) :: kv
|
|
logical :: r
|
|
r = this%find(key_t(kv)) > 0
|
|
end function is_key_kvt
|
|
|
|
function equals_key_t(this, k) result(r)
|
|
class(key_t), intent(in) :: this
|
|
type(key_t), intent(in) :: k
|
|
logical :: r
|
|
r = trim(adjustl(this%k)) == trim(adjustl(k%k))
|
|
end function equals_key_t
|
|
|
|
subroutine write_key_t(key, unit, iotype, v_list, iostat, iomsg)
|
|
class(key_t), intent(in) :: key
|
|
integer, intent(in) :: unit
|
|
character(*), intent(in) :: iotype
|
|
integer, intent(in) :: v_list(:)
|
|
integer, intent(out) :: iostat
|
|
character(*), intent(inout) :: iomsg
|
|
iostat = 0
|
|
iomsg = ""
|
|
write(6,'(a)', iostat=iostat, iomsg=iomsg) trim(adjustl(key%k))
|
|
end subroutine write_key_t
|
|
|
|
subroutine write_value_t(value, unit, iotype, v_list, iostat, iomsg)
|
|
class(value_t), intent(in) :: value
|
|
integer, intent(in) :: unit
|
|
character(*), intent(in) :: iotype
|
|
integer, intent(in) :: v_list(:)
|
|
integer, intent(out) :: iostat
|
|
character(*), intent(inout) :: iomsg
|
|
iostat = 0
|
|
iomsg = ""
|
|
write(6,'(f0.6)', iostat=iostat, iomsg=iomsg) value%v
|
|
end subroutine write_value_t
|
|
end module amap
|