python_fabm.F90 26.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
23
   use fabm_properties
Jorn Bruggeman's avatar
Jorn Bruggeman committed
24 25 26 27 28 29 30
   use fabm_python_helper

   implicit none
!
! !PUBLIC MEMBER FUNCTIONS:
   public

31 32 33 34 35 36 37
   integer,parameter :: BULK_STATE_VARIABLE            = 1
   integer,parameter :: SURFACE_STATE_VARIABLE         = 2
   integer,parameter :: BOTTOM_STATE_VARIABLE          = 3
   integer,parameter :: BULK_DIAGNOSTIC_VARIABLE       = 4
   integer,parameter :: HORIZONTAL_DIAGNOSTIC_VARIABLE = 5
   integer,parameter :: CONSERVED_QUANTITY             = 6

38
   class (type_model),private,pointer,save :: model => null()
39
   real(8),dimension(:),pointer :: state
Jorn Bruggeman's avatar
Jorn Bruggeman committed
40
   character(len=1024),dimension(:),allocatable :: environment_names,environment_units
41
   type (type_link_list),save :: coupling_link_list
Jorn Bruggeman's avatar
Jorn Bruggeman committed
42

43
   type (type_property_dictionary),save,private :: forced_parameters,forced_couplings
44 45 46

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

   contains

!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Initialise the model
!
! !INTERFACE:
61
   subroutine initialize(path) bind(c)
62
!DIR$ ATTRIBUTES DLLEXPORT :: initialize
63
      character(kind=c_char),target,intent(in) :: path(*)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
64 65 66 67 68 69 70 71
!
! !DESCRIPTION:
!
! !REVISION HISTORY:
!  Original author(s): Jorn Bruggeman
!
!EOP
!
72
      character(len=attribute_length),pointer :: ppath
73
      class (type_property),          pointer :: property
Jorn Bruggeman's avatar
Jorn Bruggeman committed
74 75
!-----------------------------------------------------------------------
!BOC
76 77
      call c_f_pointer(c_loc(path), ppath)

78
      if (associated(model)) call finalize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
79

80 81
      if (.not.associated(driver)) allocate(type_python_driver::driver)

Jorn Bruggeman's avatar
Jorn Bruggeman committed
82
      ! Build FABM model tree (configuration will be read from fabm.yaml).
83 84 85
      allocate(model)
      call fabm_create_model_from_yaml_file(model,path=ppath(:index(ppath,C_NULL_CHAR)-1),parameters=forced_parameters)

86
      ! Get a list of all parameters that had an explicit value specified.
87 88
      property => model%root%parameters%first
      do while (associated(property))
89
         if (.not.model%root%parameters%missing%contains(property%name)) &
90 91 92
            call forced_parameters%set_property(property)
         property => property%next
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
93

94 95 96 97 98 99 100 101
      ! 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
102 103 104
      ! Send information on spatial domain to FABM (this also allocates memory for diagnostics)
      call fabm_set_domain(model)

105 106 107
      ! Retrieve arrays to hold values for environmental variables and corresponding metadata.
      call get_environment_metadata(model,environment_names,environment_units)

108
      call get_couplings(model,coupling_link_list)
109 110 111
   end subroutine initialize
!EOC

112 113 114 115 116 117 118 119 120 121
   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

      allocate(newmodel)

      ! Transfer forced parameters to root of the model.
      call newmodel%root%parameters%update(forced_parameters)
122
      call newmodel%root%couplings%update(forced_couplings)
123 124 125 126

      ! Re-create original models
      node => model%root%children%first
      do while (associated(node))
127
         if (node%model%user_created) then
128
            call factory%create(node%model%type_name,childmodel)
129
            childmodel%user_created = .true.
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
            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))
145
         if (.not. model%root%parameters%retrieved%contains(property%name)) then
146 147 148 149 150 151 152 153 154 155 156 157 158
            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.
      call get_environment_metadata(model,environment_names,environment_units)
