python_fabm.F90 24.6 KB
Newer Older
Jorn Bruggeman's avatar
Jorn Bruggeman committed
1 2 3 4 5 6 7 8 9 10 11 12 13
#include "fabm_driver.h"
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: Python interface to the Framework for Aquatic Biogeochemical Models (FABM)
!
! !INTERFACE:
   module fabm_python
!
! !DESCRIPTION:
! TODO
!
! !USES:
14
   use iso_c_binding, only: c_double, c_int, c_char, C_NULL_CHAR, c_f_pointer, c_loc, c_ptr
15 16 17

   !DIR$ ATTRIBUTES DLLEXPORT :: STATE_VARIABLE,DIAGNOSTIC_VARIABLE,CONSERVED_QUANTITY

Jorn Bruggeman's avatar
Jorn Bruggeman committed
18 19
   use fabm
   use fabm_config
Jorn Bruggeman's avatar
Jorn Bruggeman committed
20 21
   use fabm_types, only:rk,attribute_length,type_model_list_node,type_base_model, &
                        factory,type_link,type_link_list,type_internal_variable
22
   use fabm_driver, only: type_base_driver, driver
23
   use fabm_properties
Jorn Bruggeman's avatar
Jorn Bruggeman committed
24
   use fabm_python_helper
25
   use fabm_c_helper
Jorn Bruggeman's avatar
Jorn Bruggeman committed
26 27 28 29 30 31

   implicit none
!
! !PUBLIC MEMBER FUNCTIONS:
   public

32
   integer,parameter :: INTERIOR_STATE_VARIABLE        = 1
33 34
   integer,parameter :: SURFACE_STATE_VARIABLE         = 2
   integer,parameter :: BOTTOM_STATE_VARIABLE          = 3
35
   integer,parameter :: INTERIOR_DIAGNOSTIC_VARIABLE   = 4
36 37 38
   integer,parameter :: HORIZONTAL_DIAGNOSTIC_VARIABLE = 5
   integer,parameter :: CONSERVED_QUANTITY             = 6

39
   class (type_model),private,pointer,save :: model => null()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
40
   character(len=1024),dimension(:),allocatable :: environment_names,environment_units
41 42
   integer :: index_column_depth
   real(c_double),pointer :: column_depth
43
   type (type_link_list),save :: coupling_link_list
44
   logical, save :: error_occurred = .false.
Jorn Bruggeman's avatar
Jorn Bruggeman committed
45

46
   type (type_property_dictionary),save,private :: forced_parameters,forced_couplings
47 48 49

   type,extends(type_base_driver) :: type_python_driver
   contains
50 51
      procedure :: fatal_error => python_driver_fatal_error
      procedure :: log_message => python_driver_log_message
52
   end type
Jorn Bruggeman's avatar
Jorn Bruggeman committed
53 54 55 56 57
!EOP
!-----------------------------------------------------------------------

   contains

58 59 60 61 62 63 64 65 66 67 68 69
   subroutine get_version(length,version_string) bind(c)
