Skip to content

Commit

Permalink
refactor(gwt1src1.f90): minor updates in source loading package
Browse files Browse the repository at this point in the history
  • Loading branch information
@emorway-usgs
emorway-usgs committed Nov 7, 2023
1 parent d7babfa commit 9e56f47
Show file tree
Hide file tree
Showing 2 changed files with 71 additions and 79 deletions.
3 changes: 2 additions & 1 deletion src/Model/GroundWaterTransport/gwt1.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -790,7 +790,8 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, mempath, &
call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, &
pakname, dvt, mempath)
case ('SRC6')
call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname)
call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, &
this%depvartype, pakname)
case ('LKT6')
call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, &
pakname, this%fmi)
Expand Down
147 changes: 69 additions & 78 deletions src/Model/GroundWaterTransport/gwt1src1.f90
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
module GwtSrcModule
!
use KindModule, only: DP, I4B
use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE
use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE, LENVARNAME
use BndModule, only: BndType
use ObsModule, only: DefaultObsIdProcessor
use TimeSeriesLinkModule, only: TimeSeriesLinkType, &
Expand All @@ -18,7 +18,11 @@ module GwtSrcModule
character(len=16) :: text = ' SRC'
!
type, extends(BndType) :: GwtSrcType

character(len=LENVARNAME) :: depvartype = '' !< stores string of dependent variable type, depending on model type

contains

procedure :: allocate_scalars => src_allocate_scalars
procedure :: bnd_cf => src_cf
procedure :: bnd_fc => src_fc
Expand All @@ -29,19 +33,17 @@ module GwtSrcModule
procedure, public :: bnd_df_obs => src_df_obs
! -- methods for time series
procedure, public :: bnd_rp_ts => src_rp_ts

end type GwtSrcType

contains

subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
! ******************************************************************************
! src_create -- Create a New Src Package
! Subroutine: (1) create new-style package
! (2) point bndobj to the new package
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
!> @brief Create an energy source loading package
!!
!! This subroutine points bndobj to the newly created package
!<
subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, &
depvartype)
! -- dummy
class(BndType), pointer :: packobj
integer(I4B), intent(in) :: id
Expand All @@ -50,9 +52,9 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
integer(I4B), intent(in) :: iout
character(len=*), intent(in) :: namemodel
character(len=*), intent(in) :: pakname
character(len=LENVARNAME), intent(in) :: depvartype
! -- local
type(GwtSrcType), pointer :: srcobj
! ------------------------------------------------------------------------------
!
! -- allocate the object and assign values to object variables
allocate (srcobj)
Expand All @@ -75,43 +77,38 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
packobj%ncolbnd = 1
packobj%iscloc = 1
!
! -- Store the appropriate label based on the dependent variable
srcobj%depvartype = depvartype
!
! -- return
return
end subroutine src_create

!> @brief Deallocate memory
!<
subroutine src_da(this)
! ******************************************************************************
! src_da -- deallocate
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
! -- modules
use MemoryManagerModule, only: mem_deallocate
! -- dummy
class(GwtSrcType) :: this
! ------------------------------------------------------------------------------
!
! -- Deallocate parent package
call this%BndType%bnd_da()
!
! -- scalars
!
! -- return
! -- Return
return
end subroutine src_da

!> @brief Allocate scalars
!!
!! Allocate scalars specific to this energy source loading package
!<
subroutine src_allocate_scalars(this)
! ******************************************************************************
! allocate_scalars -- allocate scalar members
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
use MemoryManagerModule, only: mem_allocate
! -- dummy
class(GwtSrcType) :: this
! ------------------------------------------------------------------------------
!
! -- call standard BndType allocate scalars
call this%BndType%allocate_scalars()
Expand All @@ -120,25 +117,22 @@ subroutine src_allocate_scalars(this)
!
! -- Set values
!
! -- return
! -- Return
return
end subroutine src_allocate_scalars

!> @brief Formulate the HCOF and RHS terms
!!
!! This subroutine:
!! - calculates hcof and rhs terms
!! - skip if no sources
!<
subroutine src_cf(this)
! ******************************************************************************
! src_cf -- Formulate the HCOF and RHS terms
! Subroutine: (1) skip if no sources
! (2) calculate hcof and rhs
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
! -- dummy
class(GwtSrcType) :: this
! -- local
integer(I4B) :: i, node
real(DP) :: q
! ------------------------------------------------------------------------------
!
! -- Return if no sources
if (this%nbound == 0) return
Expand All @@ -155,16 +149,15 @@ subroutine src_cf(this)
this%rhs(i) = -q
end do
!
! -- Return
return
end subroutine src_cf

