Commit 933a1e67 authored by Jorn Bruggeman's avatar Jorn Bruggeman
Browse files

do not call driver%fatal_error directly; prevent infinite recursion if fatal_error returns

parent b2eb23a6
......@@ -19,7 +19,7 @@
use fabm_config
use fabm_types, only:rk,attribute_length,type_model_list_node,type_base_model, &
factory,type_link,type_link_list,type_internal_variable
use fabm_driver, only: type_base_driver, driver
use fabm_driver, only: type_base_driver, driver, fatal_error
use fabm_properties
use fabm_python_helper
use fabm_c_helper
......@@ -350,7 +350,7 @@
call c_f_pointer(c_loc(name), pname)
found_model => model%root%find_model(pname(:index(pname,C_NULL_CHAR)-1))
if (.not.associated(found_model)) call driver%fatal_error('get_model_metadata', &
if (.not.associated(found_model)) call fatal_error('get_model_metadata', &
'model "'//pname(:index(pname,C_NULL_CHAR)-1)//'" not found.')
call copy_to_c_string(found_model%long_name,long_name)
user_created = logical2int(found_model%user_created)
......@@ -414,7 +414,7 @@
if (int2logical(do_bottom)) call fabm_do_bottom(model, rates(1:size(model%state_variables)), &
rates(size(model%state_variables)+size(model%surface_state_variables)+1:))
if (int2logical(do_surface) .or. int2logical(do_bottom)) then
if (.not.associated(column_depth)) call driver%fatal_error('get_rates', &
if (.not.associated(column_depth)) call fatal_error('get_rates', &
'Value for environmental dependency '//trim(environment_names(index_column_depth))// &
' must be provided if get_rates is called with the do_surface and/or do_bottom flags.')
rates(1:size(model%state_variables)) = rates(1:size(model%state_variables))/column_depth
......@@ -459,7 +459,7 @@
logical :: surface, bottom
if (ny /= size(model%state_variables)+size(model%surface_state_variables)+size(model%bottom_state_variables)) &
call driver%fatal_error('integrate', 'ny is wrong length')
call fatal_error('integrate', 'ny is wrong length')
call c_f_pointer(c_loc(t_), t, (/nt/))
call c_f_pointer(c_loc(y_ini_), y_ini, (/ny/))
......@@ -468,7 +468,7 @@
surface = int2logical(do_surface)
bottom = int2logical(do_bottom)
if (surface .or. bottom) then
if (.not.associated(column_depth)) call driver%fatal_error('get_rates', &
if (.not.associated(column_depth)) call fatal_error('get_rates', &
'Value for environmental dependency '//trim(environment_names(index_column_depth))// &
' must be provided if integrate is called with the do_surface and/or do_bottom flags.')
end if
......@@ -562,7 +562,7 @@
value = property%value
end if
class default
call driver%fatal_error('get_real_parameter','not a real variable')
call fatal_error('get_real_parameter','not a real variable')
end select
end function get_real_parameter
......@@ -595,7 +595,7 @@
value = property%value
end if
class default
call driver%fatal_error('get_integer_parameter','not an integer variable')
call fatal_error('get_integer_parameter','not an integer variable')
end select
end function get_integer_parameter
......@@ -628,7 +628,7 @@
value = logical2int(property%value)
end if
class default
call driver%fatal_error('get_logical_parameter','not a logical variable')
call fatal_error('get_logical_parameter','not a logical variable')
end select
end function get_logical_parameter
......@@ -662,7 +662,7 @@
call copy_to_c_string(property%value, value)
end if
class default
call driver%fatal_error('get_string_parameter','not a string variable')
call fatal_error('get_string_parameter','not a string variable')
end select
end subroutine get_string_parameter
......
......@@ -4493,7 +4493,7 @@ function create_external_interior_id(variable) result(id)
type (type_internal_variable),intent(inout),target :: variable
type (type_bulk_variable_id) :: id
if (variable%domain/=domain_interior) call driver%fatal_error('create_external_interior_id','BUG: called on non-interior variable.')
if (variable%domain/=domain_interior) call fatal_error('create_external_interior_id','BUG: called on non-interior variable.')
id%variable => variable
if (.not.variable%read_indices%is_empty()) id%read_index = variable%read_indices%value
end function create_external_interior_id
......@@ -4503,7 +4503,7 @@ function create_external_horizontal_id(variable) result(id)
type (type_horizontal_variable_id) :: id
if (variable%domain/=domain_horizontal.and.variable%domain/=domain_surface.and.variable%domain/=domain_bottom) &
call driver%fatal_error('create_external_horizontal_id','BUG: called on non-horizontal variable.')
call fatal_error('create_external_horizontal_id','BUG: called on non-horizontal variable.')
id%variable => variable
if (.not.variable%read_indices%is_empty()) id%read_index = variable%read_indices%value
end function create_external_horizontal_id
......@@ -4511,7 +4511,7 @@ end function create_external_horizontal_id
function create_external_scalar_id(variable) result(id)
type (type_internal_variable),intent(inout),target :: variable
type (type_scalar_variable_id) :: id
if (variable%domain/=domain_scalar) call driver%fatal_error('create_external_scalar_id','BUG: called on non-scalar variable.')
if (variable%domain/=domain_scalar) call fatal_error('create_external_scalar_id','BUG: called on non-scalar variable.')
id%variable => variable
if (.not.variable%read_indices%is_empty()) id%read_index = variable%read_indices%value
end function create_external_scalar_id
......@@ -4732,11 +4732,11 @@ subroutine classify_variables(self)
consvar%long_name = trim(consvar%standard_variable%name)
consvar%path = trim(consvar%standard_variable%name)
consvar%target => self%root%find_object(trim(aggregate_variable%standard_variable%name))
if (.not.associated(consvar%target)) call driver%fatal_error('classify_variables', &
if (.not.associated(consvar%target)) call fatal_error('classify_variables', &
'BUG: conserved quantity '//trim(aggregate_variable%standard_variable%name)//' was not created')
call consvar%target%read_indices%append(consvar%index)
consvar%target_hz => self%root%find_object(trim(aggregate_variable%standard_variable%name)//'_at_interfaces')
if (.not.associated(consvar%target_hz)) call driver%fatal_error('classify_variables', &
if (.not.associated(consvar%target_hz)) call fatal_error('classify_variables', &
'BUG: conserved quantity '//trim(aggregate_variable%standard_variable%name)//'_at_interfaces was not created')
call consvar%target_hz%read_indices%append(consvar%horizontal_index)
end if
......@@ -4745,7 +4745,7 @@ subroutine classify_variables(self)
! Get link to extinction variable.
self%extinction_target => self%root%find_object(trim(standard_variables%attenuation_coefficient_of_photosynthetic_radiative_flux%name))
if (.not.associated(self%extinction_target)) call driver%fatal_error('classify_variables', &
if (.not.associated(self%extinction_target)) call fatal_error('classify_variables', &
'BUG: variable attenuation_coefficient_of_photosynthetic_radiative_flux was not created')
call self%extinction_target%read_indices%append(self%extinction_index)
......
......@@ -849,6 +849,7 @@ recursive subroutine find_dependencies(self,list,forbidden)
node => node%next
end do
call fatal_error('find_dependencies','circular dependency found: '//trim(chain(2:))//' '//trim(self%get_path()))
return
end if
call forbidden_with_self%extend(forbidden)
end if
......@@ -1104,6 +1105,7 @@ recursive subroutine find_dependencies2(self,source,allowed_sources,list,forbidd
node => node%next
end do
call fatal_error('find_dependencies','circular dependency found: '//trim(chain(2:))//' '//trim(self%get_path()))
return
end if
call forbidden_with_self%extend(forbidden)
end if
......@@ -1253,7 +1255,7 @@ contains
maxwrite = -1
node => call_list_node%written_variables%first
do while (associated(node))
if (node%target%write_indices%is_empty()) call driver%fatal_error('call_list_node_initialize','BUG: target without write indices')
if (node%target%write_indices%is_empty()) call fatal_error('call_list_node_initialize','BUG: target without write indices')
if (iand(node%target%domain,domain)/=0) then
n = n + 1
maxwrite = max(maxwrite,node%target%write_indices%value)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment