python_fabm.F90 28.1 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, fatal_error
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.
45
   character(len=:), allocatable, save :: error_message
Jorn Bruggeman's avatar
Jorn Bruggeman committed
46

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

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

   contains

59 60 61 62 63
   subroutine get_version(length,version_string) bind(c)
!DIR$ ATTRIBUTES DLLEXPORT :: get_version
      integer(c_int),value,intent(in) :: length
      character(kind=c_char)          :: version_string(length)

64
      character(len=length-1) :: string
65

66 67
      call fabm_get_version(string)
      call copy_to_c_string(string, version_string)
68 69
   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
      ! Send information on spatial domain to FABM (this also allocates memory for diagnostics)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
124
      call fabm_set_domain(model, 1._rk)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
125

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
            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)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
178
      call fabm_set_domain(model, 1._rk)
179 180

      ! 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

Jorn Bruggeman's avatar
Jorn Bruggeman committed
192 193 194 195 196 197
   subroutine update_time(nsec) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: update_time
      real(rk), value, intent(in) :: nsec
      call fabm_update_time(model, nsec)
   end subroutine update_time

198 199 200 201 202
   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

203 204 205 206 207 208 209
   subroutine get_error(length, message) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_error
      integer(c_int),        intent(in), value             :: length
      character(kind=c_char),intent(out),dimension(length) :: message
      call copy_to_c_string(error_message, message)
   end subroutine get_error

210
   integer(c_int) function model_count() bind(c)
211 212 213 214 215 216 217 218 219
      !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
220
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
221
   end function model_count
222

223
   subroutine get_counts(nstate_interior,nstate_surface,nstate_bottom,ndiagnostic_interior,ndiagnostic_horizontal,nconserved, &
224
      ndependencies,nparameters,ncouplings) bind(c)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
225
      !DIR$ ATTRIBUTES DLLEXPORT :: get_counts
226 227
      integer(c_int),intent(out) :: nstate_interior,nstate_surface,nstate_bottom
      integer(c_int),intent(out) :: ndiagnostic_interior,ndiagnostic_horizontal
228
      integer(c_int),intent(out) :: nconserved,ndependencies,nparameters,ncouplings
229
      nstate_interior = size(model%state_variables)
230 231
      nstate_surface = size(model%surface_state_variables)
      nstate_bottom = size(model%bottom_state_variables)
232
      ndiagnostic_interior = size(model%diagnostic_variables)
233 234 235 236
      ndiagnostic_horizontal = size(model%horizontal_diagnostic_variables)
      nconserved = size(model%conserved_quantities)
      ndependencies = size(environment_names)
      nparameters = model%root%parameters%size()
237
      ncouplings = coupling_link_list%count()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
238
   end subroutine get_counts
239

240
   subroutine get_variable_metadata(category,index,length,name,units,long_name,path) bind(c)
241
      !DIR$ ATTRIBUTES DLLEXPORT :: get_variable_metadata
242
      integer(c_int),        intent(in), value             :: category,index,length
243
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name,path
244 245 246 247 248

      class (type_external_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
249
      case (INTERIOR_STATE_VARIABLE)
250 251 252 253 254
         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)
255
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
256 257 258 259 260 261
         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
262 263 264 265
      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
266
   end subroutine get_variable_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
267

Jorn Bruggeman's avatar
Jorn Bruggeman committed
268 269 270 271
   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
