1
! @@LICENSE@@ see Copyright notice in the top-directory
3
#include "bud_utils.inc"
5
! The following pre-processor variables are currently used when
7
! - BUD_MOD_NAME of the module
8
! - BUD_TYPE_NAME of the type
9
! - BUD_TYPE_NAME_, internal data pointer of the type
10
! - BUD_TYPE_NAME_STR, the routine name in "string" format (for IO)
11
! - BUD_TYPE_VAR, the variable type contained in the array
12
! - BUD_TYPE_VAR_PREC, the precision specifier for the array
14
!> BUD_MOD_NAME documentation
17
!! The detailed implementation of the BUD_TYPE_NAME type.
20
!! This documentation is duplicated in all types with different precision.
22
! First we need to use the parameters
23
use BUD_CC3(BUD_MOD,_,List_common)
25
! This *MUST* be the first statement
26
! Common parameters and variables used
27
# include "bud_common_declarations.inc"
31
!! This data type contains the reference counted
34
!! The content is of fixed size. So changing the
35
!! List dimensions is heavy on performance.
38
!> @cond BUD_DEVELOPER
40
!> Stored pointer which contains the reference counting etc.
41
type(BUD_TYPE_NAME_), pointer :: D => null()
43
!> @endcond BUD_DEVELOPER
45
# include "bud_common_type.inc"
46
#if BUD_FORTRAN >= 2003
48
!> @name Private procedures
52
procedure, private :: new_dim_
53
procedure, private :: new_copy_
54
procedure, private :: new_copy_n_
55
procedure, private :: new_range_
57
procedure, private :: push_value_
58
procedure, private :: push_array_
59
procedure, private :: push_list_
61
procedure, private :: shrink_
62
procedure, private :: shrink_n_
64
# ifdef BUD_IS_INTEGER
65
procedure, private :: new_index_list_range_
66
procedure, private :: new_index_list_list_
72
generic, public :: new => new_dim_, new_copy_, &
73
new_copy_n_, new_range_
75
# ifdef BUD_IS_INTEGER
76
!> @iSee new_index_list
77
generic, public :: new_index_list => new_index_list_list_, &
82
procedure, public :: size => size_
84
procedure, public :: size_p => sizep_
87
procedure, public :: size_max => max_size_
89
procedure, public :: size_max_p => max_size_p_
92
procedure, public :: list_p => list_p_
94
procedure, public :: list_max_p => list_max_p_
97
generic, public :: push => push_value_, push_array_, push_list_
100
procedure, public :: pop => pop_value_
102
# ifdef BUD_IS_INTEGER
104
procedure, public :: sort => sort_
108
procedure, public :: union => union_
110
procedure, public :: complement => complement_
112
procedure, public :: intersect => intersect_
116
procedure, public :: unique => unique_
120
procedure, public :: reverse => reverse_
123
procedure, public :: reorder => reorder_
126
procedure, public :: extend => extend_
129
generic, public :: shrink => shrink_, shrink_n_
132
procedure, public :: clear => clear_
135
procedure, public :: merge => merge_
137
!> @iSee #set_increment
138
procedure, public :: set_increment => set_increment_
141
procedure, public :: increment => increment_
143
# ifdef BUD_IS_INTEGER
145
procedure, public :: index => index_
148
# ifndef BUD_IS_COMPLEX
150
procedure, public :: minval => minval_
152
procedure, public :: maxval => maxval_
155
# ifdef BUD_IS_INTEGER
157
procedure, public :: in_list => in_list_
160
procedure, public :: is_sorted => is_sorted_
164
end type BUD_TYPE_NAME
166
!> @cond BUD_DEVELOPER
168
!> @bud container for BUD_TYPE_NAME
170
!! Contains a List of integers.
174
!> Associated name of the list
175
character(len=LIST_MAX_NAME_LEN) :: name = ' '
177
!> Current number of stored values
178
integer(BUD_INT_PREC) :: n = 0
180
!> Current maximum number of values
181
integer(BUD_INT_PREC) :: max_n = 0
183
!> Incremental extension when the list is not enough
184
!! In some cases this may be advantageous to be a relatively low number.
185
integer(BUD_INT_PREC) :: incr_n = 10
187
!> List content stored in the @bud
188
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), allocatable :: lst(:)
190
!> Whether this list is a sorted list, or not
192
!! A sorted list has certain efficient properties
193
!! when querying certain elements.
194
logical :: sorted = .false.
196
! Consistent data in the reference counted object
197
# include "bud_common_type_.inc"
199
end type BUD_TYPE_NAME_
201
!> @endcond BUD_DEVELOPER
203
!> Create a new BUD_TYPE_NAME.
205
!! This allocates the data list in the @bud.
207
!! The dimensions of the contained array may be
208
!! explicitly passed, or an array may be passed
209
!! which will be copied to the contained array.
212
!! If the array is created from dimensions, the initial
213
!! value of the array is arbitrary.
215
module procedure new_dim_
216
module procedure new_copy_
217
module procedure new_copy_n_
218
module procedure new_range_
222
#ifdef BUD_IS_INTEGER
223
!> Create a new list via an index transfer.
225
!! This enables one to create an index list (or pivoting list)
226
!! which contains the indices of certain values in another
228
interface new_index_list
229
module procedure new_index_list_list_
230
module procedure new_index_list_range_
232
public :: new_index_list
235
!> Retrieve pointer to array in the @bud
237
!! The array-pointer will _always_ be contiguous.
239
!! This pointer will only be a sub-set pointer of the
240
!! total list array if `size(this) < max_size(this)`.
241
!! @iSee #list_max_p for the full list pointer.
244
!! Do not deallocate the array-pointer.
246
module procedure list_p_
250
!> Retrieve pointer to full array in the @bud
252
!! The array-pointer will _always_ be contiguous.
255
!! Do not deallocate the array-pointer.
257
module procedure list_max_p_
262
!> Query current size of list (number of current elements)
264
!! Returns the size of the list.
266
!! This is equivalent to:
272
module procedure size_
277
!> Track the current size of list (number of current elements)
279
!! Returns a pointer to the size of the list.
281
module procedure sizep_
286
!> Query maximum allowed size of list
288
!! Returns the allowed size of the list.
290
module procedure max_size_
294
!> Track maximum allowed size of list
296
!! Returns a pointer to the the allowed size of the list.
298
module procedure max_size_p_
303
#ifdef BUD_IS_INTEGER
304
!> Returns index of the queried element. If non-existing returns `-1`.
306
module procedure index_
312
#ifndef BUD_IS_COMPLEX
313
!> Returns the minimum value in the list
315
module procedure minval_
319
!> Returns the maximum value in the list
321
module procedure maxval_
326
!> Push a new value to the list (added at the end)
328
!! Will append a new value in the list (at the end).
329
!! In case there is not any available elements, i.e. if:
331
!! size(this) == max_size(this)
333
!! then the internal array will be re-allocated.
334
!! This means that a pointer to the array should be
335
!! re-instantiated, if needed.
337
module procedure push_value_, push_array_, push_list_
342
!> Pop the last element in the list
344
!! Will return and remove the latest element in the list (from the end).
345
!! The list will never be re-allocated.
347
module procedure pop_value_
351
!> Merges two lists into a new list.
353
!! Takes two lists and merges them into one. This is equivalent to
360
module procedure merge_
365
#ifdef BUD_IS_INTEGER
366
!> Sorts the entries in the list
368
!! The values in the list will be sorted.
370
!! To create a copy of the list and sort the copied list
371
!! one must do the following:
373
!! call copy(this, other)
377
module procedure sort_
383
!> Ensures that the list may contain a given number of values
385
!! One may query an explicit number of maximum values (`max_n`),
386
!! or an additive number of values (`n`).
388
module procedure extend_
392
!> Shrinks the List to the number of elements currently in the List (or an explicit size)
394
!! If the number of contained elements are larger than the new size,
395
!! the last elements will silently be removed.
397
module procedure shrink_, shrink_n_
402
#ifdef BUD_IS_INTEGER
404
!> Returns the union of two lists in a third list
406
module procedure union_
410
!> Returns the intersection of two lists in a third list
412
module procedure intersect_
416
!> Returns the complement of two lists in a third list
418
module procedure complement_
422
!> Reduces the list to only the unique elements
424
module procedure unique_
428
!> Query whether a value is in the list
430
module procedure in_list_
434
!> Query whether the list is sorted. It will return `.true.` if the list has
435
!! size == 1, or if it has been sorted.
437
module procedure is_sorted_
445
module procedure reverse_
451
module procedure reorder_
456
! Define a few constants used throughout
457
integer(BUD_INT_PREC), parameter :: ONE = BUD_CC2(1_,BUD_INT_PREC)
460
! Include common data routines
461
! Note that 'CONTAINS' is present in this include file.
462
# include "bud_common.inc"
465
!> @cond BUD_DEVELOPER
467
!> Internal routine for cleaning up the data container.
470
!! This routine is only used internally to clean-up
471
!! any data in the type.
472
!! Should never be made public.
473
subroutine delete_(this)
474
type(BUD_TYPE_NAME), intent(inout) :: this
477
! Currently we do not allow external memory
479
if ( .not. allocated(this%D%lst) ) return
480
deallocate(this%D%lst, stat=stat)
481
call set_error(this, stat)
485
#ifdef BUD_IS_INTEGER
486
this%D%sorted = .false.
489
end subroutine delete_
491
!> @endcond BUD_DEVELOPER
494
!> @param[in] from the origin of data
495
!! @param[inout] to the destination of the data
496
subroutine copy_(from, to)
497
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: from
498
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: to
501
if ( .not. is_initd(from) ) return
503
call new_copy_n_(to, from%D%n, from%D%lst)
505
call common_copy_(from, to)
510
!> @param[inout] this array @bud
511
!! @param[in] n size of list
512
subroutine new_dim_(this, n)
513
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
514
integer(BUD_INT_PREC), intent(in) :: n
516
! Make sure the container is initialized and ready for
519
call initialize(this)
521
! Allocate the value array
522
allocate(this%D%lst(n))
526
#ifdef BUD_IS_INTEGER
527
this%D%sorted = .false.
530
end subroutine new_dim_
533
!> @param[inout] this list @bud
534
!! @param[in] list list to duplicate in `this` (dimensions _and_ values), *must* be contiguous
535
subroutine new_copy_(this, list)
536
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
537
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in) BUD_FORTRAN_CONTIGUOUS :: list(:)
539
integer(BUD_INT_PREC) :: n
543
call new_copy_n_(this, n, list)
545
end subroutine new_copy_
548
!> @param[inout] this array @bud
549
!! @param[in] a first value of the range
550
!! @param[in] b last value of the range
551
!! @param[in] step @opt=1 the step of the sequence
552
subroutine new_range_(this, a, b, step)
553
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
554
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in) :: a, b
555
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in), optional :: step
557
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC) :: c, lstep
558
integer(BUD_INT_PREC) :: i, n
561
if ( present(step) ) lstep = step
564
call new_dim_(this, n)
566
this%D%n = this%D%max_n
573
#ifdef BUD_IS_INTEGER
574
if ( lstep > 0 ) then
575
this%D%sorted = .true.
579
end subroutine new_range_
581
!> @param[inout] this list @bud
582
!! @param[in] n size of list
583
!! @param[in] list list to duplicate in `this` (dimensions _and_ values)
584
subroutine new_copy_n_(this, n, list)
585
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
586
integer(BUD_INT_PREC), intent(in) :: n
587
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in) :: list(n)
589
! initialize and create data-container
590
call new_dim_(this, n)
593
call push(this, n, list)
595
end subroutine new_copy_n_
598
#ifdef BUD_IS_INTEGER
599
!> @param[inout] this list @bud
600
!! @param[in] list list to convert to a list index using `[1:size(list)]`
601
subroutine new_index_list_range_(this, list)
602
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
603
type(BUD_TYPE_NAME), intent(in) :: list
605
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: ths(:)
606
integer(BUD_INT_PREC) :: i, n
607
type(BUD_TYPE_NAME) :: tmp
611
call new_dim_(tmp, n)
616
ths(i) = index(list, i)
619
! Doing it like this allows for using the same list
623
end subroutine new_index_list_range_
625
!> @param[inout] this list @bud
626
!! @param[in] list list to lookup values from `lookup`
627
!! @param[in] lookup the lookup values in `list`
628
subroutine new_index_list_list_(this, list, lookup)
629
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
630
type(BUD_TYPE_NAME), intent(in) :: list, lookup
632
type(BUD_TYPE_NAME) :: tmp
633
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: ths(:), look(:)
634
integer(BUD_INT_PREC) :: i, n
638
call new_dim_(tmp, n)
641
look => list_p(lookup)
644
ths(i) = index(list, look(i))
650
end subroutine new_index_list_list_
653
!> @param[in] this @bud container
654
!! @return the size of the contained list
655
pure function size_(this) result(d)
656
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
658
integer(BUD_INT_PREC) :: d
660
if ( is_initd(this) ) then
668
!> @param[in] this @bud container
669
!! @return a pointer to the current size of the contained list
670
function sizep_(this) result(d)
671
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
673
integer(BUD_INT_PREC), pointer :: d
675
if ( is_initd(this) ) then
684
!> @param[in] this @bud container
685
!! @return the size of the contained list
686
pure function max_size_(this) result(d)
687
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
689
integer(BUD_INT_PREC) :: d
691
if ( is_initd(this) ) then
697
end function max_size_
699
!> @param[in] this @bud container
700
!! @return the size of the contained list
701
function max_size_p_(this) result(d)
702
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
704
integer(BUD_INT_PREC), pointer :: d
706
if ( is_initd(this) ) then
712
end function max_size_p_
715
!> @param[inout] this list
716
!! @param[in] incr_n the default number of values that should be
717
subroutine set_increment_(this, incr_n)
718
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
719
integer(BUD_INT_PREC), intent(in) :: incr_n
721
if ( .not. is_initd(this) ) return
723
this%D%incr_n = incr_n
725
end subroutine set_increment_
727
!> @param[in] this list
728
!! @param[out] incr_n the default number of values that should be
729
subroutine increment_(this, incr_n)
730
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
731
integer(BUD_INT_PREC), intent(out) :: incr_n
734
if ( .not. is_initd(this) ) return
736
incr_n = this%D%incr_n
738
end subroutine increment_
741
!> @cond BUD_DEVELOPER
743
!> Initialize `bud` if not initialized with size `n`, else extend by `n`
745
!! If `this` is not initialized the `bud` will be initialized and
746
!! have initial size `n`.
747
!! Else, `this` will be extended to be at least capable of retaining
748
!! its current elements + `n`.
750
!! @param[inout] this List to be asserted
751
!! @param[in] n size to be initialized/extended
752
subroutine assert_init_size_add(this, n)
753
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
754
integer(BUD_INT_PREC), intent(in) :: n
756
if ( is_initd(this) ) then
758
if ( this%D%max_n < this%D%n + n ) then
759
call extend(this, max_n= &
760
max(this%D%n+n,this%D%max_n+this%D%incr_n))
765
call new_dim_(this, n)
769
end subroutine assert_init_size_add
771
!> @endcond BUD_DEVELOPER
774
!> @param[inout] this list @bud
775
!! @param[in] val value to be appended to the list
776
subroutine push_value_(this, val)
777
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
778
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC) :: val
780
call assert_init_size_add(this, BUD_CC2(1_,BUD_INT_PREC) )
782
this%D%n = this%D%n + 1
783
this%D%lst(this%D%n) = val
785
#ifdef BUD_IS_INTEGER
786
if ( this%D%sorted .and. this%D%n > 1 ) then
787
this%D%sorted = this%D%lst(this%D%n-1) <= this%D%lst(this%D%n)
789
this%D%sorted = .false.
793
end subroutine push_value_
796
!> @param[inout] this list @bud
797
!! @param[in] n size of list to be added to the list
798
!! @param[in] list the list to be added to the list
799
subroutine push_array_(this, n, list)
800
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
801
integer(BUD_INT_PREC), intent(in) :: n
802
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in) :: list(n)
803
integer(BUD_INT_PREC) :: i
804
#ifdef BUD_IS_INTEGER
810
call assert_init_size_add(this, n)
812
#ifdef BUD_IS_INTEGER
813
if ( this%D%n > 0 ) then
814
sorted = this%D%lst(this%D%n) <= list(1)
816
! This is an empty list, so
817
! it will probably be default to
818
! true if the passed list is sorted.
823
this%D%lst(this%D%n+1) = list(1)
825
this%D%lst(this%D%n+i) = list(i)
826
#ifdef BUD_IS_INTEGER
827
sorted = sorted .and. &
832
this%D%n = this%D%n + n
834
#ifdef BUD_IS_INTEGER
835
this%D%sorted = this%D%sorted .and. sorted
838
end subroutine push_array_
840
!> @param[inout] this list @bud
841
!! @param[in] other other list to be added to `this`
842
subroutine push_list_(this, other)
843
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
844
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: other
846
if ( .not. is_initd(other) ) return
848
call push(this, other%D%n, other%D%lst)
850
end subroutine push_list_
853
!> @param[inout] this List
854
!! @return the last element in the list (also decrement list size)
855
!! if there are no elements `0` will be returned.
856
function pop_value_(this) result(val)
857
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
858
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC) :: val
860
if ( size(this) == 0 ) then
865
val = this%D%lst(this%D%n)
866
this%D%n = this%D%n - 1
868
end function pop_value_
870
!> @param[in] A first list
871
!> @param[in] B second list
872
!> @param[inout] C the merged list of `A` and `B`
873
subroutine merge_(A, B, C)
874
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: A, B
875
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: C
876
type(BUD_TYPE_NAME) :: tmp
878
! We need to operate on a temporary list,
885
end subroutine merge_
887
!> @param[in] this list @bud
888
!! @return a pointer to the list (contiguous)
889
function list_p_(this) result(p)
890
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
891
#ifdef BUD_TYPE_VAR_PREC
892
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
894
BUD_TYPE_VAR, pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
897
! only return the currently known values
898
p => this%D%lst(1:this%D%n)
902
!> @param[in] this list @bud
903
!! @return a pointer to the list (contiguous)
904
function list_max_p_(this) result(p)
905
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
906
#ifdef BUD_TYPE_VAR_PREC
907
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
909
BUD_TYPE_VAR, pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
912
! return the full list values
915
end function list_max_p_
918
!> @param[in] this @bud container
919
!! @param[in] max_n maximum number of allowed elements that should be available in the list
920
!! @param[in] n @opt number of elements that needs to be available in its current state
921
subroutine extend_(this, max_n, n)
922
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
923
integer(BUD_INT_PREC), optional :: max_n, n
925
integer(BUD_INT_PREC) :: lmax_n, i
926
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), allocatable :: tmp(:)
928
! We will select the larger of the two
929
! max(max_n, this%D%n + n, this%D%max_n)
930
if ( present(n) .and. present(max_n) ) then
931
lmax_n = max(max_n, this%D%max_n, this%D%n + n)
932
else if ( present(n) ) then
933
lmax_n = max(this%D%max_n, this%D%n + n)
934
else if ( present(max_n) ) then
935
lmax_n = max(this%D%max_n, max_n)
938
! The user is actually not requesting any
944
! quick-return if possible...
945
if ( lmax_n <= this%D%max_n ) return
947
! Extend the array to the new size
948
allocate(tmp(this%D%n))
950
tmp(i) = this%D%lst(i)
953
deallocate(this%D%lst)
954
allocate(this%D%lst(this%D%n+n))
955
! set the new maximum size of the list
956
this%D%max_n = lmax_n
958
this%D%lst(i) = tmp(i)
962
end subroutine extend_
965
!> @param[inout] this @bud container
966
!! @param[in] max_n new maximum number of allowed elements that should be available in the list
967
subroutine shrink_n_(this, max_n)
968
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
969
integer(BUD_INT_PREC), intent(in) :: max_n
971
integer(BUD_INT_PREC) :: i, n
972
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), allocatable :: tmp(:)
974
n = min(max_n, this%D%n)
976
! Reduce the array to the new size
977
! we only need to copy the elements
981
tmp(i) = this%D%lst(i)
985
deallocate(this%D%lst)
986
allocate(this%D%lst(max_n))
988
! set the new maximum size of the list
991
this%D%lst(i) = tmp(i)
999
end subroutine shrink_n_
1001
!> @param[inout] this List reduced to number of elements already in the list
1002
subroutine shrink_(this)
1003
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1005
integer(BUD_INT_PREC) :: n
1008
call shrink(this, n)
1010
end subroutine shrink_
1013
!> @param[inout] this clear the elements without shrinking the allocated list
1014
!! @param[in] n @opt=0 the retained elements in the list
1015
subroutine clear_(this, n)
1016
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1017
integer(BUD_INT_PREC), intent(in), optional :: n
1018
integer(BUD_INT_PREC) :: ln
1020
if ( .not. is_initd(this) ) return
1023
if ( present(n) ) ln = n
1027
end subroutine clear_
1030
#ifdef BUD_IS_INTEGER
1031
!> @param[inout] this list @bud (sorted on exit)
1032
subroutine sort_(this)
1033
use BUD_CC2(BUD_MOD,_utils), only: sort_quick
1034
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1036
if ( this%D%n > 0 ) then
1037
call sort_quick(this%D%n, this%D%lst)
1040
this%D%sorted = .true.
1042
end subroutine sort_
1045
!> @param[in] A list one
1046
!> @param[in] B list two
1047
!> @param[inout] C the list that intersects `A` and `B`
1048
subroutine intersect_(A, B, C)
1049
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: A, B
1050
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: C
1052
type(BUD_TYPE_NAME) :: tmp, D
1053
integer(BUD_INT_PREC) :: i, n
1054
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: l(:)
1056
! Ensure the output list is empty
1059
! Quick return if the list is
1060
n = min(size(A), size(B))
1067
call new_dim_(tmp, n)
1069
! Prefer to not copy any of the sets...
1070
if ( is_sorted(A) .and. .not. is_sorted(B) ) then
1075
if ( in_list(A, l(i)) ) then
1076
call push(tmp, l(i))
1080
else if ( .not. is_sorted(A) .and. is_sorted(B) ) then
1085
if ( in_list(B, l(i)) ) then
1086
call push(tmp, l(i))
1090
else if ( size(A) > size(B) ) then
1092
! We will sort list B and then perform the list insertion
1093
! We will sort list B and then perform the list insertion
1094
if ( is_sorted(B) ) then
1095
! both are actually sorted, but B is smaller
1105
if ( in_list(D, l(i)) ) then
1106
call push(tmp, l(i))
1114
! We will sort list B and then perform the list insertion
1115
if ( is_sorted(A) ) then
1116
! both are actually sorted, but B is smaller
1126
if ( in_list(D, l(i)) ) then
1127
call push(tmp, l(i))
1138
end subroutine intersect_
1141
!> @param[in] A list one
1142
!> @param[in] B list two
1143
!> @param[inout] C list as union of `A` and `B`
1144
subroutine union_(A, B, C)
1145
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: A, B
1146
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: C
1148
type(BUD_TYPE_NAME) :: tmp, D
1149
logical :: sorted_A, sorted_B
1150
integer(BUD_INT_PREC) :: i, j, n, m
1151
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: l(:), l2(:)
1153
if ( size(A) == 0 ) then
1156
else if ( size(B) == 0 ) then
1161
! Get maximum size of the union and allocate
1162
n = size(A) + size(B)
1163
call new_dim_(tmp, n)
1165
sorted_A = is_sorted(A)
1166
sorted_B = is_sorted(B)
1168
! Prefer to not copy any of the sets...
1169
if ( sorted_A .and. sorted_B ) then
1171
! Ensure it is sorted...
1180
do while ( i < n .and. j < m )
1182
if ( l(i) == l2(j) ) then
1183
call push(tmp, l(i))
1186
else if ( l(i) < l2(j) ) then
1187
call push(tmp, l(i))
1189
else if ( l2(j) < l(i) ) then
1190
call push(tmp, l2(j))
1199
if ( l2(j) < l(n) ) then
1200
call push(tmp, l2(j))
1205
if ( l2(j) > l(n) ) then
1206
call push(tmp, l(n))
1209
call push(tmp, m-j+ONE, l2(j:m))
1211
else if ( j == m ) then
1214
if ( l(i) < l2(m) ) then
1215
call push(tmp, l(i))
1220
if ( l(i) > l2(m) ) then
1221
call push(tmp, l2(m))
1224
call push(tmp, n-i+ONE, l(i:n))
1228
else if ( sorted_A .and. .not. sorted_B ) then
1236
if ( .not. in_list(A, l(i)) ) then
1237
call push(tmp, l(i))
1241
else if ( .not. sorted_A .and. sorted_B ) then
1249
if ( .not. in_list(B, l(i)) ) then
1250
call push(tmp, l(i))
1254
else if ( size(A) > size(B) ) then
1256
! We will sort list B and then perform the list insertion
1257
if ( sorted_B ) then
1258
! both are actually sorted, but B is smaller
1271
if ( .not. in_list(D, l(i)) ) then
1272
call push(tmp, l(i))
1280
! We will sort list B and then perform the list insertion
1281
if ( sorted_A ) then
1282
! both are actually sorted, but B is smaller
1295
if ( .not. in_list(D, l(i)) ) then
1296
call push(tmp, l(i))
1307
end subroutine union_
1310
!> @param[in] A list one
1311
!> @param[in] B list two
1312
!> @param[inout] C list as the complement: `A \ B`, i.e. elements in `B` but not in `A`.
1313
subroutine complement_(A, B, C)
1314
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: A, B
1315
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: C
1317
type(BUD_TYPE_NAME) :: tmp ,D
1318
integer(BUD_INT_PREC) :: i, n
1319
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: l(:)
1321
if ( size(A) == 0 ) then
1324
else if ( size(B) == 0 ) then
1329
! Get maximum size of the union and allocate
1331
call new_dim_(tmp, n)
1333
if ( is_sorted(A) ) then
1345
if ( .not. in_list(D, l(i)) ) then
1346
call push(tmp, l(i))
1355
end subroutine complement_
1357
!> @param[inout] this the list which will be returned with reversed elements
1358
subroutine unique_(this)
1359
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1361
type(BUD_TYPE_NAME) :: tmp
1363
integer(BUD_INT_PREC) :: i, j, n
1364
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: l(:)
1367
call copy(this, tmp)
1370
! Retrieve the list value pointer
1374
if ( l(j) /= l(i) ) then
1380
! Ensure that the number of elements is
1386
end subroutine unique_
1390
!> @param[inout] this the list which will be returned with reversed elements
1391
subroutine reverse_(this)
1392
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1394
integer(BUD_INT_PREC) :: i, n
1395
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: l(:)
1396
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC) :: tmp
1407
end subroutine reverse_
1409
!> @param[inout] this the list that will re-order
1410
!! @param[in] n size of pivoting list (must be size of list)
1411
!! @param[in] pivot pivoting table for the elements
1412
subroutine reorder_(this, n, pivot)
1413
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1414
integer(BUD_INT_PREC), intent(in) :: n
1415
integer(BUD_INT_PREC), intent(in) :: pivot(n)
1417
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), allocatable :: nlst(:)
1418
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: olst(:)
1420
integer(BUD_INT_PREC) :: i
1422
if ( .not. is_initd(this) ) return
1424
if ( n < size(this) ) then
1426
call set_error(this, 1)
1433
olst => list_p(this)
1436
! Now loop the pivoting stuff...
1438
nlst(i) = olst(pivot(i))
1448
end subroutine reorder_
1452
#ifndef BUD_IS_COMPLEX
1453
!> @param[inout] this list @bud
1454
!! @return the value of the minimum value in the list
1455
pure function minval_(this) result(val)
1456
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1457
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC) :: val
1458
integer(BUD_INT_PREC) :: i
1461
#ifdef BUD_IS_INTEGER
1462
if ( this%D%sorted ) return
1465
do i = 2 , size(this)
1466
if ( this%D%lst(i) < val ) then
1471
end function minval_
1473
!> @param[inout] this list @bud
1474
!! @return the value of the maximum value in the list
1475
pure function maxval_(this) result(val)
1476
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1477
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC) :: val
1478
integer(BUD_INT_PREC) :: i
1480
val = this%D%lst(size(this))
1481
#ifdef BUD_IS_INTEGER
1482
if ( this%D%sorted ) return
1485
do i = 1 , size(this) - 1
1486
if ( this%D%lst(i) > val ) then
1491
end function maxval_
1495
#ifdef BUD_IS_INTEGER
1496
!> @param[inout] this list @bud
1497
!! @param[in] val the value to be indexed in the list
1498
!! @return the index of `val` in the list (-1 if not found)
1499
pure function index_(this, val) result(idx)
1500
use BUD_CC2(BUD_MOD,_utils), only: find_bin
1501
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1502
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in) :: val
1503
integer(BUD_INT_PREC) :: idx
1505
if ( this%D%sorted ) then
1507
! we may easily find indices of a sorted array
1508
call find_bin(this%D%n, this%D%lst, val, idx)
1514
do idx = 1 , this%D%n
1515
if ( this%D%lst(idx) == val ) return
1524
!> @param[in] this list @bud
1525
!! @param[in] val the value to be queried whether it is in the list
1526
!! @return .true. if `val` is in the list
1527
pure function in_list_(this, val) result(found)
1528
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1529
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), intent(in) :: val
1532
found = index(this, val) > 0
1534
end function in_list_
1537
!> @param[in] this list @bud
1538
!! @return .true. if `this` is a sorted list
1539
pure function is_sorted_(this) result(sorted)
1540
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1543
sorted = this%D%sorted
1544
if ( .not. sorted ) then
1545
sorted = size(this) == 1
1548
end function is_sorted_
1552
!> @param[inout] f `File` bud
1553
!! @param[in] this the list
1554
subroutine write_(f, this)
1555
use BUD_CC2(BUD_MOD,_File)
1557
BUD_CLASS( BUD_CC2(BUD_TYPE,File) ), intent(inout) :: f
1558
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1560
#ifdef BUD_TYPE_VAR_PREC
1561
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
1563
BUD_TYPE_VAR, pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
1566
logical :: formatted
1569
integer(BUD_INT_PREC) :: n
1571
! If file is not opened, return immediately
1572
if ( .not. is_open(f) ) return
1573
if ( .not. is_initd(this) ) return
1575
! First figure out if the file is an unformatted file
1576
formatted = is_formatted(f)
1583
! First we write the size of the list
1584
! and the state of the values (sorted/non-sorted)
1585
if ( formatted ) then
1586
write(iu, '(i16)') n
1587
write(iu, '(l16)') this%D%sorted
1590
write(iu) this%D%sorted
1593
if ( formatted ) then
1594
#ifdef BUD_IS_INTEGER
1595
write(iu, '(i16)') p
1597
write(iu, '(e20.16)') p
1603
end subroutine write_
1605
!> @param[inout] f `File` bud
1606
!! @param[inout] this the array bud
1607
subroutine read_(f, this)
1608
use BUD_CC2(BUD_MOD,_File)
1610
BUD_CLASS( BUD_CC2(BUD_TYPE,File) ), intent(inout) :: f
1611
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
1613
#ifdef BUD_TYPE_VAR_PREC
1614
BUD_TYPE_VAR(BUD_TYPE_VAR_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
1616
BUD_TYPE_VAR, pointer BUD_FORTRAN_CONTIGUOUS :: p(:)
1619
logical :: formatted
1622
integer(BUD_INT_PREC) :: n
1625
! If file is not opened, return immediately
1626
if ( .not. is_open(f) ) return
1628
! First figure out if the file is an unformatted file
1629
formatted = is_formatted(f)
1632
! First we need to read the array dimensions...
1633
if ( formatted ) then
1635
read(iu, '(l16)') sorted
1642
this%D%sorted = sorted
1643
p => list_max_p(this)
1645
if ( formatted ) then
1646
#ifdef BUD_IS_INTEGER
1649
read(iu, '(e20.16)') p
1654
! Ensure elements are contained.
1657
end subroutine read_
1659
!> @param[in] this list @bud
1660
!! @param[in] info @opt=BUD_TYPE_NAME_STR additional information printed
1661
!! @param[in] indent @opt=1 possible indentation of printed statement
1662
subroutine print_(this, info, indent)
1663
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
1664
character(len=*), intent(in), optional :: info
1665
integer, intent(in), optional :: indent
1668
integer(BUD_INT_PREC) :: n, max_n
1671
character(len=32) :: fmt
1672
character(len=256) :: name
1674
name = BUD_TYPE_NAME_STR
1675
if ( present(info) ) name = info
1677
if ( present(indent) ) lindent = indent
1679
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
1681
if ( .not. is_initd(this) ) then
1682
write(*,fmt) "<", trim(name), " not initialized>"
1688
max_n = max_size_(this)
1691
write(fmt, '(a,i0,a)') '(t',lindent,',3a,2(i0,a),l1,a,i0)'
1693
write(*,fmt) "<", trim(name), " size/max=", n,'/',max_n, &
1694
#ifdef BUD_IS_INTEGER
1695
", sorted=", is_sorted(this), &
1697
", refs: ", references(this), ">"
1699
end subroutine print_
1702
! Local pre-processor variables that
1703
! undefine the variables that are not needed anymore.
1705
#undef BUD_TYPE_VAR_PREC
1707
#include "bud_cleanup.inc"
1710
! project-buds -- local file settings
1711
! Anything below this line may be overwritten by scripts
1712
! Below are non-editable settings
1717
! f90-type-indent: 2
1718
! f90-associate-indent: 2
1719
! f90-continuation-indent: 2
1720
! f90-structure-indent: 2
1721
! f90-critical-indent: 2
1722
! f90-program-indent: 2
added
removed
Src/buds/src/List.inc
