From a8d48942cf5a9e1798c1cd5429a6c07f60affb5f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 9 Nov 2023 05:04:35 -0800 Subject: [PATCH] refactor(gwt1src1.f90): minor updates in source loading package (#1432) * refactor(gwt1src1.f90): minor updates in source loading package * Update src/Model/GroundWaterTransport/gwt1src1.f90 Co-authored-by: langevin-usgs * Update src/Model/GroundWaterTransport/gwt1src1.f90 Co-authored-by: langevin-usgs * Restore original docstring (not sure where all these GWE related changes crept in) --------- Co-authored-by: langevin-usgs --- src/Model/GroundWaterTransport/gwt1.f90 | 3 +- src/Model/GroundWaterTransport/gwt1src1.f90 | 147 +++++++++----------- 2 files changed, 71 insertions(+), 79 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index d8bbc3ff975..03f24ae691d 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -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) diff --git a/src/Model/GroundWaterTransport/gwt1src1.f90 b/src/Model/GroundWaterTransport/gwt1src1.f90 index 92d8db04782..0314413ce72 100644 --- a/src/Model/GroundWaterTransport/gwt1src1.f90 +++ b/src/Model/GroundWaterTransport/gwt1src1.f90 @@ -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, & @@ -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 @@ -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 a 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 @@ -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) @@ -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 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() @@ -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 @@ -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 @@ -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 @@ -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.' @@ -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 ! @@ -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 SMASSRATE 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 @@ -297,6 +287,7 @@ subroutine src_rp_ts(this) end if end do ! + ! -- Return return end subroutine src_rp_ts