272 273 274 275 276

      type (type_internal_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
277
      case (INTERIOR_STATE_VARIABLE)
278 279 280 281 282
         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
283
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
284 285 286 287 288 289 290
         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
291
   end function get_variable
292

293
   subroutine get_parameter_metadata(index,length,name,units,long_name,typecode,has_default) bind(c)
294
      !DIR$ ATTRIBUTES DLLEXPORT :: get_parameter_metadata
295
      integer(c_int),        intent(in), value             :: index,length
296
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name
297
      integer(c_int),        intent(out)                   :: typecode,has_default
298 299 300 301 302 303 304 305 306 307

      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
308 309
      end do

310 311 312 313
      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()
314
      has_default = logical2int(property%has_default)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
315
   end subroutine get_parameter_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
316

317 318
   subroutine get_dependency_metadata(index,length,name,units) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_dependency_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
319
      integer(c_int),        intent(in), value             :: index,length
320
      character(kind=c_char),intent(out),dimension(length) :: name,units
Jorn Bruggeman's avatar
Jorn Bruggeman committed
321

322 323
      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
324
   end subroutine get_dependency_metadata
325

326 327 328 329 330 331 332
   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
333

334 335 336 337 338 339
      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
340
   end subroutine get_coupling
341

Jorn Bruggeman's avatar
Jorn Bruggeman committed
342 343
   function variable_get_suitable_masters(pvariable) result(plist) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_suitable_masters
344 345
      type (c_ptr), intent(in), value :: pvariable
      type (c_ptr)                    :: plist
346

347
      type (type_internal_variable),pointer :: variable
348
      type (type_link_list),        pointer :: list
349 350 351 352

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

355
   subroutine get_model_metadata(name,length,long_name,user_created) bind(c)
356
      !DIR$ ATTRIBUTES DLLEXPORT :: get_model_metadata
357 358 359
      character(kind=c_char),intent(in), target :: name(*)
      integer(c_int),        intent(in), value  :: length
      character(kind=c_char),intent(out)        :: long_name(length)
360
      integer(c_int),        intent(out)        :: user_created
361

362 363
      character(len=attribute_length),pointer   :: pname
      class (type_base_model),        pointer   :: found_model
364 365 366

      call c_f_pointer(c_loc(name), pname)
      found_model => model%root%find_model(pname(:index(pname,C_NULL_CHAR)-1))
367
      if (.not.associated(found_model)) call fatal_error('get_model_metadata', &
Jorn Bruggeman's avatar
Jorn Bruggeman committed
368
         'model "'//pname(:index(pname,C_NULL_CHAR)-1)//'" not found.')
369
      call copy_to_c_string(found_model%long_name,long_name)
370
      user_created = logical2int(found_model%user_created)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
371
   end subroutine get_model_metadata
372

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

378
      call fabm_link_interior_data(model,environment_names(index),value)
379 380
      call fabm_link_horizontal_data(model,environment_names(index),value)
      call fabm_link_scalar_data(model,environment_names(index),value)
381
      if (index==index_column_depth) column_depth => value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
382
   end subroutine link_dependency_data
383

384 385
   subroutine link_interior_state_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_interior_state_data
386 387
      integer(c_int),intent(in),   value  :: index
      real(c_double),intent(inout),target :: value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
388

389
      value = model%state_variables(index)%initial_value
390 391
      call fabm_link_interior_state_data(model,index,value)
   end subroutine link_interior_state_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
392

393 394 395 396
   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
397

398 399
      value = model%surface_state_variables(index)%initial_value
      call fabm_link_surface_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
400
   end subroutine link_surface_state_data
Knut's avatar
Knut committed
401

402 403 404 405 406 407 408
   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
409
   end subroutine link_bottom_state_data
410

411
   subroutine get_rates(rates_, do_surface, do_bottom) bind(c)
412
      !DIR$ ATTRIBUTES DLLEXPORT :: get_rates
413
      real(c_double),target,intent(in) :: rates_(*)
414
      integer(c_int),value, intent(in) :: do_surface, do_bottom
415

416
      real(c_double),pointer :: rates(:)
417

418
      call c_f_pointer(c_loc(rates_),rates, &
419
        (/size(model%state_variables)+size(model%surface_state_variables)+size(model%bottom_state_variables)/))
420 421 422 423 424 425

      rates = 0.0_rk
      if (int2logical(do_surface)) call fabm_do_surface(model, rates(1:size(model%state_variables)), &
         rates(size(model%state_variables)+1:size(model%state_variables)+size(model%surface_state_variables)))
      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:))
426
      if (int2logical(do_surface) .or. int2logical(do_bottom)) then
427
         if (.not.associated(column_depth)) call fatal_error('get_rates', &
428 429
            '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.')
430
         rates(1:size(model%state_variables)) = rates(1:size(model%state_variables))/column_depth
431
      end if
