ExplicitSolution.f90

Go to the documentation of this file.

!> @brief Explicit solutions for solving explicit models.
!!
!! Explicit solutions manage and solve explicit models. An
!! explicit model solves itself, as opposed to a numerical
!! model which requires a numerical solution procedure. An
!! explicit solution involves a double loop: an outer loop
!! that continues until no model has pending work, as well
!! as an inner loop that scrolls through the models in the
!! solution and tells each to solve itself. The outer loop
!! is necessary because the explicit models may be coupled
!! by exchanges; models may send work during each solve to
!! other models. The outer loop continues until all models
!! have completed all work.
!<
module explicitsolutionmodule
  use kindmodule, only: i4b, dp
  use timermodule, only: code_timer
  use constantsmodule, only: lenmempath, lensolutionname, mvalidate, &
                             mnormal, linelength, dzero
  use memoryhelpermodule, only: create_mem_path
  use basemodelmodule, only: basemodeltype
  use explicitmodelmodule, only: explicitmodeltype, &
                                 addexplicitmodeltolist, &
                                 getexplicitmodelfromlist
  use baseexchangemodule, only: baseexchangetype, getbaseexchangefromlist
  use basesolutionmodule, only: basesolutiontype, addbasesolutiontolist
  use listmodule, only: listtype
  use listsmodule, only: basesolutionlist
  use simvariablesmodule, only: iout, isim_mode
  use blockparsermodule, only: blockparsertype
  use memorymanagermodule, only: mem_allocate, mem_deallocate
  use inputoutputmodule, only: getunit
 
  implicit none
  private
 
  public :: create_explicit_solution
  public :: explicitsolutiontype
 
  !> @brief Manages and solves explicit models.
  type, extends(basesolutiontype) :: explicitsolutiontype
    character(len=LENMEMPATH) :: memorypath !< the path for storing solution variables in the memory manager
    type(listtype), pointer :: modellist !< list of models in solution
    type(listtype), pointer :: exchangelist !< list of exchanges in solution
    integer(I4B), pointer :: id !< solution number
    integer(I4B), pointer :: iu !< input file unit
    real(dp), pointer :: ttsoln !< timer - total solution time
    integer(I4B), pointer :: icnvg => null() !< convergence flag
    type(blockparsertype) :: parser !< block parser object
  contains
    procedure :: sln_df
    procedure :: sln_ar
    procedure :: sln_dt
    procedure :: sln_ad
    procedure :: sln_ot
    procedure :: sln_ca
    procedure :: sln_fp
    procedure :: sln_da
    procedure :: add_model
    procedure :: add_exchange
    procedure :: get_models
    procedure :: get_exchanges
    procedure :: save
 
    procedure, private :: allocate_scalars
 
    ! Expose these for use through the BMI/XMI:
    procedure, public :: preparesolve
    procedure, public :: solve
    procedure, public :: finalizesolve
 
  end type explicitsolutiontype
 
