-
Notifications
You must be signed in to change notification settings - Fork 43
/
fabm.F90
3161 lines (2725 loc) · 171 KB
/
fabm.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
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
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#include "fabm_driver.h"
#include "fabm_private.h"
! =============================================================================
!> FABM --- Framework for Aquatic Biogeochemical Models
!! This is the core module of FABM, serving as the "glue layer" between a
!! physical host model (e.g., a general circulation model), and one or more
!! specific biogeochemical models. A physical host model will call the
!! interfaces of this module to access biogeochemistry.
!!
!! For more information, see the documentation at https://fabm.net/wiki.
!!
!! To add new biogeochemical models, add source code under src/models and
!! reference your institute in src/CMakeLists.txt
! =============================================================================
module fabm
use fabm_parameters
use fabm_types, rki => rk, fabm_standard_variables => standard_variables
use fabm_expressions
use fabm_driver
use fabm_properties
use fabm_builtin_depth_integral
use fabm_builtin_reduction
use fabm_coupling
use fabm_job
use fabm_schedule
use fabm_debug
use fabm_work
implicit none
private
! ------------------------------------------------------------------------------------------------------------------------------
! Public members
! ------------------------------------------------------------------------------------------------------------------------------
! Routines
public fabm_initialize_library
public fabm_get_version
public fabm_create_model
public fabm_finalize_library
! The main model type
public type_fabm_model
! Variable identifier types
public type_fabm_variable_id
public type_fabm_interior_variable_id
public type_fabm_horizontal_variable_id
public type_fabm_scalar_variable_id
public type_fabm_variable, type_fabm_interior_state_variable, type_fabm_horizontal_state_variable, &
type_fabm_interior_diagnostic_variable, type_fabm_horizontal_diagnostic_variable
! Object with all supported standard variables as its members.
! Imported from fabm_types, and made available so hosts only need to "use fabm"
public fabm_standard_variables
integer, parameter :: status_none = 0
integer, parameter :: status_initialize_done = 1
integer, parameter, public :: status_set_domain_done = 2
integer, parameter, public :: status_start_done = 3
integer, parameter, public :: data_source_none = 0
integer, parameter, public :: data_source_host = 1
integer, parameter, public :: data_source_fabm = 2
integer, parameter, public :: data_source_user = 3
integer, parameter, public :: data_source_default = data_source_host
logical, save :: default_driver = .false.
! ------------------------------------------------------------------------------------------------------------------------------
! Derived typed for variable identifiers
! ------------------------------------------------------------------------------------------------------------------------------
!> Base type for a variable identifier
type type_fabm_variable_id
type (type_internal_variable), pointer :: variable => null()
end type
!> Identifier for an interior variable (varying in the horizontal and in depth)
type, extends(type_fabm_variable_id) :: type_fabm_interior_variable_id
end type
!> Identifier for a horizontal variable (varying in the horizontal but depth-independent)
type, extends(type_fabm_variable_id) :: type_fabm_horizontal_variable_id
end type
!> Identifier for a scalar variable (constant in space)
type, extends(type_fabm_variable_id) :: type_fabm_scalar_variable_id
end type
! ------------------------------------------------------------------------------------------------------------------------------
! Derived types for variable metadata
! ------------------------------------------------------------------------------------------------------------------------------
!> Variable metadata (base type)
type, abstract :: type_fabm_variable
!> Unique variable name (alphanumeric characters and underscores only).
!! It combines the name of the registering model instance and the local variable name.
!! It is equal to `path`, but with slashes replaced by underscores.
character(len=attribute_length) :: name = ''
!> Long variable name (alphanumeric characters, underscores, spaces).
!! This combines the long name of the registering model instance and the local long name.
character(len=attribute_length) :: long_name = ''
!> Local long name as registered by the model instance (no instance name is prefixed)
character(len=attribute_length) :: local_long_name = ''
!> Units
character(len=attribute_length) :: units = ''
!> Unique variable path: model instance path, followed by a slash, followed by the variable name
character(len=attribute_length) :: path = ''
!> Minimum value that the variable is allowed to take
real(rke) :: minimum = -1.e20_rke
!> Maximum value that the variable is allowed to take
real(rke) :: maximum = 1.e20_rke
!> Missing value used in masked points (typically, on land)
real(rke) :: missing_value = -2.e20_rke
! See output_* parameters defined in fabm_types
integer :: output = output_instantaneous
!> Custom properties defined by the model instance that registered the variable
type (type_property_dictionary) :: properties
!> Identifier to be used freely by host
integer :: externalid = 0
type (type_internal_variable), pointer :: target => null()
type (type_internal_variable), pointer :: original => null()
end type
!> Metadata for an interior state variable
type, extends(type_fabm_variable) :: type_fabm_interior_state_variable
class (type_interior_standard_variable), pointer :: standard_variable => null()
!> Default initial value
real(rke) :: initial_value = 0.0_rke
!> Whether to assume that this variable is not diluted by precipitation.
!! If set, the variable concentration in water added by precipitation should by default
!! be assumed equal to that of the receiving cell.
logical :: no_precipitation_dilution = .false.
!> Whether to assume that this variable is not diluted by riverine inflow.
!! If set, the variable concentration in river water should by default
!! be assumed equal to that of the receiving cell.
logical :: no_river_dilution = .false.
end type
!> Metadata for a bottom or surface state variable
type, extends(type_fabm_variable) :: type_fabm_horizontal_state_variable
class (type_horizontal_standard_variable), pointer :: standard_variable => null()
!> Default initial value
real(rke) :: initial_value = 0.0_rke
end type
!> Metadata for an interior diagnostic variable
type, extends(type_fabm_variable) :: type_fabm_interior_diagnostic_variable
class (type_interior_standard_variable), pointer :: standard_variable => null()
!> Whether this variable will be included in output and thus needs to be computed.
logical :: save = .false.
integer :: source
end type
!> Metadata for a horizontal diagnostic variable
type, extends(type_fabm_variable) :: type_fabm_horizontal_diagnostic_variable
class (type_horizontal_standard_variable), pointer :: standard_variable => null()
!> Whether this variable will be included in output and thus needs to be computed.
logical :: save = .false.
integer :: source
end type
!> Metadata for a conserved quantity
type, extends(type_fabm_variable) :: type_fabm_conserved_quantity
class (type_base_standard_variable), pointer :: standard_variable => null()
integer :: index = -1
integer :: horizontal_index = -1
type (type_internal_variable), pointer :: target_hz => null()
end type
type type_check_state_data
integer :: index
real(rki) :: minimum
real(rki) :: maximum
end type
! ------------------------------------------------------------------------------------------------------------------------------
!> A biogeochemical model as seen by the host
! ------------------------------------------------------------------------------------------------------------------------------
type type_fabm_model
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Variable metadata
!> @{
type (type_fabm_interior_state_variable), allocatable, dimension(:) :: interior_state_variables
type (type_fabm_horizontal_state_variable), allocatable, dimension(:) :: surface_state_variables
type (type_fabm_horizontal_state_variable), allocatable, dimension(:) :: bottom_state_variables
type (type_fabm_interior_diagnostic_variable), allocatable, dimension(:) :: interior_diagnostic_variables
type (type_fabm_horizontal_diagnostic_variable), allocatable, dimension(:) :: horizontal_diagnostic_variables
type (type_fabm_conserved_quantity), allocatable, dimension(:) :: conserved_quantities
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Potential dependencies
!! Names of variables taken as input by one or more biogeochemical model instances.
!! These may be accessed by the host to enumerate potential forcing variables.
!> @{
character(len=attribute_length), allocatable, dimension(:) :: dependencies
character(len=attribute_length), allocatable, dimension(:) :: dependencies_hz
character(len=attribute_length), allocatable, dimension(:) :: dependencies_scalar
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> Configuration information read from fabm.yaml
type (type_fabm_settings) :: settings
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Individual jobs
!> @{
type (type_job) :: get_interior_sources_job
type (type_job) :: get_bottom_sources_job
type (type_job) :: get_surface_sources_job
type (type_job) :: get_vertical_movement_job
type (type_job) :: get_interior_conserved_quantities_job
type (type_job) :: get_horizontal_conserved_quantities_job
type (type_job) :: finalize_outputs_job
type (type_job) :: prepare_inputs_job
type (type_job) :: check_interior_state_job
type (type_job) :: check_bottom_state_job
type (type_job) :: check_surface_state_job
type (type_job) :: initialize_interior_state_job
type (type_job) :: initialize_bottom_state_job
type (type_job) :: initialize_surface_state_job
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> Root instance containing all user-specified biogeochemical model instances
type (type_base_model) :: root
! ---------------------------------------------------------------------------------------------------------------------------
integer :: status = status_none
logical :: log = .false.
logical :: require_initialization = .false.
! ---------------------------------------------------------------------------------------------------------------------------
type (type_link_list) :: links_postcoupling
! ---------------------------------------------------------------------------------------------------------------------------
type (type_global_variable_register) :: variable_register
type (type_job_manager) :: job_manager
type (type_catalog) :: catalog
type (type_store) :: store
type (type_schedules) :: schedules
type (type_domain) :: domain
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Memory caches for exchanging information with biogeochemical model instances
!> @{
type (type_interior_cache) :: cache_int
type (type_horizontal_cache) :: cache_hz
type (type_vertical_cache) :: cache_vert
type (type_cache_fill_values) :: cache_fill_values
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
! Information for check_state routines
type (type_check_state_data), allocatable, private :: check_interior_state_data(:)
type (type_check_state_data), allocatable, private :: check_surface_state_data(:)
type (type_check_state_data), allocatable, private :: check_bottom_state_data(:)
! ---------------------------------------------------------------------------------------------------------------------------
contains
! ---------------------------------------------------------------------------------------------------------------------------
procedure :: initialize
procedure :: finalize
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Domain information
!> @{
procedure :: set_domain
#if _FABM_DIMENSION_COUNT_>0
procedure :: set_domain_start
procedure :: set_domain_stop
#endif
#if defined(_FABM_DEPTH_DIMENSION_INDEX_)&&_FABM_BOTTOM_INDEX_==-1
procedure :: set_bottom_index
#endif
#ifdef _HAS_MASK_
procedure :: set_mask
#endif
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
procedure :: start
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Initialize state
!> @{
procedure :: initialize_interior_state
procedure :: initialize_bottom_state
procedure :: initialize_surface_state
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Check and/or repair state
!> @{
procedure :: check_interior_state
procedure :: check_bottom_state
procedure :: check_surface_state
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
procedure :: prepare_inputs1
procedure :: prepare_inputs2
generic :: prepare_inputs => prepare_inputs1, prepare_inputs2
procedure :: finalize_outputs
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Get source terms and surface/bottom fluxes
!> @{
procedure :: get_interior_sources_rhs
procedure :: get_interior_sources_ppdd
generic :: get_interior_sources => get_interior_sources_rhs, get_interior_sources_ppdd
procedure :: get_bottom_sources_rhs
procedure :: get_bottom_sources_ppdd
generic :: get_bottom_sources => get_bottom_sources_rhs, get_bottom_sources_ppdd
procedure :: get_surface_sources
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
procedure :: get_vertical_movement
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Get totals of conserved quantities
!> @{
procedure :: get_interior_conserved_quantities
procedure :: get_horizontal_conserved_quantities
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Provide variable data
!> @{
procedure :: link_interior_data_by_variable
procedure :: link_interior_data_by_id
procedure :: link_interior_data_by_sn
procedure :: link_interior_data_by_name
generic :: link_interior_data => link_interior_data_by_variable, link_interior_data_by_id, &
link_interior_data_by_sn, link_interior_data_by_name
procedure :: link_horizontal_data_by_variable
procedure :: link_horizontal_data_by_id
procedure :: link_horizontal_data_by_sn
procedure :: link_horizontal_data_by_name
generic :: link_horizontal_data => link_horizontal_data_by_variable, link_horizontal_data_by_id, &
link_horizontal_data_by_sn, link_horizontal_data_by_name
procedure :: link_scalar_by_variable
procedure :: link_scalar_by_id
procedure :: link_scalar_by_sn
procedure :: link_scalar_by_name
generic :: link_scalar => link_scalar_by_variable, link_scalar_by_id, &
link_scalar_by_sn, link_scalar_by_name
procedure :: link_interior_state_data
procedure :: link_bottom_state_data
procedure :: link_surface_state_data
procedure :: link_all_interior_state_data
procedure :: link_all_bottom_state_data
procedure :: link_all_surface_state_data
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Request computation of variables
!> @{
procedure :: require_interior_data
procedure :: require_horizontal_data
generic :: require_data => require_interior_data, require_horizontal_data
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Get variable data
!> @{
procedure :: get_interior_data
procedure :: get_horizontal_data
procedure :: get_scalar_data
generic :: get_data => get_interior_data, get_horizontal_data, get_scalar_data
procedure :: get_interior_diagnostic_data
procedure :: get_horizontal_diagnostic_data
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Get variable identifiers
!> @{
procedure :: get_interior_variable_id_by_name
procedure :: get_interior_variable_id_sn
generic :: get_interior_variable_id => get_interior_variable_id_by_name, get_interior_variable_id_sn
procedure :: get_horizontal_variable_id_by_name
procedure :: get_horizontal_variable_id_sn
generic :: get_horizontal_variable_id => get_horizontal_variable_id_by_name, get_horizontal_variable_id_sn
procedure :: get_scalar_variable_id_by_name
procedure :: get_scalar_variable_id_sn
generic :: get_scalar_variable_id => get_scalar_variable_id_by_name, get_scalar_variable_id_sn
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
procedure, nopass :: is_variable_used
procedure :: get_variable_name
! ---------------------------------------------------------------------------------------------------------------------------
!> @name Verify whether variable values must be provided
!> @{
procedure :: interior_variable_needs_values
procedure :: interior_variable_needs_values_sn
procedure :: horizontal_variable_needs_values
procedure :: horizontal_variable_needs_values_sn
procedure :: scalar_variable_needs_values
procedure :: scalar_variable_needs_values_sn
generic :: variable_needs_values => interior_variable_needs_values, interior_variable_needs_values_sn, &
horizontal_variable_needs_values, horizontal_variable_needs_values_sn, &
scalar_variable_needs_values, scalar_variable_needs_values_sn
!> @}
! ---------------------------------------------------------------------------------------------------------------------------
procedure :: process_job
generic :: process => process_job
#if _FABM_DIMENSION_COUNT_ > 1 || (_FABM_DIMENSION_COUNT_ == 1 && !defined(_FABM_DEPTH_DIMENSION_INDEX_))
procedure :: process_job_everywhere
generic :: process => process_job_everywhere
#endif
! ---------------------------------------------------------------------------------------------------------------------------
end type type_fabm_model
character(len=*), parameter :: log_prefix = 'fabm_'
contains
! ------------------------------------------------------------------------------------------------------------------------------
!> Initialize global variables shared by all models.
!! This routine will be called automatically when creating new models.
!! For instance, from fabm_create_model().
! ------------------------------------------------------------------------------------------------------------------------------
subroutine fabm_initialize_library()
use fabm_library, only: fabm_model_factory
! Do nothing if already initialized.
if (associated(factory)) return
! If needed, create default object for communication (e.g., logging, error reporting) with host.
if (.not. associated(driver)) then
allocate(driver)
default_driver = .true.
end if
! Create all standard variable objects.
call fabm_standard_variables%initialize()
! Create the model factory.
factory => fabm_model_factory
call factory%initialize()
end subroutine fabm_initialize_library
! ------------------------------------------------------------------------------------------------------------------------------
!> Deallocate all global variables allocated by fabm_initialize_library()
! ------------------------------------------------------------------------------------------------------------------------------
subroutine fabm_finalize_library()
call fabm_standard_variables%finalize()
if (associated(driver) .and. default_driver) deallocate(driver)
if (associated(factory)) call factory%finalize()
factory => null()
end subroutine fabm_finalize_library
! ------------------------------------------------------------------------------------------------------------------------------
!> Get FABM version string
! ------------------------------------------------------------------------------------------------------------------------------
subroutine fabm_get_version(string)
use fabm_version
character(len=*), intent(out) :: string
type (type_version), pointer :: version
call fabm_initialize_library()
string = git_commit_id // ' (' // git_branch_name // ' branch)'
version => first_module_version
do while (associated(version))
string = trim(string) // ', ' // trim(version%module_name) // ': ' // trim(version%version_string)
version => version%next
end do
end subroutine fabm_get_version
! ------------------------------------------------------------------------------------------------------------------------------
!> Create a model from a yaml-based configuration file
! ------------------------------------------------------------------------------------------------------------------------------
function fabm_create_model(path, initialize, settings, unit) result(model)
use fabm_config, only: fabm_configure_model, fabm_load_settings
!> Path to yaml-based configuration file (defaults to `fabm.yaml`)
character(len=*), optional, intent(in) :: path
!> Whether to automatically initialize the model (the default).
!! If set to `.false.`, additional model instances can be added after this function returns.
!! However, the caller is then responsible for calling initialize() on the returned model object.
logical, optional, intent(in) :: initialize
!> An existing configuration to take settings from.
!! If provided, the `path` argument is not used.
!! After this routine returns, the underlying configuration data have been _moved_ to the new model.
!! As a result, the old `settings` object can only access configuration information it already retrieved previously.
type (type_fabm_settings), target, optional, intent(inout) :: settings
!> Unit number to use for opening the yaml-based configuration file (default: the next free unit)
integer, optional, intent(in) :: unit
!> Pointer to a newly allocated model.
class (type_fabm_model), pointer :: model
logical :: initialize_
! Make sure the library is initialized.
call fabm_initialize_library()
allocate(model)
if (present(settings)) then
call model%settings%take_values(settings)
else
call fabm_load_settings(model%settings, path, unit=unit)
end if
call fabm_configure_model(model%root, model%settings, model%schedules, model%log, model%require_initialization)
! Initialize model tree
initialize_ = .true.
if (present(initialize)) initialize_ = initialize
if (initialize_) call model%initialize()
end function fabm_create_model
! ------------------------------------------------------------------------------------------------------------------------------
!> Initialize the model.
!! This freezes the tree of biogeochemical model instances;
!! after this, no new instances can be added.
!! This routine will be called automatically from fabm_create_model()
!! unless the latter is called with `initialize=.false.`
! ------------------------------------------------------------------------------------------------------------------------------
subroutine initialize(self)
class (type_fabm_model), target, intent(inout) :: self
integer :: ivar, log_unit, ios
if (self%status >= status_initialize_done) &
call fatal_error('initialize', 'initialize has already been called on this model object.')
! Create zero fields.
call self%root%add_interior_variable('zero', act_as_state_variable=.true., source=source_constant, &
missing_value=0.0_rki, output=output_none)
call self%root%add_horizontal_variable('zero_hz', act_as_state_variable=.true., source=source_constant, &
missing_value=0.0_rki, output=output_none)
! Filter out expressions that FABM can handle itself.
! The remainder, if any, must be handled by the host model.
call filter_expressions(self)
log_unit = -1
if (self%log) then
log_unit = get_free_unit()
open(unit=log_unit, file=log_prefix // 'coupling.log', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'coupling.log')
end if
! This will resolve all FABM dependencies and generate final authoritative lists of variables of different types.
call freeze_model_info(self%root, self%require_initialization, coupling_log_unit=log_unit)
if (self%log) close(log_unit)
if (.not. self%settings%check_all_used(finalize_store=.false.)) call fatal_error('initialize', 'invalid configuration')
! Build final authoritative arrays with variable metadata.
call classify_variables(self)
! Create catalog for storing pointers to data per variable.
call create_catalog(self)
! Create built-in jobs, which can then be chained by the host/user by calling job%set_next.
! (the reason for chaining is to allow later jobs to use results of earlier ones, thus reducing the number of calls needed)
call self%job_manager%create(self%prepare_inputs_job, 'prepare_inputs')
call self%job_manager%create(self%get_interior_sources_job, 'get_interior_sources', source=source_do, previous=self%prepare_inputs_job)
call self%job_manager%create(self%get_surface_sources_job, 'get_surface_sources', source=source_do_surface, previous=self%prepare_inputs_job)
call self%job_manager%create(self%get_bottom_sources_job, 'get_bottom_sources', source=source_do_bottom, previous=self%prepare_inputs_job)
call self%job_manager%create(self%get_interior_conserved_quantities_job, 'get_interior_conserved_quantities', source=source_do, previous=self%prepare_inputs_job)
call self%job_manager%create(self%get_horizontal_conserved_quantities_job, 'get_horizontal_conserved_quantities', source=source_do_horizontal, previous=self%prepare_inputs_job)
call self%job_manager%create(self%finalize_outputs_job, 'finalize_outputs', outsource_tasks=.true.)
call self%get_interior_sources_job%connect(self%finalize_outputs_job)
call self%get_surface_sources_job%connect(self%finalize_outputs_job)
call self%get_bottom_sources_job%connect(self%finalize_outputs_job)
!call self%get_interior_conserved_quantities_job%connect(self%finalize_outputs_job)
!call self%get_horizontal_conserved_quantities_job%connect(self%finalize_outputs_job)
call self%job_manager%create(self%get_vertical_movement_job, 'get_vertical_movement', source=source_get_vertical_movement, previous=self%finalize_outputs_job)
call self%job_manager%create(self%initialize_interior_state_job, 'initialize_interior_state', source=source_initialize_state, previous=self%finalize_outputs_job)
call self%job_manager%create(self%initialize_bottom_state_job, 'initialize_bottom_state', source=source_initialize_bottom_state, previous=self%finalize_outputs_job)
call self%job_manager%create(self%initialize_surface_state_job, 'initialize_surface_state', source=source_initialize_surface_state, previous=self%finalize_outputs_job)
call self%job_manager%create(self%check_interior_state_job, 'check_interior_state', source=source_check_state, previous=self%finalize_outputs_job)
call self%job_manager%create(self%check_bottom_state_job, 'check_bottom_state', source=source_check_bottom_state, previous=self%finalize_outputs_job)
call self%job_manager%create(self%check_surface_state_job, 'check_surface_state', source=source_check_surface_state, previous=self%finalize_outputs_job)
call require_flux_computation(self%get_bottom_sources_job, self%links_postcoupling, domain_bottom)
call require_flux_computation(self%get_surface_sources_job, self%links_postcoupling, domain_surface)
call require_flux_computation(self%get_interior_sources_job, self%links_postcoupling, domain_interior)
call require_flux_computation(self%get_vertical_movement_job, self%links_postcoupling, domain_interior + 999)
call require_call_all_with_state(self%initialize_interior_state_job, self%root%links, domain_interior, source_initialize_state)
call require_call_all_with_state(self%initialize_bottom_state_job, self%root%links, domain_bottom, source_initialize_bottom_state)
call require_call_all_with_state(self%initialize_surface_state_job, self%root%links, domain_surface, source_initialize_surface_state)
call require_call_all_with_state(self%check_interior_state_job, self%root%links, domain_interior, source_check_state)
call require_call_all_with_state(self%check_bottom_state_job, self%root%links, domain_bottom, source_check_bottom_state)
call require_call_all_with_state(self%check_bottom_state_job, self%root%links, domain_interior, source_check_bottom_state)
call require_call_all_with_state(self%check_surface_state_job, self%root%links, domain_surface, source_check_surface_state)
call require_call_all_with_state(self%check_surface_state_job, self%root%links, domain_interior, source_check_surface_state)
do ivar = 1, size(self%interior_state_variables)
call self%check_interior_state_job%read_cache_loads%add(self%interior_state_variables(ivar)%target)
end do
do ivar = 1, size(self%bottom_state_variables)
call self%check_bottom_state_job%read_cache_loads%add(self%bottom_state_variables(ivar)%target)
end do
do ivar = 1, size(self%surface_state_variables)
call self%check_surface_state_job%read_cache_loads%add(self%surface_state_variables(ivar)%target)
end do
do ivar = 1, size(self%conserved_quantities)
call self%get_interior_conserved_quantities_job%request_variable(self%conserved_quantities(ivar)%target)
call self%get_horizontal_conserved_quantities_job%request_variable(self%conserved_quantities(ivar)%target_hz)
call self%conserved_quantities(ivar)%target%write_indices%append(self%conserved_quantities(ivar)%index)
call self%conserved_quantities(ivar)%target_hz%write_indices%append(self%conserved_quantities(ivar)%horizontal_index)
end do
self%status = status_initialize_done
end subroutine initialize
! ------------------------------------------------------------------------------------------------------------------------------
!> Deallocate all variables of the model.
! ------------------------------------------------------------------------------------------------------------------------------
subroutine finalize(self)
class (type_fabm_model), target, intent(inout) :: self
self%status = status_none
call self%job_manager%finalize()
call self%variable_register%finalize()
call self%settings%finalize()
call self%settings%finalize_store()
call self%root%finalize()
call self%links_postcoupling%finalize()
end subroutine finalize
! ------------------------------------------------------------------------------------------------------------------------------
!> Set extents of spatial domain and optionally time step length.
! ------------------------------------------------------------------------------------------------------------------------------
subroutine set_domain(self _POSTARG_LOCATION_, seconds_per_time_unit)
class (type_fabm_model), target, intent(inout) :: self
_DECLARE_ARGUMENTS_LOCATION_
!> Scale factor that converts the time value provided to prepare_inputs() to seconds.
!! The combination of this scale factor and the time value will be used to determine the number of seconds that has passed
!! between calls to prepare_inputs(). In turn this enables support for built-in time filters such as moving averages.
real(rke), optional, intent(in) :: seconds_per_time_unit
class (type_expression), pointer :: expression
real(rke) :: missing_value
if (self%status < status_initialize_done) call fatal_error('set_domain', 'initialize has not yet been called on this model object.')
if (self%status >= status_set_domain_done) call fatal_error('set_domain', 'set_domain has already been called on this model object.')
self%status = status_set_domain_done
#if _FABM_DIMENSION_COUNT_>0
self%domain%shape(:) = (/_LOCATION_/)
self%domain%start(:) = 1
self%domain%stop(:) = self%domain%shape
#endif
#if _HORIZONTAL_DIMENSION_COUNT_>0
self%domain%horizontal_shape(:) = (/_HORIZONTAL_LOCATION_/)
#endif
if (present(seconds_per_time_unit)) then
! Since the host provides information about time, we will support time filters.
! These includes moving average and moving maximum filters.
expression => self%root%first_expression
do while (associated(expression))
select type (expression)
class is (type_interior_temporal_mean)
! Moving average of interior variable
call self%finalize_outputs_job%request_variable(expression%link%target, store=.true.)
expression%in = expression%link%target%catalog_index
expression%period = expression%period / seconds_per_time_unit
allocate(expression%history(_PREARG_LOCATION_ expression%n + 1))
expression%history = 0.0_rke
#if _FABM_DIMENSION_COUNT_>0
allocate(expression%previous_value _INDEX_LOCATION_, expression%last_exact_mean _INDEX_LOCATION_, expression%mean _INDEX_LOCATION_)
#endif
expression%last_exact_mean = 0.0_rke
missing_value = expression%missing_value ! To avoid a stack overflow for the next line with ifort 2021.3
expression%mean = missing_value
call self%link_interior_data(expression%output_name, expression%mean)
class is (type_horizontal_temporal_mean)
! Moving average of horizontal variable
call self%finalize_outputs_job%request_variable(expression%link%target, store=.true.)
expression%in = expression%link%target%catalog_index
expression%period = expression%period / seconds_per_time_unit
allocate(expression%history(_PREARG_HORIZONTAL_LOCATION_ expression%n + 1))
expression%history = 0.0_rke
#if _HORIZONTAL_DIMENSION_COUNT_>0
allocate(expression%previous_value _INDEX_HORIZONTAL_LOCATION_, expression%last_exact_mean _INDEX_HORIZONTAL_LOCATION_, expression%mean _INDEX_HORIZONTAL_LOCATION_)
#endif
expression%last_exact_mean = 0.0_rke
missing_value = expression%missing_value ! To avoid a stack overflow for the next line with ifort 2021.3
expression%mean = missing_value
call self%link_horizontal_data(expression%output_name, expression%mean)
class is (type_horizontal_temporal_maximum)
! Moving maximum of horizontal variable
call self%finalize_outputs_job%request_variable(expression%link%target, store=.true.)
expression%in = expression%link%target%catalog_index
expression%period = expression%period / seconds_per_time_unit
allocate(expression%history(_PREARG_HORIZONTAL_LOCATION_ expression%n))
expression%history = -huge(1.0_rke)
#if _HORIZONTAL_DIMENSION_COUNT_>0
allocate(expression%previous_value _INDEX_HORIZONTAL_LOCATION_, expression%maximum _INDEX_HORIZONTAL_LOCATION_)
#endif
missing_value = expression%missing_value ! To avoid a stack overflow for the next line with ifort 2021.3
expression%maximum = missing_value
call self%link_horizontal_data(expression%output_name, expression%maximum)
end select
expression => expression%next
end do
end if
end subroutine set_domain
#if _FABM_DIMENSION_COUNT_>0
! ------------------------------------------------------------------------------------------------------------------------------
!> Set start index of all spatial dimensions.
!! This is optional; by default the start index for all dimensions is 1.
! ------------------------------------------------------------------------------------------------------------------------------
subroutine set_domain_start(self _POSTARG_LOCATION_)
class (type_fabm_model), target, intent(inout) :: self
_DECLARE_ARGUMENTS_LOCATION_
if (self%status < status_set_domain_done) &
call fatal_error('set_domain_start', 'set_domain has not yet been called on this model object.')
self%domain%start(:) = (/_LOCATION_/)
end subroutine set_domain_start
! ------------------------------------------------------------------------------------------------------------------------------
!> Set stop index of all spatial dimensions.
!! This is optional; by default the stop index for all dimensions matches
!! the domain size provided to set_domain().
! ------------------------------------------------------------------------------------------------------------------------------
subroutine set_domain_stop(self _POSTARG_LOCATION_)
class (type_fabm_model), target, intent(inout) :: self
_DECLARE_ARGUMENTS_LOCATION_
if (self%status < status_set_domain_done) &
call fatal_error('set_domain_stop', 'set_domain has not yet been called on this model object.')
self%domain%stop(:) = (/_LOCATION_/)
end subroutine set_domain_stop
#endif
#ifdef _HAS_MASK_
! ------------------------------------------------------------------------------------------------------------------------------
!> Provide spatial mask.
!! As FABM will keep a pointer to the mask, it needs to remain valid for
!! the lifetime of the model object.
! ------------------------------------------------------------------------------------------------------------------------------
# ifdef _FABM_HORIZONTAL_MASK_
subroutine set_mask(self, mask_hz)
# else
subroutine set_mask(self, mask, mask_hz)
# endif
class (type_fabm_model), target, intent(inout) :: self
# ifndef _FABM_HORIZONTAL_MASK_
!> Mask for the interior domain.
!! Its shape must match that of the full interior domain as specified by the call to set_domain()
_FABM_MASK_TYPE_, target, intent(in) _ATTRIBUTES_GLOBAL_ :: mask
# endif
!> Mask for the horizontal domain.
!! Its shape must match that of the full horizontal domain as specified by the call to set_domain()
_FABM_MASK_TYPE_, target, intent(in) _ATTRIBUTES_GLOBAL_HORIZONTAL_ :: mask_hz
integer :: i
if (self%status < status_set_domain_done) &
call fatal_error('set_mask', 'set_domain has not yet been called on this model object.')
# ifndef _FABM_HORIZONTAL_MASK_
# if !defined(NDEBUG)&&_FABM_DIMENSION_COUNT_>0
do i = 1, size(self%domain%shape)
if (size(mask, i) /= self%domain%shape(i)) &
call fatal_error('set_mask', 'shape of provided mask does not match domain extents provided to set_domain.')
end do
# endif
self%domain%mask => mask
# endif
# if !defined(NDEBUG)&&_HORIZONTAL_DIMENSION_COUNT_>0
do i = 1, size(self%domain%horizontal_shape)
if (size(mask_hz, i) /= self%domain%horizontal_shape(i)) &
call fatal_error('set_mask', 'shape of provided horizontal mask does not match domain extents provided to set_domain.')
end do
# endif
self%domain%mask_hz => mask_hz
end subroutine set_mask
#endif
#if defined(_FABM_DEPTH_DIMENSION_INDEX_)&&_FABM_BOTTOM_INDEX_==-1
! ------------------------------------------------------------------------------------------------------------------------------
!> Provide the vertical index of the bottom layer for every horizontal point
! ------------------------------------------------------------------------------------------------------------------------------
subroutine set_bottom_index(self, indices)
class (type_fabm_model), intent(inout) :: self
!> Vertical indices.
!! Its shape must match that of the full horizontal domain as specified by the call to set_domain().
!! FABM will keep a pointer to this variable, which therefore needs to stay valid for the lifetime
!! of the model, or until the next call to set_bottom_index()
integer, target, intent(in) _ATTRIBUTES_GLOBAL_HORIZONTAL_ :: indices
integer :: i
if (self%status < status_set_domain_done) &
call fatal_error('set_bottom_index', 'set_domain has not yet been called on this model object.')
# if !defined(NDEBUG)&&_HORIZONTAL_DIMENSION_COUNT_>0
do i = 1, size(self%domain%horizontal_shape)
if (size(indices, i) /= self%domain%horizontal_shape(i)) &
call fatal_error('set_bottom_index', 'shape of provided index array does not match domain extents provided to set_domain.')
end do
# endif
self%domain%bottom_indices => indices
end subroutine set_bottom_index
#endif
! ------------------------------------------------------------------------------------------------------------------------------
!> Prepare for simulation start.
!! This tells FABM that the user/host have finished providing (or overriding)
!! data (link_data procedures) and have finished flagging diagnostics for
!! output (by setting the `save` flag that is part of the variable metadata)
! ------------------------------------------------------------------------------------------------------------------------------
subroutine start(self)
class (type_fabm_model), intent(inout), target :: self
integer :: ivar
logical :: ready
type (type_variable_node),pointer :: variable_node
type (type_link), pointer :: link
integer :: log_unit, ios
class (type_fabm_variable), pointer :: pvariables(:)
if (self%status < status_set_domain_done) then
call fatal_error('start', 'set_domain has not yet been called on this model object.')
return
elseif (self%status >= status_start_done) then
! start has been called on this model before and it must have succeeded to have this status.
! Reset store (e.g., all diagnostics) by setting each variable to its fill value and return.
! (this allows masked cells to be properly initialized if the mask changes between calls to start)
call reset_store(self)
return
end if
ready = .true.
#ifdef _HAS_MASK_
# ifndef _FABM_HORIZONTAL_MASK_
if (.not. associated(self%domain%mask)) then
call log_message('spatial mask has not been set. Make sure to call set_mask.')
ready = .false.
end if
# endif
if (.not. associated(self%domain%mask_hz)) then
call log_message('horizontal spatial mask has not been set. Make sure to call set_mask.')
ready = .false.
end if
#endif
#if defined(_FABM_DEPTH_DIMENSION_INDEX_)&&_FABM_BOTTOM_INDEX_==-1
if (.not. associated(self%domain%bottom_indices)) then
call log_message('bottom indices have not been set. Make sure to call set_bottom_index.')
ready = .false.
end if
#endif
! Flag variables that have had data asssigned (by user, host or FABM).
! This is done only now because the user/host had till this moment to provide (or override) model fields.
call flag_variables_with_data(self%variable_register%catalog%interior, self%catalog%interior_sources)
call flag_variables_with_data(self%variable_register%catalog%horizontal, self%catalog%horizontal_sources)
call flag_variables_with_data(self%variable_register%catalog%scalar, self%catalog%scalar_sources)
! Create job that ensures all diagnostics required by the user are computed.
! This is done only now because the user/host had till this moment to change the "save" flag of each diagnostic.
do ivar = 1, size(self%interior_diagnostic_variables)
if (self%interior_diagnostic_variables(ivar)%save) then
select case (self%interior_diagnostic_variables(ivar)%target%source)
case (source_check_state)
call self%check_interior_state_job%request_variable(self%interior_diagnostic_variables(ivar)%target, store=.true.)
case (source_get_vertical_movement)
call self%get_vertical_movement_job%request_variable(self%interior_diagnostic_variables(ivar)%target, store=.true.)
case default
call self%finalize_outputs_job%request_variable(self%interior_diagnostic_variables(ivar)%target, store=.true.)
end select
end if
end do
do ivar = 1, size(self%horizontal_diagnostic_variables)
if (self%horizontal_diagnostic_variables(ivar)%save) &
call self%finalize_outputs_job%request_variable(self%horizontal_diagnostic_variables(ivar)%target, store=.true.)
end do
log_unit = -1
if (self%log) log_unit = get_free_unit()
! Merge write indices when operations can be done in place
! This must be done after all variables are requested from the different jobs, so we know which variables
! will be needed separately (such variables cannot be merged)
if (self%log) then
open(unit=log_unit, file=log_prefix // 'merges.log', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'merges.log')
call merge_indices(self%root, log_unit)
close(log_unit)
else
call merge_indices(self%root)
end if
! Initialize all jobs. This also creates registers for the read and write caches, as well as the persistent store.
if (self%log) then
open(unit=log_unit, file=log_prefix // 'task_order.log', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'task_order.log')
end if
call self%job_manager%initialize(self%variable_register, self%schedules, log_unit, self%finalize_outputs_job)
if (self%log) then
close(log_unit)
open(unit=log_unit, file=log_prefix // 'graph.gv', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'graph.gv')
call self%job_manager%write_graph(log_unit)
close(log_unit)
end if
! Create persistent store. This provides memory for all variables to be stored there.
call create_store(self)
! Collect fill values and missing values for cache entries.
self%cache_fill_values = get_cache_fill_values(self%variable_register)
! Create global caches for exchanging information with BGC models.
! This can only be done after get_cache_fill_values completes, because that determines what values to prefill the cache with.
call cache_create(self%domain, self%cache_fill_values, self%cache_int)
call cache_create(self%domain, self%cache_fill_values, self%cache_hz)
call cache_create(self%domain, self%cache_fill_values, self%cache_vert)
! For diagnostics that are not needed, set their write index to 0 (rubbish bin)
if (self%log) then
open(unit=log_unit, file=log_prefix // 'discards.log', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'discards.log')
write (log_unit,'(a)') 'Writes for the following variables are discarded:'
end if
link => self%links_postcoupling%first
do while (associated(link))
if (.not. link%target%write_indices%is_empty() .and. link%target%write_indices%value == -1) then
call link%target%write_indices%set_value(0)
if (self%log) write (log_unit,'("- ",a)') trim(link%target%name)
end if
link => link%next
end do
if (self%log) close(log_unit)
if (self%log) then
open(unit=log_unit, file=log_prefix // 'register.log', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'register.log')
call self%variable_register%print(log_unit)
close(log_unit)
open(unit=log_unit, file=log_prefix // 'jobs.log', action='write', status='replace', iostat=ios)
if (ios /= 0) call fatal_error('start', 'Unable to open ' // log_prefix // 'jobs.log')
call self%job_manager%print(log_unit)
close(log_unit)
end if
! Report all unfulfilled dependencies.
variable_node => self%variable_register%unfulfilled_dependencies%first
do while (associated(variable_node))
call report_unfulfilled_dependency(variable_node%target)
variable_node => variable_node%next
end do
! Gather information for check_state routines in cache-friendly data structures
! NB intermediate pointer "pvariables" is needed to work around bug in PGI 19.1, 20.7
pvariables => self%interior_state_variables
call gather_check_state_data(pvariables, self%check_interior_state_data)
pvariables => self%surface_state_variables
call gather_check_state_data(pvariables, self%check_surface_state_data)
pvariables => self%bottom_state_variables
call gather_check_state_data(pvariables, self%check_bottom_state_data)
if (associated(self%variable_register%unfulfilled_dependencies%first) .or. .not. ready) &
call fatal_error('start', 'FABM is lacking required data.')
self%status = status_start_done
contains
subroutine gather_check_state_data(variables, dat)
class (type_fabm_variable), intent(in) :: variables(:)
type (type_check_state_data), allocatable :: dat(:)
allocate(dat(size(variables)))
do ivar = 1, size(variables)
dat(ivar)%index = variables(ivar)%target%read_indices%value