432
      call fabm_do(model, rates(1:size(model%state_variables)))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
433 434

      ! Compute rate of change in conserved quantities
435
      !call fabm_state_to_conserved_quantities(model,pelagic_rates,conserved_rates)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
436 437

      ! Normalize rate of change in conserved quantities to sum of absolute rates of change.
438 439
      !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
440
   end subroutine get_rates
441

442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
   function check_state(repair_) bind(c) result(valid_)
      !DIR$ ATTRIBUTES DLLEXPORT :: check_state
      integer(c_int),value, intent(in) :: repair_
      integer(c_int)                   :: valid_

      logical :: repair, interior_valid, surface_valid, bottom_valid

      repair = int2logical(repair_)
      call fabm_check_state(model, repair, interior_valid)
      call fabm_check_surface_state(model, repair, surface_valid)
      call fabm_check_bottom_state(model, repair, bottom_valid)
      valid_ = logical2int(interior_valid .and. surface_valid .and. bottom_valid)
   end function check_state

   subroutine integrate(nt, ny, t_, y_ini_, y_, dt, do_surface, do_bottom) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: integrate
      integer(c_int),value, intent(in) :: nt, ny
      real(c_double),target,intent(in) :: t_(*), y_ini_(*), y_(*)
      real(c_double),value, intent(in) :: dt
      integer(c_int),value, intent(in) :: do_surface, do_bottom

      real(c_double),pointer :: t(:), y_ini(:), y(:,:)
      integer                :: it
      real(rk)               :: t_cur
      real(rk), target       :: y_cur(ny)
      real(rk)               :: rates(ny)
      real(rk)               :: ext
      logical                :: surface, bottom

      if (ny /= size(model%state_variables)+size(model%surface_state_variables)+size(model%bottom_state_variables)) &
472
          call fatal_error('integrate', 'ny is wrong length')
473 474 475 476 477 478 479 480

      call c_f_pointer(c_loc(t_), t, (/nt/))
      call c_f_pointer(c_loc(y_ini_), y_ini, (/ny/))
      call c_f_pointer(c_loc(y_), y, (/ny, nt/))

      surface = int2logical(do_surface)
      bottom = int2logical(do_bottom)
      if (surface .or. bottom) then
481
          if (.not.associated(column_depth)) call fatal_error('get_rates', &
482 483 484 485
            '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
      call model%link_all_interior_state_data(y_cur(1:size(model%state_variables)))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
486 487 488
      call model%link_all_surface_state_data(y_cur(size(model%state_variables) + 1: &
         size(model%state_variables) + size(model%surface_state_variables)))
      call model%link_all_bottom_state_data(y_cur(size(model%state_variables) + size(model%surface_state_variables) + 1:))
489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512

      it = 1
      t_cur = t(1)
      y_cur = y_ini
      do while (it <= nt)
          if (t_cur >= t(it)) then
              y(:, it) = y_cur
              it = it + 1
          end if

          call fabm_get_light_extinction(model, ext)
          call fabm_get_light(model)
          rates = 0.0_rk
          if (surface) call fabm_do_surface(model, rates(1:size(model%state_variables)), &
             rates(size(model%state_variables)+1:size(model%state_variables)+size(model%surface_state_variables)))
          if (bottom) call fabm_do_bottom(model, rates(1:size(model%state_variables)), &
             rates(size(model%state_variables)+size(model%surface_state_variables)+1:))
          if (surface .or. bottom) rates(1:size(model%state_variables)) = rates(1:size(model%state_variables))/column_depth
          call fabm_do(model, rates(1:size(model%state_variables)))
          y_cur = y_cur + dt*rates*86400
          t_cur = t_cur + dt
      end do
   end subroutine integrate

513 514
   subroutine get_interior_diagnostic_data(index,ptr) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_interior_diagnostic_data
515 516
      integer(c_int),intent(in),value :: index
      type(c_ptr),   intent(out)      :: ptr
517 518
      ptr = c_loc(fabm_get_interior_diagnostic_data(model,index))
   end subroutine get_interior_diagnostic_data
519 520 521 522 523 524

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

527
   subroutine finalize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
528 529 530
      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
531
   end subroutine finalize
Jorn Bruggeman's avatar
Jorn Bruggeman committed
532

533
   subroutine reset_parameter(index) bind(c)
534
      !DIR$ ATTRIBUTES DLLEXPORT :: reset_parameter
535 536
      integer(c_int),value,intent(in) :: index
      class (type_property),pointer   :: property
537

538 539 540
      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
541 542

      ! Re-initialize the model using updated parameter values
543
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
544
   end subroutine reset_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
545

546 547
   subroutine set_real_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_real_parameter
548 549
      character(kind=c_char),target,intent(in) :: name(*)
      real(c_double),value,         intent(in) :: value
550 551 552 553 554

      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
555 556

      ! Re-initialize the model using updated parameter values
557
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
558
   end subroutine set_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
559

560
   function get_real_parameter(index,default) bind(c) result(value)
561
      !DIR$ ATTRIBUTES DLLEXPORT :: get_real_parameter
562
      integer(c_int),value,intent(in) :: index,default
563
      real(c_double)                  :: value
564 565 566 567 568
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_real_property)
569
         if (int2logical(default)) then