contains
 
  !> @brief Create a new solution
  !!
  !! Create a new solution using the data in filename, assign this new
  !! solution an id number and store the solution in the basesolutionlist.
  !! Also open the filename for later reading.
  !<
  subroutine create_explicit_solution(exp_sol, filename, id)
    ! modules
    use inputoutputmodule, only: getunit, openfile
    ! dummy
    class(explicitsolutiontype), pointer :: exp_sol !< the create solution
    character(len=*), intent(in) :: filename !< solution input file name
    integer(I4B), intent(in) :: id !< solution id
    ! local
    integer(I4B) :: inunit
    class(basesolutiontype), pointer :: solbase => null()
    character(len=LENSOLUTIONNAME) :: solutionname
 
    ! Create a new solution and add it to the basesolutionlist container
    solbase => exp_sol
    write (solutionname, '(a, i0)') 'SLN_', id
    exp_sol%name = solutionname
    exp_sol%memoryPath = create_mem_path(solutionname)
    allocate (exp_sol%modellist)
    allocate (exp_sol%exchangelist)
    call exp_sol%allocate_scalars()
    call addbasesolutiontolist(basesolutionlist, solbase)
    exp_sol%id = id
 
    ! Open solution input file for reading later after problem size is known
    ! Check to see if the file is already opened, which can happen when
    ! running in single model mode
    inquire (file=filename, number=inunit)
    if (inunit < 0) inunit = getunit()
    exp_sol%iu = inunit
    write (iout, '(/a,a/)') ' Creating explicit solution (EMS): ', exp_sol%name
    call openfile(exp_sol%iu, iout, filename, 'EMS')
 
    ! Initialize block parser
    call exp_sol%parser%Initialize(exp_sol%iu, iout)
  end subroutine create_explicit_solution
 
  !> @brief Allocate scalars
  subroutine allocate_scalars(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
 
    ! allocate
    call mem_allocate(this%id, 'ID', this%memoryPath)
    call mem_allocate(this%iu, 'IU', this%memoryPath)
    call mem_allocate(this%ttsoln, 'TTSOLN', this%memoryPath)
    call mem_allocate(this%icnvg, 'ICNVG', this%memoryPath)
 
    ! initialize
    this%id = 0
    this%iu = 0
    this%ttsoln = dzero
    this%icnvg = 0
  end subroutine allocate_scalars
 
  !> @brief Define the solution
  subroutine sln_df(this)
    class(explicitsolutiontype) :: this
  end subroutine
 
  !> @brief Allocate and read
  subroutine sln_ar(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    ! close ems input file
    call this%parser%Clear()
  end subroutine sln_ar
 
  !> @brief Calculate time step length
  subroutine sln_dt(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
  end subroutine sln_dt
 
  !> @brief Advance the solution
  subroutine sln_ad(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
 
    ! reset convergence flag
    this%icnvg = 0
  end subroutine sln_ad
 
  !> @brief Output
  subroutine sln_ot(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
  end subroutine sln_ot
 
  subroutine sln_fp(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
  end subroutine sln_fp
 
  !> @brief Deallocate
  subroutine sln_da(this)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
 
    ! lists
    call this%modellist%Clear()
    deallocate (this%modellist)
    call this%exchangelist%Clear()
    deallocate (this%exchangelist)
 
    ! scalars
    call mem_deallocate(this%id)
    call mem_deallocate(this%iu)
    call mem_deallocate(this%ttsoln)
    call mem_deallocate(this%icnvg)
  end subroutine sln_da
 
  !> @brief Calculate
  subroutine sln_ca(this, isgcnvg, isuppress_output)
    ! dummy
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    integer(I4B), intent(inout) :: isgcnvg !< solution group convergence flag
    integer(I4B), intent(in) :: isuppress_output !< flag for suppressing output
    ! local
    class(explicitmodeltype), pointer :: mp => null()
    character(len=LINELENGTH) :: line
    character(len=LINELENGTH) :: fmt
    integer(I4B) :: im
    integer(I4B) :: kiter
 
    kiter = 1
 
    call this%prepareSolve()
 
    select case (isim_mode)
    case (mvalidate)
      line = 'mode="validation" -- Skipping assembly and solution.'
      fmt = "(/,1x,a,/)"
      do im = 1, this%modellist%Count()
        mp => getexplicitmodelfromlist(this%modellist, im)
        call mp%model_message(line, fmt=fmt)
      end do
    case (mnormal)
 
      ! solve the models
      call this%solve(kiter, isuppress_output)
 
      ! finish up
      call this%finalizeSolve(kiter, isgcnvg, isuppress_output)
    end select
  end subroutine sln_ca
 
  !> @brief Prepare to solve
  subroutine preparesolve(this)
    ! dummy
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    ! local
    integer(I4B) :: i
    class(explicitmodeltype), pointer :: mp => null()
    class(baseexchangetype), pointer :: ep => null()
 
    ! advance exchanges
    do i = 1, this%exchangelist%Count()
      ep => getbaseexchangefromlist(this%exchangelist, i)
      call ep%exg_ad()
    end do
 
    ! advance models
    do i = 1, this%modellist%Count()
      mp => getexplicitmodelfromlist(this%modellist, i)
      call mp%model_ad()
    end do
 
    ! advance solution
    call this%sln_ad()
  end subroutine preparesolve
 
  !> @brief Solve models
  subroutine solve(this, kiter, isuppress_output)
    ! dummy
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    integer(I4B), intent(in) :: kiter !< Picard iteration (1 for explicit)
    integer(I4B), intent(in) :: isuppress_output !< flag for suppressing output
    ! local
    class(explicitmodeltype), pointer :: mp => null()
    integer(I4B) :: im
    logical :: any_pending
    real(DP) :: ttsoln
 
    call code_timer(0, ttsoln, this%ttsoln)
 
    ! Outer loop: repeat until no model has pending work
    do
      ! Solve every model in the solution
      do im = 1, this%modellist%Count()
        mp => getexplicitmodelfromlist(this%modellist, im)
        call mp%model_solve(isuppress_output)
      end do
 
      ! Continue if any have pending work
      any_pending = .false.
      do im = 1, this%modellist%Count()
        mp => getexplicitmodelfromlist(this%modellist, im)
        if (mp%has_pending()) then
          any_pending = .true.
          exit
        end if
      end do
      if (.not. any_pending) exit
    end do
 
    call code_timer(1, ttsoln, this%ttsoln)
    this%icnvg = 1
  end subroutine solve
 
  !> @brief Finalize solve
  subroutine finalizesolve(this, kiter, isgcnvg, isuppress_output)
    ! dummy
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    integer(I4B), intent(in) :: kiter !< Picard iteration number (always 1 for explicit)
    integer(I4B), intent(inout) :: isgcnvg !< solution group convergence flag
    integer(I4B), intent(in) :: isuppress_output !< flag for suppressing output
    ! local
    integer(I4B) :: im
    class(explicitmodeltype), pointer :: mp => null()
 
    ! Calculate flow for each model
    do im = 1, this%modellist%Count()
      mp => getexplicitmodelfromlist(this%modellist, im)
      call mp%model_cq(this%icnvg, isuppress_output)
    end do
 
    ! Budget terms for each model
    do im = 1, this%modellist%Count()
      mp => getexplicitmodelfromlist(this%modellist, im)
      call mp%model_bd(this%icnvg, isuppress_output)
    end do
  end subroutine finalizesolve
 
  !> @brief Save output
  subroutine save(this, filename)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    character(len=*), intent(in) :: filename !< filename to save solution data
    integer(I4B) :: inunit
    inunit = getunit()
    open (unit=inunit, file=filename, status='unknown')
    write (inunit, *) 'The save routine currently writes nothing'
    close (inunit)
  end subroutine save
 
  !> @brief Add explicit model to list
  subroutine add_model(this, mp)
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    class(basemodeltype), pointer, intent(in) :: mp !< model instance
    class(explicitmodeltype), pointer :: m => null()
    select type (mp)
    class is (explicitmodeltype)
      m => mp
      call addexplicitmodeltolist(this%modellist, m)
    end select
  end subroutine add_model
 
  !> @brief Get a pointer to a list of models in the solution
  function get_models(this) result(models)
    type(listtype), pointer :: models !< pointer to the model list
    class(explicitsolutiontype) :: this !< ExplicitSolutionType instance
    models => this%modellist
  end function get_models
 
  !> @brief Add exchange to list of exchanges
  subroutine add_exchange(this, exchange)
    class(explicitsolutiontype) :: this
    class(baseexchangetype), pointer, intent(in) :: exchange
    class(*), pointer :: obj
    obj => exchange
    call this%exchangelist%Add(obj)
  end subroutine add_exchange
 
  !> @brief Get list of exchanges
  function get_exchanges(this) result(exchanges)
    class(explicitsolutiontype) :: this
    type(listtype), pointer :: exchanges
    exchanges => this%exchangelist
  end function get_exchanges
 
end module explicitsolutionmodule