159 160

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

163 164 165
   subroutine check_ready()
      !DIR$ ATTRIBUTES DLLEXPORT :: check_ready
      call fabm_check_ready(model)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
166
   end subroutine check_ready
167

168
   integer(c_int) function model_count() bind(c)
169 170 171 172 173 174 175 176 177
      !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
178
      end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
179
   end function model_count
180

Jorn Bruggeman's avatar
Jorn Bruggeman committed
181
   subroutine get_counts(nstate_bulk,nstate_surface,nstate_bottom,ndiagnostic_bulk,ndiagnostic_horizontal,nconserved, &
182
      ndependencies,nparameters,ncouplings) bind(c)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
183
      !DIR$ ATTRIBUTES DLLEXPORT :: get_counts
184 185
      integer(c_int),intent(out) :: nstate_bulk,nstate_surface,nstate_bottom
      integer(c_int),intent(out) :: ndiagnostic_bulk,ndiagnostic_horizontal
186
      integer(c_int),intent(out) :: nconserved,ndependencies,nparameters,ncouplings
187 188 189 190 191 192 193 194
      nstate_bulk = size(model%state_variables)
      nstate_surface = size(model%surface_state_variables)
      nstate_bottom = size(model%bottom_state_variables)
      ndiagnostic_bulk = size(model%diagnostic_variables)
      ndiagnostic_horizontal = size(model%horizontal_diagnostic_variables)
      nconserved = size(model%conserved_quantities)
      ndependencies = size(environment_names)
      nparameters = model%root%parameters%size()
195
      ncouplings = coupling_link_list%count()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
196
   end subroutine get_counts
197

198
   subroutine get_variable_metadata(category,index,length,name,units,long_name,path) bind(c)
199
      !DIR$ ATTRIBUTES DLLEXPORT :: get_variable_metadata
200
      integer(c_int),        intent(in), value             :: category,index,length
201
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name,path
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219

      class (type_external_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
      case (BULK_STATE_VARIABLE)
         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)
      case (BULK_DIAGNOSTIC_VARIABLE)
         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
220 221 222 223
      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
224
   end subroutine get_variable_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
225

Jorn Bruggeman's avatar
Jorn Bruggeman committed
226 227 228 229
   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
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248

      type (type_internal_variable),pointer :: variable

      ! Get a pointer to the target variable
      select case (category)
      case (BULK_STATE_VARIABLE)
         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
      case (BULK_DIAGNOSTIC_VARIABLE)
         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
249
   end function get_variable
250

251
   subroutine get_parameter_metadata(index,length,name,units,long_name,typecode,has_default) bind(c)
252
      !DIR$ ATTRIBUTES DLLEXPORT :: get_parameter_metadata
253
      integer(c_int),        intent(in), value             :: index,length
254
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name
255
      integer(c_int),        intent(out)                   :: typecode,has_default
256 257 258 259 260 261 262 263 264 265

      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
266 267
      end do

268 269 270 271
      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()
272
      has_default = logical2int(property%has_default)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
273
   end subroutine get_parameter_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
274

275 276
   subroutine get_dependency_metadata(index,length,name,units) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_dependency_metadata
Jorn Bruggeman's avatar
Jorn Bruggeman committed
277
      integer(c_int),        intent(in), value             :: index,length
278
      character(kind=c_char),intent(out),dimension(length) :: name,units
Jorn Bruggeman's avatar
Jorn Bruggeman committed
279

280 281
      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
282
   end subroutine get_dependency_metadata
283

284 285 286 287 288 289 290
   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
291

292 293 294 295 296 297
      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
298
   end subroutine get_coupling
299

Jorn Bruggeman's avatar
Jorn Bruggeman committed
300 301
   function variable_get_suitable_masters(pvariable) result(plist) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_suitable_masters
302 303
      type (c_ptr), intent(in), value :: pvariable
      type (c_ptr)                    :: plist
304

305
      type (type_internal_variable),pointer :: variable