570 571 572 573 574
            value = property%default
         else
            value = property%value
         end if
      class default
575
         call fatal_error('get_real_parameter','not a real variable')
576
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
577
   end function get_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
578

579 580
   subroutine set_integer_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_integer_parameter
581 582
      character(kind=c_char),target,intent(in) :: name(*)
      integer(c_int),value,         intent(in) :: value
583 584 585 586 587

      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
588 589

      ! Re-initialize the model using updated parameter values
590
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
591
   end subroutine set_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
592

593
   function get_integer_parameter(index,default) bind(c) result(value)
594
      !DIR$ ATTRIBUTES DLLEXPORT :: get_integer_parameter
595
      integer(c_int),value,intent(in) :: index,default
596
      integer(c_int)                  :: value
597 598 599 600 601
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_integer_property)
602
         if (int2logical(default)) then
603 604 605 606 607
            value = property%default
         else
            value = property%value
         end if
      class default
608
         call fatal_error('get_integer_parameter','not an integer variable')
609
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
610
   end function get_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
611

612 613
   subroutine set_logical_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_logical_parameter
614
      character(kind=c_char),target,    intent(in) :: name(*)
615 616 617 618 619
      integer(c_int),value,intent(in) :: value

      character(len=attribute_length),pointer :: pname

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

      ! Re-initialize the model using updated parameter values
623
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
624
   end subroutine set_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
625

626
   function get_logical_parameter(index,default) bind(c) result(value)
627
      !DIR$ ATTRIBUTES DLLEXPORT :: get_logical_parameter
628
      integer(c_int),value,intent(in) :: index,default
629
      integer(c_int)                  :: value
630 631 632 633 634
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_logical_property)
635 636
         if (int2logical(default)) then
            value = logical2int(property%default)
637
         else
638
            value = logical2int(property%value)
639 640
         end if
      class default
641
         call fatal_error('get_logical_parameter','not a logical variable')
642
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
643
   end function get_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
644

645 646 647 648 649
   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
650

651 652 653
      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
654 655

      ! Re-initialize the model using updated parameter values
656
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
657
   end subroutine set_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
658

659 660 661 662 663
   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)

664 665 666 667 668
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_string_property)
669
         if (int2logical(default)) then
670
            call copy_to_c_string(property%default, value)
671
         else
672
            call copy_to_c_string(property%value, value)
673 674
         end if
      class default
675
         call fatal_error('get_string_parameter','not a string variable')
676
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
677
   end subroutine get_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
678

679
   subroutine python_driver_fatal_error(self,location,message)
680 681 682
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: location,message

683
      if (error_occurred) return
684
      error_occurred = .true.
685
      error_message = trim(location) // ': ' // trim(message)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
686
   end subroutine python_driver_fatal_error
687

688
   subroutine python_driver_log_message(self,message)
689 690 691 692
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: message

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

Jorn Bruggeman's avatar
Jorn Bruggeman committed
695 696 697
   end module fabm_python

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