fabm_standard_variables.F90 15.2 KB
Newer Older
1 2 3 4
! ====================================================================================================
! This module declares objects ("identities") for standard physical-biogeochemical variables
! that have a well-defined interpretation and unit.
!
5 6 7 8
! To use these identities, "use" the fabm_types module, which provides a single "standard_variables"
! variable (derived type) that has all standard identities as its members. This can then be used as
! standard_variables%temperature, standard_variables%wind_speed, etc.
! For a list of all supported variables, please see:
9
! https://github.com/fabm-model/fabm/wiki/List-of-standard-variables
10 11 12
!
! Biogeochemical models can use these "identity" objects in two ways. First, they can access the value
! of the corresponding variable by registering them as dependency. To do so, call register_dependency
13
! with the "identity" object (e.g., standard_variables%temperature) as argument.
14 15 16 17 18
! Additionally, biogeochemical models can assign a standard identities to their own variables during
! registration. FABM will couple all variables that have been assigned the same identity. Thus, using
! standard identities enables implicit variable coupling.
! ====================================================================================================
! The names of standard variables are based on the Standard Name Table from the NetCDF Climate and
19
! Forecast (CF) Metadata Convention. See http://cfconventions.org/.
20 21 22 23 24 25 26 27 28
! In deriving names from the CF convention, the following exceptions are made to account for the fact
! that FABM handles both marine and limnic systems and has the water column as default domain:
! - "sea_water_" prefix is suppressed.
! - "_in_sea_water" suffix is suppressed.
! - instead of the "_at_sea_floor" suffix a "bottom_" prefix is used, analogous to the "surface_"
!   prefix used in CF.
! - the "sea_floor_" prefix is replaced by a "bottom_" prefix.
! ====================================================================================================

29 30
module fabm_standard_variables

31 32
   implicit none

33
   private
34

35
   public type_base_standard_variable
36
   public type_universal_standard_variable, type_domain_specific_standard_variable, type_interior_standard_variable, type_horizontal_standard_variable, type_surface_standard_variable, type_bottom_standard_variable, type_global_standard_variable
37
   public type_standard_variable_node, type_standard_variable_set
38
   public standard_variables, initialize_standard_variables
39

40 41 42 43
   ! ====================================================================================================
   ! Data types that contain all metadata needed to describe standard variables.
   ! ====================================================================================================

Jorn Bruggeman's avatar
Jorn Bruggeman committed
44
   type type_base_standard_variable
45 46
      character(len=256) :: name  = ''    ! Name
      character(len=64)  :: units = ''    ! Units
47
      character(len=512) :: cf_names = '' ! Comma-separated list of standard names defined in the NetCDF CF convention
