models.F90 13.2 KB
Newer Older
1 2 3 4 5 6 7 8
#include "fabm_driver.h"

module test_models

use fabm_types

implicit none

9
private
10

11 12 13 14 15 16
integer, parameter, public :: interior_state_offset = 0
integer, parameter, public :: surface_state_offset  = 1000
integer, parameter, public :: bottom_state_offset   = 2000

integer, parameter, public :: interior_dependency_offset = 3000
integer, parameter, public :: horizontal_dependency_offset = 4000
17 18 19

real(rk), parameter :: epsilon = 1e-14_rk

20
type, extends(type_base_model), public :: type_test_model
21 22 23 24
   type (type_state_variable_id),        allocatable :: id_state(:)
   type (type_surface_state_variable_id),allocatable :: id_surface_state(:)
   type (type_bottom_state_variable_id), allocatable :: id_bottom_state(:)

Jorn Bruggeman's avatar
Jorn Bruggeman committed
25 26 27
   type (type_diagnostic_variable_id),           allocatable :: id_diag(:)
   type (type_horizontal_diagnostic_variable_id),allocatable :: id_horizontal_diag(:)

28 29 30 31 32 33 34
   type (type_dependency_id)            :: id_dep
   type (type_dependency_id)            :: id_depth
   type (type_horizontal_dependency_id) :: id_hz_dep

   integer :: nstate         = 12
   integer :: nsurface_state = 11
   integer :: nbottom_state  = 10
Jorn Bruggeman's avatar
Jorn Bruggeman committed
35 36 37
   integer :: nint_diag      = 12
   integer :: nsurface_diag  = 4
   integer :: nbottom_diag   = 6
38
   integer :: nhz_diag_vert  = 3
Jorn Bruggeman's avatar
Jorn Bruggeman committed
39
   integer :: nint_diag_vert = 2
40 41
contains
   procedure :: initialize
42
   procedure :: do
43 44
   procedure :: do_surface
   procedure :: do_bottom
Jorn Bruggeman's avatar
Jorn Bruggeman committed
45
   procedure :: do_column
46
   procedure :: get_vertical_movement
47 48
end type

49 50 51 52 53
integer, save, public :: interior_loop_count = 0
integer, save, public :: surface_loop_count = 0
integer, save, public :: bottom_loop_count = 0
integer, save, public :: column_loop_count = 0
integer, save, public :: vertical_movement_loop_count = 0
54

55 56
type (type_universal_standard_variable), parameter :: state_total = type_universal_standard_variable(name='state', conserved=.true., aggregate_variable=.true.)

57 58 59 60 61 62 63 64
   contains

subroutine initialize(self,configunit)
   class (type_test_model), intent(inout), target :: self
   integer,                 intent(in)            :: configunit

   integer          :: i
   character(len=8) :: strindex
65
   real(rk) :: w
66 67 68 69

   allocate(self%id_state(self%nstate))
   do i=1,self%nstate
      write (strindex,'(i0)') i
