python_fabm.F90 24.3 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
Jorn Bruggeman's avatar
Jorn Bruggeman committed
44

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

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

   contains

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

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

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

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

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

114 115 116 117 118 119 120 121
      ! 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
122 123 124
      ! Send information on spatial domain to FABM (this also allocates memory for diagnostics)
      call fabm_set_domain(model)

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

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

133 134 135 136 137 138
   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
139
      ! Create new model object.
140 141 142 143
      allocate(newmodel)

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

      ! Re-create original models
      node => model%root%children%first
      do while (associated(node))
149
         if (node%model%user_created) then
150
            call factory%create(node%model%type_name,childmodel)
151
            childmodel%user_created = .true.
152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
            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))
167
         if (.not. model%root%parameters%retrieved%contains(property%name)) then
168 169 170 171 172 173 174 175 176 177 178 179
            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.
180 181
      call get_environment_metadata(model,environment_names,environment_units,index_column_depth)
      column_depth => null()
182 183

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

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

191
   integer(c_int) function model_count() bind(c)
192 193 194 195 196 197 198 199 200
      !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
201
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
202
   end function model_count
203

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

221
   subroutine get_variable_metadata(category,index,length,name,units,long_name,path) bind(c)
222
      !DIR$ ATTRIBUTES DLLEXPORT :: get_variable_metadata
223
      integer(c_int),        intent(in), value             :: category,index,length
224
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name,path
225 226 227 228 229

      class (type_external_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
230
      case (INTERIOR_STATE_VARIABLE)
231 232 233 234 235
         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)
236
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
237 238 239 240 241 242
         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
243 244 245 246
      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
247
   end subroutine get_variable_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
248

Jorn Bruggeman's avatar
Jorn Bruggeman committed
249 250 251 252
   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
253 254 255 256 257

      type (type_internal_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
258
      case (INTERIOR_STATE_VARIABLE)
259 260 261 262 263
         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
264
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
265 266 267 268 269 270 271
         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
272
   end function get_variable
273

274
   subroutine get_parameter_metadata(index,length,name,units,long_name,typecode,has_default) bind(c)
275
      !DIR$ ATTRIBUTES DLLEXPORT :: get_parameter_metadata
276
      integer(c_int),        intent(in), value             :: index,length
277
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name
278
      integer(c_int),        intent(out)                   :: typecode,has_default
279 280 281 282 283 284 285 286 287 288

      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
289 290
      end do

291 292 293 294
      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()
295
      has_default = logical2int(property%has_default)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
296
   end subroutine get_parameter_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
297

298 299
   subroutine get_dependency_metadata(index,length,name,units) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_dependency_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
300
      integer(c_int),        intent(in), value             :: index,length
301
      character(kind=c_char),intent(out),dimension(length) :: name,units
Jorn Bruggeman's avatar
Jorn Bruggeman committed
302

303 304
      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
305
   end subroutine get_dependency_metadata
306

307 308 309 310 311 312 313
   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
314

315 316 317 318 319 320
      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
321
   end subroutine get_coupling
322

Jorn Bruggeman's avatar
Jorn Bruggeman committed
323 324
   function variable_get_suitable_masters(pvariable) result(plist) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_suitable_masters
325 326
      type (c_ptr), intent(in), value :: pvariable
      type (c_ptr)                    :: plist
327

328
      type (type_internal_variable),pointer :: variable
329
      type (type_link_list),        pointer :: list
330 331 332 333

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

336
   subroutine get_model_metadata(name,length,long_name,user_created) bind(c)
337
      !DIR$ ATTRIBUTES DLLEXPORT :: get_model_metadata
338 339 340
      character(kind=c_char),intent(in), target :: name(*)
      integer(c_int),        intent(in), value  :: length
      character(kind=c_char),intent(out)        :: long_name(length)
341
      integer(c_int),        intent(out)        :: user_created
342

343 344
      character(len=attribute_length),pointer   :: pname
      class (type_base_model),        pointer   :: found_model
345 346 347

      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
348 349
      if (.not.associated(found_model)) call driver%fatal_error('get_model_metadata', &
         'model "'//pname(:index(pname,C_NULL_CHAR)-1)//'" not found.')
350
      call copy_to_c_string(found_model%long_name,long_name)
351
      user_created = logical2int(found_model%user_created)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
352
   end subroutine get_model_metadata
353

354 355 356 357 358
   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

359
      call fabm_link_interior_data(model,environment_names(index),value)
360 361
      call fabm_link_horizontal_data(model,environment_names(index),value)
      call fabm_link_scalar_data(model,environment_names(index),value)
362
      if (index==index_column_depth) column_depth => value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
363
   end subroutine link_dependency_data
364

365 366
   subroutine link_interior_state_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_interior_state_data
367 368
      integer(c_int),intent(in),   value  :: index
      real(c_double),intent(inout),target :: value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
369

370
      value = model%state_variables(index)%initial_value
371 372
      call fabm_link_interior_state_data(model,index,value)
   end subroutine link_interior_state_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
373

374 375 376 377
   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
378

379 380
      value = model%surface_state_variables(index)%initial_value
      call fabm_link_surface_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
381
   end subroutine link_surface_state_data
Knut's avatar
Knut committed
382

383 384 385 386 387 388 389
   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
390
   end subroutine link_bottom_state_data
391

392
   subroutine get_rates(pelagic_rates_, do_surface, do_bottom) bind(c)
393
      !DIR$ ATTRIBUTES DLLEXPORT :: get_rates
394
      real(c_double),target,intent(in) :: pelagic_rates_(*)
395
      integer(c_int),value, intent(in) :: do_surface, do_bottom
396 397

      real(c_double),pointer :: pelagic_rates(:)
398
      real(rk)               :: ext
399

400 401
      call fabm_get_light_extinction(model,ext)
      call fabm_get_light(model)
402 403
      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
404
      pelagic_rates = 0.0_rk
405
      if (int2logical(do_surface)) call fabm_do_surface(model,pelagic_rates(1:size(model%state_variables)), &
Jorn Bruggeman's avatar
Jorn Bruggeman committed
406
         pelagic_rates(size(model%state_variables)+1:size(model%state_variables)+size(model%surface_state_variables)))
407
      if (int2logical(do_bottom)) call fabm_do_bottom(model,pelagic_rates(1:size(model%state_variables)), &
408
         pelagic_rates(size(model%state_variables)+size(model%surface_state_variables)+1:))
409 410 411 412 413 414
      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
415
      call fabm_do(model,pelagic_rates(1:size(model%state_variables)))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
416 417

      ! Compute rate of change in conserved quantities
418
      !call fabm_state_to_conserved_quantities(model,pelagic_rates,conserved_rates)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
419 420

      ! Normalize rate of change in conserved quantities to sum of absolute rates of change.
421 422
      !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
423
   end subroutine get_rates
424

425 426
   subroutine get_interior_diagnostic_data(index,ptr) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_interior_diagnostic_data
427 428
      integer(c_int),intent(in),value :: index
      type(c_ptr),   intent(out)      :: ptr
429 430
      ptr = c_loc(fabm_get_interior_diagnostic_data(model,index))
   end subroutine get_interior_diagnostic_data
431 432 433 434 435 436

   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
437
   end subroutine get_horizontal_diagnostic_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
438

439
   subroutine finalize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
440 441 442
      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
443
   end subroutine finalize
Jorn Bruggeman's avatar
Jorn Bruggeman committed
444

445
   subroutine reset_parameter(index) bind(c)
446
      !DIR$ ATTRIBUTES DLLEXPORT :: reset_parameter
447 448
      integer(c_int),value,intent(in) :: index
      class (type_property),pointer   :: property
449

450 451 452
      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
453 454

      ! Re-initialize the model using updated parameter values
455
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
456
   end subroutine reset_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
457

458 459
   subroutine set_real_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_real_parameter
460 461
      character(kind=c_char),target,intent(in) :: name(*)
      real(c_double),value,         intent(in) :: value
462 463 464 465 466

      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
467 468

      ! Re-initialize the model using updated parameter values
469
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
470
   end subroutine set_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
471

472
   function get_real_parameter(index,default) bind(c) result(value)
473
      !DIR$ ATTRIBUTES DLLEXPORT :: get_real_parameter
474
      integer(c_int),value,intent(in) :: index,default
475
      real(c_double)                  :: value
476 477 478 479 480
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_real_property)
481
         if (int2logical(default)) then
482 483 484 485 486 487 488
            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
489
   end function get_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
490

491 492
   subroutine set_integer_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_integer_parameter
493 494
      character(kind=c_char),target,intent(in) :: name(*)
      integer(c_int),value,         intent(in) :: value
495 496 497 498 499

      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
500 501

      ! Re-initialize the model using updated parameter values
502
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
503
   end subroutine set_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
504

505
   function get_integer_parameter(index,default) bind(c) result(value)
506
      !DIR$ ATTRIBUTES DLLEXPORT :: get_integer_parameter
507
      integer(c_int),value,intent(in) :: index,default
508
      integer(c_int)                  :: value
509 510 511 512 513
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_integer_property)
514
         if (int2logical(default)) then
