1! --- 2! Copyright (C) 1996-2016 The SIESTA group 3! This file is distributed under the terms of the 4! GNU General Public License: see COPYING in the top directory 5! or http://www.gnu.org/copyleft/gpl.txt . 6! See Docs/Contributors.txt for a list of contributors. 7! --- 8 9!=========================== begin template --- 10! 11! The basic data structure is an array which can be cyclically shifted, 12! and whose individual elements can be indexed. 13! The most recent item is the highest-numbered one. 14! 15! Parameters: FSTACK_NAME 16! _T_ 17!=============================================== 18 19 20type Fstack_ 21 integer :: refCount = 0 22 character(len=36) :: id = "null_id" 23 !------------------------------------- 24 character(len=256) :: name = "(null Fstack_)" 25 !> See [[_T_(type)]] 26 type(_T_), pointer :: val(:) => null() 27 integer :: size = 0 28 integer :: nvals = 0 29end type Fstack_ 30 31type FSTACK_NAME 32 type(Fstack_), pointer :: data => null() 33end type FSTACK_NAME 34 35public :: new, push, pop, get, get_pointer, reset 36public :: n_items, max_size, print_type 37 38interface new 39 module procedure new__ 40end interface 41interface push 42 module procedure push__ 43end interface 44interface pop 45 module procedure pop__ 46 module procedure pop_delete__ 47 module procedure pop_delete_idx_ 48end interface 49interface get 50 module procedure get__ 51end interface 52interface get_pointer 53 module procedure get_pointer__ 54end interface 55 56interface reset 57 module procedure reset__ 58end interface 59 60interface print_type 61 module procedure print__ 62end interface 63 64interface n_items 65 module procedure n_items__ 66end interface 67interface max_size 68 module procedure max_size__ 69end interface 70 71!============================== 72#define TYPE_NAME FSTACK_NAME 73#include "basic_type.inc" 74!============================== 75 76 subroutine delete_Data(data) 77 type(Fstack_) :: data 78 integer :: i 79 if (associated(data%val)) then 80 do i = 1, data%size 81 call delete(data%val(i)) 82 enddo 83 deallocate(data%val) 84 endif 85 ! Reset data 86 data%size = 0 87 data%nvals = 0 88 end subroutine delete_Data 89!============================================================= 90 91!--------------------------------------------- 92function max_size__(this) result (n) 93type(FSTACK_NAME), intent(in) :: this 94integer :: n 95if (.not. associated(this%data)) then 96 n = 0 97else 98 n = this%data%size 99end if 100end function max_size__ 101 102!--------------------------------------------- 103function n_items__(this) result (n) 104type(FSTACK_NAME), intent(in) :: this 105integer :: n 106if (.not. associated(this%data)) then 107 n = 0 108else 109 n = this%data%nvals 110end if 111 112end function n_items__ 113 114!--------------------------------------------- 115subroutine new__(this,nsize,name) 116type(FSTACK_NAME), intent(inout) :: this 117integer, intent(in) :: nsize 118character(len=*), intent(in), OPTIONAL :: name 119 120integer :: i 121 122call init(this) 123this%data%size = nsize 124this%data%nvals = 0 125 126if (present(name)) then 127 this%data%name = name 128else 129 this%data%name = "Fstack" 130endif 131 132allocate(this%data%val(nsize)) 133call tag_new_object(this) 134 135end subroutine new__ 136 137!--------------------------------------------- 138! The most recent item is the highest-numbered 139! 140subroutine push__(this,item) 141type(FSTACK_NAME), intent(inout) :: this 142type(_T_), intent(in) :: item 143 144if (max_size(this) == 0) RETURN 145 146if (this%data%nvals == this%data%size) then 147 !! print *, "cycling fstack..." 148 this%data%val = cshift(this%data%val,+1) 149 call delete(this%data%val(this%data%nvals)) 150 this%data%val(this%data%nvals) = item ! Assignment 151else 152 this%data%nvals = this%data%nvals + 1 153 this%data%val(this%data%nvals) = item 154endif 155end subroutine push__ 156 157 158!--------------------------------------------- 159! Returns and pops the latest element 160! 161subroutine pop__(this,item) 162type(FSTACK_NAME), intent(inout) :: this 163type(_T_), intent(inout) :: item 164 165if (max_size(this) == 0) RETURN 166if (n_items(this) == 0) then 167 call delete(item) 168 RETURN 169endif 170 171! retrieve the latest value 172item = this%data%val(this%data%nvals) 173! Delete the local and decrease counter 174call delete(this%data%val(this%data%nvals)) 175this%data%nvals = this%data%nvals - 1 176 177end subroutine pop__ 178 179subroutine pop_delete__(this) 180type(FSTACK_NAME), intent(inout) :: this 181 182if (max_size(this) == 0) RETURN 183if (n_items(this) == 0) RETURN 184 185! Delete the local item and decrease counter 186call delete(this%data%val(this%data%nvals)) 187this%data%nvals = this%data%nvals - 1 188 189end subroutine pop_delete__ 190 191subroutine pop_delete_idx_(this, index) 192type(FSTACK_NAME), intent(inout) :: this 193integer, intent(in) :: index 194integer :: lidx, i, n 195 196if (max_size(this) == 0) RETURN 197n = n_items(this) 198if (n == 0) RETURN 199 200if ( index > 0 ) then 201 lidx = index 202else 203 lidx = n + index + 1 204end if 205 206! Delete the local item and decrease counter 207do i = lidx , n - 1 208 this%data%val(i) = this%data%val(i+1) 209end do 210call delete(this%data%val(n)) 211this%data%nvals = this%data%nvals - 1 212 213end subroutine pop_delete_idx_ 214 215!--------------------------------------------- 216subroutine get__(this,i,value) 217type(FSTACK_NAME), intent(in) :: this 218integer, intent(in) :: i 219type(_T_), intent(inout) :: value 220 221if (i > this%data%nvals) then 222 call die("wrong index in get__ FSTACK_NAME") 223endif 224value = this%data%val(i) 225end subroutine get__ 226 227!--------------------------------------------- 228function get_pointer__(this,i) result(valuep) 229type(FSTACK_NAME), intent(in) :: this 230integer, intent(in) :: i 231type(_T_), pointer :: valuep 232 233if (i > this%data%nvals) then 234 call die("wrong index in get_pointer__ FSTACK_NAME") 235endif 236valuep => this%data%val(i) 237end function get_pointer__ 238 239!--------------------------------------------- 240! reset oldest history by cyclic shifts and deleting top values 241! Defaults to resetting the entire history 242! If n < 0, keeps min(-n,n_items) history segments 243! If n > 0, deletes min(n,n_items) history segments 244! If n == 0, deletes entire history 245! 246subroutine reset__(this,n) 247type(FSTACK_NAME), intent(inout) :: this 248! Number of elements to keep 249integer, intent(in), optional :: n 250integer :: i, ns, ln 251 252if (.not. associated(this%data)) return 253 254ns = n_items(this) 255ln = ns 256if ( present(n) ) ln = n 257 258! There are three options 259 260if ( ln > 0 ) then 261 ! We will delete the oldest 'ln' entries 262 ln = min(ln,ns) 263 264 ! 'ln' is now the number of elements deleted 265 266else if ( ln < 0 ) then 267 ! We will keep the latest '-ln' entries 268 ln = min(-ln,ns) 269 270 ! Calculate the number of oldest elements to be deleted 271 ln = ns - ln 272 if ( ln == 0 ) return 273 274else 275 ! Delete entire history 276 ln = ns 277end if 278 279ns = max_size(this) 280if ( ln /= ns ) then 281 ! Cyclic shifts 282 this%data%val = cshift(this%data%val,+ln) 283end if 284 285! delete back values as the cycling puts them 286! in the back 287do i = 1 , ln 288 call delete(this%data%val(ns)) 289 ns = ns - 1 290 this%data%nvals = this%data%nvals - 1 291end do 292 293end subroutine reset__ 294 295 296!--------------------------------------------- 297subroutine print__(this) 298type(FSTACK_NAME), intent(in) :: this 299 300integer :: i 301 302if (.not. associated(this%data)) then 303 print *, "<Fstack not initialized>" 304 return 305endif 306 307print "(a,i0,a,i0,a)", "<" // trim(this%data%name) // ". Slots: ", & 308 this%data%size, " Nvals: ", this%data%nvals, ">" 309do i=1,this%data%nvals 310 call print_type(this%data%val(i)) 311enddo 312print "(a,i0,a)", "<refcount: ", this%data%refCount, ">" 313 314end subroutine print__ 315 316!=========================== end of template 317 318#undef _T_ 319#undef FSTACK_NAME 320