Commit 12d3de95 authored by Jorn Bruggeman's avatar Jorn Bruggeman
Browse files

fixed indentation of fabm_graph

parent 7896cd6c
......@@ -130,579 +130,578 @@ module fabm_graph
contains
function output_variable_set_add(self, variable) result(output_variable)
class (type_output_variable_set), intent(inout) :: self
type (type_internal_variable),target :: variable
type (type_output_variable_set_node), pointer :: node
type (type_output_variable), pointer :: output_variable
! Check if this variable already exists.
node => self%first
do while (associated(node))
if (associated(node%p%target, variable)) then
output_variable => node%p
return
end if
node => node%next
end do
! Create a new variable object and prepend it to the list.
allocate(output_variable)
output_variable%target => variable
call self%add_output_variable(output_variable)
end function output_variable_set_add
subroutine output_variable_set_add_output_variable(self, output_variable)
class (type_output_variable_set), intent(inout) :: self
type (type_output_variable), target :: output_variable
type (type_output_variable_set_node), pointer :: node
allocate(node)
node%p => output_variable
node%next => self%first
self%first => node
end subroutine output_variable_set_add_output_variable
function input_variable_set_add(self, variable) result(input_variable)
class (type_input_variable_set), intent(inout) :: self
type (type_internal_variable), target :: variable
type (type_input_variable_set_node), pointer :: node
type (type_input_variable), pointer :: input_variable
node => self%first
do while (associated(node))
if (associated(node%p%target, variable)) then
input_variable => node%p
call input_variable%sources%finalize(owner=.false.)
return
end if
node => node%next
end do
function output_variable_set_add(self, variable) result(output_variable)
class (type_output_variable_set), intent(inout) :: self
type (type_internal_variable),target :: variable
type (type_output_variable_set_node), pointer :: node
type (type_output_variable), pointer :: output_variable
! Check if this variable already exists.
node => self%first
do while (associated(node))
if (associated(node%p%target, variable)) then
output_variable => node%p
return
end if
node => node%next
end do
! Create a new variable object and prepend it to the list.
allocate(output_variable)
output_variable%target => variable
call self%add_output_variable(output_variable)
end function output_variable_set_add
subroutine output_variable_set_add_output_variable(self, output_variable)
class (type_output_variable_set), intent(inout) :: self
type (type_output_variable), target :: output_variable
type (type_output_variable_set_node), pointer :: node
allocate(node)
node%p => output_variable
node%next => self%first
self%first => node
end subroutine output_variable_set_add_output_variable
function input_variable_set_add(self, variable) result(input_variable)
class (type_input_variable_set), intent(inout) :: self
type (type_internal_variable), target :: variable
type (type_input_variable_set_node), pointer :: node
type (type_input_variable), pointer :: input_variable
node => self%first
do while (associated(node))
if (associated(node%p%target, variable)) then
input_variable => node%p
call input_variable%sources%finalize(owner=.false.)
return
end if
node => node%next
end do
allocate(input_variable)
input_variable%target => variable
allocate(input_variable)
input_variable%target => variable
allocate(node)
node%p => input_variable
node%next => self%first
self%first => node
end function input_variable_set_add
allocate(node)
node%p => input_variable
node%next => self%first
self%first => node
end function input_variable_set_add
subroutine output_variable_set_finalize(self, owner)
class (type_output_variable_set), intent(inout) :: self
logical, intent(in) :: owner
type (type_output_variable_set_node),pointer :: node, next
node => self%first
do while (associated(node))
next => node%next
if (owner) then
call node%p%dependent_nodes%finalize()
deallocate(node%p)
end if
deallocate(node)
node => next
end do
self%first => null()
end subroutine output_variable_set_finalize
subroutine output_variable_set_finalize(self, owner)
class (type_output_variable_set), intent(inout) :: self
logical, intent(in) :: owner
subroutine input_variable_set_finalize(self)
class (type_input_variable_set), intent(inout) :: self
type (type_output_variable_set_node),pointer :: node, next
type (type_input_variable_set_node), pointer :: node, next
node => self%first
do while (associated(node))
next => node%next
if (owner) then
call node%p%dependent_nodes%finalize()
node => self%first
do while (associated(node))
next => node%next
call node%p%sources%finalize(owner=.false.)
deallocate(node%p)
end if
deallocate(node)
node => next
end do
self%first => null()
end subroutine output_variable_set_finalize
subroutine input_variable_set_finalize(self)
class (type_input_variable_set), intent(inout) :: self
type (type_input_variable_set_node), pointer :: node, next
node => self%first
do while (associated(node))
next => node%next
call node%p%sources%finalize(owner=.false.)
deallocate(node%p)
deallocate(node)
node => next
end do
self%first => null()
end subroutine input_variable_set_finalize
subroutine graph_print(self)
class (type_graph), intent(in) :: self
type (type_node_list_member),pointer :: node
type (type_output_variable_set_node), pointer :: variable
type (type_node_set_member), pointer :: pnode
node => self%first
do while (associated(node))
write (*,'(a,": ",a)') trim(node%p%model%get_path()),trim(source2string(node%p%source))
variable => node%p%outputs%first
do while (associated(variable))
write (*,'(" ",a,",write@",i0)',advance='no') trim(variable%p%target%name),variable%p%target%write_indices%value
if (variable%p%copy_to_cache) write (*,'(",cache@",i0)',advance='no') variable%p%target%read_indices%value
if (variable%p%copy_to_store) write (*,'(",store@",i0)',advance='no') variable%p%target%store_index
write (*,*)
pnode => variable%p%dependent_nodes%first
do while (associated(pnode))
write (*,'(" <- ",a,": ",a)') trim(pnode%p%model%get_path()),trim(source2string(pnode%p%source))
pnode => pnode%next
deallocate(node)
node => next
end do
self%first => null()
end subroutine input_variable_set_finalize
subroutine graph_print(self)
class (type_graph), intent(in) :: self
type (type_node_list_member),pointer :: node
type (type_output_variable_set_node), pointer :: variable
type (type_node_set_member), pointer :: pnode
node => self%first
do while (associated(node))
write (*,'(a,": ",a)') trim(node%p%model%get_path()),trim(source2string(node%p%source))
variable => node%p%outputs%first
do while (associated(variable))
write (*,'(" ",a,",write@",i0)',advance='no') trim(variable%p%target%name),variable%p%target%write_indices%value
if (variable%p%copy_to_cache) write (*,'(",cache@",i0)',advance='no') variable%p%target%read_indices%value
if (variable%p%copy_to_store) write (*,'(",store@",i0)',advance='no') variable%p%target%store_index
write (*,*)
pnode => variable%p%dependent_nodes%first
do while (associated(pnode))
write (*,'(" <- ",a,": ",a)') trim(pnode%p%model%get_path()),trim(source2string(pnode%p%source))
pnode => pnode%next
end do
variable => variable%next
end do
variable => variable%next
node => node%next
end do
node => node%next
end do
end subroutine graph_print
recursive subroutine find_node(self, model, source, graph, node)
class (type_graph), intent(inout), target :: self
class (type_base_model), intent(in), target :: model
integer, intent(in) :: source
class (type_graph), pointer :: graph
type (type_node), pointer :: node
end subroutine graph_print
type (type_graph_set_member), pointer :: member
recursive subroutine find_node(self, model, source, graph, node)
class (type_graph), intent(inout), target :: self
class (type_base_model), intent(in), target :: model
integer, intent(in) :: source
class (type_graph), pointer :: graph
type (type_node), pointer :: node
graph => self
node => self%find(model, source)
if (associated(node)) return
type (type_graph_set_member), pointer :: member
member => self%next%first
do while (associated(member))
call find_node(member%p, model, source, graph, node)
graph => self
node => self%find(model, source)
if (associated(node)) return
member => member%next
end do
graph => null()
end subroutine
recursive function graph_has_descendant(self, graph) result(has_descendant)
class (type_graph), pointer :: self
class (type_graph), pointer :: graph
logical :: has_descendant
type (type_graph_set_member), pointer :: member
has_descendant = .true.
if (associated(self, graph)) return
member => self%next%first
do while (associated(member))
if (graph_has_descendant(member%p, graph)) return
member => member%next
end do
has_descendant = .false.
end function
recursive function graph_add_call(self, model, source, stack_top) result(node)
class (type_graph), target, intent(inout) :: self
class (type_base_model), target, intent(in) :: model
integer, intent(in) :: source
member => self%next%first
do while (associated(member))
call find_node(member%p, model, source, graph, node)
if (associated(node)) return
member => member%next
end do
graph => null()
end subroutine
recursive function graph_has_descendant(self, graph) result(has_descendant)
class (type_graph), pointer :: self
class (type_graph), pointer :: graph
logical :: has_descendant
type (type_graph_set_member), pointer :: member
has_descendant = .true.
if (associated(self, graph)) return
member => self%next%first
do while (associated(member))
if (graph_has_descendant(member%p, graph)) return
member => member%next
end do
has_descendant = .false.
end function
recursive function graph_add_call(self, model, source, stack_top) result(node)
class (type_graph), target, intent(inout) :: self
class (type_base_model), target, intent(in) :: model
integer, intent(in) :: source
type (type_call_stack_node), pointer :: stack_top
type (type_node), pointer :: node
type (type_call_stack_node), pointer :: existing_stack_node, stack_node
character(len=2048) :: chain
class (type_graph), pointer :: root_graph, owner_graph, target_graph
integer :: operation
type (type_link), pointer :: link
type (type_input_variable), pointer :: input_variable
! Circular dependency check:
! Search the list of outer model calls, i.e., calls that [indirectly] request the current call.
! If the current call is already on this list, it is indirectly calling itself: there is a circular dependency.
existing_stack_node => stack_top
do while (associated(existing_stack_node))
if (associated(existing_stack_node%model, model) .and. existing_stack_node%source == source) exit
existing_stack_node => existing_stack_node%previous
end do
if (associated(existing_stack_node)) then
! Circular dependency found - report as fatal error.
chain = trim(model%get_path()) // ':' // trim(source2string(source))
stack_node => stack_top
do
chain = trim(stack_node%model%get_path()) // ':' // trim(source2string(stack_node%source)) &
// ' needs ' // trim(stack_node%requested_variable%name) // ' provided by ' // trim(chain)
if (associated(stack_node, existing_stack_node)) exit
stack_node => stack_node%previous
type (type_node), pointer :: node
type (type_call_stack_node), pointer :: existing_stack_node, stack_node
character(len=2048) :: chain
class (type_graph), pointer :: root_graph, owner_graph, target_graph
integer :: operation
type (type_link), pointer :: link
type (type_input_variable), pointer :: input_variable
! Circular dependency check:
! Search the stack, i.e., the list of calls that [indirectly] request the current call.
! If the current call is already on the stack, it is indirectly calling itself: there is a circular dependency.
existing_stack_node => stack_top
do while (associated(existing_stack_node))
if (associated(existing_stack_node%model, model) .and. existing_stack_node%source == source) exit
existing_stack_node => existing_stack_node%previous
end do
call driver%fatal_error('graph::add_call', 'circular dependency found: ' // trim(chain))
end if
! By default we add the call to the current graph (but if necessary we will target an ancestor instead)
target_graph => self
! Check if this node is already in a graph of another job (recursive search from the root graph/very first job).
root_graph => target_graph
do while (associated(root_graph%previous%first))
root_graph => root_graph%previous%first%p
end do
call find_node(root_graph, model, source, owner_graph, node)
if (associated(node)) then
! If the graph that contains the target call is one of our ancestors, or us (i.e., it is scheduled to run before us or together with us),
! we are done - return.
if (graph_has_descendant(owner_graph, target_graph)) return
! This node is in sibling graph (a job scheduled to run in parallel) or in a descendent graph (a job scheduled to run later).
! It needs to be moved to the last common ancestor of the currently targeted graph and the graph that already contains the call.
! First find the last common ancestor (i.e., the graph that needs to receive the node)
do while (.not. graph_has_descendant(target_graph, owner_graph))
_ASSERT_(.not. associated(target_graph%previous%first%next), 'graph::add_call', 'Multiple ancestors found when trying to find common')
target_graph => target_graph%previous%first%p
if (associated(existing_stack_node)) then
! Circular dependency found - report as fatal error.
chain = trim(model%get_path()) // ':' // trim(source2string(source))
stack_node => stack_top
do
chain = trim(stack_node%model%get_path()) // ':' // trim(source2string(stack_node%source)) &
// ' needs ' // trim(stack_node%requested_variable%name) // ' provided by ' // trim(chain)
if (associated(stack_node, existing_stack_node)) exit
stack_node => stack_node%previous
end do
call driver%fatal_error('graph::add_call', 'circular dependency found: ' // trim(chain))
end if
! By default we add the call to the current graph (but if necessary we will target an ancestor instead)
target_graph => self
! Check if this node is already in a graph of another job (recursive search from the root graph/very first job).
root_graph => target_graph
do while (associated(root_graph%previous%first))
root_graph => root_graph%previous%first%p
end do
call find_node(root_graph, model, source, owner_graph, node)
if (associated(node)) then
! If the graph that contains the target call is one of our ancestors, or us (i.e., it is scheduled to run before us or together with us),
! we are done - return.
if (graph_has_descendant(owner_graph, target_graph)) return
! This node is in sibling graph (a job scheduled to run in parallel) or in a descendent graph (a job scheduled to run later).
! It needs to be moved to the last common ancestor of the currently targeted graph and the graph that already contains the call.
! First find the last common ancestor (i.e., the graph that needs to receive the node)
do while (.not. graph_has_descendant(target_graph, owner_graph))
_ASSERT_(.not. associated(target_graph%previous%first%next), 'graph::add_call', 'Multiple ancestors found when trying to find common')
target_graph => target_graph%previous%first%p
end do
! Now remove the node from the graph that currently contains it.
call owner_graph%remove(node)
else
allocate(node)
node%model => model
node%source = source
end if
! Find an ancestor graph (earlier scheduled job) with a compatible operation.
operation = source2operation(source)
do while (target_graph%operation /= source_unknown .and. target_graph%operation /= operation .and. .not. ((target_graph%operation == source_do_bottom .or. target_graph%operation == source_do_surface) .and. operation == source_do_horizontal))
_ASSERT_(.not. associated(target_graph%previous%first%next), 'graph::add_call', 'Multiple ancestors found when trying to find ancestor with compatible operation')
target_graph => target_graph%previous%first%p
end do
if (target_graph%frozen) call driver%fatal_error('graph_add_call','Target graph is frozen; no calls can be added.')
! First add this call to the list of requesting calls [a list of all calls higher on the call stack]
! This forbids any indirect dependency on this call, as such would be a circular dependency.
allocate(stack_node)
stack_node%model => model
stack_node%source = source
stack_node%previous => stack_top
link => model%links%first
do while (associated(link))
if (index(link%name, '/') == 0 .and. associated(link%original%read_index)) then
! This is the model's own variable (not inherited from child model) and the model itself originally requested read access to it.
_ASSERT_(.not. associated(link%target%write_owner), 'graph::add_call', 'BUG: required input variable is co-written.')
input_variable => node%inputs%add(link%target)
stack_node%requested_variable => link%target
if (.not. (associated(link%target%owner, model) .and. link%target%source == source)) &
call target_graph%add_variable(link%target, stack_node, input_variable%sources, caller=node)
! Now remove the node from the graph that currently contains it.
call owner_graph%remove(node)
else
allocate(node)
node%model => model
node%source = source
end if
link => link%next
end do
! Remove node from the list of outer calls and add it to the graph instead.
deallocate(stack_node)
call target_graph%append(node)
end function graph_add_call
recursive subroutine graph_add_variable(self, variable, stack_top, variable_set, copy_to_store, caller)
class (type_graph), intent(inout) :: self
type (type_internal_variable), intent(in) :: variable
type (type_call_stack_node), pointer :: stack_top
type (type_output_variable_set), intent(inout) :: variable_set
logical, optional, intent(in) :: copy_to_store
type (type_node), optional, target, intent(inout) :: caller
type (type_variable_node), pointer :: variable_node
if (self%frozen) call driver%fatal_error('graph_add_variable','Graph is frozen; no variables can be added.')
if (associated(variable%cowriters)) then
variable_node => variable%cowriters%first
do while (associated(variable_node))
call add_call(variable_node%target)
variable_node => variable_node%next
! Find an ancestor graph (earlier scheduled job) with a compatible operation.
operation = source2operation(source)
do while (target_graph%operation /= source_unknown .and. target_graph%operation /= operation .and. .not. ((target_graph%operation == source_do_bottom .or. target_graph%operation == source_do_surface) .and. operation == source_do_horizontal))
_ASSERT_(.not. associated(target_graph%previous%first%next), 'graph::add_call', 'Multiple ancestors found when trying to find ancestor with compatible operation')
target_graph => target_graph%previous%first%p
end do
else
call add_call(variable)
end if
contains
if (target_graph%frozen) call driver%fatal_error('graph_add_call','Target graph is frozen; no calls can be added.')
! Push this call onto the stack [the list of requesting calls]. This will be used for circular dependency checking.
allocate(stack_node)
stack_node%model => model
stack_node%source = source
stack_node%previous => stack_top
link => model%links%first
do while (associated(link))
if (index(link%name, '/') == 0 .and. associated(link%original%read_index)) then
! This is the model's own variable (not inherited from child model) and the model itself originally requested read access to it.
_ASSERT_(.not. associated(link%target%write_owner), 'graph::add_call', 'BUG: required input variable is co-written.')
input_variable => node%inputs%add(link%target)
stack_node%requested_variable => link%target
if (.not. (associated(link%target%owner, model) .and. link%target%source == source)) &
call target_graph%add_variable(link%target, stack_node, input_variable%sources, caller=node)
end if
link => link%next
end do
! Remove node from the list of outer calls and add it to the graph instead.
deallocate(stack_node)
call target_graph%append(node)
end function graph_add_call
recursive subroutine add_call(variable)
type (type_internal_variable), intent(in) :: variable
recursive subroutine graph_add_variable(self, variable, stack_top, variable_set, copy_to_store, caller)
class (type_graph), intent(inout) :: self
type (type_internal_variable), intent(in) :: variable
type (type_call_stack_node), pointer :: stack_top
type (type_output_variable_set), intent(inout) :: variable_set
logical, optional, intent(in) :: copy_to_store
type (type_node), optional, target, intent(inout) :: caller
type (type_node), pointer :: node
type (type_output_variable), pointer :: output_variable
type (type_variable_node), pointer :: variable_node
if (variable%source == source_constant .or. variable%source == source_state .or. variable%source == source_external .or. variable%source == source_unknown) return
_ASSERT_ (.not. variable%write_indices%is_empty(), 'graph_add_variable::add_call', 'Variable "' // trim(variable%name) // '" with source ' // trim(source2string(variable%source)) // ' does not have a write index')
if (self%frozen) call driver%fatal_error('graph_add_variable','Graph is frozen; no variables can be added.')
node => self%add_call(variable%owner, variable%source, stack_top)
output_variable => node%outputs%add(variable)
if (present(copy_to_store)) output_variable%copy_to_store = output_variable%copy_to_store .or. copy_to_store
if (present(caller)) then
call caller%dependencies%add(node)
call output_variable%dependent_nodes%add(caller)
if (associated(variable%cowriters)) then
variable_node => variable%cowriters%first
do while (associated(variable_node))
call add_call(variable_node%target)
variable_node => variable_node%next
end do
else
call add_call(variable)
end if
call variable_set%add_output_variable(output_variable)
end subroutine add_call
end subroutine graph_add_variable