hydro/Routing/Subsurface/module_subsurface.F

   1 module module_subsurface_data
   2
   3     use module_subsurface_state
   4     use module_subsurface_properties
   5     use module_subsurface_grid_transform
   6
   7     ! included to allow properties to be shared between overland and subsurface code
   8     use overland_data
   9
  10     implicit none
  11
  12     type subsurface_struct
  13
  14         type ( subsurface_state_interface), pointer :: state => null()
  15         type ( subsurface_properties_interface), pointer :: properties => null()
  16         type ( subsurface_grid_transform_interface), pointer :: grid_transform => null()
  17
  18         ! unused pointer are in an undefined state
  19         ! this means the result of calling associated(<pointer>)
  20         ! on a pointer that has not been set is unknown
  21         ! therefore associated can not be used as a guard
  22         ! in inital pointer allocation
  23         logical, private :: pointer_allocation_guard = .false.
  24
  25         contains
  26
  27         procedure :: init => subsurface_struct_init
  28         procedure :: destroy => subsurface_struct_destroy
  29
  30     end type subsurface_struct
  31
  32     contains
  33
  34     subroutine subsurface_struct_init(this,ix,jx,nsoil,overland_data)
  35         implicit none
  36         class(subsurface_struct), intent(inout) :: this ! the type object being initialized
  37         integer, intent(in) :: ix                     ! x grid size
  38         integer, intent(in) :: jx                     ! y grid size
  39         integer, intent(in) :: nsoil                  ! number of soil layers
  40         type(overland_struct), intent(inout) :: overland_data        ! overland data strucuture
  41
  42     if (this%pointer_allocation_guard .eqv. .false. ) then
  43         this%pointer_allocation_guard = .true.
  44         ! allocate the io interface
  45         allocate( this%state )
  46         if ( .not. associated( this%state) ) then
  47             write(0,*) "Failure to allocate subsurface io interface"
  48         else
  49             !write(0,*) "Allocating io structure"
  50             call this%state%init(ix,jx)
  51         end if
  52
  53         ! allocate the properties interface
  54         allocate( this%properties )
  55         if ( .not. associated( this%properties) ) then
  56             write(0,*) "Failure to allocate subsurface io interface"
  57         else
  58             !write(0,*) "Allocating properties structure"
  59             call this%properties%init(ix,jx,nsoil,overland_data)
  60         end if
  61
  62         ! allocate the grid_transfrom interface
  63         allocate( this%grid_transform )
  64         if ( .not. associated( this%grid_transform) ) then
  65             write(0,*) "Failure to allocate grid transform interface"
  66         else
  67             !write(0,*) "Allocating grid transform structure"
  68             call this%grid_transform%init(ix,jx,nsoil)
  69         end if
  70     else
  71         write(0,*)  "Attempt to double allocate subsurface_struct"
  72     end if
  73
  74     end subroutine subsurface_struct_init
  75
  76     subroutine subsurface_struct_destroy(this)
  77         implicit none
  78         class(subsurface_struct), intent(inout) :: this ! the type object being initialized
  79
  80         if ( this%pointer_allocation_guard .eqv. .true.) then
  81             !write(0,*) "Testing pointers for deallocation"
  82             if ( associated( this%state ) ) then
  83                 call this%state%destroy
  84                 deallocate( this%state )
  85             end if
  86
  87             if (associated( this%properties ) )then
  88                 call this%properties%destroy
  89                 deallocate( this%properties )
  90             end if
  91
  92             if (associated( this%grid_transform ) ) then
  93                 call this%grid_transform%destroy
  94                 deallocate( this%grid_transform )
  95             end if
  96
  97             this%pointer_allocation_guard = .false.
  98         else
  99             write(0,*)  "Attempt to double delete subsurface_struct"
 100         end if
 101
 102     end subroutine subsurface_struct_destroy
 103
 104 end module module_subsurface_data