70 71 72
      w = 0
      if (mod(i, 2) /= 0) w = -real(i+interior_state_offset,rk)
      call self%register_state_variable(self%id_state(i),'state'//trim(strindex),'','state variable #'//trim(strindex),vertical_movement=w, initial_value=1._rk+i+interior_state_offset, missing_value=-999._rk-interior_state_offset-i)
73
      call self%add_to_aggregate_variable(state_total, self%id_state(i))
74 75 76 77
   end do
   allocate(self%id_surface_state(self%nsurface_state))
   do i=1,self%nsurface_state
      write (strindex,'(i0)') i
78
      call self%register_state_variable(self%id_surface_state(i),'surface_state'//trim(strindex),'','surface state variable #'//trim(strindex), initial_value=1._rk+i+surface_state_offset, missing_value=-999._rk-surface_state_offset-i)
79
      call self%add_to_aggregate_variable(state_total, self%id_surface_state(i))
80 81 82 83
   end do
   allocate(self%id_bottom_state(self%nbottom_state))
   do i=1,self%nbottom_state
      write (strindex,'(i0)') i
84
      call self%register_state_variable(self%id_bottom_state(i),'bottom_state'//trim(strindex),'','bottom state variable #'//trim(strindex), initial_value=1._rk+i+bottom_state_offset, missing_value=-999._rk-bottom_state_offset-i)
85
      call self%add_to_aggregate_variable(state_total, self%id_bottom_state(i))
86 87 88 89
   end do
   call self%register_dependency(self%id_dep,standard_variables%temperature)
   call self%register_dependency(self%id_depth,standard_variables%depth)
   call self%register_dependency(self%id_hz_dep,standard_variables%wind_speed)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
90 91 92 93 94 95 96 97

   allocate(self%id_diag(self%nint_diag + self%nint_diag_vert))
   do i=1,self%nint_diag
      write (strindex,'(i0)') i
      call self%register_diagnostic_variable(self%id_diag(i),'diagnostic'//trim(strindex),'','diagnostic variable #'//trim(strindex),missing_value=-999._rk - i)
   end do
   do i=1,self%nint_diag_vert
      write (strindex,'(i0)') i
98
      call self%register_diagnostic_variable(self%id_diag(self%nint_diag + i),'vertical_diagnostic'//trim(strindex),'','vertical diagnostic variable #'//trim(strindex),missing_value=-1999._rk - i, source=source_do_column)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
99
   end do
100
   allocate(self%id_horizontal_diag(self%nsurface_diag + self%nbottom_diag + self%nhz_diag_vert))
Jorn Bruggeman's avatar
Jorn Bruggeman committed
101 102
   do i=1,self%nsurface_diag
      write (strindex,'(i0)') i
103
      call self%register_diagnostic_variable(self%id_horizontal_diag(i),'surface_diagnostic'//trim(strindex),'','surface diagnostic variable #'//trim(strindex),missing_value=-2999._rk - i,source=source_do_surface)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
104 105 106
   end do
   do i=1,self%nbottom_diag
      write (strindex,'(i0)') i
107 108 109 110
      call self%register_diagnostic_variable(self%id_horizontal_diag(self%nsurface_diag + i),'bottom_diagnostic'//trim(strindex),'','bottom diagnostic variable #'//trim(strindex),missing_value=-3999._rk - i,source=source_do_bottom)
   end do
   do i=1,self%nhz_diag_vert
      write (strindex,'(i0)') i
Jorn Bruggeman's avatar
Jorn Bruggeman committed
111
      call self%register_diagnostic_variable(self%id_horizontal_diag(self%nsurface_diag + self%nbottom_diag + i),'vert_hz_diagnostic'//trim(strindex),'','horizontal diagnostic variable set from do_column #'//trim(strindex),missing_value=-4999._rk - i,source=source_do_column)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
112
   end do
113 114
end subroutine initialize

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
subroutine do(self,_ARGUMENTS_DO_)
   class (type_test_model),intent(in) :: self
   _DECLARE_ARGUMENTS_DO_

   integer  :: i
   real(rk) :: value

   _LOOP_BEGIN_
      do i=1,self%nstate
         _GET_(self%id_state(i),value)
         if (value/=i+interior_state_offset) call self%fatal_error('do','invalid value of interior state variable.')
         _SET_ODE_(self%id_state(i),-value)
      end do

      do i=1,self%nsurface_state
         _GET_HORIZONTAL_(self%id_surface_state(i),value)
         if (value/=i+surface_state_offset) call self%fatal_error('do','invalid value of surface state variable.')
      end do

      do i=1,self%nbottom_state
         _GET_HORIZONTAL_(self%id_bottom_state(i),value)
         if (value/=i+bottom_state_offset) call self%fatal_error('do','invalid value of bottom state variable.')
      end do

      _GET_(self%id_dep,value)
      if (value/=1+interior_dependency_offset) call self%fatal_error('do','invalid value of interior dependency #1.')
      _GET_HORIZONTAL_(self%id_hz_dep,value)
      if (value/=1+horizontal_dependency_offset) call self%fatal_error('do','invalid value of horizontal dependency #1.')

Jorn Bruggeman's avatar
Jorn Bruggeman committed
144 145 146 147
      do i=1,self%nint_diag
         _SET_DIAGNOSTIC_(self%id_diag(i),999._rk+i)
      end do

148
      interior_loop_count = interior_loop_count + 1
149 150 151
   _LOOP_END_
end subroutine do

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
subroutine do_surface(self,_ARGUMENTS_DO_SURFACE_)
   class (type_test_model),intent(in) :: self
   _DECLARE_ARGUMENTS_DO_SURFACE_

   integer  :: i
   real(rk) :: value

   _HORIZONTAL_LOOP_BEGIN_
      do i=1,self%nstate
         _GET_(self%id_state(i),value)
         if (value/=i+interior_state_offset) call self%fatal_error('do_surface','invalid value of interior state variable.')
         _SET_SURFACE_EXCHANGE_(self%id_state(i),-value)
      end do

      do i=1,self%nsurface_state
         _GET_HORIZONTAL_(self%id_surface_state(i),value)
         if (value/=i+surface_state_offset) call self%fatal_error('do_surface','invalid value of surface state variable.')
         _SET_SURFACE_ODE_(self%id_surface_state(i),-value)
      end do

      do i=1,self%nbottom_state
         _GET_HORIZONTAL_(self%id_bottom_state(i),value)
         if (value/=i+bottom_state_offset) call self%fatal_error('do_surface','invalid value of bottom state variable.')
      end do

      _GET_(self%id_depth,value)
#ifdef _FABM_DEPTH_DIMENSION_INDEX_
       if (abs(value)>epsilon) call self%fatal_error('do_surface','depth should be 0.')
#else
       if (abs(value-2)>epsilon) call self%fatal_error('do_surface','depth should be 2.')
#endif

      _GET_(self%id_dep,value)
      if (value/=1+interior_dependency_offset) call self%fatal_error('do_surface','invalid value of interior dependency #1.')
      _GET_HORIZONTAL_(self%id_hz_dep,value)
      if (value/=1+horizontal_dependency_offset) call self%fatal_error('do_surface','invalid value of horizontal dependency #1.')

Jorn Bruggeman's avatar
Jorn Bruggeman committed
189
      do i=1,self%nsurface_diag
190
         _SET_HORIZONTAL_DIAGNOSTIC_(self%id_horizontal_diag(i),2999._rk+i)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
191 192
      end do

193
      surface_loop_count = surface_loop_count + 1
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
   _HORIZONTAL_LOOP_END_
end subroutine do_surface

subroutine do_bottom(self,_ARGUMENTS_DO_SURFACE_)
   class (type_test_model),intent(in) :: self
   _DECLARE_ARGUMENTS_DO_SURFACE_

   integer  :: i
   real(rk) :: value

   _HORIZONTAL_LOOP_BEGIN_
      do i=1,self%nstate
         _GET_(self%id_state(i),value)
         if (value/=i+interior_state_offset) call self%fatal_error('do_bottom','invalid value of interior state variable.')
         _SET_BOTTOM_EXCHANGE_(self%id_state(i),-value)
      end do

      do i=1,self%nsurface_state
         _GET_HORIZONTAL_(self%id_surface_state(i),value)
         if (value/=i+surface_state_offset) call self%fatal_error('do_bottom','invalid value of surface state variable.')
      end do

      do i=1,self%nbottom_state
         _GET_HORIZONTAL_(self%id_bottom_state(i),value)
         if (value/=i+bottom_state_offset) call self%fatal_error('do_bottom','invalid value of bottom state variable.')
         _SET_BOTTOM_ODE_(self%id_bottom_state(i),-value)
      end do

      _GET_(self%id_depth,value)
#ifdef _FABM_DEPTH_DIMENSION_INDEX_
       if (abs(value-1)>epsilon) call self%fatal_error('do_bottom','depth should be 1.')
#else
       if (abs(value-2)>epsilon) call self%fatal_error('do_bottom','depth should be 2.')
#endif

      _GET_(self%id_dep,value)
      if (value/=1+interior_dependency_offset) call self%fatal_error('do_bottom','invalid value of interior dependency #1.')
      _GET_HORIZONTAL_(self%id_hz_dep,value)
      if (value/=1+horizontal_dependency_offset) call self%fatal_error('do_bottom','invalid value of horizontal dependency #1.')

Jorn Bruggeman's avatar
Jorn Bruggeman committed
234
      do i=1,self%nbottom_diag
235
         _SET_HORIZONTAL_DIAGNOSTIC_(self%id_horizontal_diag(self%nsurface_diag + i),3999._rk+i)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
236 237
      end do

238
      bottom_loop_count = bottom_loop_count + 1
239 240 241
   _HORIZONTAL_LOOP_END_
end subroutine do_bottom

Jorn Bruggeman's avatar
Jorn Bruggeman committed
242
subroutine do_column(self, _ARGUMENTS_DO_COLUMN_)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
243
   class (type_test_model),intent(in) :: self
Jorn Bruggeman's avatar
Jorn Bruggeman committed
244
   _DECLARE_ARGUMENTS_DO_COLUMN_
Jorn Bruggeman's avatar
Jorn Bruggeman committed
245 246 247

   integer  :: i
   real(rk) :: value
248 249 250
   real(rk) :: old_depth

   old_depth = -1._rk
Jorn Bruggeman's avatar
Jorn Bruggeman committed
251

252 253
   do i=1,self%nsurface_state
      _GET_HORIZONTAL_(self%id_surface_state(i),value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
254
      if (value/=i+surface_state_offset) call self%fatal_error('do_column','invalid value of surface state variable.')
255 256 257 258
   end do

   do i=1,self%nbottom_state
      _GET_HORIZONTAL_(self%id_bottom_state(i),value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
259
      if (value/=i+bottom_state_offset) call self%fatal_error('do_column','invalid value of bottom state variable.')
260 261 262
   end do

   _GET_HORIZONTAL_(self%id_hz_dep,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
263
   if (value/=1+horizontal_dependency_offset) call self%fatal_error('do_column','invalid value of horizontal dependency #1.')
264

Jorn Bruggeman's avatar
Jorn Bruggeman committed
265 266 267
   _VERTICAL_LOOP_BEGIN_
      do i=1,self%nstate
         _GET_(self%id_state(i),value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
268
         if (value/=i+interior_state_offset) call self%fatal_error('do_column','invalid value of interior state variable.')
Jorn Bruggeman's avatar
Jorn Bruggeman committed
269 270 271
      end do

      _GET_(self%id_dep,value)
Jorn Bruggeman's avatar
Jorn Bruggeman committed
272
      if (value/=1+interior_dependency_offset) call self%fatal_error('do_column','invalid value of interior dependency #1.')
273 274 275

      _GET_(self%id_depth,value)
      if (value <= old_depth) &
Jorn Bruggeman's avatar
Jorn Bruggeman committed
276
          call self%fatal_error('do_column','depth is not increasing as expected.')
277
      old_depth = value
Jorn Bruggeman's avatar
Jorn Bruggeman committed
278 279

      do i=1,self%nint_diag_vert
280 281 282
         _SET_DIAGNOSTIC_(self%id_diag(self%nint_diag + i),1999._rk+i)
      end do

283
      column_loop_count = column_loop_count + 1
Jorn Bruggeman's avatar
Jorn Bruggeman committed
284
   _VERTICAL_LOOP_END_
285 286 287 288

   do i=1,self%nhz_diag_vert
      _SET_HORIZONTAL_DIAGNOSTIC_(self%id_horizontal_diag(self%nsurface_diag + self%nbottom_diag + i),4999._rk+i)
   end do
Jorn Bruggeman's avatar
Jorn Bruggeman committed
289
end subroutine do_column
Jorn Bruggeman's avatar
Jorn Bruggeman committed
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
subroutine get_vertical_movement(self,_ARGUMENTS_GET_VERTICAL_MOVEMENT_)
   class (type_test_model),intent(in) :: self
   _DECLARE_ARGUMENTS_GET_VERTICAL_MOVEMENT_

   integer  :: i
   real(rk) :: value

   _LOOP_BEGIN_
      do i=1,self%nstate
         _GET_(self%id_state(i),value)
         if (value/=i+interior_state_offset) call self%fatal_error('get_vertical_movement','invalid value of interior state variable.')
         if (mod(i, 2) == 0) _SET_VERTICAL_MOVEMENT_(self%id_state(i),real(i+interior_state_offset,rk))
      end do

      do i=1,self%nsurface_state
         _GET_HORIZONTAL_(self%id_surface_state(i),value)
         if (value/=i+surface_state_offset) call self%fatal_error('get_vertical_movement','invalid value of surface state variable.')
      end do

      do i=1,self%nbottom_state
         _GET_HORIZONTAL_(self%id_bottom_state(i),value)
         if (value/=i+bottom_state_offset) call self%fatal_error('get_vertical_movement','invalid value of bottom state variable.')
      end do

      _GET_(self%id_dep,value)
      if (value/=1+interior_dependency_offset) call self%fatal_error('get_vertical_movement','invalid value of interior dependency #1.')
      _GET_HORIZONTAL_(self%id_hz_dep,value)
      if (value/=1+horizontal_dependency_offset) call self%fatal_error('get_vertical_movement','invalid value of horizontal dependency #1.')
319

320
      vertical_movement_loop_count = vertical_movement_loop_count + 1
321 322 323
   _LOOP_END_
end subroutine get_vertical_movement

324
end module