306
      type (type_link_list),        pointer :: list
307 308 309 310

      call c_f_pointer(pvariable, variable)
      list => get_suitable_masters(model,variable)
      plist = c_loc(list)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
311
   end function variable_get_suitable_masters
312 313 314

   function link_list_count(plist) bind(c) result(value)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_list_count
315 316
      type (c_ptr), intent(in), value :: plist
      integer(c_int)                  :: value
317 318 319 320 321

      type (type_link_list),pointer :: list

      call c_f_pointer(plist, list)
      value = list%count()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
322
   end function link_list_count
323 324 325 326 327 328 329 330 331 332

   function link_list_index(plist,index) bind(c) result(pvariable)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_list_index
      type (c_ptr),  intent(in), value :: plist
      integer(c_int),intent(in), value :: index
      type (c_ptr)                     :: pvariable

      type (type_link_list),pointer :: list
      type (type_link),     pointer :: link
      integer                       :: i
Knut's avatar
Knut committed
333

334 335 336 337 338 339
      call c_f_pointer(plist, list)
      link => list%first
      do i=2,index
         link => link%next
      end do
      pvariable = c_loc(link%target)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
340
   end function link_list_index
341

342 343 344 345 346
   subroutine link_list_finalize(plist) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_list_finalize
      type (c_ptr),  intent(in), value :: plist

      type (type_link_list),pointer :: list
Knut's avatar
Knut committed
347

348 349 350
      call c_f_pointer(plist, list)
      call list%finalize()
      deallocate(list)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
351
   end subroutine link_list_finalize
352

Jorn Bruggeman's avatar
Jorn Bruggeman committed
353 354
   subroutine variable_get_long_path(pvariable,length,long_name) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_long_path
355 356 357 358
      type (c_ptr),          intent(in), value  :: pvariable
      integer(c_int),        intent(in), value  :: length
      character(kind=c_char),intent(out),dimension(length) ::long_name

359
      type (type_internal_variable),pointer :: variable
360 361
      class (type_base_model),       pointer :: owner
      character(len=attribute_length)        :: long_name_
Knut's avatar
Knut committed
362

363 364 365 366 367 368 369 370
      call c_f_pointer(pvariable, variable)
      long_name_ = variable%long_name
      owner => variable%owner
      do while (associated(owner%parent))
         long_name_ = trim(owner%long_name)//'/'//trim(long_name_)
         owner => owner%parent
      end do
      call copy_to_c_string(long_name_,long_name)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
371
   end subroutine variable_get_long_path
372

Jorn Bruggeman's avatar
Jorn Bruggeman committed
373 374
   function variable_get_background_value(pvariable) bind(c) result(value)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_background_value
375 376 377 378 379 380 381 382
      type (c_ptr), value, intent(in)  :: pvariable
      real(kind=c_double)              :: value

      type (type_internal_variable),pointer :: variable

      call c_f_pointer(pvariable, variable)
      value = 0.0_rk
      if (size(variable%background_values%pointers)>0) value = variable%background_values%pointers(1)%p
Jorn Bruggeman's avatar
Jorn Bruggeman committed
383
   end function variable_get_background_value
384

Jorn Bruggeman's avatar
Jorn Bruggeman committed
385 386
   subroutine variable_get_metadata(pvariable,length,name,units,long_name) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: variable_get_metadata
387 388
      type (c_ptr),          intent(in), value             :: pvariable
      integer(c_int),        intent(in), value             :: length
389 390
      character(kind=c_char),intent(out),dimension(length) :: name,units,long_name

391
      type (type_internal_variable),pointer :: variable
392 393 394 395 396

      call c_f_pointer(pvariable, variable)
      call copy_to_c_string(variable%name,     name)
      call copy_to_c_string(variable%units,    units)
      call copy_to_c_string(variable%long_name,long_name)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
397
   end subroutine variable_get_metadata
398

399
   subroutine get_model_metadata(name,length,long_name,user_created) bind(c)
