Observe.f90

Go to the documentation of this file.

!> @brief This module contains the derived types ObserveType and ObsDataType
!!
!! This module contains the derived types ObserveType and ObsDataType.
!!
!! - ObserveType -- is designed to contain all information and
!!   functionality needed for one observation. ObserveType contains a
!!   pointer to an ObsDataType object.
!!
!! - ObsDataType -- is for storing package ID, observation type, and a
!!   pointer to a subroutine that will be called to process the IDstring
!!   provided in Obs input.  The ProcessIdPtr member of ObsDataType
!!   requires a pointer to an ObserveType object.
!!
!<
module observemodule
 
  use kindmodule, only: dp, i4b
  use basedismodule, only: disbasetype
  use constantsmodule, only: lenboundname, lenobsname, lenobstype, &
                             maxobstypes, dnodata, dzero
  use tablemodule, only: tabletype
  use inputoutputmodule, only: urword
  use listmodule, only: listtype
  use simmodule, only: store_warning, store_error, &
                       store_error_unit
  use tdismodule, only: totim, totalsimtime
  use arrayhandlersmodule, only: expandarraywrapper
 
  implicit none
 
  private
  public :: observetype, constructobservation, obsdatatype, &
            addobstolist, getobsfromlist
 
  type :: observetype
    ! -- Public members
    !
    ! -- For all observations
    integer(I4B), public :: nodenumber = 0 !< observation node number
    integer(I4B), public :: unitnumber = 0 !< observation output unit number
    character(len=LENOBSNAME), public :: name = '' !< observation name
    character(len=LENOBSTYPE), public :: obstypeid = '' !< observation type id
    character(len=200), public :: idstring = '' !< observation id string
    character(len=LENBOUNDNAME), public :: featurename = '' !< observation feature name
    character(len=LENBOUNDNAME), public :: featurename2 = '' !< observation feature name 2
    !
    ! -- members specific to NPF intercell-flow observations
    integer(I4B), public :: nodenumber2 = 0 !< observation second nod number
    integer(I4B), public :: jaindex = -2 !< observation JA index
    !
    ! -- members that can be used as needed by packages or models
    integer(I4B), public :: intpak1 = 0 !<
    real(dp), public :: obsdepth = dzero !<
    real(dp), public :: dblpak1 = dzero !<
    !
    ! -- indxbnds is intended to hold indices of position(s) in bound
    !    array of boundaries included in the observation.
    integer(I4B), public :: indxbnds_count = 0 !< number of observations indexes when using boundname
    integer(I4B), allocatable, dimension(:), public :: indxbnds !< node numbers for observations when using boundname
    !
    ! -- Set FormattedOutput false if output unit is opened for unformatted i/o
    logical, public :: formattedoutput = .true. !< logical indicating if observation output is formatted
    logical, public :: bndfound = .false. !< logical indicating if a boundname was found
    real(dp), public :: currenttimestependvalue = dzero !< observation value
    real(dp), public :: currenttimestependtime = dzero !< observation time
    !
    ! -- Members specific to continuous observations
    integer(I4B), public :: indxobsoutput = -1 !< index for observation output
    !
    ! -- Private members
    type(obsdatatype), pointer, private :: obsdatum => null() !< observation Datum
  contains
    ! -- Public procedures
    procedure, public :: resetcurrentvalue
    procedure, public :: writeto
    procedure, public :: addobsindex
    procedure, public :: resetobsindex
    procedure, public :: da
  end type observetype
 
  type :: obsdatatype
    ! -- Public members
    character(len=LENOBSTYPE), public :: obstypeid = '' !< observation type id
    logical, public :: cumulative = .false. !< logical indicating if observations should be summed
    procedure(processidsub), nopass, pointer, public :: processidptr => null() !< process id pointer
  end type obsdatatype
 
  abstract interface
 
    !> @ brief Process user-provided IDstring
  !!
  !!  Subroutine that processes the user-provided IDstring, which identifies
  !!  the grid location or model feature to be observed.
  !!
    !<
    subroutine processidsub(obsrv, dis, inunitobs, iout)
      use kindmodule, only: dp, i4b
      import :: observetype
      import :: disbasetype
      ! -- dummy
      type(observetype), intent(inout) :: obsrv !< observation type
      class(disbasetype), intent(in) :: dis !< discretization object
      integer(I4B), intent(in) :: inunitobs !< observation input file unit
      integer(I4B), intent(in) :: iout !< model list file unit
    end subroutine processidsub
  end interface
 
