Skip to content

Commit

Permalink
support faster link-based coupling
Browse files Browse the repository at this point in the history
  • Loading branch information
@jornbr
jornbr committed Jan 25, 2024
1 parent 2b15a86 commit 97da44e
Show file tree
Hide file tree
Showing 3 changed files with 64 additions and 48 deletions.
5 changes: 3 additions & 2 deletions src/fabm_coupling.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -186,9 +186,10 @@ subroutine collect_user_specified_couplings(self)
if (link%original%presence == presence_internal .or. associated(self%coupling_task_list%find(link))) display = display_advanced
master_name = self%couplings%get_string(trim(link%name), trim(link%original%long_name), units=trim(link%original%units), default='', display=display)
if (master_name /= '') then
call self%coupling_task_list%add(link, .true., task)
task%user_specified = .true.
allocate(task)
task%slave => link
task%master_name = master_name
call self%coupling_task_list%add(task, priority=1)
end if ! Coupling provided
end if ! Our own link, which may be coupled
link => link%next
Expand Down
6 changes: 3 additions & 3 deletions src/fabm_particle.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -172,7 +172,9 @@ subroutine request_coupling_to_model_generic(self, slave, master_model, master_m
! Create object describing the coupling, and send it to FABM.
! This must be a pointer, because FABM will manage its memory and deallocate when appropriate.
allocate(coupling)
coupling%slave => slave
base_coupling => coupling
call self%request_coupling(slave, base_coupling)
if (.not. associated(base_coupling)) return
coupling%owner => self
if (present(master_name)) coupling%master_name = master_name
if (present(master_standard_variable)) then
Expand All @@ -198,8 +200,6 @@ subroutine request_coupling_to_model_generic(self, slave, master_model, master_m
'BUG: master_model or master_model_name must be provided.')
coupling%model_reference => add_model_reference(self, master_model_name, require_empty_id=.false.)
end if
base_coupling => coupling
if (.not. self%coupling_task_list%add_object(base_coupling, .false.)) deallocate(coupling)
end subroutine request_coupling_to_model_generic

subroutine request_named_coupling_to_model(self, slave_variable, master_model, master_variable)
Expand Down
101 changes: 58 additions & 43 deletions src/fabm_types.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -165,21 +165,26 @@ module fabm_types
type (type_link), pointer :: slave => null()
character(len=attribute_length) :: master_name = ''
class (type_domain_specific_standard_variable), pointer :: master_standard_variable => null()
logical :: user_specified = .false.
integer :: priority = 0
class (type_coupling_task), pointer :: previous => null()
class (type_coupling_task), pointer :: next => null()
contains
procedure :: resolve => coupling_task_resolve
end type

type, extends(type_coupling_task) :: type_link_coupling_task
type (type_link), pointer :: master => null()
contains
procedure :: remove => link_coupling_task_resolve
end type

type type_coupling_task_list
class (type_coupling_task), pointer :: first => null()
logical :: includes_custom = .false.
contains
procedure :: remove => coupling_task_list_remove
procedure :: find => coupling_task_list_find
procedure :: add => coupling_task_list_add
procedure :: add_object => coupling_task_list_add_object
procedure :: remove => coupling_task_list_remove
procedure :: find => coupling_task_list_find
procedure :: add => coupling_task_list_add
end type

type,extends(type_settings) :: type_fabm_settings
Expand Down Expand Up @@ -491,13 +496,16 @@ module fabm_types
procedure :: find_model

! Procedures for requesting coupling between variables
procedure :: request_coupling_lt
procedure :: request_coupling_for_link
procedure :: request_coupling_for_name
procedure :: request_coupling_for_id
procedure :: request_standard_coupling_for_link
procedure :: request_standard_coupling_for_id
procedure :: request_link_coupling_for_link
generic :: request_coupling => request_coupling_for_link, request_coupling_for_name, request_coupling_for_id, &
request_standard_coupling_for_link, request_standard_coupling_for_id
request_standard_coupling_for_link, request_standard_coupling_for_id, &
request_link_coupling_for_link, request_coupling_lt

! Procedures that may be used to query parameter values during initialization.
procedure :: get_real_parameter
Expand Down Expand Up @@ -1387,10 +1395,10 @@ subroutine link_list_finalize(self)
self%first => null()
end subroutine link_list_finalize

subroutine create_coupling_task(self, link, task)
class (type_base_model), intent(inout) :: self
type (type_link), target, intent(in) :: link
class (type_coupling_task), pointer :: task
subroutine request_coupling_lt(self, link, task)
class (type_base_model), intent(inout) :: self
type (type_link), target, intent(in) :: link
class (type_coupling_task), pointer, intent(inout) :: task

type (type_link), pointer :: current_link

Expand All @@ -1410,8 +1418,9 @@ subroutine create_coupling_task(self, link, task)
&not inherited ones such as the current ' // trim(link%name) // '.')

! Create a coupling task (reuse existing one if available, and not user-specified)
call self%coupling_task_list%add(link, .false., task)
end subroutine create_coupling_task
task%slave => link
call self%coupling_task_list%add(task, priority=0)
end subroutine request_coupling_lt

subroutine request_coupling_for_link(self, link, master)
class (type_base_model), intent(inout) :: self
Expand All @@ -1420,11 +1429,9 @@ subroutine request_coupling_for_link(self, link, master)

class (type_coupling_task), pointer :: task

! Create a coupling task (reuse existing one if available, and not user-specified)
call create_coupling_task(self, link, task)
if (.not. associated(task)) return ! We already have a user-specified task, which takes priority

! Configure coupling task
allocate(task)
call self%request_coupling(link, task)
if (.not. associated(task)) return
task%master_name = master
end subroutine request_coupling_for_link

Expand Down Expand Up @@ -1468,8 +1475,9 @@ subroutine request_standard_coupling_for_link(self, link, master)

class (type_coupling_task), pointer :: task

call create_coupling_task(self, link, task)
if (.not. associated(task)) return ! We already have a user-specified task, which takes priority
allocate(task)
call self%request_coupling(link, task)
if (.not. associated(task)) return
task%master_standard_variable => master%typed_resolve()
end subroutine request_standard_coupling_for_link

Expand All @@ -1483,6 +1491,23 @@ subroutine request_standard_coupling_for_id(self, id, master)
call self%request_standard_coupling_for_link(id%link, master)
end subroutine request_standard_coupling_for_id

subroutine request_link_coupling_for_link(self, link, master)
use fabm_standard_variables ! workaround for bug in Cray compiler 8.3.4
class (type_base_model), intent(inout) :: self
type (type_link), target, intent(inout) :: link
type (type_link), target, intent(inout) :: master

class (type_link_coupling_task), pointer :: task
class (type_coupling_task), pointer :: base_class_pointer

allocate(task)
base_class_pointer => task
allocate(task)
call self%request_coupling(link, base_class_pointer)
if (.not. associated(base_class_pointer)) return
task%master => master
end subroutine request_link_coupling_for_link

subroutine integer_pointer_set_append(self, value)
class (type_integer_pointer_set), intent(inout) :: self
integer, target :: value
Expand Down Expand Up @@ -2894,6 +2919,12 @@ function coupling_task_resolve(self) result(link)
link => null()
end function

function link_coupling_task_resolve(self) result(link)
class (type_link_coupling_task), intent(inout) :: self
type (type_link), pointer :: link
link => self%master
end function

subroutine coupling_task_list_remove(self, task)
class (type_coupling_task_list), intent(inout) :: self
class (type_coupling_task), pointer :: task
Expand All @@ -2918,28 +2949,26 @@ function coupling_task_list_find(self, link) result(existing_task)
end do
end function coupling_task_list_find

function coupling_task_list_add_object(self, task, always_create) result(used)
subroutine coupling_task_list_add(self, task, priority)
class (type_coupling_task_list), intent(inout) :: self
class (type_coupling_task), pointer :: task
logical, intent(in) :: always_create
logical :: used
class (type_coupling_task), pointer :: task ! must be pointer to preserve deallocate functionality
integer, intent(in) :: priority

class (type_coupling_task), pointer :: existing_task

! First try to find an existing coupling task for this link. If one exists, we'll replace it.
used = .false.

! Check if we have found an existing task for the same link.
existing_task => self%find(task%slave)
if (associated(existing_task)) then
! If existing one has higher priority, do not add the new task and return (used=.false.)
if (existing_task%user_specified .and. .not. always_create) return
if (existing_task%priority > priority) then
deallocate(task)
return
end if

! We will overwrite the existing task - remove existing task and exit loop
call self%remove(existing_task)
end if

used = .true.
if (.not. associated(self%first)) then
! Task list is empty - add first.
self%first => task
Expand All @@ -2956,21 +2985,7 @@ function coupling_task_list_add_object(self, task, always_create) result(used)
existing_task%next => task
task%previous => existing_task
end if
task%next => null()
end function coupling_task_list_add_object

subroutine coupling_task_list_add(self, link, always_create, task)
class (type_coupling_task_list), intent(inout) :: self
type (type_link), intent(in), target :: link
logical, intent(in) :: always_create
class (type_coupling_task), pointer :: task

logical :: used

allocate(task)
task%slave => link
used = self%add_object(task, always_create)
if (.not. used) deallocate(task)
task%priority = priority
end subroutine coupling_task_list_add

character(len=32) function source2string(source)
Expand Down

0 comments on commit 97da44e

Please sign in to comment.