!DIR$ ATTRIBUTES DLLEXPORT :: get_version
      use fabm_version, only: fabm_commit_id=>git_commit_id, &
                              fabm_branch_name=>git_branch_name

      integer(c_int),value,intent(in) :: length
      character(kind=c_char)          :: version_string(length)

      call copy_to_c_string(fabm_commit_id//' ('//fabm_branch_name//' branch)', version_string)
   end subroutine get_version


Jorn Bruggeman's avatar
Jorn Bruggeman committed
70 71 72 73 74 75
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Initialise the model
!
! !INTERFACE:
76
   subroutine initialize(path) bind(c)
77
!DIR$ ATTRIBUTES DLLEXPORT :: initialize
78
      character(kind=c_char),target,intent(in) :: path(*)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
79 80 81 82 83 84 85 86
!
! !DESCRIPTION:
!
! !REVISION HISTORY:
!  Original author(s): Jorn Bruggeman
!
!EOP
!
87
      character(len=attribute_length),pointer :: ppath
88
      class (type_property),          pointer :: property
Jorn Bruggeman's avatar
Jorn Bruggeman committed
89 90
!-----------------------------------------------------------------------
!BOC
Jorn Bruggeman's avatar
Jorn Bruggeman committed
91 92
      ! Initialize driver object used by FABM for logging/error reporting.
      if (.not.associated(driver)) allocate(type_python_driver::driver)
93

Jorn Bruggeman's avatar
Jorn Bruggeman committed
94
      ! If the model object already exists, delete it to start from scratch.
95
      if (associated(model)) call finalize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
96

Jorn Bruggeman's avatar
Jorn Bruggeman committed
97 98
      ! Remove any existing user-specified parameter values and couplings.
      ! (If the user wanted to preserve those, he would have called reinitialize)
99 100 101
      call forced_parameters%finalize()
      call forced_couplings%finalize()

Jorn Bruggeman's avatar
Jorn Bruggeman committed
102
      ! Build FABM model tree (configuration will be read from file specified as argument).
103
      allocate(model)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
104
      call c_f_pointer(c_loc(path), ppath)
105 106
      call fabm_create_model_from_yaml_file(model,path=ppath(:index(ppath,C_NULL_CHAR)-1),parameters=forced_parameters)

107
      ! Get a list of all parameters that had an explicit value specified.
108 109
      property => model%root%parameters%first
      do while (associated(property))
110
         if (.not.model%root%parameters%missing%contains(property%name)) &
111 112 113
            call forced_parameters%set_property(property)
         property => property%next
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
114

115 116 117 118 119 120 121 122
      ! Get a list of all active couplings.
      property => model%root%couplings%first
      do while (associated(property))
         if (.not.model%root%couplings%missing%contains(property%name)) &
            call forced_couplings%set_property(property)
         property => property%next
      end do

Jorn Bruggeman's avatar
Jorn Bruggeman committed
123 124 125
      ! Send information on spatial domain to FABM (this also allocates memory for diagnostics)
      call fabm_set_domain(model)

126
      ! Retrieve arrays to hold values for environmental variables and corresponding metadata.
127 128
      call get_environment_metadata(model,environment_names,environment_units,index_column_depth)
      column_depth => null()
129

130
      call get_couplings(model,coupling_link_list)
131 132 133
   end subroutine initialize
!EOC

134 135 136 137 138 139
   subroutine reinitialize()
      type (type_model),           pointer :: newmodel
      type (type_model_list_node), pointer :: node
      class (type_base_model),     pointer :: childmodel
      class (type_property),       pointer :: property,next

Jorn Bruggeman's avatar
Jorn Bruggeman committed
140
      ! Create new model object.
141 142 143 144
      allocate(newmodel)

      ! Transfer forced parameters to root of the model.
      call newmodel%root%parameters%update(forced_parameters)
145
      call newmodel%root%couplings%update(forced_couplings)
146 147 148 149

      ! Re-create original models
      node => model%root%children%first
      do while (associated(node))
150
         if (node%model%user_created) then
151
            call factory%create(node%model%type_name,childmodel)
152
            childmodel%user_created = .true.
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
            call newmodel%root%add_child(childmodel,node%model%name,node%model%long_name,configunit=-1)
         end if
         node => node%next
      end do

      ! Clean up old model
      call finalize()
      model => newmodel

      ! Initialize new model
      call fabm_initialize(model)

      ! Removed unused forced parameters from root model.
      property => model%root%parameters%first
      do while (associated(property))
168
         if (.not. model%root%parameters%retrieved%contains(property%name)) then
169 170 171 172 173 174 175 176 177 178 179 180
            next => property%next
            call model%root%parameters%delete(property%name)
            property => next
         else
            property => property%next
         end if
      end do

      ! Send information on spatial domain to FABM (this also allocates memory for diagnostics)
      call fabm_set_domain(model)

      ! Retrieve arrays to hold values for environmental variables and corresponding metadata.
181 182
      call get_environment_metadata(model,environment_names,environment_units,index_column_depth)
      column_depth => null()
183 184

      call get_couplings(model,coupling_link_list)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
185
   end subroutine reinitialize
186

187
   subroutine check_ready() bind(c)
188 189
      !DIR$ ATTRIBUTES DLLEXPORT :: check_ready
      call fabm_check_ready(model)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
190
   end subroutine check_ready
191

192 193 194 195 196
   integer(c_int) function get_error_state() bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_error_state
      get_error_state = logical2int(error_occurred)
   end function get_error_state

197
   integer(c_int) function model_count() bind(c)
198 199 200 201 202 203 204 205 206
      !DIR$ ATTRIBUTES DLLEXPORT :: model_count

      type (type_model_list_node), pointer :: node

      model_count = 0
      node => model%root%children%first
      do while (associated(node))
         model_count = model_count + 1
         node => node%next
Jorn Bruggeman's avatar
Jorn Bruggeman committed
207
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
208
   end function model_count
209

210
   subroutine get_counts(nstate_interior,nstate_surface,nstate_bottom,ndiagnostic_interior,ndiagnostic_horizontal,nconserved, &
211
      ndependencies,nparameters,ncouplings) bind(c)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
212
      !DIR$ ATTRIBUTES DLLEXPORT :: get_counts
213 214
      integer(c_int),intent(out) :: nstate_interior,nstate_surface,nstate_bottom
      integer(c_int),intent(out) :: ndiagnostic_interior,ndiagnostic_horizontal
215
      integer(c_int),intent(out) :: nconserved,ndependencies,nparameters,ncouplings
216
      nstate_interior = size(model%state_variables)
217 218
      nstate_surface = size(model%surface_state_variables)
      nstate_bottom = size(model%bottom_state_variables)
219
      ndiagnostic_interior = size(model%diagnostic_variables)
220 221 222 223
      ndiagnostic_horizontal = size(model%horizontal_diagnostic_variables)
      nconserved = size(model%conserved_quantities)
      ndependencies = size(environment_names)
      nparameters = model%root%parameters%size()
224
      ncouplings = coupling_link_list%count()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
225
   end subroutine get_counts
226

227
   subroutine get_variable_metadata(category,index,length,name,units,long_name,path) bind(c)
228
      !DIR$ ATTRIBUTES DLLEXPORT :: get_variable_metadata
229
      integer(c_int),        intent(in), value             :: category,index,length
230
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name,path
231 232 233 234 235

      class (type_external_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
236
      case (INTERIOR_STATE_VARIABLE)
237 238 239 240 241
         variable => model%state_variables(index)
      case (SURFACE_STATE_VARIABLE)
         variable => model%surface_state_variables(index)
      case (BOTTOM_STATE_VARIABLE)
         variable => model%bottom_state_variables(index)
242
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
243 244 245 246 247 248
         variable => model%diagnostic_variables(index)
      case (HORIZONTAL_DIAGNOSTIC_VARIABLE)
         variable => model%horizontal_diagnostic_variables(index)
      case (CONSERVED_QUANTITY)
         variable => model%conserved_quantities(index)
      end select
249 250 251 252
      call copy_to_c_string(variable%name,           name)
      call copy_to_c_string(variable%units,          units)
      call copy_to_c_string(variable%local_long_name,long_name)
      call copy_to_c_string(variable%path,           path)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
253
   end subroutine get_variable_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
254

Jorn Bruggeman's avatar
Jorn Bruggeman committed
255 256 257 258
   function get_variable(category,index) bind(c) result(pvariable)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_variable
      integer(c_int),intent(in), value :: category,index
      type (c_ptr)                     :: pvariable
259 260 261 262 263

      type (type_internal_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
264
      case (INTERIOR_STATE_VARIABLE)
265 266 267 268 269
         variable => model%state_variables(index)%target
      case (SURFACE_STATE_VARIABLE)
         variable => model%surface_state_variables(index)%target
      case (BOTTOM_STATE_VARIABLE)
         variable => model%bottom_state_variables(index)%target
270
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
271 272 273 274 275 276 277
         variable => model%diagnostic_variables(index)%target
      case (HORIZONTAL_DIAGNOSTIC_VARIABLE)
         variable => model%horizontal_diagnostic_variables(index)%target
      case (CONSERVED_QUANTITY)
         variable => model%conserved_quantities(index)%target
      end select
      pvariable = c_loc(variable)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
278
   end function get_variable
279

280
   subroutine get_parameter_metadata(index,length,name,units,long_name,typecode,has_default) bind(c)
281
      !DIR$ ATTRIBUTES DLLEXPORT :: get_parameter_metadata
282
      integer(c_int),        intent(in), value             :: index,length
283
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name
284
      integer(c_int),        intent(out)                   :: typecode,has_default
285 286 287 288 289 290 291 292 293 294

      integer                       :: i
      class (type_property),pointer :: property

      i = 1
      property => model%root%parameters%first
      do while (associated(property))
         if (index==i) exit
         property => property%next
         i = i + 1
Jorn Bruggeman's avatar
Jorn Bruggeman committed
295 296
      end do

297 298 299 300
      call copy_to_c_string(property%name,     name)
      call copy_to_c_string(property%units,    units)
      call copy_to_c_string(property%long_name,long_name)
      typecode = property%typecode()
301
      has_default = logical2int(property%has_default)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
302
   end subroutine get_parameter_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
303

304 305
   subroutine get_dependency_metadata(index,length,name,units) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_dependency_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
306
      integer(c_int),        intent(in), value             :: index,length
307
      character(kind=c_char),intent(out),dimension(length) :: name,units
Jorn Bruggeman's avatar
Jorn Bruggeman committed
308

309 310
      call copy_to_c_string(environment_names(index),name)
      call copy_to_c_string(environment_units(index),units)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
311
   end subroutine get_dependency_metadata
312

313 314 315 316 317 318 319
   subroutine get_coupling(index,slave,master) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_coupling
      integer(c_int),        intent(in), value :: index
      type (c_ptr),          intent(out)       :: slave,master

      type (type_link),pointer :: link_slave
      integer                  :: i
Knut's avatar
Knut committed
320

321 322 323 324 325 326
      link_slave => coupling_link_list%first
      do i=2,index
         link_slave => link_slave%next
      end do
      slave = c_loc(link_slave%original)
      master = c_loc(link_slave%target)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
327
   end subroutine get_coupling
328

Jorn Bruggeman's avatar
Jorn Bruggeman committed
329 330
   function variable_get_suitable_masters(pvariable) result(plist) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_suitable_masters
331 332
      type (c_ptr), intent(in), value :: pvariable
      type (c_ptr)                    :: plist
333

334
      type (type_internal_variable),pointer :: variable
335
      type (type_link_list),        pointer :: list
336 337 338 339

      call c_f_pointer(pvariable, variable)
      list => get_suitable_masters(model,variable)
      plist = c_loc(list)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
340
   end function variable_get_suitable_masters
341

342
   subroutine get_model_metadata(name,length,long_name,user_created) bind(c)
343
      !DIR$ ATTRIBUTES DLLEXPORT :: get_model_metadata
344 345 346
      character(kind=c_char),intent(in), target :: name(*)
      integer(c_int),        intent(in), value  :: length
      character(kind=c_char),intent(out)        :: long_name(length)
347
      integer(c_int),        intent(out)        :: user_created
348

349 350
      character(len=attribute_length),pointer   :: pname
      class (type_base_model),        pointer   :: found_model
351 352 353

      call c_f_pointer(c_loc(name), pname)
      found_model => model%root%find_model(pname(:index(pname,C_NULL_CHAR)-1))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
354 355
      if (.not.associated(found_model)) call driver%fatal_error('get_model_metadata', &
         'model "'//pname(:index(pname,C_NULL_CHAR)-1)//'" not found.')
356
      call copy_to_c_string(found_model%long_name,long_name)
357
      user_created = logical2int(found_model%user_created)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
358
   end subroutine get_model_metadata
359

360 361 362 363 364
   subroutine link_dependency_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_dependency_data
      integer(c_int),intent(in),value  :: index
      real(c_double),intent(in),target :: value

365
      call fabm_link_interior_data(model,environment_names(index),value)
366 367
      call fabm_link_horizontal_data(model,environment_names(index),value)
      call fabm_link_scalar_data(model,environment_names(index),value)
368
      if (index==index_column_depth) column_depth => value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
369
   end subroutine link_dependency_data
370

371 372
   subroutine link_interior_state_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_interior_state_data
373 374
      integer(c_int),intent(in),   value  :: index
      real(c_double),intent(inout),target :: value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
375

376
      value = model%state_variables(index)%initial_value
377 378
      call fabm_link_interior_state_data(model,index,value)
   end subroutine link_interior_state_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
379

380 381 382 383
   subroutine link_surface_state_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_surface_state_data
      integer(c_int),intent(in),   value  :: index
      real(c_double),intent(inout),target :: value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
384

385 386
      value = model%surface_state_variables(index)%initial_value
      call fabm_link_surface_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
387
   end subroutine link_surface_state_data
Knut's avatar
Knut committed
388

389 390 391 392 393 394 395
   subroutine link_bottom_state_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_bottom_state_data
      integer(c_int),intent(in),   value  :: index
      real(c_double),intent(inout),target :: value

      value = model%bottom_state_variables(index)%initial_value
      call fabm_link_bottom_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
396
   end subroutine link_bottom_state_data
397

398
   subroutine get_rates(pelagic_rates_, do_surface, do_bottom) bind(c)
399
      !DIR$ ATTRIBUTES DLLEXPORT :: get_rates
400
      real(c_double),target,intent(in) :: pelagic_rates_(*)
401
      integer(c_int),value, intent(in) :: do_surface, do_bottom
402 403

      real(c_double),pointer :: pelagic_rates(:)
404
      real(rk)               :: ext
405

406 407
      call fabm_get_light_extinction(model,ext)
      call fabm_get_light(model)
408 409
      call c_f_pointer(c_loc(pelagic_rates_),pelagic_rates, &
        (/size(model%state_variables)+size(model%surface_state_variables)+size(model%bottom_state_variables)/))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
410
      pelagic_rates = 0.0_rk
411
      if (int2logical(do_surface)) call fabm_do_surface(model,pelagic_rates(1:size(model%state_variables)), &
Jorn Bruggeman's avatar
Jorn Bruggeman committed
412
         pelagic_rates(size(model%state_variables)+1:size(model%state_variables)+size(model%surface_state_variables)))
413
      if (int2logical(do_bottom)) call fabm_do_bottom(model,pelagic_rates(1:size(model%state_variables)), &
414
         pelagic_rates(size(model%state_variables)+size(model%surface_state_variables)+1:))
415 416 417 418 419 420
      if (int2logical(do_surface) .or. int2logical(do_bottom)) then
         if (.not.associated(column_depth)) call driver%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.')
         pelagic_rates(1:size(model%state_variables)) = pelagic_rates(1:size(model%state_variables))/column_depth
      end if
421
      call fabm_do(model,pelagic_rates(1:size(model%state_variables)))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
422 423

      ! Compute rate of change in conserved quantities
424
      !call fabm_state_to_conserved_quantities(model,pelagic_rates,conserved_rates)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
425 426

      ! Normalize rate of change in conserved quantities to sum of absolute rates of change.
427 428
      !call fabm_state_to_conserved_quantities(model,abs(pelagic_rates),abs_conserved_rates)
      !where (abs_conserved_rates>0.0_rk) conserved_rates = conserved_rates/abs_conserved_rates
Jorn Bruggeman's avatar
Jorn Bruggeman committed
429
   end subroutine get_rates
430

431 432
   subroutine get_interior_diagnostic_data(index,ptr) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_interior_diagnostic_data
433 434
      integer(c_int),intent(in),value :: index
      type(c_ptr),   intent(out)      :: ptr
435 436
      ptr = c_loc(fabm_get_interior_diagnostic_data(model,index))
   end subroutine get_interior_diagnostic_data
437 438 439 440 441 442

   subroutine get_horizontal_diagnostic_data(index,ptr) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_horizontal_diagnostic_data
      integer(c_int),intent(in),value :: index
      type(c_ptr),   intent(out)      :: ptr
      ptr = c_loc(fabm_get_horizontal_diagnostic_data(model,index))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
443
   end subroutine get_horizontal_diagnostic_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
444

445
   subroutine finalize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
446 447 448
      call fabm_finalize(model)
      if (allocated(environment_names)) deallocate(environment_names)
      if (allocated(environment_units)) deallocate(environment_units)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
449
   end subroutine finalize
Jorn Bruggeman's avatar
Jorn Bruggeman committed
450

451
   subroutine reset_parameter(index) bind(c)
452
      !DIR$ ATTRIBUTES DLLEXPORT :: reset_parameter
453 454
      integer(c_int),value,intent(in) :: index
      class (type_property),pointer   :: property
455

456 457 458
      property => model%root%parameters%get_property(index)
      if (.not.associated(property)) return
      call forced_parameters%delete(property%name)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
459 460

      ! Re-initialize the model using updated parameter values
461
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
462
   end subroutine reset_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
463

464 465
   subroutine set_real_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_real_parameter
466 467
      character(kind=c_char),target,intent(in) :: name(*)
      real(c_double),value,         intent(in) :: value
468 469 470 471 472

      character(len=attribute_length),pointer :: pname

      call c_f_pointer(c_loc(name), pname)
      call forced_parameters%set_real(pname(:index(pname,C_NULL_CHAR)-1),value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
473 474

      ! Re-initialize the model using updated parameter values
475
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
476
   end subroutine set_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
477

478
   function get_real_parameter(index,default) bind(c) result(value)
479
      !DIR$ ATTRIBUTES DLLEXPORT :: get_real_parameter
480
      integer(c_int),value,intent(in) :: index,default
481
      real(c_double)                  :: value
482 483 484 485 486
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_real_property)
487
         if (int2logical(default)) then
488 489 490 491 492 493 494
            value = property%default
         else
            value = property%value
         end if
      class default
         call driver%fatal_error('get_real_parameter','not a real variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
495
   end function get_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
496

497 498
   subroutine set_integer_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_integer_parameter
499 500
      character(kind=c_char),target,intent(in) :: name(*)
      integer(c_int),value,         intent(in) :: value
501 502 503 504 505

      character(len=attribute_length),pointer :: pname

      call c_f_pointer(c_loc(name), pname)
      call forced_parameters%set_integer(pname(:index(pname,C_NULL_CHAR)-1),value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
506 507

      ! Re-initialize the model using updated parameter values
508
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
509
   end subroutine set_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
510

511
   function get_integer_parameter(index,default) bind(c) result(value)
512
      !DIR$ ATTRIBUTES DLLEXPORT :: get_integer_parameter
513
      integer(c_int),value,intent(in) :: index,default
514
      integer(c_int)                  :: value
515 516 517 518 519
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_integer_property)
520
         if (int2logical(default)) then
521 522 523 524 525 526 527
            value = property%default
         else
            value = property%value
         end if
      class default
         call driver%fatal_error('get_integer_parameter','not an integer variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
528
   end function get_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
529

530 531
   subroutine set_logical_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_logical_parameter
532
      character(kind=c_char),target,    intent(in) :: name(*)
533 534 535 536 537
      integer(c_int),value,intent(in) :: value

      character(len=attribute_length),pointer :: pname

      call c_f_pointer(c_loc(name), pname)
538
      call forced_parameters%set_logical(pname(:index(pname,C_NULL_CHAR)-1),int2logical(value))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
539 540

      ! Re-initialize the model using updated parameter values
541
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
542
   end subroutine set_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
543

544
   function get_logical_parameter(index,default) bind(c) result(value)
545
      !DIR$ ATTRIBUTES DLLEXPORT :: get_logical_parameter
546
      integer(c_int),value,intent(in) :: index,default
547
      integer(c_int)                  :: value
548 549 550 551 552
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_logical_property)
553 554
         if (int2logical(default)) then
            value = logical2int(property%default)
555
         else
556
            value = logical2int(property%value)
557 558 559 560
         end if
      class default
         call driver%fatal_error('get_logical_parameter','not a logical variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
561
   end function get_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
562

563 564 565 566 567
   subroutine set_string_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_string_parameter
      character(kind=c_char),target,intent(in) :: name(*),value(*)

      character(len=attribute_length),pointer :: pname,pvalue
Knut's avatar
Knut committed
568

569 570 571
      call c_f_pointer(c_loc(name),  pname)
      call c_f_pointer(c_loc(value), pvalue)
      call forced_parameters%set_string(pname(:index(pname,C_NULL_CHAR)-1),pvalue(:index(pname,C_NULL_CHAR)-1))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
572 573

      ! Re-initialize the model using updated parameter values
574
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
575
   end subroutine set_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
576

577 578 579 580 581
   subroutine get_string_parameter(index,default,length,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_string_parameter
      integer(c_int),value,intent(in) :: index,default,length
      character(kind=c_char)          :: value(length)

582 583 584 585 586
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_string_property)
587
         if (int2logical(default)) then
588
            call copy_to_c_string(property%default, value)
589
         else
590
            call copy_to_c_string(property%value, value)
591 592 593 594
         end if
      class default
         call driver%fatal_error('get_string_parameter','not a string variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
595
   end subroutine get_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
596

597
   subroutine python_driver_fatal_error(self,location,message)
598 599 600
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: location,message

601
      error_occurred = .true.
Jorn Bruggeman's avatar
Jorn Bruggeman committed
602
      !write (*,*) trim(location)//': '//trim(message)
603
      !stop 1
Jorn Bruggeman's avatar
Jorn Bruggeman committed
604
   end subroutine python_driver_fatal_error
605

606
   subroutine python_driver_log_message(self,message)
607 608 609 610
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: message

      !write (*,*) trim(message)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
611
   end subroutine python_driver_log_message
612

Jorn Bruggeman's avatar
Jorn Bruggeman committed
613 614 615
   end module fabm_python

!-----------------------------------------------------------------------
616
! Copyright Bolding & Bruggeman ApS - Public License - www.gnu.org
Jorn Bruggeman's avatar
Jorn Bruggeman committed
617
!-----------------------------------------------------------------------