prt-fmi.f90

Go to the documentation of this file.

module prtfmimodule
 
  use kindmodule, only: dp, i4b
  use constantsmodule, only: dzero, lenauxname, lenpackagename
  use simmodule, only: store_error, store_error_unit
  use simvariablesmodule, only: errmsg
  use flowmodelinterfacemodule, only: flowmodelinterfacetype
  use basedismodule, only: disbasetype
  use budgetobjectmodule, only: budgetobjecttype
  use cellmodule, only: max_poly_cells
 
  implicit none
  private
  public :: prtfmitype
  public :: fmi_cr
 
  character(len=LENPACKAGENAME) :: text = '    PRTFMI'
 
  type, extends(flowmodelinterfacetype) :: prtfmitype
 
    double precision, allocatable, public :: sourceflows(:) ! cell source flows array
    double precision, allocatable, public :: sinkflows(:) ! cell sink flows array
    double precision, allocatable, public :: storageflows(:) ! cell storage flows array
    double precision, allocatable, public :: boundaryflows(:) ! cell boundary flows array
 
  contains
 
    procedure :: fmi_ad
    procedure :: fmi_df => prtfmi_df
    procedure, private :: accumulate_flows
 
  end type prtfmitype
 
contains
 
  !> @brief Create a new PrtFmi object
  subroutine fmi_cr(fmiobj, name_model, inunit, iout)
    ! -- dummy
    type(prtfmitype), pointer :: fmiobj
    character(len=*), intent(in) :: name_model
    integer(I4B), intent(inout) :: inunit
    integer(I4B), intent(in) :: iout
    !
    ! -- Create the object
    allocate (fmiobj)
    !
    ! -- create name and memory path
    call fmiobj%set_names(1, name_model, 'FMI', 'FMI')
    fmiobj%text = text
    !
    ! -- Allocate scalars
    call fmiobj%allocate_scalars()
    !
    ! -- Set variables
    fmiobj%inunit = inunit
    fmiobj%iout = iout
    !
    ! -- Initialize block parser
    call fmiobj%parser%Initialize(fmiobj%inunit, fmiobj%iout)
    !
    ! -- Assign dependent variable label
    fmiobj%depvartype = 'TRACKS          '
 
  end subroutine fmi_cr
 
  !> @brief Time step advance
  subroutine fmi_ad(this)
    ! -- modules
    use constantsmodule, only: dhdry
    ! -- dummy
    class(prtfmitype) :: this
    ! -- local
    integer(I4B) :: n
    character(len=15) :: nodestr
    character(len=*), parameter :: fmtdry = &
     &"(/1X,'WARNING: DRY CELL ENCOUNTERED AT ',a,';  RESET AS INACTIVE')"
    character(len=*), parameter :: fmtrewet = &
     &"(/1X,'DRY CELL REACTIVATED AT ', a)"
    !
    ! -- Set flag to indicated that flows are being updated.  For the case where
    !    flows may be reused (only when flows are read from a file) then set
    !    the flag to zero to indicated that flows were not updated
    this%iflowsupdated = 1
    !
    ! -- If reading flows from a budget file, read the next set of records
    if (this%iubud /= 0) then
      call this%advance_bfr()
    end if
    !
    ! -- If reading heads from a head file, read the next set of records
    if (this%iuhds /= 0) then
      call this%advance_hfr()
    end if
    !
    ! -- If mover flows are being read from file, read the next set of records
    if (this%iumvr /= 0) then
      call this%mvrbudobj%bfr_advance(this%dis, this%iout)
    end if
    !
    ! -- Accumulate flows
    call this%accumulate_flows()
    !
    ! -- if flow cell is dry, then set this%ibound = 0
    do n = 1, this%dis%nodes
      !
      ! -- Calculate the ibound-like array that has 0 if saturation
      !    is zero and 1 otherwise
      if (this%gwfsat(n) > dzero) then
        this%ibdgwfsat0(n) = 1
      else
        this%ibdgwfsat0(n) = 0
      end if
      !
      ! -- Check if active model cell is inactive for flow
      if (this%ibound(n) > 0) then
        if (this%gwfhead(n) == dhdry) then
          ! -- cell should be made inactive
          this%ibound(n) = 0
          call this%dis%noder_to_string(n, nodestr)
          write (this%iout, fmtdry) trim(nodestr)
        end if
      end if
      !
      ! -- Convert dry model cell to active if flow has rewet
      if (this%ibound(n) == 0) then
        if (this%gwfhead(n) /= dhdry) then
          ! -- cell is now wet
          this%ibound(n) = 1
          call this%dis%noder_to_string(n, nodestr)
          write (this%iout, fmtrewet) trim(nodestr)
        end if
      end if
    end do
 
  end subroutine fmi_ad
 
  !> @brief Define the flow model interface
  subroutine prtfmi_df(this, dis, idryinactive)
    ! -- modules
    use simmodule, only: store_error
    ! -- dummy
    class(prtfmitype) :: this
    class(disbasetype), pointer, intent(in) :: dis
    integer(I4B), intent(in) :: idryinactive
    !
    ! -- Call parent class define
    call this%FlowModelInterfaceType%fmi_df(dis, idryinactive)
    !
    ! -- Allocate arrays
    allocate (this%StorageFlows(this%dis%nodes))
    allocate (this%SourceFlows(this%dis%nodes))
    allocate (this%SinkFlows(this%dis%nodes))
    allocate (this%BoundaryFlows(this%dis%nodes * max_poly_cells))
 
  end subroutine prtfmi_df
 
  !> @brief Accumulate flows
  subroutine accumulate_flows(this)
    implicit none
    ! -- dummy
    class(prtfmitype) :: this
    ! -- local
    integer(I4B) :: j, i, ip, ib
    integer(I4B) :: ioffset, iflowface, iauxiflowface
    real(DP) :: qbnd
    character(len=LENAUXNAME) :: auxname
    integer(I4B) :: naux
    !
    this%StorageFlows = dzero
    if (this%igwfstrgss /= 0) &
      this%StorageFlows = this%StorageFlows + &
                          this%gwfstrgss
    if (this%igwfstrgsy /= 0) &
      this%StorageFlows = this%StorageFlows + &
                          this%gwfstrgsy
 
    this%SourceFlows = dzero
    this%SinkFlows = dzero
    this%BoundaryFlows = dzero
    do ip = 1, this%nflowpack
      iauxiflowface = 0
      naux = this%gwfpackages(ip)%naux
      if (naux > 0) then
        do j = 1, naux
          auxname = this%gwfpackages(ip)%auxname(j)
          if (trim(adjustl(auxname)) == "IFLOWFACE") then
            iauxiflowface = j
            exit
          end if
        end do
      end if
      do ib = 1, this%gwfpackages(ip)%nbound
        i = this%gwfpackages(ip)%nodelist(ib)
        if (i <= 0) cycle
        if (this%ibound(i) <= 0) cycle
        qbnd = this%gwfpackages(ip)%get_flow(ib)
        ! todo, after initial release: default iflowface values for different packages
        iflowface = 0
        if (iauxiflowface > 0) then
          iflowface = nint(this%gwfpackages(ip)%auxvar(iauxiflowface, ib))
          ! this maps bot -2 -> 9, top -1 -> 10; see note re: max faces below
          if (iflowface < 0) iflowface = iflowface + max_poly_cells + 1
        end if
        if (iflowface .gt. 0) then
          ioffset = (i - 1) * max_poly_cells
          this%BoundaryFlows(ioffset + iflowface) = &
            this%BoundaryFlows(ioffset + iflowface) + qbnd
        else if (qbnd .gt. dzero) then
          this%SourceFlows(i) = this%SourceFlows(i) + qbnd
        else if (qbnd .lt. dzero) then
          this%SinkFlows(i) = this%SinkFlows(i) + qbnd
        end if
      end do
    end do
 
  end subroutine accumulate_flows
 
end module prtfmimodule