1
! @@LICENSE@@ see Copyright notice in the top-directory
3
! The following pre-processor variables are currently used when
5
! - BUD_TYPE_NAME of the type
6
! - BUD_TYPE_NAME_, internal data pointer of the type
7
! - BUD_TYPE_NAME_STR, the routine name in "string" format (for IO)
8
! - BUD_TYPE_NEW, the routine name for creating a new type
9
! - BUD_STACK_TYPE, the variable type contained in the stack
11
! Include the common utilities
12
#include "bud_utils.inc"
14
#include "bud_common_declarations.inc"
18
!> @defgroup bud-fstack Finite stack of arbitrary @bud
20
!! The finite stack implementation is an extension of the regular
21
!! reference counted objects.
23
!! A stack is a "push-pop" sequence of @buds.
24
!! A `push` of a new @bud is inserted at the top, if the stack is
25
!! full the oldest entry is deleted and removed from the stack.
27
!! A `pop` of a @bud removes the top entry of the stack and possibly
31
!! A type need not have _all_ these routines available if so desired.
32
!! This is internally controlled and is mentioned for the relevant types.
34
!> @endcond BUD_DOC_INC
36
!> Finite stack with cyclic ability
38
!! Container for a finite stack of a single @bud (BUD_STACK_TYPE).
40
!! This data container holds 3 variables,
41
!! 1. track maximum number of elements allowed in the finite stack
42
!! 2. track how many elements are currently stored
43
!! 3. An array of the stack of variables stored.
46
!> @cond BUD_DEVELOPER
48
!> Stored pointer which contains the reference counting etc.
49
type(BUD_TYPE_NAME_), pointer :: D => null()
51
!> @endcond BUD_DEVELOPER
53
# include "bud_common_type.inc"
54
#if BUD_FORTRAN >= 2003
57
procedure, public :: new => new_
60
procedure, public :: push => push_
62
procedure, public :: pop => pop_
64
procedure, public :: retain => retain_
67
procedure, public :: element => get_elem_
69
procedure, public :: get => get_elem_
72
procedure, public :: element_p => get_elem_p_
74
procedure, public :: get_p => get_elem_p_
77
procedure, public :: size => size_elem_
79
procedure, public :: size_max => size_max_elem_
82
end type BUD_TYPE_NAME
85
!> @cond BUD_DEVELOPER
87
!> @bud container for BUD_TYPE_NAME
90
!> Maximum number of elements that can be stored in this stack.
93
!! There is little to no memory overhead of having an excessively
94
!! large `max` as all elements which have not been assigned are
95
!! allocations of data-pointers.
97
!! Hence creating extreme stacks may still be memory efficient.
100
!> Current number of elements in the stack.
103
!> Array of elements (stack).
104
type(BUD_STACK_TYPE), pointer :: T(:) => null()
106
! Consistent data in the reference counted object
107
# include "bud_common_type_.inc"
109
end type BUD_TYPE_NAME_
111
!> @endcond BUD_DEVELOPER
114
! special counter for deleting all elements
116
! call pop(<this>, 0)
117
!> Special parameter for popping all elements.
119
!! Allows one to pop/delete all elements in the stack.
120
!! This basically performs a
122
!! n = size_max(this)
126
!!integer, public, parameter :: BUD_FSTACK_ALL = 0
129
!> Internal initialization of finite stack holding BUD_STACK_TYPE
131
!! If called on a previously allocated data scope this
132
!! will clear the reference (@isee delete).
133
!! Subsequently the type container will be allocated
134
!! and the reference counted data will be 1.
136
module procedure new_
140
!> Adds/Pushes new element to the stack
142
!! If the stack is full the oldest element will be deleted
143
!! and the second oldest becomes the first element of the stack.
146
!! One cannot push elements in the middle of the stack.
148
module procedure push_
152
!> Pop and (possibly) return the latest item in the stack
154
!! The top item is returned in `item` and the stack
155
!! is decremented thus removing the returned item from the stack.
157
!! An optional index may be given, see #pop_delete_.
159
!! If the top element has not been initialized the returned item will
160
!! be un-initialized.
163
!! The returned item will thus not have its counted references changed.
165
module procedure pop_
166
module procedure pop_delete_
171
!> Retains a fixed number of elements in the stack
173
!! Retains a number of elements from either the top or the
174
!! bottom of the stack.
176
!! If any of the counts are larger than the currently
177
!! number of stored elements, nothing will happen.
180
!! Defaults to `top=fnelem(this)-1`
182
module procedure retain_
186
!> Retrieve specific element from the stack
188
!! If the requested element is beyond the number of
189
!! stored elements `elem` will be un-initialized upon return.
191
module procedure get_elem_
195
!> Retrieve pointer to specific element in the stack
197
!! Retrieving a pointer does not change the reference status
200
!! If the requested element is beyond the number of
201
!! stored elements `elem` will be null.
204
module procedure get_elem_p_
208
!> Query number of currently stored elements in this stack
210
module procedure size_elem_
214
!> Query maximum number of allowed elements in this stack
216
module procedure size_max_elem_
221
! all default reference counted stuff
222
# include "bud_common.inc"
224
!> @cond BUD_DEVELOPER
226
subroutine delete_(this)
227
type(BUD_TYPE_NAME), intent(inout) :: this
231
if ( associated(this%D%T) ) then
234
do i = 1 , size(this%D%T)
235
call delete(this%D%T(i))
236
if ( 0 /= error(this%D%T(i)) ) then
237
stat = error(this%D%T(i))
240
deallocate(this%D%T, stat=i)
241
if ( 0 /= i ) stat = i
248
call set_error(this, stat)
250
end subroutine delete_
252
!> @endcond BUD_DEVELOPER
255
!> @param[in] from the original `bud` which is copied to `to`
256
!! @param[inout] to the output `bud` with the full copied data
257
subroutine copy_(from, to)
258
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: from
259
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: to
261
type(BUD_STACK_TYPE), pointer :: p
262
type(BUD_STACK_TYPE) :: cp
265
if ( .not. is_initd(from) ) return
267
call new(to, from%D%nel_max)
269
do i = 1 , size(from)
270
p => element_p(from, i)
276
! Copy the common data-content
277
call common_copy_(from, to)
281
!> @param[inout] this initialize the finite stack
282
!! @param[in] nel maximum number of elements that may be contained in the stack
283
subroutine new_(this, nel)
284
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
285
integer, intent(in) :: nel
288
call set_error(this, -1)
292
call initialize(this)
297
! prepare data locations
298
allocate(this%D%T(nel))
303
!> @param[inout] this stack that gets added an element
304
!! @param[in] item element added to the stack
305
subroutine push_(this,item)
306
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
307
type(BUD_STACK_TYPE), intent(in) :: item
311
! if this has not been initialised we immediately return
312
! We _could_ initialize it, but we do not know how
313
! many maximum elements that is allowed?
315
if ( .not. is_initd(this) ) return
319
if ( el == size_max(this) ) then
321
! cycle stack and push
323
this%D%T(i-1) = this%D%T(i)
325
! Assignment will also delete.
331
! simply add it to the stack
340
!> @param[inout] this stack that gets removed an item
341
!! @param[inout] item returned element from the top of the stack
342
subroutine pop_(this, item)
343
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
344
type(BUD_STACK_TYPE), intent(inout) :: item
348
if ( .not. is_initd(this) ) then
355
! easy case if it is empty
363
! retrieve the latest value
371
!> @param[inout] this stack that gets removed an item
372
!! @param[in] top @opt=1 number of popped elements from top.
373
!! If 0 is supplied it will
374
!! clear all elements.
375
!! @param[in] bot @opt=@null has precedence if `top` not supplied.
376
!! Pops `bot` elements from the bottom of the stack.
377
subroutine pop_delete_(this, top, bot)
378
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
379
integer, intent(in), optional :: top, bot
384
! it is already empty...
385
if ( .not. is_initd(this) ) return
387
if ( .not. present(top) &
388
.and. .not. present(bot) ) then
389
call set_error(this, 1)
396
if ( present(top) .or. .not. present(bot) ) then
398
! regular top-popping
401
if ( present(top) ) lnpop = top
403
! If 0 is passed, we delete all
404
if ( lnpop == 0 ) lnpop = el
406
! we should not pop anything
407
if ( lnpop < 0 ) return
409
do while ( lnpop > 0 )
411
! easy case if it is empty
412
if ( 0 == el ) return
414
! Delete the local item and decrease counter
415
call delete(this%D%T(el))
416
this%D%nel = this%D%nel - 1
422
else ! bot has been supplied
427
! in case of a negative number we cannot pop anything
428
if ( lnpop < 0 ) return
430
do while ( lnpop > 0 )
432
! easy case if it is empty
433
if ( 0 == el ) return
435
! Delete the local item and decrease counter
436
call delete(this%D%T(1))
437
this%D%nel = this%D%nel - 1
438
! shift to attain the correct order
439
do i = 1 , this%D%nel
440
this%D%T(i) = this%D%T(i+1)
449
end subroutine pop_delete_
452
!> @param[inout] this stack to operate on
453
!! @param[in] top @opt=1 number of elements kept from the top
454
!! @param[in] bot @opt=@null number of elements kept from the bottom,
455
!! only used if `top` is not supplied.
456
subroutine retain_(this, top, bot)
457
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
458
integer, intent(in), optional :: top, bot
463
if ( .not. is_initd(this) ) return
465
if ( .not. present(top) &
466
.and. .not. present(bot) ) then
467
call set_error(this, 1)
474
if ( present(top) .or. .not. present(bot) ) then
476
! regular bot-popping
478
if ( present(top) ) lnpop = el - top
480
! we should not pop anything
481
if ( lnpop < 0 ) return
483
call pop(this, bot=lnpop)
487
! retain 'n' items from the bottom
490
! we should not pop anything
491
if ( lnpop < 0 ) return
493
call pop(this, top=lnpop)
497
end subroutine retain_
500
!> @param[in] this stack to retrieve element from
501
!! @param[inout] elem returned item stored in element `iel`
502
!! @param[in] iel @opt=`size(this)` index of element to return. May be negative to offset from the top
503
subroutine get_elem_(this, elem, iel)
504
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
505
type(BUD_STACK_TYPE), intent(inout) :: elem
506
integer, intent(in), optional :: iel
510
if ( .not. is_initd(this) ) return
515
if ( present(iel) ) then
523
if ( el <= size(this) ) then
527
end subroutine get_elem_
529
!> @param[in] this stack to retrieve pointer element from
530
!! @param[in] iel @opt=`size(this)` index of element to return. May be negative to offset from top.
531
!! @result pointer to the element `iel`
532
function get_elem_p_(this, iel) result(p)
533
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
534
integer, intent(in), optional :: iel
535
type(BUD_STACK_TYPE), pointer :: p
539
if ( .not. is_initd(this) ) return
544
if ( present(iel) ) then
552
if ( el <= size(this) ) then
556
end function get_elem_p_
559
!> @param[inout] this stack to count element from
560
!! @return number of currently stored elements
561
elemental function size_elem_(this) result (nel)
562
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
564
if ( .not. is_initd(this) ) then
569
end function size_elem_
572
!> @param[inout] this stack that is queried maximum size of
573
!! @return maximum number of allowed elements
574
elemental function size_max_elem_(this) result (nel_max)
575
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
577
if ( .not. is_initd(this) ) then
580
nel_max = this%D%nel_max
582
end function size_max_elem_
586
# ifndef BUD_IO_OVERLOAD
588
!> @param[in] f a file (bud_File)
589
!! @param[in] this collection @bud to be written
590
subroutine write_(f, this)
591
use BUD_CC2(BUD_MOD,_File)
592
BUD_CLASS( BUD_CC2(BUD_TYPE,File) ), intent(inout) :: f
593
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
597
integer :: nel, nel_max, i
599
! If file is not opened, return immediately
600
if ( .not. is_open(f) ) return
601
if ( .not. is_initd(this) ) return
603
formatted = is_formatted(f)
606
! Get information about this stack
607
nel_max = size_max(this)
610
if ( formatted ) then
611
write(iu, '(i16)') nel_max, nel
613
write(iu) nel_max, nel
616
! Now write each of them...
618
call write(f, this%D%T(i))
621
end subroutine write_
623
!> @param[in] f a file (bud_File)
624
!! @param[in] this collection @bud to be readed
625
subroutine read_(f, this)
626
use BUD_CC2(BUD_MOD,_File)
627
BUD_CLASS( BUD_CC2(BUD_TYPE,File) ), intent(inout) :: f
628
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
630
! To read each of them individually
631
type(BUD_STACK_TYPE) :: cp
635
integer :: nel, nel_max, i
637
! If file is not opened, return immediately
638
if ( .not. is_open(f) ) return
640
formatted = is_formatted(f)
643
! Get information about this stack
644
if ( formatted ) then
645
read(iu, '(i16)') nel_max, nel
647
read(iu) nel_max, nel
650
! Initialize this object
651
call new(this, nel_max)
653
! Now read each of them...
665
!> @param[in] this data type
666
!! @param[in] info @opt=BUD_TYPE_NAME_STR additional information printed
667
!! @param[in] indent @opt=1 possible indentation of printed statement
668
subroutine print_(this, info, indent)
669
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
670
character(len=*), intent(in), optional :: info
671
integer, intent(in), optional :: indent
677
character(len=32) :: fmt
678
character(len=256) :: name
680
name = BUD_TYPE_NAME_STR
681
if ( present(info) ) name = info
683
if ( present(indent) ) lindent = indent
685
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
687
if ( .not. is_initd(this) ) then
688
write(*,fmt) "<", trim(name), " not initialized>"
692
write(fmt, '(a,i0,a)') '(t',lindent,',3a)'
693
lindent = lindent + 2 ! step indentation
694
write(*,fmt) "<<", trim(name), " stack>"
695
do i = 1 , size(this)
696
call print(this%D%T(i), indent = lindent)
698
lindent = lindent - 2 ! go back to requested indentation
699
write(fmt, '(a,i0,a)') '(t',lindent,',a,i0,a)'
700
write(*,fmt) " <stack-refs: ", references(this), ">>"
702
end subroutine print_
707
#undef BUD_TYPE_NAME_
708
#undef BUD_TYPE_NAME_STR
710
#undef BUD_STACK_TYPE
713
! project-buds -- local file settings
714
! Anything below this line may be overwritten by scripts
715
! Below are non-editable settings
721
! f90-associate-indent: 2
722
! f90-continuation-indent: 2
723
! f90-structure-indent: 2
724
! f90-critical-indent: 2
725
! f90-program-indent: 2
added
removed
Src/buds/include/bud_finitestack.inc
