Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/LICENSE =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/LICENSE (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/LICENSE (revision 3705) @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Takuma Yoshida + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/README.md =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/README.md (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/README.md (revision 3705) @@ -0,0 +1,47 @@ +From https://github.com/ysdtkm/fortran_associative_array + +# Fortran associative array [![Build Status](https://travis-ci.org/ysdtkm/fortran_associative_array.svg?branch=master)](https://travis-ci.org/ysdtkm/fortran_associative_array) +A scalable associative array (known as **hash table** or **dictionary**) for Fortran + +## Specifications +* Internal data structure is treap (randomized binary search tree) +* Roughly corresponds to `std::map` (C++) or `dict` (Python) + * A **key** can be `characters` (either fixed or arbitrary length), an `integer`, or a `real` + * A **value** can be any fortran intrinsic data type (with fixed length or kind). A *copy* of the value is stored in the `dict` object + * Does not affect Fortran's intrinsic random state +* Implemented operations + + |Operation |Cost |Implementation | + |---- |---- |---- | + |Insertion/assignment |O(log n) |Subroutine `insert_or_assign(dict, key, val)` | + |Deletion |O(log n) |Subroutine `remove(dict, key)`
(Error if not exist) | + |Existence of a key |O(log n) |Logical function `exists(dict, key)` | + |Reference |O(log n) |Valuetype function `get_val(dict, key)`
(Error if not exist) | + |Get max/min/k-th key |O(log n) |Keytype function `get_kth_key(dict, k)`
(Error if out of bounds; 1-based)| + |Count |O(1) |Integer function `get_size(dict)` | + |Retrieve sorted array |O(n) |Subroutine `get_keys_vals(dict, keys, vals, n)`
(Not for arbitrary length keys)| + |Clear |O(n) |Implicitly called as a destructor | + +* Other operations allowed by the data structure (not implemented) + + |Operation |Cost |Note | + |---- |---- |---- | + |Merge/split |O(log n) |Destructive | + |lower_bound/upper_bound |O(log n) | | + |Range search |O(log n + elements found)| | + |Deep copy |O(n) |Preorder DFS | + +* Speed comparison with `gfortran`/`g++`, without compiler optimization + + + +## Usage +* See `sample.f90` for sample usage +* Edit `dtypes.h` if using another data types + * For string key (arbitrary length), `keytype1` should be `character(:),allocatable` and `keytype2` should be `character(*)` + * For other key types, `keytype1` and `keytype2` are the same + +## References +* Treap https://en.wikipedia.org/wiki/Treap +* Treap https://www.slideshare.net/iwiwi/2-12188757 + Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/dict_mod.f90.h =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/dict_mod.f90.h (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/dict_mod.f90.h (revision 3705) @@ -0,0 +1,296 @@ +module DICT_MODULENAME + ! Dictionary data structure + + implicit none + + private + public :: dict, get_val, insert_or_assign, exists, remove, get_keys_vals, get_size, get_kth_key + + type dict + type(node), pointer :: root => null() + integer :: randstate = 1231767121 + contains + final :: destruct_dict + end type dict + + type node + type(node), pointer :: left => null(), right => null() + keytype1 :: key + valtype :: val + integer :: pri ! min-heap + integer :: cnt = 1 + end type node + + contains + + pure function xorshift32(i) + implicit none + integer(4), intent(in) :: i + integer(4) :: xorshift32 + if (i == 0) then + xorshift32 = 1231767121 + else + xorshift32 = i + end if + xorshift32 = ieor(xorshift32, ishft(xorshift32, 13)) + xorshift32 = ieor(xorshift32, ishft(xorshift32, -17)) + xorshift32 = ieor(xorshift32, ishft(xorshift32, 15)) + end function xorshift32 + + function get_val(t, key) + implicit none + type(dict), intent(in) :: t + keytype2, intent(in) :: key + type(node), pointer :: nd + valtype :: get_val + nd => find_node(t%root, key) + if (.not. associated(nd)) then + stop 105 + end if + get_val = nd%val + end function get_val + + function exists(t, key) + implicit none + type(dict), intent(in) :: t + keytype2, intent(in) :: key + type(node), pointer :: nd + logical :: exists + nd => find_node(t%root, key) + exists = (associated(nd)) + end function exists + + subroutine insert_or_assign(t, key, val) + implicit none + type(dict), intent(inout) :: t + keytype2, intent(in) :: key + valtype, intent(in) :: val + type(node), pointer :: nd + nd => find_node(t%root, key) + if (associated(nd)) then + nd%val = val + else ! This implementation is not optimal + t%root => insert(t%root, key, val, t%randstate) + t%randstate = xorshift32(t%randstate) + end if + end subroutine insert_or_assign + + subroutine remove(t, key) + implicit none + type(dict), intent(inout) :: t + keytype2, intent(in) :: key + t%root => erase(t%root, key) + end subroutine remove + + function get_kth_key(t, k) + implicit none + type(dict), intent(in) :: t + integer, intent(in) :: k + type(node), pointer :: res + keytype1 :: get_kth_key + if (k < 1 .or. k > my_count(t%root)) then + print *, "get_kth_key failed" + stop 2 + else + res => kth_node(t%root, k) + get_kth_key = res%key + end if + end function get_kth_key + + subroutine get_keys_vals(t, keys, vals, n) + implicit none + type(dict), intent(in) :: t + integer, intent(in) :: n + keytype2, intent(out) :: keys(n) + valtype, intent(out) :: vals(n) + integer :: counter + if (my_count(t%root) /= n) stop 5 + counter = 0 + call inorder(t%root, keys, vals, counter) + end subroutine get_keys_vals + + function get_size(t) + implicit none + type(dict), intent(in) :: t + integer :: get_size + get_size = my_count(t%root) + end function get_size + + subroutine destruct_dict(t) + implicit none + type(dict), intent(inout) :: t + call delete_all(t%root) + end subroutine destruct_dict + + subroutine update(root) + implicit none + type(node), pointer, intent(in) :: root + root%cnt = my_count(root%left) + my_count(root%right) + 1 + end subroutine update + + function my_count(root) + implicit none + type(node), pointer, intent(in) :: root + integer :: my_count + if (associated(root)) then + my_count = root%cnt + else + my_count = 0 + end if + end function my_count + + function rotate_ccw(root) + implicit none + type(node), pointer, intent(in) :: root + type(node), pointer :: tmp, rotate_ccw + if (.not. associated(root%right)) stop 1 + tmp => root%right + root%right => tmp%left + tmp%left => root + rotate_ccw => tmp + call update(root) + call update(tmp) + end function rotate_ccw + + function rotate_cw(root) + implicit none + type(node), pointer, intent(in) :: root + type(node), pointer :: tmp, rotate_cw + if (.not. associated(root%left)) stop 1 + tmp => root%left + root%left => tmp%right + tmp%right => root + rotate_cw => tmp + call update(root) + call update(tmp) + end function rotate_cw + + recursive function insert(root, key, val, pri) result(res) + implicit none + type(node), pointer, intent(in) :: root + integer, intent(in) :: pri + keytype2, intent(in) :: key + valtype, intent(in) :: val + type(node), pointer :: res + + if (.not. associated(root)) then + allocate(res) + res%key = key + res%pri = pri + res%val = val + else + res => root + if (key > root%key) then + root%right => insert(root%right, key, val, pri) + call update(root) + if (root%pri > root%right%pri) then + res => rotate_ccw(res) + end if + else + root%left => insert(root%left, key, val, pri) + call update(root) + if (root%pri > root%left%pri) then + res => rotate_cw(res) + end if + end if + end if + end function insert + + recursive function erase(root, key) result(res) + implicit none + type(node), pointer, intent(in) :: root + keytype2, intent(in) :: key + type(node), pointer :: res, tmp + + if (.not. associated(root)) then + print *, "Erase failed" + stop 1 + end if + + if (key < root%key) then + root%left => erase(root%left, key) + res => root + else if (key > root%key) then + root%right => erase(root%right, key) + res => root + else + if ((.not. associated(root%left)) .or. (.not. associated(root%right))) then + tmp => root + if (.not. associated(root%left)) then + res => root%right + else + res => root%left + end if + deallocate(tmp) + else + if (root%left%pri < root%right%pri) then + res => rotate_ccw(root) + res%left => erase(res%left, key) + else + res => rotate_cw(root) + res%right => erase(res%right, key) + end if + end if + end if + if (associated(res)) call update(res) + end function erase + + recursive function find_node(root, key) result(res) + implicit none + type(node), pointer, intent(in) :: root + keytype2, intent(in) :: key + type(node), pointer :: res + if (.not. associated(root)) then + res => null() + else if (root%key == key) then + res => root + else if (key < root%key) then + res => find_node(root%left, key) + else + res => find_node(root%right, key) + end if + end function find_node + + recursive function kth_node(root, k) result(res) + implicit none + type(node), pointer, intent(in) :: root + integer, intent(in) :: k + type(node), pointer :: res + if (.not. associated(root)) then + res => null() + else if (k <= my_count(root%left)) then + res => kth_node(root%left, k) + else if (k == my_count(root%left) + 1) then + res => root + else + res => kth_node(root%right, k - my_count(root%left) - 1) + end if + end function kth_node + + recursive subroutine delete_all(root) + implicit none + type(node), pointer, intent(inout) :: root + if (.not. associated(root)) return + + call delete_all(root%left) + call delete_all(root%right) + deallocate(root) + nullify(root) + end subroutine delete_all + + recursive subroutine inorder(root, keys, vals, counter) + implicit none + type(node), pointer, intent(in) :: root + keytype2, intent(inout) :: keys(:) + valtype, intent(inout) :: vals(:) + integer, intent(inout) :: counter + if (.not. associated(root)) return + + call inorder(root%left, keys, vals, counter) + counter = counter + 1 + keys(counter) = root%key + vals(counter) = root%val + call inorder(root%right, keys, vals, counter) + end subroutine inorder + +end module DICT_MODULENAME Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/sample.f90 =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/sample.f90 (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict/sample.f90 (revision 3705) @@ -0,0 +1,43 @@ +program sample + call test_int + call test_real + + contains + subroutine test_int + use dict_int_mod, only: dict, exists, get_size, get_val, insert_or_assign, remove + implicit none + + type(dict) :: ages ! Initialized empty + + call insert_or_assign(ages, "Alice", 28) + call insert_or_assign(ages, "Bob", 13) + call insert_or_assign(ages, "Carol", 47) + call insert_or_assign(ages, "Alice", 35) ! Updated + + print *, "Alice is", get_val(ages, "Alice"), "years old" ! 35 + print *, "Do we know Dave's age?", exists(ages, "Dave") ! False + + call remove(ages, "Bob") + + print *, "Now we know the ages of", get_size(ages), "people" ! Alice and Caro + end subroutine test_int + subroutine test_real + use dict_real_mod, only: dict, exists, get_size, get_val, insert_or_assign, remove + implicit none + + type(dict) :: ages ! Initialized empty + + call insert_or_assign(ages, "Alice", 28.) + call insert_or_assign(ages, "Bob", 13.) + call insert_or_assign(ages, "Carol", 47.) + call insert_or_assign(ages, "Alice", 35.) ! Updated + + print *, "Alice is", get_val(ages, "Alice"), "years old" ! 35 + print *, "Do we know Dave's age?", exists(ages, "Dave") ! False + + call remove(ages, "Bob") + + print *, "Now we know the ages of", get_size(ages), "people" ! Alice and Caro + end subroutine test_real +end program sample + Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_int_mod.F90 =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_int_mod.F90 (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_int_mod.F90 (revision 3705) @@ -0,0 +1,5 @@ +#define keytype1 character(:),allocatable +#define keytype2 character(*) +#define DICT_MODULENAME dict_int_mod +#define valtype integer +#include "dict/dict_mod.f90.h" Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_logical_mod.F90 =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_logical_mod.F90 (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_logical_mod.F90 (revision 3705) @@ -0,0 +1,5 @@ +#define keytype1 character(:),allocatable +#define keytype2 character(*) +#define DICT_MODULENAME dict_logical_mod +#define valtype logical +#include "dict/dict_mod.f90.h" Index: LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_real_mod.F90 =================================================================== --- LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_real_mod.F90 (revision 3705) +++ LMDZ6/branches/Optimisation_LMDZ/libf/misc/dict_real_mod.F90 (revision 3705) @@ -0,0 +1,5 @@ +#define keytype1 character(:),allocatable +#define keytype2 character(*) +#define DICT_MODULENAME dict_real_mod +#define valtype real +#include "dict/dict_mod.f90.h"