48
                                          ! (http://cfconventions.org/standard-names.html)
49 50
      logical            :: aggregate_variable = .false. ! Whether biogeochemical models can contribute (add to) this variable.
                                                         ! If .true., this variable is always available with a default value of 0.
Jorn Bruggeman's avatar
Jorn Bruggeman committed
51
      logical, private   :: resolved = .false.
52
   contains
53 54
      procedure :: resolve         => base_standard_variable_resolve
      procedure :: assert_resolved => base_standard_variable_assert_resolved
55
   end type
56

Jorn Bruggeman's avatar
Jorn Bruggeman committed
57 58
   type, extends(type_base_standard_variable) :: type_domain_specific_standard_variable
      type (type_universal_standard_variable), pointer :: universal => null()
59 60 61 62 63
   contains
      procedure :: typed_resolve => domain_specific_standard_variable_typed_resolve
   end type

   type, extends(type_domain_specific_standard_variable) :: type_interior_standard_variable
64
   end type
65

66
   type, extends(type_domain_specific_standard_variable) :: type_horizontal_standard_variable
67
   end type
68

69 70 71 72 73 74 75 76 77 78
   type, extends(type_horizontal_standard_variable) :: type_surface_standard_variable
   end type

   type, extends(type_horizontal_standard_variable) :: type_bottom_standard_variable
   end type

   type, extends(type_domain_specific_standard_variable) :: type_global_standard_variable
   end type

   type, extends(type_base_standard_variable) :: type_universal_standard_variable
Jorn Bruggeman's avatar
Jorn Bruggeman committed
79
      logical                                                    :: conserved = .false.          ! Whether this variable should be included in lists of conserved quantities.
Jorn Bruggeman's avatar
Jorn Bruggeman committed
80 81 82 83
      type (type_interior_standard_variable),   pointer, private :: pin_interior   => null()
      type (type_horizontal_standard_variable), pointer, private :: pat_interfaces => null()
      type (type_surface_standard_variable),    pointer, private :: pat_surface    => null()
      type (type_bottom_standard_variable),     pointer, private :: pat_bottom     => null()
84 85 86 87 88 89
   contains
      procedure :: typed_resolve => universal_standard_variable_typed_resolve
      procedure :: in_interior   => universal_standard_variable_in_interior
      procedure :: at_interfaces => universal_standard_variable_at_interfaces
      procedure :: at_surface    => universal_standard_variable_at_surface
      procedure :: at_bottom     => universal_standard_variable_at_bottom
90
   end type
91

92
   type type_standard_variable_node
93 94
      class (type_base_standard_variable), pointer :: p    => null()
      type (type_standard_variable_node),  pointer :: next => null()
95 96 97 98 99 100 101
   end type

   type type_standard_variable_set
      type (type_standard_variable_node), pointer :: first => null()
   contains
      procedure :: contains_variable => standard_variable_set_contains_variable
      procedure :: contains_name     => standard_variable_set_contains_name
102
      generic   :: contains => contains_variable, contains_name
103 104 105 106 107
      procedure :: add      => standard_variable_set_add
      procedure :: update   => standard_variable_set_update
      procedure :: finalize => standard_variable_set_finalize
   end type

108
   type type_standard_variable_collection
109
      type (type_standard_variable_node), pointer :: first => null()
110
#include "standard_variables.h"
111 112 113
   end type

   ! Single instance of the collection that contains all standard variables.
114
   type (type_standard_variable_collection), save :: standard_variables
115 116 117

contains

118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
   function base_standard_variable_resolve(self) result(p)
      class (type_base_standard_variable), intent(in), target :: self
      class (type_base_standard_variable), pointer            :: p

      type (type_standard_variable_node), pointer :: node

      if (self%resolved) then
         p => self
         return
      end if

      node => standard_variables%first
      do while (associated(node))
         if (compare(self, node%p)) then
            p => node%p
            return
         end if
         node => node%next
      end do

      allocate(p, source=self)
      call add(p)
140

141 142 143 144 145 146
   contains

      logical function compare(variable1, variable2)
         class (type_base_standard_variable), intent(in) :: variable1, variable2

         ! Compare the type of the standard variables.
147
         compare = same_type_as(variable1, variable2) .or. extends_type_of(variable1, variable2) .or. extends_type_of(variable2, variable1)
148 149 150 151 152 153 154 155

         ! Compare the metadata of the standard variables.
         if (compare) compare = (variable1%name  == '' .or. variable2%name  == '' .or. variable1%name  == variable2%name ) &
                          .and. (variable1%units == '' .or. variable2%units == '' .or. variable1%units == variable2%units)
      end function

   end function base_standard_variable_resolve

156 157 158
   subroutine add_child(standard_variable, name, units, universal)
      class (type_domain_specific_standard_variable), target :: standard_variable
      character(len=*), intent(in)                           :: name, units
Jorn Bruggeman's avatar
Jorn Bruggeman committed
159
      type (type_universal_standard_variable),        target :: universal
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
      standard_variable%name = name
      standard_variable%units = units
      standard_variable%aggregate_variable = universal%aggregate_variable
      standard_variable%universal => universal
      call add(standard_variable)
   end subroutine

   recursive subroutine add(standard_variable)
      class (type_base_standard_variable), target, intent(inout) :: standard_variable

      type (type_standard_variable_node), pointer :: node

      select type (standard_variable)
      class is (type_universal_standard_variable)
         allocate(standard_variable%pin_interior, standard_variable%pat_surface, standard_variable%pat_bottom, standard_variable%pat_interfaces)
         call add_child(standard_variable%pin_interior,   trim(standard_variable%name),                     standard_variable%units, standard_variable)
         call add_child(standard_variable%pat_surface,    trim(standard_variable%name) // '_at_surface',    trim(standard_variable%units) // '*m', standard_variable)
         call add_child(standard_variable%pat_bottom,     trim(standard_variable%name) // '_at_bottom',     trim(standard_variable%units) // '*m', standard_variable)
         call add_child(standard_variable%pat_interfaces, trim(standard_variable%name) // '_at_interfaces', trim(standard_variable%units) // '*m', standard_variable)
      end select

      allocate(node)
      node%p => standard_variable
      node%next => standard_variables%first
      standard_variables%first => node
      standard_variable%resolved = .true.
   end subroutine

188 189 190 191 192 193 194 195 196 197 198 199 200 201
   function universal_standard_variable_typed_resolve(self) result(p)
      class (type_universal_standard_variable), target  :: self
      class (type_universal_standard_variable), pointer :: p
      class (type_base_standard_variable), pointer :: presolved
      presolved => self%resolve()
      select type (presolved)
      class is (type_universal_standard_variable)
         p => presolved
#ifndef NDEBUG
      class default
         write (*,*) 'universal_standard_variable_typed_resolve: BUG wrong type returned'
         stop 1
#endif
      end select
202 203
   end function

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
   function universal_standard_variable_in_interior(self) result(p)
      class (type_universal_standard_variable), target  :: self
      class (type_interior_standard_variable), pointer :: p
      class (type_universal_standard_variable), pointer  :: presolved
      presolved => self%typed_resolve()
      p => presolved%pin_interior
   end function

   function universal_standard_variable_at_surface(self) result(p)
      class (type_universal_standard_variable), target  :: self
      class (type_surface_standard_variable), pointer :: p
      class (type_universal_standard_variable), pointer  :: presolved
      presolved => self%typed_resolve()
      p => presolved%pat_surface
   end function

   function universal_standard_variable_at_bottom(self) result(p)
      class (type_universal_standard_variable), target  :: self
      class (type_bottom_standard_variable), pointer :: p
      class (type_universal_standard_variable), pointer  :: presolved
      presolved => self%typed_resolve()
      p => presolved%pat_bottom
   end function

   function universal_standard_variable_at_interfaces(self) result(p)
      class (type_universal_standard_variable), target  :: self
      class (type_horizontal_standard_variable), pointer :: p
      class (type_universal_standard_variable), pointer  :: presolved
      presolved => self%typed_resolve()
      p => presolved%pat_interfaces
   end function

   function domain_specific_standard_variable_typed_resolve(self) result(p)
      class (type_domain_specific_standard_variable), target  :: self
      class (type_domain_specific_standard_variable), pointer :: p
      class (type_base_standard_variable), pointer :: pbase
      pbase => self%resolve()
      select type (pbase)
      class is (type_domain_specific_standard_variable)
         p => pbase
#ifndef NDEBUG
      class default
         write (*,*) 'domain_specific_standard_variable_typed_resolve: BUG wrong type returned'
         stop 1
#endif
249
      end select
250 251 252 253
   end function

   subroutine base_standard_variable_assert_resolved(self)
      class (type_base_standard_variable), intent(in) :: self
254

255 256 257 258
      if (self%resolved) return
      write (*,*) 'FATAL ERROR: standard_variable_collection_assert_contains: "' // trim(self%name) // '" not in standard variable collection."'
      stop 1
   end subroutine
259

260 261 262
   subroutine initialize_standard_variables()
#include "standard_variable_assignments.h"
   end subroutine
263

264 265
   logical function standard_variable_set_contains_variable(self, standard_variable)
      class (type_standard_variable_set),  intent(in) :: self
266
      class (type_base_standard_variable), target     :: standard_variable
267 268 269

      type (type_standard_variable_node), pointer :: node

270 271 272
#ifndef NDEBUG
      call standard_variable%assert_resolved()
#endif
273 274 275
      standard_variable_set_contains_variable = .true.
      node => self%first
      do while (associated(node))
276 277 278 279
#ifndef NDEBUG
         call node%p%assert_resolved()
#endif
         if (associated(node%p, standard_variable)) return
280 281 282 283 284
         node => node%next
      end do
      standard_variable_set_contains_variable = .false.
   end function standard_variable_set_contains_variable

285 286 287
   logical function standard_variable_set_contains_name(self, name)
      class (type_standard_variable_set), intent(in) :: self
      character(len=*),                   intent(in) :: name
288 289 290 291 292 293

      type (type_standard_variable_node), pointer :: node

      standard_variable_set_contains_name = .true.
      node => self%first
      do while (associated(node))
294
         if (node%p%name == name) return
295 296 297 298 299
         node => node%next
      end do
      standard_variable_set_contains_name = .false.
   end function standard_variable_set_contains_name

300 301
   subroutine standard_variable_set_add(self, standard_variable)
      class (type_standard_variable_set),  intent(inout) :: self
302
      class (type_base_standard_variable), target        :: standard_variable
303 304 305

      type (type_standard_variable_node), pointer :: node

306 307 308 309
#ifndef NDEBUG
      call standard_variable%assert_resolved()
#endif

310 311
      if (self%contains(standard_variable)) return

312
      if (.not. associated(self%first)) then
313 314 315 316 317 318 319 320 321 322
         allocate(self%first)
         node => self%first
      else
         node => self%first
         do while (associated(node%next))
            node => node%next
         end do
         allocate(node%next)
         node => node%next
      end if
323
      node%p => standard_variable
324 325
   end subroutine standard_variable_set_add

326 327 328
   subroutine standard_variable_set_update(self, other)
      class (type_standard_variable_set), intent(inout) :: self
      class (type_standard_variable_set), intent(in)    :: other
329 330 331 332 333 334 335 336 337 338 339

      type (type_standard_variable_node), pointer :: node

      node => other%first
      do while (associated(node))
         call self%add(node%p)
         node => node%next
      end do
   end subroutine standard_variable_set_update

   subroutine standard_variable_set_finalize(self)
340
      class (type_standard_variable_set), intent(inout) :: self
341

342
      type (type_standard_variable_node), pointer :: node, next_node
343 344 345 346 347 348 349 350 351 352

      node => self%first
      do while (associated(node))
         next_node => node%next
         deallocate(node)
         node => next_node
      end do
      self%first => null()
   end subroutine standard_variable_set_finalize

353
end module fabm_standard_variables