direct_soil_moisture__gridded_data.F90

Go to the documentation of this file.

!> @file
!! Contains the module \ref direct_soil_moisture__gridded_data.
 
!>
!!  Module \ref direct_soil_moisture__gridded_data
!!  provides support for adding miscellaneous source and sink terms.
 
module direct_soil_moisture__gridded_data
 
  use iso_c_binding
  use constants_and_conversions
  use datetime
  use data_catalog
  use data_catalog_entry
  use dictionary
  use exceptions
  use file_operations
  use netcdf4_support
  use parameters, only          : params
  use simulation_datetime
  use fstring
  use fstring_list
 
  implicit none
 
  private
 
  public :: direct_soil_moisture_initialize, direct_soil_moisture_calculate
 
  type (data_catalog_entry_t), pointer :: pseptic_discharge
  type (data_catalog_entry_t), pointer :: pannual_septic_discharge
 
  real (c_float), allocatable     :: fseptic_discharge(:)
  real (c_float), allocatable     :: fannual_septic_discharge(:)
 
  real (c_float), allocatable     :: fseptic_discharge_table(:)
  real (c_float), allocatable     :: fannual_septic_discharge_table(:)
 
  type ( datetime_t )                  :: date_of_last_retrieval
 
contains
 
  !> Initialize the routine to enable input/output of arbitrary sources/sink terms
  !! to be added directly to SOIL MOISTURE.
  !!
  !! Open gridded data file.
  !! Open a NetCDF output file to hold variable output.
  !!
  !! @param[in] lActive 2D array of active cells within the model domain.
  !! @param[in] iLanduseIndex 1D vector of indices corresponding to rows of the
  !!            landuse lookup table(s).
  !! @param[in] dX 1D vector of X coordinates associated with the model domain.
  !! @param[in] dY 1D vector of Y coordinates.
  !! @param[in] dX_lon 2D array of longitude values.
  !! @param[in] dY_lat 2D array of latitude values.
 
  subroutine direct_soil_moisture_initialize( is_cell_active, landuse_index )
 
    logical (c_bool), intent(in)     :: is_cell_active(:,:)
    integer (c_int), intent(in)      :: landuse_index(:)
 
    ! [ LOCALS ]
    integer (c_int)                 :: istat
    type (fstring_list_t)            :: parameter_list
    integer (c_int)                 :: iindex
    integer (c_int), allocatable    :: ilandusecodes(:)
    integer (c_int)                 :: inumberoflanduses
    logical (c_bool)                :: larelengthsequal
 
 
    !> Determine how many landuse codes are present
    call parameter_list%append( "LU_Code" )
    call parameter_list%append( "Landuse_Code" )
 
    call params%get_parameters( slkeys=parameter_list, ivalues=ilandusecodes )
    inumberoflanduses = count( ilandusecodes > 0 )
 
    call parameter_list%clear()
    call parameter_list%append( "Septic_system_discharge" )
    call parameter_list%append( "SEPTIC_DISCHARGE" )
    call parameter_list%append( "Daily_septic_discharge" )
 
    call params%get_parameters( slkeys=parameter_list , fvalues=fseptic_discharge_table )
 
    ! attempt to find a source of GRIDDED SEPTIC DISCHARGE data
    pseptic_discharge => dat%find( "SEPTIC_DISCHARGE" )
 
    ! look for data in the form of a grid
    if ( associated( pseptic_discharge ) ) then
 
      allocate( fseptic_discharge( count( is_cell_active ) ), stat=istat )
      call assert( istat==0, "Problem allocating memory", __file__, __line__ )
 
    ! no grid? then look for a table version; values > TINYVAL indicate that
    ! something is present
    elseif ( fseptic_discharge_table(1) > ftinyval ) then
 
      larelengthsequal = ( ( ubound(fseptic_discharge_table,1) == ubound(ilandusecodes,1) )  )
 
      if ( .not. larelengthsequal )     &
        call warn( smessage="The number of landuses does not match the number of annual direct"   &
          //" recharge rate values.", smodule=__file__, iline=__line__, lfatal=.true._c_bool )
 
      allocate( fseptic_discharge( count( is_cell_active ) ), stat=istat )
      call assert( istat==0, "Problem allocating memory", __file__, __line__ )
 
      ! now populate the vector of cell values
      do iindex=lbound( landuse_index, 1 ), ubound( landuse_index, 1 )
        fseptic_discharge( iindex ) = fseptic_discharge_table( landuse_index( iindex ) )
      enddo
 
     endif
 
    call parameter_list%clear()
    call parameter_list%append( "ANNUAL_septic_system_discharge" )
    call parameter_list%append( "ANNUAL_SEPTIC_DISCHARGE" )
    call parameter_list%append( "ANNUAL_septic_discharge" )
 
    call params%get_parameters( slkeys=parameter_list , fvalues=fannual_septic_discharge_table )
 
    ! attempt to find a source of GRIDDED ANNUAL SEPTIC DISCHARGE data
    pannual_septic_discharge => dat%find( "ANNUAL_SEPTIC_DISCHARGE" )
 
    ! look for data in the form of a grid
    if ( associated( pannual_septic_discharge ) ) then
 
      allocate( fannual_septic_discharge( count( is_cell_active ) ), stat=istat )
      call assert( istat==0, "Problem allocating memory", __file__, __line__ )
 
    ! no grid? then look for a table version; values > TINYVAL indicate that
    ! something is present
    elseif ( fannual_septic_discharge_table(1) > ftinyval ) then
 
      larelengthsequal = ( ( ubound(fannual_septic_discharge_table,1) == ubound(ilandusecodes,1) )  )
 
      if ( .not. larelengthsequal )     &
        call warn( smessage="The number of landuses does not match the number of annual direct"   &
          //" recharge rate values.", smodule=__file__, iline=__line__, lfatal=.true._c_bool )
 
      allocate( fannual_septic_discharge( count( is_cell_active ) ), stat=istat )
      call assert( istat==0, "Problem allocating memory", __file__, __line__ )
 
      ! now populate the vector of cell values
      do iindex=lbound( landuse_index, 1 ), ubound( landuse_index, 1 )
        fannual_septic_discharge( iindex ) = fannual_septic_discharge_table( landuse_index( iindex ) )
      enddo
 
     endif
 
     ! initialize last retrieval date to something implausibly low to trigger initial read
     ! in the calculate procedure
     call date_of_last_retrieval%parseDate("01/01/1000")
 
  end subroutine direct_soil_moisture_initialize
 
!--------------------------------------------------------------------------------------------------
 
  subroutine direct_soil_moisture_calculate( direct_soil_moisture, is_cell_active, indx )
 
    real (c_float), intent(inout)     :: direct_soil_moisture
    logical (c_bool), intent(in)      :: is_cell_active(:,:)
    integer (c_int), intent(in)       :: indx
 
    ! [ LOCALS ]
 
    if ( .not. date_of_last_retrieval == sim_dt%curr ) then
 
      associate( dt => sim_dt%curr )
 
        if ( associated( pseptic_discharge ) ) then
          call pseptic_discharge%getvalues( dt )
          if ( pseptic_discharge%lGridHasChanged ) fseptic_discharge =                   &
               pack( pseptic_discharge%pGrdBase%rData, is_cell_active )
        endif
 
        if ( associated( pannual_septic_discharge ) ) then
          call pannual_septic_discharge%getvalues( dt )
          if ( pannual_septic_discharge%lGridHasChanged ) fannual_septic_discharge =     &
              pack( pannual_septic_discharge%pGrdBase%rData, is_cell_active )
        endif
 
      end associate
 
      date_of_last_retrieval = sim_dt%curr
 
    endif
 
    direct_soil_moisture = 0.0_c_float
 
    if ( allocated( fseptic_discharge) )  direct_soil_moisture = direct_soil_moisture           &
                                            + fseptic_discharge( indx )
    if ( allocated( fannual_septic_discharge) )  direct_soil_moisture = direct_soil_moisture    &
                                            + fannual_septic_discharge( indx ) / 365.25
 
 
  end subroutine direct_soil_moisture_calculate
 
end module direct_soil_moisture__gridded_data