prt-mip.f90

Go to the documentation of this file.

module prtmipmodule
 
  use kindmodule, only: dp, i4b, lgp
  use constantsmodule, only: dzero, done, linelength
  use numericalpackagemodule, only: numericalpackagetype
  use blockparsermodule, only: blockparsertype
  use basedismodule, only: disbasetype
  use memorymanagermodule, only: mem_allocate, mem_deallocate
  use memorymanagerextmodule, only: mem_set_value, memorylist_remove
  use simvariablesmodule, only: idm_context
  use simmodule, only: store_error
  use prtmipinputmodule, only: prtmipparamfoundtype
 
  implicit none
  private
  public :: prtmiptype
  public :: mip_cr
 
  type, extends(numericalpackagetype) :: prtmiptype
    real(dp), dimension(:), pointer, contiguous :: porosity => null() !< aquifer porosity
    real(dp), dimension(:), pointer, contiguous :: retfactor => null() !< retardation factor
    integer(I4B), dimension(:), pointer, contiguous :: izone => null() !< zone number
    integer(I4B), pointer :: zeromethod
  contains
    procedure :: mip_ar
    procedure :: mip_da
    procedure :: allocate_scalars
    procedure, private :: allocate_arrays
  end type prtmiptype
 
contains
 
  !> @brief Create a model input object
  subroutine mip_cr(mip, name_model, input_mempath, inunit, iout, dis)
    ! -- dummy
    type(prtmiptype), pointer :: mip
    character(len=*), intent(in) :: name_model
    character(len=*), intent(in) :: input_mempath
    integer(I4B), intent(in) :: inunit
    integer(I4B), intent(in) :: iout
    class(disbasetype), pointer, intent(in) :: dis
    ! -- formats
    character(len=*), parameter :: fmtheader = &
      "(1x, /1x, 'MIP -- MODEL INPUT PACKAGE', &
       &' INPUT READ FROM MEMPATH: ', A, /)"
    !
    ! -- Create the object
    allocate (mip)
    !
    ! -- Create name and memory path
    call mip%set_names(1, name_model, 'MIP', 'MIP', input_mempath)
    !
    ! -- Allocate scalars
    call mip%allocate_scalars()
    !
    ! -- Set variables
    mip%inunit = inunit
    mip%iout = iout
    !
    ! -- Set pointers
    mip%dis => dis
    !
    ! -- Print a message identifying the package if enabled
    if (inunit > 0) &
      write (iout, fmtheader) input_mempath
 
  end subroutine mip_cr
 
  !> @brief Deallocate memory
  subroutine mip_da(this)
    class(prtmiptype) :: this
    !
    ! -- Deallocate input memory
    call memorylist_remove(this%name_model, 'MIP', idm_context)
    !
    ! -- Deallocate parent package
    call this%NumericalPackageType%da()
    !
    ! -- Deallocate arrays
    call mem_deallocate(this%porosity)
    call mem_deallocate(this%retfactor)
    call mem_deallocate(this%izone)
    !
    ! -- Deallocate scalars
    call mem_deallocate(this%zeromethod)
  end subroutine mip_da
 
  subroutine allocate_scalars(this)
    class(prtmiptype) :: this
    call this%NumericalPackageType%allocate_scalars()
    call mem_allocate(this%zeromethod, 'IZEROMETHOD', this%memoryPath)
  end subroutine allocate_scalars
 
  !> @brief Allocate arrays
  subroutine allocate_arrays(this, nodes)
    class(prtmiptype) :: this
    integer(I4B), intent(in) :: nodes
    ! -- local
    integer(I4B) :: i
    !
    ! -- Allocate
    call mem_allocate(this%porosity, nodes, 'POROSITY', this%memoryPath)
    call mem_allocate(this%retfactor, nodes, 'RETFACTOR', this%memoryPath)
    call mem_allocate(this%izone, nodes, 'IZONE', this%memoryPath)
    !
    do i = 1, nodes
      this%porosity(i) = dzero
      this%retfactor(i) = done
      this%izone(i) = 0
    end do
 
  end subroutine allocate_arrays
 
  !> @ brief Initialize package inputs
  subroutine mip_ar(this)
    ! -- dummy variables
    class(prtmiptype), intent(inout) :: this !< PrtMipType object
    ! -- local variables
    character(len=LINELENGTH) :: errmsg
    type(prtmipparamfoundtype) :: found
    integer(I4B), dimension(:), pointer, contiguous :: map => null()
    !
    ! -- set map to convert user input data into reduced data
    if (this%dis%nodes < this%dis%nodesuser) map => this%dis%nodeuser
    !
    ! -- Allocate arrays
    call this%allocate_arrays(this%dis%nodes)
    !
    ! -- Source array inputs from IDM
    call mem_set_value(this%porosity, 'POROSITY', this%input_mempath, &
                       map, found%porosity)
    call mem_set_value(this%retfactor, 'RETFACTOR', this%input_mempath, &
                       map, found%retfactor)
    call mem_set_value(this%izone, 'IZONE', this%input_mempath, map, &
                       found%izone)
    !
    ! -- Source scalars
    call mem_set_value(this%zeromethod, 'ZERO_METHOD', this%input_mempath, &
                       found%zero_method)
    if (.not. found%zero_method) this%zeromethod = 1
    !
    ! -- Ensure POROSITY was found
    if (.not. found%porosity) then
      write (errmsg, '(a)') 'Error in GRIDDATA block: POROSITY not found'
      call store_error(errmsg)
    end if
 
  end subroutine mip_ar
 
end module prtmipmodule