400
      !DIR$ ATTRIBUTES DLLEXPORT :: get_model_metadata
401 402 403
      character(kind=c_char),intent(in), target :: name(*)
      integer(c_int),        intent(in), value  :: length
      character(kind=c_char),intent(out)        :: long_name(length)
404
      integer(c_int),        intent(out)        :: user_created
405

406 407
      character(len=attribute_length),pointer   :: pname
      class (type_base_model),        pointer   :: found_model
408 409 410

      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
411 412
      if (.not.associated(found_model)) call driver%fatal_error('get_model_metadata', &
         'model "'//pname(:index(pname,C_NULL_CHAR)-1)//'" not found.')
413
      call copy_to_c_string(found_model%long_name,long_name)
414
      user_created = logical2int(found_model%user_created)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
415
   end subroutine get_model_metadata
416

417 418 419 420 421 422 423 424
   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

      call fabm_link_bulk_data(model,environment_names(index),value)
      call fabm_link_horizontal_data(model,environment_names(index),value)
      call fabm_link_scalar_data(model,environment_names(index),value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
425
   end subroutine link_dependency_data
426 427 428 429 430

   subroutine link_bulk_state_data(index,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: link_bulk_state_data
      integer(c_int),intent(in),   value  :: index
      real(c_double),intent(inout),target :: value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
431

432 433
      value = model%state_variables(index)%initial_value
      call fabm_link_bulk_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
434
   end subroutine link_bulk_state_data
Jorn Bruggeman's avatar
Jorn Bruggeman committed
435

436 437 438 439
   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
440

441 442
      value = model%surface_state_variables(index)%initial_value
      call fabm_link_surface_state_data(model,index,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
443
   end subroutine link_surface_state_data
Knut's avatar
Knut committed
444

445 446 447 448 449 450 451
   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
452
   end subroutine link_bottom_state_data
453 454 455

   subroutine get_rates(pelagic_rates_) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_rates
456
      real(c_double),target,intent(in) :: pelagic_rates_(*)
457 458

      real(c_double),pointer :: pelagic_rates(:)
459
      real(rk)               :: ext
460

461 462
      call fabm_get_light_extinction(model,ext)
      call fabm_get_light(model)
463 464
      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
465 466 467 468
      pelagic_rates = 0.0_rk
      call fabm_do(model,pelagic_rates)

      ! Compute rate of change in conserved quantities
469
      !call fabm_state_to_conserved_quantities(model,pelagic_rates,conserved_rates)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
470 471

      ! Normalize rate of change in conserved quantities to sum of absolute rates of change.
472 473
      !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
474
   end subroutine get_rates
475 476 477 478 479 480

   subroutine get_bulk_diagnostic_data(index,ptr) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: get_bulk_diagnostic_data
      integer(c_int),intent(in),value :: index
      type(c_ptr),   intent(out)      :: ptr
      ptr = c_loc(fabm_get_bulk_diagnostic_data(model,index))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
481
   end subroutine get_bulk_diagnostic_data
482 483 484 485 486 487

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

490
   subroutine finalize() bind(c)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
491 492 493
      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
494
   end subroutine finalize
Jorn Bruggeman's avatar
Jorn Bruggeman committed
495

496
   subroutine reset_parameter(index) bind(c)
497
      !DIR$ ATTRIBUTES DLLEXPORT :: reset_parameter
498 499
      integer(c_int),value,intent(in) :: index
      class (type_property),pointer   :: property
500

501 502 503
      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
504 505

      ! Re-initialize the model using updated parameter values
506
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
507
   end subroutine reset_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
508

509 510
   subroutine set_real_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_real_parameter
511 512
      character(kind=c_char),target,intent(in) :: name(*)
      real(c_double),value,         intent(in) :: value
513 514 515 516 517

      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
518 519

      ! Re-initialize the model using updated parameter values
520
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
521
   end subroutine set_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
522

523
   function get_real_parameter(index,default) bind(c) result(value)
524
      !DIR$ ATTRIBUTES DLLEXPORT :: get_real_parameter
525
      integer(c_int),value,intent(in) :: index,default
526
      real(c_double)                  :: value
527 528 529 530 531
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_real_property)
532
         if (int2logical(default)) then
533 534 535 536 537 538 539
            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
540
   end function get_real_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
541

542 543
   subroutine set_integer_parameter(name,value) bind(c)
      !DIR$ ATTRIBUTES DLLEXPORT :: set_integer_parameter
544 545
      character(kind=c_char),target,intent(in) :: name(*)
      integer(c_int),value,         intent(in) :: value
546 547 548 549 550

      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
551 552

      ! Re-initialize the model using updated parameter values
553
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
554
   end subroutine set_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
555

556
   function get_integer_parameter(index,default) bind(c) result(value)
557
      !DIR$ ATTRIBUTES DLLEXPORT :: get_integer_parameter
558
      integer(c_int),value,intent(in) :: index,default
559
      integer(c_int)                  :: value
560 561 562 563 564
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_integer_property)
565
         if (int2logical(default)) then
566 567 568 569 570 571 572
            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
573
   end function get_integer_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
574

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

      character(len=attribute_length),pointer :: pname

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

      ! Re-initialize the model using updated parameter values
586
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
587
   end subroutine set_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
588

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

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_logical_property)
598 599
         if (int2logical(default)) then
            value = logical2int(property%default)
600
         else
601
            value = logical2int(property%value)
602 603 604 605
         end if
      class default
         call driver%fatal_error('get_logical_parameter','not a logical variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
606
   end function get_logical_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
607

608 609 610 611 612
   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
613

614 615 616
      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
617 618

      ! Re-initialize the model using updated parameter values
619
      call reinitialize()
Jorn Bruggeman's avatar
Jorn Bruggeman committed
620
   end subroutine set_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
621

622 623 624 625 626
   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)

627 628 629 630 631
      class (type_property),pointer   :: property

      property => model%root%parameters%get_property(index)
      select type (property)
      class is (type_string_property)
632
         if (int2logical(default)) then
633
            call copy_to_c_string(property%default, value)
634
         else
635
            call copy_to_c_string(property%value, value)
636 637 638 639
         end if
      class default
         call driver%fatal_error('get_string_parameter','not a string variable')
      end select
Jorn Bruggeman's avatar
Jorn Bruggeman committed
640
   end subroutine get_string_parameter
Jorn Bruggeman's avatar
Jorn Bruggeman committed
641

642
   subroutine python_driver_fatal_error(self,location,message)
643 644 645 646 647
      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
648
   end subroutine python_driver_fatal_error
649

650
   subroutine python_driver_log_message(self,message)
651 652 653 654
      class (type_python_driver),intent(inout) :: self
      character(len=*),          intent(in)    :: message

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

657
   subroutine copy_to_c_string(string,cstring)
658 659
      character(len=*),      intent(in)  :: string
      character(kind=c_char),intent(out) :: cstring(:)
660 661 662 663 664
      integer i,n
      n = min(len_trim(string),size(cstring)-1)
      do i=1,n
         cstring(i) = string(i:i)
      end do
Knut's avatar
Knut committed
665
      cstring(n+1) = C_NULL_CHAR
666 667
   end subroutine

668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683
   function logical2int(value) result(ivalue)
      logical,intent(in) :: value
      integer            :: ivalue
      if (value) then
         ivalue = 1
      else
         ivalue = 0
      end if
   end function

   function int2logical(ivalue) result(value)
      integer,intent(in) :: ivalue
      logical            :: value
      value = ivalue/=0
   end function

Jorn Bruggeman's avatar
Jorn Bruggeman committed
684 685 686 687 688
   end module fabm_python

!-----------------------------------------------------------------------
! Copyright by the GOTM-team under the GNU Public License - www.gnu.org
!-----------------------------------------------------------------------