Neko  0.9.99
A portable framework for high-order spectral element flow simulations
scratch_registry.f90
Go to the documentation of this file.
1 ! Copyright (c) 2018-2023, The Neko Authors
2 ! All rights reserved.
3 !
4 ! Redistribution and use in source and binary forms, with or without
5 ! modification, are permitted provided that the following conditions
6 ! are met:
7 !
8 ! * Redistributions of source code must retain the above copyright
9 ! notice, this list of conditions and the following disclaimer.
10 !
11 ! * Redistributions in binary form must reproduce the above
12 ! copyright notice, this list of conditions and the following
13 ! disclaimer in the documentation and/or other materials provided
14 ! with the distribution.
15 !
16 ! * Neither the name of the authors nor the names of its
17 ! contributors may be used to endorse or promote products derived
18 ! from this software without specific prior written permission.
19 !
20 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23 ! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24 ! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
25 ! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
26 ! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
27 ! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
28 ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29 ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
30 ! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31 ! POSSIBILITY OF SUCH DAMAGE.
32 !
38  use field, only : field_t, field_ptr_t
39  use dofmap, only : dofmap_t
40  implicit none
41  private
42 
43 
44  type, public :: scratch_registry_t
46  type(field_ptr_t), private, allocatable :: fields(:)
48  logical, private, allocatable :: inuse(:)
50  integer, private :: nfields
52  integer, private :: nfields_inuse
54  integer, private :: expansion_size
56  type(dofmap_t), pointer :: dof => null()
57  contains
58  procedure, private, pass(this) :: expand
60  procedure, pass(this) :: free => scratch_registry_free
62  procedure, pass(this) :: get_nfields
64  procedure, pass(this) :: get_nfields_inuse
66  procedure, pass(this) :: get_expansion_size
68  procedure, pass(this) :: get_size
70  procedure, pass(this) :: get_inuse
72  procedure, pass(this) :: request_field
73  procedure, pass(this) :: relinquish_field_single
74  procedure, pass(this) :: relinquish_field_multiple
76  generic :: relinquish_field => relinquish_field_single, &
78  end type scratch_registry_t
79 
80  interface scratch_registry_t
81  procedure :: init
82  end interface scratch_registry_t
83 
85  type(scratch_registry_t), public, target :: neko_scratch_registry
86 
87 contains
88 
91  type(scratch_registry_t) function init(dof, size, expansion_size) result(this)
92  type(dofmap_t), target, intent(in) :: dof
93  integer, optional, intent(in) :: size
94  integer, optional, intent(in) :: expansion_size
95  integer :: i
96 
97  call this%free()
98 
99  this%dof => dof
100 
101  if (present(size)) then
102  allocate (this%fields(size))
103  do i= 1, size
104  allocate(this%fields(i)%ptr)
105  end do
106  allocate (this%inuse(size))
107  else
108  allocate (this%fields(10))
109  allocate (this%inuse(10))
110  end if
111 
112  this%inuse(:) = .false.
113  if (present(expansion_size)) then
114  this%expansion_size = expansion_size
115  else
116  this%expansion_size = 10
117  end if
118 
119  this%nfields = 0
120  this%nfields_inuse = 0
121  end function init
122 
124  subroutine scratch_registry_free(this)
125  class(scratch_registry_t), intent(inout):: this
126  integer :: i
127 
128  if (allocated(this%fields)) then
129  do i=1, this%nfields
130  call this%fields(i)%ptr%free()
131  deallocate(this%fields(i)%ptr)
132  end do
133 
134  deallocate(this%fields)
135  deallocate(this%inuse)
136  end if
137 
138  if (associated(this%dof)) then
139  nullify(this%dof)
140  end if
141 
142  end subroutine scratch_registry_free
143 
144 
146  pure function get_nfields(this) result(n)
147  class(scratch_registry_t), intent(in) :: this
148  integer :: n
149 
150  n = this%nfields
151  end function get_nfields
152 
153  pure function get_nfields_inuse(this) result(n)
154  class(scratch_registry_t), intent(in) :: this
155  integer :: n, i
156 
157  n = 0
158  do i=1,this%get_size()
159  if (this%inuse(i)) n = n + 1
160  end do
161  end function get_nfields_inuse
162 
164  pure function get_size(this) result(n)
165  class(scratch_registry_t), intent(in) :: this
166  integer :: n
167 
168  n = size(this%fields)
169  end function get_size
170 
172  pure function get_expansion_size(this) result(n)
173  class(scratch_registry_t), intent(in) :: this
174  integer :: n
175 
176  n = this%expansion_size
177  end function get_expansion_size
178 
179  subroutine expand(this)
180  class(scratch_registry_t), intent(inout) :: this
181  type(field_ptr_t), allocatable :: temp(:)
182  logical, allocatable :: temp2(:)
183  integer :: i
184 
185  allocate(temp(this%get_size() + this%expansion_size))
186  temp(1:this%nfields) = this%fields(1:this%nfields)
187 
188  do i=this%nfields +1, size(temp)
189  allocate(temp(i)%ptr)
190  enddo
191 
192  call move_alloc(temp, this%fields)
193 
194  allocate(temp2(this%get_size() + this%expansion_size))
195  temp2(1:this%nfields) = this%inuse(1:this%nfields)
196  temp2(this%nfields+1:) = .false.
197  this%inuse = temp2
198  end subroutine expand
199 
200 
202  subroutine request_field(this, f, index)
203  class(scratch_registry_t), target, intent(inout) :: this
204  type(field_t), pointer, intent(inout) :: f
205  integer, intent(inout) :: index
206  character(len=10) :: name
207 
208 
209  associate(nfields => this%nfields, nfields_inuse => this%nfields_inuse)
210 
211  do index=1,this%get_size()
212  if (this%inuse(index) .eqv. .false.) then
213  write (name, "(A3,I0.3)") "wrk", index
214 
215  if (.not. allocated(this%fields(index)%ptr%x)) then
216  call this%fields(index)%ptr%init(this%dof, trim(name))
217  nfields = nfields + 1
218  end if
219  f => this%fields(index)%ptr
220  this%inuse(index) = .true.
221  this%nfields_inuse = this%nfields_inuse + 1
222  return
223  end if
224  end do
225  ! all existing fields in use, we need to expand to add a new one
226  index = nfields +1
227  call this%expand()
228  nfields = nfields + 1
229  nfields_inuse = nfields_inuse + 1
230  this%inuse(nfields) = .true.
231  write (name, "(A3,I0.3)") "wrk", index
232  call this%fields(nfields)%ptr%init(this%dof, trim(name))
233  f => this%fields(nfields)%ptr
234 
235  end associate
236  end subroutine request_field
237 
239  subroutine relinquish_field_single(this, index)
240  class(scratch_registry_t), target, intent(inout) :: this
241  integer, intent(inout) :: index
242 
243  this%inuse(index) = .false.
244  this%nfields_inuse = this%nfields_inuse - 1
245  end subroutine relinquish_field_single
246 
247  subroutine relinquish_field_multiple(this, indices)
248  class(scratch_registry_t), target, intent(inout) :: this
249  integer, intent(inout) :: indices(:)
250  integer :: i
251 
252  do i=1, size(indices)
253  this%inuse(indices(i)) = .false.
254  end do
255  this%nfields_inuse = this%nfields_inuse - size(indices)
256  end subroutine relinquish_field_multiple
257 
258  logical function get_inuse(this, index)
259  class(scratch_registry_t), target, intent(inout) :: this
260  integer, intent(inout) :: index
261 
262  get_inuse = this%inuse(index)
263  end function get_inuse
264 
265 end module scratch_registry
Defines a mapping of the degrees of freedom.
Definition: dofmap.f90:35
Defines a field.
Definition: field.f90:34
Defines a registry for storing and requesting temporary fields This can be used when you have a funct...
logical function get_inuse(this, index)
pure integer function get_nfields_inuse(this)
subroutine scratch_registry_free(this)
Destructor.
type(scratch_registry_t) function init(dof, size, expansion_size)
Constructor, optionally taking initial registry and expansion size as argument.
subroutine relinquish_field_single(this, index)
Relinquish the use of a field in the registry.
pure integer function get_size(this)
Get the size of the fields array.
subroutine relinquish_field_multiple(this, indices)
type(scratch_registry_t), target, public neko_scratch_registry
Global scratch registry.
subroutine request_field(this, f, index)
Get a field from the registry by assigning it to a pointer.
subroutine expand(this)
pure integer function get_nfields(this)
Get the number of fields stored in the registry.
pure integer function get_expansion_size(this)
Get the expansion size.
field_ptr_t, To easily obtain a pointer to a field
Definition: field.f90:80