contains
 
  ! Procedures bound to ObserveType
 
  !> @ brief Reset current observation value
  !!
  !!  Subroutine to reset the current observation value.
  !!
  !<
  subroutine resetcurrentvalue(this)
    ! -- dummy
    class(observetype), intent(inout) :: this
    !
    ! -- Reset current value to zero.
    this%CurrentTimeStepEndValue = dzero
    !
    ! -- return
    return
  end subroutine resetcurrentvalue
 
  !> @ brief Write observation input data
  !!
  !!  Subroutine to write observation input data to a table in the model
  !!  list file.
  !!
  !<
  subroutine writeto(this, obstab, btagfound, fnamein)
    ! -- dummy
    class(observetype), intent(inout) :: this
    type(tabletype), intent(inout) :: obstab !< observation table
    character(len=*), intent(in) :: btagfound !< logical indicating if boundname was found
    character(len=*), intent(in) :: fnamein !< observation input file name
    ! -- local
    character(len=12) :: tag
    character(len=80) :: fnameout
    !
    ! -- write btagfound to tag
    if (len_trim(btagfound) > 12) then
      tag = btagfound(1:12)
    else
      write (tag, '(a12)') btagfound
    end if
    !
    ! -- write fnamein to fnameout
    if (len_trim(fnamein) > 80) then
      fnameout = fnamein(1:80)
    else
      write (fnameout, '(a80)') fnamein
    end if
    !
    ! -- write data to observation table
    call obstab%add_term(this%Name)
    call obstab%add_term(tag//trim(this%ObsTypeId))
    call obstab%add_term('ALL TIMES')
    call obstab%add_term('"'//trim(this%IDstring)//'"')
    call obstab%add_term(fnameout)
    !
    ! -- return
    return
  end subroutine writeto
 
  !> @ brief Reset a observation index
  !!
  !!  Subroutine to reset the observation index count and array.
  !!
  !<
  subroutine resetobsindex(this)
    ! -- dummy
    class(observetype), intent(inout) :: this
    !
    ! -- Reset the index count
    this%indxbnds_count = 0
    !
    ! -- Deallocate observation index array, if necessary
    if (allocated(this%indxbnds)) then
      deallocate (this%indxbnds)
    end if
    !
    ! -- Allocate observation index array to size 0
    allocate (this%indxbnds(0))
    !
    ! -- return
    return
  end subroutine resetobsindex
 
  !> @ brief Add a observation index
  !!
  !!  Subroutine to add the observation index to the observation index
  !!  array (indxbnds). The observation index count (indxbnds_count) is
  !!  also incremented by one and the observation index array is
  !!  expanded, if necessary.
  !!
  !<
  subroutine addobsindex(this, indx)
    ! -- dummy
    class(observetype), intent(inout) :: this
    integer(I4B), intent(in) :: indx !< observation index
    !
    ! -- Increment the index count
    this%indxbnds_count = this%indxbnds_count + 1
    !
    ! -- Expand the observation index array, if necessary
    call expandarraywrapper(this%indxbnds_count, this%indxbnds, loginc=.true.)
    !
    ! -- add index to observation index
    this%indxbnds(this%indxbnds_count) = indx
    !
    ! -- return
    return
  end subroutine addobsindex
 
  !> @ brief Deallocate a observation
  !!
  !!  Subroutine to deallocated a observation (ObserveType).
  !!
  !<
  subroutine da(this)
    ! -- dummy
    class(observetype), intent(inout) :: this
    if (allocated(this%indxbnds)) then
      deallocate (this%indxbnds)
    end if
    !
    ! -- return
    return
  end subroutine da
 
  ! Non-type-bound procedures
 
  !> @ brief Construct a new ObserveType
  !!
  !!  Subroutine to construct and return an ObserveType object based
  !!  on the contents of defLine.
  !!
  !<
  subroutine constructobservation(newObservation, defLine, numunit, &
                                  formatted, indx, obsData, inunit)
    ! -- dummy variables
    type(observetype), pointer :: newobservation !< new ObserveType
    character(len=*), intent(in) :: defline !< string with observation data
    integer(I4B), intent(in) :: numunit !< Output unit number
    logical, intent(in) :: formatted !< logical indicating if formatted output will be written
    integer(I4B), intent(in) :: indx !< Index in ObsOutput array
    type(obsdatatype), dimension(:), pointer, intent(in) :: obsdata !< obsData type
    integer(I4B), intent(in) :: inunit !< observation input file unit
    ! -- local
    real(dp) :: r
    integer(I4B) :: i
    integer(I4B) :: icol
    integer(I4B) :: iout
    integer(I4B) :: istart
    integer(I4B) :: istop
    integer(I4B) :: n
    !
    ! -- initialize
    iout = 0
    icol = 1
    !
    ! -- Allocate an ObserveType object.
    allocate (newobservation)
    allocate (newobservation%indxbnds(0))
    !
    ! -- Set indxbnds_count to 0
    newobservation%indxbnds_count = 0
    !
    ! -- Define the contents of the ObservationSingleType object based on the
    !    contents of defLine.
    !
    ! -- Get observation name and store it
    call urword(defline, icol, istart, istop, 1, n, r, iout, inunit)
    newobservation%Name = defline(istart:istop)
    !
    ! -- Get observation type, convert it to uppercase, and store it.
    call urword(defline, icol, istart, istop, 1, n, r, iout, inunit)
    newobservation%ObsTypeId = defline(istart:istop)
    !
    ! -- Look up package ID for this observation type and store it
    do i = 1, maxobstypes
      if (obsdata(i)%ObsTypeID == newobservation%ObsTypeId) then
        newobservation%obsDatum => obsdata(i)
        exit
      elseif (obsdata(i)%ObsTypeID == '') then
        exit
      end if
    end do
    !
    ! -- Remaining text is ID [and ID2]; store the remainder of the string
    istart = istop + 1
    istop = len_trim(defline)
    if (istart > istop) then
      istart = istop
    end if
    newobservation%IDstring = defline(istart:istop)
    !
    ! Store UnitNumber, FormattedOutput, and IndxObsOutput
    newobservation%UnitNumber = numunit
    newobservation%FormattedOutput = formatted
    newobservation%IndxObsOutput = indx
    !
    ! -- return
    return
  end subroutine constructobservation
 
  !> @ brief Cast a object as a ObserveType
  !!
  !!  Function to cast an object as a ObserveType object.
  !!
  !<
  function castasobservetype(obj) result(res)
    ! -- dummy
    class(*), pointer, intent(inout) :: obj !< object
    ! -- return
    type(observetype), pointer :: res !< returned ObserveType object
    !
    res => null()
    if (.not. associated(obj)) return
    !
    select type (obj)
    type is (observetype)
      res => obj
    end select
    !
    ! -- return
    return
  end function castasobservetype
 
  !> @ brief Add a ObserveType to a list
  !!
  !!  Subroutine to add a ObserveType to a list.
  !!
  !<
  subroutine addobstolist(list, obs)
    ! -- dummy
    type(listtype), intent(inout) :: list !< ObserveType list
    type(observetype), pointer, intent(inout) :: obs !< ObserveType
    ! -- local
    class(*), pointer :: obj
    !
    obj => obs
    call list%Add(obj)
    !
    ! -- return
    return
  end subroutine addobstolist
 
  !> @ brief Get an ObserveType from a list
  !!
  !!  Function to get an ObserveType from a list.
  !!
  !<
  function getobsfromlist(list, idx) result(res)
    ! -- dummy
    type(listtype), intent(inout) :: list !< ObserveType list
    integer(I4B), intent(in) :: idx !< ObserveType list index
    ! -- return
    type(observetype), pointer :: res !< returned ObserveType
    ! -- local
    class(*), pointer :: obj
    !
    obj => list%GetItem(idx)
    res => castasobservetype(obj)
    !
    ! -- return
    return
  end function getobsfromlist
 
end module observemodule