python_fabm.F90 28 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 65 66 67
      character(len=length-1) :: string

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

204
   integer(c_int) function model_count() bind(c)
205 206 207 208 209 210 211 212 213
      !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
214
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
215
   end function model_count
216

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

234
   subroutine get_variable_metadata(category,index,length,name,units,long_name,path) bind(c)
235
      !DIR$ ATTRIBUTES DLLEXPORT :: get_variable_metadata
236
      integer(c_int),        intent(in), value             :: category,index,length
237
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name,path
238 239 240 241 242

      class (type_external_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
243
      case (INTERIOR_STATE_VARIABLE)
244 245 246 247 248
         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)
249
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
250 251 252 253 254 255
         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
256 257 258 259
      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
260
   end subroutine get_variable_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
261

Jorn Bruggeman's avatar
Jorn Bruggeman committed
262 263 264 265
   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
266 267 268 269 270

      type (type_internal_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
271
      case (INTERIOR_STATE_VARIABLE)
272 273 274 275 276
         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
277
      case (INTERIOR_DIAGNOSTIC_VARIABLE)
278 279 280 281 282 283 284
         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
285
   end function get_variable
286

287
   subroutine get_parameter_metadata(index,length,name,units,long_name,typecode,has_default) bind(c)
288
      !DIR$ ATTRIBUTES DLLEXPORT :: get_parameter_metadata
289
      integer(c_int),        intent(in), value             :: index,length
290
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name
291
      integer(c_int),        intent(out)                   :: typecode,has_default
292 293 294 295 296 297 298 299 300 301

      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
302 303
      end do

304 305 306 307
      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()
308
      has_default = logical2int(property%has_default)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
309
   end subroutine get_parameter_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
310

311 312
   subroutine get_dependency_metadata(index,length,name,units) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_dependency_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
313
      integer(c_int),        intent(in), value             :: index,length
314
      character(kind=c_char),intent(out),dimension(length) :: name,units
Jorn Bruggeman's avatar
Jorn Bruggeman committed
315

316 317
      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
318
   end subroutine get_dependency_metadata
319

320 321 322 323 324 325 326
   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
327

328 329 330 331 332 333
      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
334
   end subroutine get_coupling
335

Jorn Bruggeman's avatar
Jorn Bruggeman committed
336 337
   function variable_get_suitable_masters(pvariable) result(plist) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_suitable_masters
338 339
      type (c_ptr), intent(in), value :: pvariable
      type (c_ptr)                    :: plist
340

341
      type (type_internal_variable),pointer :: variable
342
      type (type_link_list),        pointer :: list
343 344 345 346

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

349
   subroutine get_model_metadata(name,length,long_name,user_created) bind(c)
350
      !DIR$ ATTRIBUTES DLLEXPORT :: get_model_metadata
351 352 353
      character(kind=c_char),intent(in), target :: name(*)
      integer(c_int),        intent(in), value  :: length
      character(kind=c_char),intent(out)        :: long_name(length)
354
      integer(c_int),        intent(out)        :: user_created
355

356 357
      character(len=attribute_length),pointer   :: pname
      class (type_base_model),        pointer   :: found_model
358 359 360

      call c_f_pointer(c_loc(name), pname)
      found_model => model%root%find_model(pname(:index(pname,C_NULL_CHAR)-1))
361
      if (.not.associated(found_model)) call fatal_error('get_model_metadata', &
Jorn Bruggeman's avatar
Jorn Bruggeman committed
362
         'model "'//pname(:index(pname,C_NULL_CHAR)-1)//'" not found.')
363
      call copy_to_c_string(found_model%long_name,long_name)
364
      user_created = logical2int(found_model%user_created)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
365
   end subroutine get_model_metadata
366

367 368 369 370 371
   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

372
      call fabm_link_interior_data(model,environment_names(index),value)
373 374
      call fabm_link_horizontal_data(model,environment_names(index),value)
      call fabm_link_scalar_data(model,environment_names(index),value)
375
      if (index==index_column_depth) column_depth => value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
376
   end subroutine link_dependency_data
377

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

383
      value = model%state_variables(index)%initial_value
384 385
      call fabm_link_interior_state_data(model,index,value)
   end subroutine link_interior_state_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
386

387 388 389 390
   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
391

392 393
      value = model%surface_state_variables(index)%initial_value
      call fabm_link_surface_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
394
   end subroutine link_surface_state_data
Knut's avatar
Knut committed
395

396 397 398 399 400 401 402
   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
403
   end subroutine link_bottom_state_data
404

405
   subroutine get_rates(rates_, do_surface, do_bottom) bind(c)
406
      !DIR$ ATTRIBUTES DLLEXPORT :: get_rates
407
      real(c_double),target,intent(in) :: rates_(*)
408
      integer(c_int),value, intent(in) :: do_surface, do_bottom
409

410
      real(c_double),pointer :: rates(:)
411
      real(rk)               :: ext
412

413
      call c_f_pointer(c_loc(rates_),rates, &
414
        (/size(model%state_variables)+size(model%surface_state_variables)+size(model%bottom_state_variables)/))
415 416 417 418 419 420 421 422 423

      call fabm_get_light_extinction(model, ext)
      call fabm_get_light(model)

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

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

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

440 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
   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)) &
470
          call fatal_error('integrate', 'ny is wrong length')
471 472 473 474 475 476 477 478

      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
479
          if (.not.associated(column_depth)) call fatal_error('get_rates', &
480 481 482 483
            '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
484 485 486
      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:))
487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510

      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

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

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

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

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

536 537 538
      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
539 540

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

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

      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
553 554

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

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

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

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

      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
586 587

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

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

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

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

      character(len=attribute_length),pointer :: pname

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

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

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

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

643 644 645 646 647
   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
648

649 650 651
      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
652 653

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

657 658 659 660 661
   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)

662 663 664 665 666
      class (type_property),pointer   :: property

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

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

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

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

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

Jorn Bruggeman's avatar
Jorn Bruggeman committed
693 694 695
   end module fabm_python

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