515 516 517 518 519 520 521
            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
522
   end function get_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
523

524 525
   subroutine set_logical_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_logical_parameter
526
      character(kind=c_char),target,    intent(in) :: name(*)
527 528 529 530 531
      integer(c_int),value,intent(in) :: value

      character(len=attribute_length),pointer :: pname

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

      ! Re-initialize the model using updated parameter values
535
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
536
   end subroutine set_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
537

538
   function get_logical_parameter(index,default) bind(c) result(value)
539
      !DIR$ ATTRIBUTES DLLEXPORT :: get_logical_parameter
540
      integer(c_int),value,intent(in) :: index,default
541
      integer(c_int)                  :: value
542 543 544 545 546
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_logical_property)
547 548
         if (int2logical(default)) then
            value = logical2int(property%default)
549
         else
550
            value = logical2int(property%value)
551 552 553 554
         end if
      class default
         call driver%fatal_error('get_logical_parameter','not a logical variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
555
   end function get_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
556

557 558 559 560 561
   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
562

563 564 565
      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
566 567

      ! Re-initialize the model using updated parameter values
568
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
569
   end subroutine set_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
570

571 572 573 574 575
   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)

576 577 578 579 580
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_string_property)
581
         if (int2logical(default)) then
582
            call copy_to_c_string(property%default, value)
583
         else
584
            call copy_to_c_string(property%value, value)
585 586 587 588
         end if
      class default
         call driver%fatal_error('get_string_parameter','not a string variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
589
   end subroutine get_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
590

591
   subroutine python_driver_fatal_error(self,location,message)
592 593 594 595 596
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: location,message

      write (*,*) trim(location)//': '//trim(message)
      stop 1
Jorn Bruggeman's avatar
Jorn Bruggeman committed
597
   end subroutine python_driver_fatal_error
598

599
   subroutine python_driver_log_message(self,message)
600 601 602 603
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: message

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

Jorn Bruggeman's avatar
Jorn Bruggeman committed
606 607 608
   end module fabm_python

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