!> @brief Add matrix terms related to specified mass source loading
!!
!! Copy rhs and hcof into solution rhs and amat
!<
subroutine src_fc(this, rhs, ia, idxglo, matrix_sln)
! **************************************************************************
! src_fc -- Copy rhs and hcof into solution rhs and amat
! **************************************************************************
!
! SPECIFICATIONS:
! --------------------------------------------------------------------------
! -- dummy
class(GwtSrcType) :: this
real(DP), dimension(:), intent(inout) :: rhs
Expand All @@ -173,7 +166,6 @@ subroutine src_fc(this, rhs, ia, idxglo, matrix_sln)
class(MatrixBaseType), pointer :: matrix_sln
! -- local
integer(I4B) :: i, n, ipos
! --------------------------------------------------------------------------
!
! -- pakmvrobj fc
if (this%imover == 1) then
Expand All @@ -194,20 +186,19 @@ subroutine src_fc(this, rhs, ia, idxglo, matrix_sln)
end if
end do
!
! -- return
! -- Return
return
end subroutine src_fc

!> @brief Define list labels
!!
!! Define the list heading that is written to iout when PRINT_INPUT
!! option is used.
!<
subroutine define_listlabel(this)
! ******************************************************************************
! define_listlabel -- Define the list heading that is written to iout when
! PRINT_INPUT option is used.
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
! -- dummy
class(GwtSrcType), intent(inout) :: this
! ------------------------------------------------------------------------------
! -- local
!
! -- create the header list label
this%listlabel = trim(this%filtyp)//' NO.'
Expand All @@ -226,42 +217,41 @@ subroutine define_listlabel(this)
write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME'
end if
!
! -- return
! -- Return
return
end subroutine define_listlabel

! -- Procedures related to observations
!> @brief Support function for specified mass source loading observations
!!
!! This function:
!! - returns true because SRC package supports observations.
!! - overrides BndType%bnd_obs_supported()
!<
logical function src_obs_supported(this)
! ******************************************************************************
! src_obs_supported
! -- Return true because SRC package supports observations.
! -- Overrides BndType%bnd_obs_supported()
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
implicit none
! -- dummy
class(GwtSrcType) :: this
! ------------------------------------------------------------------------------
!
src_obs_supported = .true.
!
! -- Return
return
end function src_obs_supported

!> @brief Define observations
!!
!! This subroutine:
!! - stores observation types supported by SRC package.
!! - overrides BndType%bnd_df_obs
!<
subroutine src_df_obs(this)
! ******************************************************************************
! src_df_obs (implements bnd_df_obs)
! -- Store observation type supported by SRC package.
! -- Overrides BndType%bnd_df_obs
! ******************************************************************************
!
! SPECIFICATIONS:
! ------------------------------------------------------------------------------
implicit none
! -- dummy
class(GwtSrcType) :: this
! -- local
integer(I4B) :: indx
! ------------------------------------------------------------------------------
!
call this%obs%StoreObsType('src', .true., indx)
this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor
!
Expand All @@ -270,17 +260,17 @@ subroutine src_df_obs(this)
call this%obs%StoreObsType('to-mvr', .true., indx)
this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor
!
! -- return
! -- Return
return
end subroutine src_df_obs

! -- Procedure related to time series

!> @brief Procedure related to time series
!!
!! Assign tsLink%Text appropriately for all time series in use by package.
!! In the SRC package only the SENERRATE variable can be controlled by time
!! series.
!<
subroutine src_rp_ts(this)
! -- Assign tsLink%Text appropriately for
! all time series in use by package.
! In the SRC package only the SMASSRATE variable
! can be controlled by time series.
! -- dummy
class(GwtSrcType), intent(inout) :: this
! -- local
Expand All @@ -297,6 +287,7 @@ subroutine src_rp_ts(this)
end if
end do
!
! -- Return
return
end subroutine src_rp_ts

Expand Down

0 comments on commit 9e56f47

Please sign in to comment.