From 44c6317810cf2454014e8549303de8edb0981c67 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 19 May 2022 11:34:41 -0700 Subject: [PATCH 001/212] refactor(gwt): set hooks to prepare for for gwe --- msvs/mf6core.vfproj | 3 ++- src/Model/GroundWaterTransport/gwt1.f90 | 3 ++- src/Model/TransportModel.f90 | 31 +++++++++++++++++++++++++ 3 files changed, 35 insertions(+), 2 deletions(-) create mode 100644 src/Model/TransportModel.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index df4306a417e..bb503ae2105 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -140,7 +140,8 @@ - + + diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index c0e225e12ea..04e0ebb8977 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -12,6 +12,7 @@ module GwtModule use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType + use TransportModelModule, only: TransportModelType use BaseModelModule, only: BaseModelType use BndModule, only: BndType, AddBndToList, GetBndFromList use GwtIcModule, only: GwtIcType @@ -32,7 +33,7 @@ module GwtModule public :: GwtModelType public :: CastAsGwtModel - type, extends(NumericalModelType) :: GwtModelType + type, extends(TransportModelType) :: GwtModelType type(GwtIcType), pointer :: ic => null() ! initial conditions package type(GwtFmiType), pointer :: fmi => null() ! flow model interface diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 new file mode 100644 index 00000000000..f2a0058c734 --- /dev/null +++ b/src/Model/TransportModel.f90 @@ -0,0 +1,31 @@ +! Generalized Transport Base Class +! Base class for solute (mass) and energy (thermal) transport +! (The following copied from gwt1.f90) +! * Add check that discretization is the same between both models +! * Program GWT-GWT exchange transport (awaiting implementation of interface model) +! * Consider implementation of steady-state transport (affects MST, IST) +! * Check and handle pore space discrepancy between flow and transport (porosity vs specific yield) +! * UZT may not have the required porosity term + +module TransportModelModule + use KindModule, only: DP, I4B + use ConstantsModule, only: LENFTYPE + use SimVariablesModule, only: errmsg + use NumericalModelModule, only: NumericalModelType + + implicit none + + private + + public :: TransportModelType + + type, extends(NumericalModelType) :: TransportModelType + + contains + + end type TransportModelType + + + +end module TransportModelModule + \ No newline at end of file From 6de9ec94d8345e46e2e40aba4800cddcd60a622f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 19 May 2022 11:43:56 -0700 Subject: [PATCH 002/212] feat(gwe): groundwater energy (heat) transport --- msvs/mf6core.vfproj | 2 ++ src/Model/GroundWaterEnergy/gwe.f90 | 29 +++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+) create mode 100644 src/Model/GroundWaterEnergy/gwe.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index bb503ae2105..14e89b4289d 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -138,6 +138,8 @@ + + diff --git a/src/Model/GroundWaterEnergy/gwe.f90 b/src/Model/GroundWaterEnergy/gwe.f90 new file mode 100644 index 00000000000..31eb5e96957 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe.f90 @@ -0,0 +1,29 @@ +! Groundwater Energy Transport (GWE) Model + +module GweModule + + use KindModule, only: DP, I4B + use InputOutputModule, only: ParseLine, upcase + use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC + use VersionModule, only: write_listfile_header + use NumericalModelModule, only: NumericalModelType + use TransportModelModule, only: TransportModelType + use BaseModelModule, only: BaseModelType + + implicit none + + private + + public :: GweModelType + + type, extends(TransportModelType) :: GweModelType + + contains + + + end type GweModelType + + ! -- Module variables constant for simulation + integer(I4B), parameter :: NIUNIT=100 + +end module GweModule \ No newline at end of file From e1d1b47f86e44c06fc122b97591b2db244bc586b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 15:23:45 -0700 Subject: [PATCH 003/212] Updating Mike Reno's fprettify stuff on my GWE branch (and whatever other changes have occurred). This commit has everything in the GWF folder. --- src/Model/GroundWaterFlow/gwf3.f90 | 840 +- src/Model/GroundWaterFlow/gwf3api8.f90 | 32 +- src/Model/GroundWaterFlow/gwf3buy8.f90 | 678 +- src/Model/GroundWaterFlow/gwf3chd8.f90 | 191 +- src/Model/GroundWaterFlow/gwf3csub8.f90 | 1349 ++- src/Model/GroundWaterFlow/gwf3dis8.f90 | 935 +- src/Model/GroundWaterFlow/gwf3disu8.f90 | 967 +- src/Model/GroundWaterFlow/gwf3disv8.f90 | 1019 +- src/Model/GroundWaterFlow/gwf3drn8.f90 | 290 +- src/Model/GroundWaterFlow/gwf3evt8.f90 | 470 +- src/Model/GroundWaterFlow/gwf3ghb8.f90 | 188 +- src/Model/GroundWaterFlow/gwf3hfb8.f90 | 384 +- src/Model/GroundWaterFlow/gwf3ic8.f90 | 68 +- src/Model/GroundWaterFlow/gwf3lak8.f90 | 2566 +++-- src/Model/GroundWaterFlow/gwf3maw8.f90 | 1718 ++-- src/Model/GroundWaterFlow/gwf3mvr8.f90 | 484 +- src/Model/GroundWaterFlow/gwf3npf8.f90 | 2393 ++--- src/Model/GroundWaterFlow/gwf3obs8.f90 | 80 +- src/Model/GroundWaterFlow/gwf3oc8.f90 | 54 +- src/Model/GroundWaterFlow/gwf3rch8.f90 | 417 +- src/Model/GroundWaterFlow/gwf3riv8.f90 | 216 +- src/Model/GroundWaterFlow/gwf3sfr8.f90 | 10140 ++++++++++---------- src/Model/GroundWaterFlow/gwf3sto8.f90 | 220 +- src/Model/GroundWaterFlow/gwf3tvbase8.f90 | 114 +- src/Model/GroundWaterFlow/gwf3tvk8.f90 | 75 +- src/Model/GroundWaterFlow/gwf3tvs8.f90 | 70 +- src/Model/GroundWaterFlow/gwf3uzf8.f90 | 1103 +-- src/Model/GroundWaterFlow/gwf3wel8.f90 | 937 +- 28 files changed, 14029 insertions(+), 13969 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index f3a28da225b..00b6c39a468 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -1,26 +1,26 @@ module GwfModule - use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, upcase - use ConstantsModule, only: LENFTYPE, LENPAKLOC, DZERO, DEM1, DTEN, DEP20 - use VersionModule, only: write_listfile_header - use NumericalModelModule, only: NumericalModelType - use BaseDisModule, only: DisBaseType - use BndModule, only: BndType, AddBndToList, GetBndFromList - use GwfIcModule, only: GwfIcType - use GwfNpfModule, only: GwfNpfType - use Xt3dModule, only: Xt3dType - use GwfBuyModule, only: GwfBuyType - use GwfHfbModule, only: GwfHfbType - use GwfStoModule, only: GwfStoType - use GwfCsubModule, only: GwfCsubType - use GwfMvrModule, only: GwfMvrType - use BudgetModule, only: BudgetType - use GwfOcModule, only: GwfOcType - use GhostNodeModule, only: GhostNodeType, gnc_cr - use GwfObsModule, only: GwfObsType, gwf_obs_cr - use SimModule, only: count_errors, store_error - use BaseModelModule, only: BaseModelType + use KindModule, only: DP, I4B + use InputOutputModule, only: ParseLine, upcase + use ConstantsModule, only: LENFTYPE, LENPAKLOC, DZERO, DEM1, DTEN, DEP20 + use VersionModule, only: write_listfile_header + use NumericalModelModule, only: NumericalModelType + use BaseDisModule, only: DisBaseType + use BndModule, only: BndType, AddBndToList, GetBndFromList + use GwfIcModule, only: GwfIcType + use GwfNpfModule, only: GwfNpfType + use Xt3dModule, only: Xt3dType + use GwfBuyModule, only: GwfBuyType + use GwfHfbModule, only: GwfHfbType + use GwfStoModule, only: GwfStoType + use GwfCsubModule, only: GwfCsubType + use GwfMvrModule, only: GwfMvrType + use BudgetModule, only: BudgetType + use GwfOcModule, only: GwfOcType + use GhostNodeModule, only: GhostNodeType, gnc_cr + use GwfObsModule, only: GwfObsType, gwf_obs_cr + use SimModule, only: count_errors, store_error + use BaseModelModule, only: BaseModelType implicit none @@ -31,52 +31,52 @@ module GwfModule type, extends(NumericalModelType) :: GwfModelType - type(GwfIcType), pointer :: ic => null() ! initial conditions package - type(GwfNpfType), pointer :: npf => null() ! node property flow package - type(Xt3dType), pointer :: xt3d => null() ! xt3d option for npf - type(GwfBuyType), pointer :: buy => null() ! buoyancy package - type(GwfStoType), pointer :: sto => null() ! storage package - type(GwfCsubType), pointer :: csub => null() ! subsidence package - type(GwfOcType), pointer :: oc => null() ! output control package - type(GhostNodeType), pointer :: gnc => null() ! ghost node correction package - type(GwfHfbType), pointer :: hfb => null() ! horizontal flow barrier package - type(GwfMvrType), pointer :: mvr => null() ! water mover package - type(GwfObsType), pointer :: obs => null() ! observation package - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: innpf => null() ! unit number NPF - integer(I4B), pointer :: inbuy => null() ! unit number BUY - integer(I4B), pointer :: insto => null() ! unit number STO - integer(I4B), pointer :: incsub => null() ! unit number CSUB - integer(I4B), pointer :: inmvr => null() ! unit number MVR - integer(I4B), pointer :: inhfb => null() ! unit number HFB - integer(I4B), pointer :: ingnc => null() ! unit number GNC - integer(I4B), pointer :: inobs => null() ! unit number OBS - integer(I4B), pointer :: iss => null() ! steady state flag - integer(I4B), pointer :: inewtonur => null() ! newton under relaxation flag + type(GwfIcType), pointer :: ic => null() ! initial conditions package + type(GwfNpfType), pointer :: npf => null() ! node property flow package + type(Xt3dType), pointer :: xt3d => null() ! xt3d option for npf + type(GwfBuyType), pointer :: buy => null() ! buoyancy package + type(GwfStoType), pointer :: sto => null() ! storage package + type(GwfCsubType), pointer :: csub => null() ! subsidence package + type(GwfOcType), pointer :: oc => null() ! output control package + type(GhostNodeType), pointer :: gnc => null() ! ghost node correction package + type(GwfHfbType), pointer :: hfb => null() ! horizontal flow barrier package + type(GwfMvrType), pointer :: mvr => null() ! water mover package + type(GwfObsType), pointer :: obs => null() ! observation package + type(BudgetType), pointer :: budget => null() ! budget object + integer(I4B), pointer :: inic => null() ! unit number IC + integer(I4B), pointer :: inoc => null() ! unit number OC + integer(I4B), pointer :: innpf => null() ! unit number NPF + integer(I4B), pointer :: inbuy => null() ! unit number BUY + integer(I4B), pointer :: insto => null() ! unit number STO + integer(I4B), pointer :: incsub => null() ! unit number CSUB + integer(I4B), pointer :: inmvr => null() ! unit number MVR + integer(I4B), pointer :: inhfb => null() ! unit number HFB + integer(I4B), pointer :: ingnc => null() ! unit number GNC + integer(I4B), pointer :: inobs => null() ! unit number OBS + integer(I4B), pointer :: iss => null() ! steady state flag + integer(I4B), pointer :: inewtonur => null() ! newton under relaxation flag contains - procedure :: model_df => gwf_df - procedure :: model_ac => gwf_ac - procedure :: model_mc => gwf_mc - procedure :: model_ar => gwf_ar - procedure :: model_rp => gwf_rp - procedure :: model_ad => gwf_ad - procedure :: model_cf => gwf_cf - procedure :: model_fc => gwf_fc - procedure :: model_cc => gwf_cc - procedure :: model_ptcchk => gwf_ptcchk - procedure :: model_ptc => gwf_ptc - procedure :: model_nur => gwf_nur - procedure :: model_cq => gwf_cq - procedure :: model_bd => gwf_bd - procedure :: model_ot => gwf_ot - procedure :: model_fp => gwf_fp - procedure :: model_da => gwf_da - procedure :: model_bdentry => gwf_bdentry - procedure :: get_iasym => gwf_get_iasym + procedure :: model_df => gwf_df + procedure :: model_ac => gwf_ac + procedure :: model_mc => gwf_mc + procedure :: model_ar => gwf_ar + procedure :: model_rp => gwf_rp + procedure :: model_ad => gwf_ad + procedure :: model_cf => gwf_cf + procedure :: model_fc => gwf_fc + procedure :: model_cc => gwf_cc + procedure :: model_ptcchk => gwf_ptcchk + procedure :: model_ptc => gwf_ptc + procedure :: model_nur => gwf_nur + procedure :: model_cq => gwf_cq + procedure :: model_bd => gwf_bd + procedure :: model_ot => gwf_ot + procedure :: model_fp => gwf_fp + procedure :: model_da => gwf_da + procedure :: model_bdentry => gwf_bdentry + procedure :: get_iasym => gwf_get_iasym ! -- private procedure :: allocate_scalars procedure :: package_create @@ -89,51 +89,51 @@ module GwfModule end type GwfModelType ! -- Module variables constant for simulation - integer(I4B), parameter :: NIUNIT=100 + integer(I4B), parameter :: NIUNIT = 100 character(len=LENFTYPE), dimension(NIUNIT) :: cunit - data cunit/ 'IC6 ', 'DIS6 ', 'DISU6', 'OC6 ', 'NPF6 ', & ! 5 - 'STO6 ', 'HFB6 ', 'WEL6 ', 'DRN6 ', 'RIV6 ', & ! 10 - 'GHB6 ', 'RCH6 ', 'EVT6 ', 'OBS6 ', 'GNC6 ', & ! 15 - 'API6 ', 'CHD6 ', ' ', ' ', ' ', & ! 20 - ' ', 'MAW6 ', 'SFR6 ', 'LAK6 ', 'UZF6 ', & ! 25 - 'DISV6', 'MVR6 ', 'CSUB6', 'BUY6 ', ' ', & ! 30 - 70 * ' '/ + data cunit/'IC6 ', 'DIS6 ', 'DISU6', 'OC6 ', 'NPF6 ', & ! 5 + &'STO6 ', 'HFB6 ', 'WEL6 ', 'DRN6 ', 'RIV6 ', & ! 10 + &'GHB6 ', 'RCH6 ', 'EVT6 ', 'OBS6 ', 'GNC6 ', & ! 15 + &'API6 ', 'CHD6 ', ' ', ' ', ' ', & ! 20 + &' ', 'MAW6 ', 'SFR6 ', 'LAK6 ', 'UZF6 ', & ! 25 + &'DISV6', 'MVR6 ', 'CSUB6', 'BUY6 ', ' ', & ! 30 + &70*' '/ - contains +contains !> @brief Create a new groundwater flow model object !! !! (1) creates model object and add to modellist !! (2) assign values !! - !< + !< subroutine gwf_cr(filename, id, modelname, smr) - ! -- modules - use ListsModule, only: basemodellist - use MemoryHelperModule, only: create_mem_path - use BaseModelModule, only: AddBaseModelToList - use SimModule, only: store_error, count_errors - use GenericUtilitiesModule, only: write_centered - use ConstantsModule, only: LINELENGTH, LENPACKAGENAME - use MemoryManagerModule, only: mem_allocate - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use GwfNpfModule, only: npf_cr - use Xt3dModule, only: xt3d_cr - use GwfBuyModule, only: buy_cr - use GwfStoModule, only: sto_cr - use GwfCsubModule, only: csub_cr - use GwfMvrModule, only: mvr_cr - use GwfHfbModule, only: hfb_cr - use GwfIcModule, only: ic_cr - use GwfOcModule, only: oc_cr - use BudgetModule, only: budget_cr - use NameFileModule, only: NameFileType + ! -- modules + use ListsModule, only: basemodellist + use MemoryHelperModule, only: create_mem_path + use BaseModelModule, only: AddBaseModelToList + use SimModule, only: store_error, count_errors + use GenericUtilitiesModule, only: write_centered + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use MemoryManagerModule, only: mem_allocate + use GwfDisModule, only: dis_cr + use GwfDisvModule, only: disv_cr + use GwfDisuModule, only: disu_cr + use GwfNpfModule, only: npf_cr + use Xt3dModule, only: xt3d_cr + use GwfBuyModule, only: buy_cr + use GwfStoModule, only: sto_cr + use GwfCsubModule, only: csub_cr + use GwfMvrModule, only: mvr_cr + use GwfHfbModule, only: hfb_cr + use GwfIcModule, only: ic_cr + use GwfOcModule, only: oc_cr + use BudgetModule, only: budget_cr + use NameFileModule, only: NameFileType ! -- dummy - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: id - character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: id + character(len=*), intent(in) :: modelname logical, optional, intent(in) :: smr ! -- local integer(I4B) :: indis, indis6, indisu6, indisv6 @@ -141,15 +141,15 @@ subroutine gwf_cr(filename, id, modelname, smr) character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname type(NameFileType) :: namefile_obj - type(GwfModelType), pointer :: this - class(BaseModelType), pointer :: model + type(GwfModelType), pointer :: this + class(BaseModelType), pointer :: model integer(I4B) :: nwords character(len=LINELENGTH), allocatable, dimension(:) :: words ! -- format ! ------------------------------------------------------------------------------ ! ! -- Allocate a new GWF Model (this) and add it to basemodellist - allocate(this) + allocate (this) ! ! -- Set memory path before allocation in memory manager can be done this%memoryPath = create_mem_path(modelname) @@ -163,7 +163,7 @@ subroutine gwf_cr(filename, id, modelname, smr) this%name = modelname this%macronym = 'GWF' this%id = id - if(present(smr)) this%single_model_run = smr + if (present(smr)) this%single_model_run = smr ! ! -- Open namefile and set iout call namefile_obj%init(this%filename, 0) @@ -178,45 +178,45 @@ subroutine gwf_cr(filename, id, modelname, smr) ! ! -- GWF options if (size(namefile_obj%opts) > 0) then - write(this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' end if ! ! -- Parse options in the GWF name file do i = 1, size(namefile_obj%opts) call ParseLine(namefile_obj%opts(i), nwords, words) call upcase(words(1)) - select case(words(1)) - case('NEWTON') - this%inewton = 1 - write(this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method enabled for the model.' - if (nwords > 1) then - call upcase(words(2)) - if (words(2) == 'UNDER_RELAXATION') then - this%inewtonur = 1 - write(this%iout, '(4x,a,a)') & - 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & - 'elevation of the model will be applied to the model.' - end if + select case (words(1)) + case ('NEWTON') + this%inewton = 1 + write (this%iout, '(4x,a)') & + 'NEWTON-RAPHSON method enabled for the model.' + if (nwords > 1) then + call upcase(words(2)) + if (words(2) == 'UNDER_RELAXATION') then + this%inewtonur = 1 + write (this%iout, '(4x,a,a)') & + 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & + 'elevation of the model will be applied to the model.' end if - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - 'FOR ALL MODEL STRESS PACKAGES' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - 'FOR ALL MODEL PACKAGES' - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, '(4x,a)') & - 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - case default - write(errmsg,'(4x,a,a,a,a)') & - 'Unknown GWF namefile (', & - trim(adjustl(this%filename)), ') option: ', & - trim(adjustl(namefile_obj%opts(i))) - call store_error(errmsg, terminate=.TRUE.) + end if + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + 'FOR ALL MODEL STRESS PACKAGES' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + 'FOR ALL MODEL PACKAGES' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, '(4x,a)') & + 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + case default + write (errmsg, '(4x,a,a,a,a)') & + 'Unknown GWF namefile (', & + trim(adjustl(this%filename)), ') option: ', & + trim(adjustl(namefile_obj%opts(i))) + call store_error(errmsg, terminate=.TRUE.) end select end do ! @@ -228,13 +228,13 @@ subroutine gwf_cr(filename, id, modelname, smr) indisu6 = 0 indisv6 = 0 call namefile_obj%get_unitnumber('DIS6', indis6, 1) - if(indis6 > 0) indis = indis6 - if(indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) - if(indisu6 > 0) indis = indisu6 - if(indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) - if(indisv6 > 0) indis = indisv6 - call namefile_obj%get_unitnumber('IC6', this%inic, 1) - call namefile_obj%get_unitnumber('OC6', this%inoc, 1) + if (indis6 > 0) indis = indis6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) + if (indisu6 > 0) indis = indisu6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) + if (indisv6 > 0) indis = indisv6 + call namefile_obj%get_unitnumber('IC6', this%inic, 1) + call namefile_obj%get_unitnumber('OC6', this%inoc, 1) call namefile_obj%get_unitnumber('NPF6', this%innpf, 1) call namefile_obj%get_unitnumber('BUY6', this%inbuy, 1) call namefile_obj%get_unitnumber('STO6', this%insto, 1) @@ -248,13 +248,13 @@ subroutine gwf_cr(filename, id, modelname, smr) call this%ftype_check(namefile_obj, indis) ! ! -- Create discretization object - if(indis6 > 0) then + if (indis6 > 0) then call dis_cr(this%dis, this%name, indis, this%iout) - elseif(indisu6 > 0) then + elseif (indisu6 > 0) then call disu_cr(this%dis, this%name, indis, this%iout) - elseif(indisv6 > 0) then + elseif (indisv6 > 0) then call disv_cr(this%dis, this%name, indis, this%iout) - endif + end if ! ! -- Create utility objects call budget_cr(this%budget, this%name) @@ -266,7 +266,7 @@ subroutine gwf_cr(filename, id, modelname, smr) call gnc_cr(this%gnc, this%name, this%ingnc, this%iout) call hfb_cr(this%hfb, this%name, this%inhfb, this%iout) call sto_cr(this%sto, this%name, this%insto, this%iout) - call csub_cr(this%csub, this%name, this%insto, this%sto%packName, & + call csub_cr(this%csub, this%name, this%insto, this%sto%packName, & this%incsub, this%iout) call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) call mvr_cr(this%mvr, this%name, this%inmvr, this%iout, this%dis) @@ -280,19 +280,19 @@ subroutine gwf_cr(filename, id, modelname, smr) do j = 1, namefile_obj%get_nval_for_row(i) iu = namefile_obj%get_unitnumber_rowcol(i, j) call namefile_obj%get_pakname(i, j, pakname) - call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & - this%iout) + call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & + this%iout) ipaknum = ipaknum + 1 ipakid = ipakid + 1 - enddo - enddo + end do + end do ! ! -- return return end subroutine gwf_cr !> @brief Define packages of the model - !! + !! !! (1) call df routines for each package !! (2) set gwf variables and pointers !! @@ -318,8 +318,8 @@ subroutine gwf_df(this) ! this%neq will be incremented if packages add additional unknowns this%neq = this%dis%nodes this%nja = this%dis%nja - this%ia => this%dis%con%ia - this%ja => this%dis%con%ja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja ! ! -- Allocate model arrays, now that neq and nja are known call this%allocate_arrays() @@ -328,7 +328,7 @@ subroutine gwf_df(this) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_df(this%neq, this%dis) - enddo + end do ! ! -- Store information needed for observations call this%obs%obs_df(this%iout, this%name, 'GWF', this%dis) @@ -353,16 +353,16 @@ subroutine gwf_ac(this, sparse) call this%dis%dis_ac(this%moffset, sparse) ! ! -- Add any additional connections that NPF may need - if(this%innpf > 0) call this%npf%npf_ac(this%moffset, sparse) + if (this%innpf > 0) call this%npf%npf_ac(this%moffset, sparse) ! ! -- Add any package connections do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ac(this%moffset, sparse) - enddo + end do ! ! -- If GNC is active, then add the gnc connections to sparse - if(this%ingnc > 0) call this%gnc%gnc_ac(sparse) + if (this%ingnc > 0) call this%gnc%gnc_ac(sparse) ! ! -- return return @@ -386,17 +386,17 @@ subroutine gwf_mc(this, iasln, jasln) call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln) ! ! -- Map any additional connections that NPF may need - if(this%innpf > 0) call this%npf%npf_mc(this%moffset, iasln, jasln) + if (this%innpf > 0) call this%npf%npf_mc(this%moffset, iasln, jasln) ! ! -- Map any package connections - do ip=1,this%bndlist%Count() + do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_mc(this%moffset, iasln, jasln) - enddo + end do ! ! -- For implicit gnc, need to store positions of gnc connections ! in solution matrix connection - if(this%ingnc > 0) call this%gnc%gnc_mc(iasln, jasln) + if (this%ingnc > 0) call this%gnc%gnc_mc(iasln, jasln) ! ! -- return return @@ -405,7 +405,7 @@ end subroutine gwf_mc !> @brief GroundWater Flow Model Allocate and Read !! !! (1) allocates and reads packages part of this model, - !! (2) allocates memory for arrays part of this model object + !! (2) allocates memory for arrays part of this model object !! !< subroutine gwf_ar(this) @@ -417,14 +417,14 @@ subroutine gwf_ar(this) ! ------------------------------------------------------------------------------ ! ! -- Allocate and read modules attached to model - if(this%inic > 0) call this%ic%ic_ar(this%x) - if(this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x) - if(this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) - if(this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) - if(this%insto > 0) call this%sto%sto_ar(this%dis, this%ibound) - if(this%incsub > 0) call this%csub%csub_ar(this%dis, this%ibound) - if(this%inmvr > 0) call this%mvr%mvr_ar() - if(this%inobs > 0) call this%obs%gwf_obs_ar(this%ic, this%x, this%flowja) + if (this%inic > 0) call this%ic%ic_ar(this%x) + if (this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x) + if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) + if (this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) + if (this%insto > 0) call this%sto%sto_ar(this%dis, this%ibound) + if (this%incsub > 0) call this%csub%csub_ar(this%dis, this%ibound) + if (this%inmvr > 0) call this%mvr%mvr_ar() + if (this%inobs > 0) call this%obs%gwf_obs_ar(this%ic, this%x, this%flowja) ! ! -- Call dis_ar to write binary grid file call this%dis%dis_ar(this%npf%icelltype) @@ -434,24 +434,24 @@ subroutine gwf_ar(this) call this%budget%set_ibudcsv(this%oc%ibudcsv) ! ! -- Package input files now open, so allocate and read - do ip = 1,this%bndlist%Count() + do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) - call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & + call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & this%xold, this%flowja) ! -- Read and allocate package call packobj%bnd_ar() if (this%inbuy > 0) call this%buy%buy_ar_bnd(packobj, this%x) - enddo + end do ! ! -- return return end subroutine gwf_ar !> @brief GroundWater Flow Model Read and Prepare - !! - !! (1) calls package read and prepare routines !! - !< + !! (1) calls package read and prepare routines + !! + !< subroutine gwf_rp(this) ! -- modules use TdisModule, only: readnewdata @@ -466,18 +466,18 @@ subroutine gwf_rp(this) if (.not. readnewdata) return ! ! -- Read and prepare - if(this%innpf > 0) call this%npf%npf_rp() - if(this%inbuy > 0) call this%buy%buy_rp() - if(this%inhfb > 0) call this%hfb%hfb_rp() - if(this%inoc > 0) call this%oc%oc_rp() - if(this%insto > 0) call this%sto%sto_rp() - if(this%incsub > 0) call this%csub%csub_rp() - if(this%inmvr > 0) call this%mvr%mvr_rp() + if (this%innpf > 0) call this%npf%npf_rp() + if (this%inbuy > 0) call this%buy%buy_rp() + if (this%inhfb > 0) call this%hfb%hfb_rp() + if (this%inoc > 0) call this%oc%oc_rp() + if (this%insto > 0) call this%sto%sto_rp() + if (this%incsub > 0) call this%csub%csub_rp() + if (this%inmvr > 0) call this%mvr%mvr_rp() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_rp() call packobj%bnd_rp_obs() - enddo + end do ! ! -- Return return @@ -507,29 +507,29 @@ subroutine gwf_ad(this) ! -- copy x into xold do n = 1, this%dis%nodes this%xold(n) = this%x(n) - enddo + end do else ! ! -- copy xold into x if this time step is a redo do n = 1, this%dis%nodes this%x(n) = this%xold(n) - enddo + end do end if ! ! -- Advance - if(this%innpf > 0) call this%npf%npf_ad(this%dis%nodes, this%xold, & - this%x, irestore) - if(this%insto > 0) call this%sto%sto_ad() - if(this%incsub > 0) call this%csub%csub_ad(this%dis%nodes, this%x) - if(this%inbuy > 0) call this%buy%buy_ad() - if(this%inmvr > 0) call this%mvr%mvr_ad() - do ip=1,this%bndlist%Count() + if (this%innpf > 0) call this%npf%npf_ad(this%dis%nodes, this%xold, & + this%x, irestore) + if (this%insto > 0) call this%sto%sto_ad() + if (this%incsub > 0) call this%csub%csub_ad(this%dis%nodes, this%x) + if (this%inbuy > 0) call this%buy%buy_ad() + if (this%inmvr > 0) call this%mvr%mvr_ad() + do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ad() if (isimcheck > 0) then call packobj%bnd_ck() end if - enddo + end do ! ! -- Push simulated values to preceding time/subtime step call this%obs%obs_ad() @@ -542,20 +542,20 @@ end subroutine gwf_ad subroutine gwf_cf(this, kiter) ! -- dummy class(GwfModelType) :: this - integer(I4B),intent(in) :: kiter + integer(I4B), intent(in) :: kiter ! -- local class(BndType), pointer :: packobj integer(I4B) :: ip ! ------------------------------------------------------------------------------ ! ! -- Call package cf routines - if(this%innpf > 0) call this%npf%npf_cf(kiter, this%dis%nodes, this%x) - if(this%inbuy > 0) call this%buy%buy_cf(kiter) + if (this%innpf > 0) call this%npf%npf_cf(kiter, this%dis%nodes, this%x) + if (this%inbuy > 0) call this%buy%buy_cf(kiter) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_cf() if (this%inbuy > 0) call this%buy%buy_cf_bnd(packobj, this%x) - enddo + end do ! ! -- return return @@ -577,70 +577,70 @@ subroutine gwf_fc(this, kiter, amatsln, njasln, inwtflag) ! ! -- newton flags inwt = inwtflag - if(inwtflag == 1) inwt = this%npf%inewton + if (inwtflag == 1) inwt = this%npf%inewton inwtsto = inwtflag - if(this%insto > 0) then - if(inwtflag == 1) inwtsto = this%sto%inewton - endif + if (this%insto > 0) then + if (inwtflag == 1) inwtsto = this%sto%inewton + end if inwtcsub = inwtflag - if(this%incsub > 0) then - if(inwtflag == 1) inwtcsub = this%csub%inewton - endif + if (this%incsub > 0) then + if (inwtflag == 1) inwtcsub = this%csub%inewton + end if ! ! -- Fill standard conductance terms - if(this%innpf > 0) call this%npf%npf_fc(kiter, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%inbuy > 0) call this%buy%buy_fc(kiter, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%inhfb > 0) call this%hfb%hfb_fc(kiter, njasln, amatsln, & - this%idxglo, this%rhs, this%x) - if(this%ingnc > 0) call this%gnc%gnc_fc(kiter, amatsln) + if (this%innpf > 0) call this%npf%npf_fc(kiter, njasln, amatsln, & + this%idxglo, this%rhs, this%x) + if (this%inbuy > 0) call this%buy%buy_fc(kiter, njasln, amatsln, & + this%idxglo, this%rhs, this%x) + if (this%inhfb > 0) call this%hfb%hfb_fc(kiter, njasln, amatsln, & + this%idxglo, this%rhs, this%x) + if (this%ingnc > 0) call this%gnc%gnc_fc(kiter, amatsln) ! -- storage - if(this%insto > 0) then - call this%sto%sto_fc(kiter, this%xold, this%x, njasln, amatsln, & + if (this%insto > 0) then + call this%sto%sto_fc(kiter, this%xold, this%x, njasln, amatsln, & this%idxglo, this%rhs) end if - ! -- skeletal storage, compaction, and land subsidence - if(this%incsub > 0) then - call this%csub%csub_fc(kiter, this%xold, this%x, njasln, amatsln, & + ! -- skeletal storage, compaction, and land subsidence + if (this%incsub > 0) then + call this%csub%csub_fc(kiter, this%xold, this%x, njasln, amatsln, & this%idxglo, this%rhs) end if - if(this%inmvr > 0) call this%mvr%mvr_fc() + if (this%inmvr > 0) call this%mvr%mvr_fc() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) - enddo + end do ! !--Fill newton terms - if(this%innpf > 0) then - if(inwt /= 0) then - call this%npf%npf_fn(kiter, njasln, amatsln, this%idxglo, this%rhs, & + if (this%innpf > 0) then + if (inwt /= 0) then + call this%npf%npf_fn(kiter, njasln, amatsln, this%idxglo, this%rhs, & this%x) - endif - endif + end if + end if ! ! -- Fill newton terms for ghost nodes - if(this%ingnc > 0) then - if(inwt /= 0) then - call this%gnc%gnc_fn(kiter, njasln, amatsln, this%npf%condsat, & - ivarcv_opt=this%npf%ivarcv, & - ictm1_opt=this%npf%icelltype, & - ictm2_opt=this%npf%icelltype) - endif - endif + if (this%ingnc > 0) then + if (inwt /= 0) then + call this%gnc%gnc_fn(kiter, njasln, amatsln, this%npf%condsat, & + ivarcv_opt=this%npf%ivarcv, & + ictm1_opt=this%npf%icelltype, & + ictm2_opt=this%npf%icelltype) + end if + end if ! ! -- Fill newton terms for storage - if(this%insto > 0) then + if (this%insto > 0) then if (inwtsto /= 0) then - call this%sto%sto_fn(kiter, this%xold, this%x, njasln, amatsln, & + call this%sto%sto_fn(kiter, this%xold, this%x, njasln, amatsln, & this%idxglo, this%rhs) end if end if ! - ! -- Fill newton terms for skeletal storage, compaction, and land subsidence - if(this%incsub > 0) then + ! -- Fill newton terms for skeletal storage, compaction, and land subsidence + if (this%incsub > 0) then if (inwtcsub /= 0) then - call this%csub%csub_fn(kiter, this%xold, this%x, njasln, amatsln, & + call this%csub%csub_fn(kiter, this%xold, this%x, njasln, amatsln, & this%idxglo, this%rhs) end if end if @@ -649,11 +649,11 @@ subroutine gwf_fc(this, kiter, amatsln, njasln, inwtflag) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) inwtpak = inwtflag - if(inwtflag == 1) inwtpak = packobj%inewton + if (inwtflag == 1) inwtpak = packobj%inewton if (inwtpak /= 0) then call packobj%bnd_fn(this%rhs, this%ia, this%idxglo, amatsln) end if - enddo + end do ! ! -- return return @@ -662,15 +662,15 @@ end subroutine gwf_fc !> @brief GroundWater Flow Model Final Convergence Check for Boundary Packages !! !! (1) calls package cc routines - !! + !! !< subroutine gwf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! -- dummy class(GwfModelType) :: this - integer(I4B),intent(in) :: innertot - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod + integer(I4B), intent(in) :: innertot + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod character(len=LENPAKLOC), intent(inout) :: cpak integer(I4B), intent(inout) :: ipak real(DP), intent(inout) :: dpak @@ -687,8 +687,8 @@ subroutine gwf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! ! -- csub convergence check if (this%incsub > 0) then - call this%csub%csub_cc(innertot, kiter, iend, icnvgmod, & - this%dis%nodes, this%x, this%xold, & + call this%csub%csub_cc(innertot, kiter, iend, icnvgmod, & + this%dis%nodes, this%x, this%xold, & cpak, ipak, dpak) end if ! @@ -696,12 +696,12 @@ subroutine gwf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_cc(innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) - enddo + end do ! ! -- return return end subroutine gwf_cc - + !> @brief check if pseudo-transient continuation factor should be used !! !! (1) Check if pseudo-transient continuation factor should be used @@ -712,7 +712,7 @@ subroutine gwf_ptcchk(this, iptc) class(GwfModelType) :: this integer(I4B), intent(inout) :: iptc ! ------------------------------------------------------------------------------ - ! -- determine if pseudo-transient continuation should be applied to this + ! -- determine if pseudo-transient continuation should be applied to this ! model - pseudo-transient continuation only applied to problems that ! use the Newton-Raphson formulation during steady-state stress periods iptc = 0 @@ -734,22 +734,22 @@ end subroutine gwf_ptcchk !! for the current outer iteration !! !< - subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & + subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & x, rhs, amatsln, iptc, ptcf) ! modules use ConstantsModule, only: DONE, DP9 ! -- dummy class(GwfModelType) :: this - integer(I4B),intent(in) :: kiter + integer(I4B), intent(in) :: kiter integer(I4B), intent(in) :: neqsln - integer(I4B),intent(in) :: njasln - integer(I4B), dimension(neqsln+1), intent(in) :: ia - integer(I4B),dimension(njasln),intent(in) :: ja + integer(I4B), intent(in) :: njasln + integer(I4B), dimension(neqsln + 1), intent(in) :: ia + integer(I4B), dimension(njasln), intent(in) :: ja real(DP), dimension(neqsln), intent(in) :: x real(DP), dimension(neqsln), intent(in) :: rhs - real(DP),dimension(njasln),intent(in) :: amatsln + real(DP), dimension(njasln), intent(in) :: amatsln integer(I4B), intent(inout) :: iptc - real(DP),intent(inout) :: ptcf + real(DP), intent(inout) :: ptcf ! -- local integer(I4B) :: iptct integer(I4B) :: n @@ -766,7 +766,7 @@ subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & ! -- set temporary flag indicating if pseudo-transient continuation should ! be used for this model and time step iptct = 0 - ! -- only apply pseudo-transient continuation to problems using the + ! -- only apply pseudo-transient continuation to problems using the ! Newton-Raphson formulations for steady-state stress periods if (this%iss > 0) then if (this%inewton > 0) then @@ -785,12 +785,12 @@ subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & if (this%npf%ibound(n) < 1) cycle jcol = n + this%moffset ! - ! get the maximum volume of the cell (head at top of cell) + ! get the maximum volume of the cell (head at top of cell) v = this%dis%get_cell_volume(n, this%dis%top(n)) ! ! -- calculate the residual for the cell resid = DZERO - do j = ia(jcol), ia(jcol+1)-1 + do j = ia(jcol), ia(jcol + 1) - 1 jj = ja(j) resid = resid + amatsln(j) * x(jcol) end do @@ -801,8 +801,8 @@ subroutine gwf_ptc(this, kiter, neqsln, njasln, ia, ja, & ptcdelem1 = abs(resid) / v ! ! -- set ptcf if the reciprocal of the pseudo-time step - ! exceeds the current value (equivalent to using the - ! smallest pseudo-time step) + ! exceeds the current value (equivalent to using the + ! smallest pseudo-time step) if (ptcdelem1 > ptcf) ptcf = ptcdelem1 ! ! -- determine minimum and maximum diagonal entries @@ -880,7 +880,7 @@ subroutine gwf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) dx(i0:i1), inewtonur, dxmax, locmax) i0 = i1 + 1 end if - enddo + end do end if ! ! -- return @@ -911,14 +911,14 @@ subroutine gwf_cq(this, icnvg, isuppress_output) ! its flow to this diagonal position. do i = 1, this%nja this%flowja(i) = DZERO - enddo - if(this%innpf > 0) call this%npf%npf_cq(this%x, this%flowja) - if(this%inbuy > 0) call this%buy%buy_cq(this%x, this%flowja) - if(this%inhfb > 0) call this%hfb%hfb_cq(this%x, this%flowja) - if(this%ingnc > 0) call this%gnc%gnc_cq(this%flowja) - if(this%insto > 0) call this%sto%sto_cq(this%flowja, this%x, this%xold) - if(this%incsub > 0) call this%csub%csub_cq(this%dis%nodes, this%x, & - this%xold, isuppress_output, & + end do + if (this%innpf > 0) call this%npf%npf_cq(this%x, this%flowja) + if (this%inbuy > 0) call this%buy%buy_cq(this%x, this%flowja) + if (this%inhfb > 0) call this%hfb%hfb_cq(this%x, this%flowja) + if (this%ingnc > 0) call this%gnc%gnc_cq(this%flowja) + if (this%insto > 0) call this%sto%sto_cq(this%flowja, this%x, this%xold) + if (this%incsub > 0) call this%csub%csub_cq(this%dis%nodes, this%x, & + this%xold, isuppress_output, & this%flowja) ! ! -- Go through packages and call cq routines. cf() routines are called @@ -929,12 +929,12 @@ subroutine gwf_cq(this, icnvg, isuppress_output) call packobj%bnd_cf(reset_mover=.false.) if (this%inbuy > 0) call this%buy%buy_cf_bnd(packobj, this%x) call packobj%bnd_cq(this%x, this%flowja) - enddo + end do ! ! -- Return return end subroutine gwf_cq - + !> @brief GroundWater Flow Model Budget !! !! (1) Calculate stress package contributions to model budget @@ -965,13 +965,13 @@ subroutine gwf_bd(this, icnvg, isuppress_output) ! should be added here to this%budget. In a subsequent exchange call, ! exchange flows might also be added. call this%budget%reset() - if(this%insto > 0) call this%sto%sto_bd(isuppress_output, this%budget) - if(this%incsub > 0) call this%csub%csub_bd(isuppress_output, this%budget) - if(this%inmvr > 0) call this%mvr%mvr_bd() + if (this%insto > 0) call this%sto%sto_bd(isuppress_output, this%budget) + if (this%incsub > 0) call this%csub%csub_bd(isuppress_output, this%budget) + if (this%inmvr > 0) call this%mvr%mvr_bd() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_bd(this%budget) - enddo + end do ! ! -- npf velocities have to be calculated here, after gwf-gwf exchanges ! have passed in their contributions from exg_cq() @@ -999,7 +999,7 @@ subroutine gwf_ot(this) integer(I4B) :: ibudfl integer(I4B) :: ipflag ! -- formats - character(len=*),parameter :: fmtnocnvg = & + character(len=*), parameter :: fmtnocnvg = & "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & &I0,' OF STRESS PERIOD ',I0,'****')" ! ------------------------------------------------------------------------------ @@ -1009,10 +1009,10 @@ subroutine gwf_ot(this) idvprint = 0 icbcfl = 0 ibudfl = 0 - if(this%oc%oc_save('HEAD')) idvsave = 1 - if(this%oc%oc_print('HEAD')) idvprint = 1 - if(this%oc%oc_save('BUDGET')) icbcfl = 1 - if(this%oc%oc_print('BUDGET')) ibudfl = 1 + if (this%oc%oc_save('HEAD')) idvsave = 1 + if (this%oc%oc_print('HEAD')) idvprint = 1 + if (this%oc%oc_save('BUDGET')) icbcfl = 1 + if (this%oc%oc_print('BUDGET')) ibudfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') ! ! -- Override ibudfl and idvprint flags for nonconvergence @@ -1022,38 +1022,38 @@ subroutine gwf_ot(this) ! ! Calculate and save observations call this%gwf_ot_obs() - ! + ! ! Save and print flows call this%gwf_ot_flow(icbcfl, ibudfl, icbcun) - ! + ! ! Save and print dependent variables call this%gwf_ot_dv(idvsave, idvprint, ipflag) - ! + ! ! Print budget summaries call this%gwf_ot_bdsummary(ibudfl, ipflag) ! ! -- Timing Output; if any dependendent variables or budgets ! are printed, then ipflag is set to 1. - if(ipflag == 1) call tdis_ot(this%iout) + if (ipflag == 1) call tdis_ot(this%iout) ! ! -- Write non-convergence message - if(this%icnvg == 0) then - write(this%iout, fmtnocnvg) kstp, kper - endif + if (this%icnvg == 0) then + write (this%iout, fmtnocnvg) kstp, kper + end if ! ! -- Return return end subroutine gwf_ot - + subroutine gwf_ot_obs(this) class(GwfModelType) :: this class(BndType), pointer :: packobj integer(I4B) :: ip - + ! -- Calculate and save GWF observations call this%obs%obs_bd() call this%obs%obs_ot() - + ! -- Calculate and save csub observations if (this%incsub > 0) then call this%csub%csub_bd_obs() @@ -1066,9 +1066,9 @@ subroutine gwf_ot_obs(this) call packobj%bnd_bd_obs() call packobj%bnd_ot_obs() end do - + end subroutine gwf_ot_obs - + subroutine gwf_ot_flow(this, icbcfl, ibudfl, icbcun) class(GwfModelType) :: this integer(I4B), intent(in) :: icbcfl @@ -1078,46 +1078,46 @@ subroutine gwf_ot_flow(this, icbcfl, ibudfl, icbcun) integer(I4B) :: ip ! -- Save GWF flows - if(this%insto > 0) then + if (this%insto > 0) then call this%sto%sto_save_model_flows(icbcfl, icbcun) - endif - if(this%innpf > 0) then + end if + if (this%innpf > 0) then call this%npf%npf_save_model_flows(this%flowja, icbcfl, icbcun) - endif - if(this%incsub > 0) call this%csub%csub_save_model_flows(icbcfl, icbcun) + end if + if (this%incsub > 0) call this%csub%csub_save_model_flows(icbcfl, icbcun) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) end do - + ! -- Save advanced package flows do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) end do - if(this%inmvr > 0) then + if (this%inmvr > 0) then call this%mvr%mvr_ot_saveflow(icbcfl, ibudfl) end if ! -- Print GWF flows - if(this%innpf > 0) call this%npf%npf_print_model_flows(ibudfl, this%flowja) - if(this%ingnc > 0) call this%gnc%gnc_ot(ibudfl) + if (this%innpf > 0) call this%npf%npf_print_model_flows(ibudfl, this%flowja) + if (this%ingnc > 0) call this%gnc%gnc_ot(ibudfl) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) end do - + ! -- Print advanced package flows do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) end do - if(this%inmvr > 0) then + if (this%inmvr > 0) then call this%mvr%mvr_ot_printflow(icbcfl, ibudfl) end if - + end subroutine gwf_ot_flow - + subroutine gwf_ot_dv(this, idvsave, idvprint, ipflag) class(GwfModelType) :: this integer(I4B), intent(in) :: idvsave @@ -1125,26 +1125,26 @@ subroutine gwf_ot_dv(this, idvsave, idvprint, ipflag) integer(I4B), intent(inout) :: ipflag class(BndType), pointer :: packobj integer(I4B) :: ip - + ! -- Save compaction to binary file - if(this%incsub > 0) call this%csub%csub_ot_dv(idvsave, idvprint) - + if (this%incsub > 0) call this%csub%csub_ot_dv(idvsave, idvprint) + ! -- save density to binary file if (this%inbuy > 0) then call this%buy%buy_ot_dv(idvsave) end if - + ! -- Print advanced package dependent variables do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_dv(idvsave, idvprint) end do - + ! -- save head and print head call this%oc%oc_ot(ipflag) - + end subroutine gwf_ot_dv - + subroutine gwf_ot_bdsummary(this, ibudfl, ipflag) use TdisModule, only: kstp, kper, totim class(GwfModelType) :: this @@ -1158,24 +1158,24 @@ subroutine gwf_ot_bdsummary(this, ibudfl, ipflag) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) - enddo - + end do + ! -- mover budget summary - if(this%inmvr > 0) then + if (this%inmvr > 0) then call this%mvr%mvr_ot_bdsummary(ibudfl) end if - + ! -- model budget summary if (ibudfl /= 0) then ipflag = 1 call this%budget%budget_ot(kstp, kper, this%iout) end if - + ! -- Write to budget csv every time step call this%budget%writecsv(totim) - + end subroutine gwf_ot_bdsummary - + !> @brief Final processing subroutine gwf_fp(this) ! -- modules @@ -1200,7 +1200,7 @@ subroutine gwf_da(this) class(GwfModelType) :: this ! -- local integer(I4B) :: ip - class(BndType),pointer :: packobj + class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ ! ! -- Internal flow packages deallocate @@ -1219,26 +1219,26 @@ subroutine gwf_da(this) call this%obs%obs_da() ! ! -- Internal package objects - deallocate(this%dis) - deallocate(this%ic) - deallocate(this%npf) - deallocate(this%xt3d) - deallocate(this%buy) - deallocate(this%gnc) - deallocate(this%sto) - deallocate(this%csub) - deallocate(this%budget) - deallocate(this%hfb) - deallocate(this%mvr) - deallocate(this%obs) - deallocate(this%oc) + deallocate (this%dis) + deallocate (this%ic) + deallocate (this%npf) + deallocate (this%xt3d) + deallocate (this%buy) + deallocate (this%gnc) + deallocate (this%sto) + deallocate (this%csub) + deallocate (this%budget) + deallocate (this%hfb) + deallocate (this%mvr) + deallocate (this%obs) + deallocate (this%oc) ! ! -- Boundary packages do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_da() - deallocate(packobj) - enddo + deallocate (packobj) + end do ! ! -- Scalars call mem_deallocate(this%inic) @@ -1272,7 +1272,7 @@ end subroutine gwf_da subroutine gwf_bdentry(this, budterm, budtxt, rowlabel) ! -- modules use ConstantsModule, only: LENBUDTXT - use TdisModule, only:delt + use TdisModule, only: delt ! -- dummy class(GwfModelType) :: this real(DP), dimension(:, :), intent(in) :: budterm @@ -1288,8 +1288,8 @@ end subroutine gwf_bdentry !> @brief return 1 if any package causes the matrix to be asymmetric. !! Otherwise return 0. - !< - function gwf_get_iasym(this) result (iasym) + !< + function gwf_get_iasym(this) result(iasym) class(GwfModelType) :: this ! -- local integer(I4B) :: iasym @@ -1304,18 +1304,18 @@ function gwf_get_iasym(this) result (iasym) if (this%innpf > 0) then if (this%npf%iasym /= 0) iasym = 1 if (this%npf%ixt3d /= 0) iasym = 1 - endif + end if ! ! -- GNC if (this%ingnc > 0) then if (this%gnc%iasym /= 0) iasym = 1 - endif + end if ! ! -- Check for any packages that introduce matrix asymmetry - do ip=1,this%bndlist%Count() + do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) if (packobj%iasym /= 0) iasym = 1 - enddo + end do ! ! -- return return @@ -1327,15 +1327,15 @@ subroutine allocate_scalars(this, modelname) use MemoryManagerModule, only: mem_allocate ! -- dummy class(GwfModelType) :: this - character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: modelname ! ------------------------------------------------------------------------------ ! ! -- allocate members from parent class call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class - call mem_allocate(this%inic, 'INIC', this%memoryPath) - call mem_allocate(this%inoc, 'INOC', this%memoryPath) + call mem_allocate(this%inic, 'INIC', this%memoryPath) + call mem_allocate(this%inoc, 'INOC', this%memoryPath) call mem_allocate(this%innpf, 'INNPF', this%memoryPath) call mem_allocate(this%inbuy, 'INBUY', this%memoryPath) call mem_allocate(this%insto, 'INSTO', this%memoryPath) @@ -1344,7 +1344,7 @@ subroutine allocate_scalars(this, modelname) call mem_allocate(this%inhfb, 'INHFB', this%memoryPath) call mem_allocate(this%ingnc, 'INGNC', this%memoryPath) call mem_allocate(this%inobs, 'INOBS', this%memoryPath) - call mem_allocate(this%iss, 'ISS', this%memoryPath) + call mem_allocate(this%iss, 'ISS', this%memoryPath) call mem_allocate(this%inewtonur, 'INEWTONUR', this%memoryPath) ! this%inic = 0 @@ -1357,7 +1357,7 @@ subroutine allocate_scalars(this, modelname) this%inhfb = 0 this%ingnc = 0 this%inobs = 0 - this%iss = 1 !default is steady-state (i.e., no STO package) + this%iss = 1 !default is steady-state (i.e., no STO package) this%inewtonur = 0 !default is to not use newton bottom head dampening ! ! -- return @@ -1370,7 +1370,7 @@ end subroutine allocate_scalars !! (2) add a pointer to the package !! !< - subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & + subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) ! -- modules use ConstantsModule, only: LINELENGTH @@ -1389,13 +1389,13 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & use ApiModule, only: api_create ! -- dummy class(GwfModelType) :: this - character(len=*),intent(in) :: filtyp + character(len=*), intent(in) :: filtyp character(len=LINELENGTH) :: errmsg - integer(I4B),intent(in) :: ipakid - integer(I4B),intent(in) :: ipaknum + integer(I4B), intent(in) :: ipakid + integer(I4B), intent(in) :: ipaknum character(len=*), intent(in) :: pakname - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout ! -- local class(BndType), pointer :: packobj class(BndType), pointer :: packobj2 @@ -1403,33 +1403,33 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! ------------------------------------------------------------------------------ ! ! -- This part creates the package object - select case(filtyp) - case('CHD6') + select case (filtyp) + case ('CHD6') call chd_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('WEL6') + case ('WEL6') call wel_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('DRN6') + case ('DRN6') call drn_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('RIV6') + case ('RIV6') call riv_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('GHB6') + case ('GHB6') call ghb_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('RCH6') + case ('RCH6') call rch_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('EVT6') + case ('EVT6') call evt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('MAW6') + case ('MAW6') call maw_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('SFR6') + case ('SFR6') call sfr_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('LAK6') + case ('LAK6') call lak_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('UZF6') + case ('UZF6') call uzf_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('API6') + case ('API6') call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) case default - write(errmsg, *) 'Invalid package type: ', filtyp + write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) end select ! @@ -1437,12 +1437,12 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! pointer to the package in the model bndlist do ip = 1, this%bndlist%Count() packobj2 => GetBndFromList(this%bndlist, ip) - if(packobj2%packName == pakname) then - write(errmsg, '(a,a)') 'Cannot create package. Package name ' // & + if (packobj2%packName == pakname) then + write (errmsg, '(a,a)') 'Cannot create package. Package name '// & 'already exists: ', trim(pakname) call store_error(errmsg, terminate=.TRUE.) - endif - enddo + end if + end do call AddBndToList(this%bndlist, packobj) ! ! -- return @@ -1452,9 +1452,9 @@ end subroutine package_create !> @brief Check to make sure required input files have been specified subroutine ftype_check(this, namefile_obj, indis) ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors - use NameFileModule, only: NameFileType + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors + use NameFileModule, only: NameFileType ! -- dummy class(GwfModelType) :: this type(NameFileType), intent(in) :: namefile_obj @@ -1462,90 +1462,93 @@ subroutine ftype_check(this, namefile_obj, indis) ! -- local character(len=LINELENGTH) :: errmsg integer(I4B) :: i, iu - character(len=LENFTYPE), dimension(11) :: nodupftype = & - (/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'OC6 ', 'NPF6 ', 'STO6 ', & - 'MVR6 ', 'HFB6 ', 'GNC6 ', 'OBS6 '/) + character(len=LENFTYPE), dimension(11) :: nodupftype = & + (/'DIS6 ', 'DISU6', 'DISV6', & + 'IC6 ', 'OC6 ', 'NPF6 ', & + 'STO6 ', 'MVR6 ', 'HFB6 ', & + 'GNC6 ', 'OBS6 '/) ! ------------------------------------------------------------------------------ ! - if(this%single_model_run) then + if (this%single_model_run) then ! ! -- Ensure TDIS6 is present call namefile_obj%get_unitnumber('TDIS6', iu, 1) - if(iu == 0) then + if (iu == 0) then call store_error('TDIS6 ftype not specified in name file.') - endif + end if ! ! -- Ensure IMS6 is present call namefile_obj%get_unitnumber('IMS6', iu, 1) - if(iu == 0) then + if (iu == 0) then call store_error('IMS6 ftype not specified in name file.') - endif + end if ! else ! ! -- Warn if TDIS6 is present call namefile_obj%get_unitnumber('TDIS6', iu, 1) - if(iu > 0) then - write(this%iout, '(/a)') 'Warning TDIS6 detected in GWF name file.' - write(this%iout, *) 'Simulation TDIS file will be used instead.' - close(iu) - endif + if (iu > 0) then + write (this%iout, '(/a)') 'Warning TDIS6 detected in GWF name file.' + write (this%iout, *) 'Simulation TDIS file will be used instead.' + close (iu) + end if ! ! -- Warn if SMS8 is present call namefile_obj%get_unitnumber('IMS6', iu, 1) - if(iu > 0) then - write(this%iout, '(/a)') 'Warning IMS6 detected in GWF name file.' - write(this%iout, *) 'Simulation IMS6 file will be used instead.' - close(iu) - endif - endif + if (iu > 0) then + write (this%iout, '(/a)') 'Warning IMS6 detected in GWF name file.' + write (this%iout, *) 'Simulation IMS6 file will be used instead.' + close (iu) + end if + end if ! ! -- Check for IC8, DIS(u), and NPF. Stop if not present. - if(this%inic==0) then - write(errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' + if (this%inic == 0) then + write (errmsg, '(1x,a)') & + 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' call store_error(errmsg) - endif - if(indis==0) then - write(errmsg, '(1x,a)') & + end if + if (indis == 0) then + write (errmsg, '(1x,a)') & 'ERROR. DISCRETIZATION (DIS6, DISV6, or DISU6) PACKAGE NOT SPECIFIED.' call store_error(errmsg) - endif - if(this%innpf==0) then - write(errmsg, '(1x,a)') & + end if + if (this%innpf == 0) then + write (errmsg, '(1x,a)') & 'ERROR. NODE PROPERTY FLOW (NPF6) PACKAGE NOT SPECIFIED.' call store_error(errmsg) - endif - if(count_errors() > 0) then - write(errmsg,'(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' + end if + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' call store_error(errmsg) - endif + end if ! ! -- Check to make sure that some GWF packages are not specified more ! than once do i = 1, size(nodupftype) call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) if (iu > 0) then - write(errmsg,'(1x, a, a, a)') & - 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & + write (errmsg, '(1x, a, a, a)') & + 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & ' NOT ALLOWED FOR GWF MODEL.' call store_error(errmsg) - endif - enddo + end if + end do ! ! -- Stop if errors - if(count_errors() > 0) then - write(errmsg, '(a, a)') 'Error occurred while reading file: ', & + if (count_errors() > 0) then + write (errmsg, '(a, a)') 'Error occurred while reading file: ', & trim(namefile_obj%filename) call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- return return end subroutine ftype_check - + !> @brief Cast to GWF model !< - function CastAsGwfModel(model) result (gwfModel) + function CastAsGwfModel(model) result(gwfModel) implicit none class(*), pointer, intent(inout) :: model class(GwfModelType), pointer :: gwfModel @@ -1554,11 +1557,10 @@ function CastAsGwfModel(model) result (gwfModel) if (.not. associated(model)) return select type (model) class is (GwfModelType) - gwfModel => model + gwfModel => model end select return - + end function CastAsGwfModel - end module GwfModule diff --git a/src/Model/GroundWaterFlow/gwf3api8.f90 b/src/Model/GroundWaterFlow/gwf3api8.f90 index 6ac2ee1c39e..2e381f14149 100644 --- a/src/Model/GroundWaterFlow/gwf3api8.f90 +++ b/src/Model/GroundWaterFlow/gwf3api8.f90 @@ -2,10 +2,10 @@ !! !! This module contains the overridden methods from the base model package !! class for the API package. The API package is designed to be used with the -!! shared object and have period data specified using the MODFLOW API. Several -!! methods need to be overridden since no period data are specified in the +!! shared object and have period data specified using the MODFLOW API. Several +!! methods need to be overridden since no period data are specified in the !! API input file. Overridden methods include: -!! - bnd_rp no period data is specified +!! - bnd_rp no period data is specified !! - bnd_fc BOUND array is not filled. hcof and rhs are specified dierctly !! !< @@ -24,7 +24,7 @@ module apimodule public :: api_create public :: ApiType ! - character(len=LENFTYPE) :: ftype = 'API' + character(len=LENFTYPE) :: ftype = 'API' character(len=LENPACKAGENAME) :: text = ' API' ! type, extends(BndType) :: ApiType @@ -46,13 +46,13 @@ module apimodule !< subroutine api_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! -- dummy variables - class(BndType), pointer :: packobj !< pointer to default package type - integer(I4B), intent(in) :: id !< package id - integer(I4B), intent(in) :: ibcnum !< boundary condition number - integer(I4B), intent(in) :: inunit !< unit number of USR package input file - integer(I4B), intent(in) :: iout !< unit number of model listing file - character(len=*), intent(in) :: namemodel !< model name - character(len=*), intent(in) :: pakname !< package name + class(BndType), pointer :: packobj !< pointer to default package type + integer(I4B), intent(in) :: id !< package id + integer(I4B), intent(in) :: ibcnum !< boundary condition number + integer(I4B), intent(in) :: inunit !< unit number of USR package input file + integer(I4B), intent(in) :: iout !< unit number of model listing file + character(len=*), intent(in) :: namemodel !< model name + character(len=*), intent(in) :: pakname !< package name ! -- local variables type(ApiType), pointer :: apiobj ! @@ -133,10 +133,10 @@ end subroutine api_rp subroutine api_fc(this, rhs, ia, idxglo, amatsln) ! -- dummy variables class(ApiType) :: this - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector - integer(I4B), dimension(:), intent(in) :: ia !< pointer to the rows in A matrix - integer(I4B), dimension(:), intent(in) :: idxglo !< position of entries in A matrix - real(DP), dimension(:), intent(inout) :: amatsln !< A matrix for solution + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector + integer(I4B), dimension(:), intent(in) :: ia !< pointer to the rows in A matrix + integer(I4B), dimension(:), intent(in) :: idxglo !< position of entries in A matrix + real(DP), dimension(:), intent(inout) :: amatsln !< A matrix for solution ! -- local variables integer(I4B) :: i integer(I4B) :: n @@ -157,7 +157,7 @@ subroutine api_fc(this, rhs, ia, idxglo, amatsln) ! ! -- If mover is active and this boundary is discharging, ! store available water (as positive value). - qusr = this%rhs(i) - this%hcof(i)*this%xnew(n) + qusr = this%rhs(i) - this%hcof(i) * this%xnew(n) if (this%imover == 1 .and. qusr > DZERO) then call this%pakmvrobj%accumulate_qformvr(i, qusr) end if diff --git a/src/Model/GroundWaterFlow/gwf3buy8.f90 b/src/Model/GroundWaterFlow/gwf3buy8.f90 index 563612f203b..e5029e404a5 100644 --- a/src/Model/GroundWaterFlow/gwf3buy8.f90 +++ b/src/Model/GroundWaterFlow/gwf3buy8.f90 @@ -1,54 +1,53 @@ ! Buoyancy Package for representing variable-density groundwater flow ! The BUY Package does not work yet with the NPF XT3D option - module GwfBuyModule - - use KindModule, only: DP, I4B - use SimModule, only: store_error, count_errors - use MemoryManagerModule, only: mem_allocate, mem_reallocate, & - mem_deallocate - use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, & - LENAUXNAME, DHNOFLO, MAXCHARLEN, LINELENGTH + + use KindModule, only: DP, I4B + use SimModule, only: store_error, count_errors + use MemoryManagerModule, only: mem_allocate, mem_reallocate, & + mem_deallocate + use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, & + LENAUXNAME, DHNOFLO, MAXCHARLEN, LINELENGTH use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use GwfNpfModule, only: GwfNpfType - use GwfBuyInputDataModule, only: GwfBuyInputDataType - + use BaseDisModule, only: DisBaseType + use GwfNpfModule, only: GwfNpfType + use GwfBuyInputDataModule, only: GwfBuyInputDataType + implicit none private public :: GwfBuyType public :: buy_cr - + type :: ConcentrationPointer - real(DP), dimension(:), pointer :: conc => null() ! pointer to concentration array - integer(I4B), dimension(:), pointer :: icbund => null() ! store pointer to gwt ibound array + real(DP), dimension(:), pointer :: conc => null() ! pointer to concentration array + integer(I4B), dimension(:), pointer :: icbund => null() ! store pointer to gwt ibound array end type ConcentrationPointer type, extends(NumericalPackageType) :: GwfBuyType - type(GwfNpfType), pointer :: npf => null() ! npf object - integer(I4B), pointer :: ioutdense => null() ! unit number for saving density - integer(I4B), pointer :: iform => null() ! formulation: 0 freshwater head, 1 hh rhs, 2 hydraulic head - integer(I4B), pointer :: ireadelev => null() ! if 1 then elev has been allocated and filled - integer(I4B), pointer :: ireadconcbuy => null() ! if 1 then dense has been read from this buy input file - integer(I4B), pointer :: iconcset => null() ! if 1 then conc is pointed to a gwt model%x - real(DP), pointer :: denseref => null() ! reference fluid density - real(DP), dimension(:), pointer, contiguous :: dense => null() ! density - real(DP), dimension(:), pointer, contiguous :: concbuy => null() ! concentration array if specified in buy package - real(DP), dimension(:), pointer, contiguous :: elev => null() ! cell center elevation (optional; if not specified, hten use (top+bot)/2) - integer(I4B), dimension(:), pointer :: ibound => null() ! store pointer to ibound - - integer(I4B), pointer :: nrhospecies => null() ! number of species used in equation of state to calculate density - real(DP), dimension(:), pointer, contiguous :: drhodc => null() ! change in density with change in concentration - real(DP), dimension(:), pointer, contiguous :: crhoref => null() ! reference concentration used in equation of state - real(DP), dimension(:), pointer, contiguous :: ctemp => null() ! temporary array of size (nrhospec) to pass to calcdens - character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname ! names of gwt models used in equation of state - character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname ! names of gwt models used in equation of state + type(GwfNpfType), pointer :: npf => null() ! npf object + integer(I4B), pointer :: ioutdense => null() ! unit number for saving density + integer(I4B), pointer :: iform => null() ! formulation: 0 freshwater head, 1 hh rhs, 2 hydraulic head + integer(I4B), pointer :: ireadelev => null() ! if 1 then elev has been allocated and filled + integer(I4B), pointer :: ireadconcbuy => null() ! if 1 then dense has been read from this buy input file + integer(I4B), pointer :: iconcset => null() ! if 1 then conc is pointed to a gwt model%x + real(DP), pointer :: denseref => null() ! reference fluid density + real(DP), dimension(:), pointer, contiguous :: dense => null() ! density + real(DP), dimension(:), pointer, contiguous :: concbuy => null() ! concentration array if specified in buy package + real(DP), dimension(:), pointer, contiguous :: elev => null() ! cell center elevation (optional; if not specified, hten use (top+bot)/2) + integer(I4B), dimension(:), pointer :: ibound => null() ! store pointer to ibound - type(ConcentrationPointer), allocatable, dimension(:) :: modelconc ! concentration pointer for each transport model - - contains + integer(I4B), pointer :: nrhospecies => null() ! number of species used in equation of state to calculate density + real(DP), dimension(:), pointer, contiguous :: drhodc => null() ! change in density with change in concentration + real(DP), dimension(:), pointer, contiguous :: crhoref => null() ! reference concentration used in equation of state + real(DP), dimension(:), pointer, contiguous :: ctemp => null() ! temporary array of size (nrhospec) to pass to calcdens + character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname ! names of gwt models used in equation of state + character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname ! names of gwt models used in equation of state + + type(ConcentrationPointer), allocatable, dimension(:) :: modelconc ! concentration pointer for each transport model + + contains procedure :: buy_df procedure :: buy_ar procedure :: buy_ar_bnd @@ -67,15 +66,15 @@ module GwfBuyModule procedure :: allocate_scalars procedure, private :: allocate_arrays procedure, private :: read_options - procedure, private :: set_options + procedure, private :: set_options procedure, private :: read_dimensions procedure, private :: read_packagedata procedure, private :: set_packagedata procedure :: set_concentration_pointer end type GwfBuyType - - contains - + +contains + function calcdens(denseref, drhodc, crhoref, conc) result(dense) ! ****************************************************************************** ! calcdens -- generic function to calculate fluid density from concentration @@ -120,7 +119,7 @@ subroutine buy_cr(buyobj, name_model, inunit, iout) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(buyobj) + allocate (buyobj) ! ! -- create name and memory path call buyobj%set_names(1, name_model, 'BUY', 'BUY') @@ -140,7 +139,7 @@ subroutine buy_cr(buyobj, name_model, inunit, iout) end subroutine buy_cr !> @brief Read options and package data, or set from argument - !< + !< subroutine buy_df(this, dis, buy_input) ! ****************************************************************************** ! buy_df -- Allocate and Read @@ -150,18 +149,18 @@ subroutine buy_df(this, dis, buy_input) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwfBuyType) :: this !< this buoyancy package - class(DisBaseType), pointer, intent(in) :: dis !< pointer to discretization + class(GwfBuyType) :: this !< this buoyancy package + class(DisBaseType), pointer, intent(in) :: dis !< pointer to discretization type(GwfBuyInputDataType), optional, intent(in) :: buy_input !< optional buy input data, otherwise read from file ! -- local ! -- formats - character(len=*), parameter :: fmtbuy = & - "(1x,/1x,'BUY -- BUOYANCY PACKAGE, VERSION 1, 5/16/2018', & + character(len=*), parameter :: fmtbuy = & + "(1x,/1x,'BUY -- BUOYANCY PACKAGE, VERSION 1, 5/16/2018', & &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! --print a message identifying the buoyancy package. - write(this%iout, fmtbuy) this%inunit + write (this%iout, fmtbuy) this%inunit ! ! -- store pointers to arguments that were passed in this%dis => dis @@ -212,15 +211,15 @@ subroutine buy_ar(this, npf, ibound) ! ------------------------------------------------------------------------------ ! ! -- store pointers to arguments that were passed in - this%npf => npf - this%ibound => ibound + this%npf => npf + this%ibound => ibound ! ! -- Ensure NPF XT3D is not on if (this%npf%ixt3d /= 0) then - call store_error('Error in model ' // trim(this%name_model) // & - '. The XT3D option cannot be used with the BUY Package.') + call store_error('Error in model '//trim(this%name_model)// & + '. The XT3D option cannot be used with the BUY Package.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Calculate cell elevations call this%buy_calcelev() @@ -251,39 +250,39 @@ subroutine buy_ar_bnd(this, packobj, hnew) ! ! -- Add density terms based on boundary package type select case (packobj%filtyp) - case('LAK') - ! - ! -- activate density for lake package - select type(packobj) - type is (LakType) - call packobj%lak_activate_density() - end select - - case('SFR') - ! - ! -- activate density for sfr package - select type(packobj) - type is (SfrType) - call packobj%sfr_activate_density() - end select - - case('MAW') - ! - ! -- activate density for maw package - select type(packobj) - type is (MawType) - call packobj%maw_activate_density() - end select - - case default - ! - ! -- nothing + case ('LAK') + ! + ! -- activate density for lake package + select type (packobj) + type is (LakType) + call packobj%lak_activate_density() + end select + + case ('SFR') + ! + ! -- activate density for sfr package + select type (packobj) + type is (SfrType) + call packobj%sfr_activate_density() + end select + + case ('MAW') + ! + ! -- activate density for maw package + select type (packobj) + type is (MawType) + call packobj%maw_activate_density() + end select + + case default + ! + ! -- nothing end select ! ! -- Return return end subroutine buy_ar_bnd - + subroutine buy_rp(this) ! ****************************************************************************** ! buy_rp -- Check for new buy period data @@ -299,7 +298,7 @@ subroutine buy_rp(this) character(len=LINELENGTH) :: errmsg integer(I4B) :: i ! -- formats - character(len=*),parameter :: fmtc = & + character(len=*), parameter :: fmtc = & "('BUOYANCY PACKAGE DOES NOT HAVE HAVE A CONCENTRATION SET & &FOR SPECIES ',i0,'. ONE OR MORE MODEL NAMES MAY BE SPECIFIED & &INCORRECTLY IN THE PACKAGEDATA BLOCK OR A GWF-GWT EXCHANGE MAY NEED & @@ -310,7 +309,7 @@ subroutine buy_rp(this) if (kstp * kper == 1) then do i = 1, this%nrhospecies if (.not. associated(this%modelconc(i)%conc)) then - write(errmsg, fmtc) i + write (errmsg, fmtc) i call store_error(errmsg) end if end do @@ -341,7 +340,7 @@ subroutine buy_ad(this) ! -- Return return end subroutine buy_ad - + subroutine buy_cf(this, kiter) ! ****************************************************************************** ! buy_cf -- Fill coefficients @@ -365,7 +364,7 @@ subroutine buy_cf(this, kiter) ! -- Return return end subroutine buy_cf - + subroutine buy_cf_bnd(this, packobj, hnew) !, hcof, rhs, auxnam, auxvar) ! ****************************************************************************** ! buy_cf_bnd -- Fill coefficients @@ -392,7 +391,7 @@ subroutine buy_cf_bnd(this, packobj, hnew) !, hcof, rhs, auxnam, auxvar) ! -- initialize locdense = 0 locelev = 0 - allocate(locconc(this%nrhospecies)) + allocate (locconc(this%nrhospecies)) locconc(:) = 0 ! ! -- Add buoyancy terms for head-dependent boundaries @@ -422,54 +421,54 @@ subroutine buy_cf_bnd(this, packobj, hnew) !, hcof, rhs, auxnam, auxvar) ! ! -- Add density terms based on boundary package type select case (packobj%filtyp) - case('GHB') - ! - ! -- general head boundary - call buy_cf_ghb(packobj, hnew, this%dense, this%elev, this%denseref, & - locelev, locdense, locconc, this%drhodc, this%crhoref, & - this%ctemp, this%iform) - case('RIV') - ! - ! -- river - call buy_cf_riv(packobj, hnew, this%dense, this%elev, this%denseref, & - locelev, locdense, locconc, this%drhodc, this%crhoref, & - this%ctemp, this%iform) - case('DRN') - ! - ! -- drain - call buy_cf_drn(packobj, hnew, this%dense, this%denseref) - case('LAK') - ! - ! -- lake - call buy_cf_lak(packobj, hnew, this%dense, this%elev, this%denseref, & - locdense, locconc, this%drhodc, this%crhoref, & - this%ctemp, this%iform) - case('SFR') - ! - ! -- sfr - call buy_cf_sfr(packobj, hnew, this%dense, this%elev, this%denseref, & - locdense, locconc, this%drhodc, this%crhoref, & - this%ctemp, this%iform) - case('MAW') - ! - ! -- maw - call buy_cf_maw(packobj, hnew, this%dense, this%elev, this%denseref, & - locdense, locconc, this%drhodc, this%crhoref, & - this%ctemp, this%iform) - case default - ! - ! -- nothing + case ('GHB') + ! + ! -- general head boundary + call buy_cf_ghb(packobj, hnew, this%dense, this%elev, this%denseref, & + locelev, locdense, locconc, this%drhodc, this%crhoref, & + this%ctemp, this%iform) + case ('RIV') + ! + ! -- river + call buy_cf_riv(packobj, hnew, this%dense, this%elev, this%denseref, & + locelev, locdense, locconc, this%drhodc, this%crhoref, & + this%ctemp, this%iform) + case ('DRN') + ! + ! -- drain + call buy_cf_drn(packobj, hnew, this%dense, this%denseref) + case ('LAK') + ! + ! -- lake + call buy_cf_lak(packobj, hnew, this%dense, this%elev, this%denseref, & + locdense, locconc, this%drhodc, this%crhoref, & + this%ctemp, this%iform) + case ('SFR') + ! + ! -- sfr + call buy_cf_sfr(packobj, hnew, this%dense, this%elev, this%denseref, & + locdense, locconc, this%drhodc, this%crhoref, & + this%ctemp, this%iform) + case ('MAW') + ! + ! -- maw + call buy_cf_maw(packobj, hnew, this%dense, this%elev, this%denseref, & + locdense, locconc, this%drhodc, this%crhoref, & + this%ctemp, this%iform) + case default + ! + ! -- nothing end select ! ! -- deallocate - deallocate(locconc) + deallocate (locconc) ! ! -- Return return end subroutine buy_cf_bnd - - function get_bnd_density(n, locdense, locconc, denseref, drhodc, crhoref, & - ctemp, auxvar) result (densebnd) + + function get_bnd_density(n, locdense, locconc, denseref, drhodc, crhoref, & + ctemp, auxvar) result(densebnd) ! ****************************************************************************** ! get_bnd_density -- Return the density of the boundary package using one of ! several different options in the following order of priority: @@ -517,9 +516,9 @@ function get_bnd_density(n, locdense, locconc, denseref, drhodc, crhoref, & ! -- return return end function get_bnd_density - - subroutine buy_cf_ghb(packobj, hnew, dense, elev, denseref, locelev, & - locdense, locconc, drhodc, crhoref, ctemp, & + + subroutine buy_cf_ghb(packobj, hnew, dense, elev, denseref, locelev, & + locdense, locconc, drhodc, crhoref, ctemp, & iform) ! ****************************************************************************** ! buy_cf_ghb -- Fill ghb coefficients @@ -559,7 +558,7 @@ subroutine buy_cf_ghb(packobj, hnew, dense, elev, denseref, locelev, & ! ! -- density denseghb = get_bnd_density(n, locdense, locconc, denseref, & - drhodc, crhoref, ctemp, packobj%auxvar) + drhodc, crhoref, ctemp, packobj%auxvar) ! ! -- elevation elevghb = elev(node) @@ -570,9 +569,9 @@ subroutine buy_cf_ghb(packobj, hnew, dense, elev, denseref, locelev, & cond = packobj%bound(2, n) ! ! -- calculate HCOF and RHS terms - call calc_ghb_hcof_rhs_terms(denseref, denseghb, dense(node), & - elevghb, elev(node), hghb, hnew(node), & - cond, iform, rhsterm, hcofterm) + call calc_ghb_hcof_rhs_terms(denseref, denseghb, dense(node), & + elevghb, elev(node), hghb, hnew(node), & + cond, iform, rhsterm, hcofterm) packobj%hcof(n) = packobj%hcof(n) + hcofterm packobj%rhs(n) = packobj%rhs(n) - rhsterm ! @@ -581,12 +580,12 @@ subroutine buy_cf_ghb(packobj, hnew, dense, elev, denseref, locelev, & ! -- Return return end subroutine buy_cf_ghb - + subroutine calc_ghb_hcof_rhs_terms(denseref, denseghb, densenode, & elevghb, elevnode, hghb, hnode, & cond, iform, rhsterm, hcofterm) ! ****************************************************************************** -! calc_ghb_hcof_rhs_terms -- Calculate density hcof and rhs terms for ghb +! calc_ghb_hcof_rhs_terms -- Calculate density hcof and rhs terms for ghb ! conditions ! ****************************************************************************** ! @@ -636,9 +635,9 @@ subroutine calc_ghb_hcof_rhs_terms(denseref, denseghb, densenode, & ! -- return return end subroutine calc_ghb_hcof_rhs_terms - - subroutine buy_cf_riv(packobj, hnew, dense, elev, denseref, locelev, & - locdense, locconc, drhodc, crhoref, ctemp, & + + subroutine buy_cf_riv(packobj, hnew, dense, elev, denseref, locelev, & + locdense, locconc, drhodc, crhoref, ctemp, & iform) ! ****************************************************************************** ! buy_cf_riv -- Fill riv coefficients @@ -680,7 +679,7 @@ subroutine buy_cf_riv(packobj, hnew, dense, elev, denseref, locelev, & ! ! -- density denseriv = get_bnd_density(n, locdense, locconc, denseref, & - drhodc, crhoref, ctemp, packobj%auxvar) + drhodc, crhoref, ctemp, packobj%auxvar) ! ! -- elevation elevriv = elev(node) @@ -695,9 +694,9 @@ subroutine buy_cf_riv(packobj, hnew, dense, elev, denseref, locelev, & if (hnew(node) > rbot) then ! ! --calculate HCOF and RHS terms, similar to GHB in this case - call calc_ghb_hcof_rhs_terms(denseref, denseriv, dense(node), & - elevriv, elev(node), hriv, hnew(node), & - cond, iform, rhsterm, hcofterm) + call calc_ghb_hcof_rhs_terms(denseref, denseriv, dense(node), & + elevriv, elev(node), hriv, hnew(node), & + cond, iform, rhsterm, hcofterm) else hcofterm = DZERO rhsterm = cond * (denseriv / denseref - DONE) * (hriv - rbot) @@ -711,7 +710,7 @@ subroutine buy_cf_riv(packobj, hnew, dense, elev, denseref, locelev, & ! -- Return return end subroutine buy_cf_riv - + subroutine buy_cf_drn(packobj, hnew, dense, denseref) ! ****************************************************************************** ! buy_cf_drn -- Fill drn coefficients @@ -744,7 +743,7 @@ subroutine buy_cf_drn(packobj, hnew, dense, denseref) hbnd = packobj%bound(1, n) cond = packobj%bound(2, n) if (hnew(node) > hbnd) then - hcofterm = - cond * (rho / denseref - DONE) + hcofterm = -cond * (rho / denseref - DONE) rhsterm = hcofterm * hbnd packobj%hcof(n) = packobj%hcof(n) + hcofterm packobj%rhs(n) = packobj%rhs(n) + rhsterm @@ -754,8 +753,8 @@ subroutine buy_cf_drn(packobj, hnew, dense, denseref) ! -- Return return end subroutine buy_cf_drn - - subroutine buy_cf_lak(packobj, hnew, dense, elev, denseref, locdense, & + + subroutine buy_cf_lak(packobj, hnew, dense, elev, denseref, locdense, & locconc, drhodc, crhoref, ctemp, iform) ! ****************************************************************************** ! buy_cf_lak -- Pass density information into lak package; density terms are @@ -788,7 +787,7 @@ subroutine buy_cf_lak(packobj, hnew, dense, elev, denseref, locdense, & ! ! -- Insert the lake and gwf relative densities into col 1 and 2 and the ! gwf elevation into col 3 of the lake package denseterms array - select type(packobj) + select type (packobj) type is (LakType) do n = 1, packobj%nbound ! @@ -815,8 +814,8 @@ subroutine buy_cf_lak(packobj, hnew, dense, elev, denseref, locdense, & ! -- Return return end subroutine buy_cf_lak - - subroutine buy_cf_sfr(packobj, hnew, dense, elev, denseref, locdense, & + + subroutine buy_cf_sfr(packobj, hnew, dense, elev, denseref, locdense, & locconc, drhodc, crhoref, ctemp, iform) ! ****************************************************************************** ! buy_cf_sfr -- Pass density information into sfr package; density terms are @@ -849,7 +848,7 @@ subroutine buy_cf_sfr(packobj, hnew, dense, elev, denseref, locdense, & ! ! -- Insert the sfr and gwf relative densities into col 1 and 2 and the ! gwf elevation into col 3 of the sfr package denseterms array - select type(packobj) + select type (packobj) type is (SfrType) do n = 1, packobj%nbound ! @@ -876,8 +875,8 @@ subroutine buy_cf_sfr(packobj, hnew, dense, elev, denseref, locdense, & ! -- Return return end subroutine buy_cf_sfr - - subroutine buy_cf_maw(packobj, hnew, dense, elev, denseref, locdense, & + + subroutine buy_cf_maw(packobj, hnew, dense, elev, denseref, locdense, & locconc, drhodc, crhoref, ctemp, iform) ! ****************************************************************************** ! buy_cf_maw -- Pass density information into maw package; density terms are @@ -910,7 +909,7 @@ subroutine buy_cf_maw(packobj, hnew, dense, elev, denseref, locdense, & ! ! -- Insert the maw and gwf relative densities into col 1 and 2 and the ! gwf elevation into col 3 of the maw package denseterms array - select type(packobj) + select type (packobj) type is (MawType) do n = 1, packobj%nbound ! @@ -937,7 +936,7 @@ subroutine buy_cf_maw(packobj, hnew, dense, elev, denseref, locdense, & ! -- Return return end subroutine buy_cf_maw - + subroutine buy_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! ****************************************************************************** ! buy_fc -- Fill coefficients @@ -948,7 +947,7 @@ subroutine buy_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! -- dummy class(GwfBuyType) :: this integer(I4B) :: kiter - integer,intent(in) :: njasln + integer, intent(in) :: njasln real(DP), dimension(njasln), intent(inout) :: amat integer(I4B), intent(in), dimension(:) :: idxglo real(DP), dimension(:), intent(inout) :: rhs @@ -963,24 +962,24 @@ subroutine buy_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! ! -- fill buoyancy flow term do n = 1, this%dis%nodes - if(this%ibound(n) == 0) cycle + if (this%ibound(n) == 0) cycle idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) - if(this%ibound(m) == 0) cycle - if(this%iform == 0) then + if (this%ibound(m) == 0) cycle + if (this%iform == 0) then call this%calcbuy(n, m, ipos, hnew(n), hnew(m), rhsterm) else - call this%calchhterms(n, m, ipos, hnew(n), hnew(m), rhsterm, & + call this%calchhterms(n, m, ipos, hnew(n), hnew(m), rhsterm, & amatnn, amatnm) - endif + end if ! ! -- Add terms to rhs, diagonal, and off diagonal rhs(n) = rhs(n) - rhsterm amat(idxglo(idiag)) = amat(idxglo(idiag)) - amatnn amat(idxglo(ipos)) = amat(idxglo(ipos)) + amatnm - enddo - enddo + end do + end do ! ! -- Return return @@ -997,7 +996,7 @@ subroutine buy_ot_dv(this, idvfl) class(GwfBuyType) :: this integer(I4B), intent(in) :: idvfl ! -- local - character(len=1) :: cdatafmp=' ', editdesc=' ' + character(len=1) :: cdatafmp = ' ', editdesc = ' ' integer(I4B) :: ibinun integer(I4B) :: iprint integer(I4B) :: nvaluesp @@ -1006,12 +1005,12 @@ subroutine buy_ot_dv(this, idvfl) ! ------------------------------------------------------------------------------ ! ! -- Set unit number for density output - if(this%ioutdense /= 0) then + if (this%ioutdense /= 0) then ibinun = 1 else ibinun = 0 - endif - if(idvfl == 0) ibinun = 0 + end if + if (idvfl == 0) ibinun = 0 ! ! -- save density array if (ibinun /= 0) then @@ -1021,12 +1020,12 @@ subroutine buy_ot_dv(this, idvfl) ! -- write density to binary file if (this%ioutdense /= 0) then ibinun = this%ioutdense - call this%dis%record_array(this%dense, this%iout, iprint, ibinun, & - ' DENSITY', cdatafmp, nvaluesp, & + call this%dis%record_array(this%dense, this%iout, iprint, ibinun, & + ' DENSITY', cdatafmp, nvaluesp, & nwidthp, editdesc, dinact) end if end if - + ! ! -- Return return @@ -1041,37 +1040,37 @@ subroutine buy_cq(this, hnew, flowja) ! ------------------------------------------------------------------------------ implicit none class(GwfBuyType) :: this - real(DP),intent(in),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja + real(DP), intent(in), dimension(:) :: hnew + real(DP), intent(inout), dimension(:) :: flowja integer(I4B) :: n, m, ipos real(DP) :: deltaQ real(DP) :: rhsterm, amatnn, amatnm ! ------------------------------------------------------------------------------ ! ! -- Calculate the flow across each cell face and store in flowja - do n=1,this%dis%nodes + do n = 1, this%dis%nodes do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) - if(m < n) cycle - if(this%iform == 0) then + if (m < n) cycle + if (this%iform == 0) then ! -- equivalent freshwater head formulation call this%calcbuy(n, m, ipos, hnew(n), hnew(m), deltaQ) else ! -- hydraulic head formulation - call this%calchhterms(n, m, ipos, hnew(n), hnew(m), rhsterm, & + call this%calchhterms(n, m, ipos, hnew(n), hnew(m), rhsterm, & amatnn, amatnm) deltaQ = amatnm * hnew(m) - amatnn * hnew(n) + rhsterm - endif + end if flowja(ipos) = flowja(ipos) + deltaQ - flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - & - deltaQ - enddo - enddo + flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - & + deltaQ + end do + end do ! ! -- Return return end subroutine buy_cq - + subroutine buy_da(this) ! ****************************************************************************** ! buy_da -- Deallocate @@ -1085,17 +1084,17 @@ subroutine buy_da(this) ! ------------------------------------------------------------------------------ ! ! -- Deallocate arrays if package was active - if(this%inunit > 0) then + if (this%inunit > 0) then call mem_deallocate(this%elev) call mem_deallocate(this%dense) call mem_deallocate(this%concbuy) call mem_deallocate(this%drhodc) call mem_deallocate(this%crhoref) call mem_deallocate(this%ctemp) - deallocate(this%cmodelname) - deallocate(this%cauxspeciesname) - deallocate(this%modelconc) - endif + deallocate (this%cmodelname) + deallocate (this%cauxspeciesname) + deallocate (this%modelconc) + end if ! ! -- Scalars call mem_deallocate(this%ioutdense) @@ -1104,7 +1103,7 @@ subroutine buy_da(this) call mem_deallocate(this%ireadconcbuy) call mem_deallocate(this%iconcset) call mem_deallocate(this%denseref) - + call mem_deallocate(this%nrhospecies) ! ! -- deallocate parent @@ -1123,9 +1122,9 @@ subroutine read_dimensions(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwfBuyType),intent(inout) :: this + class(GwfBuyType), intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg, keyword + character(len=LINELENGTH) :: errmsg, keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- format @@ -1137,23 +1136,23 @@ subroutine read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING BUY DIMENSIONS' + write (this%iout, '(/1x,a)') 'PROCESSING BUY DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NRHOSPECIES') - this%nrhospecies = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'NRHOSPECIES = ', this%nrhospecies - case default - write(errmsg,'(4x,a,a)') & - 'UNKNOWN BUY DIMENSION: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('NRHOSPECIES') + this%nrhospecies = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NRHOSPECIES = ', this%nrhospecies + case default + write (errmsg, '(4x,a,a)') & + 'UNKNOWN BUY DIMENSION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF BUY DIMENSIONS' + write (this%iout, '(1x,a)') 'END OF BUY DIMENSIONS' else call store_error('REQUIRED BUY DIMENSIONS BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() @@ -1163,7 +1162,7 @@ subroutine read_dimensions(this) if (this%nrhospecies < 1) then call store_error('NRHOSPECIES MUST BE GREATER THAN ZERO.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -1190,35 +1189,35 @@ subroutine read_packagedata(this) character(len=10) :: c10 character(len=16) :: c16 ! -- format - character(len=*),parameter :: fmterr = & + character(len=*), parameter :: fmterr = & "('INVALID VALUE FOR IRHOSPEC (',i0,') DETECTED IN BUY PACKAGE. & &IRHOSPEC MUST BE > 0 AND <= NRHOSPECIES, AND DUPLICATE VALUES & &ARE NOT ALLOWED.')" ! ------------------------------------------------------------------------------ ! ! -- initialize - allocate(itemp(this%nrhospecies)) + allocate (itemp(this%nrhospecies)) itemp(:) = 0 ! ! -- get packagedata block blockrequired = .true. - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - blockRequired=blockRequired, & + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + blockRequired=blockRequired, & supportOpenClose=.true.) ! ! -- parse packagedata block if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING BUY PACKAGEDATA' + write (this%iout, '(1x,a)') 'PROCESSING BUY PACKAGEDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit irhospec = this%parser%GetInteger() if (irhospec < 1 .or. irhospec > this%nrhospecies) then - write(errmsg, fmterr) irhospec + write (errmsg, fmterr) irhospec call store_error(errmsg) end if if (itemp(irhospec) /= 0) then - write(errmsg, fmterr) irhospec + write (errmsg, fmterr) irhospec call store_error(errmsg) end if itemp(irhospec) = 1 @@ -1227,7 +1226,7 @@ subroutine read_packagedata(this) call this%parser%GetStringCaps(this%cmodelname(irhospec)) call this%parser%GetStringCaps(this%cauxspeciesname(irhospec)) end do - write(this%iout,'(1x,a)') 'END OF BUY PACKAGEDATA' + write (this%iout, '(1x,a)') 'END OF BUY PACKAGEDATA' end if ! ! -- Check for errors. @@ -1236,26 +1235,26 @@ subroutine read_packagedata(this) end if ! ! -- write packagedata information - write(this%iout, '(/,a)') 'SUMMARY OF SPECIES INFORMATION IN BUY PACKAGE' - write(this%iout, '(1a11, 4a17)') & - 'SPECIES', 'DRHODC', 'CRHOREF', 'MODEL', & - 'AUXSPECIESNAME' + write (this%iout, '(/,a)') 'SUMMARY OF SPECIES INFORMATION IN BUY PACKAGE' + write (this%iout, '(1a11, 4a17)') & + 'SPECIES', 'DRHODC', 'CRHOREF', 'MODEL', & + 'AUXSPECIESNAME' do irhospec = 1, this%nrhospecies - write(c10, '(i0)') irhospec - line = ' ' // adjustr(c10) - write(c16, '(g15.6)') this%drhodc(irhospec) - line = trim(line) // ' ' // adjustr(c16) - write(c16, '(g15.6)') this%crhoref(irhospec) - line = trim(line) // ' ' // adjustr(c16) - write(c16, '(a)') this%cmodelname(irhospec) - line = trim(line) // ' ' // adjustr(c16) - write(c16, '(a)') this%cauxspeciesname(irhospec) - line = trim(line) // ' ' // adjustr(c16) - write(this%iout, '(a)') trim(line) + write (c10, '(i0)') irhospec + line = ' '//adjustr(c10) + write (c16, '(g15.6)') this%drhodc(irhospec) + line = trim(line)//' '//adjustr(c16) + write (c16, '(g15.6)') this%crhoref(irhospec) + line = trim(line)//' '//adjustr(c16) + write (c16, '(a)') this%cmodelname(irhospec) + line = trim(line)//' '//adjustr(c16) + write (c16, '(a)') this%cauxspeciesname(irhospec) + line = trim(line)//' '//adjustr(c16) + write (this%iout, '(a)') trim(line) end do ! ! -- deallocate - deallocate(itemp) + deallocate (itemp) ! ! -- return return @@ -1264,7 +1263,7 @@ end subroutine read_packagedata !> @brief Sets package data instead of reading from file !< subroutine set_packagedata(this, input_data) - class(GwfBuyType) :: this !< this buyoancy pkg + class(GwfBuyType) :: this !< this buyoancy pkg type(GwfBuyInputDataType), intent(in) :: input_data !< the input data to be set ! local integer(I4B) :: ispec @@ -1276,9 +1275,8 @@ subroutine set_packagedata(this, input_data) this%cauxspeciesname(ispec) = input_data%cauxspeciesname(ispec) end do - end subroutine set_packagedata - + subroutine calcbuy(this, n, m, icon, hn, hm, buy) ! ****************************************************************************** ! calcbuy -- Calculate buyancy term for this connection @@ -1299,7 +1297,7 @@ subroutine calcbuy(this, n, m, icon, hn, hm, buy) ! -- local integer(I4B) :: ihc real(DP) :: densen, densem, cl1, cl2, avgdense, wt, elevn, elevm, & - cond, tp, bt + cond, tp, bt real(DP) :: hyn real(DP) :: hym ! ------------------------------------------------------------------------------ @@ -1314,11 +1312,11 @@ subroutine calcbuy(this, n, m, icon, hn, hm, buy) cl1 = this%dis%con%cl2(this%dis%con%jas(icon)) cl2 = this%dis%con%cl1(this%dis%con%jas(icon)) end if - wt = cl1 / (cl1 + cl2) + wt = cl1 / (cl1 + cl2) avgdense = wt * densen + (DONE - wt) * densem ! ! -- Elevations - if(this%ireadelev == 0) then + if (this%ireadelev == 0) then tp = this%dis%top(n) bt = this%dis%bot(n) elevn = bt + DHALF * this%npf%sat(n) * (tp - bt) @@ -1328,40 +1326,40 @@ subroutine calcbuy(this, n, m, icon, hn, hm, buy) else elevn = this%elev(n) elevm = this%elev(m) - endif + end if ! ihc = this%dis%con%ihc(this%dis%con%jas(icon)) hyn = this%npf%hy_eff(n, m, ihc, ipos=icon) hym = this%npf%hy_eff(m, n, ihc, ipos=icon) ! ! -- Conductance - if(this%dis%con%ihc(this%dis%con%jas(icon)) == 0) then - cond = vcond(this%ibound(n), this%ibound(m), & - this%npf%icelltype(n), this%npf%icelltype(m), & - this%npf%inewton, & - this%npf%ivarcv, this%npf%idewatcv, & - this%npf%condsat(this%dis%con%jas(icon)), hn, hm, & - hyn, hym, & - this%npf%sat(n), this%npf%sat(m), & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(icon))) + if (this%dis%con%ihc(this%dis%con%jas(icon)) == 0) then + cond = vcond(this%ibound(n), this%ibound(m), & + this%npf%icelltype(n), this%npf%icelltype(m), & + this%npf%inewton, & + this%npf%ivarcv, this%npf%idewatcv, & + this%npf%condsat(this%dis%con%jas(icon)), hn, hm, & + hyn, hym, & + this%npf%sat(n), this%npf%sat(m), & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(icon))) else - cond = hcond(this%ibound(n), this%ibound(m), & - this%npf%icelltype(n), this%npf%icelltype(m), & - this%npf%inewton, this%npf%inewton, & - this%dis%con%ihc(this%dis%con%jas(icon)), & - this%npf%icellavg, this%npf%iusgnrhc, this%npf%inwtupw, & - this%npf%condsat(this%dis%con%jas(icon)), & - hn, hm, this%npf%sat(n), this%npf%sat(m), & - hyn, hym, & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(icon)), & - this%dis%con%cl2(this%dis%con%jas(icon)), & - this%dis%con%hwva(this%dis%con%jas(icon)), & - this%npf%satomega, this%npf%satmin) - endif + cond = hcond(this%ibound(n), this%ibound(m), & + this%npf%icelltype(n), this%npf%icelltype(m), & + this%npf%inewton, this%npf%inewton, & + this%dis%con%ihc(this%dis%con%jas(icon)), & + this%npf%icellavg, this%npf%iusgnrhc, this%npf%inwtupw, & + this%npf%condsat(this%dis%con%jas(icon)), & + hn, hm, this%npf%sat(n), this%npf%sat(m), & + hyn, hym, & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(icon)), & + this%dis%con%cl2(this%dis%con%jas(icon)), & + this%dis%con%hwva(this%dis%con%jas(icon)), & + this%npf%satomega, this%npf%satmin) + end if ! ! -- Calculate buoyancy term buy = cond * (avgdense - this%denseref) / this%denseref * (elevm - elevn) @@ -1370,7 +1368,6 @@ subroutine calcbuy(this, n, m, icon, hn, hm, buy) return end subroutine calcbuy - subroutine calchhterms(this, n, m, icon, hn, hm, rhsterm, amatnn, amatnm) ! ****************************************************************************** ! calchhterms -- Calculate hydraulic head term for this connection @@ -1411,7 +1408,7 @@ subroutine calchhterms(this, n, m, icon, hn, hm, rhsterm, amatnn, amatnm) cl1 = this%dis%con%cl2(this%dis%con%jas(icon)) cl2 = this%dis%con%cl1(this%dis%con%jas(icon)) end if - wt = cl1 / (cl1 + cl2) + wt = cl1 / (cl1 + cl2) avgdense = wt * densen + (1.0 - wt) * densem ! ! -- Elevations @@ -1424,33 +1421,33 @@ subroutine calchhterms(this, n, m, icon, hn, hm, rhsterm, amatnn, amatnm) hym = this%npf%hy_eff(m, n, ihc, ipos=icon) ! ! -- Conductance - if(ihc == 0) then - cond = vcond(this%ibound(n), this%ibound(m), & - this%npf%icelltype(n), this%npf%icelltype(m), & - this%npf%inewton, & - this%npf%ivarcv, this%npf%idewatcv, & - this%npf%condsat(this%dis%con%jas(icon)), hn, hm, & - hyn, hym, & - this%npf%sat(n), this%npf%sat(m), & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(icon))) + if (ihc == 0) then + cond = vcond(this%ibound(n), this%ibound(m), & + this%npf%icelltype(n), this%npf%icelltype(m), & + this%npf%inewton, & + this%npf%ivarcv, this%npf%idewatcv, & + this%npf%condsat(this%dis%con%jas(icon)), hn, hm, & + hyn, hym, & + this%npf%sat(n), this%npf%sat(m), & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(icon))) else - cond = hcond(this%ibound(n), this%ibound(m), & - this%npf%icelltype(n), this%npf%icelltype(m), & - this%npf%inewton, this%npf%inewton, & - this%dis%con%ihc(this%dis%con%jas(icon)), & - this%npf%icellavg, this%npf%iusgnrhc, this%npf%inwtupw, & - this%npf%condsat(this%dis%con%jas(icon)), & - hn, hm, this%npf%sat(n), this%npf%sat(m), & - hyn, hym, & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(icon)), & - this%dis%con%cl2(this%dis%con%jas(icon)), & - this%dis%con%hwva(this%dis%con%jas(icon)), & - this%npf%satomega, this%npf%satmin) - endif + cond = hcond(this%ibound(n), this%ibound(m), & + this%npf%icelltype(n), this%npf%icelltype(m), & + this%npf%inewton, this%npf%inewton, & + this%dis%con%ihc(this%dis%con%jas(icon)), & + this%npf%icellavg, this%npf%iusgnrhc, this%npf%inwtupw, & + this%npf%condsat(this%dis%con%jas(icon)), & + hn, hm, this%npf%sat(n), this%npf%sat(m), & + hyn, hym, & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(icon)), & + this%dis%con%cl2(this%dis%con%jas(icon)), & + this%dis%con%hwva(this%dis%con%jas(icon)), & + this%npf%satomega, this%npf%satmin) + end if ! ! -- Calculate terms rhonormn = densen / this%denseref @@ -1467,7 +1464,7 @@ subroutine calchhterms(this, n, m, icon, hn, hm, rhsterm, amatnn, amatnm) ! -- lhs, results in asymmetric matrix due to weight term amatnn = amatnn - cond * (DONE - wt) * (rhonormm - rhonormn) amatnm = amatnm + cond * wt * (rhonormm - rhonormn) - endif + end if ! ! -- Return return @@ -1482,7 +1479,7 @@ subroutine buy_calcdens(this) ! ------------------------------------------------------------------------------ ! -- dummy class(GwfBuyType) :: this - + ! -- local integer(I4B) :: n integer(I4B) :: i @@ -1491,7 +1488,7 @@ subroutine buy_calcdens(this) ! -- Calculate the density using the specified concentration array do n = 1, this%dis%nodes do i = 1, this%nrhospecies - if(this%modelconc(i)%icbund(n) == 0) then + if (this%modelconc(i)%icbund(n) == 0) then this%ctemp = DZERO else this%ctemp(i) = this%modelconc(i)%conc(n) @@ -1499,12 +1496,12 @@ subroutine buy_calcdens(this) end do this%dense(n) = calcdens(this%denseref, this%drhodc, this%crhoref, & this%ctemp) - enddo + end do ! ! -- Return return end subroutine buy_calcdens - + subroutine buy_calcelev(this) ! ****************************************************************************** ! buy_calcelev -- Calculate cell elevations to use in density flow equations @@ -1530,7 +1527,7 @@ subroutine buy_calcelev(this) ! -- Return return end subroutine buy_calcelev - + subroutine allocate_scalars(this) ! ****************************************************************************** ! allocate_scalars @@ -1557,7 +1554,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%denseref, 'DENSEREF', this%memoryPath) call mem_allocate(this%nrhospecies, 'NRHOSPECIES', this%memoryPath) - + ! ! -- Initialize this%ioutdense = 0 @@ -1565,9 +1562,9 @@ subroutine allocate_scalars(this) this%iconcset = 0 this%ireadconcbuy = 0 this%denseref = 1000.d0 - + this%nrhospecies = 0 - + ! ! -- Initialize default to LHS implementation of hydraulic head formulation this%iform = 2 @@ -1599,15 +1596,15 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%drhodc, this%nrhospecies, 'DRHODC', this%memoryPath) call mem_allocate(this%crhoref, this%nrhospecies, 'CRHOREF', this%memoryPath) call mem_allocate(this%ctemp, this%nrhospecies, 'CTEMP', this%memoryPath) - allocate(this%cmodelname(this%nrhospecies)) - allocate(this%cauxspeciesname(this%nrhospecies)) - allocate(this%modelconc(this%nrhospecies)) + allocate (this%cmodelname(this%nrhospecies)) + allocate (this%cauxspeciesname(this%nrhospecies)) + allocate (this%modelconc(this%nrhospecies)) ! ! -- Initialize do i = 1, nodes this%dense(i) = this%denseref this%elev(i) = DZERO - enddo + end do ! ! -- Initialize nrhospecies arrays do i = 1, this%nrhospecies @@ -1640,8 +1637,9 @@ subroutine read_options(this) integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*),parameter :: fmtfileout = & - "(4x, 'BUY ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtfileout = & + "(4x, 'BUY ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & + &a, /4x, 'OPENED ON UNIT: ', I7)" ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -1650,50 +1648,50 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING BUY OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING BUY OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('HHFORMULATION_RHS') - this%iform = 1 - this%iasym = 0 - write(this%iout,'(4x,a)') & - 'HYDDRAULIC HEAD FORMULATION SET TO RIGHT-HAND SIDE' - case ('DENSEREF') - this%denseref = this%parser%GetDouble() - write(this%iout, '(4x,a,1pg15.6)') & - 'REFERENCE DENSITY HAS BEEN SET TO: ', & - this%denseref - case ('DEV_EFH_FORMULATION') - call this%parser%DevOpt() - this%iform = 0 - this%iasym = 0 - write(this%iout,'(4x,a)') & - 'FORMULATION SET TO EQUIVALENT FRESHWATER HEAD' - case ('DENSITY') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ioutdense = getunit() - call openfile(this%ioutdense, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtfileout) & - 'DENSITY', fname, this%ioutdense - else - errmsg = 'OPTIONAL DENSITY KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT' - call store_error(errmsg) - end if - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN BUY OPTION: ', & - trim(keyword) + case ('HHFORMULATION_RHS') + this%iform = 1 + this%iasym = 0 + write (this%iout, '(4x,a)') & + 'HYDDRAULIC HEAD FORMULATION SET TO RIGHT-HAND SIDE' + case ('DENSEREF') + this%denseref = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg15.6)') & + 'REFERENCE DENSITY HAS BEEN SET TO: ', & + this%denseref + case ('DEV_EFH_FORMULATION') + call this%parser%DevOpt() + this%iform = 0 + this%iasym = 0 + write (this%iout, '(4x,a)') & + 'FORMULATION SET TO EQUIVALENT FRESHWATER HEAD' + case ('DENSITY') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutdense = getunit() + call openfile(this%ioutdense, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write (this%iout, fmtfileout) & + 'DENSITY', fname, this%ioutdense + else + errmsg = 'OPTIONAL DENSITY KEYWORD MUST BE '// & + 'FOLLOWED BY FILEOUT' call store_error(errmsg) - call this%parser%StoreErrorUnit() + end if + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN BUY OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF BUY OPTIONS' + write (this%iout, '(1x,a)') 'END OF BUY OPTIONS' end if ! ! -- Return @@ -1710,7 +1708,7 @@ subroutine set_options(this, input_data) this%denseref = input_data%denseref ! derived option: - ! if not iform==2, there is no asymmetry + ! if not iform==2, there is no asymmetry if (this%iform == 0 .or. this%iform == 1) then this%iasym = 0 end if @@ -1720,7 +1718,7 @@ end subroutine set_options subroutine set_concentration_pointer(this, modelname, conc, icbund) ! ****************************************************************************** ! set_concentration_pointer -- pass in a gwt model name, concentration array -! and ibound, and store a pointer to these in the BUY package so that +! and ibound, and store a pointer to these in the BUY package so that ! density can be calculated from them. ! This routine is called from the gwfgwt exchange in the exg_ar() method. ! ****************************************************************************** @@ -1752,5 +1750,5 @@ subroutine set_concentration_pointer(this, modelname, conc, icbund) ! -- Return return end subroutine set_concentration_pointer - -end module GwfBuyModule \ No newline at end of file + +end module GwfBuyModule diff --git a/src/Model/GroundWaterFlow/gwf3chd8.f90 b/src/Model/GroundWaterFlow/gwf3chd8.f90 index 63287e0bd4d..e65e95789d9 100644 --- a/src/Model/GroundWaterFlow/gwf3chd8.f90 +++ b/src/Model/GroundWaterFlow/gwf3chd8.f90 @@ -1,12 +1,12 @@ module ChdModule ! - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & - LINELENGTH, LENPACKAGENAME - use MemoryHelperModule, only: create_mem_path - use ObsModule, only: DefaultObsIdProcessor - use BndModule, only: BndType - use ObserveModule, only: ObserveType + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & + LINELENGTH, LENPACKAGENAME + use MemoryHelperModule, only: create_mem_path + use ObsModule, only: DefaultObsIdProcessor + use BndModule, only: BndType + use ObserveModule, only: ObserveType use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList ! @@ -15,27 +15,27 @@ module ChdModule private public :: chd_create, ChdType ! - character(len=LENFTYPE) :: ftype = 'CHD' - character(len=LENPACKAGENAME) :: text = ' CHD' + character(len=LENFTYPE) :: ftype = 'CHD' + character(len=LENPACKAGENAME) :: text = ' CHD' ! type, extends(BndType) :: ChdType - real(DP), dimension(:), pointer, contiguous :: ratechdin => null() !simulated flows into constant head (excluding other chds) - real(DP), dimension(:), pointer, contiguous :: ratechdout => null() !simulated flows out of constant head (excluding to other chds) - contains - procedure :: bnd_rp => chd_rp - procedure :: bnd_ad => chd_ad - procedure :: bnd_ck => chd_ck - procedure :: bnd_fc => chd_fc - procedure :: bnd_cq => chd_cq - procedure :: bnd_bd => chd_bd - procedure :: bnd_da => chd_da - procedure :: allocate_arrays => chd_allocate_arrays - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => chd_obs_supported - procedure, public :: bnd_df_obs => chd_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => chd_rp_ts + real(DP), dimension(:), pointer, contiguous :: ratechdin => null() !simulated flows into constant head (excluding other chds) + real(DP), dimension(:), pointer, contiguous :: ratechdout => null() !simulated flows out of constant head (excluding to other chds) + contains + procedure :: bnd_rp => chd_rp + procedure :: bnd_ad => chd_ad + procedure :: bnd_ck => chd_ck + procedure :: bnd_fc => chd_fc + procedure :: bnd_cq => chd_cq + procedure :: bnd_bd => chd_bd + procedure :: bnd_da => chd_da + procedure :: allocate_arrays => chd_allocate_arrays + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => chd_obs_supported + procedure, public :: bnd_df_obs => chd_df_obs + ! -- method for time series + procedure, public :: bnd_rp_ts => chd_rp_ts end type ChdType contains @@ -51,10 +51,10 @@ subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -62,7 +62,7 @@ subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(chdobj) + allocate (chdobj) packobj => chdobj ! ! -- create name and memory path @@ -82,7 +82,7 @@ subroutine chd_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%ibcnum = ibcnum packobj%ncolbnd = 1 packobj%iscloc = 1 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return return @@ -110,7 +110,8 @@ subroutine chd_allocate_arrays(this, nodelist, auxvar) ! ! -- allocate ratechdex call mem_allocate(this%ratechdin, this%maxbound, 'RATECHDIN', this%memoryPath) - call mem_allocate(this%ratechdout, this%maxbound, 'RATECHDOUT', this%memoryPath) + call mem_allocate(this%ratechdout, this%maxbound, 'RATECHDOUT', & + this%memoryPath) do i = 1, this%maxbound this%ratechdin(i) = DZERO this%ratechdout(i) = DZERO @@ -119,7 +120,7 @@ subroutine chd_allocate_arrays(this, nodelist, auxvar) ! -- return return end subroutine chd_allocate_arrays - + subroutine chd_rp(this) ! ****************************************************************************** ! chd_rp -- Read and prepare @@ -137,34 +138,34 @@ subroutine chd_rp(this) ! ------------------------------------------------------------------------------ ! ! -- Reset previous CHDs to active cell - do i=1,this%nbound - node = this%nodelist(i) - this%ibound(node) = this%ibcnum - enddo + do i = 1, this%nbound + node = this%nodelist(i) + this%ibound(node) = this%ibcnum + end do ! ! -- Call the parent class read and prepare call this%BndType%bnd_rp() ! ! -- Set ibound to -(ibcnum + 1) for constant head cells ierr = 0 - do i=1,this%nbound + do i = 1, this%nbound node = this%nodelist(i) ibd = this%ibound(node) - if(ibd < 0) then + if (ibd < 0) then call this%dis%noder_to_string(node, nodestr) - write(errmsg, '(3a)') & + write (errmsg, '(3a)') & 'Cell is already a constant head (', trim(adjustl(nodestr)), ').' call store_error(errmsg) ierr = ierr + 1 else this%ibound(node) = -this%ibcnum - endif - enddo + end if + end do ! ! -- Stop if errors detected - if(ierr > 0) then + if (ierr > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -195,7 +196,7 @@ subroutine chd_ad(this) hb = this%bound(1, i) this%xnew(node) = hb this%xold(node) = this%xnew(node) - enddo + end do ! ! -- For each observation, push simulated value and corresponding ! simulation time from "current" to "preceding" and reset @@ -217,7 +218,7 @@ subroutine chd_ck(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors ! -- dummy - class(ChdType),intent(inout) :: this + class(ChdType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: errmsg character(len=30) :: nodestr @@ -226,20 +227,20 @@ subroutine chd_ck(this) real(DP) :: bt ! -- formats character(len=*), parameter :: fmtchderr = & - "('CHD BOUNDARY ',i0,' HEAD (',g0,') IS LESS THAN CELL " // & - "BOTTOM (',g0,')',' FOR CELL ',a)" + "('CHD BOUNDARY ',i0,' HEAD (',g0,') IS LESS THAN CELL & + &BOTTOM (',g0,')',' FOR CELL ',a)" ! ------------------------------------------------------------------------------ ! ! -- check stress period data - do i=1,this%nbound - node=this%nodelist(i) - bt = this%dis%bot(node) - ! -- accumulate errors - if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then - call this%dis%noder_to_string(node, nodestr) - write(errmsg, fmt=fmtchderr) i, this%bound(1,i), bt, trim(nodestr) - call store_error(errmsg) - end if + do i = 1, this%nbound + node = this%nodelist(i) + bt = this%dis%bot(node) + ! -- accumulate errors + if (this%bound(1, i) < bt .and. this%icelltype(node) /= 0) then + call this%dis%noder_to_string(node, nodestr) + write (errmsg, fmt=fmtchderr) i, this%bound(1, i), bt, trim(nodestr) + call store_error(errmsg) + end if end do ! !write summary of chd package error messages @@ -296,7 +297,7 @@ subroutine chd_cq(this, x, flowja, iadv) ! ------------------------------------------------------------------------------ ! ! -- If no boundaries, skip flow calculations. - if(this%nbound > 0) then + if (this%nbound > 0) then ! ! -- Loop through each boundary calculating flow. do i = 1, this%nbound @@ -308,7 +309,7 @@ subroutine chd_cq(this, x, flowja, iadv) ! ! -- Calculate the flow rate into the cell. do ipos = this%dis%con%ia(node) + 1, & - this%dis%con%ia(node + 1) - 1 + this%dis%con%ia(node + 1) - 1 q = flowja(ipos) rate = rate - q ! -- only accumulate chin and chout for active @@ -323,7 +324,7 @@ subroutine chd_cq(this, x, flowja, iadv) end if end do ! - ! -- For chd, store total flow in rhs so it is available for other + ! -- For chd, store total flow in rhs so it is available for other ! calculations this%rhs(i) = -rate this%hcof(i) = DZERO @@ -355,7 +356,7 @@ subroutine chd_bd(this, model_budget) isuppress_output = 0 call rate_accumulator(this%ratechdin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratechdout(1:this%nbound), ratout, dum) - call model_budget%addentry(ratin, ratout, delt, this%text, & + call model_budget%addentry(ratin, ratout, delt, this%text, & isuppress_output, this%packName) end subroutine chd_bd @@ -395,21 +396,21 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'HEAD' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'HEAD' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -417,7 +418,7 @@ end subroutine define_listlabel ! -- Procedures related to observations -logical function chd_obs_supported(this) + logical function chd_obs_supported(this) ! ****************************************************************************** ! chd_obs_supported ! -- Return true because CHD package supports observations. @@ -426,14 +427,14 @@ logical function chd_obs_supported(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - implicit none - class(ChdType) :: this + implicit none + class(ChdType) :: this ! ------------------------------------------------------------------------------ - chd_obs_supported = .true. - return -end function chd_obs_supported + chd_obs_supported = .true. + return + end function chd_obs_supported -subroutine chd_df_obs(this) + subroutine chd_df_obs(this) ! ****************************************************************************** ! chd_df_obs (implements bnd_df_obs) ! -- Store observation type supported by CHD package. @@ -442,16 +443,16 @@ subroutine chd_df_obs(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(ChdType) :: this - ! -- local - integer(I4B) :: indx + implicit none + ! -- dummy + class(ChdType) :: this + ! -- local + integer(I4B) :: indx ! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('chd', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - return -end subroutine chd_df_obs + call this%obs%StoreObsType('chd', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + return + end subroutine chd_df_obs ! -- Procedure related to time series @@ -467,15 +468,15 @@ subroutine chd_rp_ts(this) type(TimeSeriesLinkType), pointer :: tslink => null() ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then select case (tslink%JCol) case (1) tslink%Text = 'HEAD' end select - endif - enddo + end if + end do ! return end subroutine chd_rp_ts diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index 7590ba92aa2..fb6e373471b 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -1,7 +1,7 @@ !> @brief This module contains the CSUB package methods !! -!! This module contains the methods used to add the effects of elastic -!! skeletal storage, compaction, and subsidence on the groundwater flow +!! This module contains the methods used to add the effects of elastic +!! skeletal storage, compaction, and subsidence on the groundwater flow !! equation. The contribution of elastic skelatal, inelastic and elastic !! interbed storage and water compressibility can be represented. !! @@ -41,6 +41,8 @@ module GwfCsubModule use ListModule, only: ListType use TableModule, only: TableType, table_cr ! + use IMSLinearMisc, only: ims_misc_thomas + ! implicit none ! private @@ -49,174 +51,179 @@ module GwfCsubModule ! character(len=LENBUDTXT), dimension(4) :: budtxt = & !< text labels for budget terms [' CSUB-CGELASTIC', & - ' CSUB-ELASTIC', ' CSUB-INELASTIC', & + ' CSUB-ELASTIC', & + ' CSUB-INELASTIC', & ' CSUB-WATERCOMP'] character(len=LENBUDTXT), dimension(6) :: comptxt = & !< text labels for compaction terms - ['CSUB-COMPACTION', ' CSUB-INELASTIC', ' CSUB-ELASTIC', & - ' CSUB-INTERBED', ' CSUB-COARSE', ' CSUB-ZDISPLACE'] + ['CSUB-COMPACTION', & + ' CSUB-INELASTIC', & + ' CSUB-ELASTIC', & + ' CSUB-INTERBED', & + ' CSUB-COARSE', & + ' CSUB-ZDISPLACE'] ! ! -- local parameter - real(DP), parameter :: dlog10es = 0.4342942_DP !< derivative of the log of effective stress + real(DP), parameter :: dlog10es = 0.4342942_DP !< derivative of the log of effective stress ! ! CSUB type type, extends(NumericalPackageType) :: GwfCsubType ! -- characters scalars - character(len=LENLISTLABEL), pointer :: listlabel => null() !< title of table written for RP - character(len=LENMEMPATH), pointer :: stoMemPath => null() !< memory path of storage package + character(len=LENLISTLABEL), pointer :: listlabel => null() !< title of table written for RP + character(len=LENMEMPATH), pointer :: stoMemPath => null() !< memory path of storage package ! -- character arrays character(len=LENBOUNDNAME), dimension(:), & - pointer, contiguous :: boundname => null() !< vector of boundnames + pointer, contiguous :: boundname => null() !< vector of boundnames character(len=LENAUXNAME), dimension(:), & - pointer, contiguous :: auxname => null() !< vector of auxname + pointer, contiguous :: auxname => null() !< vector of auxname ! -- logical scalars - logical, pointer :: lhead_based => null() !< logical variable indicating if head-based solution + logical, pointer :: lhead_based => null() !< logical variable indicating if head-based solution ! -- integer scalars - integer(I4B), pointer :: istounit => null() !< unit number of storage package - integer(I4B), pointer :: istrainib => null() !< unit number of interbed strain output - integer(I4B), pointer :: istrainsk => null() !< unit number of coarse-grained strain output - integer(I4B), pointer :: ioutcomp => null() !< unit number for cell-by-cell compaction output - integer(I4B), pointer :: ioutcompi => null() !< unit number for cell-by-cell inelastic compaction output - integer(I4B), pointer :: ioutcompe => null() !< unit number for cell-by-cell elastic compaction output - integer(I4B), pointer :: ioutcompib => null() !< unit number for cell-by-cell interbed compaction output - integer(I4B), pointer :: ioutcomps => null() !< unit number for cell-by-cell coarse-grained compaction output - integer(I4B), pointer :: ioutzdisp => null() !< unit number for z-displacement output - integer(I4B), pointer :: ipakcsv => null() !< unit number for csv output - integer(I4B), pointer :: iupdatematprop => null() !< flag indicating if material properties will be updated - integer(I4B), pointer :: istoragec => null() !< flag indicating specific storage coefficient will be specified - integer(I4B), pointer :: icellf => null() !< flag indicating cell fractions will be specified - integer(I4B), pointer :: ispecified_pcs => null() !< flag indicating preconsolidation state is specified (not relative) - integer(I4B), pointer :: ispecified_dbh => null() !< flag indicating delay bed head is specified (not relative) - integer(I4B), pointer :: inamedbound => null() !< flag to read boundnames - integer(I4B), pointer :: iconvchk => null() !< flag indicating if a final convergence check will be made - integer(I4B), pointer :: naux => null() !< number of auxiliary variables - integer(I4B), pointer :: ninterbeds => null() !< number of interbeds - integer(I4B), pointer :: maxsig0 => null() !< maximum number of cells with specified sig0 values - integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period - integer(I4B), pointer :: iscloc => null() !< bound column to scale with SFAC - integer(I4B), pointer :: iauxmultcol => null() !< column to use as multiplier for column iscloc - integer(I4B), pointer :: ndelaycells => null() !< number of cells in delay interbeds - integer(I4B), pointer :: ndelaybeds => null() !< number of delay interbeds - integer(I4B), pointer :: initialized => null() !< flag indicating if the initial stresses have been initialized - integer(I4B), pointer :: ieslag => null() !< flag indicating if the effective stress is lagged - integer(I4B), pointer :: ipch => null() !< flag indicating if initial precosolidation value is a head - integer(I4B), pointer :: iupdatestress => null() !< flag indicating if the geostatic stress is active + integer(I4B), pointer :: istounit => null() !< unit number of storage package + integer(I4B), pointer :: istrainib => null() !< unit number of interbed strain output + integer(I4B), pointer :: istrainsk => null() !< unit number of coarse-grained strain output + integer(I4B), pointer :: ioutcomp => null() !< unit number for cell-by-cell compaction output + integer(I4B), pointer :: ioutcompi => null() !< unit number for cell-by-cell inelastic compaction output + integer(I4B), pointer :: ioutcompe => null() !< unit number for cell-by-cell elastic compaction output + integer(I4B), pointer :: ioutcompib => null() !< unit number for cell-by-cell interbed compaction output + integer(I4B), pointer :: ioutcomps => null() !< unit number for cell-by-cell coarse-grained compaction output + integer(I4B), pointer :: ioutzdisp => null() !< unit number for z-displacement output + integer(I4B), pointer :: ipakcsv => null() !< unit number for csv output + integer(I4B), pointer :: iupdatematprop => null() !< flag indicating if material properties will be updated + integer(I4B), pointer :: istoragec => null() !< flag indicating specific storage coefficient will be specified + integer(I4B), pointer :: icellf => null() !< flag indicating cell fractions will be specified + integer(I4B), pointer :: ispecified_pcs => null() !< flag indicating preconsolidation state is specified (not relative) + integer(I4B), pointer :: ispecified_dbh => null() !< flag indicating delay bed head is specified (not relative) + integer(I4B), pointer :: inamedbound => null() !< flag to read boundnames + integer(I4B), pointer :: iconvchk => null() !< flag indicating if a final convergence check will be made + integer(I4B), pointer :: naux => null() !< number of auxiliary variables + integer(I4B), pointer :: ninterbeds => null() !< number of interbeds + integer(I4B), pointer :: maxsig0 => null() !< maximum number of cells with specified sig0 values + integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period + integer(I4B), pointer :: iscloc => null() !< bound column to scale with SFAC + integer(I4B), pointer :: iauxmultcol => null() !< column to use as multiplier for column iscloc + integer(I4B), pointer :: ndelaycells => null() !< number of cells in delay interbeds + integer(I4B), pointer :: ndelaybeds => null() !< number of delay interbeds + integer(I4B), pointer :: initialized => null() !< flag indicating if the initial stresses have been initialized + integer(I4B), pointer :: ieslag => null() !< flag indicating if the effective stress is lagged + integer(I4B), pointer :: ipch => null() !< flag indicating if initial precosolidation value is a head + integer(I4B), pointer :: iupdatestress => null() !< flag indicating if the geostatic stress is active ! -- real scalars - real(DP), pointer :: epsilon => null() !< epsilon for stress smoothing - real(DP), pointer :: cc_crit => null() !< convergence criteria for csub-gwf convergence check - real(DP), pointer :: gammaw => null() !< product of fluid density, and gravity - real(DP), pointer :: beta => null() !< water compressibility - real(DP), pointer :: brg => null() !< product of gammaw and water compressibility - real(DP), pointer :: satomega => null() !< newton-raphson saturation omega + real(DP), pointer :: epsilon => null() !< epsilon for stress smoothing + real(DP), pointer :: cc_crit => null() !< convergence criteria for csub-gwf convergence check + real(DP), pointer :: gammaw => null() !< product of fluid density, and gravity + real(DP), pointer :: beta => null() !< water compressibility + real(DP), pointer :: brg => null() !< product of gammaw and water compressibility + real(DP), pointer :: satomega => null() !< newton-raphson saturation omega ! -- integer pointer to storage package variables - integer(I4B), pointer :: gwfiss => NULL() !< pointer to model iss flag - integer(I4B), pointer :: gwfiss0 => NULL() !< iss flag for last stress period + integer(I4B), pointer :: gwfiss => NULL() !< pointer to model iss flag + integer(I4B), pointer :: gwfiss0 => NULL() !< iss flag for last stress period ! -- integer arrays - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - integer(I4B), dimension(:), pointer, contiguous :: stoiconv => null() !< pointer to iconvert in storage + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + integer(I4B), dimension(:), pointer, contiguous :: stoiconv => null() !< pointer to iconvert in storage ! -- real arrays - real(DP), dimension(:), pointer, contiguous :: stoss => null() !< pointer to ss in storage - real(DP), dimension(:), pointer, contiguous :: buff => null() !< buff array - real(DP), dimension(:), pointer, contiguous :: buffusr => null() !< buffusr array - integer, dimension(:), pointer, contiguous :: nodelist => null() !< reduced node that the interbed is attached to - integer, dimension(:), pointer, contiguous :: unodelist => null() !< user node that the interbed is attached to + real(DP), dimension(:), pointer, contiguous :: stoss => null() !< pointer to ss in storage + real(DP), dimension(:), pointer, contiguous :: buff => null() !< buff array + real(DP), dimension(:), pointer, contiguous :: buffusr => null() !< buffusr array + integer, dimension(:), pointer, contiguous :: nodelist => null() !< reduced node that the interbed is attached to + integer, dimension(:), pointer, contiguous :: unodelist => null() !< user node that the interbed is attached to ! ! -- coarse-grained storage variables - real(DP), dimension(:), pointer, contiguous :: sgm => null() !< specific gravity moist sediments - real(DP), dimension(:), pointer, contiguous :: sgs => null() !< specific gravity saturated sediments - real(DP), dimension(:), pointer, contiguous :: cg_ske_cr => null() !< coarse-grained specified storage - real(DP), dimension(:), pointer, contiguous :: cg_gs => null() !< geostatic stress for a cell - real(DP), dimension(:), pointer, contiguous :: cg_es => null() !< coarse-grained (aquifer) effective stress - real(DP), dimension(:), pointer, contiguous :: cg_es0 => null() !< coarse-grained (aquifer) effective stress for the previous time step - real(DP), dimension(:), pointer, contiguous :: cg_pcs => null() !< coarse-grained (aquifer) preconsolidation stress - real(DP), dimension(:), pointer, contiguous :: cg_comp => null() !< coarse-grained (aquifer) incremental compaction - real(DP), dimension(:), pointer, contiguous :: cg_tcomp => null() !< coarse-grained (aquifer) total compaction - real(DP), dimension(:), pointer, contiguous :: cg_stor => null() !< coarse-grained (aquifer) storage - real(DP), dimension(:), pointer, contiguous :: cg_ske => null() !< coarse-grained (aquifer) elastic storage coefficient - real(DP), dimension(:), pointer, contiguous :: cg_sk => null() !< coarse-grained (aquifer) first storage coefficient - real(DP), dimension(:), pointer, contiguous :: cg_thickini => null() !< initial coarse-grained (aquifer) thickness - real(DP), dimension(:), pointer, contiguous :: cg_thetaini => null() !< initial coarse-grained (aquifer) porosity - real(DP), dimension(:), pointer, contiguous :: cg_thick => null() !< current coarse-grained (aquifer) thickness - real(DP), dimension(:), pointer, contiguous :: cg_thick0 => null() !< previous coarse-grained (aquifer) thickness - real(DP), dimension(:), pointer, contiguous :: cg_theta => null() !< current coarse-grained (aquifer) porosity - real(DP), dimension(:), pointer, contiguous :: cg_theta0 => null() !< previous coarse-grained (aquifer) porosity + real(DP), dimension(:), pointer, contiguous :: sgm => null() !< specific gravity moist sediments + real(DP), dimension(:), pointer, contiguous :: sgs => null() !< specific gravity saturated sediments + real(DP), dimension(:), pointer, contiguous :: cg_ske_cr => null() !< coarse-grained specified storage + real(DP), dimension(:), pointer, contiguous :: cg_gs => null() !< geostatic stress for a cell + real(DP), dimension(:), pointer, contiguous :: cg_es => null() !< coarse-grained (aquifer) effective stress + real(DP), dimension(:), pointer, contiguous :: cg_es0 => null() !< coarse-grained (aquifer) effective stress for the previous time step + real(DP), dimension(:), pointer, contiguous :: cg_pcs => null() !< coarse-grained (aquifer) preconsolidation stress + real(DP), dimension(:), pointer, contiguous :: cg_comp => null() !< coarse-grained (aquifer) incremental compaction + real(DP), dimension(:), pointer, contiguous :: cg_tcomp => null() !< coarse-grained (aquifer) total compaction + real(DP), dimension(:), pointer, contiguous :: cg_stor => null() !< coarse-grained (aquifer) storage + real(DP), dimension(:), pointer, contiguous :: cg_ske => null() !< coarse-grained (aquifer) elastic storage coefficient + real(DP), dimension(:), pointer, contiguous :: cg_sk => null() !< coarse-grained (aquifer) first storage coefficient + real(DP), dimension(:), pointer, contiguous :: cg_thickini => null() !< initial coarse-grained (aquifer) thickness + real(DP), dimension(:), pointer, contiguous :: cg_thetaini => null() !< initial coarse-grained (aquifer) porosity + real(DP), dimension(:), pointer, contiguous :: cg_thick => null() !< current coarse-grained (aquifer) thickness + real(DP), dimension(:), pointer, contiguous :: cg_thick0 => null() !< previous coarse-grained (aquifer) thickness + real(DP), dimension(:), pointer, contiguous :: cg_theta => null() !< current coarse-grained (aquifer) porosity + real(DP), dimension(:), pointer, contiguous :: cg_theta0 => null() !< previous coarse-grained (aquifer) porosity ! ! -- cell storage variables - real(DP), dimension(:), pointer, contiguous :: cell_wcstor => null() !< cell water compressibility storage - real(DP), dimension(:), pointer, contiguous :: cell_thick => null() !< cell compressible material thickness + real(DP), dimension(:), pointer, contiguous :: cell_wcstor => null() !< cell water compressibility storage + real(DP), dimension(:), pointer, contiguous :: cell_thick => null() !< cell compressible material thickness ! ! -- interbed variables - integer(I4B), dimension(:), pointer, contiguous :: idelay => null() !< delay interbed flag - 0 = nodelay, > 0 = delay - integer(I4B), dimension(:), pointer, contiguous :: ielastic => null() !< elastic interbed equation - 0 = inelastic and elastic, > 0 = elastic - integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !< convertible cell flag - 0 = elastic, > 0 = inelastic - real(DP), dimension(:), pointer, contiguous :: ci => null() !< compression index - real(DP), dimension(:), pointer, contiguous :: rci => null() !< recompression index - real(DP), dimension(:), pointer, contiguous :: pcs => null() !< preconsolidation stress - real(DP), dimension(:), pointer, contiguous :: rnb => null() !< interbed system material factor - real(DP), dimension(:), pointer, contiguous :: kv => null() !< vertical hydraulic conductivity of interbed - real(DP), dimension(:), pointer, contiguous :: h0 => null() !< initial head in interbed - real(DP), dimension(:), pointer, contiguous :: comp => null() !< interbed incremental compaction - real(DP), dimension(:), pointer, contiguous :: tcomp => null() !< total interbed compaction - real(DP), dimension(:), pointer, contiguous :: tcompi => null() !< total inelastic interbed compaction - real(DP), dimension(:), pointer, contiguous :: tcompe => null() !< total elastic interbed compaction - real(DP), dimension(:), pointer, contiguous :: storagee => null() !< elastic storage - real(DP), dimension(:), pointer, contiguous :: storagei => null() !< inelastic storage - real(DP), dimension(:), pointer, contiguous :: ske => null() !< elastic storage coefficient - real(DP), dimension(:), pointer, contiguous :: sk => null() !< first storage coefficient - real(DP), dimension(:), pointer, contiguous :: thickini => null() !< initial interbed thickness - real(DP), dimension(:), pointer, contiguous :: thetaini => null() !< initial interbed theta - real(DP), dimension(:), pointer, contiguous :: thick => null() !< current interbed thickness - real(DP), dimension(:), pointer, contiguous :: thick0 => null() !< previous interbed thickness - real(DP), dimension(:), pointer, contiguous :: theta => null() !< current interbed porosity - real(DP), dimension(:), pointer, contiguous :: theta0 => null() !< previous interbed porosity - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< auxiliary variable array + integer(I4B), dimension(:), pointer, contiguous :: idelay => null() !< delay interbed flag - 0 = nodelay, > 0 = delay + integer(I4B), dimension(:), pointer, contiguous :: ielastic => null() !< elastic interbed equation - 0 = inelastic and elastic, > 0 = elastic + integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !< convertible cell flag - 0 = elastic, > 0 = inelastic + real(DP), dimension(:), pointer, contiguous :: ci => null() !< compression index + real(DP), dimension(:), pointer, contiguous :: rci => null() !< recompression index + real(DP), dimension(:), pointer, contiguous :: pcs => null() !< preconsolidation stress + real(DP), dimension(:), pointer, contiguous :: rnb => null() !< interbed system material factor + real(DP), dimension(:), pointer, contiguous :: kv => null() !< vertical hydraulic conductivity of interbed + real(DP), dimension(:), pointer, contiguous :: h0 => null() !< initial head in interbed + real(DP), dimension(:), pointer, contiguous :: comp => null() !< interbed incremental compaction + real(DP), dimension(:), pointer, contiguous :: tcomp => null() !< total interbed compaction + real(DP), dimension(:), pointer, contiguous :: tcompi => null() !< total inelastic interbed compaction + real(DP), dimension(:), pointer, contiguous :: tcompe => null() !< total elastic interbed compaction + real(DP), dimension(:), pointer, contiguous :: storagee => null() !< elastic storage + real(DP), dimension(:), pointer, contiguous :: storagei => null() !< inelastic storage + real(DP), dimension(:), pointer, contiguous :: ske => null() !< elastic storage coefficient + real(DP), dimension(:), pointer, contiguous :: sk => null() !< first storage coefficient + real(DP), dimension(:), pointer, contiguous :: thickini => null() !< initial interbed thickness + real(DP), dimension(:), pointer, contiguous :: thetaini => null() !< initial interbed theta + real(DP), dimension(:), pointer, contiguous :: thick => null() !< current interbed thickness + real(DP), dimension(:), pointer, contiguous :: thick0 => null() !< previous interbed thickness + real(DP), dimension(:), pointer, contiguous :: theta => null() !< current interbed porosity + real(DP), dimension(:), pointer, contiguous :: theta0 => null() !< previous interbed porosity + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< auxiliary variable array ! ! -- delay interbed integer(I4B), dimension(:), pointer, contiguous :: idb_nconv_count => null() !< non-convertible count of interbeds with heads below delay cell top - integer(I4B), dimension(:, :), pointer, contiguous :: idbconvert => null() !0 = elastic, > 0 = inelastic - real(DP), dimension(:), pointer, contiguous :: dbdhmax => null() !< delay bed maximum head change - real(DP), dimension(:, :), pointer, contiguous :: dbz => null() !< delay bed cell z - real(DP), dimension(:, :), pointer, contiguous :: dbrelz => null() !< delay bed cell z relative to znode - real(DP), dimension(:, :), pointer, contiguous :: dbh => null() !< delay bed cell h - real(DP), dimension(:, :), pointer, contiguous :: dbh0 => null() !< delay bed cell previous h - real(DP), dimension(:, :), pointer, contiguous :: dbgeo => null() !< delay bed cell geostatic stress - real(DP), dimension(:, :), pointer, contiguous :: dbes => null() !< delay bed cell effective stress - real(DP), dimension(:, :), pointer, contiguous :: dbes0 => null() !< delay bed cell previous effective stress - real(DP), dimension(:, :), pointer, contiguous :: dbpcs => null() !< delay bed cell preconsolidation stress - real(DP), dimension(:), pointer, contiguous :: dbflowtop => null() !< delay bed flow through interbed top - real(DP), dimension(:), pointer, contiguous :: dbflowbot => null() !< delay bed flow through interbed bottom - real(DP), dimension(:, :), pointer, contiguous :: dbdzini => null() !< initial delay bed cell thickness - real(DP), dimension(:, :), pointer, contiguous :: dbthetaini => null() !< initial delay bed cell porosity - real(DP), dimension(:, :), pointer, contiguous :: dbdz => null() !< delay bed dz - real(DP), dimension(:, :), pointer, contiguous :: dbdz0 => null() !< delay bed previous dz - real(DP), dimension(:, :), pointer, contiguous :: dbtheta => null() !< delay bed cell porosity - real(DP), dimension(:, :), pointer, contiguous :: dbtheta0 => null() !< delay bed cell previous porosity - real(DP), dimension(:, :), pointer, contiguous :: dbcomp => null() !< delay bed incremental compaction - real(DP), dimension(:, :), pointer, contiguous :: dbtcomp => null() !< delay bed total interbed compaction + integer(I4B), dimension(:, :), pointer, contiguous :: idbconvert => null() !0 = elastic, > 0 = inelastic + real(DP), dimension(:), pointer, contiguous :: dbdhmax => null() !< delay bed maximum head change + real(DP), dimension(:, :), pointer, contiguous :: dbz => null() !< delay bed cell z + real(DP), dimension(:, :), pointer, contiguous :: dbrelz => null() !< delay bed cell z relative to znode + real(DP), dimension(:, :), pointer, contiguous :: dbh => null() !< delay bed cell h + real(DP), dimension(:, :), pointer, contiguous :: dbh0 => null() !< delay bed cell previous h + real(DP), dimension(:, :), pointer, contiguous :: dbgeo => null() !< delay bed cell geostatic stress + real(DP), dimension(:, :), pointer, contiguous :: dbes => null() !< delay bed cell effective stress + real(DP), dimension(:, :), pointer, contiguous :: dbes0 => null() !< delay bed cell previous effective stress + real(DP), dimension(:, :), pointer, contiguous :: dbpcs => null() !< delay bed cell preconsolidation stress + real(DP), dimension(:), pointer, contiguous :: dbflowtop => null() !< delay bed flow through interbed top + real(DP), dimension(:), pointer, contiguous :: dbflowbot => null() !< delay bed flow through interbed bottom + real(DP), dimension(:, :), pointer, contiguous :: dbdzini => null() !< initial delay bed cell thickness + real(DP), dimension(:, :), pointer, contiguous :: dbthetaini => null() !< initial delay bed cell porosity + real(DP), dimension(:, :), pointer, contiguous :: dbdz => null() !< delay bed dz + real(DP), dimension(:, :), pointer, contiguous :: dbdz0 => null() !< delay bed previous dz + real(DP), dimension(:, :), pointer, contiguous :: dbtheta => null() !< delay bed cell porosity + real(DP), dimension(:, :), pointer, contiguous :: dbtheta0 => null() !< delay bed cell previous porosity + real(DP), dimension(:, :), pointer, contiguous :: dbcomp => null() !< delay bed incremental compaction + real(DP), dimension(:, :), pointer, contiguous :: dbtcomp => null() !< delay bed total interbed compaction ! ! -- delay interbed solution arrays - real(DP), dimension(:), pointer, contiguous :: dbal => null() !< delay bed lower diagonal - real(DP), dimension(:), pointer, contiguous :: dbad => null() !< delay bed diagonal - real(DP), dimension(:), pointer, contiguous :: dbau => null() !< delay bed upper diagonal - real(DP), dimension(:), pointer, contiguous :: dbrhs => null() !< delay bed right hand side - real(DP), dimension(:), pointer, contiguous :: dbdh => null() !< delay bed dh - real(DP), dimension(:), pointer, contiguous :: dbaw => null() !< delay bed work vector + real(DP), dimension(:), pointer, contiguous :: dbal => null() !< delay bed lower diagonal + real(DP), dimension(:), pointer, contiguous :: dbad => null() !< delay bed diagonal + real(DP), dimension(:), pointer, contiguous :: dbau => null() !< delay bed upper diagonal + real(DP), dimension(:), pointer, contiguous :: dbrhs => null() !< delay bed right hand side + real(DP), dimension(:), pointer, contiguous :: dbdh => null() !< delay bed dh + real(DP), dimension(:), pointer, contiguous :: dbaw => null() !< delay bed work vector ! ! -- period data - integer(I4B), dimension(:), pointer, contiguous :: nodelistsig0 => null() !< vector of reduced node numbers - real(DP), dimension(:), pointer, contiguous :: sig0 => null() !< array of package specific boundary numbers + integer(I4B), dimension(:), pointer, contiguous :: nodelistsig0 => null() !< vector of reduced node numbers + real(DP), dimension(:), pointer, contiguous :: sig0 => null() !< array of package specific boundary numbers ! ! -- timeseries - type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager + type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager ! ! -- observation data - integer(I4B), pointer :: inobspkg => null() !< unit number for obs package - type(ObsType), pointer :: obs => null() !< observation package + integer(I4B), pointer :: inobspkg => null() !< unit number for obs package + type(ObsType), pointer :: obs => null() !< observation package ! ! -- table objects - type(TableType), pointer :: inputtab => null() !< table for input variables - type(TableType), pointer :: outputtab => null() !< table for output variables - type(TableType), pointer :: pakcsvtab => null() !< table for csv output + type(TableType), pointer :: inputtab => null() !< table for input variables + type(TableType), pointer :: outputtab => null() !< table for output variables + type(TableType), pointer :: pakcsvtab => null() !< table for csv output contains procedure :: define_listlabel @@ -310,12 +317,12 @@ module GwfCsubModule !< subroutine csub_cr(csubobj, name_model, istounit, stoPckName, inunit, iout) ! -- dummy variables - type(GwfCsubType), pointer :: csubobj !< pointer to default package type - character(len=*), intent(in) :: name_model !< model name - integer(I4B), intent(in) :: inunit !< unit number of csub input file - integer(I4B), intent(in) :: istounit !< unit number of storage package - character(len=*), intent(in) :: stoPckName !< name of the storage package - integer(I4B), intent(in) :: iout !< unit number of lst output file + type(GwfCsubType), pointer :: csubobj !< pointer to default package type + character(len=*), intent(in) :: name_model !< model name + integer(I4B), intent(in) :: inunit !< unit number of csub input file + integer(I4B), intent(in) :: istounit !< unit number of storage package + character(len=*), intent(in) :: stoPckName !< name of the storage package + integer(I4B), intent(in) :: iout !< unit number of lst output file ! -- local variables ! ! -- allocate the object and assign values to object variables @@ -354,8 +361,8 @@ subroutine csub_ar(this, dis, ibound) use KindModule, only: I4B ! -- dummy variables class(GwfCsubType), intent(inout) :: this - class(DisBaseType), pointer, intent(in) :: dis !< model discretization - integer(I4B), dimension(:), pointer, contiguous :: ibound !< model ibound array + class(DisBaseType), pointer, intent(in) :: dis !< model discretization + integer(I4B), dimension(:), pointer, contiguous :: ibound !< model ibound array ! -- local variables logical :: isfound, endOfBlock character(len=:), allocatable :: line @@ -381,7 +388,7 @@ subroutine csub_ar(this, dis, ibound) real(DP) :: v ! -- format character(len=*), parameter :: fmtcsub = & - "(1x,/1x,'CSUB -- COMPACTION PACKAGE, VERSION 1, 12/15/2019', & + "(1x,/1x,'CSUB -- COMPACTION PACKAGE, VERSION 1, 12/15/2019', & &' INPUT READ FROM UNIT ', i0, //)" ! ! --print a message identifying the csub package. @@ -520,7 +527,8 @@ subroutine csub_ar(this, dis, ibound) if (istoerr /= 0) then write (errmsg, '(a,3(1x,a))') & 'Specific storage values in the storage (STO) package must', & - 'be zero in all active cells when using the', trim(adjustl(this%packName)), & + 'be zero in all active cells when using the', & + trim(adjustl(this%packName)), & 'package.' call store_error(errmsg) end if @@ -545,7 +553,7 @@ subroutine csub_ar(this, dis, ibound) if (idelay == 0) then v = this%thickini(ib) else - v = this%rnb(ib)*this%thickini(ib) + v = this%rnb(ib) * this%thickini(ib) end if this%cg_thickini(node) = this%cg_thickini(node) - v end do @@ -589,7 +597,7 @@ end subroutine csub_ar subroutine read_options(this) ! -- modules use ConstantsModule, only: MAXCHARLEN, DZERO, MNORMAL - use MemoryManagerModule, only: mem_allocate + use MemoryManagerModule, only: mem_reallocate use OpenSpecModule, only: access, form use InputOutputModule, only: getunit, urdaux, openfile ! -- dummy variables @@ -612,23 +620,24 @@ subroutine read_options(this) integer(I4B) :: isetgamma ! -- formats character(len=*), parameter :: fmtts = & - "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + &"(4x,'TIME-SERIES DATA WILL BE READ FROM FILE: ',a)" character(len=*), parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + &"(4x,'FLOWS WILL BE SAVED TO FILE: ',a,/4x,'OPENED ON UNIT: ',I7)" character(len=*), parameter :: fmtflow2 = & - "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" + &"(4x,'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" character(len=*), parameter :: fmtssessv = & - "(4x, 'USING SSE AND SSV INSTEAD OF CR AND CC.')" + &"(4x,'USING SSE AND SSV INSTEAD OF CR AND CC.')" character(len=*), parameter :: fmtoffset = & - "(4x, 'INITIAL_STRESS TREATED AS AN OFFSET.')" + &"(4x,'INITIAL_STRESS TREATED AS AN OFFSET.')" character(len=*), parameter :: fmtopt = & - "(4x, A)" + &"(4x,A)" character(len=*), parameter :: fmtopti = & - "(4x, A, 1X, I0)" + &"(4x,A,1X,I0)" character(len=*), parameter :: fmtoptr = & - "(4x, A, 1X, G0)" + &"(4x,A,1X,G0)" character(len=*), parameter :: fmtfileout = & - "(4x, 'CSUB ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + "(4x,'CSUB ',1x,a,1x,' WILL BE SAVED TO FILE: ',a,/4x,& + &'OPENED ON UNIT: ',I7)" ! ! -- initialize variables ibrg = 0 @@ -654,8 +663,8 @@ subroutine read_options(this) lloc = 1 call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & istart, istop, caux, line, this%packName) - call mem_allocate(this%auxname, LENAUXNAME, this%naux, & - 'AUXNAME', this%memoryPath) + call mem_reallocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', this%memoryPath) do n = 1, this%naux this%auxname(n) = caux(n) end do @@ -665,8 +674,8 @@ subroutine read_options(this) write (this%iout, fmtflow2) case ('PRINT_INPUT') this%iprpak = 1 - write (this%iout, '(4x,a)') 'LISTS OF '//trim(adjustl(this%packName))// & - ' CELLS WILL BE PRINTED.' + write (this%iout, '(4x,a)') & + 'LISTS OF '//trim(adjustl(this%packName))//' CELLS WILL BE PRINTED.' case ('PRINT_FLOWS') this%iprflow = 1 write (this%iout, '(4x,a)') trim(adjustl(this%packName))// & @@ -674,7 +683,7 @@ subroutine read_options(this) case ('BOUNDNAMES') this%inamedbound = 1 write (this%iout, '(4x,a)') trim(adjustl(this%packName))// & - ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' ! user specified boundnames + ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' ! user specified boundnames case ('TS6') call this%parser%GetStringCaps(keyword) if (trim(adjustl(keyword)) /= 'FILEIN') then @@ -883,7 +892,8 @@ subroutine read_options(this) this%ipakcsv = getunit() call openfile(this%ipakcsv, this%iout, fname, 'CSV', & filstat_opt='REPLACE', mode_opt=MNORMAL) - write (this%iout, fmtfileout) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv + write (this%iout, fmtfileout) & + 'PACKAGE_CONVERGENCE', fname, this%ipakcsv else call store_error('Optional PACKAGE_CONVERGENCE keyword must be '// & 'followed by FILEOUT.') @@ -995,9 +1005,9 @@ subroutine read_options(this) if (ieslag /= 0) then ieslag = 0 write (this%iout, '(4x,a,2(/,6x,a))') & - 'EFFECTIVE_STRESS_LAG HAS BEEN SPECIFIED BUT HAS NO EFFECT WHEN USING', & - 'THE HEAD-BASED FORMULATION (HEAD_BASED HAS BEEN SPECIFIED IN THE', & - 'OPTIONS BLOCK)' + 'EFFECTIVE_STRESS_LAG HAS BEEN SPECIFIED BUT HAS NO EFFECT WHEN', & + 'USING THE HEAD-BASED FORMULATION (HEAD_BASED HAS BEEN SPECIFIED', & + 'IN THE OPTIONS BLOCK)' end if end if this%ieslag = ieslag @@ -1005,7 +1015,7 @@ subroutine read_options(this) ! -- recalculate BRG if necessary and output ! water compressibility values if (ibrg /= 0) then - this%brg = this%gammaw*this%beta + this%brg = this%gammaw * this%beta end if write (this%iout, fmtoptr) 'GAMMAW =', this%gammaw write (this%iout, fmtoptr) 'BETA =', this%beta @@ -1152,7 +1162,10 @@ subroutine csub_allocate_scalars(this) call mem_allocate(this%gwfiss0, 'GWFISS0', this%memoryPath) ! ! -- allocate TS object - allocate(this%TsManager) + allocate (this%TsManager) + ! + ! -- allocate text strings + call mem_allocate(this%auxname, LENAUXNAME, 0, 'AUXNAME', this%memoryPath) ! ! -- initialize values this%istounit = 0 @@ -1187,14 +1200,14 @@ subroutine csub_allocate_scalars(this) this%iupdatematprop = 0 this%epsilon = DZERO this%cc_crit = DEM7 - this%gammaw = DGRAVITY*1000._DP + this%gammaw = DGRAVITY * 1000._DP this%beta = 4.6512e-10_DP - this%brg = this%gammaw*this%beta + this%brg = this%gammaw * this%beta ! ! -- set omega value used for saturation calculations if (this%inewton /= 0) then this%satomega = DEM6 - this%epsilon = DHALF*DEM6 + this%epsilon = DHALF * DEM6 else this%satomega = DZERO end if @@ -1241,15 +1254,22 @@ subroutine csub_allocate_arrays(this) call mem_allocate(this%sgs, this%dis%nodes, 'SGS', trim(this%memoryPath)) call mem_allocate(this%cg_ske_cr, this%dis%nodes, 'CG_SKE_CR', & trim(this%memoryPath)) - call mem_allocate(this%cg_es, this%dis%nodes, 'CG_ES', trim(this%memoryPath)) - call mem_allocate(this%cg_es0, this%dis%nodes, 'CG_ES0', trim(this%memoryPath)) - call mem_allocate(this%cg_pcs, this%dis%nodes, 'CG_PCS', trim(this%memoryPath)) - call mem_allocate(this%cg_comp, this%dis%nodes, 'CG_COMP', trim(this%memoryPath)) + call mem_allocate(this%cg_es, this%dis%nodes, 'CG_ES', & + trim(this%memoryPath)) + call mem_allocate(this%cg_es0, this%dis%nodes, 'CG_ES0', & + trim(this%memoryPath)) + call mem_allocate(this%cg_pcs, this%dis%nodes, 'CG_PCS', & + trim(this%memoryPath)) + call mem_allocate(this%cg_comp, this%dis%nodes, 'CG_COMP', & + trim(this%memoryPath)) call mem_allocate(this%cg_tcomp, this%dis%nodes, 'CG_TCOMP', & trim(this%memoryPath)) - call mem_allocate(this%cg_stor, this%dis%nodes, 'CG_STOR', trim(this%memoryPath)) - call mem_allocate(this%cg_ske, this%dis%nodes, 'CG_SKE', trim(this%memoryPath)) - call mem_allocate(this%cg_sk, this%dis%nodes, 'CG_SK', trim(this%memoryPath)) + call mem_allocate(this%cg_stor, this%dis%nodes, 'CG_STOR', & + trim(this%memoryPath)) + call mem_allocate(this%cg_ske, this%dis%nodes, 'CG_SKE', & + trim(this%memoryPath)) + call mem_allocate(this%cg_sk, this%dis%nodes, 'CG_SK', & + trim(this%memoryPath)) call mem_allocate(this%cg_thickini, this%dis%nodes, 'CG_THICKINI', & trim(this%memoryPath)) call mem_allocate(this%cg_thetaini, this%dis%nodes, 'CG_THETAINI', & @@ -1332,6 +1352,10 @@ subroutine csub_allocate_arrays(this) if (this%inamedbound /= 0) then call mem_allocate(this%boundname, LENBOUNDNAME, this%ninterbeds, & 'BOUNDNAME', trim(this%memoryPath)) + else + call mem_allocate(this%boundname, LENBOUNDNAME, 1, & + 'BOUNDNAME', trim(this%memoryPath)) + end if ! ! -- allocate the nodelist and bound arrays @@ -1509,7 +1533,7 @@ subroutine csub_read_packagedata(this) 'for packagedata entry', itmp, '.' call store_error(errmsg) end if - rval = rval*baq + rval = rval * baq end if this%thickini(itmp) = rval if (this%iupdatematprop /= 0) then @@ -1780,7 +1804,7 @@ subroutine csub_read_packagedata(this) ! ! -- initialize delay interbed variables do n = 1, this%ndelaycells - rval = this%thickini(ib)/real(this%ndelaycells, DP) + rval = this%thickini(ib) / real(this%ndelaycells, DP) this%dbdzini(n, idelay) = rval this%dbh(n, idelay) = this%h0(ib) this%dbh0(n, idelay) = this%h0(ib) @@ -1881,8 +1905,8 @@ subroutine csub_fp(this) do ib = 1, this%ninterbeds idelay = this%idelay(ib) b0 = this%thickini(ib) - strain = this%tcomp(ib)/b0 - pctcomp = DHUNDRED*strain + strain = this%tcomp(ib) / b0 + pctcomp = DHUNDRED * strain pctcomp_arr(ib) = pctcomp if (pctcomp >= DONE) then iexceed = iexceed + 1 @@ -1942,10 +1966,10 @@ subroutine csub_fp(this) ctype = 'no-delay' else ctype = 'delay' - b0 = b0*this%rnb(ib) + b0 = b0 * this%rnb(ib) end if - strain = this%tcomp(ib)/b0 - pctcomp = DHUNDRED*strain + strain = this%tcomp(ib) / b0 + pctcomp = DHUNDRED * strain if (pctcomp >= 5.0_DP) then cflag = '**>=5%' else if (pctcomp >= DONE) then @@ -2033,10 +2057,10 @@ subroutine csub_fp(this) ctype = 'no-delay' else ctype = 'delay' - b0 = b0*this%rnb(ib) + b0 = b0 * this%rnb(ib) end if - strain = this%tcomp(ib)/b0 - pctcomp = DHUNDRED*strain + strain = this%tcomp(ib) / b0 + pctcomp = DHUNDRED * strain node = this%nodelist(ib) call this%dis%noder_to_array(node, locs) ! @@ -2070,9 +2094,9 @@ subroutine csub_fp(this) do node = 1, this%dis%nodes strain = DZERO if (this%cg_thickini(node) > DZERO) then - strain = this%cg_tcomp(node)/this%cg_thickini(node) + strain = this%cg_tcomp(node) / this%cg_thickini(node) end if - pctcomp = DHUNDRED*strain + pctcomp = DHUNDRED * strain pctcomp_arr(node) = pctcomp if (pctcomp >= DONE) then iexceed = iexceed + 1 @@ -2121,11 +2145,11 @@ subroutine csub_fp(this) do nn = 1, nlen node = imap_sel(nn) if (this%cg_thickini(node) > DZERO) then - strain = this%cg_tcomp(node)/this%cg_thickini(node) + strain = this%cg_tcomp(node) / this%cg_thickini(node) else strain = DZERO end if - pctcomp = DHUNDRED*strain + pctcomp = DHUNDRED * strain if (pctcomp >= 5.0_DP) then cflag = '**>=5%' else if (pctcomp >= DONE) then @@ -2201,11 +2225,11 @@ subroutine csub_fp(this) ! -- write data do node = 1, this%dis%nodes if (this%cg_thickini(node) > DZERO) then - strain = this%cg_tcomp(node)/this%cg_thickini(node) + strain = this%cg_tcomp(node) / this%cg_thickini(node) else strain = DZERO end if - pctcomp = DHUNDRED*strain + pctcomp = DHUNDRED * strain call this%dis%noder_to_array(node, locs) ! ! -- fill table line @@ -2229,8 +2253,9 @@ subroutine csub_fp(this) if (this%idb_nconv_count(2) > 0) then write (warnmsg, '(a,1x,a,1x,i0,1x,a,1x,a)') & 'Delay interbed cell heads were less than the top of the interbed', & - 'cell in', this%idb_nconv_count(2), 'interbed cells in non-convertible', & - 'GWF cells for at least one time step during the simulation.' + 'cell in', this%idb_nconv_count(2), 'interbed cells in ', & + 'non-convertible GWF cells for at least one time step during '// & + 'the simulation.' call store_warning(warnmsg) end if end if @@ -2452,14 +2477,13 @@ subroutine csub_da(this) ! ! -- deallocate and nullify observations deallocate (this%obs) - nullify(this%obs) + nullify (this%obs) end if ! ! -- deallocate TsManager deallocate (this%TsManager) nullify (this%TsManager) - ! ! -- deallocate parent call this%NumericalPackageType%da() @@ -2496,9 +2520,9 @@ subroutine csub_rp(this) real(DP), pointer :: bndElem => null() ! -- formats character(len=*), parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + &"('Looking for BEGIN PERIOD iper. Found ',a,' instead.')" character(len=*), parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + &"(1X,/1X,'REUSING ',a,'S FROM LAST STRESS PERIOD')" ! ! -- return if data is not read from file if (this%inunit == 0) return @@ -2590,10 +2614,11 @@ subroutine csub_rp(this) ! ! -- get sig0 call this%parser%GetString(text) - jj = 1 ! For 'SIG0' + jj = 1 ! For 'SIG0' bndElem => this%sig0(nlist) - call read_value_or_time_series_adv(text, nlist, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, nlist, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & 'SIG0') ! ! -- write line to table @@ -2642,8 +2667,8 @@ subroutine csub_ad(this, nodes, hnew) use TdisModule, only: nper, kper ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes !< number of active model nodes - real(DP), dimension(nodes), intent(in) :: hnew !< current head + integer(I4B), intent(in) :: nodes !< number of active model nodes + real(DP), dimension(nodes), intent(in) :: hnew !< current head ! -- local variables integer(I4B) :: ib integer(I4B) :: n @@ -2762,13 +2787,13 @@ subroutine csub_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) use TdisModule, only: delt ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: kiter !< outer iteration numbed - real(DP), intent(in), dimension(:) :: hold !< previous heads - real(DP), intent(in), dimension(:) :: hnew !< current heads - integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution - real(DP), dimension(njasln), intent(inout) :: amat !< A matrix - integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution - real(DP), intent(inout), dimension(:) :: rhs !< right-hand side + integer(I4B), intent(in) :: kiter !< outer iteration numbed + real(DP), intent(in), dimension(:) :: hold !< previous heads + real(DP), intent(in), dimension(:) :: hnew !< current heads + integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution + real(DP), dimension(njasln), intent(inout) :: amat !< A matrix + integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution + real(DP), intent(inout), dimension(:) :: rhs !< right-hand side ! -- local variables integer(I4B) :: ib integer(I4B) :: node @@ -2787,7 +2812,7 @@ subroutine csub_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) if (this%gwfiss == 0) then ! ! -- initialize tled - tled = DONE/delt + tled = DONE / delt ! ! -- coarse-grained storage do node = 1, this%dis%nodes @@ -2883,13 +2908,13 @@ subroutine csub_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) use TdisModule, only: delt ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: kiter !< outer iteration number - real(DP), intent(in), dimension(:) :: hold !< previous heads - real(DP), intent(in), dimension(:) :: hnew !< current heads - integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution - real(DP), dimension(njasln), intent(inout) :: amat !< A matrix - integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution - real(DP), intent(inout), dimension(:) :: rhs !< right-hand side + integer(I4B), intent(in) :: kiter !< outer iteration number + real(DP), intent(in), dimension(:) :: hold !< previous heads + real(DP), intent(in), dimension(:) :: hnew !< current heads + integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution + real(DP), dimension(njasln), intent(inout) :: amat !< A matrix + integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution + real(DP), intent(inout), dimension(:) :: rhs !< right-hand side ! -- local variables integer(I4B) :: idelay integer(I4B) :: node @@ -2902,7 +2927,7 @@ subroutine csub_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) ! ! -- formulate csub terms if (this%gwfiss == 0) then - tled = DONE/delt + tled = DONE / delt ! ! -- coarse-grained storage do node = 1, this%dis%nodes @@ -2993,16 +3018,16 @@ subroutine csub_cc(this, innertot, kiter, iend, icnvgmod, nodes, & use TdisModule, only: totim, kstp, kper, delt ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: innertot !< total number of inner iterations - integer(I4B), intent(in) :: kiter !< outer iteration number - integer(I4B), intent(in) :: iend !< flag indicating if it is the last iteration - integer(I4B), intent(in) :: icnvgmod !< flag indicating if the solution is considered converged - integer(I4B), intent(in) :: nodes !< number of active nodes - real(DP), dimension(nodes), intent(in) :: hnew !< current gwf head - real(DP), dimension(nodes), intent(in) :: hold !< gwf for previous time step - character(len=LENPAKLOC), intent(inout) :: cpak !< string location of the maximum change in csub package - integer(I4B), intent(inout) :: ipak !< node with the maximum change in csub package - real(DP), intent(inout) :: dpak !< maximum change in csub package + integer(I4B), intent(in) :: innertot !< total number of inner iterations + integer(I4B), intent(in) :: kiter !< outer iteration number + integer(I4B), intent(in) :: iend !< flag indicating if it is the last iteration + integer(I4B), intent(in) :: icnvgmod !< flag indicating if the solution is considered converged + integer(I4B), intent(in) :: nodes !< number of active nodes + real(DP), dimension(nodes), intent(in) :: hnew !< current gwf head + real(DP), dimension(nodes), intent(in) :: hold !< gwf for previous time step + character(len=LENPAKLOC), intent(inout) :: cpak !< string location of the maximum change in csub package + integer(I4B), intent(inout) :: ipak !< node with the maximum change in csub package + real(DP), intent(inout) :: dpak !< maximum change in csub package ! -- local variables character(len=LINELENGTH) :: tag character(len=LENPAKLOC) :: cloc @@ -3096,7 +3121,7 @@ subroutine csub_cc(this, innertot, kiter, iend, icnvgmod, nodes, & ! -- perform package convergence check if (icheck /= 0) then if (DELT > DZERO) then - tled = DONE/DELT + tled = DONE / DELT else tled = DZERO end if @@ -3125,22 +3150,22 @@ subroutine csub_cc(this, innertot, kiter, iend, icnvgmod, nodes, & ! ! -- calculate the change in storage call this%csub_delay_calc_dstor(ib, hcell, stoe, stoi) - v1 = (stoe + stoi)*area*this%rnb(ib)*tled + v1 = (stoe + stoi) * area * this%rnb(ib) * tled ! ! -- add water compressibility to storage term call this%csub_delay_calc_wcomp(ib, dwc) - v1 = v1 + dwc*area*this%rnb(ib) + v1 = v1 + dwc * area * this%rnb(ib) ! ! -- calculate the flow between the interbed and the cell call this%csub_delay_fc(ib, hcof, rhs) - v2 = (-hcof*hcell - rhs)*area*this%rnb(ib) + v2 = (-hcof * hcell - rhs) * area * this%rnb(ib) ! ! -- calculate the difference between the interbed change in ! storage and the flow between the interbed and the cell df = v2 - v1 ! ! -- normalize by cell area and convert to a depth - df = df*delt/area + df = df * delt / area ! ! -- evaluate magnitude of differences if (ifirst == 1) then @@ -3218,10 +3243,10 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) use ConstantsModule, only: LENBOUNDNAME, DZERO, DONE ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes !< number of active model nodes - real(DP), intent(in), dimension(nodes) :: hnew !< current head - real(DP), intent(in), dimension(nodes) :: hold !< head for the previous time step - integer(I4B), intent(in) :: isuppress_output !< flag indicating if budget output should be suppressed + integer(I4B), intent(in) :: nodes !< number of active model nodes + real(DP), intent(in), dimension(nodes) :: hnew !< current head + real(DP), intent(in), dimension(nodes) :: hold !< head for the previous time step + integer(I4B), intent(in) :: isuppress_output !< flag indicating if budget output should be suppressed real(DP), dimension(:), contiguous, intent(inout) :: flowja ! -- local variables integer(I4B) :: ib @@ -3276,7 +3301,7 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) rratewc = DZERO if (this%gwfiss == 0) then if (DELT > DZERO) then - tled = DONE/DELT + tled = DONE / DELT else tled = DZERO end if @@ -3285,7 +3310,7 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) ! -- calculate coarse-grained storage terms call this%csub_cg_fc(node, tled, area, hnew(node), hold(node), & hcof, rhs) - rrate = hcof*hnew(node) - rhs + rrate = hcof * hnew(node) - rhs ! ! -- calculate compaction call this%csub_cg_calc_comp(node, hnew(node), hold(node), comp) @@ -3293,7 +3318,7 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) ! -- calculate coarse-grained water compressibility storage terms call this%csub_cg_wcomp_fc(node, tled, area, hnew(node), hold(node), & hcof, rhs) - rratewc = hcof*hnew(node) - rhs + rratewc = hcof * hnew(node) - rhs end if end if ! @@ -3347,7 +3372,7 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) b = this%thick(ib) ! -- delay interbeds else - b = this%thick(ib)*this%rnb(ib) + b = this%thick(ib) * this%rnb(ib) end if ! ! -- set variables required for no-delay and delay interbeds @@ -3361,7 +3386,7 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) ! -- update budget terms if transient stress period if (this%gwfiss == 0) then if (DELT > DZERO) then - tledm = DONE/DELT + tledm = DONE / DELT else tledm = DZERO end if @@ -3387,15 +3412,15 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) if (ielastic > 0 .or. iconvert == 0) then stoe = comp else - stoi = -pcs*rho2 + (rho2*es) - stoe = pcs*rho1 - (rho1*es0) + stoi = -pcs * rho2 + (rho2 * es) + stoe = pcs * rho1 - (rho1 * es0) end if compe = stoe compi = stoi - stoe = stoe*area - stoi = stoi*area - this%storagee(ib) = stoe*tledm - this%storagei(ib) = stoi*tledm + stoe = stoe * area + stoi = stoi * area + this%storagee(ib) = stoe * tledm + this%storagei(ib) = stoi * tledm ! ! -- update compaction this%comp(ib) = comp @@ -3424,14 +3449,14 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) ! ! -- calculate inelastic and elastic storage contributions call this%csub_delay_calc_dstor(ib, h, stoe, stoi) - this%storagee(ib) = stoe*area*this%rnb(ib)*tledm - this%storagei(ib) = stoi*area*this%rnb(ib)*tledm + this%storagee(ib) = stoe * area * this%rnb(ib) * tledm + this%storagei(ib) = stoi * area * this%rnb(ib) * tledm ! ! -- calculate flow across the top and bottom of the delay interbed - q = this%csub_calc_delay_flow(ib, 1, h)*area*this%rnb(ib) + q = this%csub_calc_delay_flow(ib, 1, h) * area * this%rnb(ib) this%dbflowtop(idelay) = q nn = this%ndelaycells - q = this%csub_calc_delay_flow(ib, nn, h)*area*this%rnb(ib) + q = this%csub_calc_delay_flow(ib, nn, h) * area * this%rnb(ib) this%dbflowbot(idelay) = q ! ! -- update states if required @@ -3453,7 +3478,8 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) ! ! -- update total compaction for each delay bed cell do n = 1, this%ndelaycells - this%dbtcomp(n, idelay) = this%dbtcomp(n, idelay) + this%dbcomp(n, idelay) + this%dbtcomp(n, idelay) = this%dbtcomp(n, idelay) + & + this%dbcomp(n, idelay) end do ! ! -- check delay bed heads relative to the top and bottom of each @@ -3468,12 +3494,12 @@ subroutine csub_cq(this, nodes, hnew, hold, isuppress_output, flowja) if (idelay == 0) then call this%csub_nodelay_wcomp_fc(ib, node, tledm, area, & hnew(node), hold(node), hcof, rhs) - rratewc = hcof*hnew(node) - rhs + rratewc = hcof * hnew(node) - rhs ! ! -- delay interbed else call this%csub_delay_calc_wcomp(ib, q) - rratewc = q*area*this%rnb(ib) + rratewc = q * area * this%rnb(ib) end if this%cell_wcstor(node) = this%cell_wcstor(node) + rratewc ! @@ -3522,7 +3548,7 @@ subroutine csub_bd(this, isuppress_output, model_budget) ! -- dummy variables class(GwfCsubType) :: this integer(I4B), intent(in) :: isuppress_output - type(BudgetType), intent(inout) :: model_budget !< model budget object + type(BudgetType), intent(inout) :: model_budget !< model budget object ! -- local real(DP) :: rin real(DP) :: rout @@ -3544,21 +3570,21 @@ subroutine csub_bd(this, isuppress_output, model_budget) isuppress_output, ' CSUB') end if call rate_accumulator(this%cell_wcstor, rin, rout) - call model_budget%addentry(rin, rout, delt, budtxt(4), & + call model_budget%addentry(rin, rout, delt, budtxt(4), & isuppress_output, ' CSUB') return end subroutine csub_bd - + !> @ brief Save model flows for package !! -!! Save cell-by-cell budget terms for the CSUB package. +!! Save cell-by-cell budget terms for the CSUB package. !! !< subroutine csub_save_model_flows(this, icbcfl, icbcun) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: icbcfl !< flag to output budget data - integer(I4B), intent(in) :: icbcun !< unit number for cell-by-cell file + integer(I4B), intent(in) :: icbcfl !< flag to output budget data + integer(I4B), intent(in) :: icbcun !< unit number for cell-by-cell file ! -- local variables character(len=1) :: cdatafmp = ' ' character(len=1) :: editdesc = ' ' @@ -3596,9 +3622,16 @@ subroutine csub_save_model_flows(this, icbcfl, icbcun) naux = 0 ! ! -- interbed elastic storage - call this%dis%record_srcdst_list_header(budtxt(2), this%name_model, & - this%name_model, this%name_model, this%packName, naux, & - this%auxname, ibinun, this%ninterbeds, this%iout) + call this%dis%record_srcdst_list_header(budtxt(2), & + this%name_model, & + this%name_model, & + this%name_model, & + this%packName, & + naux, & + this%auxname, & + ibinun, & + this%ninterbeds, & + this%iout) do ib = 1, this%ninterbeds q = this%storagee(ib) node = this%nodelist(ib) @@ -3607,9 +3640,16 @@ subroutine csub_save_model_flows(this, icbcfl, icbcun) end do ! ! -- interbed inelastic storage - call this%dis%record_srcdst_list_header(budtxt(3), this%name_model, & - this%name_model, this%name_model, this%packName, naux, & - this%auxname, ibinun, this%ninterbeds, this%iout) + call this%dis%record_srcdst_list_header(budtxt(3), & + this%name_model, & + this%name_model, & + this%name_model, & + this%packName, & + naux, & + this%auxname, & + ibinun, & + this%ninterbeds, & + this%iout) do ib = 1, this%ninterbeds q = this%storagei(ib) node = this%nodelist(ib) @@ -3630,15 +3670,15 @@ end subroutine csub_save_model_flows !> @ brief Save and print dependent values for package !! -!! Method saves cell-by-cell compaction and z-displacement terms. The method +!! Method saves cell-by-cell compaction and z-displacement terms. The method !! also calls the method to process observation output. !! !< subroutine csub_ot_dv(this, idvfl, idvprint) ! -- dummy variables - class(GwfCsubType) :: this - integer(I4B), intent(in) :: idvfl !< flag to save dependent variable data - integer(I4B), intent(in) :: idvprint !< flag to print dependent variable data + class(GwfCsubType) :: this + integer(I4B), intent(in) :: idvfl !< flag to save dependent variable data + integer(I4B), intent(in) :: idvprint !< flag to print dependent variable data ! -- local variables character(len=1) :: cdatafmp = ' ' character(len=1) :: editdesc = ' ' @@ -3657,7 +3697,7 @@ subroutine csub_ot_dv(this, idvfl, idvprint) real(DP) :: dinact ! -- formats character(len=*), parameter :: fmtnconv = & - "(/4x, 'DELAY INTERBED CELL HEADS IN ', i0, ' INTERBEDS IN', & + "(/4x, 'DELAY INTERBED CELL HEADS IN ', i0, ' INTERBEDS IN', & &' NON-CONVERTIBLE GWF CELLS WERE LESS THAN THE TOP OF THE INTERBED CELL')" ! ! -- Save compaction results @@ -3715,11 +3755,11 @@ subroutine csub_ot_dv(this, idvfl, idvprint) ! TO DO - ! -- disv or dis else - nlay = this%dis%nodesuser/ncpl + nlay = this%dis%nodesuser / ncpl do k = nlay - 1, 1, -1 do i = 1, ncpl - node = (k - 1)*ncpl + i - nodem = k*ncpl + i + node = (k - 1) * ncpl + i + nodem = k * ncpl + i this%buffusr(node) = this%buffusr(node) + this%buffusr(nodem) end do end do @@ -3882,8 +3922,8 @@ end subroutine csub_ot_dv subroutine csub_cg_calc_stress(this, nodes, hnew) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: nodes !< number of active model nodes - real(DP), dimension(nodes), intent(in) :: hnew !< current head + integer(I4B), intent(in) :: nodes !< number of active model nodes + real(DP), dimension(nodes), intent(in) :: hnew !< current head ! -- local variables integer(I4B) :: node integer(I4B) :: ii @@ -3928,9 +3968,9 @@ subroutine csub_cg_calc_stress(this, nodes, hnew) ! ! -- geostatic stress calculation if (hcell < top) then - gs = (top - hbar)*this%sgm(node) + (hbar - bot)*this%sgs(node) + gs = (top - hbar) * this%sgm(node) + (hbar - bot) * this%sgs(node) else - gs = thick*this%sgs(node) + gs = thick * this%sgs(node) end if ! ! -- cell contribution to geostatic stress @@ -3976,9 +4016,9 @@ subroutine csub_cg_calc_stress(this, nodes, hnew) else area_conn = this%dis%get_area(m) hwva = this%dis%con%hwva(iis) - va_scale = this%dis%con%hwva(iis)/this%dis%get_area(m) + va_scale = this%dis%con%hwva(iis) / this%dis%get_area(m) gs_conn = this%cg_gs(m) - gs = gs + (gs_conn*va_scale) + gs = gs + (gs_conn * va_scale) end if end if @@ -4144,13 +4184,13 @@ subroutine csub_nodelay_fc(this, ib, hcell, hcellold, rho1, rho2, rhs, & use TdisModule, only: delt ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head in the cell - real(DP), intent(in) :: hcellold !< previous head in the cell - real(DP), intent(inout) :: rho1 !< current storage coefficient value using Sske - real(DP), intent(inout) :: rho2 !< current storage coefficient value based on Ssk - real(DP), intent(inout) :: rhs !< no-delay interbed contribution to the right-hand side - real(DP), intent(in), optional :: argtled !< optional reciprocal of the time step length + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head in the cell + real(DP), intent(in) :: hcellold !< previous head in the cell + real(DP), intent(inout) :: rho1 !< current storage coefficient value using Sske + real(DP), intent(inout) :: rho2 !< current storage coefficient value based on Ssk + real(DP), intent(inout) :: rhs !< no-delay interbed contribution to the right-hand side + real(DP), intent(in), optional :: argtled !< optional reciprocal of the time step length ! -- local variables integer(I4B) :: node real(DP) :: tled @@ -4175,7 +4215,7 @@ subroutine csub_nodelay_fc(this, ib, hcell, hcellold, rho1, rho2, rhs, & if (present(argtled)) then tled = argtled else - tled = DONE/delt + tled = DONE / delt end if node = this%nodelist(ib) area = this%dis%get_area(node) @@ -4205,29 +4245,29 @@ subroutine csub_nodelay_fc(this, ib, hcell, hcellold, rho1, rho2, rhs, & ! current and previous head call this%csub_calc_sfacts(node, bot, znode, theta, es, es0, f) end if - sto_fac = tled*snnew*thick*f - sto_fac0 = tled*snold*thick*f + sto_fac = tled * snnew * thick * f + sto_fac0 = tled * snold * thick * f ! ! -- calculate rho1 and rho2 - rho1 = this%rci(ib)*sto_fac0 - rho2 = this%rci(ib)*sto_fac + rho1 = this%rci(ib) * sto_fac0 + rho2 = this%rci(ib) * sto_fac if (this%cg_es(node) > this%pcs(ib)) then this%iconvert(ib) = 1 - rho2 = this%ci(ib)*sto_fac + rho2 = this%ci(ib) * sto_fac end if ! ! -- calculate correction term - rcorr = rho2*(hcell - hbar) + rcorr = rho2 * (hcell - hbar) ! ! -- fill right-hand side if (this%ielastic(ib) /= 0) then - rhs = rho1*this%cg_es0(node) - & - rho2*(this%cg_gs(node) + bot) - & + rhs = rho1 * this%cg_es0(node) - & + rho2 * (this%cg_gs(node) + bot) - & rcorr else - rhs = -rho2*(this%cg_gs(node) + bot) + & - (this%pcs(ib)*(rho2 - rho1)) + & - (rho1*this%cg_es0(node)) - & + rhs = -rho2 * (this%cg_gs(node) + bot) + & + (this%pcs(ib) * (rho2 - rho1)) + & + (rho1 * this%cg_es0(node)) - & rcorr end if ! @@ -4253,12 +4293,12 @@ end subroutine csub_nodelay_fc subroutine csub_nodelay_calc_comp(this, ib, hcell, hcellold, comp, rho1, rho2) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head for the cell - real(DP), intent(in) :: hcellold !< previous head for the cell - real(DP), intent(inout) :: comp !< no-delay interbed compaction - real(DP), intent(inout) :: rho1 !< current storage coefficient based on Sske - real(DP), intent(inout) :: rho2 !< current storage coefficient based on Ssk + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head for the cell + real(DP), intent(in) :: hcellold !< previous head for the cell + real(DP), intent(inout) :: comp !< no-delay interbed compaction + real(DP), intent(inout) :: rho1 !< current storage coefficient based on Sske + real(DP), intent(inout) :: rho2 !< current storage coefficient based on Ssk ! -- local variables integer(I4B) :: node real(DP) :: es @@ -4279,9 +4319,9 @@ subroutine csub_nodelay_calc_comp(this, ib, hcell, hcellold, comp, rho1, rho2) ! ! -- calculate no-delay interbed compaction if (this%ielastic(ib) /= 0) then - comp = rho2*es - rho1*es0 + comp = rho2 * es - rho1 * es0 else - comp = -pcs*(rho2 - rho1) - (rho1*es0) + (rho2*es) + comp = -pcs * (rho2 - rho1) - (rho1 * es0) + (rho2 * es) end if ! ! -- return @@ -4299,8 +4339,8 @@ subroutine csub_set_initial_state(this, nodes, hnew) ! -- dummy variables class(GwfCsubType) :: this ! -- dummy variables - integer(I4B), intent(in) :: nodes !< number of active model nodes - real(DP), dimension(nodes), intent(in) :: hnew !< current heads + integer(I4B), intent(in) :: nodes !< number of active model nodes + real(DP), dimension(nodes), intent(in) :: hnew !< current heads ! -- local variables character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag @@ -4363,7 +4403,7 @@ subroutine csub_set_initial_state(this, nodes, hnew) ! ! -- delay bed initial states if (idelay /= 0) then - dzhalf = DHALF*this%dbdzini(1, idelay) + dzhalf = DHALF * this%dbdzini(1, idelay) ! ! -- fill delay bed head with aquifer head or offset from aquifer head ! heads need to be filled first since used to calculate @@ -4386,7 +4426,7 @@ subroutine csub_set_initial_state(this, nodes, hnew) zbot = this%dbz(n, idelay) - dzhalf ! -- adjust pcs to bottom of each delay bed cell ! not using csub_calc_adjes() since smoothing not required - dbpcs = pcs - (zbot - bot)*(this%sgs(node) - DONE) + dbpcs = pcs - (zbot - bot) * (this%sgs(node) - DONE) this%dbpcs(n, idelay) = dbpcs ! ! -- initialize effective stress for previous time step @@ -4420,14 +4460,14 @@ subroutine csub_set_initial_state(this, nodes, hnew) ! -- calculate znode and factor znode = this%csub_calc_znode(top, bot, hbar) fact = this%csub_calc_adjes(node, es, bot, znode) - fact = fact*(DONE + void) + fact = fact * (DONE + void) end if ! ! -- user-specified compression indices - multiply by dlog10es else fact = dlog10es end if - this%cg_ske_cr(node) = this%cg_ske_cr(node)*fact + this%cg_ske_cr(node) = this%cg_ske_cr(node) * fact ! ! -- write error message if negative compression indices if (fact <= DZERO) then @@ -4466,15 +4506,15 @@ subroutine csub_set_initial_state(this, nodes, hnew) ! -- calculate zone and factor znode = this%csub_calc_znode(top, bot, hbar) fact = this%csub_calc_adjes(node, es, bot, znode) - fact = fact*(DONE + void) + fact = fact * (DONE + void) end if ! ! -- user-specified compression indices - multiply by dlog10es else fact = dlog10es end if - this%ci(ib) = this%ci(ib)*fact - this%rci(ib) = this%rci(ib)*fact + this%ci(ib) = this%ci(ib) * fact + this%rci(ib) = this%rci(ib) * fact ! ! -- write error message if negative compression indices if (fact <= DZERO) then @@ -4644,15 +4684,15 @@ subroutine csub_set_initial_state(this, nodes, hnew) ! ! -- write the data do ib = 1, this%ninterbeds - fact = DONE/dlog10es + fact = DONE / dlog10es node = this%nodelist(ib) call this%dis%noder_to_string(node, cellid) ! ! -- write the columns call this%inputtab%add_term(ib) call this%inputtab%add_term(cellid) - call this%inputtab%add_term(this%ci(ib)*fact) - call this%inputtab%add_term(this%rci(ib)*fact) + call this%inputtab%add_term(this%ci(ib) * fact) + call this%inputtab%add_term(this%rci(ib) * fact) if (this%inamedbound /= 0) then call this%inputtab%add_term(this%boundname(ib)) end if @@ -4690,13 +4730,13 @@ end subroutine csub_set_initial_state subroutine csub_cg_fc(this, node, tled, area, hcell, hcellold, hcof, rhs) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: tled !< recripicol of the time step length - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head - real(DP), intent(in) :: hcellold !< previous head - real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry - real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: tled !< recripicol of the time step length + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head + real(DP), intent(in) :: hcellold !< previous head + real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry + real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry ! -- local variables real(DP) :: top real(DP) :: bot @@ -4727,19 +4767,19 @@ subroutine csub_cg_fc(this, node, tled, area, hcell, hcellold, hcof, rhs) ! ! -- storage coefficients call this%csub_cg_calc_sske(node, sske, hcell) - rho1 = sske*area*tthk*tled + rho1 = sske * area * tthk * tled ! ! -- update sk and ske - this%cg_ske(node) = sske*tthk*snold - this%cg_sk(node) = sske*tthk*snnew + this%cg_ske(node) = sske * tthk * snold + this%cg_sk(node) = sske * tthk * snnew ! ! -- calculate hcof and rhs term - hcof = -rho1*snnew - rhs = rho1*snold*this%cg_es0(node) - & - rho1*snnew*(this%cg_gs(node) + bot) + hcof = -rho1 * snnew + rhs = rho1 * snold * this%cg_es0(node) - & + rho1 * snnew * (this%cg_gs(node) + bot) ! ! -- calculate and apply the flow correction term - rhs = rhs - rho1*snnew*(hcell - hbar) + rhs = rhs - rho1 * snnew * (hcell - hbar) end if ! ! -- return @@ -4759,12 +4799,12 @@ end subroutine csub_cg_fc subroutine csub_cg_fn(this, node, tled, area, hcell, hcof, rhs) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: node !< node number - real(DP), intent(in) :: tled !< reciprocal of the time step length - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry - real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry + integer(I4B), intent(in) :: node !< node number + real(DP), intent(in) :: tled !< reciprocal of the time step length + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry + real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry ! -- local variables real(DP) :: top real(DP) :: bot @@ -4803,19 +4843,19 @@ subroutine csub_cg_fn(this, node, tled, area, hcell, hcof, rhs) ! ! -- storage coefficients call this%csub_cg_calc_sske(node, sske, hcell) - rho1 = sske*area*tthk*tled + rho1 = sske * area * tthk * tled ! ! -- calculate hcof term - hcof = rho1*snnew*(DONE - hbarderv) + & - rho1*(this%cg_gs(node) - hbar + bot)*satderv + hcof = rho1 * snnew * (DONE - hbarderv) + & + rho1 * (this%cg_gs(node) - hbar + bot) * satderv ! ! -- Add additional term if using lagged effective stress if (this%ieslag /= 0) then - hcof = hcof - rho1*this%cg_es0(node)*satderv + hcof = hcof - rho1 * this%cg_es0(node) * satderv end if ! ! -- calculate rhs term - rhs = hcof*hcell + rhs = hcof * hcell end if ! ! -- return @@ -4834,13 +4874,13 @@ end subroutine csub_cg_fn subroutine csub_interbed_fc(this, ib, node, area, hcell, hcellold, hcof, rhs) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: hcof !< interbed A matrix entry - real(DP), intent(inout) :: rhs !< interbed right-hand side + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: hcof !< interbed A matrix entry + real(DP), intent(inout) :: rhs !< interbed right-hand side ! -- local variables real(DP) :: snnew real(DP) :: snold @@ -4901,10 +4941,10 @@ subroutine csub_interbed_fc(this, ib, node, area, hcell, hcellold, hcof, rhs) ! -- calculate delay interbed hcof and rhs call this%csub_delay_sln(ib, hcell) call this%csub_delay_fc(ib, hcof, rhs) - f = area*this%rnb(ib) + f = area * this%rnb(ib) end if - rhs = rhs*f - hcof = -hcof*f + rhs = rhs * f + hcof = -hcof * f end if ! ! -- return @@ -4925,12 +4965,12 @@ subroutine csub_interbed_fn(this, ib, node, hcell, hcellold, hcof, rhs) use TdisModule, only: delt ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: hcell !< current head in a cell - real(DP), intent(in) :: hcellold !< previous head in a cell - real(DP), intent(inout) :: hcof !< interbed A matrix entry - real(DP), intent(inout) :: rhs !< interbed right-hand side entry + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: hcell !< current head in a cell + real(DP), intent(in) :: hcellold !< previous head in a cell + real(DP), intent(inout) :: hcof !< interbed A matrix entry + real(DP), intent(inout) :: rhs !< interbed right-hand side entry ! -- local variables integer(I4B) :: idelay real(DP) :: hcofn @@ -4960,7 +5000,7 @@ subroutine csub_interbed_fn(this, ib, node, hcell, hcellold, hcof, rhs) ! ! -- skip inactive and constant head cells if (this%ibound(node) > 0) then - tled = DONE/delt + tled = DONE / delt tthk = this%thickini(ib) ! ! -- calculate cell saturation @@ -4985,18 +5025,18 @@ subroutine csub_interbed_fn(this, ib, node, hcell, hcellold, hcof, rhs) call this%csub_nodelay_fc(ib, hcell, hcellold, rho1, rho2, rhsn) ! ! -- calculate hcofn term - hcofn = rho2*(DONE - hbarderv)*snnew + & - rho2*(this%cg_gs(node) - hbar + bot)*satderv + hcofn = rho2 * (DONE - hbarderv) * snnew + & + rho2 * (this%cg_gs(node) - hbar + bot) * satderv if (this%ielastic(ib) == 0) then - hcofn = hcofn - rho2*this%pcs(ib)*satderv + hcofn = hcofn - rho2 * this%pcs(ib) * satderv end if ! ! -- Add additional term if using lagged effective stress if (this%ieslag /= 0) then if (this%ielastic(ib) /= 0) then - hcofn = hcofn - rho1*this%cg_es0(node)*satderv + hcofn = hcofn - rho1 * this%cg_es0(node) * satderv else - hcofn = hcofn - rho1*(this%pcs(ib) - this%cg_es0(node))*satderv + hcofn = hcofn - rho1 * (this%pcs(ib) - this%cg_es0(node)) * satderv end if end if end if @@ -5016,9 +5056,9 @@ end subroutine csub_interbed_fn subroutine csub_cg_calc_sske(this, n, sske, hcell) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: n !< cell node number - real(DP), intent(inout) :: sske !< coarse grained Sske - real(DP), intent(in) :: hcell !< current head in cell + integer(I4B), intent(in) :: n !< cell node number + real(DP), intent(inout) :: sske !< coarse grained Sske + real(DP), intent(in) :: hcell !< current head in cell ! -- local variables real(DP) :: top real(DP) :: bot @@ -5059,7 +5099,7 @@ subroutine csub_cg_calc_sske(this, n, sske, hcell) ! current and previous head call this%csub_calc_sfacts(n, bot, znode, theta, es, es0, f) end if - sske = f*this%cg_ske_cr(n) + sske = f * this%cg_ske_cr(n) ! ! -- return return @@ -5075,10 +5115,10 @@ end subroutine csub_cg_calc_sske subroutine csub_cg_calc_comp(this, node, hcell, hcellold, comp) ! -- dummy variables class(GwfCsubType) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: comp !< coarse-grained compaction + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: comp !< coarse-grained compaction ! -- local variables real(DP) :: area real(DP) :: tled @@ -5093,7 +5133,7 @@ subroutine csub_cg_calc_comp(this, node, hcell, hcellold, comp) call this%csub_cg_fc(node, tled, area, hcell, hcellold, hcof, rhs) ! ! - calculate compaction - comp = hcof*hcell - rhs + comp = hcof * hcell - rhs ! ! -- return return @@ -5107,7 +5147,7 @@ end subroutine csub_cg_calc_comp subroutine csub_cg_update(this, node) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number + integer(I4B), intent(in) :: node !< cell node number ! -- local variables character(len=20) :: cellid real(DP) :: comp @@ -5155,13 +5195,13 @@ subroutine csub_cg_wcomp_fc(this, node, tled, area, hcell, hcellold, & hcof, rhs) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: tled !< reciprocal of the time step length - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry - real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: tled !< reciprocal of the time step length + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry + real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry ! -- local variables real(DP) :: top real(DP) :: bot @@ -5186,14 +5226,14 @@ subroutine csub_cg_wcomp_fc(this, node, tled, area, hcell, hcellold, & call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) ! ! -- storage coefficients - wc0 = this%brg*area*tthk0*this%cg_theta0(node)*tled - wc = this%brg*area*tthk*this%cg_theta(node)*tled + wc0 = this%brg * area * tthk0 * this%cg_theta0(node) * tled + wc = this%brg * area * tthk * this%cg_theta(node) * tled ! ! -- calculate hcof term - hcof = -wc*snnew + hcof = -wc * snnew ! ! -- calculate rhs term - rhs = -wc0*snold*hcellold + rhs = -wc0 * snold * hcellold ! ! -- return return @@ -5212,13 +5252,13 @@ end subroutine csub_cg_wcomp_fc subroutine csub_cg_wcomp_fn(this, node, tled, area, hcell, hcellold, hcof, rhs) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: tled !< reciprocal of the time step length - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry - real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: tled !< reciprocal of the time step length + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: hcof !< coarse-grained A matrix entry + real(DP), intent(inout) :: rhs !< coarse-grained right-hand side entry ! -- local variables real(DP) :: top real(DP) :: bot @@ -5242,23 +5282,23 @@ subroutine csub_cg_wcomp_fn(this, node, tled, area, hcell, hcellold, hcof, rhs) satderv = this%csub_calc_sat_derivative(node, hcell) ! ! -- calculate water compressibility factor - f = this%brg*area*tled + f = this%brg * area * tled ! ! -- water compressibility coefficient - wc = f*tthk*this%cg_theta(node) + wc = f * tthk * this%cg_theta(node) ! ! -- calculate hcof term - hcof = -wc*hcell*satderv + hcof = -wc * hcell * satderv ! ! -- Add additional term if using lagged effective stress if (this%ieslag /= 0) then tthk0 = this%cg_thick0(node) - wc0 = f*tthk0*this%cg_theta0(node) - hcof = hcof + wc*hcellold*satderv + wc0 = f * tthk0 * this%cg_theta0(node) + hcof = hcof + wc * hcellold * satderv end if ! ! -- calculate rhs term - rhs = hcof*hcell + rhs = hcof * hcell ! ! -- return return @@ -5278,14 +5318,14 @@ subroutine csub_nodelay_wcomp_fc(this, ib, node, tled, area, & hcell, hcellold, hcof, rhs) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: tled !< reciprocal of time step length - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: hcof !< no-delay A matrix entry - real(DP), intent(inout) :: rhs !< no-delay right-hand side entry + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: tled !< reciprocal of time step length + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: hcof !< no-delay A matrix entry + real(DP), intent(inout) :: rhs !< no-delay right-hand side entry ! -- local variables real(DP) :: top real(DP) :: bot @@ -5307,11 +5347,11 @@ subroutine csub_nodelay_wcomp_fc(this, ib, node, tled, area, & call this%csub_calc_sat(node, hcell, hcellold, snnew, snold) ! ! - f = this%brg*area*tled - wc0 = f*this%theta0(ib)*this%thick0(ib) - wc = f*this%theta(ib)*this%thick(ib) - hcof = -wc*snnew - rhs = -wc0*snold*hcellold + f = this%brg * area * tled + wc0 = f * this%theta0(ib) * this%thick0(ib) + wc = f * this%theta(ib) * this%thick(ib) + hcof = -wc * snnew + rhs = -wc0 * snold * hcellold ! ! -- return return @@ -5331,14 +5371,14 @@ subroutine csub_nodelay_wcomp_fn(this, ib, node, tled, area, & hcell, hcellold, hcof, rhs) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: tled !< reciprocal of time step length - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: hcof !< no-delay A matrix entry - real(DP), intent(inout) :: rhs !< no-delay right-hand side entry + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: tled !< reciprocal of time step length + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: hcof !< no-delay A matrix entry + real(DP), intent(inout) :: rhs !< no-delay right-hand side entry ! -- local variables real(DP) :: top real(DP) :: bot @@ -5356,25 +5396,25 @@ subroutine csub_nodelay_wcomp_fn(this, ib, node, tled, area, & bot = this%dis%bot(node) ! ! - f = this%brg*area*tled + f = this%brg * area * tled ! ! -- calculate saturation derivitive satderv = this%csub_calc_sat_derivative(node, hcell) ! ! -- calculate the current water compressibility factor - wc = f*this%theta(ib)*this%thick(ib) + wc = f * this%theta(ib) * this%thick(ib) ! ! -- calculate derivative term - hcof = -wc*hcell*satderv + hcof = -wc * hcell * satderv ! ! -- Add additional term if using lagged effective stress if (this%ieslag /= 0) then - wc0 = f*this%theta0(ib)*this%thick0(ib) - hcof = hcof + wc0*hcellold*satderv + wc0 = f * this%theta0(ib) * this%thick0(ib) + hcof = hcof + wc0 * hcellold * satderv end if ! ! -- set rhs - rhs = hcof*hcell + rhs = hcof * hcell ! ! -- return return @@ -5389,11 +5429,11 @@ end subroutine csub_nodelay_wcomp_fn function csub_calc_void(this, theta) result(void) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - real(DP), intent(in) :: theta !< porosity + real(DP), intent(in) :: theta !< porosity ! -- local variables real(DP) :: void ! -- calculate void ratio - void = theta/(DONE - theta) + void = theta / (DONE - theta) ! ! -- return return @@ -5413,7 +5453,7 @@ function csub_calc_theta(this, void) result(theta) real(DP) :: theta ! ! -- calculate theta - theta = void/(DONE + void) + theta = void / (DONE + void) ! ! -- return return @@ -5428,7 +5468,7 @@ end function csub_calc_theta function csub_calc_interbed_thickness(this, ib) result(thick) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: ib !< interbed number ! -- local variables integer(I4B) :: idelay real(DP) :: thick @@ -5437,7 +5477,7 @@ function csub_calc_interbed_thickness(this, ib) result(thick) idelay = this%idelay(ib) thick = this%thick(ib) if (idelay /= 0) then - thick = thick*this%rnb(ib) + thick = thick * this%rnb(ib) end if ! ! -- return @@ -5457,9 +5497,9 @@ end function csub_calc_interbed_thickness function csub_calc_znode(this, top, bottom, zbar) result(znode) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - real(DP), intent(in) :: top !< top of cell - real(DP), intent(in) :: bottom !< bottom of cell - real(DP), intent(in) :: zbar !< corrected elevation + real(DP), intent(in) :: top !< top of cell + real(DP), intent(in) :: bottom !< bottom of cell + real(DP), intent(in) :: zbar !< corrected elevation ! -- local variables real(DP) :: znode real(DP) :: v @@ -5470,7 +5510,7 @@ function csub_calc_znode(this, top, bottom, zbar) result(znode) else v = zbar end if - znode = DHALF*(v + bottom) + znode = DHALF * (v + bottom) ! ! -- return return @@ -5487,15 +5527,15 @@ end function csub_calc_znode function csub_calc_adjes(this, node, es0, z0, z) result(es) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: es0 !< effective stress at elevation z0 - real(DP), intent(in) :: z0 !< elevation effective stress is calculate at - real(DP), intent(in) :: z !< elevation to calculate effective stress at + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: es0 !< effective stress at elevation z0 + real(DP), intent(in) :: z0 !< elevation effective stress is calculate at + real(DP), intent(in) :: z !< elevation to calculate effective stress at ! -- local variables real(DP) :: es ! ! -- adjust effective stress to vertical node position - es = es0 - (z - z0)*(this%sgs(node) - DONE) + es = es0 - (z - z0) * (this%sgs(node) - DONE) ! ! -- return return @@ -5511,7 +5551,7 @@ end function csub_calc_adjes subroutine csub_delay_head_check(this, ib) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: ib !< interbed number ! -- local variables integer(I4B) :: iviolate integer(I4B) :: idelay @@ -5531,7 +5571,7 @@ subroutine csub_delay_head_check(this, ib) idelaycells: do n = 1, this%ndelaycells z = this%dbz(n, idelay) h = this%dbh(n, idelay) - dzhalf = DHALF*this%dbdzini(1, idelay) + dzhalf = DHALF * this%dbdzini(1, idelay) ! ! -- non-convertible cell if (this%stoiconv(node) == 0) then @@ -5564,11 +5604,11 @@ end subroutine csub_delay_head_check subroutine csub_calc_sat(this, node, hcell, hcellold, snnew, snold) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: hcell !< current head - real(DP), intent(in) :: hcellold !< previous head - real(DP), intent(inout) :: snnew !< current saturation - real(DP), intent(inout) :: snold !< previous saturation + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: hcell !< current head + real(DP), intent(in) :: hcellold !< previous head + real(DP), intent(inout) :: snnew !< current saturation + real(DP), intent(inout) :: snold !< previous saturation ! -- local variables real(DP) :: top real(DP) :: bot @@ -5601,8 +5641,8 @@ end subroutine csub_calc_sat function csub_calc_sat_derivative(this, node, hcell) result(satderv) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: hcell !< current head + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: hcell !< current head ! -- local variables real(DP) :: satderv real(DP) :: top @@ -5632,13 +5672,13 @@ end function csub_calc_sat_derivative subroutine csub_calc_sfacts(this, node, bot, znode, theta, es, es0, fact) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - real(DP), intent(in) :: bot ! + integer(I4B), intent(in) :: node !< cell node number + real(DP), intent(in) :: bot ! real(DP), intent(in) :: znode - real(DP), intent(in) :: theta !< porosity - real(DP), intent(in) :: es !< current effective stress - real(DP), intent(in) :: es0 !< previous effective stress - real(DP), intent(inout) :: fact !< skeletal storage coefficient factor (1/((1+void)*bar(es))) + real(DP), intent(in) :: theta !< porosity + real(DP), intent(in) :: es !< current effective stress + real(DP), intent(in) :: es0 !< previous effective stress + real(DP), intent(inout) :: fact !< skeletal storage coefficient factor (1/((1+void)*bar(es))) ! -- local variables real(DP) :: esv real(DP) :: void @@ -5655,9 +5695,9 @@ subroutine csub_calc_sfacts(this, node, bot, znode, theta, es, es0, fact) ! -- calculate storage factors for the effective stress case void = this%csub_calc_void(theta) denom = this%csub_calc_adjes(node, esv, bot, znode) - denom = denom*(DONE + void) + denom = denom * (DONE + void) if (denom /= DZERO) then - fact = DONE/denom + fact = DONE / denom end if ! ! -- return @@ -5675,9 +5715,9 @@ end subroutine csub_calc_sfacts subroutine csub_adj_matprop(this, comp, thick, theta) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - real(DP), intent(in) :: comp !< compaction - real(DP), intent(inout) :: thick !< thickness - real(DP), intent(inout) :: theta !< porosity + real(DP), intent(in) :: comp !< compaction + real(DP), intent(inout) :: thick !< thickness + real(DP), intent(inout) :: theta !< porosity ! -- local variables real(DP) :: strain real(DP) :: void @@ -5687,10 +5727,10 @@ subroutine csub_adj_matprop(this, comp, thick, theta) void = this%csub_calc_void(theta) ! ! -- calculate strain - if (thick > DZERO) strain = -comp/thick + if (thick > DZERO) strain = -comp / thick ! ! -- update void ratio, theta, and thickness - void = void + strain*(DONE + void) + void = void + strain * (DONE + void) theta = this%csub_calc_theta(void) thick = thick - comp ! @@ -5708,9 +5748,9 @@ end subroutine csub_adj_matprop subroutine csub_delay_sln(this, ib, hcell, update) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head in a cell - logical, intent(in), optional :: update !< optional logical variable indicating + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head in a cell + logical, intent(in), optional :: update !< optional logical variable indicating !! if the maximum head change variable !! in a delay bed should be updated ! -- local variables @@ -5722,7 +5762,7 @@ subroutine csub_delay_sln(this, ib, hcell, update) real(DP) :: dh real(DP) :: dhmax real(DP) :: dhmax0 - real(DP), parameter :: dclose = DHUNDRED*DPREC + real(DP), parameter :: dclose = DHUNDRED * DPREC ! ! -- initialize variables if (present(update)) then @@ -5751,9 +5791,9 @@ subroutine csub_delay_sln(this, ib, hcell, update) call this%csub_delay_assemble(ib, hcell) ! ! -- solve for head change in delay interbed cells - call csub_delay_solve(this%ndelaycells, & - this%dbal, this%dbad, this%dbau, & - this%dbrhs, this%dbdh, this%dbaw) + call ims_misc_thomas(this%ndelaycells, & + this%dbal, this%dbad, this%dbau, & + this%dbrhs, this%dbdh, this%dbaw) ! ! -- calculate maximum head change and update delay bed heads dhmax = DZERO @@ -5804,7 +5844,7 @@ end subroutine csub_delay_sln subroutine csub_delay_init_zcell(this, ib) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: ib !< interbed number ! -- local variables integer(I4B) :: n integer(I4B) :: node @@ -5830,8 +5870,8 @@ subroutine csub_delay_init_zcell(this, ib) ! -- calculate znode based on assumption that the delay bed bottom ! is equal to the cell bottom znode = this%csub_calc_znode(top, bot, hbar) - dz = DHALF*this%dbdzini(1, idelay) - dzz = DHALF*b + dz = DHALF * this%dbdzini(1, idelay) + dzz = DHALF * b z = znode + dzz zr = dzz ! @@ -5865,8 +5905,8 @@ end subroutine csub_delay_init_zcell subroutine csub_delay_calc_stress(this, ib, hcell) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head in a cell + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head in a cell ! -- local variables integer(I4B) :: n integer(I4B) :: idelay @@ -5891,7 +5931,7 @@ subroutine csub_delay_calc_stress(this, ib, hcell) sigma = this%cg_gs(node) topaq = this%dis%top(node) botaq = this%dis%bot(node) - dzhalf = DHALF*this%dbdzini(1, idelay) + dzhalf = DHALF * this%dbdzini(1, idelay) top = this%dbz(1, idelay) + dzhalf ! ! -- calculate corrected head (hbar) @@ -5901,9 +5941,9 @@ subroutine csub_delay_calc_stress(this, ib, hcell) sgm = this%sgm(node) sgs = this%sgs(node) if (hcell < top) then - sadd = ((top - hbar)*sgm) + ((hbar - botaq)*sgs) + sadd = ((top - hbar) * sgm) + ((hbar - botaq) * sgs) else - sadd = (top - botaq)*sgs + sadd = (top - botaq) * sgs end if sigma = sigma - sadd ! @@ -5921,9 +5961,9 @@ subroutine csub_delay_calc_stress(this, ib, hcell) ! ! -- geostatic stress calculation if (h < top) then - sadd = ((top - hbar)*sgm) + ((hbar - bot)*sgs) + sadd = ((top - hbar) * sgm) + ((hbar - bot) * sgs) else - sadd = (top - bot)*sgs + sadd = (top - bot) * sgs end if sigma = sigma + sadd phead = hbar - bot @@ -5948,11 +5988,11 @@ end subroutine csub_delay_calc_stress subroutine csub_delay_calc_ssksske(this, ib, n, hcell, ssk, sske) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: n !< delay interbed cell number - real(DP), intent(in) :: hcell !< current head in a cell - real(DP), intent(inout) :: ssk !< delay interbed skeletal specific storage - real(DP), intent(inout) :: sske !< delay interbed elastic skeletal specific storage + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: n !< delay interbed cell number + real(DP), intent(in) :: hcell !< current head in a cell + real(DP), intent(inout) :: ssk !< delay interbed skeletal specific storage + real(DP), intent(inout) :: sske !< delay interbed elastic skeletal specific storage ! -- local variables integer(I4B) :: idelay integer(I4B) :: ielastic @@ -6004,7 +6044,7 @@ subroutine csub_delay_calc_ssksske(this, ib, n, hcell, ssk, sske) ! ! -- set variables for delay interbed zcell calulations zcenter = zcell + this%dbrelz(n, idelay) - dzhalf = DHALF*this%dbdzini(1, idelay) + dzhalf = DHALF * this%dbdzini(1, idelay) top = zcenter + dzhalf bot = zcenter - dzhalf h = this%dbh(n, idelay) @@ -6030,12 +6070,12 @@ subroutine csub_delay_calc_ssksske(this, ib, n, hcell, ssk, sske) call this%csub_calc_sfacts(node, zbot, znode, theta, es, es0, f) end if this%idbconvert(n, idelay) = 0 - sske = f*this%rci(ib) - ssk = f*this%rci(ib) + sske = f * this%rci(ib) + ssk = f * this%rci(ib) if (ielastic == 0) then if (this%dbes(n, idelay) > this%dbpcs(n, idelay)) then this%idbconvert(n, idelay) = 1 - ssk = f*this%ci(ib) + ssk = f * this%ci(ib) end if end if ! @@ -6053,8 +6093,8 @@ end subroutine csub_delay_calc_ssksske subroutine csub_delay_assemble(this, ib, hcell) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head in a cell + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head in a cell ! -- local variables integer(I4B) :: n real(DP) :: aii @@ -6095,13 +6135,13 @@ subroutine csub_delay_assemble_fc(this, ib, n, hcell, aii, au, al, r) use TdisModule, only: delt ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: n !< delay interbed cell number - real(DP), intent(in) :: hcell !< current head in a cell - real(DP), intent(inout) :: aii !< diagonal in the A matrix - real(DP), intent(inout) :: au !< upper term in the A matrix - real(DP), intent(inout) :: al !< lower term in the A matrix - real(DP), intent(inout) :: r !< right-hand side term + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: n !< delay interbed cell number + real(DP), intent(in) :: hcell !< current head in a cell + real(DP), intent(inout) :: aii !< diagonal in the A matrix + real(DP), intent(inout) :: au !< upper term in the A matrix + real(DP), intent(inout) :: al !< lower term in the A matrix + real(DP), intent(inout) :: r !< right-hand side term ! -- local variables integer(I4B) :: node integer(I4B) :: idelay @@ -6145,11 +6185,11 @@ subroutine csub_delay_assemble_fc(this, ib, n, hcell, aii, au, al, r) ielastic = this%ielastic(ib) node = this%nodelist(ib) dzini = this%dbdzini(1, idelay) - dzhalf = DHALF*dzini - tled = DONE/delt - c = this%kv(ib)/dzini - c2 = DTWO*c - c3 = DTHREE*c + dzhalf = DHALF * dzini + tled = DONE / delt + c = this%kv(ib) / dzini + c2 = DTWO * c + c3 = DTHREE * c ! ! -- add qdb terms aii = aii - c2 @@ -6157,7 +6197,7 @@ subroutine csub_delay_assemble_fc(this, ib, n, hcell, aii, au, al, r) ! -- top or bottom cell if (n == 1 .or. n == this%ndelaycells) then aii = aii - c - r = r - c2*hcell + r = r - c2 * hcell end if ! ! -- lower qdb term @@ -6191,28 +6231,28 @@ subroutine csub_delay_assemble_fc(this, ib, n, hcell, aii, au, al, r) call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) ! ! -- calculate and add storage terms - smult = dzini*tled + smult = dzini * tled gs = this%dbgeo(n, idelay) es0 = this%dbes0(n, idelay) pcs = this%dbpcs(n, idelay) - aii = aii - smult*dsn*ssk + aii = aii - smult * dsn * ssk if (ielastic /= 0) then - r = r - smult* & - (dsn*ssk*(gs + zbot) - dsn0*sske*es0) + r = r - smult * & + (dsn * ssk * (gs + zbot) - dsn0 * sske * es0) else - r = r - smult* & - (dsn*ssk*(gs + zbot - pcs) + dsn0*sske*(pcs - es0)) + r = r - smult * & + (dsn * ssk * (gs + zbot - pcs) + dsn0 * sske * (pcs - es0)) end if ! ! -- add storage correction term - r = r + smult*dsn*ssk*(h - hbar) + r = r + smult * dsn * ssk * (h - hbar) ! ! -- add water compressibility terms - wcf = this%brg*tled - wc = dz*wcf*theta - wc0 = dz0*wcf*theta0 - aii = aii - dsn*wc - r = r - dsn0*wc0*h0 + wcf = this%brg * tled + wc = dz * wcf * theta + wc0 = dz0 * wcf * theta0 + aii = aii - dsn * wc + r = r - dsn0 * wc0 * h0 ! ! -- return return @@ -6230,13 +6270,13 @@ subroutine csub_delay_assemble_fn(this, ib, n, hcell, aii, au, al, r) use TdisModule, only: delt ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: n !< delay interbed cell number - real(DP), intent(in) :: hcell !< current head in a cell - real(DP), intent(inout) :: aii !< diagonal in the A matrix - real(DP), intent(inout) :: au !< upper term in the A matrix - real(DP), intent(inout) :: al !< lower term in the A matrix - real(DP), intent(inout) :: r !< right-hand side term + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: n !< delay interbed cell number + real(DP), intent(in) :: hcell !< current head in a cell + real(DP), intent(inout) :: aii !< diagonal in the A matrix + real(DP), intent(inout) :: au !< upper term in the A matrix + real(DP), intent(inout) :: al !< lower term in the A matrix + real(DP), intent(inout) :: r !< right-hand side term ! -- local variables integer(I4B) :: node integer(I4B) :: idelay @@ -6286,11 +6326,11 @@ subroutine csub_delay_assemble_fn(this, ib, n, hcell, aii, au, al, r) ielastic = this%ielastic(ib) node = this%nodelist(ib) dzini = this%dbdzini(1, idelay) - dzhalf = DHALF*dzini - tled = DONE/delt - c = this%kv(ib)/dzini - c2 = DTWO*c - c3 = DTHREE*c + dzhalf = DHALF * dzini + tled = DONE / delt + c = this%kv(ib) / dzini + c2 = DTWO * c + c3 = DTHREE * c ! ! -- add qdb terms aii = aii - c2 @@ -6298,7 +6338,7 @@ subroutine csub_delay_assemble_fn(this, ib, n, hcell, aii, au, al, r) ! -- top or bottom cell if (n == 1 .or. n == this%ndelaycells) then aii = aii - c - r = r - c2*hcell + r = r - c2 * hcell end if ! ! -- lower qdb term @@ -6338,97 +6378,55 @@ subroutine csub_delay_assemble_fn(this, ib, n, hcell, aii, au, al, r) call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) ! ! -- calculate storage terms - smult = dzini*tled + smult = dzini * tled gs = this%dbgeo(n, idelay) es0 = this%dbes0(n, idelay) pcs = this%dbpcs(n, idelay) if (ielastic /= 0) then - qsto = smult*(dsn*ssk*(gs - hbar + zbot) - dsn0*sske*es0) - stoderv = -smult*dsn*ssk*hbarderv + & - smult*ssk*(gs - hbar + zbot)*dsnderv + qsto = smult * (dsn * ssk * (gs - hbar + zbot) - dsn0 * sske * es0) + stoderv = -smult * dsn * ssk * hbarderv + & + smult * ssk * (gs - hbar + zbot) * dsnderv else - qsto = smult*(dsn*ssk*(gs - hbar + zbot - pcs) + & - dsn0*sske*(pcs - es0)) - stoderv = -smult*dsn*ssk*hbarderv + & - smult*ssk*(gs - hbar + zbot - pcs)*dsnderv + qsto = smult * (dsn * ssk * (gs - hbar + zbot - pcs) + & + dsn0 * sske * (pcs - es0)) + stoderv = -smult * dsn * ssk * hbarderv + & + smult * ssk * (gs - hbar + zbot - pcs) * dsnderv end if ! ! -- Add additional term if using lagged effective stress if (this%ieslag /= 0) then if (ielastic /= 0) then - stoderv = stoderv - smult*sske*es0*dsnderv + stoderv = stoderv - smult * sske * es0 * dsnderv else - stoderv = stoderv + smult*sske*(pcs - es0)*dsnderv + stoderv = stoderv + smult * sske * (pcs - es0) * dsnderv end if end if ! ! -- add newton-raphson storage terms aii = aii + stoderv - r = r - qsto + stoderv*h + r = r - qsto + stoderv * h ! ! -- add water compressibility terms - wcf = this%brg*tled - wc = dz*wcf*theta - wc0 = dz0*wcf*theta0 - qwc = dsn0*wc0*h0 - dsn*wc*h - wcderv = -dsn*wc - wc*h*dsnderv + wcf = this%brg * tled + wc = dz * wcf * theta + wc0 = dz0 * wcf * theta0 + qwc = dsn0 * wc0 * h0 - dsn * wc * h + wcderv = -dsn * wc - wc * h * dsnderv ! ! -- Add additional term if using lagged effective stress if (this%ieslag /= 0) then - wcderv = wcderv + wc0*h0*dsnderv + wcderv = wcderv + wc0 * h0 * dsnderv end if ! ! -- add newton-raphson water compressibility terms aii = aii + wcderv - r = r - qwc + wcderv*h + r = r - qwc + wcderv * h ! ! -- return return end subroutine csub_delay_assemble_fn - !> @brief Delay interbed linear solution - !! - !! Method to solve the tridiagonal linear equations for a delay interbed - !! using the Thomas algorithm. - !! - !< - subroutine csub_delay_solve(n, tl, td, tu, b, x, w) - ! -- dummy variables - integer(I4B), intent(in) :: n !< number of matrix rows - real(DP), dimension(n), intent(in) :: tl !< lower matrix terms - real(DP), dimension(n), intent(in) :: td !< diagonal matrix terms - real(DP), dimension(n), intent(in) :: tu !< upper matrix terms - real(DP), dimension(n), intent(in) :: b !< right-hand side vector - real(DP), dimension(n), intent(inout) :: x !< solution vectot - real(DP), dimension(n), intent(inout) :: w !< work vector - ! -- local variables - integer(I4B) :: j - real(DP) :: bet - real(DP) :: beti - ! - ! -- initialize variables - w(1) = DZERO - bet = td(1) - beti = DONE/bet - x(1) = b(1)*beti - ! - ! -- decomposition and forward substitution - do j = 2, n - w(j) = tu(j - 1)*beti - bet = td(j) - tl(j)*w(j) - beti = DONE/bet - x(j) = (b(j) - tl(j)*x(j - 1))*beti - end do - ! - ! -- backsubstitution - do j = n - 1, 1, -1 - x(j) = x(j) - w(j + 1)*x(j + 1) - end do - ! -- return - return - end subroutine csub_delay_solve - !> @brief Calculate delay interbed saturation !! !! Method to calculate the saturation in a delay interbed cell. @@ -6441,13 +6439,13 @@ subroutine csub_delay_calc_sat(this, node, idelay, n, hcell, hcellold, & snnew, snold) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - integer(I4B), intent(in) :: idelay !< delay interbed number - integer(I4B), intent(in) :: n !< delay interbed cell number - real(DP), intent(in) :: hcell !< current head in delay interbed cell n - real(DP), intent(in) :: hcellold !< previous head in delay interbed cell n - real(DP), intent(inout) :: snnew !< current saturation in delay interbed cell n - real(DP), intent(inout) :: snold !< previous saturation in delay interbed cell n + integer(I4B), intent(in) :: node !< cell node number + integer(I4B), intent(in) :: idelay !< delay interbed number + integer(I4B), intent(in) :: n !< delay interbed cell number + real(DP), intent(in) :: hcell !< current head in delay interbed cell n + real(DP), intent(in) :: hcellold !< previous head in delay interbed cell n + real(DP), intent(inout) :: snnew !< current saturation in delay interbed cell n + real(DP), intent(inout) :: snold !< previous saturation in delay interbed cell n ! -- local variables real(DP) :: dzhalf real(DP) :: top @@ -6455,7 +6453,7 @@ subroutine csub_delay_calc_sat(this, node, idelay, n, hcell, hcellold, & ! ! -- calculate delay interbed cell saturation if (this%stoiconv(node) /= 0) then - dzhalf = DHALF*this%dbdzini(n, idelay) + dzhalf = DHALF * this%dbdzini(n, idelay) top = this%dbz(n, idelay) + dzhalf bot = this%dbz(n, idelay) - dzhalf snnew = sQuadraticSaturation(top, bot, hcell, this%satomega) @@ -6483,10 +6481,10 @@ function csub_delay_calc_sat_derivative(this, node, idelay, n, hcell) & result(satderv) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: node !< cell node number - integer(I4B), intent(in) :: idelay !< delay interbed number - integer(I4B), intent(in) :: n !< delay interbed cell number - real(DP), intent(in) :: hcell !< current head in delay interbed cell n + integer(I4B), intent(in) :: node !< cell node number + integer(I4B), intent(in) :: idelay !< delay interbed number + integer(I4B), intent(in) :: n !< delay interbed cell number + real(DP), intent(in) :: hcell !< current head in delay interbed cell n ! -- local variables real(DP) :: satderv real(DP) :: dzhalf @@ -6494,7 +6492,7 @@ function csub_delay_calc_sat_derivative(this, node, idelay, n, hcell) & real(DP) :: bot ! ------------------------------------------------------------------------------ if (this%stoiconv(node) /= 0) then - dzhalf = DHALF*this%dbdzini(n, idelay) + dzhalf = DHALF * this%dbdzini(n, idelay) top = this%dbz(n, idelay) + dzhalf bot = this%dbz(n, idelay) - dzhalf satderv = sQuadraticSaturationDerivative(top, bot, hcell, this%satomega) @@ -6517,10 +6515,10 @@ end function csub_delay_calc_sat_derivative subroutine csub_delay_calc_dstor(this, ib, hcell, stoe, stoi) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(inout) :: stoe !< elastic storage change - real(DP), intent(inout) :: stoi !< inelastic storage change + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(inout) :: stoe !< elastic storage change + real(DP), intent(inout) :: stoi !< inelastic storage change ! -- local variables integer(I4B) :: idelay integer(I4B) :: ielastic @@ -6554,7 +6552,7 @@ subroutine csub_delay_calc_dstor(this, ib, hcell, stoe, stoi) ! if (this%thickini(ib) > DZERO) then fmult = this%dbdzini(1, idelay) - dzhalf = DHALF*this%dbdzini(1, idelay) + dzhalf = DHALF * this%dbdzini(1, idelay) do n = 1, this%ndelaycells call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) z = this%dbz(n, idelay) @@ -6564,26 +6562,26 @@ subroutine csub_delay_calc_dstor(this, ib, hcell, stoe, stoi) call this%csub_delay_calc_sat(node, idelay, n, h, h0, dsn, dsn0) hbar = sQuadratic0sp(h, zbot, this%satomega) if (ielastic /= 0) then - v1 = dsn*ssk*(this%dbgeo(n, idelay) - hbar + zbot) - & - dsn0*sske*this%dbes0(n, idelay) + v1 = dsn * ssk * (this%dbgeo(n, idelay) - hbar + zbot) - & + dsn0 * sske * this%dbes0(n, idelay) v2 = DZERO else - v1 = dsn*ssk*(this%dbgeo(n, idelay) - hbar + zbot - & - this%dbpcs(n, idelay)) - v2 = dsn0*sske*(this%dbpcs(n, idelay) - this%dbes0(n, idelay)) + v1 = dsn * ssk * (this%dbgeo(n, idelay) - hbar + zbot - & + this%dbpcs(n, idelay)) + v2 = dsn0 * sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay)) end if ! ! -- calculate inelastic and elastic storage components if (this%idbconvert(n, idelay) /= 0) then - stoi = stoi + v1*fmult - stoe = stoe + v2*fmult + stoi = stoi + v1 * fmult + stoe = stoe + v2 * fmult else - stoe = stoe + (v1 + v2)*fmult + stoe = stoe + (v1 + v2) * fmult end if ! ! calculate inelastic and elastic storativity - ske = ske + sske*fmult - sk = sk + ssk*fmult + ske = ske + sske * fmult + sk = sk + ssk * fmult end do end if ! @@ -6607,8 +6605,8 @@ subroutine csub_delay_calc_wcomp(this, ib, dwc) use TdisModule, only: delt ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(inout) :: dwc !< water compressibility change + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(inout) :: dwc !< water compressibility change ! -- local variables integer(I4B) :: idelay integer(I4B) :: node @@ -6631,17 +6629,17 @@ subroutine csub_delay_calc_wcomp(this, ib, dwc) if (this%thickini(ib) > DZERO) then idelay = this%idelay(ib) node = this%nodelist(ib) - tled = DONE/delt + tled = DONE / delt do n = 1, this%ndelaycells h = this%dbh(n, idelay) h0 = this%dbh0(n, idelay) dz = this%dbdz(n, idelay) dz0 = this%dbdz0(n, idelay) call this%csub_delay_calc_sat(node, idelay, n, h, h0, dsn, dsn0) - wc = dz*this%brg*this%dbtheta(n, idelay) - wc0 = dz0*this%brg*this%dbtheta0(n, idelay) - v = dsn0*wc0*h0 - dsn*wc*h - dwc = dwc + v*tled + wc = dz * this%brg * this%dbtheta(n, idelay) + wc0 = dz0 * this%brg * this%dbtheta0(n, idelay) + v = dsn0 * wc0 * h0 - dsn * wc * h + dwc = dwc + v * tled end do end if ! @@ -6661,12 +6659,12 @@ end subroutine csub_delay_calc_wcomp subroutine csub_delay_calc_comp(this, ib, hcell, hcellold, comp, compi, compe) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(in) :: hcell !< current head in cell - real(DP), intent(in) :: hcellold !< previous head in cell - real(DP), intent(inout) :: comp !< compaction in delay interbed - real(DP), intent(inout) :: compi !< inelastic compaction in delay interbed - real(DP), intent(inout) :: compe !< elastic compaction in delay interbed + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(in) :: hcell !< current head in cell + real(DP), intent(in) :: hcellold !< previous head in cell + real(DP), intent(inout) :: comp !< compaction in delay interbed + real(DP), intent(inout) :: compi !< inelastic compaction in delay interbed + real(DP), intent(inout) :: compe !< elastic compaction in delay interbed ! -- local variables integer(I4B) :: idelay integer(I4B) :: ielastic @@ -6705,32 +6703,32 @@ subroutine csub_delay_calc_comp(this, ib, hcell, hcellold, comp, compi, compe) call this%csub_delay_calc_sat(node, idelay, n, h, h0, dsn, dsn0) call this%csub_delay_calc_ssksske(ib, n, hcell, ssk, sske) if (ielastic /= 0) then - v1 = dsn*ssk*this%dbes(n, idelay) - sske*this%dbes0(n, idelay) + v1 = dsn * ssk * this%dbes(n, idelay) - sske * this%dbes0(n, idelay) v2 = DZERO else - v1 = dsn*ssk*(this%dbes(n, idelay) - this%dbpcs(n, idelay)) - v2 = dsn0*sske*(this%dbpcs(n, idelay) - this%dbes0(n, idelay)) + v1 = dsn * ssk * (this%dbes(n, idelay) - this%dbpcs(n, idelay)) + v2 = dsn0 * sske * (this%dbpcs(n, idelay) - this%dbes0(n, idelay)) end if - v = (v1 + v2)*fmult + v = (v1 + v2) * fmult comp = comp + v ! ! -- save compaction data - this%dbcomp(n, idelay) = v*snnew + this%dbcomp(n, idelay) = v * snnew ! ! -- calculate inelastic and elastic storage components if (this%idbconvert(n, idelay) /= 0) then - compi = compi + v1*fmult - compe = compe + v2*fmult + compi = compi + v1 * fmult + compe = compe + v2 * fmult else - compe = compe + (v1 + v2)*fmult + compe = compe + (v1 + v2) * fmult end if end do end if ! ! -- fill compaction - comp = comp*this%rnb(ib) - compi = compi*this%rnb(ib) - compe = compe*this%rnb(ib) + comp = comp * this%rnb(ib) + compi = compi * this%rnb(ib) + compe = compe * this%rnb(ib) ! ! -- return return @@ -6744,7 +6742,7 @@ end subroutine csub_delay_calc_comp subroutine csub_delay_update(this, ib) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: ib !< interbed number ! -- local variables integer(I4B) :: idelay integer(I4B) :: n @@ -6768,7 +6766,7 @@ subroutine csub_delay_update(this, ib) ! ! -- scale compaction by rnb to get the compaction for ! the interbed system (as opposed to the full system) - comp = comp/this%rnb(ib) + comp = comp / this%rnb(ib) ! ! -- update thickness and theta if (ABS(comp) > DZERO) then @@ -6790,19 +6788,19 @@ subroutine csub_delay_update(this, ib) this%dbdz(n, idelay) = thick this%dbtheta(n, idelay) = theta tthick = tthick + thick - wtheta = wtheta + thick*theta + wtheta = wtheta + thick * theta else thick = this%dbdz(n, idelay) theta = this%dbtheta(n, idelay) tthick = tthick + thick - wtheta = wtheta + thick*theta + wtheta = wtheta + thick * theta end if end do ! ! -- calculate thickness weighted theta and save thickness and weighted ! theta values for delay interbed if (tthick > DZERO) then - wtheta = wtheta/tthick + wtheta = wtheta / tthick else tthick = DZERO wtheta = DZERO @@ -6827,9 +6825,9 @@ end subroutine csub_delay_update subroutine csub_delay_fc(this, ib, hcof, rhs) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - real(DP), intent(inout) :: hcof !< head dependent coefficient - real(DP), intent(inout) :: rhs !< right-hand side + integer(I4B), intent(in) :: ib !< interbed number + real(DP), intent(inout) :: hcof !< head dependent coefficient + real(DP), intent(inout) :: rhs !< right-hand side ! -- local variables integer(I4B) :: idelay real(DP) :: c1 @@ -6841,11 +6839,11 @@ subroutine csub_delay_fc(this, ib, hcof, rhs) rhs = DZERO if (this%thickini(ib) > DZERO) then ! -- calculate terms for gwf matrix - c1 = DTWO*this%kv(ib)/this%dbdzini(1, idelay) - rhs = -c1*this%dbh(1, idelay) - c2 = DTWO* & - this%kv(ib)/this%dbdzini(this%ndelaycells, idelay) - rhs = rhs - c2*this%dbh(this%ndelaycells, idelay) + c1 = DTWO * this%kv(ib) / this%dbdzini(1, idelay) + rhs = -c1 * this%dbh(1, idelay) + c2 = DTWO * & + this%kv(ib) / this%dbdzini(this%ndelaycells, idelay) + rhs = rhs - c2 * this%dbh(this%ndelaycells, idelay) hcof = c1 + c2 end if ! @@ -6863,9 +6861,9 @@ end subroutine csub_delay_fc function csub_calc_delay_flow(this, ib, n, hcell) result(q) ! -- dummy variables class(GwfCsubType), intent(inout) :: this - integer(I4B), intent(in) :: ib !< interbed number - integer(I4B), intent(in) :: n !< delay interbed cell - real(DP), intent(in) :: hcell !< current head in cell + integer(I4B), intent(in) :: ib !< interbed number + integer(I4B), intent(in) :: n !< delay interbed cell + real(DP), intent(in) :: hcell !< current head in cell ! -- local variables integer(I4B) :: idelay real(DP) :: q @@ -6873,8 +6871,8 @@ function csub_calc_delay_flow(this, ib, n, hcell) result(q) ! ! -- calculate flow between delay interbed and GWF idelay = this%idelay(ib) - c = DTWO*this%kv(ib)/this%dbdzini(n, idelay) - q = c*(hcell - this%dbh(n, idelay)) + c = DTWO * this%kv(ib) / this%dbdzini(n, idelay) + q = c * (hcell - this%dbh(n, idelay)) ! ! -- return return @@ -7154,8 +7152,8 @@ subroutine csub_bd_obs(this) case ('DELAY-HEAD', 'DELAY-PRECONSTRESS', & 'DELAY-GSTRESS', 'DELAY-ESTRESS') if (n > this%ndelaycells) then - r = real(n - 1, DP)/real(this%ndelaycells, DP) - idelay = int(floor(r)) + 1 + r = real(n - 1, DP) / real(this%ndelaycells, DP) + idelay = int(floor(r)) + 1 ncol = n - int(floor(r)) * this%ndelaycells else idelay = 1 @@ -7212,12 +7210,12 @@ subroutine csub_bd_obs(this) ! ! -- add the coarse component if (j == 1) then - f = this%cg_thick(n)/this%cell_thick(n) - v = f*this%cg_theta(n) + f = this%cg_thick(n) / this%cell_thick(n) + v = f * this%cg_theta(n) else node = this%nodelist(n) - f = this%csub_calc_interbed_thickness(n)/this%cell_thick(node) - v = f*this%theta(n) + f = this%csub_calc_interbed_thickness(n) / this%cell_thick(node) + v = f * this%theta(n) end if case ('GSTRESS-CELL') v = this%cg_gs(n) @@ -7257,7 +7255,7 @@ subroutine csub_bd_obs(this) idelay = this%idelay(n) v = this%thick(n) if (idelay /= 0) then - v = v*this%rnb(n) + v = v * this%rnb(n) end if case ('COARSE-THICKNESS') v = this%cg_thick(n) @@ -7266,7 +7264,7 @@ subroutine csub_bd_obs(this) case ('DELAY-COMPACTION', 'DELAY-THICKNESS', & 'DELAY-THETA') if (n > this%ndelaycells) then - r = real(n, DP)/real(this%ndelaycells, DP) + r = real(n, DP) / real(this%ndelaycells, DP) idelay = int(floor(r)) + 1 ncol = mod(n, this%ndelaycells) else @@ -7380,7 +7378,7 @@ subroutine csub_rp_obs(this) n = obsrv%NodeNumber idelay = this%idelay(n) if (idelay /= 0) then - j = (idelay - 1)*this%ndelaycells + 1 + j = (idelay - 1) * this%ndelaycells + 1 n2 = obsrv%NodeNumber2 if (n2 < 1 .or. n2 > this%ndelaycells) then write (errmsg, '(a,2(1x,a),1x,i0,1x,a,i0,a)') & @@ -7389,7 +7387,7 @@ subroutine csub_rp_obs(this) '(specified value is ', n2, ').' call store_error(errmsg) else - j = (idelay - 1)*this%ndelaycells + n2 + j = (idelay - 1) * this%ndelaycells + n2 end if obsrv%BndFound = .true. call obsrv%AddObsIndex(j) @@ -7427,7 +7425,8 @@ subroutine csub_rp_obs(this) j = obsrv%NodeNumber if (j < 1 .or. j > this%ninterbeds) then write (errmsg, '(a,2(1x,a),1x,i0,1x,a,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), 'interbed cell must be greater ', & + trim(adjustl(obsrv%ObsTypeId)), & + 'interbed cell must be greater ', & 'than 0 and less than or equal to', this%ninterbeds, & '(specified value is ', j, ').' call store_error(errmsg) @@ -7488,10 +7487,10 @@ end subroutine csub_rp_obs !< subroutine csub_process_obsID(obsrv, dis, inunitobs, iout) ! -- dummy variables - type(ObserveType), intent(inout) :: obsrv !< observation type - class(DisBaseType), intent(in) :: dis !< pointer to the model discretization - integer(I4B), intent(in) :: inunitobs !< unit number of the observation file - integer(I4B), intent(in) :: iout !< unit number to the model listing file + type(ObserveType), intent(inout) :: obsrv !< observation type + class(DisBaseType), intent(in) :: dis !< pointer to the model discretization + integer(I4B), intent(in) :: inunitobs !< unit number of the observation file + integer(I4B), intent(in) :: iout !< unit number to the model listing file ! -- local variables integer(I4B) :: nn1 integer(I4B) :: nn2 diff --git a/src/Model/GroundWaterFlow/gwf3dis8.f90 b/src/Model/GroundWaterFlow/gwf3dis8.f90 index 499b951df30..52b5ab20907 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8.f90 @@ -9,24 +9,24 @@ module GwfDisModule use SimModule, only: count_errors, store_error, store_error_unit use BlockParserModule, only: BlockParserType use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt + use TdisModule, only: kstp, kper, pertim, totim, delt implicit none private public dis_cr, dis_init_mem, GwfDisType type, extends(DisBaseType) :: GwfDisType - integer(I4B), pointer :: nlay => null() ! number of layers - integer(I4B), pointer :: nrow => null() ! number of rows - integer(I4B), pointer :: ncol => null() ! number of columns - real(DP), dimension(:), pointer, contiguous :: delr => null() ! spacing along a row - real(DP), dimension(:), pointer, contiguous :: delc => null() ! spacing along a column - real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncol, nrow) - real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncol, nrow, nlay) - integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncol, nrow, nlay) - real(DP), dimension(:, :, :), pointer :: botm => null() ! top and bottom elevations for each cell (ncol, nrow, nlay) - real(DP), dimension(:), pointer, contiguous :: cellx => null() ! cell center x coordinate for column j - real(DP), dimension(:), pointer, contiguous :: celly => null() ! cell center y coordinate for row i + integer(I4B), pointer :: nlay => null() ! number of layers + integer(I4B), pointer :: nrow => null() ! number of rows + integer(I4B), pointer :: ncol => null() ! number of columns + real(DP), dimension(:), pointer, contiguous :: delr => null() ! spacing along a row + real(DP), dimension(:), pointer, contiguous :: delc => null() ! spacing along a column + real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncol, nrow) + real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncol, nrow, nlay) + integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncol, nrow, nlay) + real(DP), dimension(:, :, :), pointer :: botm => null() ! top and bottom elevations for each cell (ncol, nrow, nlay) + real(DP), dimension(:), pointer, contiguous :: cellx => null() ! cell center x coordinate for column j + real(DP), dimension(:), pointer, contiguous :: celly => null() ! cell center y coordinate for row i contains procedure :: dis_df => dis3d_df procedure :: dis_da => dis3d_da @@ -61,7 +61,7 @@ module GwfDisModule procedure :: read_dbl_array end type GwfDisType - contains +contains subroutine dis_cr(dis, name_model, inunit, iout) ! ****************************************************************************** @@ -76,7 +76,7 @@ subroutine dis_cr(dis, name_model, inunit, iout) integer(I4B), intent(in) :: iout type(GwfDisType), pointer :: disnew ! ------------------------------------------------------------------------------ - allocate(disnew) + allocate (disnew) dis => disnew call disnew%allocate_scalars(name_model) dis%inunit = inunit @@ -88,8 +88,8 @@ subroutine dis_cr(dis, name_model, inunit, iout) ! -- Return return end subroutine dis_cr - - subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & + + subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & delr, delc, top2d, bot3d, idomain) ! ****************************************************************************** ! dis_init_mem -- Create a new discretization 3d object from memory @@ -107,7 +107,7 @@ subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & real(DP), dimension(:), pointer, contiguous, intent(in) :: delc real(DP), dimension(:, :), pointer, contiguous, intent(in) :: top2d real(DP), dimension(:, :, :), pointer, contiguous, intent(in) :: bot3d - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & optional :: idomain ! -- local type(GwfDisType), pointer :: disext @@ -117,7 +117,7 @@ subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & integer(I4B) :: ival ! -- local ! ------------------------------------------------------------------------------ - allocate(disext) + allocate (disext) dis => disext call disext%allocate_scalars(name_model) dis%inunit = 0 @@ -134,11 +134,11 @@ subroutine dis_init_mem(dis, name_model, iout, nlay, nrow, ncol, & ! -- Allocate delr, delc, and non-reduced vectors for dis call mem_allocate(disext%delr, disext%ncol, 'DELR', disext%memoryPath) call mem_allocate(disext%delc, disext%nrow, 'DELC', disext%memoryPath) - call mem_allocate(disext%idomain, disext%ncol, disext%nrow, disext%nlay, & - 'IDOMAIN',disext%memoryPath) - call mem_allocate(disext%top2d, disext%ncol, disext%nrow, 'TOP2D', & + call mem_allocate(disext%idomain, disext%ncol, disext%nrow, disext%nlay, & + 'IDOMAIN', disext%memoryPath) + call mem_allocate(disext%top2d, disext%ncol, disext%nrow, 'TOP2D', & disext%memoryPath) - call mem_allocate(disext%bot3d, disext%ncol, disext%nrow, disext%nlay, & + call mem_allocate(disext%bot3d, disext%ncol, disext%nrow, disext%nlay, & 'BOT3D', disext%memoryPath) ! -- fill data do i = 1, disext%nrow @@ -186,9 +186,9 @@ subroutine dis3d_df(this) if (this%inunit /= 0) then ! ! -- Identify package - write(this%iout,1) this%inunit -1 format(1X,/1X,'DIS -- STRUCTURED GRID DISCRETIZATION PACKAGE,', & - ' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ',I0,//) + write (this%iout, 1) this%inunit +1 format(1X, /1X, 'DIS -- STRUCTURED GRID DISCRETIZATION PACKAGE,', & + ' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ', I0, //) ! ! -- Read options call this%read_options() @@ -270,54 +270,56 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING DISCRETIZATION OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('LENGTH_UNITS') - call this%parser%GetStringCaps(keyword) - if(keyword == 'FEET') then - this%lenuni = 1 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS FEET' - elseif(keyword == 'METERS') then - this%lenuni = 2 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS METERS' - elseif(keyword == 'CENTIMETERS') then - this%lenuni = 3 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' - else - write(this%iout,'(4x,a)')'UNKNOWN UNIT: ',trim(keyword) - write(this%iout,'(4x,a)')'SETTING TO: ','UNDEFINED' - endif - case('NOGRB') - write(this%iout,'(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' - this%writegrb = .false. - case('XORIGIN') - this%xorigin = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & - this%xorigin - case('YORIGIN') - this%yorigin = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & - this%yorigin - case('ANGROT') - this%angrot = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & - this%angrot - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN DIS OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('LENGTH_UNITS') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FEET') then + this%lenuni = 1 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS FEET' + elseif (keyword == 'METERS') then + this%lenuni = 2 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS METERS' + elseif (keyword == 'CENTIMETERS') then + this%lenuni = 3 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' + else + write (this%iout, '(4x,a)') 'UNKNOWN UNIT: ', trim(keyword) + write (this%iout, '(4x,a)') 'SETTING TO: ', 'UNDEFINED' + end if + case ('NOGRB') + write (this%iout, '(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' + this%writegrb = .false. + case ('XORIGIN') + this%xorigin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & + this%xorigin + case ('YORIGIN') + this%yorigin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & + this%yorigin + case ('ANGROT') + this%angrot = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & + this%angrot + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN DIS OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' + write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' else - write(this%iout,'(1x,a)')'NO OPTION BLOCK DETECTED.' + write (this%iout, '(1x,a)') 'NO OPTION BLOCK DETECTED.' + end if + if (this%lenuni == 0) then + write (this%iout, '(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' end if - if(this%lenuni==0) write(this%iout,'(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' ! ! -- Return return @@ -330,7 +332,7 @@ subroutine read_dimensions(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfDisType) :: this ! -- locals @@ -346,50 +348,50 @@ subroutine read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING DISCRETIZATION DIMENSIONS' + write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit + if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NLAY') - this%nlay = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NLAY = ', this%nlay - case ('NROW') - this%nrow = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NROW = ', this%nrow - case ('NCOL') - this%ncol = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NCOL = ', this%ncol - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN DIS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('NLAY') + this%nlay = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NLAY = ', this%nlay + case ('NROW') + this%nrow = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NROW = ', this%nrow + case ('NCOL') + this%ncol = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NCOL = ', this%ncol + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN DIS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF DISCRETIZATION DIMENSIONS' + write (this%iout, '(1x,a)') 'END OF DISCRETIZATION DIMENSIONS' else call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() end if ! ! -- verify dimensions were set - if(this%nlay < 1) then + if (this%nlay < 1) then call store_error( & - 'ERROR. NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + 'ERROR. NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() - endif - if(this%nrow < 1) then + end if + if (this%nrow < 1) then call store_error( & - 'ERROR. NROW WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + 'ERROR. NROW WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() - endif - if(this%ncol < 1) then + end if + if (this%ncol < 1) then call store_error( & - 'ERROR. NCOL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + 'ERROR. NCOL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- calculate nodesuser this%nodesuser = this%nlay * this%nrow * this%ncol @@ -397,10 +399,10 @@ subroutine read_dimensions(this) ! -- Allocate delr, delc, and non-reduced vectors for dis call mem_allocate(this%delr, this%ncol, 'DELR', this%memoryPath) call mem_allocate(this%delc, this%nrow, 'DELC', this%memoryPath) - call mem_allocate(this%idomain, this%ncol, this%nrow, this%nlay, 'IDOMAIN', & + call mem_allocate(this%idomain, this%ncol, this%nrow, this%nlay, 'IDOMAIN', & this%memoryPath) call mem_allocate(this%top2d, this%ncol, this%nrow, 'TOP2D', this%memoryPath) - call mem_allocate(this%bot3d, this%ncol, this%nrow, this%nlay, 'BOT3D', & + call mem_allocate(this%bot3d, this%ncol, this%nrow, this%nlay, 'BOT3D', & this%memoryPath) call mem_allocate(this%cellx, this%ncol, 'CELLX', this%memoryPath) call mem_allocate(this%celly, this%nrow, 'CELLY', this%memoryPath) @@ -427,7 +429,7 @@ subroutine read_mf6_griddata(this) ! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, DZERO use MemoryManagerModule, only: mem_allocate ! -- dummy class(GwfDisType) :: this @@ -439,15 +441,15 @@ subroutine read_mf6_griddata(this) logical :: isfound, endOfBlock integer(I4B), parameter :: nname = 5 logical, dimension(nname) :: lname - character(len=24),dimension(nname) :: aname + character(len=24), dimension(nname) :: aname character(len=300) :: ermsg ! -- formats ! -- data - data aname(1) /' DELR'/ - data aname(2) /' DELC'/ - data aname(3) /'TOP ELEVATION OF LAYER 1'/ - data aname(4) /' MODEL LAYER BOTTOM EL.'/ - data aname(5) /' IDOMAIN'/ + data aname(1)/' DELR'/ + data aname(2)/' DELC'/ + data aname(3)/'TOP ELEVATION OF LAYER 1'/ + data aname(4)/' MODEL LAYER BOTTOM EL.'/ + data aname(5)/' IDOMAIN'/ ! ------------------------------------------------------------------------------ do n = 1, size(aname) lname(n) = .false. @@ -456,56 +458,56 @@ subroutine read_mf6_griddata(this) ! -- Read GRIDDATA block call this%parser%GetBlock('GRIDDATA', isfound, ierr) lname(:) = .false. - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('DELR') - call ReadArray(this%parser%iuactive, this%delr, aname(1), & - this%ndim, this%ncol, this%iout, 0) - lname(1) = .true. - case ('DELC') - call ReadArray(this%parser%iuactive, this%delc, aname(2), & - this%ndim, this%nrow, this%iout, 0) - lname(2) = .true. - case ('TOP') - call ReadArray(this%parser%iuactive, this%top2d(:,:), aname(3), & - this%ndim, this%ncol, this%nrow, this%iout, 0) - lname(3) = .true. - case ('BOTM') - call this%parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - call ReadArray(this%parser%iuactive, this%bot3d(:,:,:), & - aname(4), this%ndim, this%ncol, this%nrow, & - this%nlay, this%iout, 1, this%nlay) - else - nvals = this%ncol * this%nrow * this%nlay - call ReadArray(this%parser%iuactive, this%bot3d(:,:,:), & - aname(4), this%ndim, nvals, this%iout) - end if - lname(4) = .true. - case ('IDOMAIN') - call this%parser%GetStringCaps(keyword) - if (keyword .EQ. 'LAYERED') then - call ReadArray(this%parser%iuactive, this%idomain, aname(5), & - this%ndim, this%ncol, this%nrow, this%nlay, & - this%iout, 1, this%nlay) - else - call ReadArray(this%parser%iuactive, this%idomain, aname(5), & - this%ndim, this%nodesuser, 1, 1, this%iout, 0, 0) - end if - lname(5) = .true. - case default - write(ermsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() + case ('DELR') + call ReadArray(this%parser%iuactive, this%delr, aname(1), & + this%ndim, this%ncol, this%iout, 0) + lname(1) = .true. + case ('DELC') + call ReadArray(this%parser%iuactive, this%delc, aname(2), & + this%ndim, this%nrow, this%iout, 0) + lname(2) = .true. + case ('TOP') + call ReadArray(this%parser%iuactive, this%top2d(:, :), aname(3), & + this%ndim, this%ncol, this%nrow, this%iout, 0) + lname(3) = .true. + case ('BOTM') + call this%parser%GetStringCaps(keyword) + if (keyword .EQ. 'LAYERED') then + call ReadArray(this%parser%iuactive, this%bot3d(:, :, :), & + aname(4), this%ndim, this%ncol, this%nrow, & + this%nlay, this%iout, 1, this%nlay) + else + nvals = this%ncol * this%nrow * this%nlay + call ReadArray(this%parser%iuactive, this%bot3d(:, :, :), & + aname(4), this%ndim, nvals, this%iout) + end if + lname(4) = .true. + case ('IDOMAIN') + call this%parser%GetStringCaps(keyword) + if (keyword .EQ. 'LAYERED') then + call ReadArray(this%parser%iuactive, this%idomain, aname(5), & + this%ndim, this%ncol, this%nrow, this%nlay, & + this%iout, 1, this%nlay) + else + call ReadArray(this%parser%iuactive, this%idomain, aname(5), & + this%ndim, this%nodesuser, 1, 1, this%iout, 0, 0) + end if + lname(5) = .true. + case default + write (ermsg, '(4x,a,a)') 'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(ermsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() @@ -513,20 +515,20 @@ subroutine read_mf6_griddata(this) ! ! -- Verify all required items were read (IDOMAIN not required) do n = 1, nname - 1 - if(.not. lname(n)) then - write(ermsg,'(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ',aname(n) + if (.not. lname(n)) then + write (ermsg, '(1x,a,a)') & + 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) call store_error(ermsg) - endif - enddo + end if + end do if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return end subroutine read_mf6_griddata - + subroutine grid_finalize(this) ! ****************************************************************************** ! grid_finalize -- Finalize grid @@ -536,7 +538,7 @@ subroutine grid_finalize(this) ! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, DZERO use MemoryManagerModule, only: mem_allocate ! -- dummy class(GwfDisType) :: this @@ -550,12 +552,12 @@ subroutine grid_finalize(this) real(DP) :: dz ! -- formats character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',i0,',',i0,') THICKNESS <= 0. ', " // & - "'TOP, BOT: ',2(1pg24.15))" + "('ERROR. CELL (',i0,',',i0,',',i0,') THICKNESS <= 0. ', & + &'TOP, BOT: ',2(1pg24.15))" character(len=*), parameter :: fmtnr = & - "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.'," // & - "/1x, 'NUMBER OF USER NODES: ',I0," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" + "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.',& + &/1x, 'NUMBER OF USER NODES: ',I0,& + &/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" ! ------------------------------------------------------------------------------ ! ! -- count active cells @@ -563,10 +565,10 @@ subroutine grid_finalize(this) do k = 1, this%nlay do i = 1, this%nrow do j = 1, this%ncol - if(this%idomain(j, i, k) > 0) this%nodes = this%nodes + 1 - enddo - enddo - enddo + if (this%idomain(j, i, k) > 0) this%nodes = this%nodes + 1 + end do + end do + end do ! ! -- Check to make sure nodes is a valid number if (this%nodes == 0) then @@ -590,20 +592,20 @@ subroutine grid_finalize(this) dz = top - this%bot3d(j, i, k) if (dz <= DZERO) then n = n + 1 - write(ermsg, fmt=fmtdz) k, i, j, top, this%bot3d(j, i, k) + write (ermsg, fmt=fmtdz) k, i, j, top, this%bot3d(j, i, k) call store_error(ermsg) - endif - enddo - enddo - enddo + end if + end do + end do + end do if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Write message if reduced grid - if(this%nodes < this%nodesuser) then - write(this%iout, fmtnr) this%nodesuser, this%nodes - endif + if (this%nodes < this%nodesuser) then + write (this%iout, fmtnr) this%nodesuser, this%nodes + end if ! ! -- Array size is now known, so allocate call this%allocate_arrays() @@ -612,52 +614,52 @@ subroutine grid_finalize(this) ! a negative number to indicate it is a pass-through cell, or ! a zero to indicate that the cell is excluded from the ! solution. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then node = 1 noder = 1 do k = 1, this%nlay do i = 1, this%nrow do j = 1, this%ncol - if(this%idomain(j, i, k) > 0) then + if (this%idomain(j, i, k) > 0) then this%nodereduced(node) = noder noder = noder + 1 - elseif(this%idomain(j, i, k) < 0) then + elseif (this%idomain(j, i, k) < 0) then this%nodereduced(node) = -1 else this%nodereduced(node) = 0 - endif + end if node = node + 1 - enddo - enddo - enddo - endif + end do + end do + end do + end if ! ! -- allocate and fill nodeuser if a reduced grid - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then node = 1 noder = 1 do k = 1, this%nlay do i = 1, this%nrow do j = 1, this%ncol - if(this%idomain(j, i, k) > 0) then + if (this%idomain(j, i, k) > 0) then this%nodeuser(noder) = node noder = noder + 1 - endif + end if node = node + 1 - enddo - enddo - enddo - endif + end do + end do + end do + end if ! ! -- Move top2d and botm3d into top and bot, and calculate area node = 0 - do k=1,this%nlay - do i=1,this%nrow - do j=1,this%ncol + do k = 1, this%nlay + do i = 1, this%nrow + do j = 1, this%ncol node = node + 1 noder = node - if(this%nodes < this%nodesuser) noder = this%nodereduced(node) - if(noder <= 0) cycle + if (this%nodes < this%nodesuser) noder = this%nodereduced(node) + if (noder <= 0) cycle if (k > 1) then top = this%bot3d(j, i, k - 1) else @@ -666,29 +668,31 @@ subroutine grid_finalize(this) this%top(noder) = top this%bot(noder) = this%bot3d(j, i, k) this%area(noder) = this%delr(j) * this%delc(i) - enddo - enddo - enddo + end do + end do + end do ! ! -- fill x,y coordinate arrays - this%cellx(1) = DHALF*this%delr(1) - this%celly(this%nrow) = DHALF*this%delc(this%nrow) + this%cellx(1) = DHALF * this%delr(1) + this%celly(this%nrow) = DHALF * this%delc(this%nrow) do j = 2, this%ncol - this%cellx(j) = this%cellx(j-1) + DHALF*this%delr(j-1) + DHALF*this%delr(j) - enddo + this%cellx(j) = this%cellx(j - 1) + DHALF * this%delr(j - 1) + & + DHALF * this%delr(j) + end do ! -- row number increases in negative y direction: - do i = this%nrow-1, 1, -1 - this%celly(i) = this%celly(i+1) + DHALF*this%delc(i+1) + DHALF*this%delc(i) - enddo + do i = this%nrow - 1, 1, -1 + this%celly(i) = this%celly(i + 1) + DHALF * this%delc(i + 1) + & + DHALF * this%delc(i) + end do ! ! -- create and fill the connections object nrsize = 0 - if(this%nodes < this%nodesuser) nrsize = this%nodes - allocate(this%con) - call this%con%disconnections(this%name_model, this%nodes, & - this%ncol, this%nrow, this%nlay, & - nrsize, this%delr, this%delc, & - this%top, this%bot, this%nodereduced, & + if (this%nodes < this%nodesuser) nrsize = this%nodes + allocate (this%con) + call this%con%disconnections(this%name_model, this%nodes, & + this%ncol, this%nrow, this%nlay, & + nrsize, this%delr, this%delc, & + this%top, this%bot, this%nodereduced, & this%nodeuser) this%nja = this%con%nja this%njas = this%con%njas @@ -717,8 +721,8 @@ subroutine write_grb(this, icelltype) character(len=50) :: txthdr character(len=lentxt) :: txt character(len=LINELENGTH) :: fname - character(len=*),parameter :: fmtgrdsave = & - "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & + character(len=*), parameter :: fmtgrdsave = & + "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" ! ------------------------------------------------------------------------------ ! @@ -727,97 +731,97 @@ subroutine write_grb(this, icelltype) ncpl = this%nrow * this%ncol ! ! -- Open the file - inquire(unit=this%inunit, name=fname) - fname = trim(fname) // '.grb' + inquire (unit=this%inunit, name=fname) + fname = trim(fname)//'.grb' iunit = getunit() - write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) - call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & + write (this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) + call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & form, access, 'REPLACE') ! ! -- write header information - write(txthdr, '(a)') 'GRID DIS' + write (txthdr, '(a)') 'GRID DIS' txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a)') 'VERSION 1' + write (iunit) txthdr + write (txthdr, '(a)') 'VERSION 1' txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'NTXT ', ntxt + write (iunit) txthdr + write (txthdr, '(a, i0)') 'NTXT ', ntxt txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'LENTXT ', lentxt + write (iunit) txthdr + write (txthdr, '(a, i0)') 'LENTXT ', lentxt txthdr(50:50) = new_line('a') - write(iunit) txthdr + write (iunit) txthdr ! ! -- write variable definitions - write(txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser + write (txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay + write (iunit) txt + write (txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NROW ', 'INTEGER ', 'NDIM 0 # ', this%nrow + write (iunit) txt + write (txt, '(3a, i0)') 'NROW ', 'INTEGER ', 'NDIM 0 # ', this%nrow txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NCOL ', 'INTEGER ', 'NDIM 0 # ', this%ncol + write (iunit) txt + write (txt, '(3a, i0)') 'NCOL ', 'INTEGER ', 'NDIM 0 # ', this%ncol txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%nja + write (iunit) txt + write (txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%nja txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin + write (iunit) txt + write (txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin + write (iunit) txt + write (txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot + write (iunit) txt + write (txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'DELR ', 'DOUBLE ', 'NDIM 1 ', this%ncol + write (iunit) txt + write (txt, '(3a, i0)') 'DELR ', 'DOUBLE ', 'NDIM 1 ', this%ncol txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'DELC ', 'DOUBLE ', 'NDIM 1 ', this%nrow + write (iunit) txt + write (txt, '(3a, i0)') 'DELC ', 'DOUBLE ', 'NDIM 1 ', this%nrow txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', ncpl + write (iunit) txt + write (txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', ncpl txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + write (iunit) txt + write (txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) + write (iunit) txt + write (txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt + write (iunit) txt ! ! -- write data - write(iunit) this%nodesuser ! ncells - write(iunit) this%nlay ! nlay - write(iunit) this%nrow ! nrow - write(iunit) this%ncol ! ncol - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%delr ! delr - write(iunit) this%delc ! delc - write(iunit) this%top2d ! top2d - write(iunit) this%bot3d ! bot3d - write(iunit) this%con%iausr ! iausr - write(iunit) this%con%jausr ! jausr - write(iunit) this%idomain ! idomain - write(iunit) icelltype ! icelltype + write (iunit) this%nodesuser ! ncells + write (iunit) this%nlay ! nlay + write (iunit) this%nrow ! nrow + write (iunit) this%ncol ! ncol + write (iunit) this%nja ! nja + write (iunit) this%xorigin ! xorigin + write (iunit) this%yorigin ! yorigin + write (iunit) this%angrot ! angrot + write (iunit) this%delr ! delr + write (iunit) this%delc ! delc + write (iunit) this%top2d ! top2d + write (iunit) this%bot3d ! bot3d + write (iunit) this%con%iausr ! iausr + write (iunit) this%con%jausr ! jausr + write (iunit) this%idomain ! idomain + write (iunit) icelltype ! icelltype ! ! -- Close the file - close(iunit) + close (iunit) ! ! -- return return @@ -842,12 +846,12 @@ subroutine nodeu_to_string(this, nodeu, str) ! ------------------------------------------------------------------------------ ! call get_ijk(nodeu, this%nrow, this%ncol, this%nlay, i, j, k) - write(kstr, '(i10)') k - write(istr, '(i10)') i - write(jstr, '(i10)') j - str = '(' // trim(adjustl(kstr)) // ',' // & - trim(adjustl(istr)) // ',' // & - trim(adjustl(jstr)) // ')' + write (kstr, '(i10)') k + write (istr, '(i10)') i + write (jstr, '(i10)') j + str = '('//trim(adjustl(kstr))//','// & + trim(adjustl(istr))//','// & + trim(adjustl(jstr))//')' ! ! -- return return @@ -875,8 +879,8 @@ subroutine nodeu_to_array(this, nodeu, arr) ! -- check the size of arr isize = size(arr) if (isize /= this%ndim) then - write(errmsg,'(a,i0,a,i0,a)') & - 'Program error: nodeu_to_array size of array (', isize, & + write (errmsg, '(a,i0,a,i0,a)') & + 'Program error: nodeu_to_array size of array (', isize, & ') is not equal to the discretization dimension (', this%ndim, ')' call store_error(errmsg, terminate=.TRUE.) end if @@ -914,28 +918,28 @@ function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) ! ------------------------------------------------------------------------------ ! ! -- check the node number if requested - if(icheck /= 0) then + if (icheck /= 0) then ! ! -- If within valid range, convert to reduced nodenumber - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (errmsg, '(a,i10)') & 'Nodenumber less than 1 or greater than nodes:', nodeu call store_error(errmsg) nodenumber = 0 else nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif + if (this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + end if else nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif + if (this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + end if ! ! -- return return end function get_nodenumber_idx1 - function get_nodenumber_idx3(this, k, i, j, icheck) & + function get_nodenumber_idx3(this, k, i, j, icheck) & result(nodenumber) ! ****************************************************************************** ! get_nodenumber_idx3 -- Return a nodenumber from the user specified layer, row, @@ -958,34 +962,35 @@ function get_nodenumber_idx3(this, k, i, j, icheck) & integer(I4B) :: nodeu ! formats character(len=*), parameter :: fmterr = & - "('Error in structured-grid cell indices: layer = ',i0,', row = ',i0,', column = ',i0)" + "('Error in structured-grid cell indices: layer = ',i0,', & + &row = ',i0,', column = ',i0)" ! ------------------------------------------------------------------------------ ! nodeu = get_node(k, i, j, this%nlay, this%nrow, this%ncol) if (nodeu < 1) then - write(errmsg, fmterr) k, i, j + write (errmsg, fmterr) k, i, j call store_error(errmsg, terminate=.TRUE.) - endif + end if nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + if (this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) ! ! -- check the node number if requested - if(icheck /= 0) then + if (icheck /= 0) then ! - if(k < 1 .or. k > this%nlay) & + if (k < 1 .or. k > this%nlay) & call store_error('Layer less than one or greater than nlay') - if(i < 1 .or. i > this%nrow) & + if (i < 1 .or. i > this%nrow) & call store_error('Row less than one or greater than nrow') - if(j < 1 .or. j > this%ncol) & + if (j < 1 .or. j > this%ncol) & call store_error('Column less than one or greater than ncol') ! ! -- Error if outside of range - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (errmsg, '(a,i10)') & 'Nodenumber less than 1 or greater than nodes:', nodeu call store_error(errmsg) - endif - endif + end if + end if ! ! -- return return @@ -1039,14 +1044,14 @@ subroutine allocate_arrays(this) call this%DisBaseType%allocate_arrays() ! ! -- Allocate arrays for GwfDisType - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%memoryPath) - call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & + call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & this%memoryPath) else call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%memoryPath) call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%memoryPath) - endif + end if ! ! -- Initialize this%mshape(1) = this%nlay @@ -1074,8 +1079,8 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & integer(I4B), intent(inout) :: lloc integer(I4B), intent(inout) :: istart integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout character(len=*), intent(inout) :: line logical, optional, intent(in) :: flag_string logical, optional, intent(in) :: allow_zero @@ -1092,14 +1097,14 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & ! Check to see if first token in line can be read as an integer. lloclocal = lloc call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) - read(line(istart:istop),*,iostat=istat)n + read (line(istart:istop), *, iostat=istat) n if (istat /= 0) then ! First token in line is not an integer; return flag to this effect. nodeu = -2 return - endif - endif - endif + end if + end if + end if ! nlay = this%mshape(1) nrow = this%mshape(2) @@ -1114,28 +1119,28 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & if (allow_zero) then nodeu = 0 return - endif - endif - endif + end if + end if + end if ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) + if (k < 1 .or. k > nlay) then + write (ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) end if - if(i < 1 .or. i > nrow) then - write(ermsg, *) ' Row number in list is outside of the grid', i - call store_error(ermsg) + if (i < 1 .or. i > nrow) then + write (ermsg, *) ' Row number in list is outside of the grid', i + call store_error(ermsg) end if - if(j < 1 .or. j > ncol) then - write(ermsg, *) ' Column number in list is outside of the grid', j - call store_error(ermsg) + if (j < 1 .or. j > ncol) then + write (ermsg, *) ' Column number in list is outside of the grid', j + call store_error(ermsg) end if nodeu = get_node(k, i, j, nlay, nrow, ncol) ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (ermsg, *) ' Node number in list is outside of the grid', nodeu call store_error(ermsg) - inquire(unit=in, name=fname) + inquire (unit=in, name=fname) call store_error('Error converting in file: ') call store_error(trim(adjustl(fname))) call store_error('Cell number cannot be determined in line: ') @@ -1149,7 +1154,7 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & end function nodeu_from_string function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) + allow_zero) result(nodeu) ! ****************************************************************************** ! nodeu_from_cellid -- Receive cellid as a string and convert the string to a ! user nodenumber. @@ -1166,12 +1171,12 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & ! -- return integer(I4B) :: nodeu ! -- dummy - class(GwfDisType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero + class(GwfDisType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero ! -- local integer(I4B) :: lloclocal, istart, istop, ndum, n integer(I4B) :: k, i, j, nlay, nrow, ncol @@ -1185,14 +1190,14 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & ! Check to see if first token in cellid can be read as an integer. lloclocal = 1 call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) - read(cellid(istart:istop), *, iostat=istat) n + read (cellid(istart:istop), *, iostat=istat) n if (istat /= 0) then ! First token in cellid is not an integer; return flag to this effect. nodeu = -2 return - endif - endif - endif + end if + end if + end if ! nlay = this%mshape(1) nrow = this%mshape(2) @@ -1208,28 +1213,28 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & if (allow_zero) then nodeu = 0 return - endif - endif - endif + end if + end if + end if ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) + if (k < 1 .or. k > nlay) then + write (ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) end if - if(i < 1 .or. i > nrow) then - write(ermsg, *) ' Row number in list is outside of the grid', i - call store_error(ermsg) + if (i < 1 .or. i > nrow) then + write (ermsg, *) ' Row number in list is outside of the grid', i + call store_error(ermsg) end if - if(j < 1 .or. j > ncol) then - write(ermsg, *) ' Column number in list is outside of the grid', j - call store_error(ermsg) + if (j < 1 .or. j > ncol) then + write (ermsg, *) ' Column number in list is outside of the grid', j + call store_error(ermsg) end if nodeu = get_node(k, i, j, nlay, nrow, ncol) ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (ermsg, *) ' Node number in list is outside of the grid', nodeu call store_error(ermsg) - inquire(unit=inunit, name=fname) + inquire (unit=inunit, name=fname) call store_error('Error converting in file: ') call store_error(trim(adjustl(fname))) call store_error('Cell number cannot be determined in cellid: ') @@ -1241,7 +1246,6 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & return end function nodeu_from_cellid - logical function supports_layers(this) implicit none ! -- dummy @@ -1272,7 +1276,7 @@ function get_ncpl(this) return end function get_ncpl - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ipos) ! ****************************************************************************** ! connection_normal -- calculate the normal vector components for reduced @@ -1301,10 +1305,10 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! ------------------------------------------------------------------------------ ! ! -- Set vector components based on ihc - if(ihc == 0) then + if (ihc == 0) then xcomp = DZERO ycomp = DZERO - if(nodem < noden) then + if (nodem < noden) then ! ! -- nodem must be above noden, so upward connection zcomp = DONE @@ -1312,7 +1316,7 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! ! -- nodem must be below noden, so downward connection zcomp = -DONE - endif + end if else xcomp = DZERO ycomp = DZERO @@ -1329,15 +1333,15 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & xcomp = DONE else ! front ycomp = -DONE - endif + end if ! - endif + end if ! ! -- return return end subroutine connection_normal - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & xcomp, ycomp, zcomp, conlen) ! ****************************************************************************** ! connection_vector -- calculate the unit vector components from reduced @@ -1373,28 +1377,28 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & ! ------------------------------------------------------------------------------ ! ! -- Set vector components based on ihc - if(ihc == 0) then + if (ihc == 0) then ! ! -- vertical connection; set zcomp positive upward xcomp = DZERO ycomp = DZERO - if(nodem < noden) then + if (nodem < noden) then zcomp = DONE else zcomp = -DONE - endif + end if z1 = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) z2 = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) conlen = abs(z2 - z1) else ! - if(nozee) then + if (nozee) then z1 = DZERO z2 = DZERO else z1 = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) z2 = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) - endif + end if ipos = this%con%getjaindex(noden, nodem) ds = this%con%cl1(this%con%jas(ipos)) + this%con%cl2(this%con%jas(ipos)) nodeu1 = this%get_nodeuser(noden) @@ -1413,40 +1417,40 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & x2 = ds else ! front y2 = -ds - endif + end if call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, conlen) - endif + end if ! ! -- return return end subroutine - + ! return x,y coordinate for a node subroutine get_cellxy_dis3d(this, node, xcell, ycell) use InputOutputModule, only: get_ijk class(GwfDisType), intent(in) :: this - integer(I4B), intent(in) :: node ! the reduced node number - real(DP), intent(out) :: xcell, ycell ! the x,y for the cell + integer(I4B), intent(in) :: node ! the reduced node number + real(DP), intent(out) :: xcell, ycell ! the x,y for the cell ! local integer(I4B) :: nodeuser, i, j, k - + nodeuser = this%get_nodeuser(node) call get_ijk(nodeuser, this%nrow, this%ncol, this%nlay, i, j, k) - + xcell = this%cellx(j) ycell = this%celly(i) - + end subroutine get_cellxy_dis3d - + ! return discretization type subroutine get_dis_type(this, dis_type) - class(GwfDisType), intent(in) :: this - character(len=*), intent(out) :: dis_type - + class(GwfDisType), intent(in) :: this + character(len=*), intent(out) :: dis_type + dis_type = "DIS" - + end subroutine get_dis_type - + subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & iarray, aname) ! ****************************************************************************** @@ -1460,15 +1464,15 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfDisType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(GwfDisType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! -- local integer(I4B) :: ival real(DP) :: rval @@ -1493,15 +1497,15 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & else nval = this%nodes itemp => iarray - endif + end if ! ! -- Read the array call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then + if (line(istart:istop) .EQ. 'LAYERED') then ! ! -- Read layered input call ReadArray(in, itemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) + iout, 1, nlay) else ! ! -- Read unstructured input @@ -1509,9 +1513,9 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & end if ! ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray - if (this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call this%fill_grid_array(itemp, iarray) - endif + end if ! ! -- return return @@ -1530,18 +1534,18 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfDisType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(GwfDisType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! -- local integer(I4B) :: ival - real(DP) :: rval + real(DP) :: rval integer(I4B) :: nlay integer(I4B) :: nrow integer(I4B) :: ncol @@ -1557,21 +1561,21 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & nrow = this%mshape(2) ncol = this%mshape(3) ! - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodesuser dtemp => this%dbuff else nval = this%nodes dtemp => darray - endif + end if ! ! -- Read the array call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then + if (line(istart:istop) .EQ. 'LAYERED') then ! ! -- Read structured input call ReadArray(in, dtemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) + iout, 1, nlay) else ! ! -- Read unstructured input @@ -1579,15 +1583,15 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & end if ! ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call this%fill_grid_array(dtemp, darray) - endif + end if ! ! -- return return end subroutine read_dbl_array - subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & + subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & icolbnd, aname, inunit, iout) ! ****************************************************************************** ! read_layer_array -- Read a 2d double array into col icolbnd of darray. @@ -1620,8 +1624,8 @@ subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & ! ! -- Read the array nval = ncol * nrow - call ReadArray(inunit, this%dbuff, aname, this%ndim, ncol, nrow, nlay, & - nval, iout, 0, 0) + call ReadArray(inunit, this%dbuff, aname, this%ndim, ncol, nrow, nlay, & + nval, iout, 0, 0) ! ! -- Copy array into bound. Note that this routine was substantially ! changed on 9/21/2021 to support changes to READASARRAYS input @@ -1634,14 +1638,14 @@ subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & darray(icolbnd, ipos) = this%dbuff(nodeu) ipos = ipos + 1 ! - enddo - enddo + end do + end do ! ! -- return end subroutine read_layer_array - - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) + + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) ! ****************************************************************************** ! record_array -- Record a double precision array. The array will be ! printed to an external file and/or written to an unformatted external file @@ -1664,17 +1668,17 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwfDisType), intent(inout) :: this + class(GwfDisType), intent(inout) :: this real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact ! -- local integer(I4B) :: k, ifirst integer(I4B) :: nlay @@ -1685,7 +1689,7 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & integer(I4B) :: istart, istop real(DP), dimension(:), pointer, contiguous :: dtemp ! -- formats - character(len=*),parameter :: fmthsv = & + character(len=*), parameter :: fmthsv = & "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" ! ------------------------------------------------------------------------------ @@ -1697,61 +1701,61 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! ! -- If this is a reduced model, then copy the values from darray into ! dtemp. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodes dtemp => this%dbuff do nodeu = 1, this%nodesuser noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then + if (noder <= 0) then dtemp(nodeu) = dinact cycle - endif + end if dtemp(nodeu) = darray(noder) - enddo + end do else nval = this%nodes dtemp => darray - endif + end if ! ! -- Print to iout if iprint /= 0 - if(iprint /= 0) then + if (iprint /= 0) then istart = 1 do k = 1, nlay istop = istart + nrow * ncol - 1 - call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & + call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & aname, cdatafmp, nvaluesp, nwidthp, editdesc) istart = istop + 1 - enddo - endif + end do + end if ! ! -- Save array to an external file. - if(idataun > 0) then + if (idataun > 0) then ! -- write to binary file by layer ifirst = 1 istart = 1 - do k=1, nlay + do k = 1, nlay istop = istart + nrow * ncol - 1 - if(ifirst == 1) write(iout, fmthsv) & - trim(adjustl(aname)), idataun, & - kstp, kper + if (ifirst == 1) write (iout, fmthsv) & + trim(adjustl(aname)), idataun, & + kstp, kper ifirst = 0 - call ulasav(dtemp(istart:istop), aname, kstp, kper, & + call ulasav(dtemp(istart:istop), aname, kstp, kper, & pertim, totim, ncol, nrow, k, idataun) istart = istop + 1 - enddo - elseif(idataun < 0) then + end do + elseif (idataun < 0) then ! ! -- write entire array as one record - call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & + call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & iout, delt, pertim, totim) - endif + end if ! ! -- return return end subroutine record_array - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & ibdchn, nlist, iout) ! ****************************************************************************** ! record_srcdst_list_header -- Record list header for imeth=6 @@ -1780,8 +1784,8 @@ subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & ncol = this%mshape(3) ! ! -- Use ubdsv06 to write list header - call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& - ibdchn, naux, auxtxt, ncol, nrow, nlay, & + call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage, & + ibdchn, naux, auxtxt, ncol, nrow, nlay, & nlist, iout, delt, pertim, totim) ! ! -- return @@ -1820,10 +1824,11 @@ subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & nrow = this%mshape(2) ncol = this%mshape(3) ! - if(this%ndim > 1) then + if (this%ndim > 1) then ! nval = ncol * nrow - call ReadArray(inunit, this%ibuff, aname, this%ndim, ncol, nrow, nlay, nval, iout, 0, 0) + call ReadArray(inunit, this%ibuff, aname, this%ndim, ncol, nrow, nlay, & + nval, iout, 0, 0) ! ! -- Copy array into nodelist ipos = 1 @@ -1832,50 +1837,50 @@ subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & do ic = 1, ncol nodeu = get_node(1, ir, ic, nlay, nrow, ncol) il = this%ibuff(nodeu) - if(il < 1 .or. il > nlay) then - write(errmsg, *) 'INVALID LAYER NUMBER: ', il + if (il < 1 .or. il > nlay) then + write (errmsg, *) 'INVALID LAYER NUMBER: ', il call store_error(errmsg, terminate=.TRUE.) - endif + end if nodeu = get_node(il, ir, ic, nlay, nrow, ncol) noder = this%get_nodenumber(nodeu, 0) - if(ipos > maxbnd) then + if (ipos > maxbnd) then ierr = ipos else nodelist(ipos) = noder - endif + end if ipos = ipos + 1 - enddo - enddo + end do + end do ! ! -- Check for errors nbound = ipos - 1 - if(ierr > 0) then - write(errmsg, *) 'MAXBOUND DIMENSION IS TOO SMALL.' + if (ierr > 0) then + write (errmsg, *) 'MAXBOUND DIMENSION IS TOO SMALL.' call store_error(errmsg) - write(errmsg, *) 'INCREASE MAXBOUND TO: ', ierr + write (errmsg, *) 'INCREASE MAXBOUND TO: ', ierr call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- If nbound < maxbnd, then initialize nodelist to zero in this range - if(nbound < maxbnd) then - do ipos = nbound+1, maxbnd + if (nbound < maxbnd) then + do ipos = nbound + 1, maxbnd nodelist(ipos) = 0 - enddo - endif + end do + end if ! else ! ! -- For unstructured, read nodelist directly, then check node numbers call ReadArray(inunit, nodelist, aname, this%ndim, maxbnd, iout, 0) do noder = 1, maxbnd - if(noder < 1 .or. noder > this%nodes) then - write(errmsg, *) 'INVALID NODE NUMBER: ', noder + if (noder < 1 .or. noder > this%nodes) then + write (errmsg, *) 'INVALID NODE NUMBER: ', noder call store_error(errmsg, terminate=.TRUE.) - endif - enddo + end if + end do nbound = maxbnd ! - endif + end if ! ! -- return end subroutine nlarray_to_nodelist diff --git a/src/Model/GroundWaterFlow/gwf3disu8.f90 b/src/Model/GroundWaterFlow/gwf3disu8.f90 index 5394f0f68ab..09447a61134 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -21,25 +21,25 @@ module GwfDisuModule public :: CastAsDisuType type, extends(DisBaseType) :: GwfDisuType - integer(I4B), pointer :: njausr => null() ! user-specified nja size - integer(I4B), pointer :: nvert => null() ! number of x,y vertices - real(DP), pointer :: voffsettol => null() ! vertical offset tolerance - real(DP), dimension(:,:), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y - real(DP), dimension(:,:), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y - real(DP), dimension(:), pointer, contiguous :: top1d => null() ! (size:nodesuser) cell top elevation - real(DP), dimension(:), pointer, contiguous :: bot1d => null() ! (size:nodesuser) cell bottom elevation - real(DP), dimension(:), pointer, contiguous :: area1d => null() ! (size:nodesuser) cell area, in plan view - integer(I4B), dimension(:), pointer, contiguous :: iainp => null() ! (size:nodesuser+1) user iac converted ia - integer(I4B), dimension(:), pointer, contiguous :: jainp => null() ! (size:njausr) user-input ja array - integer(I4B), dimension(:), pointer, contiguous :: ihcinp => null() ! (size:njausr) user-input ihc array - real(DP), dimension(:), pointer, contiguous :: cl12inp => null() ! (size:njausr) user-input cl12 array - real(DP), dimension(:), pointer, contiguous :: hwvainp => null() ! (size:njausr) user-input hwva array - real(DP), dimension(:), pointer, contiguous :: angldegxinp => null() ! (size:njausr) user-input angldegx array - integer(I4B), pointer :: iangledegx => null() ! =1 when angle information was present in input, 0 otherwise - integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array - integer(I4B), dimension(:), pointer, contiguous:: javert => null() ! cell vertex pointer ja array - integer(I4B), dimension(:), pointer, contiguous :: idomain => null() ! idomain (nodes) - logical(LGP) :: readFromFile ! True, when DIS is read from file (almost always) + integer(I4B), pointer :: njausr => null() ! user-specified nja size + integer(I4B), pointer :: nvert => null() ! number of x,y vertices + real(DP), pointer :: voffsettol => null() ! vertical offset tolerance + real(DP), dimension(:, :), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y + real(DP), dimension(:, :), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y + real(DP), dimension(:), pointer, contiguous :: top1d => null() ! (size:nodesuser) cell top elevation + real(DP), dimension(:), pointer, contiguous :: bot1d => null() ! (size:nodesuser) cell bottom elevation + real(DP), dimension(:), pointer, contiguous :: area1d => null() ! (size:nodesuser) cell area, in plan view + integer(I4B), dimension(:), pointer, contiguous :: iainp => null() ! (size:nodesuser+1) user iac converted ia + integer(I4B), dimension(:), pointer, contiguous :: jainp => null() ! (size:njausr) user-input ja array + integer(I4B), dimension(:), pointer, contiguous :: ihcinp => null() ! (size:njausr) user-input ihc array + real(DP), dimension(:), pointer, contiguous :: cl12inp => null() ! (size:njausr) user-input cl12 array + real(DP), dimension(:), pointer, contiguous :: hwvainp => null() ! (size:njausr) user-input hwva array + real(DP), dimension(:), pointer, contiguous :: angldegxinp => null() ! (size:njausr) user-input angldegx array + integer(I4B), pointer :: iangledegx => null() ! =1 when angle information was present in input, 0 otherwise + integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array + integer(I4B), dimension(:), pointer, contiguous :: javert => null() ! cell vertex pointer ja array + integer(I4B), dimension(:), pointer, contiguous :: idomain => null() ! idomain (nodes) + logical(LGP) :: readFromFile ! True, when DIS is read from file (almost always) contains procedure :: dis_df => disu_df procedure :: dis_da => disu_da @@ -75,7 +75,7 @@ module GwfDisuModule procedure :: read_dbl_array end type GwfDisuType - contains +contains subroutine disu_cr(dis, name_model, inunit, iout) ! ****************************************************************************** @@ -94,7 +94,7 @@ subroutine disu_cr(dis, name_model, inunit, iout) ! ------------------------------------------------------------------------------ ! ! -- Create a new discretization object - allocate(disnew) + allocate (disnew) dis => disnew ! ! -- Allocate scalars and assign data @@ -108,9 +108,9 @@ subroutine disu_cr(dis, name_model, inunit, iout) ! -- Return return end subroutine disu_cr - - subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & - top, bot, area, iac, ja, ihc, cl12, hwva, angldegx, & + + subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & + top, bot, area, iac, ja, ihc, cl12, hwva, angldegx, & nvert, vertices, cellxy, idomain) ! ****************************************************************************** ! dis_init_mem -- Create a new unstructured discretization object from memory @@ -133,11 +133,11 @@ subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & real(DP), dimension(:), pointer, contiguous, intent(in) :: hwva real(DP), dimension(:), pointer, contiguous, intent(in), optional :: angldegx integer(I4B), intent(in), optional :: nvert - integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & + integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & optional :: vertices - integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & + integer(I4B), dimension(:, :), pointer, contiguous, intent(in), & optional :: cellxy - integer(I4B), dimension(:), pointer, contiguous, intent(in), & + integer(I4B), dimension(:), pointer, contiguous, intent(in), & optional :: idomain ! -- local type(GwfDisuType), pointer :: disext @@ -146,7 +146,7 @@ subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & integer(I4B) :: ival real(DP), dimension(:), pointer, contiguous :: atemp ! ------------------------------------------------------------------------------ - allocate(disext) + allocate (disext) dis => disext call disext%allocate_scalars(name_model) dis%inunit = 0 @@ -189,7 +189,7 @@ subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & disext%vertices(j, n) = vertices(j, n) end do end do - ! -- error + ! -- error else end if if (present(cellxy)) then @@ -198,7 +198,7 @@ subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & disext%cellxy(j, n) = cellxy(j, n) end do end do - ! -- error + ! -- error else end if else @@ -207,7 +207,7 @@ subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & end if ! ! -- allocate space for atemp and fill - allocate(atemp(nja)) + allocate (atemp(nja)) if (present(angldegx)) then disext%con%ianglex = 1 do n = 1, nja @@ -220,7 +220,7 @@ subroutine disu_init_mem(dis, name_model, iout, nodes, nja, & disext%njas = disext%con%njas ! ! -- deallocate temp arrays - deallocate(atemp) + deallocate (atemp) ! ! -- Make some final disu checks call disext%disu_ck() @@ -244,9 +244,9 @@ subroutine disu_df(this) if (this%inunit /= 0) then ! ! -- Identify package - write(this%iout,1) this%inunit - 1 format(1X,/1X,'DISU -- UNSTRUCTURED GRID DISCRETIZATION PACKAGE,', & - ' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ',I0,//) + write (this%iout, 1) this%inunit +1 format(1X, /1X, 'DISU -- UNSTRUCTURED GRID DISCRETIZATION PACKAGE,', & + ' VERSION 2 : 3/27/2014 - INPUT READ FROM UNIT ', I0, //) ! call this%read_options() call this%read_dimensions() @@ -254,20 +254,20 @@ subroutine disu_df(this) call this%read_connectivity() ! ! -- If NVERT specified and greater than 0, then read VERTICES and CELL2D - if(this%nvert > 0) then + if (this%nvert > 0) then call this%read_vertices() call this%read_cell2d() else ! -- connection direction information cannot be calculated this%icondir = 0 - endif + end if end if ! ! -- Make some final disu checks on the non-reduced user-provided ! input call this%disu_ck() ! - ! -- Finalize the grid by creating the connection object and reducing the + ! -- Finalize the grid by creating the connection object and reducing the ! grid using IDOMAIN, if necessary call this%grid_finalize() ! @@ -294,19 +294,19 @@ subroutine grid_finalize(this) integer(I4B) :: nrsize ! -- formats character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',i0,',',i0,') THICKNESS <= 0. ', " // & - "'TOP, BOT: ',2(1pg24.15))" + "('ERROR. CELL (',i0,',',i0,',',i0,') THICKNESS <= 0. ', & + &'TOP, BOT: ',2(1pg24.15))" character(len=*), parameter :: fmtnr = & - "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.'," // & - "/1x, 'NUMBER OF USER NODES: ',I0," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" + "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.',& + &/1x, 'NUMBER OF USER NODES: ',I0,& + &/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" ! ------------------------------------------------------------------------------ ! ! -- count active cells this%nodes = 0 do n = 1, this%nodesuser - if(this%idomain(n) > 0) this%nodes = this%nodes + 1 - enddo + if (this%idomain(n) > 0) this%nodes = this%nodes + 1 + end do ! ! -- Check to make sure nodes is a valid number if (this%nodes == 0) then @@ -317,9 +317,9 @@ subroutine grid_finalize(this) end if ! ! -- Write message if reduced grid - if(this%nodes < this%nodesuser) then - write(this%iout, fmtnr) this%nodesuser, this%nodes - endif + if (this%nodes < this%nodesuser) then + write (this%iout, fmtnr) this%nodesuser, this%nodes + end if ! ! -- Array size is now known, so allocate call this%allocate_arrays() @@ -328,51 +328,51 @@ subroutine grid_finalize(this) ! a negative number to indicate it is a pass-through cell, or ! a zero to indicate that the cell is excluded from the ! solution. (negative idomain not supported for disu) - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then noder = 1 do node = 1, this%nodesuser - if(this%idomain(node) > 0) then + if (this%idomain(node) > 0) then this%nodereduced(node) = noder noder = noder + 1 - elseif(this%idomain(node) < 0) then + elseif (this%idomain(node) < 0) then this%nodereduced(node) = -1 else this%nodereduced(node) = 0 - endif - enddo - endif + end if + end do + end if ! ! -- Fill nodeuser if a reduced grid - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then noder = 1 do node = 1, this%nodesuser - if(this%idomain(node) > 0) then + if (this%idomain(node) > 0) then this%nodeuser(noder) = node noder = noder + 1 - endif - enddo - endif + end if + end do + end if ! ! -- Move top1d, bot1d, and area1d into top, bot, and area do node = 1, this%nodesuser noder = node - if(this%nodes < this%nodesuser) noder = this%nodereduced(node) - if(noder <= 0) cycle + if (this%nodes < this%nodesuser) noder = this%nodereduced(node) + if (noder <= 0) cycle this%top(noder) = this%top1d(node) this%bot(noder) = this%bot1d(node) this%area(noder) = this%area1d(node) - enddo + end do ! ! -- create and fill the connections object nrsize = 0 - if(this%nodes < this%nodesuser) nrsize = this%nodes - allocate(this%con) - call this%con%disuconnections(this%name_model, this%nodes, & - this%nodesuser, nrsize, & - this%nodereduced, this%nodeuser, & - this%iainp, this%jainp, & - this%ihcinp, this%cl12inp, & - this%hwvainp, this%angldegxinp, & + if (this%nodes < this%nodesuser) nrsize = this%nodes + allocate (this%con) + call this%con%disuconnections(this%name_model, this%nodes, & + this%nodesuser, nrsize, & + this%nodereduced, this%nodeuser, & + this%iainp, this%jainp, & + this%ihcinp, this%cl12inp, & + this%hwvainp, this%angldegxinp, & this%iangledegx) this%nja = this%con%nja this%njas = this%con%njas @@ -398,19 +398,19 @@ subroutine disu_ck(this) real(DP) :: dz ! -- formats character(len=*), parameter :: fmtidm = & - "('Invalid idomain value ', i0, ' specified for node ', i0)" + &"('Invalid idomain value ', i0, ' specified for node ', i0)" character(len=*), parameter :: fmtdz = & - "('Cell ', i0, ' with thickness <= 0. Top, bot: ', 2(1pg24.15))" + &"('Cell ', i0, ' with thickness <= 0. Top, bot: ', 2(1pg24.15))" character(len=*), parameter :: fmtarea = & - "('Cell ', i0, ' with area <= 0. Area: ', 1(1pg24.15))" + &"('Cell ', i0, ' with area <= 0. Area: ', 1(1pg24.15))" character(len=*), parameter :: fmtjan = & - "('Cell ', i0, ' must have its first connection be itself. Found: ', i0)" + &"('Cell ', i0, ' must have its first connection be itself. Found: ', i0)" character(len=*), parameter :: fmtjam = & - "('Cell ', i0, ' has invalid connection in JA. Found: ', i0)" - character(len=*),parameter :: fmterrmsg = & + &"('Cell ', i0, ' has invalid connection in JA. Found: ', i0)" + character(len=*), parameter :: fmterrmsg = & "('Top elevation (', 1pg15.6, ') for cell ', i0, ' is above bottom & &elevation (', 1pg15.6, ') for cell ', i0, '. Based on node numbering & - &rules cell ', i0, ' must be below cell ', i0, '.')" + &rules cell ', i0, ' must be below cell ', i0, '.')" ! ------------------------------------------------------------------------------ ! ! -- Check connectivity @@ -425,7 +425,7 @@ subroutine disu_ck(this) this%jainp(ipos) = m end if if (n /= m) then - write(errmsg, fmtjan) n, m + write (errmsg, fmtjan) n, m call store_error(errmsg) end if ! @@ -434,26 +434,26 @@ subroutine disu_ck(this) m = this%jainp(ipos) if (m < 0 .or. m > this%nodesuser) then ! -- make sure first connection is to itself - write(errmsg, fmtjam) n, m - call store_error(errmsg) - end if + write (errmsg, fmtjam) n, m + call store_error(errmsg) + end if end do end do ! ! -- terminate if errors found - if(count_errors() > 0) then + if (count_errors() > 0) then if (this%inunit > 0) then call store_error_unit(this%inunit) end if - endif + end if ! ! -- Ensure idomain values are valid do n = 1, this%nodesuser - if(this%idomain(n) > 1 .or. this%idomain(n) < 0) then - write(errmsg, fmtidm) this%idomain(n), n + if (this%idomain(n) > 1 .or. this%idomain(n) < 0) then + write (errmsg, fmtidm) this%idomain(n), n call store_error(errmsg) end if - enddo + end do ! ! -- Check for zero and negative thickness and zero or negative areas ! for cells with idomain == 1 @@ -461,19 +461,19 @@ subroutine disu_ck(this) if (this%idomain(n) == 1) then dz = this%top1d(n) - this%bot1d(n) if (dz <= DZERO) then - write(errmsg, fmt=fmtdz) n, this%top1d(n), this%bot1d(n) + write (errmsg, fmt=fmtdz) n, this%top1d(n), this%bot1d(n) call store_error(errmsg) - endif + end if if (this%area1d(n) <= DZERO) then - write(errmsg, fmt=fmtarea) n, this%area1d(n) + write (errmsg, fmt=fmtarea) n, this%area1d(n) call store_error(errmsg) - endif + end if end if - enddo + end do ! ! -- check to make sure voffsettol is >= 0 if (this%voffsettol < DZERO) then - write(errmsg, '(a, 1pg15.6)') & + write (errmsg, '(a, 1pg15.6)') & 'Vertical offset tolerance must be greater than zero. Found ', & this%voffsettol call store_error(errmsg) @@ -489,9 +489,9 @@ subroutine disu_ck(this) m = this%jainp(ipos) ihc = this%ihcinp(ipos) if (ihc == 0 .and. m > n) then - dz = this%top1d(m) - this%bot1d(n) + dz = this%top1d(m) - this%bot1d(n) if (dz > this%voffsettol) then - write(errmsg, fmterrmsg) this%top1d(m), m, this%bot1d(n), n, m, n + write (errmsg, fmterrmsg) this%top1d(m), m, this%bot1d(n), n, m, n call store_error(errmsg) end if end if @@ -499,11 +499,11 @@ subroutine disu_ck(this) end do ! ! -- terminate if errors found - if(count_errors() > 0) then + if (count_errors() > 0) then if (this%inunit > 0) then call store_error_unit(this%inunit) end if - endif + end if ! ! -- Return return @@ -532,7 +532,7 @@ subroutine disu_da(this) if (this%readFromFile) then call mem_deallocate(this%top1d) call mem_deallocate(this%bot1d) - call mem_deallocate(this%area1d) + call mem_deallocate(this%area1d) if (associated(this%iavert)) then call mem_deallocate(this%iavert) call mem_deallocate(this%javert) @@ -543,13 +543,12 @@ subroutine disu_da(this) call mem_deallocate(this%ihcinp) call mem_deallocate(this%cl12inp) call mem_deallocate(this%hwvainp) - call mem_deallocate(this%angldegxinp) + call mem_deallocate(this%angldegxinp) end if call mem_deallocate(this%idomain) call mem_deallocate(this%cellxy) - call mem_deallocate(this%nodeuser) call mem_deallocate(this%nodereduced) ! @@ -576,8 +575,8 @@ subroutine nodeu_to_string(this, nodeu, str) character(len=10) :: nstr ! ------------------------------------------------------------------------------ ! - write(nstr, '(i0)') nodeu - str = '(' // trim(adjustl(nstr)) // ')' + write (nstr, '(i0)') nodeu + str = '('//trim(adjustl(nstr))//')' ! ! -- return return @@ -603,8 +602,8 @@ subroutine nodeu_to_array(this, nodeu, arr) ! -- check the size of arr isize = size(arr) if (isize /= this%ndim) then - write(errmsg,'(a,i0,a,i0,a)') & - 'Program error: nodeu_to_array size of array (', isize, & + write (errmsg, '(a,i0,a,i0,a)') & + 'Program error: nodeu_to_array size of array (', isize, & ') is not equal to the discretization dimension (', this%ndim, ')' call store_error(errmsg, terminate=.TRUE.) end if @@ -638,65 +637,67 @@ subroutine read_options(this) supportOpenClose=.true., blockRequired=.false.) ! ! -- set default options - this%lenuni = 0 + this%lenuni = 0 ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING DISCRETIZATION OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('LENGTH_UNITS') - call this%parser%GetStringCaps(keyword) - if(keyword=='FEET') then - this%lenuni = 1 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS FEET' - elseif(keyword=='METERS') then - this%lenuni = 2 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS METERS' - elseif(keyword=='CENTIMETERS') then - this%lenuni = 3 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' - else - write(this%iout,'(4x,a)')'UNKNOWN UNIT: ',trim(keyword) - write(this%iout,'(4x,a)')'SETTING TO: ','UNDEFINED' - endif - case('NOGRB') - write(this%iout,'(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' - this%writegrb = .false. - case('XORIGIN') - this%xorigin = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & - this%xorigin - case('YORIGIN') - this%yorigin = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & - this%yorigin - case('ANGROT') - this%angrot = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & - this%angrot - case('VERTICAL_OFFSET_TOLERANCE') - this%voffsettol = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') & - 'VERTICAL OFFSET TOLERANCE SPECIFIED AS ', this%voffsettol - case default - write(errmsg,'(a)')'Unknown DISU option: ' // trim(keyword) - call store_error(errmsg) + case ('LENGTH_UNITS') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FEET') then + this%lenuni = 1 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS FEET' + elseif (keyword == 'METERS') then + this%lenuni = 2 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS METERS' + elseif (keyword == 'CENTIMETERS') then + this%lenuni = 3 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' + else + write (this%iout, '(4x,a)') 'UNKNOWN UNIT: ', trim(keyword) + write (this%iout, '(4x,a)') 'SETTING TO: ', 'UNDEFINED' + end if + case ('NOGRB') + write (this%iout, '(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' + this%writegrb = .false. + case ('XORIGIN') + this%xorigin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & + this%xorigin + case ('YORIGIN') + this%yorigin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & + this%yorigin + case ('ANGROT') + this%angrot = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & + this%angrot + case ('VERTICAL_OFFSET_TOLERANCE') + this%voffsettol = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') & + 'VERTICAL OFFSET TOLERANCE SPECIFIED AS ', this%voffsettol + case default + write (errmsg, '(a)') 'Unknown DISU option: '//trim(keyword) + call store_error(errmsg) end select end do - write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' + write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' else - write(this%iout,'(1x,a)')'NO OPTION BLOCK DETECTED.' + write (this%iout, '(1x,a)') 'NO OPTION BLOCK DETECTED.' + end if + if (this%lenuni == 0) then + write (this%iout, '(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' end if - if(this%lenuni==0) write(this%iout,'(1x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' ! nerr = count_errors() - if(nerr > 0) then + if (nerr > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return @@ -729,42 +730,42 @@ subroutine read_dimensions(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING DISCRETIZATION DIMENSIONS' + write (this%iout, '(1x,a)') 'PROCESSING DISCRETIZATION DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NODES') - this%nodesuser = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NODES = ', this%nodesuser - case ('NJA') - this%njausr = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NJA = ', this%njausr - case ('NVERT') - this%nvert = this%parser%GetInteger() - write(this%iout,'(3x,a,i0)') 'NVERT = ', this%nvert - write(this%iout,'(3x,a)') 'VERTICES AND CELL2D BLOCKS WILL ' // & - 'BE READ BELOW. ' - case default - write(errmsg,'(a)') 'Unknown DISU dimension: ' // trim(keyword) - call store_error(errmsg) + case ('NODES') + this%nodesuser = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NODES = ', this%nodesuser + case ('NJA') + this%njausr = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NJA = ', this%njausr + case ('NVERT') + this%nvert = this%parser%GetInteger() + write (this%iout, '(3x,a,i0)') 'NVERT = ', this%nvert + write (this%iout, '(3x,a)') 'VERTICES AND CELL2D BLOCKS WILL '// & + 'BE READ BELOW. ' + case default + write (errmsg, '(a)') 'Unknown DISU dimension: '//trim(keyword) + call store_error(errmsg) end select end do - write(this%iout,'(1x,a)') 'END OF DISCRETIZATION OPTIONS' + write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' else call store_error('Required dimensions block not found.') end if ! ! -- verify dimensions were set - if(this%nodesuser < 1) then + if (this%nodesuser < 1) then call store_error( & - 'NODES was not specified or was specified incorrectly.') - endif - if(this%njausr < 1) then + 'NODES was not specified or was specified incorrectly.') + end if + if (this%njausr < 1) then call store_error( & - 'NJA was not specified or was specified incorrectly.') - endif + 'NJA was not specified or was specified incorrectly.') + end if ! ! -- terminate if errors were detected if (count_errors() > 0) then @@ -783,12 +784,13 @@ subroutine read_dimensions(this) call mem_allocate(this%ihcinp, this%njausr, 'IHCINP', this%memoryPath) call mem_allocate(this%cl12inp, this%njausr, 'CL12INP', this%memoryPath) call mem_allocate(this%hwvainp, this%njausr, 'HWVAINP', this%memoryPath) - call mem_allocate(this%angldegxinp, this%njausr, 'ANGLDEGXINP', this%memoryPath) - if(this%nvert > 0) then + call mem_allocate(this%angldegxinp, this%njausr, 'ANGLDEGXINP', & + this%memoryPath) + if (this%nvert > 0) then call mem_allocate(this%cellxy, 2, this%nodesuser, 'CELLXY', this%memoryPath) else call mem_allocate(this%cellxy, 2, 0, 'CELLXY', this%memoryPath) - endif + end if ! ! -- initialize all cells to be active (idomain = 1) do n = 1, this%nodesuser @@ -816,48 +818,48 @@ subroutine read_mf6_griddata(this) integer(I4B) :: ierr logical :: isfound, endOfBlock integer(I4B), parameter :: nname = 4 - logical,dimension(nname) :: lname - character(len=24),dimension(nname) :: aname(nname) + logical, dimension(nname) :: lname + character(len=24), dimension(nname) :: aname(nname) ! -- formats ! -- data - data aname(1) /' TOP'/ - data aname(2) /' BOT'/ - data aname(3) /' AREA'/ - data aname(4) /' IDOMAIN'/ + data aname(1)/' TOP'/ + data aname(2)/' BOT'/ + data aname(3)/' AREA'/ + data aname(4)/' IDOMAIN'/ ! ------------------------------------------------------------------------------ ! ! -- get disdata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) lname(:) = .false. - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('TOP') - call ReadArray(this%parser%iuactive, this%top1d, aname(1), & - this%ndim, this%nodesuser, this%iout, 0) - lname(1) = .true. - case ('BOT') - call ReadArray(this%parser%iuactive, this%bot1d, aname(2), & - this%ndim, this%nodesuser, this%iout, 0) - lname(2) = .true. - case ('AREA') - call ReadArray(this%parser%iuactive, this%area1d, aname(3), & - this%ndim, this%nodesuser, this%iout, 0) - lname(3) = .true. - case ('IDOMAIN') - call ReadArray(this%parser%iuactive, this%idomain, aname(4), & - this%ndim, this%nodesuser, this%iout, 0) - lname(4) = .true. - case default - write(errmsg,'(a)') 'Unknown GRIDDATA tag: ' // trim(keyword) - call store_error(errmsg) + case ('TOP') + call ReadArray(this%parser%iuactive, this%top1d, aname(1), & + this%ndim, this%nodesuser, this%iout, 0) + lname(1) = .true. + case ('BOT') + call ReadArray(this%parser%iuactive, this%bot1d, aname(2), & + this%ndim, this%nodesuser, this%iout, 0) + lname(2) = .true. + case ('AREA') + call ReadArray(this%parser%iuactive, this%area1d, aname(3), & + this%ndim, this%nodesuser, this%iout, 0) + lname(3) = .true. + case ('IDOMAIN') + call ReadArray(this%parser%iuactive, this%idomain, aname(4), & + this%ndim, this%nodesuser, this%iout, 0) + lname(4) = .true. + case default + write (errmsg, '(a)') 'Unknown GRIDDATA tag: '//trim(keyword) + call store_error(errmsg) end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else call store_error('Required GRIDDATA block not found.') end if @@ -865,11 +867,11 @@ subroutine read_mf6_griddata(this) ! -- verify all items were read do n = 1, nname if (n == 4) cycle - if(.not. lname(n)) then - write(errmsg,'(a)') 'Required input was not specified: ', trim(aname(n)) + if (.not. lname(n)) then + write (errmsg, '(a)') 'Required input was not specified: ', trim(aname(n)) call store_error(errmsg) - endif - enddo + end if + end do ! ! -- terminate if errors were detected if (count_errors() > 0) then @@ -898,63 +900,63 @@ subroutine read_connectivity(this) integer(I4B) :: ierr logical :: isfound, endOfBlock integer(I4B), parameter :: nname = 6 - logical,dimension(nname) :: lname - character(len=24),dimension(nname) :: aname(nname) + logical, dimension(nname) :: lname + character(len=24), dimension(nname) :: aname(nname) ! -- formats ! -- data - data aname(1) /' IAC'/ - data aname(2) /' JA'/ - data aname(3) /' IHC'/ - data aname(4) /' CL12'/ - data aname(5) /' HWVA'/ - data aname(6) /' ANGLDEGX'/ + data aname(1)/' IAC'/ + data aname(2)/' JA'/ + data aname(3)/' IHC'/ + data aname(4)/' CL12'/ + data aname(5)/' HWVA'/ + data aname(6)/' ANGLDEGX'/ ! ------------------------------------------------------------------------------ ! ! -- get connectiondata block call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr) lname(:) = .false. - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING CONNECTIONDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING CONNECTIONDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('IAC') - call ReadArray(this%parser%iuactive, this%iainp, aname(1), 1, & - this%nodesuser, this%iout, 0) - lname(1) = .true. - ! - ! -- Convert iac to ia - call iac_to_ia(this%iainp) - case ('JA') - call ReadArray(this%parser%iuactive, this%jainp, aname(2), 1, & - this%njausr, this%iout, 0) - lname(2) = .true. - case ('IHC') - call ReadArray(this%parser%iuactive, this%ihcinp, aname(3), 1, & - this%njausr, this%iout, 0) - lname(3) = .true. - case ('CL12') - call ReadArray(this%parser%iuactive, this%cl12inp, aname(4), 1, & - this%njausr, this%iout, 0) - lname(4) = .true. - case ('HWVA') - call ReadArray(this%parser%iuactive, this%hwvainp, aname(5), 1, & - this%njausr, this%iout, 0) - lname(5) = .true. - case ('ANGLDEGX') - call ReadArray(this%parser%iuactive, this%angldegxinp, aname(6), 1, & - this%njausr, this%iout, 0) - lname(6) = .true. - case default - write(errmsg,'(4x,a,a)')'Unknown CONNECTIONDATA tag: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('IAC') + call ReadArray(this%parser%iuactive, this%iainp, aname(1), 1, & + this%nodesuser, this%iout, 0) + lname(1) = .true. + ! + ! -- Convert iac to ia + call iac_to_ia(this%iainp) + case ('JA') + call ReadArray(this%parser%iuactive, this%jainp, aname(2), 1, & + this%njausr, this%iout, 0) + lname(2) = .true. + case ('IHC') + call ReadArray(this%parser%iuactive, this%ihcinp, aname(3), 1, & + this%njausr, this%iout, 0) + lname(3) = .true. + case ('CL12') + call ReadArray(this%parser%iuactive, this%cl12inp, aname(4), 1, & + this%njausr, this%iout, 0) + lname(4) = .true. + case ('HWVA') + call ReadArray(this%parser%iuactive, this%hwvainp, aname(5), 1, & + this%njausr, this%iout, 0) + lname(5) = .true. + case ('ANGLDEGX') + call ReadArray(this%parser%iuactive, this%angldegxinp, aname(6), 1, & + this%njausr, this%iout, 0) + lname(6) = .true. + case default + write (errmsg, '(4x,a,a)') 'Unknown CONNECTIONDATA tag: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING CONNECTIONDATA' + write (this%iout, '(1x,a)') 'END PROCESSING CONNECTIONDATA' else call store_error('Required CONNECTIONDATA block not found.') call this%parser%StoreErrorUnit() @@ -967,23 +969,23 @@ subroutine read_connectivity(this) do n = 1, nname ! ! -- skip angledegx because it is not required - if(aname(n) == aname(6)) cycle + if (aname(n) == aname(6)) cycle ! ! -- error if not read - if(.not. lname(n)) then - write(errmsg,'(1x,a,a)') & + if (.not. lname(n)) then + write (errmsg, '(1x,a,a)') & 'REQUIRED CONNECTIONDATA INPUT WAS NOT SPECIFIED: ', & adjustl(trim(aname(n))) call store_error(errmsg) - endif - enddo + end if + end do if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if if (.not. lname(6)) then - write(this%iout, '(1x,a)') 'ANGLDEGX NOT FOUND IN CONNECTIONDATA ' // & - 'BLOCK. SOME CAPABILITIES MAY BE LIMITED.' - end if + write (this%iout, '(1x,a)') 'ANGLDEGX NOT FOUND IN CONNECTIONDATA '// & + 'BLOCK. SOME CAPABILITIES MAY BE LIMITED.' + end if ! ! -- Return return @@ -1006,29 +1008,29 @@ subroutine read_vertices(this) real(DP) :: xmin, xmax, ymin, ymax ! -- formats character(len=*), parameter :: fmtvnum = & - "('ERROR. VERTEX NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0," // & - "' BUT FOUND ', i0)" + "('ERROR. VERTEX NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& + &' BUT FOUND ', i0)" character(len=*), parameter :: fmtnvert = & - "(3x, 'SUCCESSFULLY READ ',i0,' (X,Y) COORDINATES')" + &"(3x, 'SUCCESSFULLY READ ',i0,' (X,Y) COORDINATES')" character(len=*), parameter :: fmtcoord = & - "(3x, a,' COORDINATE = ', 1(1pg24.15))" + &"(3x, a,' COORDINATE = ', 1(1pg24.15))" ! ------------------------------------------------------------------------------ ! ! --Read DISDATA block call this%parser%GetBlock('VERTICES', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING VERTICES' + if (isfound) then + write (this%iout, '(/,1x,a)') 'PROCESSING VERTICES' do i = 1, this%nvert call this%parser%GetNextLine(endOfBlock) ! ! -- vertex number ival = this%parser%GetInteger() - if(ival /= i) then - write(errmsg, fmtvnum) i, ival + if (ival /= i) then + write (errmsg, fmtvnum) i, ival call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- x this%vertices(1, i) = this%parser%GetDouble() @@ -1037,7 +1039,7 @@ subroutine read_vertices(this) this%vertices(2, i) = this%parser%GetDouble() ! ! -- set min/max coords - if(i == 1) then + if (i == 1) then xmin = this%vertices(1, i) xmax = xmin ymin = this%vertices(2, i) @@ -1047,8 +1049,8 @@ subroutine read_vertices(this) xmax = max(xmax, this%vertices(1, i)) ymin = min(ymin, this%vertices(2, i)) ymax = max(ymax, this%vertices(2, i)) - endif - enddo + end if + end do ! ! -- Terminate the block call this%parser%terminateblock() @@ -1058,12 +1060,12 @@ subroutine read_vertices(this) end if ! ! -- Write information - write(this%iout, fmtnvert) this%nvert - write(this%iout, fmtcoord) 'MINIMUM X', xmin - write(this%iout, fmtcoord) 'MAXIMUM X', xmax - write(this%iout, fmtcoord) 'MINIMUM Y', ymin - write(this%iout, fmtcoord) 'MAXIMUM Y', ymax - write(this%iout,'(1x,a)')'END PROCESSING VERTICES' + write (this%iout, fmtnvert) this%nvert + write (this%iout, fmtcoord) 'MINIMUM X', xmin + write (this%iout, fmtcoord) 'MAXIMUM X', xmax + write (this%iout, fmtcoord) 'MINIMUM Y', ymin + write (this%iout, fmtcoord) 'MAXIMUM Y', ymax + write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' ! ! -- Return return @@ -1092,14 +1094,14 @@ subroutine read_cell2d(this) type(sparsematrix) :: vertspm ! -- formats character(len=*), parameter :: fmtcnum = & - "('ERROR. CELL NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0," // & - "' BUT FOUND ', i0)" + "('ERROR. CELL NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& + &' BUT FOUND ', i0)" character(len=*), parameter :: fmtncpl = & - "(3x, 'SUCCESSFULLY READ ',i0,' CELL2D INFORMATION ENTRIES')" + &"(3x, 'SUCCESSFULLY READ ',i0,' CELL2D INFORMATION ENTRIES')" character(len=*), parameter :: fmtcoord = & - "(3x, a,' CELL CENTER = ', 1(1pg24.15))" + &"(3x, a,' CELL CENTER = ', 1(1pg24.15))" character(len=*), parameter :: fmtmaxvert = & - "(3x, 'MAXIMUM NUMBER OF CELL2D VERTICES IS ',i0,' FOR CELL ', i0)" + &"(3x, 'MAXIMUM NUMBER OF CELL2D VERTICES IS ',i0,' FOR CELL ', i0)" ! ------------------------------------------------------------------------------ ! ! -- initialize @@ -1111,26 +1113,26 @@ subroutine read_cell2d(this) ! temporarily store the vertex numbers for each cell. This will ! be converted to iavert and javert after all cell vertices have ! been read. - allocate(maxnnz(this%nodesuser)) + allocate (maxnnz(this%nodesuser)) do i = 1, this%nodesuser maxnnz(i) = 5 - enddo + end do call vertspm%init(this%nodesuser, this%nvert, maxnnz) ! ! --Read CELL2D block call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING CELL2D' + if (isfound) then + write (this%iout, '(/,1x,a)') 'PROCESSING CELL2D' do i = 1, this%nodesuser call this%parser%GetNextLine(endOfBlock) ! ! -- cell number ival = this%parser%GetInteger() - if(ival /= i) then - write(errmsg, fmtcnum) i, ival + if (ival /= i) then + write (errmsg, fmtcnum) i, ival call store_error(errmsg) call store_error_unit(iuext) - endif + end if ! ! -- Cell x center this%cellxy(1, i) = this%parser%GetDouble() @@ -1140,10 +1142,10 @@ subroutine read_cell2d(this) ! ! -- Number of vertices for this cell ncvert = this%parser%GetInteger() - if(ncvert > maxvert) then + if (ncvert > maxvert) then maxvert = ncvert maxvertcell = i - endif + end if ! ! -- Read each vertex number, and then close the polygon if ! the last vertex does not equal the first vertex @@ -1152,17 +1154,17 @@ subroutine read_cell2d(this) call vertspm%addconnection(i, ivert, 0) ! ! -- If necessary, repeat the last vertex in order to close the cell - if(j == 1) then + if (j == 1) then ivert1 = ivert - elseif(j == ncvert) then - if(ivert1 /= ivert) then + elseif (j == ncvert) then + if (ivert1 /= ivert) then call vertspm%addconnection(i, ivert1, 0) - endif - endif - enddo + end if + end if + end do ! ! -- set min/max coords - if(i == 1) then + if (i == 1) then xmin = this%cellxy(1, i) xmax = xmin ymin = this%cellxy(2, i) @@ -1172,8 +1174,8 @@ subroutine read_cell2d(this) xmax = max(xmax, this%cellxy(1, i)) ymin = min(ymin, this%cellxy(2, i)) ymax = max(ymax, this%cellxy(2, i)) - endif - enddo + end if + end do ! ! -- Terminate the block call this%parser%terminateblock() @@ -1185,18 +1187,18 @@ subroutine read_cell2d(this) ! -- Convert vertspm into ia/ja form call mem_allocate(this%iavert, this%nodesuser + 1, 'IAVERT', this%memoryPath) call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%memoryPath) - + call vertspm%filliaja(this%iavert, this%javert, ierr) call vertspm%destroy() ! ! -- Write information - write(this%iout, fmtncpl) this%nodesuser - write(this%iout, fmtcoord) 'MINIMUM X', xmin - write(this%iout, fmtcoord) 'MAXIMUM X', xmax - write(this%iout, fmtcoord) 'MINIMUM Y', ymin - write(this%iout, fmtcoord) 'MAXIMUM Y', ymax - write(this%iout, fmtmaxvert) maxvert, maxvertcell - write(this%iout,'(1x,a)')'END PROCESSING VERTICES' + write (this%iout, fmtncpl) this%nodesuser + write (this%iout, fmtcoord) 'MINIMUM X', xmin + write (this%iout, fmtcoord) 'MAXIMUM X', xmax + write (this%iout, fmtcoord) 'MINIMUM Y', ymin + write (this%iout, fmtcoord) 'MAXIMUM Y', ymax + write (this%iout, fmtmaxvert) maxvert, maxvertcell + write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' ! ! -- Return return @@ -1221,8 +1223,8 @@ subroutine write_grb(this, icelltype) character(len=50) :: txthdr character(len=lentxt) :: txt character(len=LINELENGTH) :: fname - character(len=*),parameter :: fmtgrdsave = & - "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & + character(len=*), parameter :: fmtgrdsave = & + "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" ! ------------------------------------------------------------------------------ ! @@ -1231,101 +1233,101 @@ subroutine write_grb(this, icelltype) if (this%nvert > 0) ntxt = ntxt + 5 ! ! -- Open the file - inquire(unit=this%inunit, name=fname) - fname = trim(fname) // '.grb' + inquire (unit=this%inunit, name=fname) + fname = trim(fname)//'.grb' iunit = getunit() - write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) - call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & + write (this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) + call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & form, access, 'REPLACE') ! ! -- write header information - write(txthdr, '(a)') 'GRID DISU' + write (txthdr, '(a)') 'GRID DISU' txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a)') 'VERSION 1' + write (iunit) txthdr + write (txthdr, '(a)') 'VERSION 1' txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'NTXT ', ntxt + write (iunit) txthdr + write (txthdr, '(a, i0)') 'NTXT ', ntxt txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'LENTXT ', lentxt + write (iunit) txthdr + write (txthdr, '(a, i0)') 'LENTXT ', lentxt txthdr(50:50) = new_line('a') - write(iunit) txthdr + write (iunit) txthdr ! ! -- write variable definitions - write(txt, '(3a, i0)') 'NODES ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser + write (txt, '(3a, i0)') 'NODES ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja + write (iunit) txt + write (txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin + write (iunit) txt + write (txt, '(3a, 1pg24.15)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin + write (iunit) txt + write (txt, '(3a, 1pg24.15)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot + write (iunit) txt + write (txt, '(3a, 1pg24.15)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOT ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'BOT ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + write (iunit) txt + write (txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', this%con%nja + write (iunit) txt + write (txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', this%con%nja txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt + write (iunit) txt ! ! -- if vertices have been read then write additional header information if (this%nvert > 0) then - write(txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert + write (txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + write (iunit) txt + write (txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) + write (iunit) txt + write (txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - endif + write (iunit) txt + end if ! ! -- write data - write(iunit) this%nodesuser ! nodes - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%top1d ! top - write(iunit) this%bot1d ! bot - write(iunit) this%con%iausr ! ia - write(iunit) this%con%jausr ! ja - write(iunit) icelltype ! icelltype + write (iunit) this%nodesuser ! nodes + write (iunit) this%nja ! nja + write (iunit) this%xorigin ! xorigin + write (iunit) this%yorigin ! yorigin + write (iunit) this%angrot ! angrot + write (iunit) this%top1d ! top + write (iunit) this%bot1d ! bot + write (iunit) this%con%iausr ! ia + write (iunit) this%con%jausr ! ja + write (iunit) icelltype ! icelltype ! ! -- if vertices have been read then write additional data if (this%nvert > 0) then - write(iunit) this%vertices ! vertices - write(iunit) (this%cellxy(1, i), i = 1, this%nodesuser) ! cellx - write(iunit) (this%cellxy(2, i), i = 1, this%nodesuser) ! celly - write(iunit) this%iavert ! iavert - write(iunit) this%javert ! javert - endif + write (iunit) this%vertices ! vertices + write (iunit) (this%cellxy(1, i), i=1, this%nodesuser) ! cellx + write (iunit) (this%cellxy(2, i), i=1, this%nodesuser) ! celly + write (iunit) this%iavert ! iavert + write (iunit) this%javert ! javert + end if ! ! -- Close the file - close(iunit) + close (iunit) ! ! -- return return @@ -1350,13 +1352,13 @@ function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) integer(I4B) :: nodenumber ! ------------------------------------------------------------------------------ ! - if(icheck /= 0) then - if(nodeu < 1 .or. nodeu > this%nodes) then - write(errmsg, '(a,i10)') & + if (icheck /= 0) then + if (nodeu < 1 .or. nodeu > this%nodes) then + write (errmsg, '(a,i10)') & 'Nodenumber less than 1 or greater than nodes:', nodeu call store_error(errmsg) - endif - endif + end if + end if ! ! -- set node number to passed in nodenumber since there is a one to one ! mapping for an unstructured grid @@ -1370,7 +1372,7 @@ function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) return end function get_nodenumber_idx1 - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ipos) ! ****************************************************************************** ! connection_normal -- calculate the normal vector components for reduced @@ -1396,12 +1398,12 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! ------------------------------------------------------------------------------ ! ! -- Set vector components based on ihc - if(ihc == 0) then + if (ihc == 0) then ! ! -- connection is vertical xcomp = DZERO ycomp = DZERO - if(nodem < noden) then + if (nodem < noden) then ! ! -- nodem must be above noden, so upward connection zcomp = DONE @@ -1409,7 +1411,7 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! ! -- nodem must be below noden, so downward connection zcomp = -DONE - endif + end if else ! -- find from anglex, since anglex is symmetric, need to flip vector ! for lower triangle (nodem < noden) @@ -1419,13 +1421,13 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & xcomp = cos(angle) * dmult ycomp = sin(angle) * dmult zcomp = DZERO - endif + end if ! ! -- return return end subroutine connection_normal - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & xcomp, ycomp, zcomp, conlen) ! ****************************************************************************** ! connection_vector -- calculate the unit vector components from reduced @@ -1459,9 +1461,9 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & ! ! -- Terminate with error if requesting unit vector components for problems ! without cell data - if (size(this%cellxy,2) < 1) then - write(errmsg, '(a)') & - 'Cannot calculate unit vector components for DISU grid if VERTEX ' // & + if (size(this%cellxy, 2) < 1) then + write (errmsg, '(a)') & + 'Cannot calculate unit vector components for DISU grid if VERTEX '// & 'data are not specified' call store_error(errmsg, terminate=.TRUE.) end if @@ -1471,7 +1473,7 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & call this%get_cellxy(nodem, xm, ym) ! ! -- Set vector components based on ihc - if(ihc == 0) then + if (ihc == 0) then ! ! -- vertical connection, calculate z as cell center elevation zn = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) @@ -1486,11 +1488,11 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & else zn = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) zm = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) - endif - endif + end if + end if ! ! -- Use coords to find vector components and connection length - call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & + call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & conlen) ! ! -- return @@ -1504,9 +1506,9 @@ subroutine get_cellxy_disu(this, node, xcell, ycell) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - class(GwfDisuType), intent(in) :: this - integer(I4B), intent(in) :: node ! the reduced node number - real(DP), intent(out) :: xcell, ycell ! the x,y for the cell + class(GwfDisuType), intent(in) :: this + integer(I4B), intent(in) :: node ! the reduced node number + real(DP), intent(out) :: xcell, ycell ! the x,y for the cell ! -- local integer(I4B) :: nu ! ------------------------------------------------------------------------------ @@ -1520,14 +1522,14 @@ subroutine get_cellxy_disu(this, node, xcell, ycell) ! -- return return end subroutine get_cellxy_disu - + ! return discretization type subroutine get_dis_type(this, dis_type) - class(GwfDisuType), intent(in) :: this - character(len=*), intent(out) :: dis_type - + class(GwfDisuType), intent(in) :: this + character(len=*), intent(out) :: dis_type + dis_type = "DISU" - + end subroutine get_dis_type subroutine allocate_scalars(this, name_model) @@ -1584,13 +1586,14 @@ subroutine allocate_arrays(this) call this%DisBaseType%allocate_arrays() ! ! -- Allocate arrays in DISU - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%memoryPath) - call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', this%memoryPath) + call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & + this%memoryPath) else call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%memoryPath) call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%memoryPath) - endif + end if ! ! -- Initialize this%mshape(1) = this%nodesuser @@ -1602,11 +1605,11 @@ end subroutine allocate_arrays subroutine allocate_arrays_mem(this) use MemoryManagerModule, only: mem_allocate class(GwfDisuType) :: this - + call mem_allocate(this%idomain, this%nodes, 'IDOMAIN', this%memoryPath) call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%memoryPath) call mem_allocate(this%cellxy, 2, this%nodes, 'CELLXY', this%memoryPath) - + end subroutine allocate_arrays_mem function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & @@ -1628,7 +1631,7 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & integer(I4B), intent(inout) :: istop integer(I4B), intent(in) :: in integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line + character(len=*), intent(inout) :: line logical, optional, intent(in) :: flag_string logical, optional, intent(in) :: allow_zero integer(I4B) :: nodeu @@ -1643,14 +1646,14 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & ! Check to see if first token in line can be read as an integer. lloclocal = lloc call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) - read(line(istart:istop),*,iostat=istat)n + read (line(istart:istop), *, iostat=istat) n if (istat /= 0) then ! First token in line is not an integer; return flag to this effect. nodeu = -2 return - endif - endif - endif + end if + end if + end if ! call urword(line, lloc, istart, istop, 2, nodeu, r, iout, in) ! @@ -1658,14 +1661,14 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & if (present(allow_zero)) then if (allow_zero) then return - endif - endif - endif + end if + end if + end if ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, *) ' Node number in list is outside of the grid', nodeu + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (errmsg, *) ' Node number in list is outside of the grid', nodeu call store_error(errmsg) - inquire(unit=in, name=fname) + inquire (unit=in, name=fname) call store_error('Error converting in file: ') call store_error(trim(adjustl(fname))) call store_error('Cell number cannot be determined in line: ') @@ -1679,7 +1682,7 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & end function nodeu_from_string function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) + allow_zero) result(nodeu) ! ****************************************************************************** ! nodeu_from_cellid -- Receive cellid as a string and convert the string to a ! user nodenumber. @@ -1714,14 +1717,14 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & ! Check to see if first token in cellid can be read as an integer. lloclocal = 1 call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) - read(cellid(istart:istop), *, iostat=istat) n + read (cellid(istart:istop), *, iostat=istat) n if (istat /= 0) then ! First token in cellid is not an integer; return flag to this effect. nodeu = -2 return - endif - endif - endif + end if + end if + end if ! lloclocal = 1 call urword(cellid, lloclocal, istart, istop, 2, nodeu, r, iout, inunit) @@ -1730,14 +1733,14 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & if (present(allow_zero)) then if (allow_zero) then return - endif - endif - endif + end if + end if + end if ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, *) ' Node number in list is outside of the grid', nodeu + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (errmsg, *) ' Node number in list is outside of the grid', nodeu call store_error(errmsg) - inquire(unit=inunit, name=fname) + inquire (unit=inunit, name=fname) call store_error('Error converting in file: ') call store_error(trim(adjustl(fname))) call store_error('Cell number cannot be determined in cellid: ') @@ -1792,15 +1795,15 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfDisuType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(GwfDisuType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! -- local integer(I4B) :: nval integer(I4B), dimension(:), pointer, contiguous :: itemp @@ -1810,22 +1813,22 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & ! subroutine. The temporary array will point to ibuff if it is a ! reduced structured system, or to iarray if it is an unstructured ! model. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodesuser itemp => this%ibuff else nval = this%nodes itemp => iarray - endif + end if ! ! -- Read the array ! -- Read unstructured input call ReadArray(in, itemp, aname, this%ndim, nval, iout, 0) ! ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call this%fill_grid_array(itemp, iarray) - endif + end if ! ! -- return return @@ -1844,15 +1847,15 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfDisuType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(GwfDisuType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! -- local integer(I4B) :: nval real(DP), dimension(:), pointer, contiguous :: dtemp @@ -1862,28 +1865,28 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & ! subroutine. The temporary array will point to dbuff if it is a ! reduced structured system, or to darray if it is an unstructured ! model. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodesuser dtemp => this%dbuff else nval = this%nodes dtemp => darray - endif + end if ! ! -- Read the array call ReadArray(in, dtemp, aname, this%ndim, nval, iout, 0) ! ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call this%fill_grid_array(dtemp, darray) - endif + end if ! ! -- return return end subroutine read_dbl_array - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) ! ****************************************************************************** ! record_array -- Record a double precision array. The array will be ! printed to an external file and/or written to an unformatted external file @@ -1906,17 +1909,17 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwfDisuType), intent(inout) :: this + class(GwfDisuType), intent(inout) :: this real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact ! -- local integer(I4B) :: k, ifirst integer(I4B) :: nlay @@ -1927,7 +1930,7 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & integer(I4B) :: istart, istop real(DP), dimension(:), pointer, contiguous :: dtemp ! -- formats - character(len=*),parameter :: fmthsv = & + character(len=*), parameter :: fmthsv = & "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" ! ------------------------------------------------------------------------------ @@ -1939,61 +1942,61 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! ! -- If this is a reduced model, then copy the values from darray into ! dtemp. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodes dtemp => this%dbuff do nodeu = 1, this%nodesuser noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then + if (noder <= 0) then dtemp(nodeu) = dinact cycle - endif + end if dtemp(nodeu) = darray(noder) - enddo + end do else nval = this%nodes dtemp => darray - endif + end if ! ! -- Print to iout if iprint /= 0 - if(iprint /= 0) then + if (iprint /= 0) then istart = 1 do k = 1, nlay istop = istart + nrow * ncol - 1 - call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & + call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & aname, cdatafmp, nvaluesp, nwidthp, editdesc) istart = istop + 1 - enddo - endif + end do + end if ! ! -- Save array to an external file. - if(idataun > 0) then + if (idataun > 0) then ! -- write to binary file by layer ifirst = 1 istart = 1 - do k=1, nlay + do k = 1, nlay istop = istart + nrow * ncol - 1 - if(ifirst == 1) write(iout, fmthsv) & - trim(adjustl(aname)), idataun, & - kstp, kper + if (ifirst == 1) write (iout, fmthsv) & + trim(adjustl(aname)), idataun, & + kstp, kper ifirst = 0 - call ulasav(dtemp(istart:istop), aname, kstp, kper, & + call ulasav(dtemp(istart:istop), aname, kstp, kper, & pertim, totim, ncol, nrow, k, idataun) istart = istop + 1 - enddo - elseif(idataun < 0) then + end do + elseif (idataun < 0) then ! ! -- write entire array as one record - call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & + call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & iout, delt, pertim, totim) - endif + end if ! ! -- return return end subroutine record_array - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & ibdchn, nlist, iout) ! ****************************************************************************** ! record_srcdst_list_header -- Record list header for imeth=6 @@ -2022,8 +2025,8 @@ subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & ncol = this%mshape(1) ! ! -- Use ubdsv06 to write list header - call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& - ibdchn, naux, auxtxt, ncol, nrow, nlay, & + call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage, & + ibdchn, naux, auxtxt, ncol, nrow, nlay, & nlist, iout, delt, pertim, totim) ! ! -- return @@ -2033,11 +2036,11 @@ end subroutine record_srcdst_list_header !> @brief Cast base to DISU !< function CastAsDisuType(dis) result(disu) - class(*), pointer :: dis !< base pointer to DISU object + class(*), pointer :: dis !< base pointer to DISU object class(GwfDisuType), pointer :: disu !< the resulting DISU pointer disu => null() - select type(dis) + select type (dis) class is (GwfDisuType) disu => dis end select diff --git a/src/Model/GroundWaterFlow/gwf3disv8.f90 b/src/Model/GroundWaterFlow/gwf3disv8.f90 index 95476e6b8d4..f04222ad552 100644 --- a/src/Model/GroundWaterFlow/gwf3disv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disv8.f90 @@ -10,25 +10,25 @@ module GwfDisvModule use DisvGeom, only: DisvGeomType use BlockParserModule, only: BlockParserType use MemoryManagerModule, only: mem_allocate - use TdisModule, only: kstp, kper, pertim, totim, delt + use TdisModule, only: kstp, kper, pertim, totim, delt implicit none private public disv_cr, disv_init_mem, GwfDisvType type, extends(DisBaseType) :: GwfDisvType - integer(I4B), pointer :: nlay => null() ! number of layers - integer(I4B), pointer :: ncpl => null() ! number of cells per layer - integer(I4B), pointer :: nvert => null() ! number of x,y vertices - real(DP), dimension(:,:), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y - real(DP), dimension(:,:), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y - integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array - integer(I4B), dimension(:), pointer, contiguous :: javert => null() ! cell vertex pointer ja array - real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncpl, 1) - real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncpl, 1, nlay) - integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncpl, 1, nlay) - type(DisvGeomType) :: cell1 ! cell object used to calculate geometric properties - type(DisvGeomType) :: cell2 ! cell object used to calculate geometric properties + integer(I4B), pointer :: nlay => null() ! number of layers + integer(I4B), pointer :: ncpl => null() ! number of cells per layer + integer(I4B), pointer :: nvert => null() ! number of x,y vertices + real(DP), dimension(:, :), pointer, contiguous :: vertices => null() ! cell vertices stored as 2d array of x and y + real(DP), dimension(:, :), pointer, contiguous :: cellxy => null() ! cell center stored as 2d array of x and y + integer(I4B), dimension(:), pointer, contiguous :: iavert => null() ! cell vertex pointer ia array + integer(I4B), dimension(:), pointer, contiguous :: javert => null() ! cell vertex pointer ja array + real(DP), dimension(:, :), pointer, contiguous :: top2d => null() ! top elevations for each cell at top of model (ncpl, 1) + real(DP), dimension(:, :, :), pointer, contiguous :: bot3d => null() ! bottom elevations for each cell (ncpl, 1, nlay) + integer(I4B), dimension(:, :, :), pointer, contiguous :: idomain => null() ! idomain (ncpl, 1, nlay) + type(DisvGeomType) :: cell1 ! cell object used to calculate geometric properties + type(DisvGeomType) :: cell2 ! cell object used to calculate geometric properties contains procedure :: dis_df => disv_df procedure :: dis_da => disv_da @@ -67,7 +67,7 @@ module GwfDisvModule ! end type GwfDisvType - contains +contains subroutine disv_cr(dis, name_model, inunit, iout) ! ****************************************************************************** @@ -82,7 +82,7 @@ subroutine disv_cr(dis, name_model, inunit, iout) integer(I4B), intent(in) :: iout type(GwfDisvType), pointer :: disnew ! ------------------------------------------------------------------------------ - allocate(disnew) + allocate (disnew) dis => disnew call disnew%allocate_scalars(name_model) dis%inunit = inunit @@ -94,8 +94,8 @@ subroutine disv_cr(dis, name_model, inunit, iout) ! -- Return return end subroutine disv_cr - - subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & + + subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & top2d, bot3d, vertices, cellxy, idomain) ! ****************************************************************************** ! dis_init_mem -- Create a new discretization by vertices object from memory @@ -112,7 +112,7 @@ subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & real(DP), dimension(:, :, :), pointer, contiguous, intent(in) :: bot3d integer(I4B), dimension(:, :), pointer, contiguous, intent(in) :: vertices integer(I4B), dimension(:, :), pointer, contiguous, intent(in) :: cellxy - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(in), & optional :: idomain ! -- local type(GwfDisvType), pointer :: disext @@ -122,7 +122,7 @@ subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & integer(I4B) :: ival ! -- local ! ------------------------------------------------------------------------------ - allocate(disext) + allocate (disext) dis => disext call disext%allocate_scalars(name_model) dis%inunit = 0 @@ -136,14 +136,15 @@ subroutine disv_init_mem(dis, name_model, iout, nlay, ncpl, & disext%nodesuser = disext%nlay * disext%ncpl ! ! -- Allocate non-reduced vectors for disv - call mem_allocate(disext%idomain, disext%ncpl, 1, disext%nlay, 'IDOMAIN', & + call mem_allocate(disext%idomain, disext%ncpl, 1, disext%nlay, 'IDOMAIN', & disext%memoryPath) call mem_allocate(disext%top2d, disext%ncpl, 1, 'TOP2D', disext%memoryPath) - call mem_allocate(disext%bot3d, disext%ncpl, 1, disext%nlay, 'BOT3D', & + call mem_allocate(disext%bot3d, disext%ncpl, 1, disext%nlay, 'BOT3D', & disext%memoryPath) ! ! -- Allocate vertices array - call mem_allocate(disext%vertices, 2, disext%nvert, 'VERTICES', disext%memoryPath) + call mem_allocate(disext%vertices, 2, disext%nvert, 'VERTICES', & + disext%memoryPath) call mem_allocate(disext%cellxy, 2, disext%ncpl, 'CELLXY', disext%memoryPath) ! ! -- fill data @@ -192,9 +193,9 @@ subroutine disv_df(this) if (this%inunit /= 0) then ! ! -- Identify package - write(this%iout,1) this%inunit - 1 format(1X,/1X,'DISV -- VERTEX GRID DISCRETIZATION PACKAGE,', & - ' VERSION 1 : 12/23/2015 - INPUT READ FROM UNIT ',I0,//) + write (this%iout, 1) this%inunit +1 format(1X, /1X, 'DISV -- VERTEX GRID DISCRETIZATION PACKAGE,', & + ' VERSION 1 : 12/23/2015 - INPUT READ FROM UNIT ', I0, //) ! ! -- Read options call this%read_options() @@ -274,63 +275,65 @@ subroutine read_options(this) ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- set default options - this%lenuni = 0 + this%lenuni = 0 ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(/,1x,a)')'PROCESSING DISCRETIZATION OPTIONS' + write (this%iout, '(/,1x,a)') 'PROCESSING DISCRETIZATION OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('LENGTH_UNITS') - call this%parser%GetStringCaps(keyword) - if(keyword=='FEET') then - this%lenuni = 1 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS FEET' - elseif(keyword=='METERS') then - this%lenuni = 2 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS METERS' - elseif(keyword=='CENTIMETERS') then - this%lenuni = 3 - write(this%iout,'(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' - else - write(this%iout,'(4x,a)')'UNKNOWN UNIT: ',trim(keyword) - write(this%iout,'(4x,a)')'SETTING TO: ','UNDEFINED' - endif - case('NOGRB') - write(this%iout,'(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' - this%writegrb = .false. - case('XORIGIN') - this%xorigin = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & - this%xorigin - case('YORIGIN') - this%yorigin = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & - this%yorigin - case('ANGROT') - this%angrot = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & - this%angrot - case default - write(errmsg,'(4x,a,a)')'Unknown DIS option: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('LENGTH_UNITS') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FEET') then + this%lenuni = 1 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS FEET' + elseif (keyword == 'METERS') then + this%lenuni = 2 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS METERS' + elseif (keyword == 'CENTIMETERS') then + this%lenuni = 3 + write (this%iout, '(4x,a)') 'MODEL LENGTH UNIT IS CENTIMETERS' + else + write (this%iout, '(4x,a)') 'UNKNOWN UNIT: ', trim(keyword) + write (this%iout, '(4x,a)') 'SETTING TO: ', 'UNDEFINED' + end if + case ('NOGRB') + write (this%iout, '(4x,a)') 'BINARY GRB FILE WILL NOT BE WRITTEN' + this%writegrb = .false. + case ('XORIGIN') + this%xorigin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'XORIGIN SPECIFIED AS ', & + this%xorigin + case ('YORIGIN') + this%yorigin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'YORIGIN SPECIFIED AS ', & + this%yorigin + case ('ANGROT') + this%angrot = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg24.15)') 'ANGROT SPECIFIED AS ', & + this%angrot + case default + write (errmsg, '(4x,a,a)') 'Unknown DIS option: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do else - write(this%iout,'(1x,a)')'NO DISV OPTION BLOCK DETECTED.' + write (this%iout, '(1x,a)') 'NO DISV OPTION BLOCK DETECTED.' + end if + if (this%lenuni == 0) then + write (this%iout, '(3x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' + end if + if (isfound) then + write (this%iout, '(1x,a)') 'END OF DISCRETIZATION OPTIONS' end if - if(this%lenuni==0) write(this%iout,'(3x,a)') 'MODEL LENGTH UNIT IS UNDEFINED' - if(isfound) then - write(this%iout,'(1x,a)')'END OF DISCRETIZATION OPTIONS' - endif ! ! -- Return return @@ -343,7 +346,7 @@ subroutine read_dimensions(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfDisvType) :: this ! -- locals @@ -360,26 +363,26 @@ subroutine read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/,1x,a)')'PROCESSING DISCRETIZATION DIMENSIONS' + write (this%iout, '(/,1x,a)') 'PROCESSING DISCRETIZATION DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NLAY') - this%nlay = this%parser%GetInteger() - write(this%iout,'(3x,a,i0)')'NLAY = ', this%nlay - case ('NCPL') - this%ncpl = this%parser%GetInteger() - write(this%iout,'(3x,a,i0)')'NCPL = ', this%ncpl - case ('NVERT') - this%nvert = this%parser%GetInteger() - write(this%iout,'(3x,a,i0)')'NVERT = ', this%nvert - case default - write(errmsg,'(4x,a,a)')'Unknown DISV dimension: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('NLAY') + this%nlay = this%parser%GetInteger() + write (this%iout, '(3x,a,i0)') 'NLAY = ', this%nlay + case ('NCPL') + this%ncpl = this%parser%GetInteger() + write (this%iout, '(3x,a,i0)') 'NCPL = ', this%ncpl + case ('NVERT') + this%nvert = this%parser%GetInteger() + write (this%iout, '(3x,a,i0)') 'NVERT = ', this%nvert + case default + write (errmsg, '(4x,a,a)') 'Unknown DISV dimension: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do else @@ -388,31 +391,32 @@ subroutine read_dimensions(this) end if ! ! -- verify dimensions were set - if(this%nlay < 1) then + if (this%nlay < 1) then call store_error( & - 'NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + 'NLAY WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() - endif - if(this%ncpl < 1) then + end if + if (this%ncpl < 1) then call store_error( & - 'NCPL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + 'NCPL WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() - endif - if(this%nvert < 1) then + end if + if (this%nvert < 1) then call store_error( & - 'NVERT WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') + 'NVERT WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.') call this%parser%StoreErrorUnit() - endif - write(this%iout,'(1x,a)')'END OF DISCRETIZATION DIMENSIONS' + end if + write (this%iout, '(1x,a)') 'END OF DISCRETIZATION DIMENSIONS' ! ! -- Calculate nodesuser this%nodesuser = this%nlay * this%ncpl ! ! -- Allocate non-reduced vectors for disv - call mem_allocate(this%idomain, this%ncpl, 1, this%nlay, 'IDOMAIN', & + call mem_allocate(this%idomain, this%ncpl, 1, this%nlay, 'IDOMAIN', & this%memoryPath) call mem_allocate(this%top2d, this%ncpl, 1, 'TOP2D', this%memoryPath) - call mem_allocate(this%bot3d, this%ncpl, 1, this%nlay, 'BOT3D', this%memoryPath) + call mem_allocate(this%bot3d, this%ncpl, 1, this%nlay, 'BOT3D', & + this%memoryPath) ! ! -- Allocate vertices array call mem_allocate(this%vertices, 2, this%nvert, 'VERTICES', this%memoryPath) @@ -438,7 +442,7 @@ subroutine read_mf6_griddata(this) ! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, DZERO ! -- dummy class(GwfDisvType) :: this ! -- locals @@ -448,68 +452,68 @@ subroutine read_mf6_griddata(this) logical :: isfound, endOfBlock integer(I4B), parameter :: nname = 3 logical, dimension(nname) :: lname - character(len=24),dimension(nname) :: aname + character(len=24), dimension(nname) :: aname character(len=300) :: ermsg ! -- formats character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',i0,') THICKNESS <= 0. ', " // & - "'TOP, BOT: ',2(1pg24.15))" + "('ERROR. CELL (',i0,',',i0,') THICKNESS <= 0. ', & + &'TOP, BOT: ',2(1pg24.15))" character(len=*), parameter :: fmtnr = & - "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.'," // & - "/1x, 'NUMBER OF USER NODES: ',I0," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" + "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.',& + &/1x, 'NUMBER OF USER NODES: ',I0,& + &/1X, 'NUMBER OF NODES IN SOLUTION: ', I0, //)" ! -- data - data aname(1) /'TOP ELEVATION OF LAYER 1'/ - data aname(2) /' MODEL LAYER BOTTOM EL.'/ - data aname(3) /' IDOMAIN'/ + data aname(1)/'TOP ELEVATION OF LAYER 1'/ + data aname(2)/' MODEL LAYER BOTTOM EL.'/ + data aname(3)/' IDOMAIN'/ ! ------------------------------------------------------------------------------ ! ! --Read GRIDDATA block call this%parser%GetBlock('GRIDDATA', isfound, ierr) lname(:) = .false. - if(isfound) then - write(this%iout,'(/,1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(/,1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('TOP') - call ReadArray(this%parser%iuactive, this%top2d(:, :), & - aname(1), this%ndim, this%ncpl, 1, this%iout, 0) - lname(1) = .true. - case ('BOTM') - call this%parser%GetStringCaps(keyword) - if (keyword.EQ.'LAYERED') then - call ReadArray(this%parser%iuactive, & - this%bot3d(:,:,:), aname(2), this%ndim, & - this%ncpl, 1, this%nlay, this%iout, 1, this%nlay) - else - call ReadArray(this%parser%iuactive, & - this%bot3d(:, :, :), aname(2), & - this%ndim, this%nodesuser, 1, 1, this%iout, 0, 0) - end if - lname(2) = .true. - case ('IDOMAIN') - call this%parser%GetStringCaps(keyword) - if (keyword.EQ.'LAYERED') then - call ReadArray(this%parser%iuactive, this%idomain, aname(3), & - this%ndim, this%ncpl, 1, this%nlay, this%iout, & - 1, this%nlay) - else - call ReadArray(this%parser%iuactive, this%idomain, aname(3), & - this%ndim, this%nodesuser, 1, 1, this%iout, & - 0, 0) - end if - lname(3) = .true. - case default - write(ermsg,'(4x,a,a)')'Unknown GRIDDATA tag: ', & - trim(keyword) - call store_error(ermsg) - call this%parser%StoreErrorUnit() + case ('TOP') + call ReadArray(this%parser%iuactive, this%top2d(:, :), & + aname(1), this%ndim, this%ncpl, 1, this%iout, 0) + lname(1) = .true. + case ('BOTM') + call this%parser%GetStringCaps(keyword) + if (keyword .EQ. 'LAYERED') then + call ReadArray(this%parser%iuactive, & + this%bot3d(:, :, :), aname(2), this%ndim, & + this%ncpl, 1, this%nlay, this%iout, 1, this%nlay) + else + call ReadArray(this%parser%iuactive, & + this%bot3d(:, :, :), aname(2), & + this%ndim, this%nodesuser, 1, 1, this%iout, 0, 0) + end if + lname(2) = .true. + case ('IDOMAIN') + call this%parser%GetStringCaps(keyword) + if (keyword .EQ. 'LAYERED') then + call ReadArray(this%parser%iuactive, this%idomain, aname(3), & + this%ndim, this%ncpl, 1, this%nlay, this%iout, & + 1, this%nlay) + else + call ReadArray(this%parser%iuactive, this%idomain, aname(3), & + this%ndim, this%nodesuser, 1, 1, this%iout, & + 0, 0) + end if + lname(3) = .true. + case default + write (ermsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', & + trim(keyword) + call store_error(ermsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() @@ -517,20 +521,20 @@ subroutine read_mf6_griddata(this) ! ! -- Verify all required items were read (IDOMAIN not required) do n = 1, nname - 1 - if(.not. lname(n)) then - write(ermsg,'(1x,a,a)') & - 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ',aname(n) + if (.not. lname(n)) then + write (ermsg, '(1x,a,a)') & + 'ERROR. REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) call store_error(ermsg) - endif - enddo + end if + end do if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return end subroutine read_mf6_griddata - + subroutine grid_finalize(this) ! ****************************************************************************** ! grid_finalize -- Finalize grid @@ -540,7 +544,7 @@ subroutine grid_finalize(this) ! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, DZERO ! -- dummy class(GwfDisvType) :: this ! -- locals @@ -550,12 +554,12 @@ subroutine grid_finalize(this) character(len=300) :: ermsg ! -- formats character(len=*), parameter :: fmtdz = & - "('ERROR. CELL (',i0,',',i0,') THICKNESS <= 0. ', " // & - "'TOP, BOT: ',2(1pg24.15))" + "('ERROR. CELL (',i0,',',i0,') THICKNESS <= 0. ', & + &'TOP, BOT: ',2(1pg24.15))" character(len=*), parameter :: fmtnr = & - "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.'," // & - "/1x, 'NUMBER OF USER NODES: ',I7," // & - "/1X, 'NUMBER OF NODES IN SOLUTION: ', I7, //)" + "(/1x, 'THE SPECIFIED IDOMAIN RESULTS IN A REDUCED NUMBER OF CELLS.',& + &/1x, 'NUMBER OF USER NODES: ',I7,& + &/1X, 'NUMBER OF NODES IN SOLUTION: ', I7, //)" ! -- data ! ------------------------------------------------------------------------------ ! @@ -563,9 +567,9 @@ subroutine grid_finalize(this) this%nodes = 0 do k = 1, this%nlay do j = 1, this%ncpl - if(this%idomain(j, 1, k) > 0) this%nodes = this%nodes + 1 - enddo - enddo + if (this%idomain(j, 1, k) > 0) this%nodes = this%nodes + 1 + end do + end do ! ! -- Check to make sure nodes is a valid number if (this%nodes == 0) then @@ -587,20 +591,20 @@ subroutine grid_finalize(this) end if dz = top - this%bot3d(j, 1, k) if (dz <= DZERO) then - write(ermsg, fmt=fmtdz) k, j, top, this%bot3d(j, 1, k) + write (ermsg, fmt=fmtdz) k, j, top, this%bot3d(j, 1, k) call store_error(ermsg) - endif - endif - enddo - enddo + end if + end if + end do + end do if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Write message if reduced grid - if(this%nodes < this%nodesuser) then - write(this%iout, fmtnr) this%nodesuser, this%nodes - endif + if (this%nodes < this%nodesuser) then + write (this%iout, fmtnr) this%nodesuser, this%nodes + end if ! ! -- Array size is now known, so allocate call this%allocate_arrays() @@ -609,38 +613,38 @@ subroutine grid_finalize(this) ! a negative number to indicate it is a pass-through cell, or ! a zero to indicate that the cell is excluded from the ! solution. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then node = 1 noder = 1 do k = 1, this%nlay do j = 1, this%ncpl - if(this%idomain(j, 1, k) > 0) then + if (this%idomain(j, 1, k) > 0) then this%nodereduced(node) = noder noder = noder + 1 - elseif(this%idomain(j, 1, k) < 0) then + elseif (this%idomain(j, 1, k) < 0) then this%nodereduced(node) = -1 else this%nodereduced(node) = 0 - endif + end if node = node + 1 - enddo - enddo - endif + end do + end do + end if ! ! -- allocate and fill nodeuser if a reduced grid - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then node = 1 noder = 1 do k = 1, this%nlay do j = 1, this%ncpl - if(this%idomain(j, 1, k) > 0) then + if (this%idomain(j, 1, k) > 0) then this%nodeuser(noder) = node noder = noder + 1 - endif + end if node = node + 1 - enddo - enddo - endif + end do + end do + end if ! ! -- Move top2d and bot3d into top and bot, and calculate area node = 0 @@ -648,8 +652,8 @@ subroutine grid_finalize(this) do j = 1, this%ncpl node = node + 1 noder = node - if(this%nodes < this%nodesuser) noder = this%nodereduced(node) - if(noder <= 0) cycle + if (this%nodes < this%nodesuser) noder = this%nodereduced(node) + if (noder <= 0) cycle if (k > 1) then top = this%bot3d(j, 1, k - 1) else @@ -657,19 +661,19 @@ subroutine grid_finalize(this) end if this%top(noder) = top this%bot(noder) = this%bot3d(j, 1, k) - enddo - enddo + end do + end do ! ! -- Build connections call this%connect() ! ! -- Create two cell objects that can be used for geometric processing call this%cell1%init(this%nlay, this%ncpl, this%nodes, this%top, this%bot, & - this%iavert, this%javert, this%vertices, this%cellxy, & - this%nodereduced, this%nodeuser) + this%iavert, this%javert, this%vertices, this%cellxy, & + this%nodereduced, this%nodeuser) call this%cell2%init(this%nlay, this%ncpl, this%nodes, this%top, this%bot, & - this%iavert, this%javert, this%vertices, this%cellxy, & - this%nodereduced, this%nodeuser) + this%iavert, this%javert, this%vertices, this%cellxy, & + this%nodereduced, this%nodeuser) ! ! -- Return return @@ -684,7 +688,7 @@ subroutine read_vertices(this) ! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, DZERO ! -- dummy class(GwfDisvType) :: this integer(I4B) :: i @@ -694,12 +698,12 @@ subroutine read_vertices(this) character(len=300) :: ermsg ! -- formats character(len=*), parameter :: fmtvnum = & - "('ERROR. VERTEX NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0," // & - "' BUT FOUND ', i0)" + "('ERROR. VERTEX NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& + &' BUT FOUND ', i0)" character(len=*), parameter :: fmtnvert = & - "(3x, 'SUCCESSFULLY READ ',i0,' (X,Y) COORDINATES')" + &"(3x, 'SUCCESSFULLY READ ',i0,' (X,Y) COORDINATES')" character(len=*), parameter :: fmtcoord = & - "(3x, a,' COORDINATE = ', 1(1pg24.15))" + &"(3x, a,' COORDINATE = ', 1(1pg24.15))" ! ------------------------------------------------------------------------------ ! ! -- Calculates nodesuser @@ -708,18 +712,18 @@ subroutine read_vertices(this) ! --Read DISDATA block call this%parser%GetBlock('VERTICES', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING VERTICES' + if (isfound) then + write (this%iout, '(/,1x,a)') 'PROCESSING VERTICES' do i = 1, this%nvert call this%parser%GetNextLine(endOfBlock) ! ! -- vertex number ival = this%parser%GetInteger() - if(ival /= i) then - write(ermsg, fmtvnum) i, ival + if (ival /= i) then + write (ermsg, fmtvnum) i, ival call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- x this%vertices(1, i) = this%parser%GetDouble() @@ -728,7 +732,7 @@ subroutine read_vertices(this) this%vertices(2, i) = this%parser%GetDouble() ! ! -- set min/max coords - if(i == 1) then + if (i == 1) then xmin = this%vertices(1, i) xmax = xmin ymin = this%vertices(2, i) @@ -738,8 +742,8 @@ subroutine read_vertices(this) xmax = max(xmax, this%vertices(1, i)) ymin = min(ymin, this%vertices(2, i)) ymax = max(ymax, this%vertices(2, i)) - endif - enddo + end if + end do ! ! -- Terminate the block call this%parser%terminateblock() @@ -749,12 +753,12 @@ subroutine read_vertices(this) end if ! ! -- Write information - write(this%iout, fmtnvert) this%nvert - write(this%iout, fmtcoord) 'MINIMUM X', xmin - write(this%iout, fmtcoord) 'MAXIMUM X', xmax - write(this%iout, fmtcoord) 'MINIMUM Y', ymin - write(this%iout, fmtcoord) 'MAXIMUM Y', ymax - write(this%iout,'(1x,a)')'END PROCESSING VERTICES' + write (this%iout, fmtnvert) this%nvert + write (this%iout, fmtcoord) 'MINIMUM X', xmin + write (this%iout, fmtcoord) 'MAXIMUM X', xmax + write (this%iout, fmtcoord) 'MINIMUM Y', ymin + write (this%iout, fmtcoord) 'MAXIMUM Y', ymax + write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' ! ! -- Return return @@ -770,7 +774,7 @@ subroutine read_cell2d(this) ! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, DZERO use InputOutputModule, only: urword use SparseModule, only: sparsematrix use MemoryManagerModule, only: mem_allocate @@ -786,14 +790,14 @@ subroutine read_cell2d(this) type(sparsematrix) :: vertspm ! -- formats character(len=*), parameter :: fmtcnum = & - "('ERROR. CELL NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0," // & - "' BUT FOUND ', i0)" + "('ERROR. CELL NUMBER NOT CONSECUTIVE. LOOKING FOR ',i0,& + &' BUT FOUND ', i0)" character(len=*), parameter :: fmtncpl = & - "(3x, 'SUCCESSFULLY READ ',i0,' CELL2D INFORMATION ENTRIES')" + &"(3x, 'SUCCESSFULLY READ ',i0,' CELL2D INFORMATION ENTRIES')" character(len=*), parameter :: fmtcoord = & - "(3x, a,' CELL CENTER = ', 1(1pg24.15))" + &"(3x, a,' CELL CENTER = ', 1(1pg24.15))" character(len=*), parameter :: fmtmaxvert = & - "(3x, 'MAXIMUM NUMBER OF CELL2D VERTICES IS ',i0,' FOR CELL ', i0)" + &"(3x, 'MAXIMUM NUMBER OF CELL2D VERTICES IS ',i0,' FOR CELL ', i0)" ! ------------------------------------------------------------------------------ ! ! -- initialize @@ -805,26 +809,26 @@ subroutine read_cell2d(this) ! temporarily store the vertex numbers for each cell. This will ! be converted to iavert and javert after all cell vertices have ! been read. - allocate(maxnnz(this%ncpl)) + allocate (maxnnz(this%ncpl)) do i = 1, this%ncpl maxnnz(i) = 5 - enddo + end do call vertspm%init(this%ncpl, this%nvert, maxnnz) ! ! --Read CELL2D block call this%parser%GetBlock('CELL2D', isfound, ierr, supportOpenClose=.true.) - if(isfound) then - write(this%iout,'(/,1x,a)') 'PROCESSING CELL2D' + if (isfound) then + write (this%iout, '(/,1x,a)') 'PROCESSING CELL2D' do i = 1, this%ncpl call this%parser%GetNextLine(endOfBlock) ! ! -- cell number ival = this%parser%GetInteger() - if(ival /= i) then - write(ermsg, fmtcnum) i, ival + if (ival /= i) then + write (ermsg, fmtcnum) i, ival call store_error(ermsg) call store_error_unit(iuext) - endif + end if ! ! -- Cell x center this%cellxy(1, i) = this%parser%GetDouble() @@ -834,10 +838,10 @@ subroutine read_cell2d(this) ! ! -- Number of vertices for this cell ncvert = this%parser%GetInteger() - if(ncvert > maxvert) then + if (ncvert > maxvert) then maxvert = ncvert maxvertcell = i - endif + end if ! ! -- Read each vertex number, and then close the polygon if ! the last vertex does not equal the first vertex @@ -846,17 +850,17 @@ subroutine read_cell2d(this) call vertspm%addconnection(i, ivert, 0) ! ! -- If necessary, repeat the last vertex in order to close the cell - if(j == 1) then + if (j == 1) then ivert1 = ivert - elseif(j == ncvert) then - if(ivert1 /= ivert) then + elseif (j == ncvert) then + if (ivert1 /= ivert) then call vertspm%addconnection(i, ivert1, 0) - endif - endif - enddo + end if + end if + end do ! ! -- set min/max coords - if(i == 1) then + if (i == 1) then xmin = this%cellxy(1, i) xmax = xmin ymin = this%cellxy(2, i) @@ -866,8 +870,8 @@ subroutine read_cell2d(this) xmax = max(xmax, this%cellxy(1, i)) ymin = min(ymin, this%cellxy(2, i)) ymax = max(ymax, this%cellxy(2, i)) - endif - enddo + end if + end do ! ! -- Terminate the block call this%parser%terminateblock() @@ -877,19 +881,19 @@ subroutine read_cell2d(this) end if ! ! -- Convert vertspm into ia/ja form - call mem_allocate(this%iavert, this%ncpl+1, 'IAVERT', this%memoryPath) + call mem_allocate(this%iavert, this%ncpl + 1, 'IAVERT', this%memoryPath) call mem_allocate(this%javert, vertspm%nnz, 'JAVERT', this%memoryPath) call vertspm%filliaja(this%iavert, this%javert, ierr) call vertspm%destroy() ! ! -- Write information - write(this%iout, fmtncpl) this%ncpl - write(this%iout, fmtcoord) 'MINIMUM X', xmin - write(this%iout, fmtcoord) 'MAXIMUM X', xmax - write(this%iout, fmtcoord) 'MINIMUM Y', ymin - write(this%iout, fmtcoord) 'MAXIMUM Y', ymax - write(this%iout, fmtmaxvert) maxvert, maxvertcell - write(this%iout,'(1x,a)')'END PROCESSING VERTICES' + write (this%iout, fmtncpl) this%ncpl + write (this%iout, fmtcoord) 'MINIMUM X', xmin + write (this%iout, fmtcoord) 'MAXIMUM X', xmax + write (this%iout, fmtcoord) 'MINIMUM Y', ymin + write (this%iout, fmtcoord) 'MAXIMUM Y', ymax + write (this%iout, fmtmaxvert) maxvert, maxvertcell + write (this%iout, '(1x,a)') 'END PROCESSING VERTICES' ! ! -- Return return @@ -917,30 +921,30 @@ subroutine connect(this) area = this%get_cell2d_area(j) do k = 1, this%nlay noder = this%get_nodenumber(k, j, 0) - if(noder > 0) this%area(noder) = area - enddo + if (noder > 0) this%area(noder) = area + end do if (area < 0) then - write(errmsg, '(a,i0)') 'ERROR. CELL2D AREA LESS THAN ZERO FOR CELL ', j + write (errmsg, '(a,i0)') 'ERROR. CELL2D AREA LESS THAN ZERO FOR CELL ', j call store_error(errmsg) - endif - enddo + end if + end do ! ! -- check for errors - if(count_errors() > 0) then - write(errmsg, '(a)') 'CELL VERTICES MUST BE LISTED IN CLOCKWISE ORDER. ' + if (count_errors() > 0) then + write (errmsg, '(a)') 'CELL VERTICES MUST BE LISTED IN CLOCKWISE ORDER. ' call store_error(errmsg) call store_error_unit(this%inunit) - endif + end if ! ! -- create and fill the connections object nrsize = 0 - if(this%nodes < this%nodesuser) nrsize = this%nodes - allocate(this%con) - call this%con%disvconnections(this%name_model, this%nodes, & - this%ncpl, this%nlay, nrsize, & - this%nvert, this%vertices, this%iavert, & - this%javert, this%cellxy, & - this%top, this%bot, & + if (this%nodes < this%nodesuser) nrsize = this%nodes + allocate (this%con) + call this%con%disvconnections(this%name_model, this%nodes, & + this%ncpl, this%nlay, nrsize, & + this%nvert, this%vertices, this%iavert, & + this%javert, this%cellxy, & + this%top, this%bot, & this%nodereduced, this%nodeuser) this%nja = this%con%nja this%njas = this%con%njas @@ -970,8 +974,8 @@ subroutine write_grb(this, icelltype) character(len=50) :: txthdr character(len=lentxt) :: txt character(len=LINELENGTH) :: fname - character(len=*),parameter :: fmtgrdsave = & - "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & + character(len=*), parameter :: fmtgrdsave = & + "(4X,'BINARY GRID INFORMATION WILL BE WRITTEN TO:', & &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" ! ------------------------------------------------------------------------------ ! @@ -979,113 +983,115 @@ subroutine write_grb(this, icelltype) ntxt = 20 ! ! -- Open the file - inquire(unit=this%inunit, name=fname) - fname = trim(fname) // '.grb' + inquire (unit=this%inunit, name=fname) + fname = trim(fname)//'.grb' iunit = getunit() - write(this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) - call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & + write (this%iout, fmtgrdsave) iunit, trim(adjustl(fname)) + call openfile(iunit, this%iout, trim(adjustl(fname)), 'DATA(BINARY)', & form, access, 'REPLACE') ! ! -- write header information - write(txthdr, '(a)') 'GRID DISV' + write (txthdr, '(a)') 'GRID DISV' txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a)') 'VERSION 1' + write (iunit) txthdr + write (txthdr, '(a)') 'VERSION 1' txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'NTXT ', ntxt + write (iunit) txthdr + write (txthdr, '(a, i0)') 'NTXT ', ntxt txthdr(50:50) = new_line('a') - write(iunit) txthdr - write(txthdr, '(a, i0)') 'LENTXT ', lentxt + write (iunit) txthdr + write (txthdr, '(a, i0)') 'LENTXT ', lentxt txthdr(50:50) = new_line('a') - write(iunit) txthdr + write (iunit) txthdr ! ! -- write variable definitions - write(txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser + write (txt, '(3a, i0)') 'NCELLS ', 'INTEGER ', 'NDIM 0 # ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay + write (iunit) txt + write (txt, '(3a, i0)') 'NLAY ', 'INTEGER ', 'NDIM 0 # ', this%nlay txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NCPL ', 'INTEGER ', 'NDIM 0 # ', this%ncpl + write (iunit) txt + write (txt, '(3a, i0)') 'NCPL ', 'INTEGER ', 'NDIM 0 # ', this%ncpl txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NVERT ', 'INTEGER ', 'NDIM 0 # ', this%nvert + write (iunit) txt + write (txt, '(3a, i0)') 'NVERT ', 'INTEGER ', 'NDIM 0 # ', this%nvert txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJAVERT ', 'INTEGER ', 'NDIM 0 # ', size(this%javert) + write (iunit) txt + write (txt, '(3a, i0)') 'NJAVERT ', 'INTEGER ', 'NDIM 0 # ', size(this%javert) txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja + write (iunit) txt + write (txt, '(3a, i0)') 'NJA ', 'INTEGER ', 'NDIM 0 # ', this%con%nja txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg25.15e3)') 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin + write (iunit) txt + write (txt, '(3a, 1pg25.15e3)') & + 'XORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%xorigin txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg25.15e3)') 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin + write (iunit) txt + write (txt, '(3a, 1pg25.15e3)') & + 'YORIGIN ', 'DOUBLE ', 'NDIM 0 # ', this%yorigin txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, 1pg25.15e3)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot + write (iunit) txt + write (txt, '(3a, 1pg25.15e3)') 'ANGROT ', 'DOUBLE ', 'NDIM 0 # ', this%angrot txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%ncpl + write (iunit) txt + write (txt, '(3a, i0)') 'TOP ', 'DOUBLE ', 'NDIM 1 ', this%ncpl txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'BOTM ', 'DOUBLE ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert + write (iunit) txt + write (txt, '(3a, i0)') 'VERTICES ', 'DOUBLE ', 'NDIM 2 2 ', this%nvert txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%ncpl + write (iunit) txt + write (txt, '(3a, i0)') 'CELLX ', 'DOUBLE ', 'NDIM 1 ', this%ncpl txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%ncpl + write (iunit) txt + write (txt, '(3a, i0)') 'CELLY ', 'DOUBLE ', 'NDIM 1 ', this%ncpl txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%ncpl + 1 + write (iunit) txt + write (txt, '(3a, i0)') 'IAVERT ', 'INTEGER ', 'NDIM 1 ', this%ncpl + 1 txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) + write (iunit) txt + write (txt, '(3a, i0)') 'JAVERT ', 'INTEGER ', 'NDIM 1 ', size(this%javert) txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 + write (iunit) txt + write (txt, '(3a, i0)') 'IA ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + 1 txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) + write (iunit) txt + write (txt, '(3a, i0)') 'JA ', 'INTEGER ', 'NDIM 1 ', size(this%con%jausr) txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'IDOMAIN ', 'INTEGER ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt - write(txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser + write (iunit) txt + write (txt, '(3a, i0)') 'ICELLTYPE ', 'INTEGER ', 'NDIM 1 ', this%nodesuser txt(lentxt:lentxt) = new_line('a') - write(iunit) txt + write (iunit) txt ! ! -- write data - write(iunit) this%nodesuser ! ncells - write(iunit) this%nlay ! nlay - write(iunit) this%ncpl ! ncpl - write(iunit) this%nvert ! nvert - write(iunit) size(this%javert) ! njavert - write(iunit) this%nja ! nja - write(iunit) this%xorigin ! xorigin - write(iunit) this%yorigin ! yorigin - write(iunit) this%angrot ! angrot - write(iunit) this%top2d ! top - write(iunit) this%bot3d ! botm - write(iunit) this%vertices ! vertices - write(iunit) (this%cellxy(1, i), i = 1, this%ncpl) ! cellx - write(iunit) (this%cellxy(2, i), i = 1, this%ncpl) ! celly - write(iunit) this%iavert ! iavert - write(iunit) this%javert ! javert - write(iunit) this%con%iausr ! iausr - write(iunit) this%con%jausr ! jausr - write(iunit) this%idomain ! idomain - write(iunit) icelltype ! icelltype + write (iunit) this%nodesuser ! ncells + write (iunit) this%nlay ! nlay + write (iunit) this%ncpl ! ncpl + write (iunit) this%nvert ! nvert + write (iunit) size(this%javert) ! njavert + write (iunit) this%nja ! nja + write (iunit) this%xorigin ! xorigin + write (iunit) this%yorigin ! yorigin + write (iunit) this%angrot ! angrot + write (iunit) this%top2d ! top + write (iunit) this%bot3d ! botm + write (iunit) this%vertices ! vertices + write (iunit) (this%cellxy(1, i), i=1, this%ncpl) ! cellx + write (iunit) (this%cellxy(2, i), i=1, this%ncpl) ! celly + write (iunit) this%iavert ! iavert + write (iunit) this%javert ! javert + write (iunit) this%con%iausr ! iausr + write (iunit) this%con%jausr ! jausr + write (iunit) this%idomain ! idomain + write (iunit) icelltype ! icelltype ! ! -- Close the file - close(iunit) + close (iunit) ! ! -- return return @@ -1111,10 +1117,10 @@ subroutine nodeu_to_string(this, nodeu, str) ! ------------------------------------------------------------------------------ ! call get_ijk(nodeu, 1, this%ncpl, this%nlay, i, j, k) - write(kstr, '(i10)') k - write(jstr, '(i10)') j - str = '(' // trim(adjustl(kstr)) // ',' // & - trim(adjustl(jstr)) // ')' + write (kstr, '(i10)') k + write (jstr, '(i10)') j + str = '('//trim(adjustl(kstr))//','// & + trim(adjustl(jstr))//')' ! ! -- return return @@ -1142,8 +1148,8 @@ subroutine nodeu_to_array(this, nodeu, arr) ! -- check the size of arr isize = size(arr) if (isize /= this%ndim) then - write(errmsg,'(a,i0,a,i0,a)') & - 'Program error: nodeu_to_array size of array (', isize, & + write (errmsg, '(a,i0,a,i0,a)') & + 'Program error: nodeu_to_array size of array (', isize, & ') is not equal to the discretization dimension (', this%ndim, ')' call store_error(errmsg, terminate=.TRUE.) end if @@ -1158,7 +1164,7 @@ subroutine nodeu_to_array(this, nodeu, arr) ! -- return return end subroutine nodeu_to_array - + function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) ! ****************************************************************************** ! get_nodenumber -- Return a nodenumber from the user specified node number @@ -1180,28 +1186,28 @@ function get_nodenumber_idx1(this, nodeu, icheck) result(nodenumber) ! ------------------------------------------------------------------------------ ! ! -- check the node number if requested - if(icheck /= 0) then + if (icheck /= 0) then ! ! -- If within valid range, convert to reduced nodenumber - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (errmsg, '(a,i10)') & 'Nodenumber less than 1 or greater than nodes:', nodeu call store_error(errmsg) nodenumber = 0 else nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif + if (this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + end if else nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) - endif + if (this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + end if ! ! -- return return end function get_nodenumber_idx1 - function get_nodenumber_idx2(this, k, j, icheck) & + function get_nodenumber_idx2(this, k, j, icheck) & result(nodenumber) ! ****************************************************************************** ! get_nodenumber_idx2 -- Return a nodenumber from the user specified layer and @@ -1224,38 +1230,38 @@ function get_nodenumber_idx2(this, k, j, icheck) & integer(I4B) :: nodeu ! formats character(len=*), parameter :: fmterr = & - "('Error in disv grid cell indices: layer = ',i0,', node = ',i0)" + &"('Error in disv grid cell indices: layer = ',i0,', node = ',i0)" ! ------------------------------------------------------------------------------ ! nodeu = get_node(k, 1, j, this%nlay, 1, this%ncpl) if (nodeu < 1) then - write(errmsg, fmterr) k, j + write (errmsg, fmterr) k, j call store_error(errmsg, terminate=.TRUE.) - endif + end if nodenumber = nodeu - if(this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) + if (this%nodes < this%nodesuser) nodenumber = this%nodereduced(nodeu) ! ! -- check the node number if requested - if(icheck /= 0) then + if (icheck /= 0) then ! - if(k < 1 .or. k > this%nlay) & + if (k < 1 .or. k > this%nlay) & call store_error('Layer less than one or greater than nlay') - if(j < 1 .or. j > this%ncpl) & + if (j < 1 .or. j > this%ncpl) & call store_error('Node number less than one or greater than ncpl') ! ! -- Error if outside of range - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(errmsg, '(a,i10)') & + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (errmsg, '(a,i10)') & 'Nodenumber less than 1 or greater than nodes:', nodeu call store_error(errmsg) - endif - endif + end if + end if ! ! -- return return end function get_nodenumber_idx2 - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ipos) ! ****************************************************************************** ! connection_normal -- calculate the normal vector components for reduced @@ -1284,10 +1290,10 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! ------------------------------------------------------------------------------ ! ! -- Set vector components based on ihc - if(ihc == 0) then + if (ihc == 0) then xcomp = DZERO ycomp = DZERO - if(nodem < noden) then + if (nodem < noden) then ! ! -- nodem must be above noden, so upward connection zcomp = DONE @@ -1295,7 +1301,7 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! ! -- nodem must be below noden, so downward connection zcomp = -DONE - endif + end if else ! -- find from anglex, since anglex is symmetric, need to flip vector ! for lower triangle (nodem < noden) @@ -1306,13 +1312,13 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & xcomp = cos(angle) * dmult ycomp = sin(angle) * dmult zcomp = DZERO - endif + end if ! ! -- return return end subroutine connection_normal - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & xcomp, ycomp, zcomp, conlen) ! ****************************************************************************** ! connection_vector -- calculate the unit vector components from reduced @@ -1347,16 +1353,16 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & ! ------------------------------------------------------------------------------ ! ! -- Set vector components based on ihc - if(ihc == 0) then + if (ihc == 0) then ! ! -- vertical connection; set zcomp positive upward xcomp = DZERO ycomp = DZERO - if(nodem < noden) then + if (nodem < noden) then zcomp = DONE else zcomp = -DONE - endif + end if zn = this%bot(noden) + DHALF * (this%top(noden) - this%bot(noden)) zm = this%bot(nodem) + DHALF * (this%top(nodem) - this%bot(nodem)) conlen = abs(zm - zn) @@ -1370,7 +1376,7 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & else zn = this%bot(noden) + DHALF * satn * (this%top(noden) - this%bot(noden)) zm = this%bot(nodem) + DHALF * satm * (this%top(nodem) - this%bot(nodem)) - endif + end if nodeu = this%get_nodeuser(noden) call get_jk(nodeu, this%ncpl, this%nlay, ncell2d, k) nodeu = this%get_nodeuser(nodem) @@ -1379,9 +1385,9 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & yn = this%cellxy(2, ncell2d) xm = this%cellxy(1, mcell2d) ym = this%cellxy(2, mcell2d) - call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & + call line_unit_vector(xn, yn, zn, xm, ym, zm, xcomp, ycomp, zcomp, & conlen) - endif + end if ! ! -- return return @@ -1390,29 +1396,29 @@ end subroutine connection_vector ! return x,y coordinate for a node subroutine get_cellxy_disv(this, node, xcell, ycell) use InputOutputModule, only: get_jk - class(GwfDisvType), intent(in) :: this - integer(I4B), intent(in) :: node ! the reduced node number - real(DP), intent(out) :: xcell, ycell ! the x,y for the cell + class(GwfDisvType), intent(in) :: this + integer(I4B), intent(in) :: node ! the reduced node number + real(DP), intent(out) :: xcell, ycell ! the x,y for the cell ! local integer(I4B) :: nodeuser, ncell2d, k - + nodeuser = this%get_nodeuser(node) call get_jk(nodeuser, this%ncpl, this%nlay, ncell2d, k) - + xcell = this%cellxy(1, ncell2d) ycell = this%cellxy(2, ncell2d) - - end subroutine get_cellxy_disv - - ! return discretization type + + end subroutine get_cellxy_disv + + ! return discretization type subroutine get_dis_type(this, dis_type) - class(GwfDisvType), intent(in) :: this - character(len=*), intent(out) :: dis_type - + class(GwfDisvType), intent(in) :: this + character(len=*), intent(out) :: dis_type + dis_type = "DISV" - + end subroutine get_dis_type - + subroutine allocate_scalars(this, name_model) ! ****************************************************************************** ! allocate_scalars -- Allocate and initialize scalars @@ -1462,13 +1468,14 @@ subroutine allocate_arrays(this) call this%DisBaseType%allocate_arrays() ! ! -- Allocate arrays for GwfDisvType - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call mem_allocate(this%nodeuser, this%nodes, 'NODEUSER', this%memoryPath) - call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', this%memoryPath) + call mem_allocate(this%nodereduced, this%nodesuser, 'NODEREDUCED', & + this%memoryPath) else call mem_allocate(this%nodeuser, 1, 'NODEUSER', this%memoryPath) call mem_allocate(this%nodereduced, 1, 'NODEREDUCED', this%memoryPath) - endif + end if ! -- Initialize this%mshape(1) = this%nlay this%mshape(2) = this%ncpl @@ -1507,26 +1514,26 @@ function get_cell2d_area(this, icell2d) result(area) icount = 1 do ivert = this%iavert(icell2d), this%iavert(icell2d + 1) - 1 x = this%vertices(1, this%javert(ivert)) - if(icount < nvert) then + if (icount < nvert) then y = this%vertices(2, this%javert(ivert + 1)) else y = this%vertices(2, this%javert(this%iavert(icell2d))) - endif + end if area = area + x * y icount = icount + 1 - enddo + end do ! icount = 1 do ivert = this%iavert(icell2d), this%iavert(icell2d + 1) - 1 y = this%vertices(2, this%javert(ivert)) - if(icount < nvert) then + if (icount < nvert) then x = this%vertices(1, this%javert(ivert + 1)) else x = this%vertices(1, this%javert(this%iavert(icell2d))) - endif + end if area = area - x * y icount = icount + 1 - enddo + end do ! area = -DONE * area * DHALF ! @@ -1569,14 +1576,14 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & ! Check to see if first token in line can be read as an integer. lloclocal = lloc call urword(line, lloclocal, istart, istop, 1, ndum, r, iout, in) - read(line(istart:istop),*,iostat=istat)n + read (line(istart:istop), *, iostat=istat) n if (istat /= 0) then ! First token in line is not an integer; return flag to this effect. nodeu = -2 return - endif - endif - endif + end if + end if + end if ! nlay = this%mshape(1) nrow = 1 @@ -1590,24 +1597,24 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & if (allow_zero) then nodeu = 0 return - endif - endif - endif + end if + end if + end if ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) + if (k < 1 .or. k > nlay) then + write (ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) end if - if(j < 1 .or. j > ncpl) then - write(ermsg, *) ' Cell2d number in list is outside of the grid', j - call store_error(ermsg) + if (j < 1 .or. j > ncpl) then + write (ermsg, *) ' Cell2d number in list is outside of the grid', j + call store_error(ermsg) end if nodeu = get_node(k, 1, j, nlay, nrow, ncpl) ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (ermsg, *) ' Node number in list is outside of the grid', nodeu call store_error(ermsg) - inquire(unit=in, name=fname) + inquire (unit=in, name=fname) call store_error('Error converting in file: ') call store_error(trim(adjustl(fname))) call store_error('Cell number cannot be determined in line: ') @@ -1620,7 +1627,7 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & end function nodeu_from_string function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) + allow_zero) result(nodeu) ! ****************************************************************************** ! nodeu_from_cellid -- Receive cellid as a string and convert the string to a ! user nodenumber. @@ -1638,7 +1645,7 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & integer(I4B) :: nodeu ! -- dummy class(GwfDisvType) :: this - character(len=*), intent(inout) :: cellid + character(len=*), intent(inout) :: cellid integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout logical, optional, intent(in) :: flag_string @@ -1656,14 +1663,14 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & ! Check to see if first token in cellid can be read as an integer. lloclocal = 1 call urword(cellid, lloclocal, istart, istop, 1, ndum, r, iout, inunit) - read(cellid(istart:istop), *, iostat=istat) n + read (cellid(istart:istop), *, iostat=istat) n if (istat /= 0) then ! First token in cellid is not an integer; return flag to this effect. nodeu = -2 return - endif - endif - endif + end if + end if + end if ! nlay = this%mshape(1) nrow = 1 @@ -1678,24 +1685,24 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & if (allow_zero) then nodeu = 0 return - endif - endif - endif + end if + end if + end if ! - if(k < 1 .or. k > nlay) then - write(ermsg, *) ' Layer number in list is outside of the grid', k - call store_error(ermsg) + if (k < 1 .or. k > nlay) then + write (ermsg, *) ' Layer number in list is outside of the grid', k + call store_error(ermsg) end if - if(j < 1 .or. j > ncpl) then - write(ermsg, *) ' Cell2d number in list is outside of the grid', j - call store_error(ermsg) + if (j < 1 .or. j > ncpl) then + write (ermsg, *) ' Cell2d number in list is outside of the grid', j + call store_error(ermsg) end if nodeu = get_node(k, 1, j, nlay, nrow, ncpl) ! - if(nodeu < 1 .or. nodeu > this%nodesuser) then - write(ermsg, *) ' Node number in list is outside of the grid', nodeu + if (nodeu < 1 .or. nodeu > this%nodesuser) then + write (ermsg, *) ' Node number in list is outside of the grid', nodeu call store_error(ermsg) - inquire(unit=inunit, name=fname) + inquire (unit=inunit, name=fname) call store_error('Error converting in file: ') call store_error(trim(adjustl(fname))) call store_error('Cell number cannot be determined in cellid: ') @@ -1750,15 +1757,15 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfDisvType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(GwfDisvType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! -- local integer(I4B) :: ival real(DP) :: rval @@ -1777,21 +1784,21 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & nrow = 1 ncol = this%mshape(2) ! - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodesuser itemp => this%ibuff else nval = this%nodes itemp => iarray - endif + end if ! ! -- Read the array call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then + if (line(istart:istop) .EQ. 'LAYERED') then ! ! -- Read layered input call ReadArray(in, itemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) + iout, 1, nlay) else ! ! -- Read unstructured input @@ -1799,9 +1806,9 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & end if ! ! -- If reduced model, then need to copy from itemp(=>ibuff) to iarray - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call this%fill_grid_array(itemp, iarray) - endif + end if ! ! -- return return @@ -1820,15 +1827,15 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfDisvType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(GwfDisvType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! -- local integer(I4B) :: ival real(DP) :: rval @@ -1847,21 +1854,21 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & nrow = 1 ncol = this%mshape(2) ! - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodesuser dtemp => this%dbuff else nval = this%nodes dtemp => darray - endif + end if ! ! -- Read the array call urword(line, lloc, istart, istop, 1, ival, rval, iout, in) - if (line(istart:istop).EQ.'LAYERED') then + if (line(istart:istop) .EQ. 'LAYERED') then ! ! -- Read structured input call ReadArray(in, dtemp, aname, this%ndim, ncol, nrow, nlay, nval, & - iout, 1, nlay) + iout, 1, nlay) else ! ! -- Read unstructured input @@ -1869,15 +1876,15 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & end if ! ! -- If reduced model, then need to copy from dtemp(=>dbuff) to darray - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then call this%fill_grid_array(dtemp, darray) - endif + end if ! ! -- return return end subroutine read_dbl_array - subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & + subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & icolbnd, aname, inunit, iout) ! ****************************************************************************** ! read_layer_array -- Read a 2d double array into col icolbnd of darray. @@ -1922,14 +1929,14 @@ subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & nodeu = get_node(1, ir, ic, nlay, nrow, ncol) darray(icolbnd, ipos) = this%dbuff(nodeu) ipos = ipos + 1 - enddo - enddo + end do + end do ! ! -- return end subroutine read_layer_array - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) ! ****************************************************************************** ! record_array -- Record a double precision array. The array will be ! printed to an external file and/or written to an unformatted external file @@ -1952,17 +1959,17 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwfDisvType), intent(inout) :: this + class(GwfDisvType), intent(inout) :: this real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact ! -- local integer(I4B) :: k, ifirst integer(I4B) :: nlay @@ -1973,7 +1980,7 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & integer(I4B) :: istart, istop real(DP), dimension(:), pointer, contiguous :: dtemp ! -- formats - character(len=*),parameter :: fmthsv = & + character(len=*), parameter :: fmthsv = & "(1X,/1X,a,' WILL BE SAVED ON UNIT ',I4, & &' AT END OF TIME STEP',I5,', STRESS PERIOD ',I4)" ! ------------------------------------------------------------------------------ @@ -1985,61 +1992,61 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! ! -- If this is a reduced model, then copy the values from darray into ! dtemp. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nval = this%nodes dtemp => this%dbuff do nodeu = 1, this%nodesuser noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then + if (noder <= 0) then dtemp(nodeu) = dinact cycle - endif + end if dtemp(nodeu) = darray(noder) - enddo + end do else nval = this%nodes dtemp => darray - endif + end if ! ! -- Print to iout if iprint /= 0 - if(iprint /= 0) then + if (iprint /= 0) then istart = 1 do k = 1, nlay istop = istart + nrow * ncol - 1 - call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & + call ulaprufw(ncol, nrow, kstp, kper, k, iout, dtemp(istart:istop), & aname, cdatafmp, nvaluesp, nwidthp, editdesc) istart = istop + 1 - enddo - endif + end do + end if ! ! -- Save array to an external file. - if(idataun > 0) then + if (idataun > 0) then ! -- write to binary file by layer ifirst = 1 istart = 1 - do k=1, nlay + do k = 1, nlay istop = istart + nrow * ncol - 1 - if(ifirst == 1) write(iout, fmthsv) & - trim(adjustl(aname)), idataun, & - kstp, kper + if (ifirst == 1) write (iout, fmthsv) & + trim(adjustl(aname)), idataun, & + kstp, kper ifirst = 0 - call ulasav(dtemp(istart:istop), aname, kstp, kper, & + call ulasav(dtemp(istart:istop), aname, kstp, kper, & pertim, totim, ncol, nrow, k, idataun) istart = istop + 1 - enddo - elseif(idataun < 0) then + end do + elseif (idataun < 0) then ! ! -- write entire array as one record - call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & + call ubdsv1(kstp, kper, aname, -idataun, dtemp, ncol, nrow, nlay, & iout, delt, pertim, totim) - endif + end if ! ! -- return return end subroutine record_array - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & ibdchn, nlist, iout) ! ****************************************************************************** ! record_srcdst_list_header -- Record list header for imeth=6 @@ -2068,8 +2075,8 @@ subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & ncol = this%mshape(2) ! ! -- Use ubdsv06 to write list header - call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage,& - ibdchn, naux, auxtxt, ncol, nrow, nlay, & + call ubdsv06(kstp, kper, text, textmodel, textpackage, dstmodel, dstpackage, & + ibdchn, naux, auxtxt, ncol, nrow, nlay, & nlist, iout, delt, pertim, totim) ! ! -- return @@ -2118,36 +2125,36 @@ subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & do ic = 1, ncol nodeu = get_node(1, ir, ic, nlay, nrow, ncol) il = this%ibuff(nodeu) - if(il < 1 .or. il > nlay) then - write(errmsg, *) 'ERROR. INVALID LAYER NUMBER: ', il + if (il < 1 .or. il > nlay) then + write (errmsg, *) 'ERROR. INVALID LAYER NUMBER: ', il call store_error(errmsg, terminate=.TRUE.) - endif + end if nodeu = get_node(il, ir, ic, nlay, nrow, ncol) noder = this%get_nodenumber(nodeu, 0) - if(ipos > maxbnd) then + if (ipos > maxbnd) then ierr = ipos else nodelist(ipos) = noder - endif + end if ipos = ipos + 1 - enddo - enddo + end do + end do ! ! -- Check for errors nbound = ipos - 1 - if(ierr > 0) then - write(errmsg, *) 'ERROR. MAXBOUND DIMENSION IS TOO SMALL.' + if (ierr > 0) then + write (errmsg, *) 'ERROR. MAXBOUND DIMENSION IS TOO SMALL.' call store_error(errmsg) - write(errmsg, *) 'INCREASE MAXBOUND TO: ', ierr + write (errmsg, *) 'INCREASE MAXBOUND TO: ', ierr call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- If nbound < maxbnd, then initialize nodelist to zero in this range - if(nbound < maxbnd) then - do ipos = nbound+1, maxbnd + if (nbound < maxbnd) then + do ipos = nbound + 1, maxbnd nodelist(ipos) = 0 - enddo - endif + end do + end if ! ! -- return end subroutine nlarray_to_nodelist diff --git a/src/Model/GroundWaterFlow/gwf3drn8.f90 b/src/Model/GroundWaterFlow/gwf3drn8.f90 index 22e2ea82e9c..45a329f9faa 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -1,10 +1,10 @@ module DrnModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DONE, DTWO, & + use ConstantsModule, only: DZERO, DONE, DTWO, & LENFTYPE, LENPACKAGENAME, LENAUXNAME, LINELENGTH use MemoryHelperModule, only: create_mem_path - use SmoothingModule, only: sQSaturation, sQSaturationDerivative, & - sQuadraticSaturation + use SmoothingModule, only: sQSaturation, sQSaturationDerivative, & + sQuadraticSaturation use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor use TimeSeriesLinkModule, only: TimeSeriesLinkType, & @@ -16,30 +16,30 @@ module DrnModule public :: drn_create public :: DrnType ! - character(len=LENFTYPE) :: ftype = 'DRN' - character(len=LENPACKAGENAME) :: text = ' DRN' + character(len=LENFTYPE) :: ftype = 'DRN' + character(len=LENPACKAGENAME) :: text = ' DRN' ! type, extends(BndType) :: DrnType - + integer(I4B), pointer :: iauxddrncol => null() integer(I4B), pointer :: icubic_scaling => null() - - contains - procedure :: allocate_scalars => drn_allocate_scalars - procedure :: bnd_options => drn_options - procedure :: bnd_ck => drn_ck - procedure :: bnd_cf => drn_cf - procedure :: bnd_fc => drn_fc - procedure :: bnd_fn => drn_fn - procedure :: bnd_da => drn_da - procedure :: define_listlabel - procedure :: get_drain_elevations - procedure :: get_drain_factor - ! -- methods for observations - procedure, public :: bnd_obs_supported => drn_obs_supported - procedure, public :: bnd_df_obs => drn_df_obs - ! -- method for time series - procedure, public :: bnd_rp_ts => drn_rp_ts + + contains + procedure :: allocate_scalars => drn_allocate_scalars + procedure :: bnd_options => drn_options + procedure :: bnd_ck => drn_ck + procedure :: bnd_cf => drn_cf + procedure :: bnd_fc => drn_fc + procedure :: bnd_fn => drn_fn + procedure :: bnd_da => drn_da + procedure :: define_listlabel + procedure :: get_drain_elevations + procedure :: get_drain_factor + ! -- methods for observations + procedure, public :: bnd_obs_supported => drn_obs_supported + procedure, public :: bnd_df_obs => drn_df_obs + ! -- method for time series + procedure, public :: bnd_rp_ts => drn_rp_ts end type DrnType contains @@ -55,10 +55,10 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -66,7 +66,7 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(drnobj) + allocate (drnobj) packobj => drnobj ! ! -- create name and memory path @@ -80,12 +80,12 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) call packobj%pack_initialize() ! ! -- initialize - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id packobj%ibcnum = ibcnum - packobj%ncolbnd=2 ! drnelev, conductance - packobj%iscloc=2 !sfac applies to conductance + packobj%ncolbnd = 2 ! drnelev, conductance + packobj%iscloc = 2 !sfac applies to conductance packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return @@ -159,9 +159,9 @@ subroutine drn_options(this, option, found) use InputOutputModule, only: urword use SimModule, only: store_error ! -- dummy - class(DrnType), intent(inout) :: this + class(DrnType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local character(len=LINELENGTH) :: errmsg character(len=LENAUXNAME) :: ddrnauxname @@ -169,41 +169,41 @@ subroutine drn_options(this, option, found) ! ------------------------------------------------------------------------------ ! select case (option) - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case('AUXDEPTHNAME') - call this%parser%GetStringCaps(ddrnauxname) - this%iauxddrncol = -1 - write(this%iout, '(4x,a,a)') & - 'AUXILIARY DRAIN DEPTH NAME: ', trim(ddrnauxname) - found = .true. + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case ('AUXDEPTHNAME') + call this%parser%GetStringCaps(ddrnauxname) + this%iauxddrncol = -1 + write (this%iout, '(4x,a,a)') & + 'AUXILIARY DRAIN DEPTH NAME: ', trim(ddrnauxname) + found = .true. ! ! -- right now these are options that are only available in the ! development version and are not included in the documentation. ! These options are only available when IDEVELOPMODE in ! constants module is set to 1 - case ('DEV_CUBIC_SCALING') - call this%parser%DevOpt() - this%icubic_scaling = 1 - write(this%iout, '(4x,a,1x,a)') & - 'CUBIC SCALING will be used for drains with non-zero DDRN values', & - 'even if the NEWTON-RAPHSON method is not being used.' - found = .true. - case default - ! - ! -- No options found - found = .false. + case ('DEV_CUBIC_SCALING') + call this%parser%DevOpt() + this%icubic_scaling = 1 + write (this%iout, '(4x,a,1x,a)') & + 'CUBIC SCALING will be used for drains with non-zero DDRN values', & + 'even if the NEWTON-RAPHSON method is not being used.' + found = .true. + case default + ! + ! -- No options found + found = .false. end select ! ! -- DDRN was specified, so find column of auxvar that will be used if (this%iauxddrncol < 0) then ! ! -- Error if no aux variable specified - if(this%naux == 0) then - write(errmsg,'(a,2(1x,a))') & - 'AUXDDRNNAME WAS SPECIFIED AS', trim(adjustl(ddrnauxname)), & + if (this%naux == 0) then + write (errmsg, '(a,2(1x,a))') & + 'AUXDDRNNAME WAS SPECIFIED AS', trim(adjustl(ddrnauxname)), & 'BUT NO AUX VARIABLES SPECIFIED.' call store_error(errmsg) end if @@ -211,16 +211,16 @@ subroutine drn_options(this, option, found) ! -- Assign ddrn column this%iauxddrncol = 0 do n = 1, this%naux - if(ddrnauxname == this%auxname(n)) then + if (ddrnauxname == this%auxname(n)) then this%iauxddrncol = n exit end if end do ! ! -- Error if aux variable cannot be found - if(this%iauxddrncol == 0) then - write(errmsg,'(a,2(1x,a))') & - 'AUXDDRNNAME WAS SPECIFIED AS', trim(adjustl(ddrnauxname)), & + if (this%iauxddrncol == 0) then + write (errmsg, '(a,2(1x,a))') & + 'AUXDDRNNAME WAS SPECIFIED AS', trim(adjustl(ddrnauxname)), & 'BUT NO AUX VARIABLE FOUND WITH THIS NAME.' call store_error(errmsg) end if @@ -241,7 +241,7 @@ subroutine drn_ck(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(DrnType),intent(inout) :: this + class(DrnType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: errmsg integer(I4B) :: i @@ -251,32 +251,32 @@ subroutine drn_ck(this) real(DP) :: drntop real(DP) :: drnbot ! -- formats - character(len=*), parameter :: fmtddrnerr = & - "('SCALED-CONDUCTANCE DRN BOUNDARY (',i0,') BOTTOM ELEVATION " // & - "(',f10.3,') IS LESS THAN CELL BOTTOM (',f10.3,')')" - character(len=*), parameter :: fmtdrnerr = & - "('DRN BOUNDARY (',i0,') ELEVATION (',f10.3,') IS LESS THAN CELL " // & - "BOTTOM (',f10.3,')')" + character(len=*), parameter :: fmtddrnerr = & + "('SCALED-CONDUCTANCE DRN BOUNDARY (',i0,') BOTTOM ELEVATION & + &(',f10.3,') IS LESS THAN CELL BOTTOM (',f10.3,')')" + character(len=*), parameter :: fmtdrnerr = & + "('DRN BOUNDARY (',i0,') ELEVATION (',f10.3,') IS LESS THAN CELL & + &BOTTOM (',f10.3,')')" ! ------------------------------------------------------------------------------ ! ! -- check stress period data do i = 1, this%nbound - node = this%nodelist(i) - bt = this%dis%bot(node) - ! - ! -- calculate the drainage depth and the top and bottom of - ! the conductance scaling elevations - call this%get_drain_elevations(i, drndepth, drntop, drnbot) - ! - ! -- accumulate errors - if (drnbot < bt .and. this%icelltype(node) /= 0) then - if (drndepth /= DZERO) then - write(errmsg, fmt=fmtddrnerr) i, drnbot, bt - else - write(errmsg, fmt=fmtdrnerr) i, drnbot, bt - end if - call store_error(errmsg) + node = this%nodelist(i) + bt = this%dis%bot(node) + ! + ! -- calculate the drainage depth and the top and bottom of + ! the conductance scaling elevations + call this%get_drain_elevations(i, drndepth, drntop, drnbot) + ! + ! -- accumulate errors + if (drnbot < bt .and. this%icelltype(node) /= 0) then + if (drndepth /= DZERO) then + write (errmsg, fmt=fmtddrnerr) i, drnbot, bt + else + write (errmsg, fmt=fmtdrnerr) i, drnbot, bt end if + call store_error(errmsg) + end if end do ! ! -- write summary of drain package error messages @@ -310,7 +310,7 @@ subroutine drn_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! ! -- Return if no drains - if(this%nbound == 0) return + if (this%nbound == 0) return ! ! -- pakmvrobj cf lrm = .true. @@ -322,14 +322,14 @@ subroutine drn_cf(this, reset_mover) ! -- Calculate hcof and rhs for each drn entry do i = 1, this%nbound node = this%nodelist(i) - if(this%ibound(node) <= 0) then + if (this%ibound(node) <= 0) then this%hcof(i) = DZERO this%rhs(i) = DZERO cycle end if ! ! -- set local variables for this drain - cdrn = this%bound(2,i) + cdrn = this%bound(2, i) ! ! -- calculate the drainage scaling factor call this%get_drain_factor(i, fact, drnbot) @@ -367,9 +367,9 @@ subroutine drn_fc(this, rhs, ia, idxglo, amatsln) ! -------------------------------------------------------------------------- ! ! -- packmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() - endif + end if ! ! -- Copy package rhs and hcof into solution rhs and amat do i = 1, this%nbound @@ -383,17 +383,17 @@ subroutine drn_fc(this, rhs, ia, idxglo, amatsln) ! ! -- If mover is active and this drain is discharging, ! store available water (as positive value). - if(this%imover == 1 .and. fact > DZERO) then - drncond = this%bound(2,i) + if (this%imover == 1 .and. fact > DZERO) then + drncond = this%bound(2, i) qdrn = fact * drncond * (this%xnew(n) - drnbot) call this%pakmvrobj%accumulate_qformvr(i, qdrn) - endif - enddo + end if + end do ! ! -- return return end subroutine drn_fc - + subroutine drn_fn(this, rhs, ia, idxglo, amatsln) ! ************************************************************************** ! drn_fn -- Fill newton terms @@ -427,12 +427,12 @@ subroutine drn_fn(this, rhs, ia, idxglo, amatsln) node = this%nodelist(i) ! ! -- test if node is constant or inactive - if(this%ibound(node) <= 0) then + if (this%ibound(node) <= 0) then cycle end if ! ! -- set local variables for this drain - cdrn = this%bound(2,i) + cdrn = this%bound(2, i) xnew = this%xnew(node) ! ! -- calculate the drainage depth and the top and bottom of @@ -441,7 +441,7 @@ subroutine drn_fn(this, rhs, ia, idxglo, amatsln) ! ! -- calculate scaling factor if (drndepth /= DZERO) then - drterm = sQSaturationDerivative(drntop, drnbot, xnew, & + drterm = sQSaturationDerivative(drntop, drnbot, xnew, & c1=-DONE, c2=DTWO) drterm = drterm * cdrn * (drnbot - xnew) ! @@ -456,7 +456,7 @@ subroutine drn_fn(this, rhs, ia, idxglo, amatsln) ! -- return return end subroutine drn_fn - + subroutine define_listlabel(this) ! ****************************************************************************** ! define_listlabel -- Define the list heading that is written to iout when @@ -469,28 +469,27 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'DRAIN EL.' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'DRAIN EL.' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return end subroutine define_listlabel - subroutine get_drain_elevations(this, i, drndepth, drntop, drnbot) ! ****************************************************************************** ! get_drain_elevations -- Define drain depth and the top and bottom elevations @@ -512,7 +511,7 @@ subroutine get_drain_elevations(this, i, drndepth, drntop, drnbot) ! ! -- initialize dummy and local variables drndepth = DZERO - drnelev = this%bound(1,i) + drnelev = this%bound(1, i) ! ! -- set the drain depth if (this%iauxddrncol > 0) then @@ -533,7 +532,6 @@ subroutine get_drain_elevations(this, i, drndepth, drntop, drnbot) return end subroutine get_drain_elevations - subroutine get_drain_factor(this, i, factor, opt_drnbot) ! ****************************************************************************** ! get_drain_factor -- Get the drain conductance scale factor. @@ -553,39 +551,39 @@ subroutine get_drain_factor(this, i, factor, opt_drnbot) real(DP) :: drntop real(DP) :: drnbot ! ------------------------------------------------------------------------------ - ! - ! -- set local variables for this drain - node = this%nodelist(i) - xnew = this%xnew(node) - ! - ! -- calculate the drainage depth and the top and bottom of - ! the conductance scaling elevations - call this%get_drain_elevations(i, drndepth, drntop, drnbot) - ! - ! -- set opt_drnbot to drnbot if passed as dummy variable - if (present(opt_drnbot)) then - opt_drnbot = drnbot + ! + ! -- set local variables for this drain + node = this%nodelist(i) + xnew = this%xnew(node) + ! + ! -- calculate the drainage depth and the top and bottom of + ! the conductance scaling elevations + call this%get_drain_elevations(i, drndepth, drntop, drnbot) + ! + ! -- set opt_drnbot to drnbot if passed as dummy variable + if (present(opt_drnbot)) then + opt_drnbot = drnbot + end if + ! + ! -- calculate scaling factor + if (drndepth /= DZERO) then + if (this%icubic_scaling /= 0) then + factor = sQSaturation(drntop, drnbot, xnew, c1=-DONE, c2=DTWO) + else + factor = sQuadraticSaturation(drntop, drnbot, xnew, eps=DZERO) end if - ! - ! -- calculate scaling factor - if (drndepth /= DZERO) then - if (this%icubic_scaling /= 0) then - factor = sQSaturation(drntop, drnbot, xnew, c1=-DONE, c2=DTWO) - else - factor = sQuadraticSaturation(drntop, drnbot, xnew, eps=DZERO) - end if + else + if (xnew <= drnbot) then + factor = DZERO else - if (xnew <= drnbot) then - factor = DZERO - else - factor = DONE - end if + factor = DONE end if + end if ! ! -- return return end subroutine get_drain_factor - + ! -- Procedures related to observations logical function drn_obs_supported(this) @@ -647,7 +645,7 @@ subroutine drn_rp_ts(this) type(TimeSeriesLinkType), pointer :: tslink => null() ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then select case (tslink%JCol) @@ -656,8 +654,8 @@ subroutine drn_rp_ts(this) case (2) tslink%Text = 'COND' end select - endif - enddo + end if + end do ! return end subroutine drn_rp_ts diff --git a/src/Model/GroundWaterFlow/gwf3evt8.f90 b/src/Model/GroundWaterFlow/gwf3evt8.f90 index f77838db432..e90d9a10e2f 100644 --- a/src/Model/GroundWaterFlow/gwf3evt8.f90 +++ b/src/Model/GroundWaterFlow/gwf3evt8.f90 @@ -17,16 +17,16 @@ module EvtModule private public :: evt_create ! - character(len=LENFTYPE) :: ftype = 'EVT' - character(len=LENPACKAGENAME) :: text = ' EVT' - character(len=LENPACKAGENAME) :: texta = ' EVTA' + character(len=LENFTYPE) :: ftype = 'EVT' + character(len=LENPACKAGENAME) :: text = ' EVT' + character(len=LENPACKAGENAME) :: texta = ' EVTA' ! type, extends(BndType) :: EvtType ! -- logicals logical, private :: segsdefined = .true. logical, private :: fixed_cell = .false. logical, private :: read_as_arrays = .false. - logical, private:: surfratespecified = .false. + logical, private :: surfratespecified = .false. ! -- integers integer(I4B), pointer :: inievt => null() integer(I4B), pointer, private :: nseg => null() @@ -34,21 +34,21 @@ module EvtModule integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null() contains procedure :: evt_allocate_scalars - procedure :: bnd_options => evt_options - procedure :: read_dimensions => evt_read_dimensions - procedure :: read_initial_attr => evt_read_initial_attr - procedure :: bnd_rp => evt_rp + procedure :: bnd_options => evt_options + procedure :: read_dimensions => evt_read_dimensions + procedure :: read_initial_attr => evt_read_initial_attr + procedure :: bnd_rp => evt_rp procedure :: set_nodesontop - procedure :: bnd_cf => evt_cf - procedure :: bnd_fc => evt_fc - procedure :: bnd_da => evt_da - procedure :: define_listlabel => evt_define_listlabel + procedure :: bnd_cf => evt_cf + procedure :: bnd_fc => evt_fc + procedure :: bnd_da => evt_da + procedure :: define_listlabel => evt_define_listlabel procedure, private :: evt_rp_array procedure, private :: evt_rp_list procedure, private :: default_nodelist procedure, private :: check_pxdp ! -- for observations - procedure, public :: bnd_obs_supported => evt_obs_supported + procedure, public :: bnd_obs_supported => evt_obs_supported procedure, public :: bnd_df_obs => evt_df_obs ! -- for time series procedure, public :: bnd_rp_ts => evt_rp_ts @@ -66,7 +66,7 @@ module EvtModule ! 4->3+nseg Proportion of Extinction Depth PXDP PXDP ! 4+nseg->3+2(nseg) Proportion of Max ET Rate PETM PETM - contains +contains subroutine evt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ****************************************************************************** @@ -79,10 +79,10 @@ subroutine evt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -90,7 +90,7 @@ subroutine evt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate evt object and scalar variables - allocate(evtobj) + allocate (evtobj) packobj => evtobj ! ! -- create name and memory path @@ -108,8 +108,8 @@ subroutine evt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%id = id packobj%ibcnum = ibcnum packobj%ncolbnd = 3 ! Assumes NSEG = 1 - packobj%iscloc = 2 ! sfac applies to max. ET rate - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%iscloc = 2 ! sfac applies to max. ET rate + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! indxconvertflux is Column index of bound that will be multiplied by ! cell area to convert flux rates to flow rates packobj%indxconvertflux = 2 @@ -129,7 +129,7 @@ subroutine evt_allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(EvtType), intent(inout) :: this + class(EvtType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! -- call standard BndType allocate scalars @@ -157,61 +157,61 @@ subroutine evt_options(this, option, found) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(EvtType), intent(inout) :: this + class(EvtType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local character(len=MAXCHARLEN) :: ermsg ! -- formats - character(len=*),parameter :: fmtihact = & - "(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" - character(len=*),parameter :: fmtfixedcell = & - "(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO SPECIFIED CELL.')" + character(len=*), parameter :: fmtihact = & + &"(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" + character(len=*), parameter :: fmtfixedcell = & + &"(4x, 'EVAPOTRANSPIRATION WILL BE APPLIED TO SPECIFIED CELL.')" character(len=*), parameter :: fmtreadasarrays = & - "(4x, 'EVAPOTRANSPIRATION INPUT WILL BE READ AS ARRAYS.')" + &"(4x, 'EVAPOTRANSPIRATION INPUT WILL BE READ AS ARRAYS.')" character(len=*), parameter :: fmtsrz = & - "(4x, 'ET RATE AT SURFACE WILL BE ZERO.')" + &"(4x, 'ET RATE AT SURFACE WILL BE ZERO.')" character(len=*), parameter :: fmtsrs = & - "(4x, 'ET RATE AT SURFACE WILL BE AS SPECIFIED BY PETM0.')" + &"(4x, 'ET RATE AT SURFACE WILL BE AS SPECIFIED BY PETM0.')" ! ------------------------------------------------------------------------------ ! ! -- Check for FIXED_CELL AND LAYERED select case (option) case ('FIXED_CELL') this%fixed_cell = .true. - write(this%iout, fmtfixedcell) + write (this%iout, fmtfixedcell) found = .true. case ('SURF_RATE_SPECIFIED') this%surfratespecified = .true. - write(this%iout, fmtsrs) + write (this%iout, fmtsrs) found = .true. ! if (this%read_as_arrays) then - ermsg = 'READASARRAYS option is not compatible with the' // & + ermsg = 'READASARRAYS option is not compatible with the'// & ' SURF_RATE_SPECIFIED option.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if case ('READASARRAYS') if (this%dis%supports_layers()) then this%read_as_arrays = .true. this%text = texta else - ermsg = 'READASARRAYS option is not compatible with selected' // & + ermsg = 'READASARRAYS option is not compatible with selected'// & ' discretization type.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! if (this%surfratespecified) then - ermsg = 'READASARRAYS option is not compatible with the' // & + ermsg = 'READASARRAYS option is not compatible with the'// & ' SURF_RATE_SPECIFIED option.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Write option - write(this%iout, fmtreadasarrays) + write (this%iout, fmtreadasarrays) ! found = .true. case default @@ -234,14 +234,14 @@ subroutine evt_read_dimensions(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit ! -- dummy - class(EvtType),intent(inout) :: this + class(EvtType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- format character(len=*), parameter :: fmtnsegerr = & - "('Error: In EVT, NSEG must be > 0 but is specified as ',i0)" + &"('Error: In EVT, NSEG must be > 0 but is specified as ',i0)" ! ------------------------------------------------------------------------------ ! ! Dimensions block is not required if: @@ -256,7 +256,7 @@ subroutine evt_read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) @@ -265,58 +265,59 @@ subroutine evt_read_dimensions(this) select case (keyword) case ('MAXBOUND') if (this%read_as_arrays) then - errmsg = 'When READASARRAYS option is used for the selected' // & + errmsg = 'When READASARRAYS option is used for the selected'// & ' discretization package, MAXBOUND may not be specified.' call store_error(errmsg) call this%parser%StoreErrorUnit() else this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - endif + write (this%iout, '(4x,a,i7)') 'MAXBOUND = ', this%maxbound + end if case ('NSEG') this%nseg = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NSEG = ', this%nseg + write (this%iout, '(4x,a,i0)') 'NSEG = ', this%nseg if (this%nseg < 1) then - write(errmsg,fmtnsegerr)this%nseg + write (errmsg, fmtnsegerr) this%nseg call store_error(errmsg) call this%parser%StoreErrorUnit() elseif (this%nseg > 1) then ! NSEG>1 is supported only if readasarrays is false if (this%read_as_arrays) then - errmsg = 'In the EVT package, NSEG cannot be greater than 1' // & + errmsg = 'In the EVT package, NSEG cannot be greater than 1'// & ' when READASARRAYS is used.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! -- Recalculate number of columns required in bound array. if (this%surfratespecified) then - this%ncolbnd = 4 + 2*(this%nseg-1) + this%ncolbnd = 4 + 2 * (this%nseg - 1) else - this%ncolbnd = 3 + 2*(this%nseg-1) - endif - endif + this%ncolbnd = 3 + 2 * (this%nseg - 1) + end if + end if case default - write(errmsg,'(4x,a,a)') & + write (errmsg, '(4x,a,a)') & 'Unknown '//trim(this%text)//' DIMENSION: ', trim(keyword) call store_error(errmsg) call this%parser%StoreErrorUnit() end select end do ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' else call store_error('Required DIMENSIONS block not found.') call this%parser%StoreErrorUnit() - endif - endif + end if + end if ! ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(1x,a)') & + if (this%maxbound <= 0) then + write (errmsg, '(1x,a)') & 'MAXBOUND must be an integer greater than zero.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Call define_listlabel to construct the list label that is written ! when PRINT_INPUT option is used. @@ -335,11 +336,11 @@ subroutine evt_read_initial_attr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(EvtType),intent(inout) :: this + class(EvtType), intent(inout) :: this ! if (this%read_as_arrays) then call this%default_nodelist() - endif + end if ! return end subroutine evt_read_initial_attr @@ -358,7 +359,7 @@ subroutine evt_rp(this) use SimModule, only: store_error use ArrayHandlersModule, only: ifind ! -- dummy - class(EvtType),intent(inout) :: this + class(EvtType), intent(inout) :: this ! -- local integer(I4B) :: ierr integer(I4B) :: node, n @@ -367,18 +368,18 @@ subroutine evt_rp(this) logical :: isfound, supportopenclose character(len=LINELENGTH) :: line, msg ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6," // & - "') IS GREATER THAN MAXIMUM(',I6,')')" + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6,& + &') IS GREATER THAN MAXIMUM(',I6,')')" ! ------------------------------------------------------------------------------ ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- get stress period data if (this%ionper < kper) then @@ -389,7 +390,7 @@ subroutine evt_rp(this) ! so supportOpenClose needs to be false in call the GetBlock. ! When reading as arrays, set supportOpenClose as desired. call this%parser%GetBlock('PERIOD', isfound, ierr) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -402,11 +403,11 @@ subroutine evt_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - endif + end if end if ! ! -- Read data if ionper == kper @@ -432,27 +433,27 @@ subroutine evt_rp(this) ! -- Read Evt input as arrays call this%evt_rp_array(line, inrate, insurf, indepth, & kpxdp, kpetm) - endif + end if ! ! -- Ensure that all required PXDP and PETM arrays ! have been defined or redefined. if (this%surfratespecified) then if (kpxdp == this%nseg .and. kpxdp == this%nseg) then this%segsdefined = .true. - endif + end if else - if (kpxdp == this%nseg-1 .and. kpxdp == this%nseg-1) then + if (kpxdp == this%nseg - 1 .and. kpxdp == this%nseg - 1) then this%segsdefined = .true. - endif - endif + end if + end if if (.not. this%segsdefined) then msg = 'Error in EVT input: Definition of PXDP or PETM is incomplete.' call store_error(msg) call this%parser%StoreErrorUnit() - endif + end if else - write(this%iout,fmtlsp) trim(this%filtyp) - endif + write (this%iout, fmtlsp) trim(this%filtyp) + end if ! ! -- If rate was read, then multiply by cell area. If inrate = 2, then ! rate is begin managed as a time series, and the time series object @@ -463,18 +464,18 @@ subroutine evt_rp(this) if (node > 0) then this%bound(2, n) = this%bound(2, n) * this%dis%get_area(node) end if - enddo + end do ! ! -- ensure pxdp is monotonically increasing if (this%nseg > 1) then call this%check_pxdp() end if - endif + end if ! ! -- return return end subroutine evt_rp - + !> @brief Subroutine to check pxdp !! !! If the number of EVT segments (nseg) is greater than one, then @@ -484,7 +485,7 @@ end subroutine evt_rp !< subroutine check_pxdp(this) ! -- dummy - class(EvtType),intent(inout) :: this !< EvtType + class(EvtType), intent(inout) :: this !< EvtType ! -- local integer(I4B) :: n integer(I4B) :: node @@ -495,9 +496,9 @@ subroutine check_pxdp(this) character(len=15) :: nodestr ! -- formats character(len=*), parameter :: fmtpxdp0 = & - "('PXDP must be between 0 and 1. Found ', G0, ' for cell ', A)" + &"('PXDP must be between 0 and 1. Found ', G0, ' for cell ', A)" character(len=*), parameter :: fmtpxdp = & - "('PXDP is not monotonically increasing for cell ', A)" + &"('PXDP is not monotonically increasing for cell ', A)" ! ! -- check and make sure that pxdp is monotonically increasing and ! that pxdp values are between 0 and 1 @@ -512,7 +513,7 @@ subroutine check_pxdp(this) pxdp2 = this%bound(i + 3, n) if (pxdp2 <= DZERO .or. pxdp2 >= DONE) then call this%dis%noder_to_string(node, nodestr) - write(errmsg, fmtpxdp0) pxdp2, trim(nodestr) + write (errmsg, fmtpxdp0) pxdp2, trim(nodestr) call store_error(errmsg) end if else @@ -524,7 +525,7 @@ subroutine check_pxdp(this) if (ierrmono == 0) then ! -- only store mono error once for each node call this%dis%noder_to_string(node, nodestr) - write(errmsg, fmtpxdp) trim(nodestr) + write (errmsg, fmtpxdp) trim(nodestr) call store_error(errmsg) end if ierrmono = 1 @@ -550,21 +551,21 @@ subroutine set_nodesontop(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(EvtType),intent(inout) :: this + class(EvtType), intent(inout) :: this ! -- local integer(I4B) :: n ! -- formats ! ------------------------------------------------------------------------------ ! ! -- allocate if necessary - if(.not. associated(this%nodesontop)) then - allocate(this%nodesontop(this%maxbound)) - endif + if (.not. associated(this%nodesontop)) then + allocate (this%nodesontop(this%maxbound)) + end if ! ! -- copy nodelist into nodesontop do n = 1, this%nbound this%nodesontop(n) = this%nodelist(n) - enddo + end do ! ! -- return return @@ -592,7 +593,7 @@ subroutine evt_cf(this, reset_mover) if (this%nbound == 0) return ! ! -- Calculate hcof and rhs for each ET node - do i=1,this%nbound + do i = 1, this%nbound ! ! -- Find the node number if (this%fixed_cell) then @@ -613,7 +614,7 @@ subroutine evt_cf(this, reset_mover) if (this%ibound(node) == 0) & call this%dis%highest_active(node, this%ibound) this%nodelist(i) = node - endif + end if ! ! -- set rhs and hcof to zero this%rhs(i) = DZERO @@ -622,12 +623,12 @@ subroutine evt_cf(this, reset_mover) ! -- if ibound is positive and not overlain by a lake, then add terms if (this%ibound(node) > 0 .and. this%ibound(node) /= 10000) then ! - c = this%bound(2,i) ! RATE -- max. ET rate - s = this%bound(1,i) ! SURFACE -- ET surface elevation + c = this%bound(2, i) ! RATE -- max. ET rate + s = this%bound(1, i) ! SURFACE -- ET surface elevation h = this%xnew(node) if (this%surfratespecified) then - petm0 = this%bound(4+2*(this%nseg-1),i) ! PETM0 - endif + petm0 = this%bound(4 + 2 * (this%nseg - 1), i) ! PETM0 + end if ! ! -- If head in cell is greater than or equal to SURFACE, ET is constant if (h >= s) then @@ -637,11 +638,11 @@ subroutine evt_cf(this, reset_mover) else ! -- Subtract -RATE from RHS this%rhs(i) = this%rhs(i) + c - endif + end if else ! -- If depth to water >= extinction depth, then ET is 0 d = S - h - x = this%bound(3,i) ! DEPTH -- extinction depth + x = this%bound(3, i) ! DEPTH -- extinction depth if (d < x) then ! -- Variable range. add ET terms to both RHS and HCOF. if (this%nseg > 1) then @@ -661,7 +662,7 @@ subroutine evt_cf(this, reset_mover) petm1 = petm0 else petm1 = DONE - endif + end if ! -- Initialize indices to point to elements preceding ! pxdp1 and petm1 (values for lower end of segment 1). idxdepth = 3 @@ -676,38 +677,38 @@ subroutine evt_cf(this, reset_mover) idxdepth = idxdepth + 1 idxrate = idxrate + 1 ! -- Get proportions for lower end of segment - pxdp2 = this%bound(idxdepth,i) - petm2 = this%bound(idxrate,i) + pxdp2 = this%bound(idxdepth, i) + petm2 = this%bound(idxrate, i) else pxdp2 = DONE petm2 = DZERO - endif - if (d <= pxdp2*x) then + end if + if (d <= pxdp2 * x) then ! -- head is in domain of this segment exit segloop - endif + end if ! -- Proportions at lower end of segment will be for ! upper end of segment next time through loop pxdp1 = pxdp2 petm1 = petm2 - enddo segloop + end do segloop ! -- Calculate terms to add to RHS and HCOF based on ! segment that applies at head elevation - thcof = - (petm1 - petm2) * c / ((pxdp2 - pxdp1) * x) + thcof = -(petm1 - petm2) * c / ((pxdp2 - pxdp1) * x) trhs = thcof * (s - pxdp1 * x) + petm1 * c else ! -- Calculate terms to add to RHS and HCOF based on simple ! linear relation of ET vs. head for single segment trhs = c - c * s / x thcof = -c / x - endif + end if this%rhs(i) = this%rhs(i) + trhs this%hcof(i) = this%hcof(i) + thcof - endif - endif - endif + end if + end if + end if ! - enddo + end do ! ! -- return return @@ -743,7 +744,7 @@ subroutine evt_fc(this, rhs, ia, idxglo, amatsln) rhs(n) = rhs(n) + this%rhs(i) ipos = ia(n) amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo + end do ! ! -- return return @@ -763,7 +764,7 @@ subroutine evt_da(this) ! ------------------------------------------------------------------------------ ! ! -- arrays - if(associated(this%nodesontop)) deallocate(this%nodesontop) + if (associated(this%nodesontop)) deallocate (this%nodesontop) ! ! -- scalars call mem_deallocate(this%inievt) @@ -789,13 +790,13 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & use SimModule, only: store_error use ArrayHandlersModule, only: ifind ! -- dummy - class(EvtType), intent(inout) :: this + class(EvtType), intent(inout) :: this character(len=LINELENGTH), intent(inout) :: line - integer(I4B), intent(inout) :: inrate - integer(I4B), intent(inout) :: insurf - integer(I4B), intent(inout) :: indepth - integer(I4B), intent(inout) :: kpxdp - integer(I4B), intent(inout) :: kpetm + integer(I4B), intent(inout) :: inrate + integer(I4B), intent(inout) :: insurf + integer(I4B), intent(inout) :: indepth + integer(I4B), intent(inout) :: kpxdp + integer(I4B), intent(inout) :: kpetm ! -- local integer(I4B) :: n integer(I4B) :: indx, ipos @@ -811,18 +812,18 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & real(DP), dimension(:), pointer :: bndArrayPtr => null() real(DP), dimension(:), pointer :: auxArrayPtr => null() real(DP), dimension(:), pointer :: auxMultArray => null() - type(TimeArraySeriesLinkType), pointer :: tasLink => null() + type(TimeArraySeriesLinkType), pointer :: tasLink => null() ! -- formats - character(len=*),parameter :: fmtevtauxmult = & + character(len=*), parameter :: fmtevtauxmult = & "(4x, 'THE ET RATE ARRAY IS BEING MULTIPLED BY THE AUXILIARY ARRAY WITH & &THE NAME: ', A)" ! -- data - data aname(1) /' LAYER OR NODE INDEX'/ - data aname(2) /' ET SURFACE'/ - data aname(3) /' EVAPOTRANSPIRATION RATE'/ - data aname(4) /' EXTINCTION DEPTH'/ - data aname(5) /'EXTINCT. DEP. PROPORTION'/ - data aname(6) /' ET RATE PROPORTION'/ + data aname(1)/' LAYER OR NODE INDEX'/ + data aname(2)/' ET SURFACE'/ + data aname(3)/' EVAPOTRANSPIRATION RATE'/ + data aname(4)/' EXTINCTION DEPTH'/ + data aname(5)/'EXTINCT. DEP. PROPORTION'/ + data aname(6)/' ET RATE PROPORTION'/ ! ------------------------------------------------------------------------------ ! ! -- Initialize @@ -848,11 +849,12 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & call store_error('****ERROR. IEVT IS NOT FIRST VARIABLE IN & &PERIOD BLOCK OR IT IS SPECIFIED MORE THAN ONCE.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Read the IEVT array call this%dis%nlarray_to_nodelist(this%nodelist, this%maxbound, & - this%nbound, aname(1), this%parser%iuactive, this%iout) + this%nbound, aname(1), & + this%parser%iuactive, this%iout) ! ! -- set flag to indicate that IEVT has been read this%inievt = 1 @@ -867,13 +869,13 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & call store_error('Error. IEVT must be read at least once ') call store_error('prior to reading the SURFACE array.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Read the surface array, then indicate ! that surface array was read by setting insurf - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 1, aname(2), this%parser%iuactive, & - this%iout) + call this%dis%read_layer_array(this%nodelist, this%bound, this%ncolbnd, & + this%maxbound, 1, aname(2), & + this%parser%iuactive, this%iout) insurf = 1 ! case ('RATE') @@ -886,15 +888,15 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & call this%parser%GetStringCaps(tasName) ! -- Ensure that time-array series has been defined and that name ! of time-array series is valid. - jcol = 2 ! for max ET rate - bndArrayPtr => this%bound(jcol,:) + jcol = 2 ! for max ET rate + bndArrayPtr => this%bound(jcol, :) ! Make a time-array-series link and add it to the list of links ! contained in the TimeArraySeriesManagerType object. convertflux = .true. - call this%TasManager%MakeTasLink(this%packName, bndArrayPtr, & - this%iprpak, tasName, 'RATE', & - convertFlux, this%nodelist, & - this%parser%iuactive) + call this%TasManager%MakeTasLink(this%packName, bndArrayPtr, & + this%iprpak, tasName, 'RATE', & + convertFlux, this%nodelist, & + this%parser%iuactive) lpos = this%TasManager%CountLinks() tasLink => this%TasManager%GetLink(lpos) inrate = 2 @@ -903,10 +905,11 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & ! -- Read the Max. ET Rate array, then indicate ! that rate array was read by setting inrate call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 2, aname(3), this%parser%iuactive, & - this%iout) + this%ncolbnd, this%maxbound, 2, & + aname(3), this%parser%iuactive, & + this%iout) inrate = 1 - endif + end if ! case ('DEPTH') ! @@ -914,13 +917,13 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & call store_error('IEVT must be read at least once ') call store_error('prior to reading the DEPTH array.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Read the extinction-depth array, then indicate ! that depth array was read by setting indepth - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 3, aname(4), this%parser%iuactive, & - this%iout) + call this%dis%read_layer_array(this%nodelist, this%bound, this%ncolbnd, & + this%maxbound, 3, aname(4), & + this%parser%iuactive, this%iout) indepth = 1 ! case ('PXDP') @@ -928,56 +931,56 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & ermsg = 'EVT input: PXDP cannot be specified when NSEG < 2' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! if (this%inievt == 0) then call store_error('IEVT must be read at least once ') call store_error('prior to reading any PXDP array.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Assign column for this PXDP vector in bound array kpxdp = kpxdp + 1 - if (kpxdp < this%nseg-1) this%segsdefined = .false. - if (kpxdp > this%nseg-1) then + if (kpxdp < this%nseg - 1) this%segsdefined = .false. + if (kpxdp > this%nseg - 1) then ermsg = 'EVT: Number of PXDP arrays exceeds NSEG-1.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if indx = 3 + kpxdp ! ! -- Read the PXDP array - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, indx, aname(5), & - this%parser%iuactive, this%iout) + call this%dis%read_layer_array(this%nodelist, this%bound, this%ncolbnd, & + this%maxbound, indx, aname(5), & + this%parser%iuactive, this%iout) ! case ('PETM') if (this%nseg < 2) then ermsg = 'EVT input: PETM cannot be specified when NSEG < 2' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! if (this%inievt == 0) then call store_error('IEVT must be read at least once ') call store_error('prior to reading any PETM array.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Assign column for this PETM vector in bound array kpetm = kpetm + 1 - if (kpetm < this%nseg-1) this%segsdefined = .false. - if (kpetm > this%nseg-1) then + if (kpetm < this%nseg - 1) this%segsdefined = .false. + if (kpetm > this%nseg - 1) then ermsg = 'EVT: Number of PETM arrays exceeds NSEG-1.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if indx = 3 + this%nseg - 1 + kpetm ! ! -- Read the PETM array - call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, indx, aname(6), & - this%parser%iuactive, this%iout) + call this%dis%read_layer_array(this%nodelist, this%bound, this%ncolbnd, & + this%maxbound, indx, aname(6), & + this%parser%iuactive, this%iout) ! case default ! @@ -995,22 +998,23 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & ! -- Get time-array series name call this%parser%GetStringCaps(tasName) jauxcol = jauxcol + 1 - auxArrayPtr => this%auxvar(jauxcol,:) + auxArrayPtr => this%auxvar(jauxcol, :) ! Make a time-array-series link and add it to the list of links ! contained in the TimeArraySeriesManagerType object. convertflux = .false. - call this%TasManager%MakeTasLink(this%packName, auxArrayPtr, & - this%iprpak, tasName, & - this%auxname(ipos), convertFlux, & - this%nodelist, this%parser%iuactive) + call this%TasManager%MakeTasLink(this%packName, auxArrayPtr, & + this%iprpak, tasName, & + this%auxname(ipos), convertFlux, & + this%nodelist, this%parser%iuactive) else ! ! -- Read the aux variable array call this%dis%read_layer_array(this%nodelist, this%auxvar, & - this%naux, this%maxbound, ipos, atemp, this%parser%iuactive, & - this%iout) - endif - endif + this%naux, this%maxbound, ipos, & + atemp, this%parser%iuactive, & + this%iout) + end if + end if ! ! -- Nothing found if (.not. found) then @@ -1018,13 +1022,13 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & call store_error('LOOKING FOR VALID VARIABLE NAME. FOUND: ') call store_error(trim(line)) call this%parser%StoreErrorUnit() - endif + end if ! ! If this aux variable has been designated as a multiplier array ! by presence of AUXMULTNAME, set local pointer appropriately. if (this%iauxmultcol > 0 .and. this%iauxmultcol == ipos) then - auxMultArray => this%auxvar(this%iauxmultcol,:) - endif + auxMultArray => this%auxvar(this%iauxmultcol, :) + end if end select ! ! -- Increment the number of variables read @@ -1034,14 +1038,14 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & ! ! -- Ensure that all required PXDP and PETM arrays ! have been defined or redefined. - if (kpxdp == this%nseg-1 .and. kpxdp == this%nseg-1) then + if (kpxdp == this%nseg - 1 .and. kpxdp == this%nseg - 1) then this%segsdefined = .true. - endif + end if if (.not. this%segsdefined) then ermsg = 'EVT input: Definition of PXDP or PETM is incomplete.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! ! If the multiplier-array pointer has been assigned and ! stress is controlled by a time-array series, assign @@ -1049,18 +1053,18 @@ subroutine evt_rp_array(this, line, inrate, insurf, indepth, & if (associated(auxMultArray)) then if (associated(tasLink)) then tasLink%RMultArray => auxMultArray - endif - endif + end if + end if ! ! -- If et rate was read and auxmultcol was specified, then multiply ! the et rate by the multplier column - if(inrate == 1 .and. this%iauxmultcol > 0) then - write(this%iout, fmtevtauxmult) this%auxname(this%iauxmultcol) + if (inrate == 1 .and. this%iauxmultcol > 0) then + write (this%iout, fmtevtauxmult) this%auxname(this%iauxmultcol) do n = 1, this%nbound - this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & - this%auxvar(this%iauxmultcol, n) - enddo - endif + this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & + this%auxvar(this%iauxmultcol, n) + end do + end if ! return end subroutine evt_rp_array @@ -1074,27 +1078,27 @@ subroutine evt_rp_list(this, inrate) ! ------------------------------------------------------------------------------ ! -- dummy class(EvtType), intent(inout) :: this - integer(I4B), intent(inout) :: inrate + integer(I4B), intent(inout) :: inrate ! -- local integer(I4B) :: maxboundorig, nlist ! ------------------------------------------------------------------------------ ! nlist = -1 maxboundorig = this%maxbound - call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & - nlist, this%inamedbound, this%iauxmultcol, & - this%nodelist, this%bound, this%auxvar, & - this%auxname, this%boundname, this%listlabel, & - this%packName, this%tsManager, this%iscloc, & - this%indxconvertflux) + call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & + nlist, this%inamedbound, this%iauxmultcol, & + this%nodelist, this%bound, this%auxvar, & + this%auxname, this%boundname, this%listlabel, & + this%packName, this%tsManager, this%iscloc, & + this%indxconvertflux) this%nbound = nlist if (this%maxbound > maxboundorig) then ! -- The arrays that belong to BndType have been extended. ! Now, EVT array nodesontop needs to be recreated. if (associated(this%nodesontop)) then - deallocate(this%nodesontop) - endif - endif + deallocate (this%nodesontop) + end if + end if if (.not. this%fixed_cell) call this%set_nodesontop() inrate = 1 ! @@ -1117,45 +1121,45 @@ subroutine evt_define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'SURFACE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MAX. RATE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'EXT. DEPTH' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'SURFACE' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'MAX. RATE' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'EXT. DEPTH' ! ! -- add headings for as many PXDP and PETM columns as needed nsegm1 = this%nseg - 1 if (nsegm1 > 0) then - do i = 1,nsegm1 - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PXDP' - enddo - do i = 1,nsegm1 - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM' - enddo - endif + do i = 1, nsegm1 + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'PXDP' + end do + do i = 1, nsegm1 + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM' + end do + end if ! ! -- PETM0, if SURF_RATE_SPECIFIED is used if (this%surfratespecified) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM0' - endif + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'PETM0' + end if ! ! ! -- multiplier ! if(this%multindex > 0) & ! write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MULTIPLIER' ! ! -- boundary name - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -1180,15 +1184,15 @@ subroutine default_nodelist(this) ! ------------------------------------------------------------------------------ ! ! -- set variables - if(this%dis%ndim == 3) then + if (this%dis%ndim == 3) then nlay = this%dis%mshape(1) nrow = this%dis%mshape(2) ncol = this%dis%mshape(3) - elseif(this%dis%ndim == 2) then + elseif (this%dis%ndim == 2) then nlay = this%dis%mshape(1) nrow = 1 ncol = this%dis%mshape(2) - endif + end if ! ! -- Populate nodelist ipos = 1 @@ -1199,8 +1203,8 @@ subroutine default_nodelist(this) noder = this%dis%get_nodenumber(nodeu, 0) this%nodelist(ipos) = noder ipos = ipos + 1 - enddo - enddo + end do + end do ! ! Set flag that indicates IEVT has been assigned, and assign nbound. this%inievt = 1 @@ -1208,7 +1212,7 @@ subroutine default_nodelist(this) ! ! -- if fixed_cell option not set, then need to store nodelist ! in the nodesontop array - if(.not. this%fixed_cell) call this%set_nodesontop() + if (.not. this%fixed_cell) call this%set_nodesontop() ! ! -- return end subroutine default_nodelist @@ -1286,8 +1290,8 @@ subroutine evt_rp_ts(this) case (3) tslink%Text = 'DEPTH' end select - endif - enddo + end if + end do ! return end subroutine evt_rp_ts diff --git a/src/Model/GroundWaterFlow/gwf3ghb8.f90 b/src/Model/GroundWaterFlow/gwf3ghb8.f90 index 274b775af6d..9757b1a16c4 100644 --- a/src/Model/GroundWaterFlow/gwf3ghb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ghb8.f90 @@ -1,11 +1,11 @@ module ghbmodule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME - use MemoryHelperModule, only: create_mem_path - use BndModule, only: BndType - use ObsModule, only: DefaultObsIdProcessor - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - GetTimeSeriesLinkFromList + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME + use MemoryHelperModule, only: create_mem_path + use BndModule, only: BndType + use ObsModule, only: DefaultObsIdProcessor + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList ! implicit none ! @@ -13,8 +13,8 @@ module ghbmodule public :: ghb_create public :: GhbType ! - character(len=LENFTYPE) :: ftype = 'GHB' - character(len=LENPACKAGENAME) :: text = ' GHB' + character(len=LENFTYPE) :: ftype = 'GHB' + character(len=LENPACKAGENAME) :: text = ' GHB' ! type, extends(BndType) :: GhbType contains @@ -43,10 +43,10 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -54,7 +54,7 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(ghbobj) + allocate (ghbobj) packobj => ghbobj ! ! -- create name and memory path @@ -67,13 +67,13 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! -- initialize package call packobj%pack_initialize() ! - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id packobj%ibcnum = ibcnum - packobj%ncolbnd=2 - packobj%iscloc=2 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%ncolbnd = 2 + packobj%iscloc = 2 + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return return @@ -89,20 +89,20 @@ subroutine ghb_options(this, option, found) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GhbType), intent(inout) :: this + class(GhbType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! ------------------------------------------------------------------------------ ! select case (option) - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. end select ! ! -- return @@ -120,7 +120,7 @@ subroutine ghb_ck(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(GhbType),intent(inout) :: this + class(GhbType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: errmsg integer(I4B) :: i @@ -128,19 +128,19 @@ subroutine ghb_ck(this) real(DP) :: bt ! -- formats character(len=*), parameter :: fmtghberr = & - "('GHB BOUNDARY (',i0,') HEAD (',f10.3,') IS LESS THAN CELL " // & - "BOTTOM (',f10.3,')')" + "('GHB BOUNDARY (',i0,') HEAD (',f10.3,') IS LESS THAN CELL & + &BOTTOM (',f10.3,')')" ! ------------------------------------------------------------------------------ ! ! -- check stress period data do i = 1, this%nbound - node = this%nodelist(i) - bt = this%dis%bot(node) - ! -- accumulate errors - if (this%bound(1,i) < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtghberr) i, this%bound(1,i), bt - call store_error(errmsg) - end if + node = this%nodelist(i) + bt = this%dis%bot(node) + ! -- accumulate errors + if (this%bound(1, i) < bt .and. this%icelltype(node) /= 0) then + write (errmsg, fmt=fmtghberr) i, this%bound(1, i), bt + call store_error(errmsg) + end if end do ! !write summary of ghb package error messages @@ -170,25 +170,25 @@ subroutine ghb_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! ! -- Return if no ghbs - if(this%nbound.eq.0) return + if (this%nbound .eq. 0) return ! ! -- packmvrobj cf lrm = .true. if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then + if (this%imover == 1 .and. lrm) then call this%pakmvrobj%cf() - endif + end if ! ! -- Calculate hcof and rhs for each ghb entry - do i=1,this%nbound - node=this%nodelist(i) - if(this%ibound(node).le.0) then - this%hcof(i)=DZERO - this%rhs(i)=DZERO - cycle - endif - this%hcof(i) = -this%bound(2,i) - this%rhs(i) = -this%bound(2,i) * this%bound(1,i) + do i = 1, this%nbound + node = this%nodelist(i) + if (this%ibound(node) .le. 0) then + this%hcof(i) = DZERO + this%rhs(i) = DZERO + cycle + end if + this%hcof(i) = -this%bound(2, i) + this%rhs(i) = -this%bound(2, i) * this%bound(1, i) end do ! ! -- return @@ -214,9 +214,9 @@ subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) ! -------------------------------------------------------------------------- ! ! -- pakmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() - endif + end if ! ! -- Copy package rhs and hcof into solution rhs and amat do i = 1, this%nbound @@ -227,13 +227,13 @@ subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) ! ! -- If mover is active and this boundary is discharging, ! store available water (as positive value). - bhead = this%bound(1,i) - if(this%imover == 1 .and. this%xnew(n) > bhead) then - cond = this%bound(2,i) + bhead = this%bound(1, i) + if (this%imover == 1 .and. this%xnew(n) > bhead) then + cond = this%bound(2, i) qghb = cond * (this%xnew(n) - bhead) call this%pakmvrobj%accumulate_qformvr(i, qghb) - endif - enddo + end if + end do ! ! -- return return @@ -251,22 +251,22 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -275,36 +275,36 @@ end subroutine define_listlabel ! -- Procedures related to observations logical function ghb_obs_supported(this) - ! ****************************************************************************** - ! ghb_obs_supported - ! -- Return true because GHB package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! ghb_obs_supported + ! -- Return true because GHB package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ implicit none class(GhbType) :: this - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ ghb_obs_supported = .true. return end function ghb_obs_supported subroutine ghb_df_obs(this) - ! ****************************************************************************** - ! ghb_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by GHB package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! ghb_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by GHB package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ implicit none ! -- dummy class(GhbType) :: this ! -- local integer(I4B) :: indx - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ call this%obs%StoreObsType('ghb', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor ! @@ -331,7 +331,7 @@ subroutine ghb_rp_ts(this) type(TimeSeriesLinkType), pointer :: tslink => null() ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then select case (tslink%JCol) @@ -340,8 +340,8 @@ subroutine ghb_rp_ts(this) case (2) tslink%Text = 'COND' end select - endif - enddo + end if + end do ! return end subroutine ghb_rp_ts diff --git a/src/Model/GroundWaterFlow/gwf3hfb8.f90 b/src/Model/GroundWaterFlow/gwf3hfb8.f90 index 8e1e3fdfb05..3cb4808c747 100644 --- a/src/Model/GroundWaterFlow/gwf3hfb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3hfb8.f90 @@ -2,10 +2,10 @@ module GwfHfbModule use KindModule, only: DP, I4B - use Xt3dModule, only: Xt3dType + use Xt3dModule, only: Xt3dType use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType implicit none @@ -14,34 +14,34 @@ module GwfHfbModule public :: hfb_cr type, extends(NumericalPackageType) :: GwfHfbType - integer(I4B), pointer :: maxhfb => null() !max number of hfb's - integer(I4B), pointer :: nhfb => null() !number of hfb's - integer(I4B), dimension(:), pointer, contiguous :: noden => null() !first cell - integer(I4B), dimension(:), pointer, contiguous :: nodem => null() !second cell - integer(I4B), dimension(:), pointer, contiguous :: idxloc => null() !position in model ja - real(DP), dimension(:), pointer, contiguous :: hydchr => null() !hydraulic characteristic of the barrier - real(DP), dimension(:), pointer, contiguous :: csatsav => null() !value of condsat prior to hfb modification - real(DP), dimension(:), pointer, contiguous :: condsav => null() !saved conductance of combined npf and hfb - type(Xt3dType), pointer :: xt3d => null() !pointer to xt3d object - ! - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !pointer to model icelltype - integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !pointer to model ihc - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !pointer to model ia - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !pointer to model ja - integer(I4B), dimension(:), pointer, contiguous :: jas => null() !pointer to model jas - integer(I4B), dimension(:), pointer, contiguous :: isym => null() !pointer to model isym - real(DP), dimension(:), pointer, contiguous :: condsat => null() !pointer to model condsat - real(DP), dimension(:), pointer, contiguous :: top => null() !pointer to model top - real(DP), dimension(:), pointer, contiguous :: bot => null() !pointer to model bot - real(DP), dimension(:), pointer, contiguous :: hwva => null() !pointer to model hwva + integer(I4B), pointer :: maxhfb => null() !max number of hfb's + integer(I4B), pointer :: nhfb => null() !number of hfb's + integer(I4B), dimension(:), pointer, contiguous :: noden => null() !first cell + integer(I4B), dimension(:), pointer, contiguous :: nodem => null() !second cell + integer(I4B), dimension(:), pointer, contiguous :: idxloc => null() !position in model ja + real(DP), dimension(:), pointer, contiguous :: hydchr => null() !hydraulic characteristic of the barrier + real(DP), dimension(:), pointer, contiguous :: csatsav => null() !value of condsat prior to hfb modification + real(DP), dimension(:), pointer, contiguous :: condsav => null() !saved conductance of combined npf and hfb + type(Xt3dType), pointer :: xt3d => null() !pointer to xt3d object + ! + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !pointer to model icelltype + integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !pointer to model ihc + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !pointer to model ia + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !pointer to model ja + integer(I4B), dimension(:), pointer, contiguous :: jas => null() !pointer to model jas + integer(I4B), dimension(:), pointer, contiguous :: isym => null() !pointer to model isym + real(DP), dimension(:), pointer, contiguous :: condsat => null() !pointer to model condsat + real(DP), dimension(:), pointer, contiguous :: top => null() !pointer to model top + real(DP), dimension(:), pointer, contiguous :: bot => null() !pointer to model bot + real(DP), dimension(:), pointer, contiguous :: hwva => null() !pointer to model hwva contains procedure :: hfb_ar procedure :: hfb_rp procedure :: hfb_fc procedure :: hfb_cq procedure :: hfb_da - procedure :: allocate_scalars + procedure :: allocate_scalars procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: read_dimensions @@ -51,7 +51,7 @@ module GwfHfbModule procedure, private :: condsat_modify end type GwfHfbType - contains +contains subroutine hfb_cr(hfbobj, name_model, inunit, iout) ! ****************************************************************************** @@ -68,7 +68,7 @@ subroutine hfb_cr(hfbobj, name_model, inunit, iout) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(hfbobj) + allocate (hfbobj) ! ! -- create name and memory path call hfbobj%set_names(1, name_model, 'HFB', 'HFB') @@ -103,26 +103,28 @@ subroutine hfb_ar(this, ibound, xt3d, dis) type(Xt3dType), pointer :: xt3d class(DisBaseType), pointer, intent(inout) :: dis ! -- formats - character(len=*), parameter :: fmtheader = & - &"(1x, /1x, 'HFB -- HORIZONTAL FLOW BARRIER PACKAGE, VERSION 8, ', & - &'4/24/2015 INPUT READ FROM UNIT ', i4, //)" + character(len=*), parameter :: fmtheader = & + "(1x, /1x, 'HFB -- HORIZONTAL FLOW BARRIER PACKAGE, VERSION 8, ', & + &'4/24/2015 INPUT READ FROM UNIT ', i4, //)" ! ------------------------------------------------------------------------------ ! ! -- Print a message identifying the node property flow package. - write(this%iout, fmtheader) this%inunit + write (this%iout, fmtheader) this%inunit ! ! -- Set pointers this%dis => dis this%ibound => ibound this%xt3d => xt3d - call mem_setptr(this%icelltype, 'ICELLTYPE', create_mem_path(this%name_model, 'NPF')) + call mem_setptr(this%icelltype, 'ICELLTYPE', & + create_mem_path(this%name_model, 'NPF')) call mem_setptr(this%ihc, 'IHC', create_mem_path(this%name_model, 'CON')) call mem_setptr(this%ia, 'IA', create_mem_path(this%name_model, 'CON')) call mem_setptr(this%ja, 'JA', create_mem_path(this%name_model, 'CON')) call mem_setptr(this%jas, 'JAS', create_mem_path(this%name_model, 'CON')) call mem_setptr(this%isym, 'ISYM', create_mem_path(this%name_model, 'CON')) - call mem_setptr(this%condsat, 'CONDSAT', create_mem_path(this%name_model, 'NPF')) + call mem_setptr(this%condsat, 'CONDSAT', create_mem_path(this%name_model, & + 'NPF')) call mem_setptr(this%top, 'TOP', create_mem_path(this%name_model, 'DIS')) call mem_setptr(this%bot, 'BOT', create_mem_path(this%name_model, 'DIS')) call mem_setptr(this%hwva, 'HWVA', create_mem_path(this%name_model, 'CON')) @@ -153,10 +155,10 @@ subroutine hfb_rp(this) integer(I4B) :: ierr logical :: isfound ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" ! ------------------------------------------------------------------------------ ! ! -- Set ionper to the stress period number for which a new block of data @@ -166,7 +168,7 @@ subroutine hfb_rp(this) ! -- get period block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -179,20 +181,20 @@ subroutine hfb_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - endif + end if end if ! - if(this%ionper == kper) then + if (this%ionper == kper) then call this%condsat_reset() call this%read_data() call this%condsat_modify() else - write(this%iout,fmtlsp) 'HFB' - endif + write (this%iout, fmtlsp) 'HFB' + end if ! ! -- return return @@ -214,13 +216,13 @@ subroutine hfb_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! -- dummy class(GwfHfbType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amat + integer(I4B), intent(in), dimension(:) :: idxglo + real(DP), intent(inout), dimension(:) :: rhs + real(DP), intent(inout), dimension(:) :: hnew ! -- local - integer(I4B) :: nodes, nja + integer(I4B) :: nodes, nja integer(I4B) :: ihfb, n, m integer(I4B) :: ipos integer(I4B) :: idiag, isymcon @@ -238,33 +240,33 @@ subroutine hfb_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ixt3d = 0 end if ! - if(ixt3d > 0) then + if (ixt3d > 0) then ! do ihfb = 1, this%nhfb n = min(this%noden(ihfb), this%nodem(ihfb)) m = max(this%noden(ihfb), this%nodem(ihfb)) ! -- Skip if either cell is inactive. - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then ! -- Compute scale factor for hfb correction - if(this%hydchr(ihfb) > DZERO) then - if(this%inewton == 0) then + if (this%hydchr(ihfb) > DZERO) then + if (this%inewton == 0) then ipos = this%idxloc(ihfb) topn = this%top(n) topm = this%top(m) botn = this%bot(n) botm = this%bot(m) - if(this%icelltype(n) == 1) then - if(hnew(n) < topn) topn = hnew(n) - endif - if(this%icelltype(m) == 1) then - if(hnew(m) < topm) topm = hnew(m) - endif - if(this%ihc(this%jas(ipos)) == 2) then + if (this%icelltype(n) == 1) then + if (hnew(n) < topn) topn = hnew(n) + end if + if (this%icelltype(m) == 1) then + if (hnew(m) < topm) topm = hnew(m) + end if + if (this%ihc(this%jas(ipos)) == 2) then faheight = min(topn, topm) - max(botn, botm) else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif + faheight = DHALF * ((topn - botn) + (topm - botm)) + end if fawidth = this%hwva(this%jas(ipos)) condhfb = this%hydchr(ihfb) * fawidth * faheight else @@ -272,47 +274,47 @@ subroutine hfb_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) end if else condhfb = this%hydchr(ihfb) - endif + end if ! -- Make hfb corrections for xt3d - call this%xt3d%xt3d_fhfb(kiter, nodes, nja, njasln, amat, idxglo, & - rhs, hnew, n, m, condhfb) + call this%xt3d%xt3d_fhfb(kiter, nodes, nja, njasln, amat, idxglo, & + rhs, hnew, n, m, condhfb) end do ! else ! ! -- For Newton, the effect of the barrier is included in condsat. - if(this%inewton == 0) then + if (this%inewton == 0) then do ihfb = 1, this%nhfb ipos = this%idxloc(ihfb) aterm = amat(idxglo(ipos)) n = this%noden(ihfb) m = this%nodem(ihfb) - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle - if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then + if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + if (this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then ! ! -- Calculate hfb conductance topn = this%top(n) topm = this%top(m) botn = this%bot(n) botm = this%bot(m) - if(this%icelltype(n) == 1) then - if(hnew(n) < topn) topn = hnew(n) - endif - if(this%icelltype(m) == 1) then - if(hnew(m) < topm) topm = hnew(m) - endif - if(this%ihc(this%jas(ipos)) == 2) then + if (this%icelltype(n) == 1) then + if (hnew(n) < topn) topn = hnew(n) + end if + if (this%icelltype(m) == 1) then + if (hnew(m) < topm) topm = hnew(m) + end if + if (this%ihc(this%jas(ipos)) == 2) then faheight = min(topn, topm) - max(botn, botm) else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif - if(this%hydchr(ihfb) > DZERO) then + faheight = DHALF * ((topn - botn) + (topm - botm)) + end if + if (this%hydchr(ihfb) > DZERO) then fawidth = this%hwva(this%jas(ipos)) condhfb = this%hydchr(ihfb) * fawidth * faheight cond = aterm * condhfb / (aterm + condhfb) else - cond = - aterm * this%hydchr(ihfb) - endif + cond = -aterm * this%hydchr(ihfb) + end if ! ! -- Save cond for budget calculation this%condsav(ihfb) = cond @@ -328,11 +330,11 @@ subroutine hfb_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond amat(idxglo(isymcon)) = cond ! - endif - enddo - endif + end if + end do + end if ! - endif + end if ! ! -- return return @@ -351,8 +353,8 @@ subroutine hfb_cq(this, hnew, flowja) use ConstantsModule, only: DHALF, DZERO ! -- dummy class(GwfHfbType) :: this - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja + real(DP), intent(inout), dimension(:) :: hnew + real(DP), intent(inout), dimension(:) :: flowja ! -- local integer(I4B) :: ihfb, n, m integer(I4B) :: ipos @@ -370,33 +372,33 @@ subroutine hfb_cq(this, hnew, flowja) ixt3d = 0 end if ! - if(ixt3d > 0) then + if (ixt3d > 0) then ! do ihfb = 1, this%nhfb n = min(this%noden(ihfb), this%nodem(ihfb)) m = max(this%noden(ihfb), this%nodem(ihfb)) ! -- Skip if either cell is inactive. - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then ! -- Compute scale factor for hfb correction - if(this%hydchr(ihfb) > DZERO) then - if(this%inewton == 0) then + if (this%hydchr(ihfb) > DZERO) then + if (this%inewton == 0) then ipos = this%idxloc(ihfb) topn = this%top(n) topm = this%top(m) botn = this%bot(n) botm = this%bot(m) - if(this%icelltype(n) == 1) then - if(hnew(n) < topn) topn = hnew(n) - endif - if(this%icelltype(m) == 1) then - if(hnew(m) < topm) topm = hnew(m) - endif - if(this%ihc(this%jas(ipos)) == 2) then + if (this%icelltype(n) == 1) then + if (hnew(n) < topn) topn = hnew(n) + end if + if (this%icelltype(m) == 1) then + if (hnew(m) < topm) topm = hnew(m) + end if + if (this%ihc(this%jas(ipos)) == 2) then faheight = min(topn, topm) - max(botn, botm) else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif + faheight = DHALF * ((topn - botn) + (topm - botm)) + end if fawidth = this%hwva(this%jas(ipos)) condhfb = this%hydchr(ihfb) * fawidth * faheight else @@ -404,7 +406,7 @@ subroutine hfb_cq(this, hnew, flowja) end if else condhfb = this%hydchr(ihfb) - endif + end if ! -- Make hfb corrections for xt3d call this%xt3d%xt3d_flowjahfb(n, m, hnew, flowja, condhfb) end do @@ -412,12 +414,12 @@ subroutine hfb_cq(this, hnew, flowja) else ! ! -- Recalculate flowja for non-newton unconfined. - if(this%inewton == 0) then + if (this%inewton == 0) then do ihfb = 1, this%nhfb n = this%noden(ihfb) m = this%nodem(ihfb) - if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle - if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then + if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle + if (this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then ipos = this%dis%con%getjaindex(n, m) cond = this%condsav(ihfb) qnm = cond * (hnew(m) - hnew(n)) @@ -425,9 +427,9 @@ subroutine hfb_cq(this, hnew, flowja) ipos = this%dis%con%getjaindex(m, n) flowja(ipos) = -qnm ! - endif - enddo - endif + end if + end do + end if ! end if ! @@ -462,25 +464,25 @@ subroutine hfb_da(this) call mem_deallocate(this%idxloc) call mem_deallocate(this%csatsav) call mem_deallocate(this%condsav) - endif + end if ! ! -- deallocate parent call this%NumericalPackageType%da() ! ! -- nullify pointers - this%xt3d => null() - this%inewton => null() - this%ibound => null() - this%icelltype => null() - this%ihc => null() - this%ia => null() - this%ja => null() - this%jas => null() - this%isym => null() - this%condsat => null() - this%top => null() - this%bot => null() - this%hwva => null() + this%xt3d => null() + this%inewton => null() + this%ibound => null() + this%icelltype => null() + this%ihc => null() + this%ia => null() + this%ja => null() + this%jas => null() + this%isym => null() + this%condsat => null() + this%top => null() + this%bot => null() + this%hwva => null() ! ! -- return return @@ -539,7 +541,7 @@ subroutine allocate_arrays(this) ! -- initialize idxloc to 0 do ihfb = 1, this%maxhfb this%idxloc(ihfb) = 0 - enddo + end do ! ! -- return return @@ -565,28 +567,28 @@ subroutine read_options(this) ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING HFB OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING HFB OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') & - 'THE LIST OF HFBS WILL BE PRINTED.' - case default - write(errmsg,'(4x,a,a)') 'Unknown HFB option: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') & + 'THE LIST OF HFBS WILL BE PRINTED.' + case default + write (errmsg, '(4x,a,a)') 'Unknown HFB option: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF HFB OPTIONS' + write (this%iout, '(1x,a)') 'END OF HFB OPTIONS' end if ! ! -- return @@ -603,7 +605,7 @@ subroutine read_dimensions(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwfHfbType),intent(inout) :: this + class(GwfHfbType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: errmsg, keyword integer(I4B) :: ierr @@ -613,40 +615,40 @@ subroutine read_dimensions(this) ! ! -- get dimensions block call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING HFB DIMENSIONS' + write (this%iout, '(/1x,a)') 'PROCESSING HFB DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('MAXHFB') - this%maxhfb = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXHFB = ', this%maxhfb - case default - write(errmsg,'(4x,a,a)') & - 'Unknown HFB dimension: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('MAXHFB') + this%maxhfb = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'MAXHFB = ', this%maxhfb + case default + write (errmsg, '(4x,a,a)') & + 'Unknown HFB dimension: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do ! - write(this%iout,'(1x,a)')'END OF HFB DIMENSIONS' + write (this%iout, '(1x,a)') 'END OF HFB DIMENSIONS' else call store_error('Required DIMENSIONS block not found.') call this%parser%StoreErrorUnit() end if ! ! -- verify dimensions were set - if(this%maxhfb <= 0) then - write(errmsg, '(1x,a)') & + if (this%maxhfb <= 0) then + write (errmsg, '(1x,a)') & 'MAXHFB must be specified with value greater than zero.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -676,11 +678,11 @@ subroutine read_data(this) character(len=*), parameter :: fmthfb = "(i10, 2a10, 1(1pg15.6))" ! ------------------------------------------------------------------------------ ! - write(this%iout,'(//,1x,a)')'READING HFB DATA' - if(this%iprpak > 0) then - write(this%iout, '(3a10, 1a15)') 'HFB NUM', 'CELL1', 'CELL2', & - 'HYDCHR' - endif + write (this%iout, '(//,1x,a)') 'READING HFB DATA' + if (this%iprpak > 0) then + write (this%iout, '(3a10, 1a15)') 'HFB NUM', 'CELL1', 'CELL2', & + 'HYDCHR' + end if ! ihfb = 0 this%nhfb = 0 @@ -692,40 +694,42 @@ subroutine read_data(this) ! ! -- Reset lloc and read noden, nodem, and hydchr ihfb = ihfb + 1 - if(ihfb > this%maxhfb) then + if (ihfb > this%maxhfb) then call store_error('MAXHFB not large enough.') call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetCellid(this%dis%ndim, cellidn) this%noden(ihfb) = this%dis%noder_from_cellid(cellidn, & - this%parser%iuactive, this%iout) + this%parser%iuactive, & + this%iout) call this%parser%GetCellid(this%dis%ndim, cellidm) this%nodem(ihfb) = this%dis%noder_from_cellid(cellidm, & - this%parser%iuactive, this%iout) + this%parser%iuactive, & + this%iout) this%hydchr(ihfb) = this%parser%GetDouble() ! ! -- Print input if requested - if(this%iprpak /= 0) then + if (this%iprpak /= 0) then call this%dis%noder_to_string(this%noden(ihfb), nodenstr) call this%dis%noder_to_string(this%nodem(ihfb), nodemstr) - write(this%iout, fmthfb) ihfb, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)), this%hydchr(ihfb) - endif + write (this%iout, fmthfb) ihfb, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)), this%hydchr(ihfb) + end if ! this%nhfb = ihfb - enddo readloop + end do readloop ! ! -- Stop if errors nerr = count_errors() - if(nerr > 0) then + if (nerr > 0) then call store_error('Errors encountered in HFB input file.') call this%parser%StoreErrorUnit() - endif + end if ! - write(this%iout, '(3x,i0,a,i0)') this%nhfb, & - ' HFBs READ FOR STRESS PERIOD ', kper + write (this%iout, '(3x,i0,a,i0)') this%nhfb, & + ' HFBs READ FOR STRESS PERIOD ', kper call this%check_data() - write(this%iout, '(1x,a)')'END READING HFB DATA' + write (this%iout, '(1x,a)') 'END READING HFB DATA' ! ! -- return return @@ -751,9 +755,9 @@ subroutine check_data(this) character(len=LINELENGTH) :: errmsg logical :: found ! -- formats - character(len=*), parameter :: fmterr = "(1x, 'HFB no. ',i0, & + character(len=*), parameter :: fmterr = "(1x, 'HFB no. ',i0, & &' is between two unconnected cells: ', a, ' and ', a)" - character(len=*), parameter :: fmtverr = "(1x, 'HFB no. ',i0, & + character(len=*), parameter :: fmtverr = "(1x, 'HFB no. ',i0, & &' is between two cells not horizontally connected: ', a, ' and ', a)" ! ------------------------------------------------------------------------------ ! @@ -761,20 +765,20 @@ subroutine check_data(this) n = this%noden(ihfb) m = this%nodem(ihfb) found = .false. - do ipos = this%ia(n)+1, this%ia(n+1)-1 + do ipos = this%ia(n) + 1, this%ia(n + 1) - 1 if (m == this%ja(ipos)) then found = .true. this%idxloc(ihfb) = ipos exit - endif - enddo + end if + end do ! ! -- check to make sure cells are connected if (.not. found) then call this%dis%noder_to_string(n, nodenstr) call this%dis%noder_to_string(m, nodemstr) - write(errmsg, fmterr) ihfb, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)) + write (errmsg, fmterr) ihfb, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)) call store_error(errmsg) else ! @@ -783,17 +787,17 @@ subroutine check_data(this) if (this%ihc(this%jas(ipos)) == 0) then call this%dis%noder_to_string(n, nodenstr) call this%dis%noder_to_string(m, nodemstr) - write(errmsg, fmtverr) ihfb, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)) + write (errmsg, fmtverr) ihfb, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)) call store_error(errmsg) end if end if - enddo + end do ! ! -- Stop if errors detected - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error_unit(this%inunit) - endif + end if ! ! -- return return @@ -817,7 +821,7 @@ subroutine condsat_reset(this) do ihfb = 1, this%nhfb ipos = this%idxloc(ihfb) this%condsat(this%jas(ipos)) = this%csatsav(ihfb) - enddo + end do ! ! -- return return @@ -850,29 +854,29 @@ subroutine condsat_modify(this) this%csatsav(ihfb) = cond n = this%noden(ihfb) m = this%nodem(ihfb) - if(this%inewton == 1 .or. & - (this%icelltype(n) == 0 .and. this%icelltype(m) == 0) ) then + if (this%inewton == 1 .or. & + (this%icelltype(n) == 0 .and. this%icelltype(m) == 0)) then ! ! -- Calculate hfb conductance topn = this%top(n) topm = this%top(m) botn = this%bot(n) botm = this%bot(m) - if(this%ihc(this%jas(ipos)) == 2) then + if (this%ihc(this%jas(ipos)) == 2) then faheight = min(topn, topm) - max(botn, botm) else - faheight = DHALF * ( (topn - botn) + (topm - botm) ) - endif - if(this%hydchr(ihfb) > DZERO) then + faheight = DHALF * ((topn - botn) + (topm - botm)) + end if + if (this%hydchr(ihfb) > DZERO) then fawidth = this%hwva(this%jas(ipos)) condhfb = this%hydchr(ihfb) * fawidth * faheight cond = cond * condhfb / (cond + condhfb) else - cond = - cond * this%hydchr(ihfb) - endif + cond = -cond * this%hydchr(ihfb) + end if this%condsat(this%jas(ipos)) = cond - endif - enddo + end if + end do ! ! -- return return diff --git a/src/Model/GroundWaterFlow/gwf3ic8.f90 b/src/Model/GroundWaterFlow/gwf3ic8.f90 index de4a6f8f4b9..91991d170b2 100644 --- a/src/Model/GroundWaterFlow/gwf3ic8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ic8.f90 @@ -2,8 +2,8 @@ module GwfIcModule use KindModule, only: DP, I4B use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType implicit none private @@ -11,16 +11,16 @@ module GwfIcModule public :: ic_cr type, extends(NumericalPackageType) :: GwfIcType - real(DP), dimension(:), pointer, contiguous :: strt => null() ! starting head + real(DP), dimension(:), pointer, contiguous :: strt => null() ! starting head contains - procedure :: ic_ar - procedure :: ic_da + procedure :: ic_ar + procedure :: ic_da procedure, private :: allocate_arrays procedure, private :: read_options - procedure :: read_data + procedure :: read_data end type GwfIcType - contains +contains subroutine ic_cr(ic, name_model, inunit, iout, dis) ! ****************************************************************************** @@ -38,7 +38,7 @@ subroutine ic_cr(ic, name_model, inunit, iout, dis) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(ic) + allocate (ic) ! ! -- create name and memory path call ic%set_names(1, name_model, 'IC', 'IC') @@ -77,9 +77,9 @@ subroutine ic_ar(this, x) ! ------------------------------------------------------------------------------ ! ! -- Print a message identifying the initial conditions package. - write(this%iout,1) this%inunit - 1 format(1x,/1x,'IC -- INITIAL CONDITIONS PACKAGE, VERSION 8, 3/28/2015', & - ' INPUT READ FROM UNIT ',i0) + write (this%iout, 1) this%inunit +1 format(1x, /1x, 'IC -- INITIAL CONDITIONS PACKAGE, VERSION 8, 3/28/2015', & + ' INPUT READ FROM UNIT ', i0) ! ! -- Allocate arrays call this%allocate_arrays(this%dis%nodes) @@ -93,7 +93,7 @@ subroutine ic_ar(this, x) ! -- Assign x equal to strt do n = 1, this%dis%nodes x(n) = this%strt(n) - enddo + end do ! ! -- Return return @@ -154,8 +154,8 @@ subroutine read_options(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error ! -- dummy class(GwfIcType) :: this ! -- local @@ -171,24 +171,24 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING IC OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING IC OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case default - write(errmsg,'(4x,a,a)') 'Unknown IC option: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case default + write (errmsg, '(4x,a,a)') 'Unknown IC option: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF IC OPTIONS' + write (this%iout, '(1x,a)') 'END OF IC OPTIONS' end if ! ! -- Return return - end subroutine read_options + end subroutine read_options subroutine read_data(this) ! ****************************************************************************** @@ -198,8 +198,8 @@ subroutine read_data(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error ! -- dummy class(GwfIcType) :: this ! -- local @@ -216,8 +216,8 @@ subroutine read_data(this) ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -225,17 +225,17 @@ subroutine read_data(this) call this%parser%GetRemainingLine(line) lloc = 1 select case (keyword) - case ('STRT') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%strt, & - aname(1)) - case default - write(errmsg,'(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('STRT') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%strt, & + aname(1)) + case default + write (errmsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else call store_error('Required GRIDDATA block not found.') call this%parser%StoreErrorUnit() diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index 00c55efdab0..a147f88266b 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -1,22 +1,22 @@ module LakModule ! use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - DZERO, DPREC, DEM30, DEM9, DEM6, DEM5, & - DEM4, DEM2, DEM1, DHALF, DP7, DONE, & + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + DZERO, DPREC, DEM30, DEM9, DEM6, DEM5, & + DEM4, DEM2, DEM1, DHALF, DP7, DONE, & DTWO, DPI, DTHREE, DEIGHT, DTEN, DHUNDRED, DEP20, & - DONETHIRD, DTWOTHIRDS, DFIVETHIRDS, & - DGRAVITY, DCD, & - NAMEDBOUNDFLAG, LENFTYPE, LENPACKAGENAME, & - LENPAKLOC, DNODATA, & - TABLEFT, TABCENTER, TABRIGHT, & + DONETHIRD, DTWOTHIRDS, DFIVETHIRDS, & + DGRAVITY, DCD, & + NAMEDBOUNDFLAG, LENFTYPE, LENPACKAGENAME, & + LENPAKLOC, DNODATA, & + TABLEFT, TABCENTER, TABRIGHT, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & mem_deallocate use MemoryHelperModule, only: create_mem_path - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, & - sQSaturationDerivative + use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & + sQuadraticSaturationDerivative, & + sQSaturationDerivative use BndModule, only: BndType use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr use TableModule, only: TableType, table_cr @@ -24,10 +24,10 @@ module LakModule use ObsModule, only: ObsType use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, store_error_unit + use SimModule, only: count_errors, store_error, store_error_unit use GenericUtilitiesModule, only: sim_message - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType use SimVariablesModule, only: errmsg ! implicit none @@ -36,14 +36,14 @@ module LakModule public :: LakType public :: lak_create ! - character(len=LENFTYPE) :: ftype = 'LAK' - character(len=LENPACKAGENAME) :: text = ' LAK' + character(len=LENFTYPE) :: ftype = 'LAK' + character(len=LENPACKAGENAME) :: text = ' LAK' ! type LakTabType - real(DP), dimension(:), pointer, contiguous :: tabstage => null() - real(DP), dimension(:), pointer, contiguous :: tabvolume => null() - real(DP), dimension(:), pointer, contiguous :: tabsarea => null() - real(DP), dimension(:), pointer, contiguous :: tabwarea => null() + real(DP), dimension(:), pointer, contiguous :: tabstage => null() + real(DP), dimension(:), pointer, contiguous :: tabvolume => null() + real(DP), dimension(:), pointer, contiguous :: tabsarea => null() + real(DP), dimension(:), pointer, contiguous :: tabwarea => null() end type LakTabType ! type, extends(BndType) :: LakType @@ -78,50 +78,50 @@ module LakModule integer(I4B), dimension(:), pointer, contiguous :: nlakeconn => null() integer(I4B), dimension(:), pointer, contiguous :: idxlakeconn => null() integer(I4B), dimension(:), pointer, contiguous :: ntabrow => null() - real(DP), dimension(:), pointer, contiguous :: strt => null() - real(DP), dimension(:), pointer, contiguous :: laketop => null() - real(DP), dimension(:), pointer, contiguous :: lakebot => null() - real(DP), dimension(:), pointer, contiguous :: sareamax => null() - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: lakename => null() - character (len=8), dimension(:), pointer, contiguous :: status => null() - real(DP), dimension(:), pointer, contiguous :: avail => null() - real(DP), dimension(:), pointer, contiguous :: lkgwsink => null() + real(DP), dimension(:), pointer, contiguous :: strt => null() + real(DP), dimension(:), pointer, contiguous :: laketop => null() + real(DP), dimension(:), pointer, contiguous :: lakebot => null() + real(DP), dimension(:), pointer, contiguous :: sareamax => null() + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: lakename => null() + character(len=8), dimension(:), pointer, contiguous :: status => null() + real(DP), dimension(:), pointer, contiguous :: avail => null() + real(DP), dimension(:), pointer, contiguous :: lkgwsink => null() real(DP), dimension(:), pointer, contiguous :: stage => null() real(DP), dimension(:), pointer, contiguous :: rainfall => null() real(DP), dimension(:), pointer, contiguous :: evaporation => null() real(DP), dimension(:), pointer, contiguous :: runoff => null() real(DP), dimension(:), pointer, contiguous :: inflow => null() real(DP), dimension(:), pointer, contiguous :: withdrawal => null() - real(DP), dimension(:,:), pointer, contiguous :: lauxvar => null() + real(DP), dimension(:, :), pointer, contiguous :: lauxvar => null() ! ! -- table data integer(I4B), dimension(:), pointer, contiguous :: ialaktab => null() - real(DP), dimension(:), pointer, contiguous :: tabstage => null() - real(DP), dimension(:), pointer, contiguous :: tabvolume => null() - real(DP), dimension(:), pointer, contiguous :: tabsarea => null() - real(DP), dimension(:), pointer, contiguous :: tabwarea => null() + real(DP), dimension(:), pointer, contiguous :: tabstage => null() + real(DP), dimension(:), pointer, contiguous :: tabvolume => null() + real(DP), dimension(:), pointer, contiguous :: tabsarea => null() + real(DP), dimension(:), pointer, contiguous :: tabwarea => null() ! ! -- lake solution data integer(I4B), dimension(:), pointer, contiguous :: ncncvr => null() - real(DP), dimension(:), pointer, contiguous :: surfin => null() - real(DP), dimension(:), pointer, contiguous :: surfout => null() - real(DP), dimension(:), pointer, contiguous :: surfout1 => null() - real(DP), dimension(:), pointer, contiguous :: precip => null() - real(DP), dimension(:), pointer, contiguous :: precip1 => null() - real(DP), dimension(:), pointer, contiguous :: evap => null() - real(DP), dimension(:), pointer, contiguous :: evap1 => null() - real(DP), dimension(:), pointer, contiguous :: evapo => null() - real(DP), dimension(:), pointer, contiguous :: withr => null() - real(DP), dimension(:), pointer, contiguous :: withr1 => null() - real(DP), dimension(:), pointer, contiguous :: flwin => null() - real(DP), dimension(:), pointer, contiguous :: flwiter => null() - real(DP), dimension(:), pointer, contiguous :: flwiter1 => null() - real(DP), dimension(:), pointer, contiguous :: seep => null() - real(DP), dimension(:), pointer, contiguous :: seep1 => null() - real(DP), dimension(:), pointer, contiguous :: seep0 => null() - real(DP), dimension(:), pointer, contiguous :: stageiter => null() - real(DP), dimension(:), pointer, contiguous :: chterm => null() + real(DP), dimension(:), pointer, contiguous :: surfin => null() + real(DP), dimension(:), pointer, contiguous :: surfout => null() + real(DP), dimension(:), pointer, contiguous :: surfout1 => null() + real(DP), dimension(:), pointer, contiguous :: precip => null() + real(DP), dimension(:), pointer, contiguous :: precip1 => null() + real(DP), dimension(:), pointer, contiguous :: evap => null() + real(DP), dimension(:), pointer, contiguous :: evap1 => null() + real(DP), dimension(:), pointer, contiguous :: evapo => null() + real(DP), dimension(:), pointer, contiguous :: withr => null() + real(DP), dimension(:), pointer, contiguous :: withr1 => null() + real(DP), dimension(:), pointer, contiguous :: flwin => null() + real(DP), dimension(:), pointer, contiguous :: flwiter => null() + real(DP), dimension(:), pointer, contiguous :: flwiter1 => null() + real(DP), dimension(:), pointer, contiguous :: seep => null() + real(DP), dimension(:), pointer, contiguous :: seep1 => null() + real(DP), dimension(:), pointer, contiguous :: seep0 => null() + real(DP), dimension(:), pointer, contiguous :: stageiter => null() + real(DP), dimension(:), pointer, contiguous :: chterm => null() ! ! -- lake convergence integer(I4B), dimension(:), pointer, contiguous :: iseepc => null() @@ -139,16 +139,16 @@ module LakModule integer(I4B), dimension(:), pointer, contiguous :: cellid => null() integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null() integer(I4B), dimension(:), pointer, contiguous :: ictype => null() - real(DP), dimension(:), pointer, contiguous :: bedleak => null() - real(DP), dimension(:), pointer, contiguous :: belev => null() - real(DP), dimension(:), pointer, contiguous :: telev => null() - real(DP), dimension(:), pointer, contiguous :: connlength => null() - real(DP), dimension(:), pointer, contiguous :: connwidth => null() - real(DP), dimension(:), pointer, contiguous :: sarea => null() - real(DP), dimension(:), pointer, contiguous :: warea => null() - real(DP), dimension(:), pointer, contiguous :: satcond => null() - real(DP), dimension(:), pointer, contiguous :: simcond => null() - real(DP), dimension(:), pointer, contiguous :: simlakgw => null() + real(DP), dimension(:), pointer, contiguous :: bedleak => null() + real(DP), dimension(:), pointer, contiguous :: belev => null() + real(DP), dimension(:), pointer, contiguous :: telev => null() + real(DP), dimension(:), pointer, contiguous :: connlength => null() + real(DP), dimension(:), pointer, contiguous :: connwidth => null() + real(DP), dimension(:), pointer, contiguous :: sarea => null() + real(DP), dimension(:), pointer, contiguous :: warea => null() + real(DP), dimension(:), pointer, contiguous :: satcond => null() + real(DP), dimension(:), pointer, contiguous :: simcond => null() + real(DP), dimension(:), pointer, contiguous :: simlakgw => null() ! ! -- lake outlet data integer(I4B), dimension(:), pointer, contiguous :: lakein => null() @@ -159,7 +159,7 @@ module LakModule real(DP), dimension(:), pointer, contiguous :: outwidth => null() real(DP), dimension(:), pointer, contiguous :: outrough => null() real(DP), dimension(:), pointer, contiguous :: outslope => null() - real(DP), dimension(:), pointer, contiguous :: simoutrate => null() + real(DP), dimension(:), pointer, contiguous :: simoutrate => null() ! ! -- lake output data real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() @@ -175,9 +175,9 @@ module LakModule integer(I4B), pointer :: gwfik33 => NULL() ! ! -- package x, xold, and ibound - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound - real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector - real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound + real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector + real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector ! ! -- lake budget object type(BudgetObjectType), pointer :: budobj => null() @@ -188,10 +188,10 @@ module LakModule ! ! -- density variables integer(I4B), pointer :: idense - real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() + real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() ! ! -- type bound procedures - contains + contains procedure :: lak_allocate_scalars procedure :: lak_allocate_arrays procedure :: bnd_options => lak_options @@ -231,7 +231,7 @@ module LakModule procedure, private :: lak_calculate_sarea procedure, private :: lak_calculate_warea procedure, private :: lak_calculate_conn_warea - procedure, public :: lak_calculate_vol + procedure, public :: lak_calculate_vol procedure, private :: lak_calculate_conductance procedure, private :: lak_calculate_cond_head procedure, private :: lak_calculate_conn_conductance @@ -265,7 +265,7 @@ module LakModule ! -- table procedure, private :: lak_setup_tableobj ! -- density - procedure :: lak_activate_density + procedure :: lak_activate_density procedure, private :: lak_calculate_density_exchange end type LakType @@ -281,17 +281,17 @@ subroutine lak_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(LakType), pointer :: lakobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(lakobj) + allocate (lakobj) packobj => lakobj ! ! -- create name and memory path @@ -309,9 +309,9 @@ subroutine lak_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%id = id packobj%ibcnum = ibcnum packobj%ncolbnd = 3 - packobj%iscloc = 0 ! not supported + packobj%iscloc = 0 ! not supported packobj%isadvpak = 1 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return return @@ -325,7 +325,7 @@ subroutine lak_allocate_scalars(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType), intent(inout) :: this + class(LakType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! -- call standard BndType allocate scalars @@ -389,7 +389,7 @@ subroutine lak_allocate_arrays(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(LakType), intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local integer(I4B) :: i ! ------------------------------------------------------------------------------ @@ -398,18 +398,18 @@ subroutine lak_allocate_arrays(this) call this%BndType%allocate_arrays() ! ! -- allocate character array for budget text - allocate(this%clakbudget(this%bditems)) + allocate (this%clakbudget(this%bditems)) ! !-- fill clakbudget - this%clakbudget(1) = ' GWF' - this%clakbudget(2) = ' RAINFALL' - this%clakbudget(3) = ' EVAPORATION' - this%clakbudget(4) = ' RUNOFF' - this%clakbudget(5) = ' EXT-INFLOW' - this%clakbudget(6) = ' WITHDRAWAL' - this%clakbudget(7) = ' EXT-OUTFLOW' - this%clakbudget(8) = ' STORAGE' - this%clakbudget(9) = ' CONSTANT' + this%clakbudget(1) = ' GWF' + this%clakbudget(2) = ' RAINFALL' + this%clakbudget(3) = ' EVAPORATION' + this%clakbudget(4) = ' RUNOFF' + this%clakbudget(5) = ' EXT-INFLOW' + this%clakbudget(6) = ' WITHDRAWAL' + this%clakbudget(7) = ' EXT-OUTFLOW' + this%clakbudget(8) = ' STORAGE' + this%clakbudget(9) = ' CONSTANT' this%clakbudget(10) = ' FROM-MVR' this%clakbudget(11) = ' TO-MVR' ! @@ -424,7 +424,7 @@ subroutine lak_allocate_arrays(this) end if ! ! -- allocate character array for budget text - allocate(this%cauxcbc(this%cbcauxitems)) + allocate (this%cauxcbc(this%cbcauxitems)) ! ! -- allocate and initialize qauxcbc call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%memoryPath) @@ -448,7 +448,7 @@ subroutine lak_allocate_arrays(this) ! -- return return end subroutine lak_allocate_arrays - + subroutine lak_read_lakes(this) ! ****************************************************************************** ! pak1read_dimensions -- Read the dimensions for this package @@ -461,7 +461,7 @@ subroutine lak_read_lakes(this) use SimModule, only: store_error, count_errors, store_error_unit use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: text character(len=LENBOUNDNAME) :: bndName, bndNameTemp @@ -486,7 +486,8 @@ subroutine lak_read_lakes(this) ! ! -- allocate lake data call mem_allocate(this%nlakeconn, this%nlakes, 'NLAKECONN', this%memoryPath) - call mem_allocate(this%idxlakeconn, this%nlakes+1, 'IDXLAKECONN', this%memoryPath) + call mem_allocate(this%idxlakeconn, this%nlakes + 1, 'IDXLAKECONN', & + this%memoryPath) call mem_allocate(this%ntabrow, this%nlakes, 'NTABROW', this%memoryPath) call mem_allocate(this%strt, this%nlakes, 'STRT', this%memoryPath) call mem_allocate(this%laketop, this%nlakes, 'LAKETOP', this%memoryPath) @@ -494,11 +495,13 @@ subroutine lak_read_lakes(this) call mem_allocate(this%sareamax, this%nlakes, 'SAREAMAX', this%memoryPath) call mem_allocate(this%stage, this%nlakes, 'STAGE', this%memoryPath) call mem_allocate(this%rainfall, this%nlakes, 'RAINFALL', this%memoryPath) - call mem_allocate(this%evaporation, this%nlakes, 'EVAPORATION', this%memoryPath) + call mem_allocate(this%evaporation, this%nlakes, 'EVAPORATION', & + this%memoryPath) call mem_allocate(this%runoff, this%nlakes, 'RUNOFF', this%memoryPath) call mem_allocate(this%inflow, this%nlakes, 'INFLOW', this%memoryPath) call mem_allocate(this%withdrawal, this%nlakes, 'WITHDRAWAL', this%memoryPath) - call mem_allocate(this%lauxvar, this%naux, this%nlakes, 'LAUXVAR', this%memoryPath) + call mem_allocate(this%lauxvar, this%naux, this%nlakes, 'LAUXVAR', & + this%memoryPath) call mem_allocate(this%avail, this%nlakes, 'AVAIL', this%memoryPath) call mem_allocate(this%lkgwsink, this%nlakes, 'LKGWSINK', this%memoryPath) call mem_allocate(this%ncncvr, this%nlakes, 'NCNCVR', this%memoryPath) @@ -538,14 +541,14 @@ subroutine lak_read_lakes(this) call mem_allocate(this%qgwf0, this%nlakes, 'QGWF0', this%memoryPath) ! ! -- allocate character storage not managed by the memory manager - allocate(this%lakename(this%nlakes)) ! ditch after boundnames allocated?? - allocate(this%status(this%nlakes)) + allocate (this%lakename(this%nlakes)) ! ditch after boundnames allocated?? + allocate (this%status(this%nlakes)) ! do n = 1, this%nlakes this%ntabrow(n) = 0 this%status(n) = 'ACTIVE' this%laketop(n) = -DEP20 - this%lakebot(n) = DEP20 + this%lakebot(n) = DEP20 this%sareamax(n) = DZERO this%iboundpak(n) = 1 this%xnewpak(n) = DEP20 @@ -561,11 +564,11 @@ subroutine lak_read_lakes(this) ! ! -- allocate local storage for aux variables if (this%naux > 0) then - allocate(caux(this%naux)) + allocate (caux(this%naux)) end if ! ! -- allocate and initialize temporary variables - allocate(nboundchk(this%nlakes)) + allocate (nboundchk(this%nlakes)) do n = 1, this%nlakes nboundchk(n) = 0 end do @@ -573,11 +576,11 @@ subroutine lak_read_lakes(this) ! -- read lake well data ! -- get lakes block call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse locations block if detected if (isfound) then - write(this%iout,'(/1x,a)') 'PROCESSING ' // trim(adjustl(this%text)) // & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' PACKAGEDATA' nlak = 0 nconn = 0 @@ -587,11 +590,11 @@ subroutine lak_read_lakes(this) n = this%parser%GetInteger() if (n < 1 .or. n > this%nlakes) then - write(errmsg,'(a,1x,i6)') 'lakeno MUST BE > 0 and <= ', this%nlakes + write (errmsg, '(a,1x,i6)') 'lakeno MUST BE > 0 and <= ', this%nlakes call store_error(errmsg) cycle end if - + ! -- increment nboundchk nboundchk(n) = nboundchk(n) + 1 @@ -602,7 +605,7 @@ subroutine lak_read_lakes(this) ival = this%parser%GetInteger() if (ival < 0) then - write(errmsg,'(a,1x,i6)') 'nlakeconn MUST BE >= 0 for lake ', n + write (errmsg, '(a,1x,i6)') 'nlakeconn MUST BE >= 0 for lake ', n call store_error(errmsg) end if @@ -615,15 +618,15 @@ subroutine lak_read_lakes(this) end do ! -- set default bndName - write(cno,'(i9.9)') n - bndName = 'Lake' // cno + write (cno, '(i9.9)') n + bndName = 'Lake'//cno ! -- lakename if (this%inamedbound /= 0) then call this%parser%GetStringCaps(bndNameTemp) if (bndNameTemp /= '') then bndName = bndNameTemp - endif + end if end if this%lakename(n) = bndName @@ -633,8 +636,9 @@ subroutine lak_read_lakes(this) text = caux(jj) ii = n bndElem => this%lauxvar(jj, ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'AUX', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, ii, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & this%auxname(jj)) end do @@ -644,17 +648,17 @@ subroutine lak_read_lakes(this) ! -- check for duplicate or missing lakes do n = 1, this%nlakes if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') 'NO DATA SPECIFIED FOR LAKE', n + write (errmsg, '(a,1x,i0)') 'NO DATA SPECIFIED FOR LAKE', n call store_error(errmsg) else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES' call store_error(errmsg) end if end do - write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & - ' PACKAGEDATA' + write (this%iout, '(1x,a)') 'END OF '//trim(adjustl(this%text))// & + ' PACKAGEDATA' else call store_error('REQUIRED PACKAGEDATA BLOCK NOT FOUND.') end if @@ -666,21 +670,21 @@ subroutine lak_read_lakes(this) ! ! -- set MAXBOUND this%MAXBOUND = nconn - write(this%iout,'(//4x,a,i7)') 'MAXBOUND = ', this%maxbound + write (this%iout, '(//4x,a,i7)') 'MAXBOUND = ', this%maxbound ! -- set idxlakeconn this%idxlakeconn(1) = 1 do n = 1, this%nlakes - this%idxlakeconn(n+1) = this%idxlakeconn(n) + this%nlakeconn(n) + this%idxlakeconn(n + 1) = this%idxlakeconn(n) + this%nlakeconn(n) end do ! ! -- deallocate local storage for aux variables if (this%naux > 0) then - deallocate(caux) + deallocate (caux) end if ! ! -- deallocate local storage for nboundchk - deallocate(nboundchk) + deallocate (nboundchk) ! ! -- return return @@ -696,7 +700,7 @@ subroutine lak_read_lake_connections(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: keyword, cellid integer(I4B) :: ierr, ival @@ -714,7 +718,7 @@ subroutine lak_read_lake_connections(this) ! -- code ! ! -- allocate local storage - allocate(nboundchk(this%MAXBOUND)) + allocate (nboundchk(this%MAXBOUND)) do n = 1, this%MAXBOUND nboundchk(n) = 0 end do @@ -729,22 +733,24 @@ subroutine lak_read_lake_connections(this) ! -- allocate connection data using memory manager call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%memoryPath) call mem_allocate(this%cellid, this%MAXBOUND, 'CELLID', this%memoryPath) - call mem_allocate(this%nodesontop, this%MAXBOUND, 'NODESONTOP', this%memoryPath) + call mem_allocate(this%nodesontop, this%MAXBOUND, 'NODESONTOP', & + this%memoryPath) call mem_allocate(this%ictype, this%MAXBOUND, 'ICTYPE', this%memoryPath) call mem_allocate(this%bedleak, this%MAXBOUND, 'BEDLEAK', this%memoryPath) ! don't need to save this - use a temporary vector call mem_allocate(this%belev, this%MAXBOUND, 'BELEV', this%memoryPath) call mem_allocate(this%telev, this%MAXBOUND, 'TELEV', this%memoryPath) - call mem_allocate(this%connlength, this%MAXBOUND, 'CONNLENGTH', this%memoryPath) - call mem_allocate(this%connwidth, this%MAXBOUND, 'CONNWIDTH', this%memoryPath) + call mem_allocate(this%connlength, this%MAXBOUND, 'CONNLENGTH', & + this%memoryPath) + call mem_allocate(this%connwidth, this%MAXBOUND, 'CONNWIDTH', & + this%memoryPath) call mem_allocate(this%sarea, this%MAXBOUND, 'SAREA', this%memoryPath) call mem_allocate(this%warea, this%MAXBOUND, 'WAREA', this%memoryPath) call mem_allocate(this%satcond, this%MAXBOUND, 'SATCOND', this%memoryPath) call mem_allocate(this%simcond, this%MAXBOUND, 'SIMCOND', this%memoryPath) call mem_allocate(this%simlakgw, this%MAXBOUND, 'SIMLAKGW', this%memoryPath) - ! -- process the lake connection data - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' LAKE_CONNECTIONS' do call this%parser%GetNextLine(endOfBlock) @@ -752,7 +758,7 @@ subroutine lak_read_lake_connections(this) n = this%parser%GetInteger() if (n < 1 .or. n > this%nlakes) then - write(errmsg,'(a,1x,i6)') 'lakeno MUST BE > 0 and <= ', this%nlakes + write (errmsg, '(a,1x,i6)') 'lakeno MUST BE > 0 and <= ', this%nlakes call store_error(errmsg) cycle end if @@ -760,7 +766,7 @@ subroutine lak_read_lake_connections(this) ! -- read connection number ival = this%parser%GetInteger() if (ival < 1 .or. ival > this%nlakeconn(n)) then - write(errmsg,'(a,1x,i4,1x,a,1x,i6)') & + write (errmsg, '(a,1x,i4,1x,a,1x,i6)') & 'iconn FOR LAKE ', n, 'MUST BE > 1 and <= ', this%nlakeconn(n) call store_error(errmsg) cycle @@ -771,7 +777,7 @@ subroutine lak_read_lake_connections(this) ! -- set imap this%imap(ipos) = n - + ! ! -- increment nboundchk nboundchk(ipos) = nboundchk(ipos) + 1 @@ -779,11 +785,11 @@ subroutine lak_read_lake_connections(this) ! -- read gwfnodes from the line call this%parser%GetCellid(this%dis%ndim, cellid) nn = this%dis%noder_from_cellid(cellid, & - this%parser%iuactive, this%iout) + this%parser%iuactive, this%iout) ! ! -- determine if a valid cell location was provided if (nn < 1) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4)') & + write (errmsg, '(a,1x,i4,1x,a,1x,i4)') & 'INVALID cellid FOR LAKE ', n, 'connection', j call store_error(errmsg) end if @@ -795,33 +801,33 @@ subroutine lak_read_lake_connections(this) ! -- read ictype call this%parser%GetStringCaps(keyword) select case (keyword) - case ('VERTICAL') - this%ictype(ipos) = 0 - case ('HORIZONTAL') - this%ictype(ipos) = 1 - case ('EMBEDDEDH') - this%ictype(ipos) = 2 - case ('EMBEDDEDV') - this%ictype(ipos) = 3 - case default - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a,a,a)') & - 'UNKNOWN ctype FOR LAKE ', n, 'connection', j, & - '(', trim(keyword), ')' - call store_error(errmsg) + case ('VERTICAL') + this%ictype(ipos) = 0 + case ('HORIZONTAL') + this%ictype(ipos) = 1 + case ('EMBEDDEDH') + this%ictype(ipos) = 2 + case ('EMBEDDEDV') + this%ictype(ipos) = 3 + case default + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a,a,a)') & + 'UNKNOWN ctype FOR LAKE ', n, 'connection', j, & + '(', trim(keyword), ')' + call store_error(errmsg) end select ! -- bed leakance !this%bedleak(ipos) = this%parser%GetDouble() call this%parser%GetStringCaps(keyword) - select case(keyword) - case ('NONE') - this%bedleak(ipos) = -DONE - case default - read(keyword, *) this%bedleak(ipos) + select case (keyword) + case ('NONE') + this%bedleak(ipos) = -DONE + case default + read (keyword, *) this%bedleak(ipos) end select if (keyword /= 'NONE' .and. this%bedleak(ipos) < dzero) then - write(errmsg,'(a,1x,i4,1x,a)') 'bedleak FOR LAKE ', n, 'MUST BE >= 0' + write (errmsg, '(a,1x,i4,1x,a)') 'bedleak FOR LAKE ', n, 'MUST BE >= 0' call store_error(errmsg) end if @@ -833,11 +839,11 @@ subroutine lak_read_lake_connections(this) ! -- connection length rval = this%parser%GetDouble() - if (rval < dzero) then - if (this%ictype(ipos) == 1 .or. this%ictype(ipos) == 2 .or. & + if (rval < dzero) then + if (this%ictype(ipos) == 1 .or. this%ictype(ipos) == 2 .or. & this%ictype(ipos) == 3) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a)') & - 'connection length (connlength) FOR LAKE ', n, & + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a)') & + 'connection length (connlength) FOR LAKE ', n, & ' HORIZONTAL CONNECTION ', j, 'MUST BE >= 0' call store_error(errmsg) else @@ -848,11 +854,11 @@ subroutine lak_read_lake_connections(this) ! -- connection width rval = this%parser%GetDouble() - if (rval < dzero) then + if (rval < dzero) then if (this%ictype(ipos) == 1) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a)') & - 'cell width (connwidth) FOR LAKE ', n, & - ' HORIZONTAL CONNECTION ', j, 'MUST BE >= 0' + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a)') & + 'cell width (connwidth) FOR LAKE ', n, & + ' HORIZONTAL CONNECTION ', j, 'MUST BE >= 0' call store_error(errmsg) else rval = DZERO @@ -860,7 +866,7 @@ subroutine lak_read_lake_connections(this) end if this%connwidth(ipos) = rval end do - write(this%iout,'(1x,a)') & + write (this%iout, '(1x,a)') & 'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' else call store_error('REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') @@ -874,13 +880,13 @@ subroutine lak_read_lake_connections(this) ! -- check that embedded lakes have only one connection do n = 1, this%nlakes j = 0 - do ipos = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do ipos = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 if (this%ictype(ipos) /= 2 .and. this%ictype(ipos) /= 3) cycle j = j + 1 if (j > 1) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a)') & - 'nlakeconn FOR LAKE', n, 'EMBEDDED CONNECTION', j, ' EXCEEDS 1.' - call store_error(errmsg) + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a)') & + 'nlakeconn FOR LAKE', n, 'EMBEDDED CONNECTION', j, ' EXCEEDS 1.' + call store_error(errmsg) end if end do end do @@ -893,16 +899,16 @@ subroutine lak_read_lake_connections(this) do nn = 1, this%nlakes if (nn == n) cycle j = 0 - do ipos = this%idxlakeconn(nn), this%idxlakeconn(nn+1)-1 + do ipos = this%idxlakeconn(nn), this%idxlakeconn(nn + 1) - 1 j = j + 1 icellid = this%cellid(ipos) if (icellid == icellid0) then if (this%ictype(ipos) == 0) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a,1x,i4,1x,a)') & - 'EMBEDDED LAKE', n, & - 'CANNOT COINCIDE WITH VERTICAL CONNECTION', j, & - 'IN LAKE', nn, '.' - call store_error(errmsg) + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a,1x,i4,1x,a)') & + 'EMBEDDED LAKE', n, & + 'CANNOT COINCIDE WITH VERTICAL CONNECTION', j, & + 'IN LAKE', nn, '.' + call store_error(errmsg) end if end if end do @@ -912,7 +918,7 @@ subroutine lak_read_lake_connections(this) ! -- process the data do n = 1, this%nlakes j = 0 - do ipos = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do ipos = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 j = j + 1 nn = this%cellid(ipos) top = this%dis%top(nn) @@ -922,32 +928,32 @@ subroutine lak_read_lake_connections(this) this%telev(ipos) = top + this%surfdep this%belev(ipos) = top this%lakebot(n) = min(this%belev(ipos), this%lakebot(n)) - ! horizontal connection + ! horizontal connection else if (this%ictype(ipos) == 1) then if (this%belev(ipos) == this%telev(ipos)) then this%telev(ipos) = top this%belev(ipos) = bot else if (this%belev(ipos) >= this%telev(ipos)) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a)') & - 'telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a)') & + 'telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & 'MUST BE >= belev' call store_error(errmsg) else if (this%belev(ipos) < bot) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & - 'belev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & + 'belev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & 'MUST BE >= cell bottom (', bot, ')' call store_error(errmsg) else if (this%telev(ipos) > top) then - write(errmsg,'(a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & - 'telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & + write (errmsg, '(a,1x,i4,1x,a,1x,i4,1x,a,1x,g15.7,1x,a)') & + 'telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, & 'MUST BE <= cell top (', top, ')' call store_error(errmsg) end if end if this%laketop(n) = max(this%telev(ipos), this%laketop(n)) this%lakebot(n) = min(this%belev(ipos), this%lakebot(n)) - ! embedded connections + ! embedded connections else if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then this%telev(ipos) = top this%belev(ipos) = bot @@ -956,12 +962,12 @@ subroutine lak_read_lake_connections(this) ! ! -- check for missing or duplicate lake connections if (nboundchk(ipos) == 0) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0)') & 'NO DATA SPECIFIED FOR LAKE', n, 'CONNECTION', j call store_error(errmsg) else if (nboundchk(ipos) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'DATA FOR LAKE', n, 'CONNECTION', j, & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'DATA FOR LAKE', n, 'CONNECTION', j, & 'SPECIFIED', nboundchk(ipos), 'TIMES' call store_error(errmsg) end if @@ -974,7 +980,7 @@ subroutine lak_read_lake_connections(this) end do ! ! -- deallocate local variable - deallocate(nboundchk) + deallocate (nboundchk) ! ! -- write summary of lake_connection error messages if (count_errors() > 0) then @@ -995,9 +1001,9 @@ subroutine lak_read_tables(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local - type (LakTabType), dimension(:), allocatable :: laketables + type(LakTabType), dimension(:), allocatable :: laketables character(len=LINELENGTH) :: line character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -1016,13 +1022,13 @@ subroutine lak_read_tables(this) if (this%ntables < 1) return ! ! -- allocate and initialize nboundchk - allocate(nboundchk(this%nlakes)) + allocate (nboundchk(this%nlakes)) do n = 1, this%nlakes nboundchk(n) = 0 end do ! ! -- allocate derived type for table data - allocate(laketables(this%nlakes)) + allocate (laketables(this%nlakes)) ! ! -- get lake_tables block call this%parser%GetBlock('TABLES', isfound, ierr, & @@ -1032,7 +1038,7 @@ subroutine lak_read_tables(this) if (isfound) then ntabs = 0 ! -- process the lake table data - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' LAKE_TABLES' readtable: do call this%parser%GetNextLine(endOfBlock) @@ -1040,11 +1046,11 @@ subroutine lak_read_tables(this) n = this%parser%GetInteger() if (n < 1 .or. n > this%nlakes) then - write(errmsg,'(a,1x,i6)') 'lakeno MUST BE > 0 and <= ', this%nlakes + write (errmsg, '(a,1x,i6)') 'lakeno MUST BE > 0 and <= ', this%nlakes call store_error(errmsg) cycle readtable end if - + ! -- increment ntab and nboundchk ntabs = ntabs + 1 nboundchk(n) = nboundchk(n) + 1 @@ -1052,37 +1058,37 @@ subroutine lak_read_tables(this) ! -- read FILE keyword call this%parser%GetStringCaps(keyword) select case (keyword) - case('TAB6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAB6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - cycle readtable - end if - call this%parser%GetString(line) - call this%lak_read_table(n, line, laketables(n)) - case default - write(errmsg,'(a,1x,i4,1x,a)') & - 'LAKE TABLE ENTRY for LAKE ', n, 'MUST INCLUDE TAB6 KEYWORD' + case ('TAB6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAB6 keyword must be followed by "FILEIN" '// & + 'then by filename.' call store_error(errmsg) cycle readtable + end if + call this%parser%GetString(line) + call this%lak_read_table(n, line, laketables(n)) + case default + write (errmsg, '(a,1x,i4,1x,a)') & + 'LAKE TABLE ENTRY for LAKE ', n, 'MUST INCLUDE TAB6 KEYWORD' + call store_error(errmsg) + cycle readtable end select end do readtable - - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' LAKE_TABLES' + + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' LAKE_TABLES' ! ! -- check for missing or duplicate lake connections if (ntabs < this%ntables) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & - 'TABLE DATA ARE SPECIFIED', ntabs, & + write (errmsg, '(a,1x,i0,1x,a,1x,i0)') & + 'TABLE DATA ARE SPECIFIED', ntabs, & 'TIMES BUT NTABLES IS SET TO', this%ntables call store_error(errmsg) end if do n = 1, this%nlakes if (this%ntabrow(n) > 0 .and. nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'TABLE DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES' call store_error(errmsg) end if @@ -1092,7 +1098,7 @@ subroutine lak_read_tables(this) end if ! ! -- deallocate local storage - deallocate(nboundchk) + deallocate (nboundchk) ! ! -- write summary of lake_table error messages if (count_errors() > 0) then @@ -1105,21 +1111,21 @@ subroutine lak_read_tables(this) ! -- destroy laketables do n = 1, this%nlakes if (this%ntabrow(n) > 0) then - deallocate(laketables(n)%tabstage) - deallocate(laketables(n)%tabvolume) - deallocate(laketables(n)%tabsarea) + deallocate (laketables(n)%tabstage) + deallocate (laketables(n)%tabvolume) + deallocate (laketables(n)%tabsarea) iconn = this%idxlakeconn(n) if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then - deallocate(laketables(n)%tabwarea) + deallocate (laketables(n)%tabwarea) end if end if end do - deallocate(laketables) + deallocate (laketables) ! ! -- return return end subroutine lak_read_tables - + subroutine laktables_to_vectors(this, laketables) ! ****************************************************************************** ! laktables_to_vectors -- Copy the laketables structure data into flattened @@ -1129,7 +1135,7 @@ subroutine laktables_to_vectors(this, laketables) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ class(LakType), intent(inout) :: this - type (LakTabType), intent(in), dimension(:), contiguous :: laketables + type(LakTabType), intent(in), dimension(:), contiguous :: laketables integer(I4B) :: n integer(I4B) :: ntabrows integer(I4B) :: j @@ -1190,8 +1196,8 @@ subroutine lak_read_table(this, ilak, filename, laketable) ! -- dummy class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak - character (len=*), intent(in) :: filename - type (LakTabType), intent(inout) :: laketable + character(len=*), intent(in) :: filename + type(LakTabType), intent(inout) :: laketable ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -1209,8 +1215,8 @@ subroutine lak_read_table(this, ilak, filename, laketable) real(DP) :: v0 type(BlockParserType) :: parser ! -- formats - character(len=*), parameter :: fmttaberr = & - '(a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)' + character(len=*), parameter :: fmttaberr = & + &'(a,1x,i4,1x,a,1x,g15.6,1x,a,1x,i6,1x,a,1x,i4,1x,a,1x,g15.6,1x,a)' ! ------------------------------------------------------------------------------ ! -- format @@ -1233,43 +1239,43 @@ subroutine lak_read_table(this, ilak, filename, laketable) if (isfound) then ! -- process the lake table dimension data if (this%iprpak /= 0) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS' end if readdims: do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('NROW') - n = parser%GetInteger() - - if (n < 1) then - write(errmsg,'(a)') 'LAKE TABLE NROW MUST BE > 0' - call store_error(errmsg) - end if - case ('NCOL') - j = parser%GetInteger() + case ('NROW') + n = parser%GetInteger() - if (this%ictype(ilak) == 2 .or. this%ictype(ilak) == 3) then - jmin = 4 - else - jmin = 3 - end if - if (j < jmin) then - write(errmsg,'(a,1x,i0)') 'LAKE TABLE NCOL MUST BE >= ', jmin - call store_error(errmsg) - end if + if (n < 1) then + write (errmsg, '(a)') 'LAKE TABLE NROW MUST BE > 0' + call store_error(errmsg) + end if + case ('NCOL') + j = parser%GetInteger() - case default - write(errmsg,'(a,a)') & - 'UNKNOWN '//trim(this%text)//' DIMENSIONS KEYWORD: ', trim(keyword) + if (this%ictype(ilak) == 2 .or. this%ictype(ilak) == 3) then + jmin = 4 + else + jmin = 3 + end if + if (j < jmin) then + write (errmsg, '(a,1x,i0)') 'LAKE TABLE NCOL MUST BE >= ', jmin call store_error(errmsg) + end if + + case default + write (errmsg, '(a,a)') & + 'UNKNOWN '//trim(this%text)//' DIMENSIONS KEYWORD: ', trim(keyword) + call store_error(errmsg) end select end do readdims if (this%iprpak /= 0) then - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' end if else call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.') @@ -1277,12 +1283,12 @@ subroutine lak_read_table(this, ilak, filename, laketable) ! ! -- check that ncol and nrow have been specified if (n < 1) then - write(errmsg,'(a)') & + write (errmsg, '(a)') & 'NROW NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK' call store_error(errmsg) end if if (j < 1) then - write(errmsg,'(a)') & + write (errmsg, '(a)') & 'NCOL NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK' call store_error(errmsg) end if @@ -1293,14 +1299,14 @@ subroutine lak_read_table(this, ilak, filename, laketable) ! ! -- allocate space this%ntabrow(ilak) = n - allocate(laketable%tabstage(n)) - allocate(laketable%tabvolume(n)) - allocate(laketable%tabsarea(n)) + allocate (laketable%tabstage(n)) + allocate (laketable%tabvolume(n)) + allocate (laketable%tabsarea(n)) ipos = this%idxlakeconn(ilak) if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then - allocate(laketable%tabwarea(n)) + allocate (laketable%tabwarea(n)) end if - + ! -- get table block call parser%GetBlock('TABLE', isfound, ierr, supportOpenClose=.true.) ! @@ -1309,7 +1315,7 @@ subroutine lak_read_table(this, ilak, filename, laketable) ! -- process the table data if (this%iprpak /= 0) then - write(this%iout,'(/1x,a)') & + write (this%iout, '(/1x,a)') & 'PROCESSING '//trim(adjustl(this%text))//' TABLE' end if iconn = this%idxlakeconn(ilak) @@ -1328,9 +1334,9 @@ subroutine lak_read_table(this, ilak, filename, laketable) laketable%tabwarea(ipos) = parser%GetDouble() end if end do readtabledata - + if (this%iprpak /= 0) then - write(this%iout,'(1x,a)') & + write (this%iout, '(1x,a)') & 'END OF '//trim(adjustl(this%text))//' TABLE' end if else @@ -1339,7 +1345,7 @@ subroutine lak_read_table(this, ilak, filename, laketable) ! ! -- error condition if number of rows read are not equal to nrow if (ipos /= this%ntabrow(ilak)) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'NROW SET TO', this%ntabrow(ilak), 'BUT', ipos, 'ROWS WERE READ' call store_error(errmsg) end if @@ -1366,44 +1372,44 @@ subroutine lak_read_table(this, ilak, filename, laketable) ! -- verify the table data do n = 2, this%ntabrow(ilak) v = laketable%tabstage(n) - v0 = laketable%tabstage(n-1) + v0 = laketable%tabstage(n - 1) if (v <= v0) then - write(errmsg,fmttaberr) & - 'TABLE STAGE ENTRY', n, '(', laketable%tabstage(n), & - ') FOR LAKE ', ilak, 'MUST BE GREATER THAN THE PREVIOUS STAGE ENTRY',& - n-1, '(', laketable%tabstage(n-1), ')' + write (errmsg, fmttaberr) & + 'TABLE STAGE ENTRY', n, '(', laketable%tabstage(n), ') FOR LAKE ', & + ilak, 'MUST BE GREATER THAN THE PREVIOUS STAGE ENTRY', & + n - 1, '(', laketable%tabstage(n - 1), ')' call store_error(errmsg) end if v = laketable%tabvolume(n) - v0 = laketable%tabvolume(n-1) + v0 = laketable%tabvolume(n - 1) if (v <= v0) then - write(errmsg,fmttaberr) & - 'TABLE VOLUME ENTRY', n, '(', laketable%tabvolume(n), & - ') FOR LAKE ', & - ilak, 'MUST BE GREATER THAN THE PREVIOUS VOLUME ENTRY', & - n-1, '(', laketable%tabvolume(n-1), ')' + write (errmsg, fmttaberr) & + 'TABLE VOLUME ENTRY', n, '(', laketable%tabvolume(n), & + ') FOR LAKE ', & + ilak, 'MUST BE GREATER THAN THE PREVIOUS VOLUME ENTRY', & + n - 1, '(', laketable%tabvolume(n - 1), ')' call store_error(errmsg) end if v = laketable%tabsarea(n) - v0 = laketable%tabsarea(n-1) + v0 = laketable%tabsarea(n - 1) if (v < v0) then - write(errmsg,fmttaberr) & - 'TABLE SURFACE AREA ENTRY', n, '(', & - laketable%tabsarea(n), ') FOR LAKE ', ilak, & - 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS SURFACE AREA ENTRY', & - n-1, '(', laketable%tabsarea(n-1), ')' + write (errmsg, fmttaberr) & + 'TABLE SURFACE AREA ENTRY', n, '(', & + laketable%tabsarea(n), ') FOR LAKE ', ilak, & + 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS SURFACE AREA ENTRY', & + n - 1, '(', laketable%tabsarea(n - 1), ')' call store_error(errmsg) end if iconn = this%idxlakeconn(ilak) if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then v = laketable%tabwarea(n) - v0 = laketable%tabwarea(n-1) + v0 = laketable%tabwarea(n - 1) if (v < v0) then - write(errmsg,fmttaberr) & - 'TABLE EXCHANGE AREA ENTRY', n, '(', & - laketable%tabwarea(n), ') FOR LAKE ', ilak, & - 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS EXCHANGE AREA ' // & - 'ENTRY', n-1, '(', laketable%tabwarea(n-1), ')' + write (errmsg, fmttaberr) & + 'TABLE EXCHANGE AREA ENTRY', n, '(', & + laketable%tabwarea(n), ') FOR LAKE ', ilak, & + 'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS EXCHANGE AREA '// & + 'ENTRY', n - 1, '(', laketable%tabwarea(n - 1), ')' call store_error(errmsg) end if end if @@ -1433,7 +1439,7 @@ subroutine lak_read_outlets(this) use SimModule, only: store_error, count_errors use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: text, keyword character(len=LENBOUNDNAME) :: bndName @@ -1451,7 +1457,7 @@ subroutine lak_read_outlets(this) ! ------------------------------------------------------------------------------ ! ! -- get well_connections block - call this%parser%GetBlock('OUTLETS', isfound, ierr, & + call this%parser%GetBlock('OUTLETS', isfound, ierr, & supportOpenClose=.true., blockRequired=.false.) ! ! -- parse outlets block if detected @@ -1459,7 +1465,7 @@ subroutine lak_read_outlets(this) if (this%noutlets > 0) then ! ! -- allocate and initialize local variables - allocate(nboundchk(this%noutlets)) + allocate (nboundchk(this%noutlets)) do n = 1, this%noutlets nboundchk(n) = 0 end do @@ -1467,14 +1473,18 @@ subroutine lak_read_outlets(this) ! -- allocate outlet data using memory manager call mem_allocate(this%lakein, this%NOUTLETS, 'LAKEIN', this%memoryPath) call mem_allocate(this%lakeout, this%NOUTLETS, 'LAKEOUT', this%memoryPath) - call mem_allocate(this%iouttype, this%NOUTLETS, 'IOUTTYPE', this%memoryPath) + call mem_allocate(this%iouttype, this%NOUTLETS, 'IOUTTYPE', & + this%memoryPath) call mem_allocate(this%outrate, this%NOUTLETS, 'OUTRATE', this%memoryPath) - call mem_allocate(this%outinvert, this%NOUTLETS, 'OUTINVERT', & + call mem_allocate(this%outinvert, this%NOUTLETS, 'OUTINVERT', & + this%memoryPath) + call mem_allocate(this%outwidth, this%NOUTLETS, 'OUTWIDTH', & + this%memoryPath) + call mem_allocate(this%outrough, this%NOUTLETS, 'OUTROUGH', & this%memoryPath) - call mem_allocate(this%outwidth, this%NOUTLETS, 'OUTWIDTH', this%memoryPath) - call mem_allocate(this%outrough, this%NOUTLETS, 'OUTROUGH', this%memoryPath) - call mem_allocate(this%outslope, this%NOUTLETS, 'OUTSLOPE', this%memoryPath) - call mem_allocate(this%simoutrate, this%NOUTLETS, 'SIMOUTRATE', & + call mem_allocate(this%outslope, this%NOUTLETS, 'OUTSLOPE', & + this%memoryPath) + call mem_allocate(this%simoutrate, this%NOUTLETS, 'SIMOUTRATE', & this%memoryPath) ! ! -- initialize outlet rate @@ -1483,15 +1493,15 @@ subroutine lak_read_outlets(this) end do ! -- process the lake connection data - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' OUTLETS' + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' OUTLETS' readoutlet: do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit n = this%parser%GetInteger() if (n < 1 .or. n > this%noutlets) then - write(errmsg,'(a,1x,i6)') & + write (errmsg, '(a,1x,i6)') & 'outletno MUST BE > 0 and <= ', this%noutlets call store_error(errmsg) cycle readoutlet @@ -1502,8 +1512,8 @@ subroutine lak_read_outlets(this) ! ! -- read outlet lakein ival = this%parser%GetInteger() - if (ival <1 .or. ival > this%nlakes) then - write(errmsg,'(a,1x,i4,1x,a,1x,i6)') & + if (ival < 1 .or. ival > this%nlakes) then + write (errmsg, '(a,1x,i4,1x,a,1x,i6)') & 'lakein FOR OUTLET ', n, 'MUST BE > 0 and <= ', this%nlakes call store_error(errmsg) cycle readoutlet @@ -1512,8 +1522,8 @@ subroutine lak_read_outlets(this) ! -- read outlet lakeout ival = this%parser%GetInteger() - if (ival <0 .or. ival > this%nlakes) then - write(errmsg,'(a,1x,i4,1x,a,1x,i6)') & + if (ival < 0 .or. ival > this%nlakes) then + write (errmsg, '(a,1x,i4,1x,a,1x,i6)') & 'lakeout FOR OUTLET ', n, 'MUST BE >= 0 and <= ', this%nlakes call store_error(errmsg) cycle readoutlet @@ -1523,22 +1533,22 @@ subroutine lak_read_outlets(this) ! -- read ictype call this%parser%GetStringCaps(keyword) select case (keyword) - case ('SPECIFIED') - this%iouttype(n) = 0 - case ('MANNING') - this%iouttype(n) = 1 - case ('WEIR') - this%iouttype(n) = 2 - case default - write(errmsg,'(a,1x,i4,1x,a,a,a)') & - 'UNKNOWN couttype FOR OUTLET ', n, '(', trim(keyword), ')' - call store_error(errmsg) - cycle readoutlet - end select + case ('SPECIFIED') + this%iouttype(n) = 0 + case ('MANNING') + this%iouttype(n) = 1 + case ('WEIR') + this%iouttype(n) = 2 + case default + write (errmsg, '(a,1x,i4,1x,a,a,a)') & + 'UNKNOWN couttype FOR OUTLET ', n, '(', trim(keyword), ')' + call store_error(errmsg) + cycle readoutlet + end select ! -- build bndname for outlet - write(citem,'(i9.9)') n - bndName = 'OUTLET' // citem + write (citem, '(i9.9)') n + bndName = 'OUTLET'//citem ! -- set a few variables for timeseries aware variables jj = 1 @@ -1546,55 +1556,56 @@ subroutine lak_read_outlets(this) ! -- outlet invert call this%parser%GetString(text) bndElem => this%outinvert(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & 'INVERT') ! ! -- outlet width call this%parser%GetString(text) bndElem => this%outwidth(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'WIDTH') + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'WIDTH') ! ! -- outlet roughness call this%parser%GetString(text) bndElem => this%outrough(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'ROUGH') + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'ROUGH') ! ! -- outlet slope call this%parser%GetString(text) bndElem => this%outslope(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'SLOPE') + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'SLOPE') end do readoutlet - write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & - ' OUTLETS' + write (this%iout, '(1x,a)') 'END OF '//trim(adjustl(this%text))// & + ' OUTLETS' ! ! -- check for duplicate or missing outlets do n = 1, this%noutlets if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') 'NO DATA SPECIFIED FOR OUTLET', n + write (errmsg, '(a,1x,i0)') 'NO DATA SPECIFIED FOR OUTLET', n call store_error(errmsg) else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'DATA FOR OUTLET', n, 'SPECIFIED', nboundchk(n), 'TIMES' call store_error(errmsg) end if end do ! ! -- deallocate local storage - deallocate(nboundchk) + deallocate (nboundchk) else - write(errmsg,'(a,1x,a)') & - 'AN OUTLETS BLOCK SHOULD NOT BE SPECIFIED IF NOUTLETS IS NOT', & + write (errmsg, '(a,1x,a)') & + 'AN OUTLETS BLOCK SHOULD NOT BE SPECIFIED IF NOUTLETS IS NOT', & 'SPECIFIED OR IS SPECIFIED TO BE 0.' - call store_error(errmsg) + call store_error(errmsg) end if - + else if (this%noutlets > 0) then call store_error('REQUIRED OUTLETS BLOCK NOT FOUND.') @@ -1621,7 +1632,7 @@ subroutine lak_read_dimensions(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -1630,7 +1641,7 @@ subroutine lak_read_dimensions(this) ! ------------------------------------------------------------------------------ ! ! -- initialize dimensions to -1 - this%nlakes= -1 + this%nlakes = -1 this%maxbound = -1 ! ! -- get dimensions block @@ -1639,36 +1650,36 @@ subroutine lak_read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)') 'PROCESSING ' // trim(adjustl(this%text)) // & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NLAKES') - this%nlakes = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NLAKES = ', this%nlakes - case ('NOUTLETS') - this%noutlets = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NOUTLETS = ', this%noutlets - case ('NTABLES') - this%ntables = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NTABLES = ', this%ntables - case default - write(errmsg,'(a,a)') & - 'UNKNOWN '//trim(this%text)//' DIMENSION: ', trim(keyword) - call store_error(errmsg) + case ('NLAKES') + this%nlakes = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NLAKES = ', this%nlakes + case ('NOUTLETS') + this%noutlets = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NOUTLETS = ', this%noutlets + case ('NTABLES') + this%ntables = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NTABLES = ', this%ntables + case default + write (errmsg, '(a,a)') & + 'UNKNOWN '//trim(this%text)//' DIMENSION: ', trim(keyword) + call store_error(errmsg) end select end do - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' else call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.') end if if (this%nlakes < 0) then - write(errmsg, '(a)') & + write (errmsg, '(a)') & 'NLAKES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.' call store_error(errmsg) end if @@ -1704,7 +1715,6 @@ subroutine lak_read_dimensions(this) return end subroutine lak_read_dimensions - subroutine lak_read_initial_attr(this) ! ****************************************************************************** ! pak1read_dimensions -- Read the initial parameters for this package @@ -1717,7 +1727,7 @@ subroutine lak_read_initial_attr(this) use SimModule, only: store_error, count_errors use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: text integer(I4B) :: j, jj, n @@ -1738,27 +1748,27 @@ subroutine lak_read_initial_attr(this) real(DP) :: c1 real(DP) :: c2 real(DP), allocatable, dimension(:) :: clb, caq - character (len=14) :: cbedleak - character (len=14) :: cbedcond - character (len=10), dimension(0:3) :: ctype - character (len=15) :: nodestr + character(len=14) :: cbedleak + character(len=14) :: cbedcond + character(len=10), dimension(0:3) :: ctype + character(len=15) :: nodestr real(DP), pointer :: bndElem => null() ! -- data - data ctype(0) /'VERTICAL '/ - data ctype(1) /'HORIZONTAL'/ - data ctype(2) /'EMBEDDEDH '/ - data ctype(3) /'EMBEDDEDV '/ + data ctype(0)/'VERTICAL '/ + data ctype(1)/'HORIZONTAL'/ + data ctype(2)/'EMBEDDEDH '/ + data ctype(3)/'EMBEDDEDV '/ ! -- format ! ------------------------------------------------------------------------------ ! ! -- initialize xnewpak and set stage do n = 1, this%nlakes this%xnewpak(n) = this%strt(n) - write(text,'(g15.7)') this%strt(n) - jj = 1 ! For STAGE + write (text, '(g15.7)') this%strt(n) + jj = 1 ! For STAGE bndElem => this%stage(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, 'BND', & - this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'STAGE') end do ! @@ -1776,11 +1786,11 @@ subroutine lak_read_initial_attr(this) ! -- set boundname for each connection if (this%inamedbound /= 0) then do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 this%boundname(j) = this%lakename(n) end do end do - endif + end if ! ! -- set pointer to gwf iss and gwf hk call mem_setptr(this%gwfiss, 'ISS', create_mem_path(this%name_model)) @@ -1790,12 +1800,12 @@ subroutine lak_read_initial_attr(this) call mem_setptr(this%gwfsat, 'SAT', create_mem_path(this%name_model, 'NPF')) ! ! -- allocate temporary storage - allocate(clb(this%MAXBOUND)) - allocate(caq(this%MAXBOUND)) + allocate (clb(this%MAXBOUND)) + allocate (caq(this%MAXBOUND)) ! -- calculate saturated conductance for each connection do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 nn = this%cellid(j) top = this%dis%top(nn) bot = this%dis%bot(nn) @@ -1809,9 +1819,9 @@ subroutine lak_read_initial_attr(this) k = this%gwfk11(nn) else k = this%gwfk33(nn) - endif + end if length = DHALF * (top - bot) - ! horizontal connection + ! horizontal connection else if (this%ictype(j) == 1) then area = (this%telev(j) - this%belev(j)) * this%connwidth(j) ! -- recalculate area if connected cell is confined and lake @@ -1826,7 +1836,7 @@ subroutine lak_read_initial_attr(this) this%sareamax(n) = this%sareamax(n) + DZERO k = this%gwfk11(nn) length = this%connlength(j) - ! embedded horizontal connection + ! embedded horizontal connection else if (this%ictype(j) == 2) then area = DONE this%sarea(j) = DZERO @@ -1834,7 +1844,7 @@ subroutine lak_read_initial_attr(this) this%sareamax(n) = this%sareamax(n) + DZERO k = this%gwfk11(nn) length = this%connlength(j) - ! embedded vertical connection + ! embedded vertical connection else if (this%ictype(j) == 3) then area = DONE this%sarea(j) = DZERO @@ -1844,7 +1854,7 @@ subroutine lak_read_initial_attr(this) k = this%gwfk11(nn) else k = this%gwfk33(nn) - endif + end if length = this%connlength(j) end if if (this%bedleak(j) < DZERO) then @@ -1861,7 +1871,7 @@ subroutine lak_read_initial_attr(this) end if if (this%bedleak(j) < DZERO) then this%satcond(j) = area / caq(j) - else if (clb(j)*caq(j) > DZERO) then + else if (clb(j) * caq(j) > DZERO) then this%satcond(j) = area / (clb(j) + caq(j)) else this%satcond(j) = DZERO @@ -1871,17 +1881,18 @@ subroutine lak_read_initial_attr(this) ! ! -- write a summary of the conductance if (this%iprpak > 0) then - write(this%iout,'(//,29x,a,/)') 'INTERFACE CONDUCTANCE BETWEEN LAKE AND AQUIFER CELLS' - write(this%iout,'(1x,a)') & - & ' LAKE CONNECTION CONNECTION LAKEBED' // & + write (this%iout, '(//,29x,a,/)') & + 'INTERFACE CONDUCTANCE BETWEEN LAKE AND AQUIFER CELLS' + write (this%iout, '(1x,a)') & + & ' LAKE CONNECTION CONNECTION LAKEBED'// & & ' C O N D U C T A N C E S ' - write(this%iout,'(1x,a)') & - & ' NUMBER NUMBER CELLID DIRECTION LEAKANCE' // & + write (this%iout, '(1x,a)') & + & ' NUMBER NUMBER CELLID DIRECTION LEAKANCE'// & & ' LAKEBED AQUIFER COMBINED' - write(this%iout,"(1x,108('-'))") + write (this%iout, "(1x,108('-'))") do n = 1, this%nlakes idx = 0 - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 idx = idx + 1 fact = DONE if (this%ictype(j) == 1) then @@ -1898,36 +1909,43 @@ subroutine lak_read_initial_attr(this) cbedcond = ' NONE ' else if (clb(j) > DZERO) then c1 = area * fact / clb(j) - write(cbedleak,'(g14.5)') this%bedleak(j) - write(cbedcond,'(g14.5)') c1 + write (cbedleak, '(g14.5)') this%bedleak(j) + write (cbedcond, '(g14.5)') c1 else - write(cbedleak,'(g14.5)') c1 - write(cbedcond,'(g14.5)') c1 + write (cbedleak, '(g14.5)') c1 + write (cbedcond, '(g14.5)') c1 end if c2 = DZERO if (caq(j) > DZERO) then c2 = area * fact / caq(j) end if call this%dis%noder_to_string(nn, nodestr) - write(this%iout,'(1x,i10,1x,i10,1x,a15,1x,a10,2(1x,a14),2(1x,g14.5))') & - & n, idx, nodestr, ctype(this%ictype(j)), cbedleak, & - & cbedcond, c2, this%satcond(j) * fact + write (this%iout, & + '(1x,i10,1x,i10,1x,a15,1x,a10,2(1x,a14),2(1x,g14.5))') & + n, idx, nodestr, ctype(this%ictype(j)), cbedleak, & + cbedcond, c2, this%satcond(j) * fact end do end do - write(this%iout,"(1x,108('-'))") - write(this%iout,'(1x,a)') 'IF VERTICAL CONNECTION, CONDUCTANCE (L^2/T) IS BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.' - write(this%iout,'(1x,a)') 'IF HORIZONTAL CONNECTION, CONDUCTANCES ARE PER UNIT SATURATED THICKNESS (L/T).' - write(this%iout,'(1x,a)') 'IF EMBEDDED CONNECTION, CONDUCTANCES ARE PER UNIT EXCHANGE AREA (1/T).' + write (this%iout, "(1x,108('-'))") + write (this%iout, '(1x,a)') & + 'IF VERTICAL CONNECTION, CONDUCTANCE (L^2/T) IS & + &BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.' + write (this%iout, '(1x,a)') & + 'IF HORIZONTAL CONNECTION, CONDUCTANCES ARE PER & + &UNIT SATURATED THICKNESS (L/T).' + write (this%iout, '(1x,a)') & + 'IF EMBEDDED CONNECTION, CONDUCTANCES ARE PER & + &UNIT EXCHANGE AREA (1/T).' ! write(this%iout,*) n, idx, nodestr, this%sarea(j), this%warea(j) ! ! -- calculate stage, surface area, wetted area, volume relation do n = 1, this%nlakes - write(this%iout,'(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n - write(this%iout,'(/1x,5(a14))') ' STAGE', ' SURFACE AREA', & + write (this%iout, '(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n + write (this%iout, '(/1x,5(a14))') ' STAGE', ' SURFACE AREA', & & ' WETTED AREA', ' CONDUCTANCE', & & ' VOLUME' - write(this%iout,"(1x,70('-'))") + write (this%iout, "(1x,70('-'))") dx = (this%laketop(n) - this%lakebot(n)) / 150. s = this%lakebot(n) do j = 1, 151 @@ -1935,25 +1953,25 @@ subroutine lak_read_initial_attr(this) call this%lak_calculate_sarea(n, s, sa) call this%lak_calculate_warea(n, s, wa, s) call this%lak_calculate_vol(n, s, v) - write(this%iout,'(1x,5(E14.5))') s, sa, wa, c, v + write (this%iout, '(1x,5(E14.5))') s, sa, wa, c, v s = s + dx end do - write(this%iout,"(1x,70('-'))") + write (this%iout, "(1x,70('-'))") - write(this%iout,'(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n - write(this%iout,'(/1x,4(a14))') ' ', ' ', & + write (this%iout, '(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n + write (this%iout, '(/1x,4(a14))') ' ', ' ', & & ' CALCULATED', ' STAGE' - write(this%iout,'(1x,4(a14))') ' STAGE', ' VOLUME', & + write (this%iout, '(1x,4(a14))') ' STAGE', ' VOLUME', & & ' STAGE', ' DIFFERENCE' - write(this%iout,"(1x,56('-'))") + write (this%iout, "(1x,56('-'))") s = this%lakebot(n) - dx do j = 1, 156 call this%lak_calculate_vol(n, s, v) call this%lak_vol2stage(n, v, c) - write(this%iout,'(1x,4(E14.5))') s, v, c, s-c + write (this%iout, '(1x,4(E14.5))') s, v, c, s - c s = s + dx end do - write(this%iout,"(1x,56('-'))") + write (this%iout, "(1x,56('-'))") end do end if ! @@ -1964,8 +1982,8 @@ subroutine lak_read_initial_attr(this) this%gwfik33 => null() ! ! -- deallocate temporary storage - deallocate(clb) - deallocate(caq) + deallocate (clb) + deallocate (caq) ! ! -- return return @@ -1975,7 +1993,7 @@ end subroutine lak_read_initial_attr ! function assumes x data is sorted in ascending order subroutine lak_linear_interpolation(this, n, x, y, z, v) ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: n real(DP), dimension(n), intent(in) :: x real(DP), dimension(n), intent(in) :: y @@ -1989,27 +2007,27 @@ subroutine lak_linear_interpolation(this, n, x, y, z, v) ! below bottom of range - set to lowest value if (z <= x(1)) then v = y(1) - ! above highest value - ! slope calculated from interval between n and n-1 + ! above highest value + ! slope calculated from interval between n and n-1 else if (z > x(n)) then - dx = x(n) - x(n-1) + dx = x(n) - x(n - 1) dydx = DZERO if (ABS(dx) > DZERO) then - dydx = ( y(n) - y(n-1) ) / dx + dydx = (y(n) - y(n - 1)) / dx end if - dx = (z - x(n)) + dx = (z - x(n)) v = y(n) + dydx * dx - ! between lowest and highest value in current interval + ! between lowest and highest value in current interval else do i = 2, n - dx = x(i) - x(i-1) + dx = x(i) - x(i - 1) dydx = DZERO - if (z >= x(i-1) .and. z <= x(i)) then + if (z >= x(i - 1) .and. z <= x(i)) then if (ABS(dx) > DZERO) then - dydx = ( y(i) - y(i-1) ) / dx + dydx = (y(i) - y(i - 1)) / dx end if - dx = (z - x(i-1)) - v = y(i-1) + dydx * dx + dx = (z - x(i - 1)) + v = y(i - 1) + dydx * dx exit end if end do @@ -2026,7 +2044,7 @@ subroutine lak_calculate_sarea(this, ilak, stage, sarea) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: sarea @@ -2050,12 +2068,12 @@ subroutine lak_calculate_sarea(this, ilak, stage, sarea) else if (stage >= this%tabstage(ilast)) then sarea = this%tabsarea(ilast) else - call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), & - this%tabsarea(ifirst:ilast), & + call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), & + this%tabsarea(ifirst:ilast), & stage, sarea) end if else - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1 topl = this%telev(i) botl = this%belev(i) sat = sQuadraticSaturation(topl, botl, stage) @@ -2076,7 +2094,7 @@ subroutine lak_calculate_warea(this, ilak, stage, warea, hin) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: warea @@ -2089,7 +2107,7 @@ subroutine lak_calculate_warea(this, ilak, stage, warea, hin) ! -- formats ! ------------------------------------------------------------------------------ warea = DZERO - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1 if (present(hin)) then head = hin else @@ -2113,7 +2131,7 @@ subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak integer(I4B), intent(in) :: iconn real(DP), intent(in) :: stage @@ -2144,8 +2162,8 @@ subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa) else if (vv >= this%tabstage(ilast)) then wa = this%tabwarea(ilast) else - call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), & - this%tabwarea(ifirst:ilast), & + call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), & + this%tabwarea(ifirst:ilast), & vv, wa) end if else @@ -2153,7 +2171,7 @@ subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa) ! -- confined cell if (this%icelltype(node) == 0) then sat = DONE - ! -- convertible cell + ! -- convertible cell else sat = sQuadraticSaturation(topl, botl, vv) end if @@ -2164,7 +2182,6 @@ subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa) return end subroutine lak_calculate_conn_warea - subroutine lak_calculate_vol(this, ilak, stage, volume) ! ****************************************************************************** ! lak_calculate_vol -- Calculate the volume of a lake at a given stage. @@ -2173,7 +2190,7 @@ subroutine lak_calculate_vol(this, ilak, stage, volume) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: volume @@ -2201,12 +2218,12 @@ subroutine lak_calculate_vol(this, ilak, stage, volume) sa = this%tabsarea(ilast) volume = this%tabvolume(ilast) + ds * sa else - call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), & - this%tabvolume(ifirst:ilast), & + call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), & + this%tabvolume(ifirst:ilast), & stage, volume) end if else - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1 topl = this%telev(i) botl = this%belev(i) sat = sQuadraticSaturation(topl, botl, stage) @@ -2226,7 +2243,6 @@ subroutine lak_calculate_vol(this, ilak, stage, volume) return end subroutine lak_calculate_vol - subroutine lak_calculate_conductance(this, ilak, stage, conductance) ! ****************************************************************************** ! lak_calculate_conductance -- Calculate the total conductance for a lake at a @@ -2236,7 +2252,7 @@ subroutine lak_calculate_conductance(this, ilak, stage, conductance) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: conductance @@ -2246,7 +2262,7 @@ subroutine lak_calculate_conductance(this, ilak, stage, conductance) ! -- formats ! ------------------------------------------------------------------------------ conductance = DZERO - do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1 call this%lak_calculate_conn_conductance(ilak, i, stage, stage, c) conductance = conductance + c end do @@ -2266,7 +2282,7 @@ subroutine lak_calculate_cond_head(this, iconn, stage, head, vv) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: iconn real(DP), intent(in) :: stage real(DP), intent(in) :: head @@ -2294,7 +2310,6 @@ subroutine lak_calculate_cond_head(this, iconn, stage, head, vv) return end subroutine lak_calculate_cond_head - subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) ! ****************************************************************************** ! lak_calculate_conn_conductance -- Calculate the conductance for a lake @@ -2305,7 +2320,7 @@ subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak integer(I4B), intent(in) :: iconn real(DP), intent(in) :: stage @@ -2331,17 +2346,17 @@ subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) ! use full saturated conductance if top and bottom of the lake connection ! are equal if (this%ictype(iconn) == 0) then - if (ABS(topl-botl) < DPREC) then + if (ABS(topl - botl) < DPREC) then sat = DONE end if - ! horizontal connection - ! use full saturated conductance if the connected cell is not convertible + ! horizontal connection + ! use full saturated conductance if the connected cell is not convertible else if (this%ictype(iconn) == 1) then node = this%cellid(iconn) if (this%icelltype(node) == 0) then sat = DONE end if - ! embedded connection + ! embedded connection else if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then node = this%cellid(iconn) if (this%icelltype(node) == 0) then @@ -2358,7 +2373,6 @@ subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) return end subroutine lak_calculate_conn_conductance - subroutine lak_calculate_exchange(this, ilak, stage, totflow) ! ****************************************************************************** ! lak_calculate_exchange -- Calculate the total groundwater-lake flow at a @@ -2368,19 +2382,19 @@ subroutine lak_calculate_exchange(this, ilak, stage, totflow) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: totflow ! -- local integer(I4B) :: j integer(I4B) :: igwfnode - real(DP) :: flow + real(DP) :: flow real(DP) :: hgwf ! -- formats ! ------------------------------------------------------------------------------ totflow = DZERO - do j = this%idxlakeconn(ilak), this%idxlakeconn(ilak+1)-1 + do j = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1 igwfnode = this%cellid(j) hgwf = this%xnew(igwfnode) call this%lak_calculate_conn_exchange(ilak, j, stage, hgwf, flow) @@ -2391,7 +2405,6 @@ subroutine lak_calculate_exchange(this, ilak, stage, totflow) return end subroutine lak_calculate_exchange - subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, & gwfhcof, gwfrhs) ! ****************************************************************************** @@ -2402,7 +2415,7 @@ subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak integer(I4B), intent(in) :: iconn real(DP), intent(in) :: stage @@ -2423,7 +2436,7 @@ subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, & call this%lak_calculate_conn_conductance(ilak, iconn, stage, head, cond) botl = this%belev(iconn) ! - ! -- Set ss to stage or botl + ! -- Set ss to stage or botl if (stage >= botl) then ss = stage else @@ -2447,7 +2460,7 @@ subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, & else gwfhcof0 = DZERO gwfrhs0 = flow - endif + end if ! ! Add density contributions, if active if (this%idense /= 0) then @@ -2463,7 +2476,6 @@ subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, & return end subroutine lak_calculate_conn_exchange - subroutine lak_estimate_conn_exchange(this, iflag, ilak, iconn, idry, stage, & head, flow, source, gwfhcof, gwfrhs) ! ****************************************************************************** @@ -2474,7 +2486,7 @@ subroutine lak_estimate_conn_exchange(this, iflag, ilak, iconn, idry, stage, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: iflag integer(I4B), intent(in) :: ilak integer(I4B), intent(in) :: iconn @@ -2524,7 +2536,7 @@ subroutine lak_calculate_storagechange(this, ilak, stage, stage0, delt, dvr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(in) :: stage0 @@ -2554,7 +2566,7 @@ subroutine lak_calculate_rainfall(this, ilak, stage, ra) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: ra @@ -2584,7 +2596,7 @@ subroutine lak_calculate_runoff(this, ilak, ro) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: ro ! -- formats @@ -2604,7 +2616,7 @@ subroutine lak_calculate_inflow(this, ilak, qin) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: qin ! -- formats @@ -2624,7 +2636,7 @@ subroutine lak_calculate_external(this, ilak, ex) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: ex ! -- local @@ -2651,7 +2663,7 @@ subroutine lak_calculate_withdrawal(this, ilak, avail, wr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: avail real(DP), intent(inout) :: wr @@ -2682,7 +2694,7 @@ subroutine lak_calculate_evaporation(this, ilak, stage, avail, ev) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: avail @@ -2713,7 +2725,7 @@ subroutine lak_calculate_outlet_inflow(this, ilak, outinf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outinf ! -- local @@ -2743,7 +2755,7 @@ subroutine lak_calculate_outlet_outflow(this, ilak, stage, avail, outoutf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: stage real(DP), intent(inout) :: avail @@ -2769,28 +2781,28 @@ subroutine lak_calculate_outlet_outflow(this, ilak, stage, avail, outoutf) g = DGRAVITY * this%convlength * this%convtime * this%convtime select case (this%iouttype(n)) ! specified rate - case(0) - rate = this%outrate(n) - if (-rate > avail) then - rate = -avail - end if + case (0) + rate = this%outrate(n) + if (-rate > avail) then + rate = -avail + end if ! manning - case (1) - if (d > DZERO) then - c = (this%convlength**DONETHIRD) * this%convtime - gsm = DZERO - if (this%outrough(n) > DZERO) then - gsm = DONE / this%outrough(n) - end if - rate = -c * gsm * this%outwidth(n) * ( d**DFIVETHIRDS ) * & - sqrt(this%outslope(n)) + case (1) + if (d > DZERO) then + c = (this%convlength**DONETHIRD) * this%convtime + gsm = DZERO + if (this%outrough(n) > DZERO) then + gsm = DONE / this%outrough(n) end if + rate = -c * gsm * this%outwidth(n) * (d**DFIVETHIRDS) * & + sqrt(this%outslope(n)) + end if ! weir - case (2) - if (d > DZERO) then - rate = -DTWOTHIRDS * DCD * this%outwidth(n) * d * & - sqrt(DTWO * g * d) - end if + case (2) + if (d > DZERO) then + rate = -DTWOTHIRDS * DCD * this%outwidth(n) * d * & + sqrt(DTWO * g * d) + end if end select this%simoutrate(n) = rate avail = avail + rate @@ -2810,7 +2822,7 @@ subroutine lak_get_internal_inlet(this, ilak, outinf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outinf ! -- local @@ -2839,7 +2851,7 @@ subroutine lak_get_internal_outlet(this, ilak, outoutf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outoutf ! -- local @@ -2867,7 +2879,7 @@ subroutine lak_get_external_outlet(this, ilak, outoutf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outoutf ! -- local @@ -2895,7 +2907,7 @@ subroutine lak_get_external_mover(this, ilak, outoutf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outoutf ! -- local @@ -2924,7 +2936,7 @@ subroutine lak_get_internal_mover(this, ilak, outoutf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outoutf ! -- local @@ -2953,7 +2965,7 @@ subroutine lak_get_outlet_tomover(this, ilak, outoutf) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(inout) :: outoutf ! -- local @@ -2981,7 +2993,7 @@ subroutine lak_vol2stage(this, ilak, vol, stage) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: vol real(DP), intent(inout) :: stage @@ -3004,11 +3016,11 @@ subroutine lak_vol2stage(this, ilak, vol, stage) ! -- zero volume if (vol <= v0) then stage = s0 - ! -- linear relation between stage and volume above top of lake + ! -- linear relation between stage and volume above top of lake else if (vol >= v1) then call this%lak_calculate_sarea(ilak, s1, sa) stage = s1 + (vol - v1) / sa - ! -- use combination of secant and bisection + ! -- use combination of secant and bisection else en0 = s0 en1 = s1 @@ -3033,7 +3045,7 @@ subroutine lak_vol2stage(this, ilak, vol, stage) ! -- use bisection if secant method stagnates or if ! ds exceeds previous ds - bisection would occur ! after conditions exceeded in 13 iterations - if (ds*ds0 < DPREC .or. ABS(ds) > ABS(ds0)) ibs = ibs + 1 + if (ds * ds0 < DPREC .or. ABS(ds) > ABS(ds0)) ibs = ibs + 1 if (ibs > 12) then ds = DHALF * (s1 - s0) ibs = 0 @@ -3052,7 +3064,7 @@ subroutine lak_vol2stage(this, ilak, vol, stage) end do secantbisection stage = sm if (ABS(ds) >= DEM6) then - write(this%iout, '(1x,a,1x,i5,4(1x,a,1x,g15.6))') & + write (this%iout, '(1x,a,1x,i5,4(1x,a,1x,g15.6))') & & 'LAK_VOL2STAGE failed for lake', ilak, 'volume error =', fm, & & 'finding stage (', stage, ') for volume =', vol, & & 'final change in stage =', ds @@ -3063,7 +3075,6 @@ subroutine lak_vol2stage(this, ilak, vol, stage) return end subroutine lak_vol2stage - function lak_check_valid(this, itemno) result(ierr) ! ****************************************************************************** ! lak_check_valid -- Determine if a valid lake or outlet number has been @@ -3073,7 +3084,7 @@ function lak_check_valid(this, itemno) result(ierr) ! -- return integer(I4B) :: ierr ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: itemno ! -- local integer(I4B) :: ival @@ -3083,16 +3094,16 @@ function lak_check_valid(this, itemno) result(ierr) ival = abs(itemno) if (itemno > 0) then if (ival < 1 .or. ival > this%nlakes) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,a)') & - 'LAKENO', itemno, 'must be greater than 0 and less than or equal to', & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') & + 'LAKENO', itemno, 'must be greater than 0 and less than or equal to', & this%nlakes, '.' call store_error(errmsg) ierr = 1 end if else if (ival < 1 .or. ival > this%noutlets) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,a)') & - 'IOUTLET', itemno, 'must be greater than 0 and less than or equal to', & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') & + 'IOUTLET', itemno, 'must be greater than 0 and less than or equal to', & this%noutlets, '.' call store_error(errmsg) ierr = 1 @@ -3111,7 +3122,7 @@ subroutine lak_set_stressperiod(this, itemno) use TimeSeriesManagerModule, only: read_value_or_time_series_adv use SimModule, only: store_error ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: itemno ! -- local character(len=LINELENGTH) :: text @@ -3127,202 +3138,202 @@ subroutine lak_set_stressperiod(this, itemno) ! -- read line call this%parser%GetStringCaps(keyword) select case (keyword) - case ('STATUS') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetStringCaps(text) - this%status(itemno) = text(1:8) - if (text == 'CONSTANT') then - this%iboundpak(itemno) = -1 - else if (text == 'INACTIVE') then - this%iboundpak(itemno) = 0 - else if (text == 'ACTIVE') then - this%iboundpak(itemno) = 1 - else - write(errmsg,'(a,a)') & - 'Unknown ' // trim(this%text)//' lak status keyword: ', text // '.' - call store_error(errmsg) - end if - case ('STAGE') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For STAGE - bndElem => this%stage(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'STAGE') - case ('RAINFALL') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For RAINFALL - bndElem => this%rainfall(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RAINFALL') - if (this%rainfall(itemno) < DZERO) then - write(errmsg, '(a,i0,a,G0,a)') & - 'Lake ', itemno, ' was assigned a rainfall value of ', & - this%rainfall(itemno), '. Rainfall must be positive.' - call store_error(errmsg) - end if - case ('EVAPORATION') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For EVAPORATION - bndElem => this%evaporation(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'EVAPORATION') - if (this%evaporation(itemno) < DZERO) then - write(errmsg, '(a,i0,a,G0,a)') & - 'Lake ', itemno, ' was assigned an evaporation value of ', & - this%evaporation(itemno), '. Evaporation must be positive.' - call store_error(errmsg) - end if - case ('RUNOFF') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For RUNOFF - bndElem => this%runoff(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RUNOFF') - if (this%runoff(itemno) < DZERO) then - write(errmsg, '(a,i0,a,G0,a)') & - 'Lake ', itemno, ' was assigned a runoff value of ', & - this%runoff(itemno), '. Runoff must be positive.' - call store_error(errmsg) - end if - case ('INFLOW') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For specified INFLOW - bndElem => this%inflow(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'INFLOW') - if (this%inflow(itemno) < DZERO) then - write(errmsg, '(a,i0,a,G0,a)') & - 'Lake ', itemno, ' was assigned an inflow value of ', & - this%inflow(itemno), '. Inflow must be positive.' - call store_error(errmsg) - end if - case ('WITHDRAWAL') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For specified WITHDRAWAL - bndElem => this%withdrawal(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'WITHDRAWL') - if (this%withdrawal(itemno) < DZERO) then - write(errmsg, '(a,i0,a,G0,a)') & - 'Lake ', itemno, ' was assigned a withdrawal value of ', & - this%withdrawal(itemno), '. Withdrawal must be positive.' - call store_error(errmsg) - end if - case ('RATE') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For specified OUTLET RATE - bndElem => this%outrate(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RATE') - case ('INVERT') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For OUTLET INVERT - bndElem => this%outinvert(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'INVERT') - case ('WIDTH') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For OUTLET WIDTH - bndElem => this%outwidth(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'WIDTH') - case ('ROUGH') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 ! For OUTLET ROUGHNESS - bndElem => this%outrough(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'ROUGH') - case ('SLOPE') - ierr = this%lak_check_valid(-itemno) - if (ierr /= 0) then - goto 999 - end if + case ('STATUS') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetStringCaps(text) + this%status(itemno) = text(1:8) + if (text == 'CONSTANT') then + this%iboundpak(itemno) = -1 + else if (text == 'INACTIVE') then + this%iboundpak(itemno) = 0 + else if (text == 'ACTIVE') then + this%iboundpak(itemno) = 1 + else + write (errmsg, '(a,a)') & + 'Unknown '//trim(this%text)//' lak status keyword: ', text//'.' + call store_error(errmsg) + end if + case ('STAGE') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For STAGE + bndElem => this%stage(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'STAGE') + case ('RAINFALL') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For RAINFALL + bndElem => this%rainfall(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RAINFALL') + if (this%rainfall(itemno) < DZERO) then + write (errmsg, '(a,i0,a,G0,a)') & + 'Lake ', itemno, ' was assigned a rainfall value of ', & + this%rainfall(itemno), '. Rainfall must be positive.' + call store_error(errmsg) + end if + case ('EVAPORATION') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For EVAPORATION + bndElem => this%evaporation(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EVAPORATION') + if (this%evaporation(itemno) < DZERO) then + write (errmsg, '(a,i0,a,G0,a)') & + 'Lake ', itemno, ' was assigned an evaporation value of ', & + this%evaporation(itemno), '. Evaporation must be positive.' + call store_error(errmsg) + end if + case ('RUNOFF') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For RUNOFF + bndElem => this%runoff(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RUNOFF') + if (this%runoff(itemno) < DZERO) then + write (errmsg, '(a,i0,a,G0,a)') & + 'Lake ', itemno, ' was assigned a runoff value of ', & + this%runoff(itemno), '. Runoff must be positive.' + call store_error(errmsg) + end if + case ('INFLOW') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For specified INFLOW + bndElem => this%inflow(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'INFLOW') + if (this%inflow(itemno) < DZERO) then + write (errmsg, '(a,i0,a,G0,a)') & + 'Lake ', itemno, ' was assigned an inflow value of ', & + this%inflow(itemno), '. Inflow must be positive.' + call store_error(errmsg) + end if + case ('WITHDRAWAL') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For specified WITHDRAWAL + bndElem => this%withdrawal(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'WITHDRAWL') + if (this%withdrawal(itemno) < DZERO) then + write (errmsg, '(a,i0,a,G0,a)') & + 'Lake ', itemno, ' was assigned a withdrawal value of ', & + this%withdrawal(itemno), '. Withdrawal must be positive.' + call store_error(errmsg) + end if + case ('RATE') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For specified OUTLET RATE + bndElem => this%outrate(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RATE') + case ('INVERT') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For OUTLET INVERT + bndElem => this%outinvert(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'INVERT') + case ('WIDTH') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For OUTLET WIDTH + bndElem => this%outwidth(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'WIDTH') + case ('ROUGH') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For OUTLET ROUGHNESS + bndElem => this%outrough(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'ROUGH') + case ('SLOPE') + ierr = this%lak_check_valid(-itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For OUTLET SLOPE + bndElem => this%outslope(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'SLOPE') + case ('AUXILIARY') + ierr = this%lak_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetStringCaps(caux) + do jj = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle call this%parser%GetString(text) - jj = 1 ! For OUTLET SLOPE - bndElem => this%outslope(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'SLOPE') - case ('AUXILIARY') - ierr = this%lak_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetStringCaps(caux) - do jj = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle - call this%parser%GetString(text) - ii = itemno - bndElem => this%lauxvar(jj, ii) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, & - this%packName, 'AUX', this%tsManager, & - this%iprpak, this%auxname(jj)) - exit - end do - case default - write(errmsg,'(2a)') & - 'Unknown ' // trim(this%text) // ' lak data keyword: ', & - trim(keyword) // '.' + ii = itemno + bndElem => this%lauxvar(jj, ii) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & + this%auxname(jj)) + exit + end do + case default + write (errmsg, '(2a)') & + 'Unknown '//trim(this%text)//' lak data keyword: ', & + trim(keyword)//'.' end select ! ! -- return 999 return end subroutine lak_set_stressperiod - subroutine lak_set_attribute_error(this, ilak, keyword, msg) ! ****************************************************************************** ! lak_set_attribute_error -- Issue a parameter error for lakweslls(ilak) @@ -3334,18 +3345,18 @@ subroutine lak_set_attribute_error(this, ilak, keyword, msg) ! ------------------------------------------------------------------------------ use SimModule, only: store_error ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: ilak - character (len=*), intent(in) :: keyword - character (len=*), intent(in) :: msg + character(len=*), intent(in) :: keyword + character(len=*), intent(in) :: msg ! -- local ! -- formats ! ------------------------------------------------------------------------------ if (len(msg) == 0) then - write(errmsg,'(a,1x,a,1x,i6,1x,a)') & + write (errmsg, '(a,1x,a,1x,i6,1x,a)') & keyword, ' for LAKE', ilak, 'has already been set.' else - write(errmsg,'(a,1x,a,1x,i6,1x,a)') keyword, ' for LAKE', ilak, msg + write (errmsg, '(a,1x,a,1x,i6,1x,a)') keyword, ' for LAKE', ilak, msg end if call store_error(errmsg) ! -- return @@ -3366,144 +3377,145 @@ subroutine lak_options(this, option, found) use SimModule, only: store_error use InputOutputModule, only: urword, getunit, openfile ! -- dummy - class(LakType), intent(inout) :: this + class(LakType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local character(len=MAXCHARLEN) :: fname, keyword real(DP) :: r ! -- formats - character(len=*),parameter :: fmtlengthconv = & - "(4x, 'LENGTH CONVERSION VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmttimeconv = & - "(4x, 'TIME CONVERSION VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtoutdmax = & - "(4x, 'MAXIMUM OUTLET WATER DEPTH (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtlakeopt = & - "(4x, 'LAKE ', a, ' VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtlakbin = & - "(4x, 'LAK ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I0)" + character(len=*), parameter :: fmtlengthconv = & + &"(4x, 'LENGTH CONVERSION VALUE (',g15.7,') SPECIFIED.')" + character(len=*), parameter :: fmttimeconv = & + &"(4x, 'TIME CONVERSION VALUE (',g15.7,') SPECIFIED.')" + character(len=*), parameter :: fmtoutdmax = & + &"(4x, 'MAXIMUM OUTLET WATER DEPTH (',g15.7,') SPECIFIED.')" + character(len=*), parameter :: fmtlakeopt = & + &"(4x, 'LAKE ', a, ' VALUE (',g15.7,') SPECIFIED.')" + character(len=*), parameter :: fmtlakbin = & + "(4x, 'LAK ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & + &a, /4x, 'OPENED ON UNIT: ', I0)" ! ------------------------------------------------------------------------------ ! select case (option) - case ('PRINT_STAGE') - this%iprhed = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' STAGES WILL BE PRINTED TO LISTING FILE.' - found = .true. - case('STAGE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%istageout = getunit() - call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtlakbin) 'STAGE', fname, this%istageout - found = .true. - else - call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtlakbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtlakbin) 'BUDGET CSV', fname, this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtlakbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv - found = .true. - else - call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT') - end if - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + case ('PRINT_STAGE') + this%iprhed = 1 + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' STAGES WILL BE PRINTED TO LISTING FILE.' + found = .true. + case ('STAGE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%istageout = getunit() + call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtlakbin) 'STAGE', fname, this%istageout found = .true. - case('LENGTH_CONVERSION') - this%convlength = this%parser%GetDouble() - write(this%iout, fmtlengthconv) this%convlength - found = .true. - case('TIME_CONVERSION') - this%convtime = this%parser%GetDouble() - write(this%iout, fmttimeconv) this%convtime + else + call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtlakbin) 'BUDGET', fname, this%ibudgetout found = .true. - case('SURFDEP') - r = this%parser%GetDouble() - if (r < DZERO) then - r = DZERO - end if - this%surfdep = r - write(this%iout, fmtlakeopt) 'SURFDEP', this%surfdep + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtlakbin) 'BUDGET CSV', fname, this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case ('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtlakbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv found = .true. + else + call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE '// & + 'FOLLOWED BY FILEOUT') + end if + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case ('LENGTH_CONVERSION') + this%convlength = this%parser%GetDouble() + write (this%iout, fmtlengthconv) this%convlength + found = .true. + case ('TIME_CONVERSION') + this%convtime = this%parser%GetDouble() + write (this%iout, fmttimeconv) this%convtime + found = .true. + case ('SURFDEP') + r = this%parser%GetDouble() + if (r < DZERO) then + r = DZERO + end if + this%surfdep = r + write (this%iout, fmtlakeopt) 'SURFDEP', this%surfdep + found = .true. ! ! -- right now these are options that are only available in the ! development version and are not included in the documentation. ! These options are only available when IDEVELOPMODE in ! constants module is set to 1 - case('DEV_GROUNDWATER_HEAD_CONDUCTANCE') - call this%parser%DevOpt() - this%igwhcopt = 1 - write(this%iout, '(4x,a)') & - & 'CONDUCTANCE FOR HORIZONTAL CONNECTIONS WILL BE CALCULATED ' // & - & 'USING THE GROUNDWATER HEAD' - found = .true. - case('DEV_MAXIMUM_OUTLET_DEPTH') - call this%parser%DevOpt() - this%outdmax = this%parser%GetDouble() - write(this%iout, fmtoutdmax) this%outdmax - found = .true. - case('DEV_NO_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE STAGES ' // & - & 'WILL NOT BE MADE' - found = .true. - case('DEV_NO_FINAL_RESIDUAL_CHECK') - call this%parser%DevOpt() - this%iconvresidchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE RESIDUALS ' // & - & 'WILL NOT BE MADE' - found = .true. - case('DEV_MAXIMUM_PERCENT_DIFFERENCE') - call this%parser%DevOpt() - r = this%parser%GetDouble() - if (r < DZERO) then - r = DEM1 - end if - this%pdmax = r - write(this%iout, fmtlakeopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax - found = .true. - case default - ! - ! -- No options found - found = .false. + case ('DEV_GROUNDWATER_HEAD_CONDUCTANCE') + call this%parser%DevOpt() + this%igwhcopt = 1 + write (this%iout, '(4x,a)') & + 'CONDUCTANCE FOR HORIZONTAL CONNECTIONS WILL BE CALCULATED & + &USING THE GROUNDWATER HEAD' + found = .true. + case ('DEV_MAXIMUM_OUTLET_DEPTH') + call this%parser%DevOpt() + this%outdmax = this%parser%GetDouble() + write (this%iout, fmtoutdmax) this%outdmax + found = .true. + case ('DEV_NO_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write (this%iout, '(4x,a)') & + 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE STAGES & + &WILL NOT BE MADE' + found = .true. + case ('DEV_NO_FINAL_RESIDUAL_CHECK') + call this%parser%DevOpt() + this%iconvresidchk = 0 + write (this%iout, '(4x,a)') & + 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE RESIDUALS & + &WILL NOT BE MADE' + found = .true. + case ('DEV_MAXIMUM_PERCENT_DIFFERENCE') + call this%parser%DevOpt() + r = this%parser%GetDouble() + if (r < DZERO) then + r = DEM1 + end if + this%pdmax = r + write (this%iout, fmtlakeopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax + found = .true. + case default + ! + ! -- No options found + found = .false. end select ! ! -- return @@ -3511,19 +3523,19 @@ subroutine lak_options(this, option, found) end subroutine lak_options subroutine lak_ar(this) - ! ****************************************************************************** - ! lak_ar -- Allocate and Read - ! Subroutine: (1) create new-style package - ! (2) point bndobj to the new package - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(LakType),intent(inout) :: this - ! -- local - ! -- format - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! lak_ar -- Allocate and Read + ! Subroutine: (1) create new-style package + ! (2) point bndobj to the new package + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(LakType), intent(inout) :: this + ! -- local + ! -- format + ! ------------------------------------------------------------------------------ ! call this%obs%obs_ar() ! @@ -3535,15 +3547,14 @@ subroutine lak_ar(this) ! ! -- setup pakmvrobj if (this%imover /= 0) then - allocate(this%pakmvrobj) + allocate (this%pakmvrobj) call this%pakmvrobj%ar(this%noutlets, this%nlakes, this%memoryPath) - endif + end if ! ! -- return return end subroutine lak_ar - subroutine lak_rp(this) ! ****************************************************************************** ! lak_rp -- Read and Prepare @@ -3557,7 +3568,7 @@ subroutine lak_rp(this) use TdisModule, only: kper, nper use SimModule, only: store_error, count_errors ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: line @@ -3570,10 +3581,10 @@ subroutine lak_rp(this) integer(I4B) :: itemno integer(I4B) :: j ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" ! ------------------------------------------------------------------------------ ! ! -- set nbound to maxbound @@ -3581,7 +3592,7 @@ subroutine lak_rp(this) ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- get stress period data if (this%ionper < kper) then @@ -3589,7 +3600,7 @@ subroutine lak_rp(this) ! -- get period block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -3602,23 +3613,23 @@ subroutine lak_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - endif + end if end if ! ! -- Read data if ionper == kper - if(this%ionper == kper) then + if (this%ionper == kper) then ! ! -- setup table for period data if (this%iprpak /= 0) then ! ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') DATA FOR PERIOD' + write (title, '(a,1x,i6)') trim(adjustl(title)), kper call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(1, 4, this%iout, finalize=.FALSE.) text = 'NUMBER' @@ -3626,7 +3637,7 @@ subroutine lak_rp(this) text = 'KEYWORD' call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) do n = 1, 2 - write(text, '(a,1x,i6)') 'VALUE', n + write (text, '(a,1x,i6)') 'VALUE', n call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) end do end if @@ -3653,11 +3664,11 @@ subroutine lak_rp(this) if (this%iprpak /= 0) then call this%inputtab%finalize_table() end if - ! - ! -- using stress period data from the previous stress period + ! + ! -- using stress period data from the previous stress period else - write(this%iout,fmtlsp) trim(this%filtyp) - endif + write (this%iout, fmtlsp) trim(this%filtyp) + end if ! ! -- write summary of lake stress period error messages if (count_errors() > 0) then @@ -3666,12 +3677,12 @@ subroutine lak_rp(this) ! ! -- fill bound array with lake stage, conductance, and bottom elevation do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 node = this%cellid(j) this%nodelist(j) = node - this%bound(1,j) = this%xnewpak(n) - this%bound(2,j) = this%satcond(j) - this%bound(3,j) = this%belev(j) + this%bound(1, j) = this%xnewpak(n) + this%bound(2, j) = this%satcond(j) + this%bound(3, j) = this%belev(j) end do end do ! @@ -3735,7 +3746,7 @@ subroutine lak_ad(this) end do else ! - ! -- copy xold back into xnew as this is a + ! -- copy xold back into xnew as this is a ! retry of this time step do n = 1, this%nlakes this%xnewpak(n) = this%xoldpak(n) @@ -3744,7 +3755,7 @@ subroutine lak_ad(this) this%xnewpak(n) = this%stage(n) end if this%seep0(n) = DZERO - end do + end do end if ! ! -- pakmvrobj ad @@ -3762,23 +3773,23 @@ subroutine lak_ad(this) end subroutine lak_ad subroutine lak_cf(this, reset_mover) - ! ****************************************************************************** - ! lak_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip if no lakes - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! lak_cf -- Formulate the HCOF and RHS terms + ! Subroutine: (1) skip if no lakes + ! (2) calculate hcof and rhs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ ! -- dummy class(LakType) :: this logical, intent(in), optional :: reset_mover ! -- local integer(I4B) :: j, n integer(I4B) :: igwfnode - real(DP) :: hlak, blak + real(DP) :: hlak, blak logical :: lrm - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ !! !! -- Calculate lak conductance and update package RHS and HCOF !call this%lak_cfupdate() @@ -3797,13 +3808,13 @@ subroutine lak_cf(this, reset_mover) ! -- pakmvrobj cf lrm = .true. if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then + if (this%imover == 1 .and. lrm) then call this%pakmvrobj%cf() end if ! ! -- find highest active cell do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 ! -- skip horizontal connections if (this%ictype(j) /= 0) then cycle @@ -3818,14 +3829,14 @@ subroutine lak_cf(this, reset_mover) end do ! ! -- reset ibound for cells where lake stage is above the bottom - ! of the lake in the cell or the lake is inactive - only applied to + ! of the lake in the cell or the lake is inactive - only applied to ! vertical connections do n = 1, this%nlakes ! hlak = this%xnewpak(n) ! ! -- Go through lake connections - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 ! ! -- assign gwf node number igwfnode = this%cellid(j) @@ -3865,12 +3876,12 @@ subroutine lak_cf(this, reset_mover) end subroutine lak_cf subroutine lak_fc(this, rhs, ia, idxglo, amatsln) - ! ************************************************************************** - ! lak_fc -- Copy rhs and hcof into solution rhs and amat - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- + ! ************************************************************************** + ! lak_fc -- Copy rhs and hcof into solution rhs and amat + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- ! -- dummy class(LakType) :: this real(DP), dimension(:), intent(inout) :: rhs @@ -3884,7 +3895,7 @@ subroutine lak_fc(this, rhs, ia, idxglo, amatsln) ! -------------------------------------------------------------------------- ! ! -- pakmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() end if ! @@ -3893,7 +3904,7 @@ subroutine lak_fc(this, rhs, ia, idxglo, amatsln) ! ! -- add terms to the gwf matrix do n = 1, this%nlakes - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 igwfnode = this%cellid(j) if (this%ibound(igwfnode) < 1) cycle ipossymd = idxglo(ia(igwfnode)) @@ -3941,7 +3952,7 @@ subroutine lak_fn(this, rhs, ia, idxglo, amatsln) hlak = this%xnewpak(n) call this%lak_calculate_available(n, hlak, avail, & ra, ro, qinf, ex, this%delh) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 igwfnode = this%cellid(j) ipos = ia(igwfnode) head = this%xnew(igwfnode) @@ -3950,7 +3961,8 @@ subroutine lak_fn(this, rhs, ia, idxglo, amatsln) ! -- estimate lake-aquifer exchange with perturbed groundwater head ! exchange is relative to the lake !avail = DEP20 - call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head+this%delh, q1, avail) + call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, & + head + this%delh, q1, avail) q1 = -q1 ! -- calculate unperturbed lake-aquifer exchange q = this%hcof(j) * head - this%rhs(j) @@ -4037,8 +4049,8 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) if (icnvgmod == 0) then icheck = 0 end if - ! - ! -- saving package convergence data + ! + ! -- saving package convergence data else ! ! -- header for package csv @@ -4053,8 +4065,8 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! ! -- setup table call table_cr(this%pakcsvtab, this%packName, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & finalize=.FALSE.) ! ! -- add columns to package csv @@ -4148,14 +4160,14 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) if (ABS(dhmax) > abs(dpak)) then ipak = locdhmax dpak = dhmax - write(cloc, "(a,'-',a)") & + write (cloc, "(a,'-',a)") & trim(this%packName), 'stage' cpak = trim(cloc) end if if (ABS(dgwfmax) > abs(dpak)) then ipak = locdgwfmax dpak = dgwfmax - write(cloc, "(a,'-',a)") & + write (cloc, "(a,'-',a)") & trim(this%packName), 'gwf' cpak = trim(cloc) end if @@ -4163,8 +4175,8 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) if (ABS(dqoutmax) > abs(dpak)) then ipak = locdqoutmax dpak = dqoutmax - write(cloc, "(a,'-',a)") & - trim(this%packName), 'outlet' + write (cloc, "(a,'-',a)") & + trim(this%packName), 'outlet' cpak = trim(cloc) end if end if @@ -4282,7 +4294,7 @@ subroutine lak_cq(this, x, flowja, iadv) rrate = DZERO end if call this%lak_accumulate_chterm(n, rrate, chratin, chratout) - endif + end if end if end do ! @@ -4290,7 +4302,7 @@ subroutine lak_cq(this, x, flowja, iadv) do n = 1, this%nlakes if (this%iboundpak(n) == 0) cycle rrate = DZERO - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 rrate = this%simvals(j) this%qleak(j) = -rrate call this%lak_accumulate_chterm(n, rrate, chratin, chratout) @@ -4313,10 +4325,10 @@ subroutine lak_ot_package_flows(this, icbcfl, ibudfl) ! ! -- write the flows from the budobj ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & pertim, totim, this%iout) @@ -4326,7 +4338,7 @@ subroutine lak_ot_package_flows(this, icbcfl, ibudfl) if (ibudfl /= 0 .and. this%iprflow /= 0) then call this%budobj%write_flowtable(this%dis, kstp, kper) end if - + end subroutine lak_ot_package_flows subroutine lak_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) @@ -4358,10 +4370,10 @@ subroutine lak_ot_dv(this, idvsave, idvprint) ! ! -- set unit number for binary dependent variable output ibinun = 0 - if(this%istageout /= 0) then + if (this%istageout /= 0) then ibinun = this%istageout end if - if(idvsave == 0) ibinun = 0 + if (idvsave == 0) ibinun = 0 ! ! -- write lake binary output if (ibinun > 0) then @@ -4375,7 +4387,7 @@ subroutine lak_ot_dv(this, idvsave, idvprint) end if this%dbuff(n) = v end do - call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & + call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & this%nlakes, 1, 1, ibinun) end if ! @@ -4391,7 +4403,7 @@ subroutine lak_ot_dv(this, idvsave, idvprint) call this%lak_calculate_sarea(n, stage, sa) call this%lak_calculate_warea(n, stage, wa) call this%lak_calculate_vol(n, stage, v) - if(this%inamedbound==1) then + if (this%inamedbound == 1) then call this%stagetab%add_term(this%lakename(n)) end if call this%stagetab%add_term(n) @@ -4401,24 +4413,24 @@ subroutine lak_ot_dv(this, idvsave, idvprint) call this%stagetab%add_term(v) end do end if - + end subroutine lak_ot_dv - + subroutine lak_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- module use TdisModule, only: totim ! -- dummy - class(LakType) :: this !< LakType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + class(LakType) :: this !< LakType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written ! call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) ! return end subroutine lak_ot_bdsummary - + subroutine lak_da(this) ! ************************************************************************** ! lak_da -- Deallocate objects @@ -4435,11 +4447,11 @@ subroutine lak_da(this) ! -------------------------------------------------------------------------- ! ! -- arrays - deallocate(this%lakename) - deallocate(this%status) - deallocate(this%clakbudget) + deallocate (this%lakename) + deallocate (this%status) + deallocate (this%clakbudget) call mem_deallocate(this%dbuff) - deallocate(this%cauxcbc) + deallocate (this%cauxcbc) call mem_deallocate(this%qauxcbc) call mem_deallocate(this%qleak) call mem_deallocate(this%qsto) @@ -4456,8 +4468,8 @@ subroutine lak_da(this) ! ! -- budobj call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) + deallocate (this%budobj) + nullify (this%budobj) ! ! -- outlets if (this%noutlets > 0) then @@ -4470,20 +4482,20 @@ subroutine lak_da(this) call mem_deallocate(this%outrough) call mem_deallocate(this%outslope) call mem_deallocate(this%simoutrate) - endif + end if ! ! -- stage table if (this%iprhed > 0) then call this%stagetab%table_da() - deallocate(this%stagetab) - nullify(this%stagetab) + deallocate (this%stagetab) + nullify (this%stagetab) end if ! ! -- package csv table if (this%ipakcsv > 0) then call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) + deallocate (this%pakcsvtab) + nullify (this%pakcsvtab) end if ! ! -- scalars @@ -4578,7 +4590,7 @@ subroutine lak_da(this) call mem_deallocate(this%simlakgw) ! ! -- pointers to gwf variables - nullify(this%gwfiss) + nullify (this%gwfiss) ! ! -- Parent object call this%BndType%bnd_da() @@ -4587,7 +4599,6 @@ subroutine lak_da(this) return end subroutine lak_da - subroutine define_listlabel(this) ! ****************************************************************************** ! define_listlabel -- Define the list heading that is written to iout when @@ -4600,27 +4611,26 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return end subroutine define_listlabel - subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package @@ -4660,35 +4670,34 @@ end subroutine lak_set_pointers ! ! -- Procedures related to observations (type-bound) logical function lak_obs_supported(this) - ! ****************************************************************************** - ! lak_obs_supported - ! -- Return true because LAK package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! lak_obs_supported + ! -- Return true because LAK package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ class(LakType) :: this lak_obs_supported = .true. return end function lak_obs_supported - subroutine lak_df_obs(this) - ! ****************************************************************************** - ! lak_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by LAK package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! lak_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by LAK package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ ! -- dummy class(LakType) :: this ! -- local integer(I4B) :: indx - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ ! ! -- Store obs type and assign procedure pointer ! for stage observation type. @@ -4788,7 +4797,6 @@ subroutine lak_df_obs(this) return end subroutine lak_df_obs - subroutine lak_bd_obs(this) ! ************************************************************************** ! lak_bd_obs @@ -4822,123 +4830,123 @@ subroutine lak_bd_obs(this) v = DNODATA jj = obsrv%indxbnds(j) select case (obsrv%ObsTypeId) - case ('STAGE') - if (this%iboundpak(jj) /= 0) then - v = this%xnewpak(jj) - end if - case ('EXT-INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_inflow(jj, v) - end if - case ('OUTLET-INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_outlet_inflow(jj, v) - end if - case ('INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_inflow(jj, v) - call this%lak_calculate_outlet_inflow(jj, v2) - v = v + v2 - end if - case ('FROM-MVR') - if (this%iboundpak(jj) /= 0) then - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(jj) - end if - end if - case ('RAINFALL') - if (this%iboundpak(jj) /= 0) then - v = this%precip(jj) - end if - case ('RUNOFF') - if (this%iboundpak(jj) /= 0) then - v = this%runoff(jj) - end if - case ('LAK') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - igwfnode = this%cellid(jj) - hgwf = this%xnew(igwfnode) - if (this%hcof(jj) /= DZERO) then - v = -(this%hcof(jj) * (this%xnewpak(n) - hgwf)) - else - v = -this%rhs(jj) - end if - end if - case ('EVAPORATION') - if (this%iboundpak(jj) /= 0) then - v = this%evap(jj) + case ('STAGE') + if (this%iboundpak(jj) /= 0) then + v = this%xnewpak(jj) + end if + case ('EXT-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_inflow(jj, v) + end if + case ('OUTLET-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_outlet_inflow(jj, v) + end if + case ('INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_inflow(jj, v) + call this%lak_calculate_outlet_inflow(jj, v2) + v = v + v2 + end if + case ('FROM-MVR') + if (this%iboundpak(jj) /= 0) then + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(jj) end if - case ('WITHDRAWAL') - if (this%iboundpak(jj) /= 0) then - v = this%withr(jj) + end if + case ('RAINFALL') + if (this%iboundpak(jj) /= 0) then + v = this%precip(jj) + end if + case ('RUNOFF') + if (this%iboundpak(jj) /= 0) then + v = this%runoff(jj) + end if + case ('LAK') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + igwfnode = this%cellid(jj) + hgwf = this%xnew(igwfnode) + if (this%hcof(jj) /= DZERO) then + v = -(this%hcof(jj) * (this%xnewpak(n) - hgwf)) + else + v = -this%rhs(jj) end if - case ('EXT-OUTFLOW') - n = this%lakein(jj) - if (this%iboundpak(n) /= 0) then - if (this%lakeout(jj) == 0) then - v = this%simoutrate(jj) - if (v < DZERO) then - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qtomvr(jj) - end if + end if + case ('EVAPORATION') + if (this%iboundpak(jj) /= 0) then + v = this%evap(jj) + end if + case ('WITHDRAWAL') + if (this%iboundpak(jj) /= 0) then + v = this%withr(jj) + end if + case ('EXT-OUTFLOW') + n = this%lakein(jj) + if (this%iboundpak(n) /= 0) then + if (this%lakeout(jj) == 0) then + v = this%simoutrate(jj) + if (v < DZERO) then + if (this%imover == 1) then + v = v + this%pakmvrobj%get_qtomvr(jj) end if end if end if - case ('TO-MVR') - n = this%lakein(jj) - if (this%iboundpak(n) /= 0) then - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(jj) - if (v > DZERO) then - v = -v - end if + end if + case ('TO-MVR') + n = this%lakein(jj) + if (this%iboundpak(n) /= 0) then + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(jj) + if (v > DZERO) then + v = -v end if end if - case ('STORAGE') - if (this%iboundpak(jj) /= 0) then - v = this%qsto(jj) - end if - case ('CONSTANT') - if (this%iboundpak(jj) /= 0) then - v = this%chterm(jj) - end if - case ('OUTLET') - n = this%lakein(jj) - if (this%iboundpak(jj) /= 0) then - v = this%simoutrate(jj) - !if (this%imover == 1) then - ! v = v + this%pakmvrobj%get_qtomvr(jj) - !end if - end if - case ('VOLUME') - if (this%iboundpak(jj) /= 0) then - call this%lak_calculate_vol(jj, this%xnewpak(jj), v) - end if - case ('SURFACE-AREA') - if (this%iboundpak(jj) /= 0) then - hlak = this%xnewpak(jj) - call this%lak_calculate_sarea(jj, hlak, v) - end if - case ('WETTED-AREA') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - hlak = this%xnewpak(n) - igwfnode = this%cellid(jj) - hgwf = this%xnew(igwfnode) - call this%lak_calculate_conn_warea(n, jj, hlak, hgwf, v) - end if - case ('CONDUCTANCE') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - hlak = this%xnewpak(n) - igwfnode = this%cellid(jj) - hgwf = this%xnew(igwfnode) - call this%lak_calculate_conn_conductance(n, jj, hlak, hgwf, v) - end if - case default - errmsg = 'Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(errmsg) + end if + case ('STORAGE') + if (this%iboundpak(jj) /= 0) then + v = this%qsto(jj) + end if + case ('CONSTANT') + if (this%iboundpak(jj) /= 0) then + v = this%chterm(jj) + end if + case ('OUTLET') + n = this%lakein(jj) + if (this%iboundpak(jj) /= 0) then + v = this%simoutrate(jj) + !if (this%imover == 1) then + ! v = v + this%pakmvrobj%get_qtomvr(jj) + !end if + end if + case ('VOLUME') + if (this%iboundpak(jj) /= 0) then + call this%lak_calculate_vol(jj, this%xnewpak(jj), v) + end if + case ('SURFACE-AREA') + if (this%iboundpak(jj) /= 0) then + hlak = this%xnewpak(jj) + call this%lak_calculate_sarea(jj, hlak, v) + end if + case ('WETTED-AREA') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + hlak = this%xnewpak(n) + igwfnode = this%cellid(jj) + hgwf = this%xnew(igwfnode) + call this%lak_calculate_conn_warea(n, jj, hlak, hgwf, v) + end if + case ('CONDUCTANCE') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + hlak = this%xnewpak(n) + igwfnode = this%cellid(jj) + hgwf = this%xnew(igwfnode) + call this%lak_calculate_conn_conductance(n, jj, hlak, hgwf, v) + end if + case default + errmsg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId) + call store_error(errmsg) end select call this%obs%SaveOneSimval(obsrv, v) end do @@ -4953,7 +4961,6 @@ subroutine lak_bd_obs(this) return end subroutine lak_bd_obs - subroutine lak_rp_obs(this) use TdisModule, only: kper ! -- dummy @@ -4966,11 +4973,11 @@ subroutine lak_rp_obs(this) integer(I4B) :: jj character(len=LENBOUNDNAME) :: bname logical :: jfound - class(ObserveType), pointer :: obsrv => null() + class(ObserveType), pointer :: obsrv => null() ! -------------------------------------------------------------------------- ! -- formats -10 format('Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') +10 format('Boundary "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') ! ! -- process each package observation ! only done the first stress period since boundaries are fixed @@ -4988,20 +4995,20 @@ subroutine lak_rp_obs(this) ! Iterate through all lakes to identify and store ! corresponding index in bound array. jfound = .false. - if (obsrv%ObsTypeId=='LAK' .or. & - obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then + if (obsrv%ObsTypeId == 'LAK' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE' .or. & + obsrv%ObsTypeId == 'WETTED-AREA') then do j = 1, this%nlakes - do jj = this%idxlakeconn(j), this%idxlakeconn(j+1) - 1 + do jj = this%idxlakeconn(j), this%idxlakeconn(j + 1) - 1 if (this%boundname(jj) == bname) then jfound = .true. call obsrv%AddObsIndex(jj) end if end do end do - else if (obsrv%ObsTypeId=='EXT-OUTFLOW' .or. & - obsrv%ObsTypeId=='TO-MVR' .or. & - obsrv%ObsTypeId=='OUTLET') then + else if (obsrv%ObsTypeId == 'EXT-OUTFLOW' .or. & + obsrv%ObsTypeId == 'TO-MVR' .or. & + obsrv%ObsTypeId == 'OUTLET') then do j = 1, this%noutlets jj = this%lakein(j) if (this%lakename(jj) == bname) then @@ -5018,15 +5025,16 @@ subroutine lak_rp_obs(this) end do end if if (.not. jfound) then - write(errmsg,10)trim(bname), trim(obsrv%Name), trim(this%packName) + write (errmsg, 10) & + trim(bname), trim(obsrv%Name), trim(this%packName) call store_error(errmsg) end if end if else if (obsrv%indxbnds_count == 0) then - if (obsrv%ObsTypeId=='LAK' .or. & - obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then + if (obsrv%ObsTypeId == 'LAK' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE' .or. & + obsrv%ObsTypeId == 'WETTED-AREA') then nn2 = obsrv%NodeNumber2 j = this%idxlakeconn(nn1) + nn2 - 1 call obsrv%AddObsIndex(j) @@ -5036,55 +5044,55 @@ subroutine lak_rp_obs(this) else errmsg = 'Programming error in lak_rp_obs' call store_error(errmsg) - endif + end if end if ! ! -- catch non-cumulative observation assigned to observation defined ! by a boundname that is assigned to more than one element if (obsrv%ObsTypeId == 'STAGE') then if (obsrv%indxbnds_count > 1) then - write(errmsg, '(a,3(1x,a))') & - trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & + write (errmsg, '(a,3(1x,a))') & + trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & ' must be assigned to a lake with a unique boundname.' call store_error(errmsg) end if end if ! ! -- check that index values are valid - if (obsrv%ObsTypeId=='TO-MVR' .or. & - obsrv%ObsTypeId=='EXT-OUTFLOW' .or. & - obsrv%ObsTypeId=='OUTLET') then + if (obsrv%ObsTypeId == 'TO-MVR' .or. & + obsrv%ObsTypeId == 'EXT-OUTFLOW' .or. & + obsrv%ObsTypeId == 'OUTLET') then do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > this%noutlets) then - write(errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - ' outlet must be > 0 and <=', this%noutlets, & + write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + ' outlet must be > 0 and <=', this%noutlets, & '(specified value is ', nn1, ')' call store_error(errmsg) end if end do - else if (obsrv%ObsTypeId=='LAK' .or. & - obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then + else if (obsrv%ObsTypeId == 'LAK' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE' .or. & + obsrv%ObsTypeId == 'WETTED-AREA') then do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > this%maxbound) then - write(errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - 'lake connection number must be > 0 and <=', this%maxbound, & + write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + 'lake connection number must be > 0 and <=', this%maxbound, & '(specified value is ', nn1, ')' call store_error(errmsg) end if end do else do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > this%nlakes) then - write(errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - ' lake must be > 0 and <=', this%nlakes, & + write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + ' lake must be > 0 and <=', this%nlakes, & '(specified value is ', nn1, ')' call store_error(errmsg) end if @@ -5101,17 +5109,16 @@ subroutine lak_rp_obs(this) return end subroutine lak_rp_obs - ! ! -- Procedures related to observations (NOT type-bound) subroutine lak_process_obsID(obsrv, dis, inunitobs, iout) ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes ! the ID string of an observation definition for LAK package observations. ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1, nn2 integer(I4B) :: icol, istart, istop @@ -5129,15 +5136,15 @@ subroutine lak_process_obsID(obsrv, dis, inunitobs, iout) if (nn1 == NAMEDBOUNDFLAG) then obsrv%FeatureName = bndname else - if (obsrv%ObsTypeId=='LAK' .or. obsrv%ObsTypeId=='CONDUCTANCE' .or. & - obsrv%ObsTypeId=='WETTED-AREA') then + if (obsrv%ObsTypeId == 'LAK' .or. obsrv%ObsTypeId == 'CONDUCTANCE' .or. & + obsrv%ObsTypeId == 'WETTED-AREA') then call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) if (len_trim(bndName) < 1 .and. nn2 < 0) then - write(errmsg, '(a,1x,a,a,1x,a,1x,a)') & - 'For observation type', trim(adjustl(obsrv%ObsTypeId)), & - ', ID given as an integer and not as boundname,',& - 'but ID2 (iconn) is missing. Either change ID to valid', & - 'boundname or supply valid entry for ID2.' + write (errmsg, '(a,1x,a,a,1x,a,1x,a)') & + 'For observation type', trim(adjustl(obsrv%ObsTypeId)), & + ', ID given as an integer and not as boundname,', & + 'but ID2 (iconn) is missing. Either change ID to valid', & + 'boundname or supply valid entry for ID2.' call store_error(errmsg) end if if (nn2 == NAMEDBOUNDFLAG) then @@ -5149,8 +5156,8 @@ subroutine lak_process_obsID(obsrv, dis, inunitobs, iout) end if !! -- store connection number (NodeNumber2) !obsrv%NodeNumber2 = nn2 - endif - endif + end if + end if ! -- store lake number (NodeNumber) obsrv%NodeNumber = nn1 ! @@ -5196,95 +5203,94 @@ subroutine lak_accumulate_chterm(this, ilak, rrate, chratin, chratout) return end subroutine lak_accumulate_chterm - subroutine lak_cfupdate(this) - ! ****************************************************************************** - ! lak_cfupdate -- Update LAK satcond and package rhs and hcof - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(LakType), intent(inout) :: this - integer(I4B) :: j, n, node - real(DP) :: hlak, head, clak, blak - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no lak lakes - if(this%nbound.eq.0) return - ! - ! -- Calculate hcof and rhs for each lak entry - do n = 1, this%nlakes - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - node = this%cellid(j) - head = this%xnew(node) + ! ****************************************************************************** + ! lak_cfupdate -- Update LAK satcond and package rhs and hcof + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(LakType), intent(inout) :: this + integer(I4B) :: j, n, node + real(DP) :: hlak, head, clak, blak + ! ------------------------------------------------------------------------------ + ! + ! -- Return if no lak lakes + if (this%nbound .eq. 0) return + ! + ! -- Calculate hcof and rhs for each lak entry + do n = 1, this%nlakes + hlak = this%xnewpak(n) + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 + node = this%cellid(j) + head = this%xnew(node) - this%hcof(j) = DZERO - this%rhs(j) = DZERO - ! - ! -- set bound, hcof, and rhs components - call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) - this%simcond(j) = clak + this%hcof(j) = DZERO + this%rhs(j) = DZERO + ! + ! -- set bound, hcof, and rhs components + call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) + this%simcond(j) = clak - this%bound(2,j) = clak + this%bound(2, j) = clak - blak = this%bound(3,j) + blak = this%bound(3, j) - this%hcof(j) = -clak - ! - ! -- fill rhs - if (hlak < blak) then - this%rhs(j) = -clak * blak - else - this%rhs(j) = -clak * hlak - end if - end do + this%hcof(j) = -clak + ! + ! -- fill rhs + if (hlak < blak) then + this%rhs(j) = -clak * blak + else + this%rhs(j) = -clak * hlak + end if end do - ! - ! -- Return - return + end do + ! + ! -- Return + return end subroutine lak_cfupdate subroutine lak_bound_update(this) - ! ****************************************************************************** - ! lak_bound_update -- store the lake head and connection conductance in the - ! bound array - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(LakType), intent(inout) :: this - integer(I4B) :: j, n, node - real(DP) :: hlak, head, clak - ! ------------------------------------------------------------------------------ - ! - ! -- Return if no lak lakes - if (this%nbound == 0) return - ! - ! -- Calculate hcof and rhs for each lak entry - do n = 1, this%nlakes - hlak = this%xnewpak(n) - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 - node = this%cellid(j) - head = this%xnew(node) - call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) - this%bound(1, j) = hlak - this%bound(2, j) = clak - end do + ! ****************************************************************************** + ! lak_bound_update -- store the lake head and connection conductance in the + ! bound array + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(LakType), intent(inout) :: this + integer(I4B) :: j, n, node + real(DP) :: hlak, head, clak + ! ------------------------------------------------------------------------------ + ! + ! -- Return if no lak lakes + if (this%nbound == 0) return + ! + ! -- Calculate hcof and rhs for each lak entry + do n = 1, this%nlakes + hlak = this%xnewpak(n) + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 + node = this%cellid(j) + head = this%xnew(node) + call this%lak_calculate_conn_conductance(n, j, hlak, head, clak) + this%bound(1, j) = hlak + this%bound(2, j) = clak end do - ! - ! -- Return - return + end do + ! + ! -- Return + return end subroutine lak_bound_update subroutine lak_solve(this, update) - ! ************************************************************************** - ! lak_solve -- Solve for lake stage - ! ************************************************************************** - ! - ! SPECIFICATIONS: - ! -------------------------------------------------------------------------- - use TdisModule,only:delt + ! ************************************************************************** + ! lak_solve -- Solve for lake stage + ! ************************************************************************** + ! + ! SPECIFICATIONS: + ! -------------------------------------------------------------------------- + use TdisModule, only: delt logical, intent(in), optional :: update ! -- dummy class(LakType), intent(inout) :: this @@ -5431,17 +5437,17 @@ subroutine lak_solve(this, update) this%xoldpak(n) = this%xnewpak(n) end if hlak = this%xnewpak(n) - calcconnseep: do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + calcconnseep: do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 igwfnode = this%cellid(j) head = this%xnew(igwfnode) if (this%ncncvr(n) /= 2) then if (this%ibound(igwfnode) > 0) then - call this%lak_estimate_conn_exchange(i, n, j, idry, hlak, & - head, qlakgw, & - this%flwiter(n), & + call this%lak_estimate_conn_exchange(i, n, j, idry, hlak, & + head, qlakgw, & + this%flwiter(n), & gwfhcof, gwfrhs) - call this%lak_estimate_conn_exchange(i, n, j, idry1, hlak+delh,& - head, qlakgw1, & + call this%lak_estimate_conn_exchange(i, n, j, idry1, & + hlak + delh, head, qlakgw1, & this%flwiter1(n)) ! ! -- add to gwf matrix @@ -5477,7 +5483,7 @@ subroutine lak_solve(this, update) call this%lak_calculate_rainfall(n, hlak, ra) this%precip(n) = ra this%flwiter(n) = this%flwiter(n) + ra - call this%lak_calculate_rainfall(n, hlak+delh, ra) + call this%lak_calculate_rainfall(n, hlak + delh, ra) this%precip1(n) = ra this%flwiter1(n) = this%flwiter1(n) + ra ! @@ -5490,14 +5496,14 @@ subroutine lak_solve(this, update) ! -- limit evaporation to lake inflows and lake storage call this%lak_calculate_evaporation(n, hlak, this%flwiter(n), ev) this%evap(n) = ev - call this%lak_calculate_evaporation(n, hlak+delh, this%flwiter1(n), ev) + call this%lak_calculate_evaporation(n, hlak + delh, this%flwiter1(n), ev) this%evap1(n) = ev ! ! -- no outlet flow if evaporation consumes all water - call this%lak_calculate_outlet_outflow(n, hlak+delh, & - this%flwiter1(n), & + call this%lak_calculate_outlet_outflow(n, hlak + delh, & + this%flwiter1(n), & this%surfout1(n)) - call this%lak_calculate_outlet_outflow(n, hlak, this%flwiter(n), & + call this%lak_calculate_outlet_outflow(n, hlak, this%flwiter(n), & this%surfout(n)) ! ! -- update the surface inflow values @@ -5516,11 +5522,11 @@ subroutine lak_solve(this, update) this%flwin(n) = this%surfin(n) + ro + qinf + ex + v0 / delt ! ! -- compute new lake stage using Newton's method - resid = this%precip(n) + this%evap(n) + this%withr(n) + ro + & - qinf + ex + this%surfin(n) + & + resid = this%precip(n) + this%evap(n) + this%withr(n) + ro + & + qinf + ex + this%surfin(n) + & this%surfout(n) + this%seep(n) - resid1 = this%precip1(n) + this%evap1(n) + this%withr1(n) + ro + & - qinf + ex + this%surfin(n) + & + resid1 = this%precip1(n) + this%evap1(n) + this%withr1(n) + ro + & + qinf + ex + this%surfin(n) + & this%surfout1(n) + this%seep1(n) !call this%lak_calculate_residual(n, this%xnewpak(n), residb) @@ -5530,18 +5536,18 @@ subroutine lak_solve(this, update) if (this%gwfiss /= 1) then call this%lak_calculate_vol(n, hlak, v1) resid = resid + (v0 - v1) / delt - call this%lak_calculate_vol(n, hlak+delh, v1) + call this%lak_calculate_vol(n, hlak + delh, v1) resid1 = resid1 + (v0 - v1) / delt - !else - ! call this%lak_calculate_vol(n, hlak, v1) - ! resid = resid - v1 / delt - ! call this%lak_calculate_vol(n, hlak+delh, v1) - ! resid1 = resid1 - v1 / delt + !else + ! call this%lak_calculate_vol(n, hlak, v1) + ! resid = resid - v1 / delt + ! call this%lak_calculate_vol(n, hlak+delh, v1) + ! resid1 = resid1 - v1 / delt end if ! ! -- determine the derivative and the stage change - if (ABS(resid1-resid) > DZERO) then + if (ABS(resid1 - resid) > DZERO) then derv = (resid1 - resid) / delh dh = DZERO if (ABS(derv) > DPREC) then @@ -5557,14 +5563,14 @@ subroutine lak_solve(this, update) end if ! ! -- determine if the updated stage is outside the endpoints - ts = hlak-dh + ts = hlak - dh if (iter == 1) this%dh0(n) = dh adh = ABS(dh) adh0 = ABS(this%dh0(n)) if ((ts >= this%en2(n)) .or. (ts <= this%en1(n))) then ! -- use bisection if dh is increasing or updated stage is below the ! bottom of the lake - if ((adh > adh0) .or. (ts-this%lakebot(n)) < DPREC) then + if ((adh > adh0) .or. (ts - this%lakebot(n)) < DPREC) then ibflg = 1 ts = DHALF * (this%en1(n) + this%en2(n)) call this%lak_calculate_residual(n, ts, residb) @@ -5578,14 +5584,14 @@ subroutine lak_solve(this, update) end if ! ! -- check for slow convergence - if (this%seep(n)*this%seep0(n) < DPREC) then + if (this%seep(n) * this%seep0(n) < DPREC) then this%iseepc(n) = this%iseepc(n) + 1 else this%iseepc(n) = 0 end if ! -- determine of convergence is slow and oscillating idhp = 0 - if (dh*this%dh0(n) < DPREC) idhp = 1 + if (dh * this%dh0(n) < DPREC) idhp = 1 ! -- determine if stage change is increasing adh = ABS(dh) if (adh > adh0) idhp = 1 @@ -5607,10 +5613,10 @@ subroutine lak_solve(this, update) if (ibflg == 1) then ! -- change end points ! -- root is between r1 and residb - if (this%r1(n)*residb < DZERO) then + if (this%r1(n) * residb < DZERO) then this%en2(n) = ts this%r2(n) = residb - ! -- root is between fp and f2 + ! -- root is between fp and f2 else this%en1(n) = ts this%r1(n) = residb @@ -5653,7 +5659,6 @@ subroutine lak_solve(this, update) return end subroutine lak_solve - subroutine lak_calculate_available(this, n, hlak, avail, & ra, ro, qinf, ex, headp) ! ************************************************************************** @@ -5663,16 +5668,16 @@ subroutine lak_calculate_available(this, n, hlak, avail, & ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - use TdisModule,only:delt + use TdisModule, only: delt ! -- dummy class(LakType), intent(inout) :: this integer(I4B), intent(in) :: n real(DP), intent(in) :: hlak real(DP), intent(inout) :: avail - real(DP), intent(inout) :: ra - real(DP), intent(inout) :: ro - real(DP), intent(inout) :: qinf - real(DP), intent(inout) :: ex + real(DP), intent(inout) :: ra + real(DP), intent(inout) :: ro + real(DP), intent(inout) :: qinf + real(DP), intent(inout) :: ex real(DP), intent(in), optional :: headp ! -- local integer(I4B) :: j @@ -5695,11 +5700,12 @@ subroutine lak_calculate_available(this, n, hlak, avail, & avail = DZERO ! ! -- calculate the aquifer sources to the lake - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 igwfnode = this%cellid(j) if (this%ibound(igwfnode) == 0) cycle head = this%xnew(igwfnode) + hp - call this%lak_estimate_conn_exchange(1, n, j, idry, hlak, head, qlakgw, avail) + call this%lak_estimate_conn_exchange(1, n, j, idry, hlak, head, qlakgw, & + avail) end do ! ! -- add rainfall @@ -5726,7 +5732,6 @@ subroutine lak_calculate_available(this, n, hlak, avail, & return end subroutine lak_calculate_available - subroutine lak_calculate_residual(this, n, hlak, resid, headp) ! ************************************************************************** ! lak_calculate_residual -- Calculate the residual for a lake given a @@ -5735,7 +5740,7 @@ subroutine lak_calculate_residual(this, n, hlak, resid, headp) ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - use TdisModule,only:delt + use TdisModule, only: delt ! -- dummy class(LakType), intent(inout) :: this integer(I4B), intent(in) :: n @@ -5782,11 +5787,12 @@ subroutine lak_calculate_residual(this, n, hlak, resid, headp) ra, ro, qinf, ex, hp) ! ! -- calculate groundwater seepage - do j = this%idxlakeconn(n), this%idxlakeconn(n+1)-1 + do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1 igwfnode = this%cellid(j) if (this%ibound(igwfnode) == 0) cycle head = this%xnew(igwfnode) + hp - call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head, qlakgw, avail) + call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head, qlakgw, & + avail) seep = seep + qlakgw end do ! @@ -5839,7 +5845,7 @@ subroutine lak_setup_budobj(this) character(len=LENBUDTXT), dimension(1) :: auxtxt ! ------------------------------------------------------------------------------ ! - ! -- Determine the number of lake budget terms. These are fixed for + ! -- Determine the number of lake budget terms. These are fixed for ! the simulation and cannot change nbudterm = 9 nlen = 0 @@ -5885,10 +5891,10 @@ subroutine lak_setup_budobj(this) end do end if ! - ! -- + ! -- text = ' GWF' idx = idx + 1 - maxlist = this%maxbound + maxlist = this%maxbound naux = 1 auxtxt(1) = ' FLOW-AREA' call this%budobj%budterm(idx)%initialize(text, & @@ -5907,7 +5913,7 @@ subroutine lak_setup_budobj(this) end do end do ! - ! -- + ! -- text = ' RAINFALL' idx = idx + 1 maxlist = this%nlakes @@ -5920,7 +5926,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EVAPORATION' idx = idx + 1 maxlist = this%nlakes @@ -5933,7 +5939,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' RUNOFF' idx = idx + 1 maxlist = this%nlakes @@ -5946,7 +5952,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EXT-INFLOW' idx = idx + 1 maxlist = this%nlakes @@ -5959,7 +5965,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' WITHDRAWAL' idx = idx + 1 maxlist = this%nlakes @@ -5972,7 +5978,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EXT-OUTFLOW' idx = idx + 1 maxlist = this%nlakes @@ -5985,7 +5991,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' STORAGE' idx = idx + 1 maxlist = this%nlakes @@ -5999,7 +6005,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux, auxtxt) ! - ! -- + ! -- text = ' CONSTANT' idx = idx + 1 maxlist = this%nlakes @@ -6012,10 +6018,10 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- if (this%imover == 1) then ! - ! -- + ! -- text = ' FROM-MVR' idx = idx + 1 maxlist = this%nlakes @@ -6028,7 +6034,7 @@ subroutine lak_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' TO-MVR' idx = idx + 1 maxlist = this%noutlets @@ -6042,11 +6048,11 @@ subroutine lak_setup_budobj(this) naux, ordered_id1=.false.) end if ! - ! -- + ! -- naux = this%naux if (naux > 0) then ! - ! -- + ! -- text = ' AUXILIARY' idx = idx + 1 maxlist = this%nlakes @@ -6098,7 +6104,6 @@ subroutine lak_fill_budobj(this) ! -- initialize counter idx = 0 - ! -- FLOW JA FACE nlen = 0 do n = 1, this%noutlets @@ -6123,7 +6128,6 @@ subroutine lak_fill_budobj(this) end do end if - ! -- GWF (LEAKAGE) idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) @@ -6135,7 +6139,6 @@ subroutine lak_fill_budobj(this) end do end do - ! -- RAIN idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6143,8 +6146,7 @@ subroutine lak_fill_budobj(this) q = this%precip(n) call this%budobj%budterm(idx)%update_term(n, n, q) end do - - + ! -- EVAPORATION idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6152,7 +6154,6 @@ subroutine lak_fill_budobj(this) q = this%evap(n) call this%budobj%budterm(idx)%update_term(n, n, q) end do - ! -- RUNOFF idx = idx + 1 @@ -6162,7 +6163,6 @@ subroutine lak_fill_budobj(this) call this%budobj%budterm(idx)%update_term(n, n, q) end do - ! -- INFLOW idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6170,8 +6170,7 @@ subroutine lak_fill_budobj(this) q = this%inflow(n) call this%budobj%budterm(idx)%update_term(n, n, q) end do - - + ! -- WITHDRAWAL idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6180,7 +6179,6 @@ subroutine lak_fill_budobj(this) call this%budobj%budterm(idx)%update_term(n, n, q) end do - ! -- EXTERNAL OUTFLOW idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6192,7 +6190,6 @@ subroutine lak_fill_budobj(this) call this%budobj%budterm(idx)%update_term(n, n, q) end do - ! -- STORAGE idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6202,8 +6199,7 @@ subroutine lak_fill_budobj(this) this%qauxcbc(1) = v1 call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) end do - - + ! -- CONSTANT FLOW idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6211,11 +6207,10 @@ subroutine lak_fill_budobj(this) q = this%chterm(n) call this%budobj%budterm(idx)%update_term(n, n, q) end do - - + ! -- MOVER if (this%imover == 1) then - + ! -- FROM MOVER idx = idx + 1 call this%budobj%budterm(idx)%reset(this%nlakes) @@ -6223,8 +6218,7 @@ subroutine lak_fill_budobj(this) q = this%pakmvrobj%get_qfrommvr(n) call this%budobj%budterm(idx)%update_term(n, n, q) end do - - + ! -- TO MOVER idx = idx + 1 call this%budobj%budterm(idx)%reset(this%noutlets) @@ -6236,15 +6230,14 @@ subroutine lak_fill_budobj(this) end if call this%budobj%budterm(idx)%update_term(n1, n1, q) end do - + end if - - + ! -- AUXILIARY VARIABLES naux = this%naux if (naux > 0) then idx = idx + 1 - allocate(auxvartmp(naux)) + allocate (auxvartmp(naux)) call this%budobj%budterm(idx)%reset(this%nlakes) do n = 1, this%nlakes q = DZERO @@ -6254,7 +6247,7 @@ subroutine lak_fill_budobj(this) end do call this%budobj%budterm(idx)%update_term(n, n, q, auxvartmp) end do - deallocate(auxvartmp) + deallocate (auxvartmp) end if ! ! --Terms are filled, now accumulate them for this time step @@ -6266,9 +6259,9 @@ end subroutine lak_fill_budobj subroutine lak_setup_tableobj(this) ! ****************************************************************************** -! lak_setup_tableobj -- Set up the table object that is used to write the lak -! stage data. The terms listed here must correspond in -! number and order to the ones written to the stage table +! lak_setup_tableobj -- Set up the table object that is used to write the lak +! stage data. The terms listed here must correspond in +! number and order to the ones written to the stage table ! in the lak_ot method. ! ****************************************************************************** ! @@ -6287,7 +6280,7 @@ subroutine lak_setup_tableobj(this) ! -- setup stage table if (this%iprhed > 0) then ! - ! -- Determine the number of lake stage terms. These are fixed for + ! -- Determine the number of lake stage terms. These are fixed for ! the simulation and cannot change. This includes FLOW-JA-FACE ! so they can be written to the binary budget files, but these internal ! flows are not included as part of the budget table. @@ -6297,12 +6290,12 @@ subroutine lak_setup_tableobj(this) end if ! ! -- set up table title - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STAGES FOR EACH CONTROL VOLUME' + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STAGES FOR EACH CONTROL VOLUME' ! ! -- set up stage tableobj call table_cr(this%stagetab, this%packName, title) - call this%stagetab%table_df(this%nlakes, nterms, this%iout, & + call this%stagetab%table_df(this%nlakes, nterms, this%iout, & transient=.TRUE.) ! ! -- Go through and set up table budget term @@ -6335,7 +6328,7 @@ subroutine lak_setup_tableobj(this) ! -- return return end subroutine lak_setup_tableobj - + subroutine lak_activate_density(this) ! ****************************************************************************** ! lak_activate_density -- Activate addition of density terms @@ -6344,7 +6337,7 @@ subroutine lak_activate_density(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this ! -- local integer(I4B) :: i, j ! -- formats @@ -6359,17 +6352,17 @@ subroutine lak_activate_density(this) this%denseterms(j, i) = DZERO end do end do - write(this%iout,'(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR LAKE & - &PACKAGE: ' // trim(adjustl(this%packName)) + write (this%iout, '(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR LAKE & + &PACKAGE: '//trim(adjustl(this%packName)) ! ! -- return return end subroutine lak_activate_density - subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & + subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & botl, flow, gwfhcof, gwfrhs) ! ****************************************************************************** -! lak_calculate_density_exchange -- Calculate the groundwater-lake density +! lak_calculate_density_exchange -- Calculate the groundwater-lake density ! exchange terms. ! ! -- Arguments are as follows: @@ -6393,7 +6386,7 @@ subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(LakType),intent(inout) :: this + class(LakType), intent(inout) :: this integer(I4B), intent(in) :: iconn real(DP), intent(in) :: stage real(DP), intent(in) :: head @@ -6423,22 +6416,22 @@ subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & if (stage >= botl) then ss = stage stage_below_bot = .false. - rdenselak = this%denseterms(1, iconn) ! lak rel density + rdenselak = this%denseterms(1, iconn) ! lak rel density else ss = botl stage_below_bot = .true. - rdenselak = this%denseterms(2, iconn) ! gwf rel density + rdenselak = this%denseterms(2, iconn) ! gwf rel density end if ! ! -- set hh to head or botl if (head >= botl) then hh = head head_below_bot = .false. - rdensegwf = this%denseterms(2, iconn) ! gwf rel density + rdensegwf = this%denseterms(2, iconn) ! gwf rel density else hh = botl head_below_bot = .true. - rdensegwf = this%denseterms(1, iconn) ! lak rel density + rdensegwf = this%denseterms(1, iconn) ! lak rel density end if ! ! -- todo: hack because denseterms not updated in a cf calculation @@ -6454,9 +6447,9 @@ subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & ! -- calulate average relative density rdenseavg = DHALF * (rdenselak + rdensegwf) ! - ! -- Add contribution of first density term: + ! -- Add contribution of first density term: ! cond * (denseavg/denseref - 1) * (hgwf - hlak) - d1 = cond * (rdenseavg - DONE) + d1 = cond * (rdenseavg - DONE) gwfhcof = gwfhcof - d1 gwfrhs = gwfrhs - d1 * ss d1 = d1 * (hh - ss) @@ -6487,5 +6480,4 @@ subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & return end subroutine lak_calculate_density_exchange - end module LakModule diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index 6832af8ea3f..6f74ef0daa1 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -1,42 +1,41 @@ module MawModule ! use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - LENBUDTXT, & - DZERO, DEM9, DEM6, DEM4, DEM2, DQUARTER, DHALF, DP7,& - DP9, DONE, DTWO, DPI, DTWOPI, DEIGHT, DHUNDRED, & - DEP20, NAMEDBOUNDFLAG, LENPACKAGENAME, LENAUXNAME, & - LENFTYPE, DHNOFLO, DHDRY, DNODATA, MAXCHARLEN, & - TABLEFT, TABCENTER, TABRIGHT, & + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + LENBUDTXT, DZERO, DEM9, DEM6, DEM4, DEM2, DQUARTER, & + DHALF, DP7, DP9, DONE, DTWO, DPI, DTWOPI, DEIGHT, & + DHUNDRED, DEP20, NAMEDBOUNDFLAG, LENPACKAGENAME, & + LENAUXNAME, LENFTYPE, DHNOFLO, DHDRY, DNODATA, & + MAXCHARLEN, TABLEFT, TABCENTER, TABRIGHT, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, & - sQSaturationDerivative, & - sQuadratic0sp, & - sQuadratic0spDerivative + use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & + sQuadraticSaturationDerivative, & + sQSaturationDerivative, & + sQuadratic0sp, & + sQuadratic0spDerivative use BndModule, only: BndType use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr use TableModule, only: TableType, table_cr - use ObserveModule, only: ObserveType + use ObserveModule, only: ObserveType use ObsModule, only: ObsType - use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname, & + use InputOutputModule, only: get_node, URWORD, extract_idnum_or_bndname, & GetUnit, openfile use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, store_error_unit, & - store_warning - use BlockParserModule, only: BlockParserType + use SimModule, only: count_errors, store_error, store_error_unit, & + store_warning + use BlockParserModule, only: BlockParserType use SimVariablesModule, only: errmsg, warnmsg - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & mem_deallocate use MemoryHelperModule, only: create_mem_path ! implicit none - + public :: MawType - + ! - character(len=LENFTYPE) :: ftype = 'MAW' - character(len=LENPACKAGENAME) :: text = ' MAW' + character(len=LENFTYPE) :: ftype = 'MAW' + character(len=LENPACKAGENAME) :: text = ' MAW' private public :: maw_create @@ -46,10 +45,10 @@ module MawModule ! -- scalars ! -- characters ! - character(len=LENBUDTXT), dimension(:), pointer, & - contiguous :: cmawbudget => NULL() - character(len=LENAUXNAME), dimension(:), pointer, & - contiguous :: cauxcbc => NULL() + character(len=LENBUDTXT), dimension(:), pointer, & + contiguous :: cmawbudget => NULL() + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: cauxcbc => NULL() ! ! -- logical logical(LGP), pointer :: correct_flow => null() @@ -75,7 +74,7 @@ module MawModule real(DP), pointer :: kappa => NULL() ! ! -- vector data for each well - character (len=8), dimension(:), pointer, contiguous :: status => null() + character(len=8), dimension(:), pointer, contiguous :: status => null() integer(I4B), dimension(:), pointer, contiguous :: ngwfnodes => null() integer(I4B), dimension(:), pointer, contiguous :: ieqn => null() integer(I4B), dimension(:), pointer, contiguous :: ishutoff => null() @@ -99,13 +98,13 @@ module MawModule real(DP), dimension(:), pointer, contiguous :: shutoffweight => null() real(DP), dimension(:), pointer, contiguous :: shutoffdq => null() real(DP), dimension(:), pointer, contiguous :: shutoffqold => null() - character (len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: cmawname => null() + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: cmawname => null() ! ! -- time-series aware data real(DP), dimension(:), pointer, contiguous :: rate => null() real(DP), dimension(:), pointer, contiguous :: well_head => null() - real(DP), dimension(:,:), pointer, contiguous :: mauxvar => null() + real(DP), dimension(:, :), pointer, contiguous :: mauxvar => null() ! ! -- ia vector for connections integer(I4B), dimension(:), pointer, contiguous :: iaconn => null() @@ -146,21 +145,21 @@ module MawModule real(DP), dimension(:), pointer, contiguous :: gwfsat => NULL() ! ! -- arrays for handling the rows added to the solution matrix - integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !map position in global rhs and x array of pack entry - integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !map position in global array of package diagonal row entries - integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !map position in global array of package off diagonal row entries - integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !map position in global array of package diagonal entries to model rows - integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !map position in global array of package off diagonal entries to model rows - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound - real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector - real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector + integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !map position in global rhs and x array of pack entry + integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !map position in global array of package diagonal row entries + integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !map position in global array of package off diagonal row entries + integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !map position in global array of package diagonal entries to model rows + integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !map position in global array of package off diagonal entries to model rows + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound + real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector + real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector ! ! -- density variables integer(I4B), pointer :: idense - real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() + real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() ! ! -- type bound procedures - contains + contains procedure :: maw_allocate_scalars procedure :: maw_allocate_well_conn_arrays procedure :: maw_allocate_arrays @@ -228,17 +227,17 @@ subroutine maw_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(MawType), pointer :: mawobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(mawobj) + allocate (mawobj) packobj => mawobj ! ! -- create name and memory path @@ -256,9 +255,9 @@ subroutine maw_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%id = id packobj%ibcnum = ibcnum packobj%ncolbnd = 4 - packobj%iscloc = 0 ! not supported + packobj%iscloc = 0 ! not supported packobj%isadvpak = 1 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return return @@ -274,7 +273,7 @@ subroutine maw_allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(MawType), intent(inout) :: this + class(MawType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! -- call standard BndType allocate scalars @@ -334,7 +333,7 @@ subroutine maw_allocate_well_conn_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(MawType), intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local integer(I4B) :: j integer(I4B) :: n @@ -342,7 +341,7 @@ subroutine maw_allocate_well_conn_arrays(this) ! ------------------------------------------------------------------------------ ! ! -- allocate character array for budget text - call mem_allocate(this%cmawbudget, LENBUDTXT, this%bditems, 'CMAWBUDGET', & + call mem_allocate(this%cmawbudget, LENBUDTXT, this%bditems, 'CMAWBUDGET', & this%memoryPath) ! !-- fill cmawbudget @@ -356,15 +355,16 @@ subroutine maw_allocate_well_conn_arrays(this) this%cmawbudget(8) = ' FW-RATE-TO-MVR' ! ! -- allocate character arrays - call mem_allocate(this%cmawname, LENBOUNDNAME, this%nmawwells, 'CMAWNAME', & + call mem_allocate(this%cmawname, LENBOUNDNAME, this%nmawwells, 'CMAWNAME', & this%memoryPath) call mem_allocate(this%status, 8, this%nmawwells, 'STATUS', this%memoryPath) ! ! -- allocate well data pointers in memory manager - call mem_allocate(this%ngwfnodes, this%nmawwells, 'NGWFNODES', this%memoryPath) + call mem_allocate(this%ngwfnodes, this%nmawwells, 'NGWFNODES', & + this%memoryPath) call mem_allocate(this%ieqn, this%nmawwells, 'IEQN', this%memoryPath) call mem_allocate(this%ishutoff, this%nmawwells, 'ISHUTOFF', this%memoryPath) - call mem_allocate(this%ifwdischarge, this%nmawwells, 'IFWDISCHARGE', & + call mem_allocate(this%ifwdischarge, this%nmawwells, 'IFWDISCHARGE', & this%memoryPath) call mem_allocate(this%strt, this%nmawwells, 'STRT', this%memoryPath) call mem_allocate(this%radius, this%nmawwells, 'RADIUS', this%memoryPath) @@ -377,28 +377,33 @@ subroutine maw_allocate_well_conn_arrays(this) call mem_allocate(this%fwelev, this%nmawwells, 'FWELEV', this%memoryPath) call mem_allocate(this%fwcond, this%nmawwells, 'FWCONDS', this%memoryPath) call mem_allocate(this%fwrlen, this%nmawwells, 'FWRLEN', this%memoryPath) - call mem_allocate(this%fwcondsim, this%nmawwells, 'FWCONDSIM', this%memoryPath) + call mem_allocate(this%fwcondsim, this%nmawwells, 'FWCONDSIM', & + this%memoryPath) call mem_allocate(this%xsto, this%nmawwells, 'XSTO', this%memoryPath) call mem_allocate(this%xoldsto, this%nmawwells, 'XOLDSTO', this%memoryPath) - call mem_allocate(this%shutoffmin, this%nmawwells, 'SHUTOFFMIN', this%memoryPath) - call mem_allocate(this%shutoffmax, this%nmawwells, 'SHUTOFFMAX', this%memoryPath) - call mem_allocate(this%shutofflevel, this%nmawwells, 'SHUTOFFLEVEL', & + call mem_allocate(this%shutoffmin, this%nmawwells, 'SHUTOFFMIN', & + this%memoryPath) + call mem_allocate(this%shutoffmax, this%nmawwells, 'SHUTOFFMAX', & + this%memoryPath) + call mem_allocate(this%shutofflevel, this%nmawwells, 'SHUTOFFLEVEL', & this%memoryPath) - call mem_allocate(this%shutoffweight, this%nmawwells, 'SHUTOFFWEIGHT', & + call mem_allocate(this%shutoffweight, this%nmawwells, 'SHUTOFFWEIGHT', & this%memoryPath) - call mem_allocate(this%shutoffdq, this%nmawwells, 'SHUTOFFDQ', this%memoryPath) - call mem_allocate(this%shutoffqold, this%nmawwells, 'SHUTOFFQOLD', & + call mem_allocate(this%shutoffdq, this%nmawwells, 'SHUTOFFDQ', & + this%memoryPath) + call mem_allocate(this%shutoffqold, this%nmawwells, 'SHUTOFFQOLD', & this%memoryPath) ! ! -- timeseries aware variables call mem_allocate(this%rate, this%nmawwells, 'RATE', this%memoryPath) - call mem_allocate(this%well_head, this%nmawwells, 'WELL_HEAD', this%memoryPath) + call mem_allocate(this%well_head, this%nmawwells, 'WELL_HEAD', & + this%memoryPath) if (this%naux > 0) then jj = this%naux else jj = 1 end if - call mem_allocate(this%mauxvar, jj, this%nmawwells, 'MAUXVAR', & + call mem_allocate(this%mauxvar, jj, this%nmawwells, 'MAUXVAR', & this%memoryPath) ! ! -- allocate and initialize dbuff @@ -409,7 +414,7 @@ subroutine maw_allocate_well_conn_arrays(this) end if ! ! -- allocate iaconn - call mem_allocate(this%iaconn, this%nmawwells+1, 'IACONN', this%memoryPath) + call mem_allocate(this%iaconn, this%nmawwells + 1, 'IACONN', this%memoryPath) ! ! -- allocate imap call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%memoryPath) @@ -472,7 +477,7 @@ subroutine maw_allocate_well_conn_arrays(this) end do ! ! -- allocate character array for budget text - call mem_allocate(this%cauxcbc, LENAUXNAME, this%cbcauxitems, 'CAUXCBC', & + call mem_allocate(this%cauxcbc, LENAUXNAME, this%cbcauxitems, 'CAUXCBC', & this%memoryPath) ! ! -- allocate and initialize qauxcbc @@ -530,7 +535,7 @@ subroutine maw_allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(MawType), intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local !integer(I4B) :: i ! ------------------------------------------------------------------------------ @@ -552,7 +557,7 @@ subroutine maw_read_wells(this) use ConstantsModule, only: LINELENGTH use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: text character(len=LINELENGTH) :: keyword @@ -576,31 +581,31 @@ subroutine maw_read_wells(this) ! -- local allocatable arrays character(len=LINELENGTH), dimension(:), allocatable :: strttext character(len=LENBOUNDNAME), dimension(:), allocatable :: nametxt - character(len=50), dimension(:,:), allocatable :: caux + character(len=50), dimension(:, :), allocatable :: caux integer(I4B), dimension(:), allocatable :: nboundchk integer(I4B), dimension(:), allocatable :: wellieqn integer(I4B), dimension(:), allocatable :: ngwfnodes real(DP), dimension(:), allocatable :: radius real(DP), dimension(:), allocatable :: bottom ! -- format - character(len=*), parameter :: fmthdbot = & - "('well head (', G0, ') must be greater than or equal to the & - &BOTTOM_ELEVATION (', G0, ').')" + character(len=*), parameter :: fmthdbot = & + "('well head (', G0, ') must be greater than or equal to the & + &BOTTOM_ELEVATION (', G0, ').')" ! ------------------------------------------------------------------------------ ! ! -- code ! ! -- allocate and initialize temporary variables - allocate(strttext(this%nmawwells)) - allocate(nametxt(this%nmawwells)) + allocate (strttext(this%nmawwells)) + allocate (nametxt(this%nmawwells)) if (this%naux > 0) then - allocate(caux(this%naux, this%nmawwells)) + allocate (caux(this%naux, this%nmawwells)) end if - allocate(nboundchk(this%nmawwells)) - allocate(wellieqn(this%nmawwells)) - allocate(ngwfnodes(this%nmawwells)) - allocate(radius(this%nmawwells)) - allocate(bottom(this%nmawwells)) + allocate (nboundchk(this%nmawwells)) + allocate (wellieqn(this%nmawwells)) + allocate (ngwfnodes(this%nmawwells)) + allocate (radius(this%nmawwells)) + allocate (bottom(this%nmawwells)) ! ! -- initialize temporary variables do n = 1, this%nmawwells @@ -615,13 +620,13 @@ subroutine maw_read_wells(this) ! ! -- read maw well data ! -- get wells block - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & supportopenclose=.true.) ! ! -- parse locations block if detected if (isfound) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' PACKAGEDATA' + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' PACKAGEDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -629,8 +634,8 @@ subroutine maw_read_wells(this) n = ival if (n < 1 .or. n > this%nmawwells) then - write(errmsg,'(a,1x,i0,a)') & - 'IMAW must be greater than 0 and less than or equal to', & + write (errmsg, '(a,1x,i0,a)') & + 'IMAW must be greater than 0 and less than or equal to', & this%nmawwells, '.' call store_error(errmsg) cycle @@ -642,7 +647,7 @@ subroutine maw_read_wells(this) ! -- radius rval = this%parser%GetDouble() if (rval <= DZERO) then - write(errmsg,'(a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a)') & 'Radius for well', n, 'must be greater than zero.' call store_error(errmsg) end if @@ -656,19 +661,19 @@ subroutine maw_read_wells(this) ! ! -- ieqn call this%parser%GetStringCaps(keyword) - if (keyword=='SPECIFIED') then + if (keyword == 'SPECIFIED') then ieqn = 0 - else if (keyword=='THEIM' .or. keyword=='THIEM') then + else if (keyword == 'THEIM' .or. keyword == 'THIEM') then ieqn = 1 - else if (keyword=='SKIN') then + else if (keyword == 'SKIN') then ieqn = 2 - else if (keyword=='CUMULATIVE') then + else if (keyword == 'CUMULATIVE') then ieqn = 3 - else if (keyword=='MEAN') then + else if (keyword == 'MEAN') then ieqn = 4 else - write(errmsg,'(a,1x,i0,1x,a)') & - 'CONDEQN for well', n, & + write (errmsg, '(a,1x,i0,1x,a)') & + 'CONDEQN for well', n, & "must be 'CONDUCTANCE', 'THIEM', 'MEAN', or 'SKIN'." end if wellieqn(n) = ieqn @@ -677,11 +682,11 @@ subroutine maw_read_wells(this) ival = this%parser%GetInteger() if (ival < 1) then ival = 0 - write(errmsg,'(a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a)') & 'NGWFNODES for well', n, 'must be greater than zero.' call store_error(errmsg) end if - + if (ival > 0) then ngwfnodes(n) = ival end if @@ -695,8 +700,8 @@ subroutine maw_read_wells(this) end do ! ! -- set default bndName - write (cno,'(i9.9)') n - bndName = 'MAWWELL' // cno + write (cno, '(i9.9)') n + bndName = 'MAWWELL'//cno ! ! -- read well name if (this%inamedbound /= 0) then @@ -708,16 +713,16 @@ subroutine maw_read_wells(this) nametxt(n) = bndName end do - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' PACKAGEDATA' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' ! ! -- check for duplicate or missing wells - do n = 1, this%nmawwells + do n = 1, this%nmawwells if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0,a)') 'No data specified for maw well', n, '.' + write (errmsg, '(a,1x,i0,a)') 'No data specified for maw well', n, '.' call store_error(errmsg) else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'Data for maw well', n, 'specified', nboundchk(n), 'times.' call store_error(errmsg) end if @@ -733,13 +738,13 @@ subroutine maw_read_wells(this) ! ! -- set MAXBOUND this%maxbound = itmp - write(this%iout,'(//4x,a,i7)') 'MAXBOUND = ', this%maxbound + write (this%iout, '(//4x,a,i7)') 'MAXBOUND = ', this%maxbound ! ! -- allocate well and connection data call this%maw_allocate_well_conn_arrays() ! ! -- fill well data with data stored in temporary local arrays - do n = 1, this%nmawwells + do n = 1, this%nmawwells rval = radius(n) this%radius(n) = rval this%area(n) = DPI * rval**DTWO @@ -751,18 +756,18 @@ subroutine maw_read_wells(this) ! fill timeseries aware data ! ! -- well_head and strt - jj = 1 ! For WELL_HEAD + jj = 1 ! For WELL_HEAD bndElem => this%well_head(n) - call read_value_or_time_series_adv(strttext(n), n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'WELL_HEAD') + call read_value_or_time_series_adv(strttext(n), n, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'WELL_HEAD') ! ! -- set starting head value this%strt(n) = this%well_head(n) ! ! -- check for error condition if (this%strt(n) < this%bot(n)) then - write(cstr, fmthdbot) this%strt(n), this%bot(n) + write (cstr, fmthdbot) this%strt(n), this%bot(n) call this%maw_set_attribute_error(n, 'STRT', trim(cstr)) end if ! @@ -771,11 +776,11 @@ subroutine maw_read_wells(this) text = caux(jj, n) ii = n bndElem => this%mauxvar(jj, ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'AUX', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & + 'AUX', this%tsManager, this%iprpak, & this%auxname(jj)) end do - end do + end do ! ! -- set iaconn and imap for each connection idx = 0 @@ -785,20 +790,20 @@ subroutine maw_read_wells(this) idx = idx + 1 this%imap(idx) = n end do - this%iaconn(n+1) = idx + 1 + this%iaconn(n + 1) = idx + 1 end do ! ! -- deallocate local storage - deallocate(strttext) - deallocate(nametxt) + deallocate (strttext) + deallocate (nametxt) if (this%naux > 0) then - deallocate(caux) + deallocate (caux) end if - deallocate(nboundchk) - deallocate(wellieqn) - deallocate(ngwfnodes) - deallocate(radius) - deallocate(bottom) + deallocate (nboundchk) + deallocate (wellieqn) + deallocate (ngwfnodes) + deallocate (radius) + deallocate (bottom) ! ! -- return return @@ -813,7 +818,7 @@ subroutine maw_read_well_connections(this) ! ------------------------------------------------------------------------------ use ConstantsModule, only: LINELENGTH ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: cellid character(len=30) :: nodestr @@ -837,7 +842,7 @@ subroutine maw_read_well_connections(this) real(DP) :: botw integer(I4B), dimension(:), pointer, contiguous :: nboundchk integer(I4B), dimension(:), pointer, contiguous :: iachk - + ! ------------------------------------------------------------------------------ ! -- format ! @@ -849,12 +854,12 @@ subroutine maw_read_well_connections(this) ireset_wellbot = 0 ! ! -- allocate and initialize local storage - allocate(iachk(this%nmawwells+1)) + allocate (iachk(this%nmawwells + 1)) iachk(1) = 1 do n = 1, this%nmawwells - iachk(n+1) = iachk(n) + this%ngwfnodes(n) + iachk(n + 1) = iachk(n) + this%ngwfnodes(n) end do - allocate(nboundchk(this%maxbound)) + allocate (nboundchk(this%maxbound)) do n = 1, this%maxbound nboundchk(n) = 0 end do @@ -865,7 +870,7 @@ subroutine maw_read_well_connections(this) ! ! -- parse well_connections block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' CONNECTIONDATA' do call this%parser%GetNextLine(endOfBlock) @@ -877,8 +882,8 @@ subroutine maw_read_well_connections(this) ! ! -- check for error condition if (n < 1 .or. n > this%nmawwells) then - write(errmsg,'(a,1x,i0,a)') & - 'IMAW must be greater than 0 and less than or equal to ', & + write (errmsg, '(a,1x,i0,a)') & + 'IMAW must be greater than 0 and less than or equal to ', & this%nmawwells, '.' call store_error(errmsg) cycle @@ -887,23 +892,23 @@ subroutine maw_read_well_connections(this) ! -- read connection number ival = this%parser%GetInteger() if (ival < 1 .or. ival > this%ngwfnodes(n)) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,a)') & - 'JCONN for well ', n, & - 'must be greater than 1 and less than or equal to ', & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') & + 'JCONN for well ', n, & + 'must be greater than 1 and less than or equal to ', & this%ngwfnodes(n), '.' call store_error(errmsg) cycle end if - + ipos = iachk(n) + ival - 1 nboundchk(ipos) = nboundchk(ipos) + 1 - + j = ival jpos = this%get_jpos(n, ival) ! ! -- read gwfnodes from the line call this%parser%GetCellid(this%dis%ndim, cellid) - nn = this%dis%noder_from_cellid(cellid, this%inunit, this%iout) + nn = this%dis%noder_from_cellid(cellid, this%inunit, this%iout) topnn = this%dis%top(nn) botnn = this%dis%bot(nn) botw = this%bot(n) @@ -943,9 +948,9 @@ subroutine maw_read_well_connections(this) botw = rval this%bot(n) = rval else - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,g0,a,g0,a)') & - 'Screen bottom for maw well', n, 'connection', j, '(', & - this%botscrn(jpos), ') is less than the well bottom (', & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,g0,a,g0,a)') & + 'Screen bottom for maw well', n, 'connection', j, '(', & + this%botscrn(jpos), ') is less than the well bottom (', & this%bot(n), ').' call store_error(errmsg) end if @@ -955,28 +960,29 @@ subroutine maw_read_well_connections(this) rval = this%parser%GetDouble() if (this%ieqn(n) == 0) then this%satcond(jpos) = rval - else if (this%ieqn(n) == 2 .OR. this%ieqn(n) == 3 .OR. & + else if (this%ieqn(n) == 2 .OR. this%ieqn(n) == 3 .OR. & this%ieqn(n) == 4) then this%hk(jpos) = rval end if ! ! -- skin radius rval = this%parser%GetDouble() - if (this%ieqn(n) == 2 .OR. this%ieqn(n) == 3 .OR. & + if (this%ieqn(n) == 2 .OR. this%ieqn(n) == 3 .OR. & this%ieqn(n) == 4) then this%sradius(jpos) = rval if (this%sradius(jpos) <= this%radius(n)) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,g0,a,g0,a)') & - 'Screen radius for maw well', n, 'connection', j, '(', & - this%sradius(jpos),') is less than or equal to the well radius (', & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,g0,a,g0,a)') & + 'Screen radius for maw well', n, 'connection', j, '(', & + this%sradius(jpos), & + ') is less than or equal to the well radius (', & this%radius(n), ').' call store_error(errmsg) end if end if end do - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' CONNECTIONDATA' - + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' + ipos = 0 do n = 1, this%nmawwells do j = 1, this%ngwfnodes(n) @@ -984,19 +990,19 @@ subroutine maw_read_well_connections(this) ! ! -- check for missing or duplicate maw well connections if (nboundchk(ipos) == 0) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') & 'No data specified for maw well', n, 'connection', j, '.' call store_error(errmsg) else if (nboundchk(ipos) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'Data for maw well', n, 'connection', j, & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'Data for maw well', n, 'connection', j, & 'specified', nboundchk(n), 'times.' call store_error(errmsg) end if end do end do ! - ! -- make sure that more than one connection per cell is only specified + ! -- make sure that more than one connection per cell is only specified ! wells using the mean conducance type do n = 1, this%nmawwells if (this%ieqn(n) /= 4) then @@ -1011,9 +1017,9 @@ subroutine maw_read_well_connections(this) nn2 = this%get_gwfnode(n, jj) if (nn2 == nn) then call this%dis%noder_to_string(nn, nodestr) - write(errmsg,'(a,1x,i0,1x,a,1x,i0,3(1x,a))') & - 'Only one connection can be specified for maw well', & - n, 'connection', j, 'to gwf cell', trim(adjustl(nodestr)), & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,3(1x,a))') & + 'Only one connection can be specified for maw well', & + n, 'connection', j, 'to gwf cell', trim(adjustl(nodestr)), & 'unless the mean condeqn is specified.' call store_error(errmsg) end if @@ -1026,27 +1032,27 @@ subroutine maw_read_well_connections(this) end if ! ! -- deallocate local variable - deallocate(iachk) - deallocate(nboundchk) + deallocate (iachk) + deallocate (nboundchk) ! ! -- add warning messages if (ireset_scrntop > 0) then - write(warnmsg,'(a,1x,a,1x,a,1x,i0,1x,a)') & - 'The screen tops in multi-aquifer well package', trim(this%packName), & + write (warnmsg, '(a,1x,a,1x,a,1x,i0,1x,a)') & + 'The screen tops in multi-aquifer well package', trim(this%packName), & 'were reset to the top of the connected cell', ireset_scrntop, 'times.' call store_warning(warnmsg) end if if (ireset_scrnbot > 0) then - write(warnmsg,'(a,1x,a,1x,a,1x,i0,1x,a)') & + write (warnmsg, '(a,1x,a,1x,a,1x,i0,1x,a)') & 'The screen bottoms in multi-aquifer well package', trim(this%packName), & - 'were reset to the bottom of the connected cell', ireset_scrnbot, & + 'were reset to the bottom of the connected cell', ireset_scrnbot, & 'times.' call store_warning(warnmsg) end if if (ireset_wellbot > 0) then - write(warnmsg,'(a,1x,a,1x,a,1x,i0,1x,a)') & - 'The well bottoms in multi-aquifer well package', trim(this%packName), & - 'were reset to the bottom of the connected cell', ireset_wellbot, & + write (warnmsg, '(a,1x,a,1x,a,1x,i0,1x,a)') & + 'The well bottoms in multi-aquifer well package', trim(this%packName), & + 'were reset to the bottom of the connected cell', ireset_wellbot, & 'times.' call store_warning(warnmsg) end if @@ -1060,7 +1066,6 @@ subroutine maw_read_well_connections(this) return end subroutine maw_read_well_connections - subroutine maw_read_dimensions(this) ! ****************************************************************************** ! pak1read_dimensions -- Read the dimensions for this package @@ -1070,7 +1075,7 @@ subroutine maw_read_dimensions(this) ! ------------------------------------------------------------------------------ use ConstantsModule, only: LINELENGTH ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local character(len=LENBOUNDNAME) :: keyword integer(I4B) :: ierr @@ -1079,7 +1084,7 @@ subroutine maw_read_dimensions(this) ! ------------------------------------------------------------------------------ ! ! -- initialize dimensions to -1 - this%nmawwells= -1 + this%nmawwells = -1 this%maxbound = -1 ! ! -- get dimensions block @@ -1088,31 +1093,31 @@ subroutine maw_read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NMAWWELLS') - this%nmawwells = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NMAWWELLS = ', this%nmawwells - case default - write(errmsg,'(3a)') & - 'Unknown ' // trim(this%text) // ' dimension: ', trim(keyword), '.' - call store_error(errmsg) + case ('NMAWWELLS') + this%nmawwells = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NMAWWELLS = ', this%nmawwells + case default + write (errmsg, '(3a)') & + 'Unknown '//trim(this%text)//' dimension: ', trim(keyword), '.' + call store_error(errmsg) end select end do - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' else call store_error('Required dimensions block not found.', terminate=.TRUE.) end if ! ! -- verify dimensions were set correctly if (this%nmawwells < 0) then - write(errmsg, '(a)') & + write (errmsg, '(a)') & 'NMAWWELLS was not specified or was specified incorrectly.' call store_error(errmsg) end if @@ -1142,7 +1147,6 @@ subroutine maw_read_dimensions(this) return end subroutine maw_read_dimensions - subroutine maw_read_initial_attr(this) ! ****************************************************************************** ! maw_read_initial_attr -- Read the initial parameters for this package @@ -1154,7 +1158,7 @@ subroutine maw_read_initial_attr(this) use ConstantsModule, only: LINELENGTH use MemoryManagerModule, only: mem_setptr ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -1167,29 +1171,29 @@ subroutine maw_read_initial_attr(this) integer(I4B) :: idx real(DP) :: k11 real(DP) :: k22 - character (len=10), dimension(0:4) :: ccond - character (len=30) :: nodestr + character(len=10), dimension(0:4) :: ccond + character(len=30) :: nodestr ! -- data - data ccond(0) /'SPECIFIED '/ - data ccond(1) /'THIEM '/ - data ccond(2) /'SKIN '/ - data ccond(3) /'CUMULATIVE'/ - data ccond(4) /'MEAN '/ + data ccond(0)/'SPECIFIED '/ + data ccond(1)/'THIEM '/ + data ccond(2)/'SKIN '/ + data ccond(3)/'CUMULATIVE'/ + data ccond(4)/'MEAN '/ ! -- format character(len=*), parameter :: fmtwelln = & - "(1X,//43X,'MULTI-AQUIFER WELL DATA'" // & - "/1X,109('-')," // & - "/1X,7(A10,1X),A16)" + "(1X,//43X,'MULTI-AQUIFER WELL DATA'& + &/1X,109('-'),& + &/1X,7(A10,1X),A16)" character(len=*), parameter :: fmtwelld = & - "(1X,I10,1X,4(G10.3,1X),I10,1X,A10,1X,A16)" + &"(1X,I10,1X,4(G10.3,1X),I10,1X,A10,1X,A16)" character(len=*), parameter :: fmtline = & - "(1X,119('-'),//)" + &"(1X,119('-'),//)" character(len=*), parameter :: fmtwellcn = & - "(1X,//37X,'MULTI-AQUIFER WELL CONNECTION DATA'" // & - "/1X,119('-')," // & - "/1X,2(A10,1X),A20,7(A10,1X))" + "(1X,//37X,'MULTI-AQUIFER WELL CONNECTION DATA'& + &/1X,119('-'),& + &/1X,2(A10,1X),A20,7(A10,1X))" character(len=*), parameter :: fmtwellcd = & - "(1X,2(I10,1X),A20,1X,2(G10.3,1X),2(A10,1X),3(G10.3,1X))" + &"(1X,2(I10,1X),A20,1X,2(G10.3,1X),2(A10,1X),3(G10.3,1X))" ! ------------------------------------------------------------------------------ ! ! -- initialize xnewpak @@ -1201,12 +1205,12 @@ subroutine maw_read_initial_attr(this) ! -- initialize status (iboundpak) of maw wells to active do n = 1, this%nmawwells select case (this%status(n)) - case('CONSTANT') - this%iboundpak(n) = -1 - case('INACTIVE') - this%iboundpak(n) = 0 - case('ACTIVE') - this%iboundpak(n) = 1 + case ('CONSTANT') + this%iboundpak(n) = -1 + case ('INACTIVE') + this%iboundpak(n) = 0 + case ('ACTIVE') + this%iboundpak(n) = 1 end select end do ! @@ -1267,8 +1271,8 @@ subroutine maw_read_initial_attr(this) if (this%inamedbound /= 0) then ntabcols = ntabcols + 1 end if - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC WELL DATA' + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC WELL DATA' call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(this%nmawwells, ntabcols, this%iout) text = 'NUMBER' @@ -1288,7 +1292,7 @@ subroutine maw_read_initial_attr(this) if (this%inamedbound /= 0) then text = 'NAME' call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - end if + end if do n = 1, this%nmawwells call this%inputtab%add_term(n) call this%inputtab%add_term(this%radius(n)) @@ -1297,7 +1301,7 @@ subroutine maw_read_initial_attr(this) call this%inputtab%add_term(this%strt(n)) call this%inputtab%add_term(this%ngwfnodes(n)) call this%inputtab%add_term(ccond(this%ieqn(n))) - if (this%inamedbound /= 0) then + if (this%inamedbound /= 0) then call this%inputtab%add_term(this%cmawname(n)) end if end do @@ -1306,8 +1310,8 @@ subroutine maw_read_initial_attr(this) ! -- write well connection data if (this%iprpak /= 0) then ntabcols = 10 - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC WELL CONNECTION DATA' + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC WELL CONNECTION DATA' call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(this%maxbound, ntabcols, this%iout) text = 'NUMBER' @@ -1342,17 +1346,17 @@ subroutine maw_read_initial_attr(this) call this%inputtab%add_term(nodestr) call this%inputtab%add_term(this%topscrn(jpos)) call this%inputtab%add_term(this%botscrn(jpos)) - if (this%ieqn(n) == 2 .or. & - this%ieqn(n) == 3 .or. & + if (this%ieqn(n) == 2 .or. & + this%ieqn(n) == 3 .or. & this%ieqn(n) == 4) then call this%inputtab%add_term(this%sradius(jpos)) call this%inputtab%add_term(this%hk(jpos)) else - call this%inputtab%add_term(' ') - call this%inputtab%add_term(' ') - end if - if (this%ieqn(n) == 1 .or. & - this%ieqn(n) == 2 .or. & + call this%inputtab%add_term(' ') + call this%inputtab%add_term(' ') + end if + if (this%ieqn(n) == 1 .or. & + this%ieqn(n) == 2 .or. & this%ieqn(n) == 3) then k11 = this%gwfk11(nn) if (this%gwfik22 == 0) then @@ -1386,7 +1390,6 @@ subroutine maw_read_initial_attr(this) return end subroutine maw_read_initial_attr - subroutine maw_set_stressperiod(this, imaw, iheadlimit_warning) ! ****************************************************************************** ! maw_set_stressperiod -- Set a stress period attribute for mawweslls(imaw) @@ -1398,7 +1401,7 @@ subroutine maw_set_stressperiod(this, imaw, iheadlimit_warning) ! -- modules use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: imaw integer(I4B), intent(inout) :: iheadlimit_warning ! -- local @@ -1413,121 +1416,121 @@ subroutine maw_set_stressperiod(this, imaw, iheadlimit_warning) real(DP), pointer :: bndElem => null() integer(I4B) :: istat ! -- formats - character(len=*),parameter :: fmthdbot = & - "('well head (',G0,') must be >= BOTTOM_ELEVATION (',G0, ').')" + character(len=*), parameter :: fmthdbot = & + &"('well head (',G0,') must be >= BOTTOM_ELEVATION (',G0, ').')" ! ------------------------------------------------------------------------------ ! ! -- read remainder of variables on the line call this%parser%GetStringCaps(keyword) select case (keyword) - case ('STATUS') - call this%parser%GetStringCaps(text) - this%status(imaw) = text(1:8) - select case(text) - case('CONSTANT') - this%iboundpak(imaw) = -1 - case('INACTIVE') - this%iboundpak(imaw) = 0 - case('ACTIVE') - this%iboundpak(imaw) = 1 - case default - write(errmsg,'(2a)') & - 'Unknown ' // trim(this%text) // " maw status keyword: '", & - trim(text) // "'." - call store_error(errmsg) - end select - case ('RATE') - call this%parser%GetString(text) - jj = 1 ! For RATE - bndElem => this%rate(imaw) - call read_value_or_time_series_adv(text, imaw, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RATE') - case ('WELL_HEAD') - call this%parser%GetString(text) - jj = 1 ! For WELL_HEAD - bndElem => this%well_head(imaw) - call read_value_or_time_series_adv(text, imaw, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'WELL_HEAD') - ! - ! -- set xnewpak to well_head - this%xnewpak(imaw) = this%well_head(imaw) - ! - ! -- check for error condition - if (this%well_head(imaw) < this%bot(imaw)) then - write(cstr, fmthdbot) & - this%well_head(imaw), this%bot(imaw) - call this%maw_set_attribute_error(imaw, 'WELL HEAD', trim(cstr)) - end if - case ('FLOWING_WELL') - this%fwelev(imaw) = this%parser%GetDouble() - this%fwcond(imaw) = this%parser%GetDouble() - this%fwrlen(imaw) = this%parser%GetDouble() - ! - ! -- test for condition where flowing well data is specified but - ! flowing_wells is not specified in the options block - if (this%iflowingwells == 0) then - this%iflowingwells = -1 - text = 'Flowing well data is specified in the ' // trim(this%packName) // & - ' package but FLOWING_WELL was not specified in the ' // & - 'OPTIONS block.' - call store_warning(text) - end if - case ('RATE_SCALING') - rval = this%parser%GetDouble() - this%pumpelev(imaw) = rval - rval = this%parser%GetDouble() - this%reduction_length(imaw) = rval - if (rval < DZERO) then - call this%maw_set_attribute_error(imaw, trim(keyword), & - 'must be greater than or equal to 0.') - end if - case ('HEAD_LIMIT') - call this%parser%GetString(text) - if (trim(text) == 'OFF') then - this%shutofflevel(imaw) = DEP20 - else - read (text, *, iostat=istat, iomsg=errmsgr) & - this%shutofflevel(imaw) - if (istat /= 0) then - errmsg = 'Could not read HEAD_LIMIT value. ' // trim(errmsgr) - call store_error(errmsg) - end if - if (this%shutofflevel(imaw) <= this%bot(imaw)) then - iheadlimit_warning = iheadlimit_warning + 1 - end if - end if - case ('SHUT_OFF') - rval = this%parser%GetDouble() - this%shutoffmin(imaw) = rval - rval = this%parser%GetDouble() - this%shutoffmax(imaw) = rval - case ('AUXILIARY') - call this%parser%GetStringCaps(caux) - do jj = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle - call this%parser%GetString(text) - ii = imaw - bndElem => this%mauxvar(jj, ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'AUX', this%tsManager, this%iprpak, & - this%auxname(jj)) - exit - end do + case ('STATUS') + call this%parser%GetStringCaps(text) + this%status(imaw) = text(1:8) + select case (text) + case ('CONSTANT') + this%iboundpak(imaw) = -1 + case ('INACTIVE') + this%iboundpak(imaw) = 0 + case ('ACTIVE') + this%iboundpak(imaw) = 1 case default - write(errmsg,'(2a)') & - 'Unknown ' // trim(this%text) // " maw data keyword: '", & - trim(keyword) // "'." + write (errmsg, '(2a)') & + 'Unknown '//trim(this%text)//" maw status keyword: '", & + trim(text)//"'." call store_error(errmsg) end select + case ('RATE') + call this%parser%GetString(text) + jj = 1 ! For RATE + bndElem => this%rate(imaw) + call read_value_or_time_series_adv(text, imaw, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RATE') + case ('WELL_HEAD') + call this%parser%GetString(text) + jj = 1 ! For WELL_HEAD + bndElem => this%well_head(imaw) + call read_value_or_time_series_adv(text, imaw, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'WELL_HEAD') + ! + ! -- set xnewpak to well_head + this%xnewpak(imaw) = this%well_head(imaw) + ! + ! -- check for error condition + if (this%well_head(imaw) < this%bot(imaw)) then + write (cstr, fmthdbot) & + this%well_head(imaw), this%bot(imaw) + call this%maw_set_attribute_error(imaw, 'WELL HEAD', trim(cstr)) + end if + case ('FLOWING_WELL') + this%fwelev(imaw) = this%parser%GetDouble() + this%fwcond(imaw) = this%parser%GetDouble() + this%fwrlen(imaw) = this%parser%GetDouble() + ! + ! -- test for condition where flowing well data is specified but + ! flowing_wells is not specified in the options block + if (this%iflowingwells == 0) then + this%iflowingwells = -1 + text = 'Flowing well data is specified in the '//trim(this%packName)// & + ' package but FLOWING_WELL was not specified in the '// & + 'OPTIONS block.' + call store_warning(text) + end if + case ('RATE_SCALING') + rval = this%parser%GetDouble() + this%pumpelev(imaw) = rval + rval = this%parser%GetDouble() + this%reduction_length(imaw) = rval + if (rval < DZERO) then + call this%maw_set_attribute_error(imaw, trim(keyword), & + 'must be greater than or equal to 0.') + end if + case ('HEAD_LIMIT') + call this%parser%GetString(text) + if (trim(text) == 'OFF') then + this%shutofflevel(imaw) = DEP20 + else + read (text, *, iostat=istat, iomsg=errmsgr) & + this%shutofflevel(imaw) + if (istat /= 0) then + errmsg = 'Could not read HEAD_LIMIT value. '//trim(errmsgr) + call store_error(errmsg) + end if + if (this%shutofflevel(imaw) <= this%bot(imaw)) then + iheadlimit_warning = iheadlimit_warning + 1 + end if + end if + case ('SHUT_OFF') + rval = this%parser%GetDouble() + this%shutoffmin(imaw) = rval + rval = this%parser%GetDouble() + this%shutoffmax(imaw) = rval + case ('AUXILIARY') + call this%parser%GetStringCaps(caux) + do jj = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle + call this%parser%GetString(text) + ii = imaw + bndElem => this%mauxvar(jj, ii) + call read_value_or_time_series_adv(text, ii, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & + this%auxname(jj)) + exit + end do + case default + write (errmsg, '(2a)') & + 'Unknown '//trim(this%text)//" maw data keyword: '", & + trim(keyword)//"'." + call store_error(errmsg) + end select ! ! -- return return end subroutine maw_set_stressperiod - subroutine maw_set_attribute_error(this, imaw, keyword, msg) ! ****************************************************************************** ! maw_set_attribute_error -- Issue a parameter error for mawweslls(imaw) @@ -1539,18 +1542,18 @@ subroutine maw_set_attribute_error(this, imaw, keyword, msg) ! ------------------------------------------------------------------------------ use SimModule, only: store_error ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: imaw - character (len=*), intent(in) :: keyword - character (len=*), intent(in) :: msg + character(len=*), intent(in) :: keyword + character(len=*), intent(in) :: msg ! -- local ! -- formats ! ------------------------------------------------------------------------------ if (len(msg) == 0) then - write(errmsg,'(a,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,a,1x,i0,1x,a)') & keyword, ' for MAW well', imaw, 'has already been set.' else - write(errmsg,'(a,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,a,1x,i0,1x,a)') & keyword, ' for MAW well', imaw, msg end if call store_error(errmsg) @@ -1559,7 +1562,6 @@ subroutine maw_set_attribute_error(this, imaw, keyword, msg) return end subroutine maw_set_attribute_error - subroutine maw_check_attributes(this) ! ****************************************************************************** ! maw_check_attributes -- Issue parameter errors for mawwells(imaw) @@ -1571,7 +1573,7 @@ subroutine maw_check_attributes(this) ! ------------------------------------------------------------------------------ use SimModule, only: store_error ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: cgwfnode integer(I4B) :: idx @@ -1583,7 +1585,7 @@ subroutine maw_check_attributes(this) idx = 1 do n = 1, this%nmawwells if (this%ngwfnodes(n) < 1) then - call this%maw_set_attribute_error(n, 'NGWFNODES', 'must be greater ' // & + call this%maw_set_attribute_error(n, 'NGWFNODES', 'must be greater '// & 'than 0.') end if if (this%radius(n) == DEP20) then @@ -1591,7 +1593,7 @@ subroutine maw_check_attributes(this) end if if (this%shutoffmin(n) > DZERO) then if (this%shutoffmin(n) >= this%shutoffmax(n)) then - call this%maw_set_attribute_error(n, 'SHUT_OFF', 'shutoffmax must ' // & + call this%maw_set_attribute_error(n, 'SHUT_OFF', 'shutoffmax must '// & 'be greater than shutoffmin.') end if end if @@ -1601,34 +1603,34 @@ subroutine maw_check_attributes(this) jpos = this%get_jpos(n, j) ! ! -- write gwfnode number - write(cgwfnode,'(a,i0,a)') 'gwfnode(', j,')' + write (cgwfnode, '(a,i0,a)') 'gwfnode(', j, ')' ! ! -- connection screen data if (this%botscrn(jpos) >= this%topscrn(jpos)) then - call this%maw_set_attribute_error(n, 'SCREEN_TOP', 'screen bottom ' // & - 'must be less tha screen top. ' // & + call this%maw_set_attribute_error(n, 'SCREEN_TOP', 'screen bottom '// & + 'must be less tha screen top. '// & trim(cgwfnode)) end if ! ! -- connection skin hydraulic conductivity - if (this%ieqn(n) == 2 .OR. this%ieqn(n) == 3 .OR. & + if (this%ieqn(n) == 2 .OR. this%ieqn(n) == 3 .OR. & this%ieqn(n) == 4) then if (this%hk(jpos) <= DZERO) then - call this%maw_set_attribute_error(n, 'HK_SKIN', 'skin hyraulic ' // & - 'conductivity must be greater ' // & - 'than zero. ' // trim(cgwfnode)) + call this%maw_set_attribute_error(n, 'HK_SKIN', 'skin hyraulic '// & + 'conductivity must be greater '// & + 'than zero. '//trim(cgwfnode)) end if else if (this%ieqn(n) == 0) then ! ! -- saturated conductance if (this%satcond(jpos) < DZERO) then - call this%maw_set_attribute_error(n, 'HK_SKIN', & - 'skin hyraulic conductivity ' // & - 'must be greater than or ' // & - 'equal to zero when using ' // & - 'SPECIFIED condeqn. ' // & + call this%maw_set_attribute_error(n, 'HK_SKIN', & + 'skin hyraulic conductivity '// & + 'must be greater than or '// & + 'equal to zero when using '// & + 'SPECIFIED condeqn. '// & trim(cgwfnode)) - end if + end if end if idx = idx + 1 end do @@ -1648,7 +1650,7 @@ subroutine maw_ac(this, moffset, sparse) ! ------------------------------------------------------------------------------ use SparseModule, only: sparsematrix ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: moffset type(sparsematrix), intent(inout) :: sparse ! -- local @@ -1688,7 +1690,7 @@ subroutine maw_mc(this, moffset, iasln, jasln) use SparseModule, only: sparsematrix use MemoryManagerModule, only: mem_allocate ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: moffset integer(I4B), dimension(:), intent(in) :: iasln integer(I4B), dimension(:), intent(in) :: jasln @@ -1704,11 +1706,14 @@ subroutine maw_mc(this, moffset, iasln, jasln) ! ------------------------------------------------------------------------------ ! ! -- allocate connection mapping vectors - call mem_allocate(this%idxlocnode, this%nmawwells, 'IDXLOCNODE', this%memoryPath) + call mem_allocate(this%idxlocnode, this%nmawwells, 'IDXLOCNODE', & + this%memoryPath) call mem_allocate(this%idxdglo, this%maxbound, 'IDXDGLO', this%memoryPath) - call mem_allocate(this%idxoffdglo, this%maxbound, 'IDXOFFDGLO', this%memoryPath) - call mem_allocate(this%idxsymdglo, this%maxbound, 'IDXSYMDGLO', this%memoryPath) - call mem_allocate(this%idxsymoffdglo, this%maxbound, 'IDXSYMOFFDGLO', & + call mem_allocate(this%idxoffdglo, this%maxbound, 'IDXOFFDGLO', & + this%memoryPath) + call mem_allocate(this%idxsymdglo, this%maxbound, 'IDXSYMDGLO', & + this%memoryPath) + call mem_allocate(this%idxsymoffdglo, this%maxbound, 'IDXSYMOFFDGLO', & this%memoryPath) ! ! -- Find the position of each connection in the global ia, ja structure @@ -1723,7 +1728,7 @@ subroutine maw_mc(this, moffset, iasln, jasln) j = this%get_gwfnode(n, ii) jglo = j + moffset searchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then + if (jglo == jasln(jj)) then this%idxdglo(ipos) = iasln(iglo) this%idxoffdglo(ipos) = jj exit searchloop @@ -1739,7 +1744,7 @@ subroutine maw_mc(this, moffset, iasln, jasln) iglo = this%get_gwfnode(n, ii) + moffset jglo = moffset + this%dis%nodes + this%ioffset + n symsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then + if (jglo == jasln(jj)) then this%idxsymdglo(ipos) = iasln(iglo) this%idxsymoffdglo(ipos) = jj exit symsearchloop @@ -1755,7 +1760,7 @@ end subroutine maw_mc subroutine maw_read_options(this, option, found) ! ****************************************************************************** -! maw_read_options -- set options specific to MawType. +! maw_read_options -- set options specific to MawType. ! Overrides BndType%bnd_options ! ****************************************************************************** ! @@ -1765,119 +1770,119 @@ subroutine maw_read_options(this, option, found) use OpenSpecModule, only: access, form use InputOutputModule, only: urword, getunit, openfile ! -- dummy - class(MawType), intent(inout) :: this + class(MawType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local character(len=MAXCHARLEN) :: fname, keyword ! -- formats - character(len=*),parameter :: fmtflowingwells = & - "(4x, 'FLOWING WELLS WILL BE SIMULATED.')" - character(len=*),parameter :: fmtshutdown = & - "(4x, 'SHUTDOWN ', a, ' VALUE (',g15.7,') SPECIFIED.')" - character(len=*),parameter :: fmtnostoragewells = & - "(4x, 'WELL STORAGE WILL NOT BE SIMULATED.')" - character(len=*),parameter :: fmtmawbin = & - "(4x, 'MAW ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, & + character(len=*), parameter :: fmtflowingwells = & + &"(4x, 'FLOWING WELLS WILL BE SIMULATED.')" + character(len=*), parameter :: fmtshutdown = & + &"(4x, 'SHUTDOWN ', a, ' VALUE (',g15.7,') SPECIFIED.')" + character(len=*), parameter :: fmtnostoragewells = & + &"(4x, 'WELL STORAGE WILL NOT BE SIMULATED.')" + character(len=*), parameter :: fmtmawbin = & + "(4x, 'MAW ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, & &'OPENED ON UNIT: ', I0)" ! ------------------------------------------------------------------------------ ! ! -- Check for 'FLOWING_WELLS' and set this%iflowingwells select case (option) - case ('PRINT_HEAD') - this%iprhed = 1 - write(this%iout,'(4x,a)') & - trim(adjustl(this%text)) // ' heads will be printed to listing file.' + case ('PRINT_HEAD') + this%iprhed = 1 + write (this%iout, '(4x,a)') & + trim(adjustl(this%text))//' heads will be printed to listing file.' + found = .true. + case ('HEAD') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%iheadout = getunit() + call openfile(this%iheadout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtmawbin) 'HEAD', fname, this%iheadout found = .true. - case('HEAD') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%iheadout = getunit() - call openfile(this%iheadout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtmawbin) 'HEAD', fname, this%iheadout - found = .true. - else - call store_error('Optional maw stage keyword must be ' // & - 'followed by fileout.') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtmawbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('Optional maw budget keyword must be ' // & - 'followed by fileout.') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtmawbin) 'BUDGET CSV', fname, this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case('FLOWING_WELLS') - this%iflowingwells = 1 - write(this%iout, fmtflowingwells) - found = .true. - case('SHUTDOWN_THETA') - this%theta = this%parser%GetDouble() - write(this%iout, fmtshutdown) 'THETA', this%theta - found = .true. - case('SHUTDOWN_KAPPA') - this%kappa = this%parser%GetDouble() - write(this%iout, fmtshutdown) 'KAPPA', this%kappa - found = .true. - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case('NO_WELL_STORAGE') - this%imawissopt = 1 - write(this%iout, fmtnostoragewells) - found = .true. - case('FLOW_CORRECTION') - this%correct_flow = .TRUE. - write(this%iout, '(4x,a,/,4x,a)') & - 'MAW-GWF FLOW CORRECTIONS WILL BE APPLIED WHEN MAW HEADS ARE BELOW', & - 'OR GWF HEADS IN CONNECTED CELLS ARE BELOW THE CELL BOTTOM.' + else + call store_error('Optional maw stage keyword must be '// & + 'followed by fileout.') + end if + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtmawbin) 'BUDGET', fname, this%ibudgetout found = .true. - case('MAW_FLOW_REDUCE_CSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - call this%maw_redflow_csv_init(fname) - else - call store_error('OPTIONAL MAW_FLOW_REDUCE_CSV KEYWORD MUST BE & - &FOLLOWED BY FILEOUT') - end if + else + call store_error('Optional maw budget keyword must be '// & + 'followed by fileout.') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtmawbin) 'BUDGET CSV', fname, this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case ('FLOWING_WELLS') + this%iflowingwells = 1 + write (this%iout, fmtflowingwells) + found = .true. + case ('SHUTDOWN_THETA') + this%theta = this%parser%GetDouble() + write (this%iout, fmtshutdown) 'THETA', this%theta + found = .true. + case ('SHUTDOWN_KAPPA') + this%kappa = this%parser%GetDouble() + write (this%iout, fmtshutdown) 'KAPPA', this%kappa + found = .true. + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case ('NO_WELL_STORAGE') + this%imawissopt = 1 + write (this%iout, fmtnostoragewells) + found = .true. + case ('FLOW_CORRECTION') + this%correct_flow = .TRUE. + write (this%iout, '(4x,a,/,4x,a)') & + 'MAW-GWF FLOW CORRECTIONS WILL BE APPLIED WHEN MAW HEADS ARE BELOW', & + 'OR GWF HEADS IN CONNECTED CELLS ARE BELOW THE CELL BOTTOM.' + found = .true. + case ('MAW_FLOW_REDUCE_CSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + call this%maw_redflow_csv_init(fname) + else + call store_error('OPTIONAL MAW_FLOW_REDUCE_CSV KEYWORD MUST BE & + &FOLLOWED BY FILEOUT') + end if ! ! -- right now these are options that are only available in the ! development version and are not included in the documentation. ! These options are only available when IDEVELOPMODE in ! constants module is set to 1 - case('DEV_PEACEMAN_EFFECTIVE_RADIUS') - call this%parser%DevOpt() - this%ieffradopt = 1 - write(this%iout, '(4x,a)') & - & 'EFFECTIVE RADIUS FOR STRUCTURED GRIDS WILL BE CALCULATED ' // & - & 'USING PEACEMAN 1983' - found = .true. - case default - ! - ! -- No options found - found = .false. + case ('DEV_PEACEMAN_EFFECTIVE_RADIUS') + call this%parser%DevOpt() + this%ieffradopt = 1 + write (this%iout, '(4x,a)') & + 'EFFECTIVE RADIUS FOR STRUCTURED GRIDS WILL BE CALCULATED & + &USING PEACEMAN 1983' + found = .true. + case default + ! + ! -- No options found + found = .false. end select ! ! -- return @@ -1885,19 +1890,19 @@ subroutine maw_read_options(this, option, found) end subroutine maw_read_options subroutine maw_ar(this) - ! ****************************************************************************** - ! maw_ar -- Allocate and Read - ! Subroutine: (1) create new-style package - ! (2) point bndobj to the new package - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - ! -- dummy - class(MawType),intent(inout) :: this - ! -- local - ! -- format - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! maw_ar -- Allocate and Read + ! Subroutine: (1) create new-style package + ! (2) point bndobj to the new package + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + ! -- dummy + class(MawType), intent(inout) :: this + ! -- local + ! -- format + ! ------------------------------------------------------------------------------ ! call this%obs%obs_ar() ! @@ -1914,7 +1919,7 @@ subroutine maw_ar(this) ! ! -- setup pakmvrobj if (this%imover /= 0) then - allocate(this%pakmvrobj) + allocate (this%pakmvrobj) call this%pakmvrobj%ar(this%nmawwells, this%nmawwells, this%memoryPath) end if ! @@ -1922,7 +1927,6 @@ subroutine maw_ar(this) return end subroutine maw_ar - subroutine maw_rp(this) ! ****************************************************************************** ! maw_rp -- Read and Prepare @@ -1935,12 +1939,12 @@ subroutine maw_rp(this) use ConstantsModule, only: LINELENGTH use TdisModule, only: kper, nper ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: line character(len=LINELENGTH) :: text - character (len=16) :: csteady + character(len=16) :: csteady logical :: isfound logical :: endOfBlock integer(I4B) :: ierr @@ -1954,10 +1958,10 @@ subroutine maw_rp(this) integer(I4B) :: jpos integer(I4B) :: iheadlimit_warning ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" ! ------------------------------------------------------------------------------ ! ! -- initialize counters @@ -1976,7 +1980,7 @@ subroutine maw_rp(this) ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- get stress period data if (this%ionper < kper) then @@ -1984,7 +1988,7 @@ subroutine maw_rp(this) ! -- get period block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -1997,22 +2001,22 @@ subroutine maw_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg, terminate=.TRUE.) end if end if end if ! ! -- Read data if ionper == kper - if(this%ionper == kper) then + if (this%ionper == kper) then ! ! -- setup table for period data if (this%iprpak /= 0) then ! ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') DATA FOR PERIOD' + write (title, '(a,1x,i6)') trim(adjustl(title)), kper call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(1, 5, this%iout, finalize=.FALSE.) text = 'NUMBER' @@ -2020,7 +2024,7 @@ subroutine maw_rp(this) text = 'KEYWORD' call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) do n = 1, 3 - write(text, '(a,1x,i6)') 'VALUE', n + write (text, '(a,1x,i6)') 'VALUE', n call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) end do end if @@ -2033,8 +2037,8 @@ subroutine maw_rp(this) imaw = this%parser%GetInteger() if (imaw < 1 .or. imaw > this%nmawwells) then - write(errmsg,'(2(a,1x),i0,a)') & - 'IMAW must be greater than 0 and', & + write (errmsg, '(2(a,1x),i0,a)') & + 'IMAW must be greater than 0 and', & 'less than or equal to ', this%nmawwells, '.' call store_error(errmsg) cycle @@ -2052,17 +2056,17 @@ subroutine maw_rp(this) if (this%iprpak /= 0) then call this%inputtab%finalize_table() end if - ! - ! -- using data from the last stress period + ! + ! -- using data from the last stress period else - write(this%iout,fmtlsp) trim(this%filtyp) + write (this%iout, fmtlsp) trim(this%filtyp) end if ! ! -- issue warning messages if (iheadlimit_warning > 0) then - write(warnmsg, '(a,a,a,1x,a,1x,a)') & - "HEAD_LIMIT in '", trim(this%packName),"' was below the well bottom", & - "for one or more multi-aquifer well(s). This may result in", & + write (warnmsg, '(a,a,a,1x,a,1x,a)') & + "HEAD_LIMIT in '", trim(this%packName), "' was below the well bottom", & + "for one or more multi-aquifer well(s). This may result in", & "convergence failures for some models." call store_warning(warnmsg, substring=warnmsg(:50)) end if @@ -2085,23 +2089,23 @@ subroutine maw_rp(this) end if ! ! -- reset the input table object for rate data - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') ' // trim(adjustl(csteady)) // & + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') '//trim(adjustl(csteady))// & ' RATE DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + write (title, '(a,1x,i6)') trim(adjustl(title)), kper ntabcols = 6 call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(this%nmawwells, ntabcols, this%iout) text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) text = 'STATUS' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'RATE' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'SPECIFIED HEAD' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'PUMP ELEVATION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'REDUCTION LENGTH' call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) do n = 1, this%nmawwells @@ -2125,10 +2129,10 @@ subroutine maw_rp(this) if (this%iflowingwells > 0) then ! ! -- reset the input table object for flowing well data - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') ' // trim(adjustl(csteady)) // & + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') '//trim(adjustl(csteady))// & ' FLOWING WELL DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + write (title, '(a,1x,i6)') trim(adjustl(title)), kper ntabcols = 4 ntabrows = 0 do n = 1, this%nmawwells @@ -2140,11 +2144,11 @@ subroutine maw_rp(this) call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(ntabrows, ntabcols, this%iout) text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) text = 'ELEVATION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'CONDUCT.' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'REDUCTION LENGTH' call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) do n = 1, this%nmawwells @@ -2159,10 +2163,10 @@ subroutine maw_rp(this) end if ! ! -- reset the input table object for shutoff data - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') '// trim(adjustl(csteady)) // & + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') '//trim(adjustl(csteady))// & ' WELL SHUTOFF DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + write (title, '(a,1x,i6)') trim(adjustl(title)), kper ntabcols = 4 ntabrows = 0 do n = 1, this%nmawwells @@ -2174,11 +2178,11 @@ subroutine maw_rp(this) call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(ntabrows, ntabcols, this%iout) text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) text = 'ELEVATION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'MINIMUM. Q' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) text = 'MAXIMUM Q' call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) do n = 1, this%nmawwells @@ -2200,13 +2204,13 @@ subroutine maw_rp(this) jpos = this%get_jpos(n, j) node = this%get_gwfnode(n, j) this%nodelist(ibnd) = node - this%bound(1,ibnd) = this%xnewpak(n) - this%bound(2,ibnd) = this%satcond(jpos) - this%bound(3,ibnd) = this%botscrn(jpos) + this%bound(1, ibnd) = this%xnewpak(n) + this%bound(2, ibnd) = this%satcond(jpos) + this%bound(3, ibnd) = this%botscrn(jpos) if (this%iboundpak(n) > 0) then - this%bound(4,ibnd) = this%rate(n) + this%bound(4, ibnd) = this%rate(n) else - this%bound(4,ibnd) = DZERO + this%bound(4, ibnd) = DZERO end if ibnd = ibnd + 1 end do @@ -2223,7 +2227,7 @@ subroutine maw_ad(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use TdisModule, only : kper, kstp + use TdisModule, only: kper, kstp ! -- dummy class(MawType) :: this ! -- local @@ -2263,7 +2267,7 @@ subroutine maw_ad(this) ! !--use the appropriate xoldsto if intial heads are above the ! specified flowing well discharge elevation - if (kper==1 .and. kstp==1) then + if (kper == 1 .and. kstp == 1) then do n = 1, this%nmawwells if (this%fwcond(n) > DZERO) then if (this%xoldsto(n) > this%fwelev(n)) then @@ -2277,7 +2281,7 @@ subroutine maw_ad(this) this%ishutoffcnt = 0 ! ! -- pakmvrobj ad - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%ad() end if ! @@ -2291,20 +2295,20 @@ subroutine maw_ad(this) end subroutine maw_ad subroutine maw_cf(this, reset_mover) - ! ****************************************************************************** - ! maw_cf -- Formulate the HCOF and RHS terms - ! Subroutine: (1) skip if no multi-aquifer wells - ! (2) calculate hcof and rhs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! maw_cf -- Formulate the HCOF and RHS terms + ! Subroutine: (1) skip if no multi-aquifer wells + ! (2) calculate hcof and rhs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ ! -- dummy class(MawType) :: this logical, intent(in), optional :: reset_mover ! -- local logical :: lrm - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ ! ! -- Calculate maw conductance and update package RHS and HCOF call this%maw_cfupdate() @@ -2312,7 +2316,7 @@ subroutine maw_cf(this, reset_mover) ! -- pakmvrobj cf lrm = .true. if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then + if (this%imover == 1 .and. lrm) then call this%pakmvrobj%cf() end if ! @@ -2364,7 +2368,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) ! -------------------------------------------------------------------------- ! ! -- pakmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() end if ! @@ -2424,12 +2428,12 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) ! ! -- If mover is active, add receiver water to rhs and ! store available water (as positive value) - if(this%imover == 1) then + if (this%imover == 1) then rhs(iloc) = rhs(iloc) - this%pakmvrobj%get_qfrommvr(n) ! ! -- add pumping rate to mover if not injection if (rate < 0) then - call this%pakmvrobj%accumulate_qformvr(n, -rate) !pumped water + call this%pakmvrobj%accumulate_qformvr(n, -rate) !pumped water end if ! ! -- add flowing well flow to mover @@ -2446,7 +2450,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) hgwf = this%xnew(igwfnode) ! ! -- calculate connection terms - call this%maw_calculate_conn_terms(n, j, icflow, cmaw, cterm, term, & + call this%maw_calculate_conn_terms(n, j, icflow, cmaw, cterm, term, & flow) this%simcond(jpos) = cmaw ! @@ -2467,7 +2471,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) amatsln(ipossymd) = amatsln(ipossymd) - term amatsln(ipossymoffd) = term ! - ! -- add correction term to gwf row + ! -- add correction term to gwf row rhs(isymnode) = rhs(isymnode) + cterm end if ! @@ -2541,7 +2545,7 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) rate = this%ratesim(n) ! !-- calculate final derivative for pumping rate - call this%maw_calculate_wellq(n, hmaw+DEM4, rate2) + call this%maw_calculate_wellq(n, hmaw + DEM4, rate2) drterm = (rate2 - rate) / DEM4 ! !-- fill amat and rhs with newton-raphson terms @@ -2569,7 +2573,7 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) drterm = -(cfw + this%fwcond(n) * derv * (hmaw - bt)) ! ! -- fill amat and rhs with newton-raphson terms - amatsln(iposd) = amatsln(iposd) - & + amatsln(iposd) = amatsln(iposd) - & this%fwcond(n) * derv * (hmaw - bt) rhs(iloc) = rhs(iloc) - rterm + drterm * hmaw end if @@ -2595,7 +2599,7 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) ipossymoffd = this%idxsymoffdglo(idx) ! ! -- calculate newton terms - call this%maw_calculate_conn_terms(n, j, icflow, cmaw, cterm, term, & + call this%maw_calculate_conn_terms(n, j, icflow, cmaw, cterm, term, & flow, term2) ! ! -- maw is upstream @@ -2618,8 +2622,8 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) amatsln(ipossymoffd) = amatsln(ipossymoffd) - term end if end if - ! - ! -- gwf is upstream + ! + ! -- gwf is upstream else if (icflow /= 0) then rhsterm = term2 * hmaw + term * hgwf @@ -2651,7 +2655,6 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) return end subroutine maw_fn - subroutine maw_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) ! ****************************************************************************** ! maw_nur -- under-relaxation @@ -2687,7 +2690,7 @@ subroutine maw_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) ! solution head is below the bottom of the well if (x(n) < botw) then inewtonur = 1 - xx = xtemp(n)*(DONE-DP9) + botw*DP9 + xx = xtemp(n) * (DONE - DP9) + botw * DP9 dxx = x(n) - xx if (abs(dxx) > abs(dxmax)) then locmax = n @@ -2848,10 +2851,10 @@ subroutine maw_ot_package_flows(this, icbcfl, ibudfl) ! ! -- write the flows from the budobj ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & pertim, totim, this%iout) @@ -2861,7 +2864,7 @@ subroutine maw_ot_package_flows(this, icbcfl, ibudfl) if (ibudfl /= 0 .and. this%iprflow /= 0) then call this%budobj%write_flowtable(this%dis, kstp, kper) end if - + end subroutine maw_ot_package_flows subroutine maw_ot_dv(this, idvsave, idvprint) @@ -2878,10 +2881,10 @@ subroutine maw_ot_dv(this, idvsave, idvprint) ! ! -- set unit number for binary dependent variable output ibinun = 0 - if(this%iheadout /= 0) then + if (this%iheadout /= 0) then ibinun = this%iheadout end if - if(idvsave == 0) ibinun = 0 + if (idvsave == 0) ibinun = 0 ! ! -- write maw binary output if (ibinun > 0) then @@ -2895,45 +2898,45 @@ subroutine maw_ot_dv(this, idvsave, idvprint) end if this%dbuff(n) = v end do - call ulasav(this%dbuff, ' HEAD', & - kstp, kper, pertim, totim, & + call ulasav(this%dbuff, ' HEAD', & + kstp, kper, pertim, totim, & this%nmawwells, 1, 1, ibinun) end if - ! - ! -- write maw head table - if (idvprint /= 0 .and. this%iprhed /= 0) then + ! + ! -- write maw head table + if (idvprint /= 0 .and. this%iprhed /= 0) then ! ! -- set table kstp and kper call this%headtab%set_kstpkper(kstp, kper) ! ! -- fill stage data do n = 1, this%nmawwells - if(this%inamedbound==1) then + if (this%inamedbound == 1) then call this%headtab%add_term(this%cmawname(n)) end if call this%headtab%add_term(n) call this%headtab%add_term(this%xnewpak(n)) end do - end if - + end if + end subroutine maw_ot_dv - + subroutine maw_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- module use TdisModule, only: totim ! -- dummy - class(MawType) :: this !< MawType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + class(MawType) :: this !< MawType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written ! call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) ! ! -- return return end subroutine maw_ot_bdsummary - + subroutine maw_da(this) ! ****************************************************************************** ! maw_da -- deallocate @@ -2951,14 +2954,14 @@ subroutine maw_da(this) ! ! -- budobj call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) + deallocate (this%budobj) + nullify (this%budobj) ! ! -- head table if (this%iprhed > 0) then call this%headtab%table_da() - deallocate(this%headtab) - nullify(this%headtab) + deallocate (this%headtab) + nullify (this%headtab) end if ! ! -- character arrays @@ -3049,7 +3052,7 @@ subroutine maw_da(this) call mem_deallocate(this%idense) ! ! -- pointers to gwf variables - nullify(this%gwfiss) + nullify (this%gwfiss) ! ! -- call standard BndType deallocate call this%BndType%bnd_da() @@ -3070,27 +3073,26 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' end if - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' end if ! ! -- return return end subroutine define_listlabel - subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package @@ -3123,7 +3125,8 @@ subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) iend = istart + this%nmawwells - 1 this%iboundpak => this%ibound(istart:iend) this%xnewpak => this%xnew(istart:iend) - call mem_checkin(this%xnewpak, 'HEAD', this%memoryPath, 'X', this%memoryPathModel) + call mem_checkin(this%xnewpak, 'HEAD', this%memoryPath, 'X', & + this%memoryPathModel) call mem_allocate(this%xoldpak, this%nmawwells, 'XOLDPAK', this%memoryPath) ! ! -- initialize xnewpak @@ -3137,35 +3140,34 @@ end subroutine maw_set_pointers ! ! -- Procedures related to observations (type-bound) logical function maw_obs_supported(this) - ! ****************************************************************************** - ! maw_obs_supported - ! -- Return true because MAW package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! maw_obs_supported + ! -- Return true because MAW package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ class(MawType) :: this - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ maw_obs_supported = .true. return end function maw_obs_supported - subroutine maw_df_obs(this) - ! ****************************************************************************** - ! maw_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by MAW package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! maw_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by MAW package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ ! -- dummy class(MawType) :: this ! -- local integer(I4B) :: indx - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ ! ! -- Store obs type and assign procedure pointer ! for head observation type. @@ -3225,7 +3227,6 @@ subroutine maw_df_obs(this) return end subroutine maw_df_obs - subroutine maw_bd_obs(this) ! ************************************************************************** ! maw_bd_obs @@ -3260,95 +3261,95 @@ subroutine maw_bd_obs(this) v = DNODATA jj = obsrv%indxbnds(j) select case (obsrv%ObsTypeId) - case ('HEAD') - if (this%iboundpak(jj) /= 0) then - v = this%xnewpak(jj) + case ('HEAD') + if (this%iboundpak(jj) /= 0) then + v = this%xnewpak(jj) + end if + case ('FROM-MVR') + if (this%iboundpak(jj) /= 0) then + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(jj) end if - case ('FROM-MVR') - if (this%iboundpak(jj) /= 0) then + end if + case ('MAW') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + v = this%qleak(jj) + end if + case ('RATE') + if (this%iboundpak(jj) /= 0) then + v = this%ratesim(jj) + if (v < DZERO .and. this%qout(jj) < DZERO) then + qfact = v / this%qout(jj) if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(jj) + v = v + this%pakmvrobj%get_qtomvr(jj) * qfact end if end if - case ('MAW') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - v = this%qleak(jj) - end if - case ('RATE') - if (this%iboundpak(jj) /= 0) then + end if + case ('RATE-TO-MVR') + if (this%iboundpak(jj) /= 0) then + if (this%imover == 1) then v = this%ratesim(jj) + qfact = DZERO if (v < DZERO .and. this%qout(jj) < DZERO) then qfact = v / this%qout(jj) - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qtomvr(jj) * qfact - end if + end if + v = this%pakmvrobj%get_qtomvr(jj) * qfact + if (v > DZERO) then + v = -v end if end if - case ('RATE-TO-MVR') - if (this%iboundpak(jj) /= 0) then + end if + case ('FW-RATE') + if (this%iboundpak(jj) /= 0 .and. this%iflowingwells > 0) then + hmaw = this%xnewpak(jj) + cmaw = this%fwcondsim(jj) + v = cmaw * (this%fwelev(jj) - hmaw) + if (v < DZERO .and. this%qout(jj) < DZERO) then + qfact = v / this%qout(jj) if (this%imover == 1) then - v = this%ratesim(jj) - qfact = DZERO - if (v < DZERO .and. this%qout(jj) < DZERO) then - qfact = v / this%qout(jj) - end if - v = this%pakmvrobj%get_qtomvr(jj) * qfact - if (v > DZERO) then - v = -v - end if + v = v + this%pakmvrobj%get_qtomvr(jj) * qfact end if end if - case ('FW-RATE') - if (this%iboundpak(jj) /= 0 .and. this%iflowingwells > 0) then + end if + case ('FW-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%iflowingwells > 0) then + if (this%imover == 1) then hmaw = this%xnewpak(jj) cmaw = this%fwcondsim(jj) v = cmaw * (this%fwelev(jj) - hmaw) + qfact = DZERO if (v < DZERO .and. this%qout(jj) < DZERO) then qfact = v / this%qout(jj) - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qtomvr(jj) * qfact - end if end if - end if - case ('FW-TO-MVR') - if (this%iboundpak(jj) /= 0 .and. this%iflowingwells > 0) then - if (this%imover == 1) then - hmaw = this%xnewpak(jj) - cmaw = this%fwcondsim(jj) - v = cmaw * (this%fwelev(jj) - hmaw) - qfact = DZERO - if (v < DZERO .and. this%qout(jj) < DZERO) then - qfact = v / this%qout(jj) - end if - v = this%pakmvrobj%get_qtomvr(jj) * qfact - if (v > DZERO) then - v = -v - end if + v = this%pakmvrobj%get_qtomvr(jj) * qfact + if (v > DZERO) then + v = -v end if end if - case ('STORAGE') - if (this%iboundpak(jj) /= 0 .and. this%imawissopt /= 1) then - v = this%qsto(jj) - end if - case ('CONSTANT') - if (this%iboundpak(jj) /= 0) then - v = this%qconst(jj) - end if - case ('CONDUCTANCE') - n = this%imap(jj) - if (this%iboundpak(n) /= 0) then - nn = jj - this%iaconn(n) + 1 - jpos = this%get_jpos(n, nn) - v = this%simcond(jpos) - end if - case ('FW-CONDUCTANCE') - if (this%iboundpak(jj) /= 0) then - v = this%fwcondsim(jj) - end if - case default - errmsg = 'Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(errmsg) + end if + case ('STORAGE') + if (this%iboundpak(jj) /= 0 .and. this%imawissopt /= 1) then + v = this%qsto(jj) + end if + case ('CONSTANT') + if (this%iboundpak(jj) /= 0) then + v = this%qconst(jj) + end if + case ('CONDUCTANCE') + n = this%imap(jj) + if (this%iboundpak(n) /= 0) then + nn = jj - this%iaconn(n) + 1 + jpos = this%get_jpos(n, nn) + v = this%simcond(jpos) + end if + case ('FW-CONDUCTANCE') + if (this%iboundpak(jj) /= 0) then + v = this%fwcondsim(jj) + end if + case default + errmsg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId) + call store_error(errmsg) end select call this%obs%SaveOneSimval(obsrv, v) end do @@ -3369,7 +3370,6 @@ subroutine maw_bd_obs(this) return end subroutine maw_bd_obs - subroutine maw_rp_obs(this) use TdisModule, only: kper ! -- dummy @@ -3383,11 +3383,11 @@ subroutine maw_rp_obs(this) integer(I4B) :: jj character(len=LENBOUNDNAME) :: bname logical :: jfound - class(ObserveType), pointer :: obsrv => null() + class(ObserveType), pointer :: obsrv => null() ! -------------------------------------------------------------------------- ! -- formats -10 format('Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') +10 format('Boundary "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') ! ! -- process each package observation ! only done the first stress period since boundaries are fixed @@ -3405,10 +3405,10 @@ subroutine maw_rp_obs(this) ! Iterate through all multi-aquifer wells to identify and store ! corresponding index in bound array. jfound = .false. - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then + if (obsrv%ObsTypeId == 'MAW' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE') then do j = 1, this%nmawwells - do jj = this%iaconn(j), this%iaconn(j+1) - 1 + do jj = this%iaconn(j), this%iaconn(j + 1) - 1 if (this%boundname(jj) == bname) then jfound = .true. call obsrv%AddObsIndex(jj) @@ -3424,14 +3424,15 @@ subroutine maw_rp_obs(this) end do end if if (.not. jfound) then - write(errmsg,10) trim(bname), trim(obsrv%Name), trim(this%packName) + write (errmsg, 10) & + trim(bname), trim(obsrv%Name), trim(this%packName) call store_error(errmsg) end if end if else if (obsrv%indxbnds_count == 0) then - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then + if (obsrv%ObsTypeId == 'MAW' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE') then nn2 = obsrv%NodeNumber2 j = this%iaconn(nn1) + nn2 - 1 call obsrv%AddObsIndex(j) @@ -3448,38 +3449,38 @@ subroutine maw_rp_obs(this) ! by a boundname that is assigned to more than one element if (obsrv%ObsTypeId == 'HEAD') then if (obsrv%indxbnds_count > 1) then - write (errmsg, '(a,3(1x,a))') & - trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & + write (errmsg, '(a,3(1x,a))') & + trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & 'must be assigned to a multi-aquifer well with a unique boundname.' call store_error(errmsg) end if end if ! ! -- check that index values are valid - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then + if (obsrv%ObsTypeId == 'MAW' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE') then do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) n = this%imap(nn1) nn2 = nn1 - this%iaconn(n) + 1 - jj = this%iaconn(n+1) - this%iaconn(n) + jj = this%iaconn(n + 1) - this%iaconn(n) if (nn1 < 1 .or. nn1 > this%maxbound) then - write (errmsg, '(3(a,1x),i0,1x,a,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - 'multi-aquifer well connection number must be greater than 0', & + write (errmsg, '(3(a,1x),i0,1x,a,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + 'multi-aquifer well connection number must be greater than 0', & 'and less than', jj, '(specified value is ', nn2, ').' call store_error(errmsg) end if end do else do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > this%nmawwells) then - write (errmsg, '(3(a,1x),i0,1x,a,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - 'multi-aquifer well must be greater than 0 ', & - 'and less than or equal to', this%nmawwells, & + write (errmsg, '(3(a,1x),i0,1x,a,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + 'multi-aquifer well must be greater than 0 ', & + 'and less than or equal to', this%nmawwells, & '(specified value is ', nn1, ').' call store_error(errmsg) end if @@ -3497,17 +3498,16 @@ subroutine maw_rp_obs(this) return end subroutine maw_rp_obs - ! ! -- Procedures related to observations (NOT type-bound) subroutine maw_process_obsID(obsrv, dis, inunitobs, iout) ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes ! the ID string of an observation definition for MAW package observations. ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1, nn2 integer(I4B) :: icol, istart, istop @@ -3525,15 +3525,15 @@ subroutine maw_process_obsID(obsrv, dis, inunitobs, iout) if (nn1 == NAMEDBOUNDFLAG) then obsrv%FeatureName = bndname else - if (obsrv%ObsTypeId=='MAW' .or. & - obsrv%ObsTypeId=='CONDUCTANCE') then + if (obsrv%ObsTypeId == 'MAW' .or. & + obsrv%ObsTypeId == 'CONDUCTANCE') then call extract_idnum_or_bndname(strng, icol, istart, istop, nn2, bndname) if (len_trim(bndName) < 1 .and. nn2 < 0) then - write(errmsg, '(a,1x,a,a,1x,a,1x,a)') & - 'For observation type', trim(adjustl(obsrv%ObsTypeId)), & - ', ID given as an integer and not as boundname,', & - 'but ID2 (icon) is missing. Either change ID to valid', & - 'boundname or supply valid entry for ID2.' + write (errmsg, '(a,1x,a,a,1x,a,1x,a)') & + 'For observation type', trim(adjustl(obsrv%ObsTypeId)), & + ', ID given as an integer and not as boundname,', & + 'but ID2 (icon) is missing. Either change ID to valid', & + 'boundname or supply valid entry for ID2.' call store_error(errmsg) end if if (nn2 == NAMEDBOUNDFLAG) then @@ -3561,20 +3561,20 @@ subroutine maw_redflow_csv_init(this, fname) class(MawType), intent(inout) :: this !< MawType object character(len=*), intent(in) :: fname ! -- format - character(len=*),parameter :: fmtredflowcsv = & + character(len=*), parameter :: fmtredflowcsv = & "(4x, 'MAW REDUCED FLOW INFORMATION WILL BE SAVED TO FILE: ', a, /4x, & &'OPENED ON UNIT: ', I0)" - + this%ioutredflowcsv = getunit() call openfile(this%ioutredflowcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtredflowcsv) trim(adjustl(fname)), & - this%ioutredflowcsv - write(this%ioutredflowcsv, '(a)') & + filstat_opt='REPLACE') + write (this%iout, fmtredflowcsv) trim(adjustl(fname)), & + this%ioutredflowcsv + write (this%ioutredflowcsv, '(a)') & 'time,period,step,MAWnumber,rate-requested,rate-actual,maw-reduction' return end subroutine maw_redflow_csv_init - + !> @brief MAW reduced flows only when & where they occur subroutine maw_redflow_csv_write(this) ! -- modules @@ -3590,20 +3590,20 @@ subroutine maw_redflow_csv_write(this) do n = 1, this%nmawwells ! ! -- test if node is constant or inactive - if(this%status(n) .ne. 'ACTIVE') then + if (this%status(n) .ne. 'ACTIVE') then cycle end if v = this%rate(n) - this%ratesim(n) !reductions in extraction will be negative and reductions in injection will be positive; follows convention of WEL AUTO_FLOW_REDUCE_CSV - if (abs(v) > DEM9) then !need to check absolute value of difference for both extraction and injection; using 1e-9 as epsilon value but could be tweaked - write(this%ioutredflowcsv,'(*(G0,:,","))') & + if (abs(v) > DEM9) then !need to check absolute value of difference for both extraction and injection; using 1e-9 as epsilon value but could be tweaked + write (this%ioutredflowcsv, '(*(G0,:,","))') & totim, kper, kstp, n, this%rate(n), this%ratesim(n), v end if - enddo + end do end subroutine maw_redflow_csv_write - + subroutine maw_calculate_satcond(this, i, j, node) ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: i integer(I4B), intent(in) :: j integer(I4B), intent(in) :: node @@ -3661,7 +3661,7 @@ subroutine maw_calculate_satcond(this, i, j, node) ! -- set gwftop, gwfbot, and gwfsat gwftop = this%dis%top(node) gwfbot = this%dis%bot(node) - tthka = gwftop - gwfbot + tthka = gwftop - gwfbot gwfsat = this%gwfsat(node) ! ! -- set top and bottom of well screen @@ -3687,9 +3687,10 @@ subroutine maw_calculate_satcond(this, i, j, node) Tyy = k22 * tthka dx = sqrt(this%dis%area(node)) dy = dx - yx4 = (Tyy/Txx)**DQUARTER - xy4 = (Txx/Tyy)**DQUARTER - eradius = 0.28_DP * ((yx4*dx)**DTWO + (xy4*dy)**DTWO)**DHALF / (yx4+xy4) + yx4 = (Tyy / Txx)**DQUARTER + xy4 = (Txx / Tyy)**DQUARTER + eradius = 0.28_DP * ((yx4 * dx)**DTWO + & + (xy4 * dy)**DTWO)**DHALF / (yx4 + xy4) else area = this%dis%area(node) eradius = sqrt(area / (DEIGHT * DPI)) @@ -3709,17 +3710,17 @@ subroutine maw_calculate_satcond(this, i, j, node) skin = (Tcontrast - DONE) * log(this%sradius(jpos) / this%radius(i)) ! ! -- trap invalid transmissvity contrast if using skin equation (2). - ! Not trapped for cumulative Thiem and skin equations (3) - ! because the MNW2 package allowed this condition (for - ! backward compatibility with the MNW2 package for + ! Not trapped for cumulative Thiem and skin equations (3) + ! because the MNW2 package allowed this condition (for + ! backward compatibility with the MNW2 package for ! MODFLOW-2005, MODFLOW-NWT, and MODFLOW-USG). if (Tcontrast <= 1 .and. this%ieqn(i) == 2) then iTcontrastErr = 1 - write(errmsg, '(a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & - 'Invalid calculated transmissivity contrast (', Tcontrast, & - ') for maw well', i, 'connection', j, '.', 'This happens when the', & + write (errmsg, '(a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & + 'Invalid calculated transmissivity contrast (', Tcontrast, & + ') for maw well', i, 'connection', j, '.', 'This happens when the', & 'skin transmissivity equals or exceeds the aquifer transmissivity.', & - 'Consider decreasing HK_SKIN for the connection or using the', & + 'Consider decreasing HK_SKIN for the connection or using the', & 'CUMULATIVE or MEAN conductance equations.' call store_error(errmsg) else @@ -3727,7 +3728,7 @@ subroutine maw_calculate_satcond(this, i, j, node) end if end if end if - ! -- conductance using screen elevations, hk, well radius, + ! -- conductance using screen elevations, hk, well radius, ! and screen radius if (this%ieqn(i) == 4) then hks = this%hk(jpos) @@ -3737,7 +3738,7 @@ subroutine maw_calculate_satcond(this, i, j, node) c = hks * pavg * tthkw / slen end if ! - ! -- calculate final conductance for Theim (1), Skin (2), and + ! -- calculate final conductance for Theim (1), Skin (2), and ! and cumulative Thiem and skin equations (3) if (this%ieqn(i) < 4) then if (lc1 + lc2 /= DZERO) then @@ -3750,11 +3751,11 @@ subroutine maw_calculate_satcond(this, i, j, node) ! -- ensure that the conductance is not negative. Only write error message ! if error condition has not occured for skin calculations (LC2) if (c < DZERO .and. iTcontrastErr == 0) then - write(errmsg, '(a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & - 'Invalid calculated negative conductance (', c, & - ') for maw well', i, 'connection', j, '.', 'this happens when the', & - 'skin transmissivity equals or exceeds the aquifer transmissivity.', & - 'consider decreasing hk_skin for the connection or using the', & + write (errmsg, '(a,g0,a,1x,i0,1x,a,1x,i0,a,4(1x,a))') & + 'Invalid calculated negative conductance (', c, & + ') for maw well', i, 'connection', j, '.', 'this happens when the', & + 'skin transmissivity equals or exceeds the aquifer transmissivity.', & + 'consider decreasing hk_skin for the connection or using the', & 'mean conductance equation.' call store_error(errmsg) end if @@ -3766,10 +3767,9 @@ subroutine maw_calculate_satcond(this, i, j, node) return end subroutine maw_calculate_satcond - subroutine maw_calculate_saturation(this, n, j, node, sat) ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: n integer(I4B), intent(in) :: j integer(I4B), intent(in) :: node @@ -3827,12 +3827,12 @@ subroutine maw_calculate_saturation(this, n, j, node, sat) ! -- return return end subroutine maw_calculate_saturation - - subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & + + subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & flow, term2) ! ****************************************************************************** ! maw_calculate_conn_terms-- Calculate matrix terms for a multi-aquifer well -! connection. Terms for fc and fn methods are +! connection. Terms for fc and fn methods are ! calculated based on whether term2 is passed ! ! -- Arguments are as follows: @@ -3948,8 +3948,8 @@ subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & term = drterm * this%satcond(jpos) * (hbar - hmaw) dhbarterm = sQuadratic0spDerivative(hgwf, en, this%satomega) term2 = cmaw * (dhbarterm - DONE) - ! - ! -- gwf is upstream + ! + ! -- gwf is upstream else hbar = sQuadratic0sp(hmaw, en, this%satomega) term = -drterm * this%satcond(jpos) * (hgwf - hbar) @@ -3973,10 +3973,10 @@ subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & ! ! -- add density part here if (this%idense /= 0 .and. inewton == 0) then - call this%maw_calculate_density_exchange(jpos, hmaw, hgwf, cmaw, & - bmaw, flow, term, cterm) - end if - + call this%maw_calculate_density_exchange(jpos, hmaw, hgwf, cmaw, & + bmaw, flow, term, cterm) + end if + ! ! -- return return @@ -4014,7 +4014,7 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) if (rate < DZERO) then ! ! -- If well shut off is activated, then turn off well if necessary, - ! or if shut off is not activated then check to see if rate scaling + ! or if shut off is not activated then check to see if rate scaling ! is on. if (this%shutofflevel(n) /= DEP20) then call this%maw_calculate_qpot(n, q) @@ -4031,14 +4031,14 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) weight = this%shutoffweight(n) ! ! -- for flip-flop condition, decrease factor - if ( this%shutoffdq(n) * dq < DZERO ) then + if (this%shutoffdq(n) * dq < DZERO) then weight = this%theta * this%shutoffweight(n) - ! - ! -- when change is of same sign, increase factor + ! + ! -- when change is of same sign, increase factor else weight = this%shutoffweight(n) + this%kappa end if - if ( weight > DONE ) weight = DONE + if (weight > DONE) weight = DONE q = this%shutoffqold(n) + weight * dq @@ -4046,7 +4046,7 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) this%shutoffdq(n) = dq this%shutoffweight(n) = weight ! - ! -- If shutoffmin and shutoffmax are specified then apply + ! -- If shutoffmin and shutoffmax are specified then apply ! additional checks for when to shut off the well. if (this%shutoffmin(n) > DZERO) then if (hmaw < this%shutofflevel(n)) then @@ -4055,8 +4055,8 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) ! -- well is shutoff if (this%ishutoff(n) /= 0) then q = DZERO - ! - ! --- well is not shut off + ! + ! --- well is not shut off else ! -- turn off well if q is less than the minimum rate and ! reset the ishutoff flag if at least on iteration 3 @@ -4065,13 +4065,13 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) this%ishutoff(n) = 1 end if q = DZERO - ! - ! -- leave well on and use the specified rate - ! or the potential rate + ! + ! -- leave well on and use the specified rate + ! or the potential rate end if end if - ! - ! -- try to use the specified rate or the potential rate + ! + ! -- try to use the specified rate or the potential rate else if (q > this%shutoffmax(n)) then if (this%ishutoffcnt <= 2) then @@ -4089,8 +4089,8 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) else scale = DONE ! - ! -- Apply rate scaling by reducing pumpage when hmaw is less than the - ! sum of maw pump elevation (pumpelev) and the specified reduction + ! -- Apply rate scaling by reducing pumpage when hmaw is less than the + ! sum of maw pump elevation (pumpelev) and the specified reduction ! length. The rate will go to zero as hmaw drops to the pump ! elevation. if (this%reduction_length(n) /= DEP20) then @@ -4100,7 +4100,7 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) end if q = scale * rate end if - ! + ! else ! ! -- Handle the injection case (rate > 0) differently than extraction. @@ -4121,25 +4121,25 @@ subroutine maw_calculate_wellq(this, n, hmaw, q) weight = this%shutoffweight(n) ! ! -- for flip-flop condition, decrease factor - if ( this%shutoffdq(n) * dq < DZERO ) then + if (this%shutoffdq(n) * dq < DZERO) then weight = this%theta * this%shutoffweight(n) - ! - ! -- when change is of same sign, increase factor + ! + ! -- when change is of same sign, increase factor else weight = this%shutoffweight(n) + this%kappa end if - if ( weight > DONE ) weight = DONE - + if (weight > DONE) weight = DONE + q = this%shutoffqold(n) + weight * dq - + this%shutoffqold(n) = q this%shutoffdq(n) = dq this%shutoffweight(n) = weight - + else scale = DONE ! - ! -- Apply rate scaling for an injection well by reducting the + ! -- Apply rate scaling for an injection well by reducting the ! injection rate as hmaw rises above the pump elevation. The rate ! will approach zero as hmaw approaches pumpelev + reduction_length. if (this%reduction_length(n) /= DEP20) then @@ -4162,9 +4162,9 @@ subroutine maw_calculate_qpot(this, n, qnet) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use TdisModule,only:delt + use TdisModule, only: delt ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: n real(DP), intent(inout) :: qnet ! -- local @@ -4238,72 +4238,72 @@ subroutine maw_calculate_qpot(this, n, qnet) end subroutine maw_calculate_qpot subroutine maw_cfupdate(this) - ! ****************************************************************************** - ! maw_cfupdate -- Update MAW satcond and package rhs and hcof - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - class(MawType) :: this - ! -- dummy - ! -- local - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: jpos - integer(I4B) :: icflow - integer(I4B) :: ibnd - real(DP) :: flow - real(DP) :: cmaw - real(DP) :: hmaw - real(DP) :: cterm - real(DP) :: term + ! ****************************************************************************** + ! maw_cfupdate -- Update MAW satcond and package rhs and hcof + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + class(MawType) :: this + ! -- dummy + ! -- local + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: jpos + integer(I4B) :: icflow + integer(I4B) :: ibnd + real(DP) :: flow + real(DP) :: cmaw + real(DP) :: hmaw + real(DP) :: cterm + real(DP) :: term ! ------------------------------------------------------------------------------ - ! - ! -- Return if no maw wells - if(this%nbound.eq.0) return - ! - ! -- Update shutoff count - this%ishutoffcnt = this%ishutoffcnt + 1 - ! - ! -- Calculate hcof and rhs for each maw entry - ibnd = 1 - do n = 1, this%nmawwells - hmaw = this%xnewpak(n) - do j = 1, this%ngwfnodes(n) - jpos = this%get_jpos(n, j) - this%hcof(ibnd) = DZERO - this%rhs(ibnd) = DZERO - ! - ! -- set bound, hcof, and rhs components - ! - ! -- use connection method so the gwf-maw budget flows - ! are consistent with the maw-gwf budget flows - if (this%iboundpak(n) == 0) then - cmaw = DZERO - term = DZERO - cterm = DZERO - else - call this%maw_calculate_conn_terms(n, j, icflow, cmaw, cterm, & - term, flow) - end if - this%simcond(jpos) = cmaw - this%bound(2,ibnd) = cmaw - this%hcof(ibnd) = -term - this%rhs(ibnd) = -term * hmaw + cterm - ! - ! -- increment boundary number - ibnd = ibnd + 1 - end do + ! + ! -- Return if no maw wells + if (this%nbound .eq. 0) return + ! + ! -- Update shutoff count + this%ishutoffcnt = this%ishutoffcnt + 1 + ! + ! -- Calculate hcof and rhs for each maw entry + ibnd = 1 + do n = 1, this%nmawwells + hmaw = this%xnewpak(n) + do j = 1, this%ngwfnodes(n) + jpos = this%get_jpos(n, j) + this%hcof(ibnd) = DZERO + this%rhs(ibnd) = DZERO + ! + ! -- set bound, hcof, and rhs components + ! + ! -- use connection method so the gwf-maw budget flows + ! are consistent with the maw-gwf budget flows + if (this%iboundpak(n) == 0) then + cmaw = DZERO + term = DZERO + cterm = DZERO + else + call this%maw_calculate_conn_terms(n, j, icflow, cmaw, cterm, & + term, flow) + end if + this%simcond(jpos) = cmaw + this%bound(2, ibnd) = cmaw + this%hcof(ibnd) = -term + this%rhs(ibnd) = -term * hmaw + cterm + ! + ! -- increment boundary number + ibnd = ibnd + 1 end do - ! - ! -- Return - return + end do + ! + ! -- Return + return end subroutine maw_cfupdate subroutine maw_setup_budobj(this) ! ****************************************************************************** ! maw_setup_budobj -- Set up the budget object that stores all the maw flows -! The terms listed here must correspond in number and order to the ones +! The terms listed here must correspond in number and order to the ones ! listed in the maw_fill_budobj routine. ! ****************************************************************************** ! @@ -4323,8 +4323,8 @@ subroutine maw_setup_budobj(this) character(len=LENBUDTXT), dimension(1) :: auxtxt ! ------------------------------------------------------------------------------ ! - ! -- Determine the number of maw budget terms. These are fixed for - ! the simulation and cannot change. + ! -- Determine the number of maw budget terms. These are fixed for + ! the simulation and cannot change. ! gwf rate [flowing_well] storage constant_flow [frommvr tomvr tomvrcf [tomvrfw]] [aux] nbudterm = 4 if (this%iflowingwells > 0) then @@ -4346,10 +4346,10 @@ subroutine maw_setup_budobj(this) ! ! -- Go through and set up each budget term ! - ! -- + ! -- text = ' GWF' idx = idx + 1 - maxlist = this%maxbound + maxlist = this%maxbound naux = 1 auxtxt(1) = ' FLOW-AREA' call this%budobj%budterm(idx)%initialize(text, & @@ -4368,20 +4368,20 @@ subroutine maw_setup_budobj(this) end do end do ! - ! -- + ! -- text = ' RATE' idx = idx + 1 maxlist = this%nmawwells naux = 0 call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! - ! -- + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- if (this%iflowingwells > 0) then text = ' FW-RATE' idx = idx + 1 @@ -4396,10 +4396,10 @@ subroutine maw_setup_budobj(this) naux) end if ! - ! -- + ! -- text = ' STORAGE' idx = idx + 1 - maxlist = this%nmawwells + maxlist = this%nmawwells naux = 1 auxtxt(1) = ' VOLUME' call this%budobj%budterm(idx)%initialize(text, & @@ -4410,7 +4410,7 @@ subroutine maw_setup_budobj(this) maxlist, .false., .true., & naux, auxtxt) ! - ! -- + ! -- text = ' CONSTANT' idx = idx + 1 maxlist = this%nmawwells @@ -4423,10 +4423,10 @@ subroutine maw_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- if (this%imover == 1) then ! - ! -- + ! -- text = ' FROM-MVR' idx = idx + 1 maxlist = this%nmawwells @@ -4439,7 +4439,7 @@ subroutine maw_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' RATE-TO-MVR' idx = idx + 1 maxlist = this%nmawwells @@ -4465,10 +4465,10 @@ subroutine maw_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- if (this%iflowingwells > 0) then ! - ! -- + ! -- text = ' FW-RATE-TO-MVR' idx = idx + 1 maxlist = this%nmawwells @@ -4483,11 +4483,11 @@ subroutine maw_setup_budobj(this) end if end if ! - ! -- + ! -- naux = this%naux if (naux > 0) then ! - ! -- + ! -- text = ' AUXILIARY' idx = idx + 1 maxlist = this%maxbound @@ -4706,7 +4706,7 @@ subroutine maw_fill_budobj(this) call this%budobj%budterm(idx)%update_term(n, n, q) end do end if - + end if ! ! -- AUXILIARY VARIABLES @@ -4729,9 +4729,9 @@ end subroutine maw_fill_budobj subroutine maw_setup_tableobj(this) ! ****************************************************************************** -! maw_setup_tableobj -- Set up the table object that is used to write the maw -! head data. The terms listed here must correspond in -! number and order to the ones written to the head table +! maw_setup_tableobj -- Set up the table object that is used to write the maw +! head data. The terms listed here must correspond in +! number and order to the ones written to the head table ! in the maw_ot method. ! ****************************************************************************** ! @@ -4755,12 +4755,12 @@ subroutine maw_setup_tableobj(this) if (this%inamedbound == 1) nterms = nterms + 1 ! ! -- set up table title - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') HEADS FOR EACH CONTROL VOLUME' + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') HEADS FOR EACH CONTROL VOLUME' ! ! -- set up head tableobj call table_cr(this%headtab, this%packName, title) - call this%headtab%table_df(this%nmawwells, nterms, this%iout, & + call this%headtab%table_df(this%nmawwells, nterms, this%iout, & transient=.TRUE.) ! ! -- Go through and set up table budget term @@ -4838,7 +4838,7 @@ subroutine maw_activate_density(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this ! -- local integer(I4B) :: i, j ! -- formats @@ -4853,17 +4853,17 @@ subroutine maw_activate_density(this) this%denseterms(j, i) = DZERO end do end do - write(this%iout,'(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR MAW & - &PACKAGE: ' // trim(adjustl(this%packName)) + write (this%iout, '(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR MAW & + &PACKAGE: '//trim(adjustl(this%packName)) ! ! -- return return end subroutine maw_activate_density - subroutine maw_calculate_density_exchange(this, iconn, hmaw, hgwf, cond, & + subroutine maw_calculate_density_exchange(this, iconn, hmaw, hgwf, cond, & bmaw, flow, hcofterm, rhsterm) ! ****************************************************************************** -! maw_calculate_density_exchange -- Calculate the groundwater-maw density +! maw_calculate_density_exchange -- Calculate the groundwater-maw density ! exchange terms. ! ! -- Arguments are as follows: @@ -4881,7 +4881,7 @@ subroutine maw_calculate_density_exchange(this, iconn, hmaw, hgwf, cond, & ! col 1 is relative density of maw (densemaw / denseref) ! col 2 is relative density of gwf cell (densegwf / denseref) ! col 3 is elevation of gwf cell -! +! ! -- Upon return, amat and rhs for maw row should be updated as: ! amat(idiag) = amat(idiag) - hcofterm ! rhs(n) = rhs(n) + rhsterm @@ -4891,7 +4891,7 @@ subroutine maw_calculate_density_exchange(this, iconn, hmaw, hgwf, cond, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(MawType),intent(inout) :: this + class(MawType), intent(inout) :: this integer(I4B), intent(in) :: iconn real(DP), intent(in) :: hmaw real(DP), intent(in) :: hgwf diff --git a/src/Model/GroundWaterFlow/gwf3mvr8.f90 b/src/Model/GroundWaterFlow/gwf3mvr8.f90 index 6ab11693b35..54e80e4b3ec 100644 --- a/src/Model/GroundWaterFlow/gwf3mvr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3mvr8.f90 @@ -2,7 +2,7 @@ !This module contains a derived type, called GwfMvrType, that !is attached to the GWF model. The water mover can be used to move water !between packages. The mover requires that mover-aware packages have access -!to four arrays: qtformvr, qformvr, qtomvr, and qfrommvr. These arrays are +!to four arrays: qtformvr, qformvr, qtomvr, and qfrommvr. These arrays are !stored and managed by a separate PackageMoverType object. qformvr is a !vector of volumetric flow rates available for the mover. The package !must fill the vector (dimensioned by number of reaches) with the available @@ -49,11 +49,11 @@ ! ! if(this%inmvr > 0) call this%mvr%mvr_ar() ! -! Mover aware packages allocate the four vectors. The first three +! Mover aware packages allocate the four vectors. The first three ! (qtformvr, qformvr, qtomvr) are allocated to the number of providers ! and the last one (qfrommvr) is allocated to the number of receivers. ! -! 4. In gwf_rp call the RP method for the mover. This reads the +! 4. In gwf_rp call the RP method for the mover. This reads the ! movers active for the current period. ! ! if(this%inmvr > 0) call this%mvr%mvr_rp() @@ -81,8 +81,8 @@ ! if(this%inmvr > 0) call this%mvr%mvr_fc() ! called from gwf%gwf_fc() ! ! a. Mover aware packages first set qformvr(:) = 0. -! b. Mover aware packages that are receivers (MAW, SFR, LAK, UZF) add -! qfrommvr terms to their individual control volume equations as a +! b. Mover aware packages that are receivers (MAW, SFR, LAK, UZF) add +! qfrommvr terms to their individual control volume equations as a ! source of water. ! c. Mover aware packages calculate qformvr as amount of water available ! to be moved (these qformvr terms are used in the next iteration @@ -102,46 +102,46 @@ ! if(this%inmvr > 0) call this%mvr%mvr_ot() ! module GwfMvrModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMEMPATH, LENPACKAGENAME, LENMODELNAME, & - LENBUDTXT, LENAUXNAME, LENPAKLOC, & - DZERO, DNODATA, MAXCHARLEN, TABCENTER, & - LINELENGTH - use MvrModule, only: MvrType - use BudgetModule, only: BudgetType, budget_cr - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMEMPATH, LENPACKAGENAME, LENMODELNAME, & + LENBUDTXT, LENAUXNAME, LENPAKLOC, & + DZERO, DNODATA, MAXCHARLEN, TABCENTER, & + LINELENGTH + use MvrModule, only: MvrType + use BudgetModule, only: BudgetType, budget_cr + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType + use BlockParserModule, only: BlockParserType use GwfMvrPeriodDataModule, only: GwfMvrPeriodDataType - use PackageMoverModule, only: PackageMoverType - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: urword - use TableModule, only: TableType, table_cr + use PackageMoverModule, only: PackageMoverType + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: urword + use TableModule, only: TableType, table_cr implicit none private public :: GwfMvrType, mvr_cr type, extends(NumericalPackageType) :: GwfMvrType - integer(I4B), pointer :: ibudgetout => null() !< binary budget output file - integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file - integer(I4B), pointer :: maxmvr => null() !< max number of movers to be specified - integer(I4B), pointer :: maxpackages => null() !< max number of packages to be specified - integer(I4B), pointer :: maxcomb => null() !< max number of combination of packages - integer(I4B), pointer :: nmvr => null() !< number of movers for current stress period - integer(I4B), pointer :: iexgmvr => null() !< indicate mover is for an exchange (not for a single model) - integer(I4B), pointer :: imodelnames => null() !< indicate package input file has model names in it - integer(I4B), dimension(:), pointer, contiguous :: ientries => null() !< number of entries for each combination - character(len=LENMEMPATH), & - dimension(:), pointer, contiguous :: pckMemPaths !< memory paths of all packages used in this mover - character(len=LENPACKAGENAME), & - dimension(:), pointer, contiguous :: paknames => null() !< array of package names - type(MvrType), dimension(:), pointer, contiguous :: mvr => null() !< array of movers - type(GwfMvrPeriodDataType), pointer :: gwfmvrperioddata => null() !< input data object - type(BudgetType), pointer :: budget => null() !< mover budget object (used to write table) - type(BudgetObjectType), pointer :: budobj => null() !< new budget container (used to write binary file) - type(PackageMoverType), & - dimension(:), pointer, contiguous :: pakmovers => null() !< pointer to package mover objects + integer(I4B), pointer :: ibudgetout => null() !< binary budget output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + integer(I4B), pointer :: maxmvr => null() !< max number of movers to be specified + integer(I4B), pointer :: maxpackages => null() !< max number of packages to be specified + integer(I4B), pointer :: maxcomb => null() !< max number of combination of packages + integer(I4B), pointer :: nmvr => null() !< number of movers for current stress period + integer(I4B), pointer :: iexgmvr => null() !< indicate mover is for an exchange (not for a single model) + integer(I4B), pointer :: imodelnames => null() !< indicate package input file has model names in it + integer(I4B), dimension(:), pointer, contiguous :: ientries => null() !< number of entries for each combination + character(len=LENMEMPATH), & + dimension(:), pointer, contiguous :: pckMemPaths !< memory paths of all packages used in this mover + character(len=LENPACKAGENAME), & + dimension(:), pointer, contiguous :: paknames => null() !< array of package names + type(MvrType), dimension(:), pointer, contiguous :: mvr => null() !< array of movers + type(GwfMvrPeriodDataType), pointer :: gwfmvrperioddata => null() !< input data object + type(BudgetType), pointer :: budget => null() !< mover budget object (used to write table) + type(BudgetObjectType), pointer :: budobj => null() !< new budget container (used to write binary file) + type(PackageMoverType), & + dimension(:), pointer, contiguous :: pakmovers => null() !< pointer to package mover objects ! ! -- table objects type(TableType), pointer :: outputtab => null() @@ -171,7 +171,7 @@ module GwfMvrModule procedure, private :: mvr_print_outputtab end type GwfMvrType - contains +contains subroutine mvr_cr(mvrobj, name_parent, inunit, iout, dis, iexgmvr) ! ****************************************************************************** @@ -190,7 +190,7 @@ subroutine mvr_cr(mvrobj, name_parent, inunit, iout, dis, iexgmvr) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(mvrobj) + allocate (mvrobj) ! ! -- create name and memory paths. name_parent will either be model name or the ! exchange name. @@ -207,7 +207,7 @@ subroutine mvr_cr(mvrobj, name_parent, inunit, iout, dis, iexgmvr) mvrobj%iout = iout ! ! -- Set iexgmvr - if(present(iexgmvr)) mvrobj%iexgmvr = iexgmvr + if (present(iexgmvr)) mvrobj%iexgmvr = iexgmvr ! ! -- Create the budget object if (inunit > 0) then @@ -215,7 +215,7 @@ subroutine mvr_cr(mvrobj, name_parent, inunit, iout, dis, iexgmvr) ! ! -- Initialize block parser call mvrobj%parser%Initialize(mvrobj%inunit, mvrobj%iout) - endif + end if ! ! -- instantiate the budget object call budgetobject_cr(mvrobj%budobj, 'WATER MOVER') @@ -238,9 +238,9 @@ subroutine mvr_ar(this) ! ------------------------------------------------------------------------------ ! ! -- Print a message identifying the water mover package. - write(this%iout, 1) this%inunit - 1 format(1x,/1x,'MVR -- WATER MOVER PACKAGE, VERSION 8, 1/29/2016', & - ' INPUT READ FROM UNIT ', i0) + write (this%iout, 1) this%inunit +1 format(1x, /1x, 'MVR -- WATER MOVER PACKAGE, VERSION 8, 1/29/2016', & + ' INPUT READ FROM UNIT ', i0) ! ! -- Read and check options call this%read_options() @@ -282,7 +282,7 @@ subroutine mvr_rp(this) use SimModule, only: store_error, store_error_unit, count_errors use ArrayHandlersModule, only: ifind ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local integer(I4B) :: i, ierr, nlist, ipos integer(I4B) :: ii, jj @@ -290,10 +290,10 @@ subroutine mvr_rp(this) character(len=LINELENGTH) :: line, errmsg character(len=LENMODELNAME) :: mname ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" character(len=*), parameter :: fmtnbd = & "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & &') IS GREATER THAN MAXIMUM(',I6,')')" @@ -301,7 +301,7 @@ subroutine mvr_rp(this) ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- get stress period data if (this%ionper < kper) then @@ -309,7 +309,7 @@ subroutine mvr_rp(this) ! -- get period block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -322,25 +322,25 @@ subroutine mvr_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - endif + end if end if ! ! -- read data if ionper == kper - if(this%ionper == kper) then - write(this%iout, '(/,2x,a,i0)') 'READING WATER MOVERS FOR PERIOD ', kper + if (this%ionper == kper) then + write (this%iout, '(/,2x,a,i0)') 'READING WATER MOVERS FOR PERIOD ', kper nlist = -1 i = 1 ! ! -- set mname to '' if this is an exchange mover, or to the model name - if(this%iexgmvr == 0) then + if (this%iexgmvr == 0) then mname = this%name_model else mname = '' - endif + end if ! ! -- Assign a pointer to the package mover object. The pointer assignment ! will happen only the first time @@ -362,33 +362,33 @@ subroutine mvr_rp(this) call this%mvr(i)%prepare(this%parser%iuactive, & this%pckMemPaths, & this%pakmovers) - if(this%iprpak == 1) call this%mvr(i)%echo(this%iout) + if (this%iprpak == 1) call this%mvr(i)%echo(this%iout) end do - write(this%iout,'(/,1x,a,1x,i6,/)') 'END OF DATA FOR PERIOD', kper + write (this%iout, '(/,1x,a,1x,i6,/)') 'END OF DATA FOR PERIOD', kper ! ! -- Set the number of movers for this period to nlist this%nmvr = nlist - write(this%iout, '(4x, i0, a, i0)') this%nmvr, & + write (this%iout, '(4x, i0, a, i0)') this%nmvr, & ' MOVERS READ FOR PERIOD ', kper ! ! -- Check to make sure all providers and receivers are properly stored do i = 1, this%nmvr ipos = ifind(this%pckMemPaths, this%mvr(i)%pckNameSrc) - if(ipos < 1) then - write(errmsg,'(4x,a,a,a)') 'PROVIDER ', & + if (ipos < 1) then + write (errmsg, '(4x,a,a,a)') 'PROVIDER ', & trim(this%mvr(i)%pckNameSrc), ' NOT LISTED IN PACKAGES BLOCK.' call store_error(errmsg) - endif + end if ipos = ifind(this%pckMemPaths, this%mvr(i)%pckNameTgt) - if(ipos < 1) then - write(errmsg,'(4x,a,a,a)') 'RECEIVER ', & + if (ipos < 1) then + write (errmsg, '(4x,a,a,a)') 'RECEIVER ', & trim(this%mvr(i)%pckNameTgt), ' NOT LISTED IN PACKAGES BLOCK.' call store_error(errmsg) - endif - enddo - if(count_errors() > 0) then + end if + end do + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- reset ientries do i = 1, this%maxcomb @@ -403,9 +403,9 @@ subroutine mvr_rp(this) this%ientries(ipos) = this%ientries(ipos) + 1 end do else - write(this%iout, fmtlsp) 'MVR' + write (this%iout, fmtlsp) 'MVR' ! - endif + end if ! ! -- return return @@ -427,7 +427,7 @@ subroutine mvr_ad(this) ! do i = 1, this%nmvr call this%mvr(i)%advance() - enddo + end do ! ! -- Return return @@ -449,7 +449,7 @@ subroutine mvr_fc(this) ! do i = 1, this%nmvr call this%mvr(i)%fc() - enddo + end do ! ! -- Return return @@ -464,16 +464,16 @@ subroutine mvr_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! ------------------------------------------------------------------------------ ! -- dummy class(GwfMvrType) :: this - integer(I4B),intent(in) :: innertot - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod + integer(I4B), intent(in) :: innertot + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod character(len=LENPAKLOC), intent(inout) :: cpak integer(I4B), intent(inout) :: ipak real(DP), intent(inout) :: dpak ! -- local ! -- formats - character(len=*),parameter :: fmtmvrcnvg = & + character(len=*), parameter :: fmtmvrcnvg = & "(/,1x,'MOVER PACKAGE REQUIRES AT LEAST TWO OUTER ITERATIONS. CONVERGE & &FLAG HAS BEEN RESET TO FALSE.')" ! ------------------------------------------------------------------------------ @@ -483,14 +483,14 @@ subroutine mvr_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) if (icnvgmod == 1 .and. kiter == 1) then dpak = DNODATA cpak = trim(this%packName) - write(this%iout, fmtmvrcnvg) - endif - endif + write (this%iout, fmtmvrcnvg) + end if + end if ! ! -- return return end subroutine mvr_cc - + subroutine mvr_bd(this) ! ****************************************************************************** ! mvr_bd -- fill the mover budget object @@ -521,7 +521,7 @@ subroutine mvr_bdsav(this, icbcfl, ibudfl, isuppress_output) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only : kstp, kper, delt, pertim, totim + use TdisModule, only: kstp, kper, delt, pertim, totim use InputOutputModule, only: ubdsv06, ubdsvd ! -- dummy class(GwfMvrType) :: this @@ -532,7 +532,7 @@ subroutine mvr_bdsav(this, icbcfl, ibudfl, isuppress_output) integer(I4B) :: ibinun ! -- formats character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" + "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" ! ------------------------------------------------------------------------------ ! ! -- Print the mover flow table @@ -542,14 +542,14 @@ subroutine mvr_bdsav(this, icbcfl, ibudfl, isuppress_output) ! ! -- Save the mover flows from the budobj to a mover binary file ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (isuppress_output /= 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) + pertim, totim, this%iout) end if ! ! -- Return @@ -564,7 +564,7 @@ subroutine mvr_ot_saveflow(this, icbcfl, ibudfl) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only : kstp, kper, delt, pertim, totim + use TdisModule, only: kstp, kper, delt, pertim, totim ! -- dummy class(GwfMvrType) :: this integer(I4B), intent(in) :: icbcfl @@ -575,13 +575,13 @@ subroutine mvr_ot_saveflow(this, icbcfl, ibudfl) ! ! -- Save the mover flows from the budobj to a mover binary file ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) + pertim, totim, this%iout) end if ! ! -- Return @@ -632,34 +632,34 @@ subroutine mvr_ot_bdsummary(this, ibudfl) ! ------------------------------------------------------------------------------ ! ! -- Allocate and initialize ratin/ratout - allocate(ratin(this%maxpackages), ratout(this%maxpackages)) + allocate (ratin(this%maxpackages), ratout(this%maxpackages)) do j = 1, this%maxpackages ratin(j) = DZERO ratout(j) = DZERO - enddo + end do ! ! -- Accumulate the rates do i = 1, this%nmvr do j = 1, this%maxpackages - if(this%pckMemPaths(j) == this%mvr(i)%pckNameSrc) then + if (this%pckMemPaths(j) == this%mvr(i)%pckNameSrc) then ratin(j) = ratin(j) + this%mvr(i)%qpactual - endif - if(this%pckMemPaths(j) == this%mvr(i)%pckNameTgt) then + end if + if (this%pckMemPaths(j) == this%mvr(i)%pckNameTgt) then ratout(j) = ratout(j) + this%mvr(i)%qpactual - endif - enddo - enddo + end if + end do + end do ! ! -- Send rates to budget object call this%budget%reset() do j = 1, this%maxpackages - if((this%iexgmvr) == 1) then + if ((this%iexgmvr) == 1) then pckMemPath = this%pckMemPaths(j) else pckMemPath = this%paknames(j) - endif + end if call this%budget%addentry(ratin(j), ratout(j), delt, pckMemPath) - enddo + end do ! ! -- Write the budget if (ibudfl /= 0) then @@ -670,7 +670,7 @@ subroutine mvr_ot_bdsummary(this, ibudfl) call this%budget%writecsv(totim) ! ! -- Deallocate - deallocate(ratin, ratout) + deallocate (ratin, ratout) ! ! -- Output mvr budget ! Not using budobj write_table here because it would result @@ -700,32 +700,32 @@ subroutine mvr_da(this) ! -- Arrays if (this%inunit > 0) then call mem_deallocate(this%ientries) - deallocate(this%mvr) - deallocate(this%pckMemPaths) - deallocate(this%paknames) - deallocate(this%pakmovers) + deallocate (this%mvr) + deallocate (this%pckMemPaths) + deallocate (this%paknames) + deallocate (this%pakmovers) ! ! -- allocate the perioddata object call this%gwfmvrperioddata%destroy() - deallocate(this%gwfmvrperioddata) - nullify(this%gwfmvrperioddata) + deallocate (this%gwfmvrperioddata) + nullify (this%gwfmvrperioddata) ! ! -- budget object call this%budget%budget_da() - deallocate(this%budget) + deallocate (this%budget) ! ! -- budobj call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) + deallocate (this%budobj) + nullify (this%budobj) ! ! -- output table object if (associated(this%outputtab)) then call this%outputtab%table_da() - deallocate(this%outputtab) - nullify(this%outputtab) + deallocate (this%outputtab) + nullify (this%outputtab) end if - endif + end if ! ! -- Scalars call mem_deallocate(this%ibudgetout) @@ -764,77 +764,78 @@ subroutine read_options(this) integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*),parameter :: fmtmvrbin = & + character(len=*), parameter :: fmtmvrbin = & "(4x, 'MVR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON & &UNIT: ', I0)" ! ------------------------------------------------------------------------------ ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING MVR OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING MVR OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtmvrbin) 'BUDGET', fname, this%ibudgetout - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtmvrbin) 'BUDGET CSV', fname, this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'WATER MOVER INPUT '// & - 'WILL BE PRINTED TO LIST FILE.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') 'LISTS OF WATER MOVER FLOWS '// & - 'WILL BE PRINTED TO LIST FILE.' - case ('MODELNAMES') - this%imodelnames = 1 - write(this%iout,'(4x,a)') 'ALL PACKAGE NAMES ARE PRECEDED '// & - 'BY THE NAME OF THE MODEL CONTAINING THE PACKAGE.' - if (this%iexgmvr == 0) then - write(errmsg,'(4x,a,a)') & - 'MODELNAMES CANNOT BE SPECIFIED UNLESS THE ' // & - 'MOVER PACKAGE IS FOR AN EXCHANGE.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - case default - write(errmsg,'(4x,a,a)') 'Unknown MVR option: ', trim(keyword) + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write (this%iout, fmtmvrbin) 'BUDGET', fname, this%ibudgetout + else + call store_error('OPTIONAL BUDGET KEYWORD MUST & + &BE FOLLOWED BY FILEOUT') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtmvrbin) 'BUDGET CSV', fname, this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'WATER MOVER INPUT '// & + 'WILL BE PRINTED TO LIST FILE.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') 'LISTS OF WATER MOVER FLOWS '// & + 'WILL BE PRINTED TO LIST FILE.' + case ('MODELNAMES') + this%imodelnames = 1 + write (this%iout, '(4x,a)') 'ALL PACKAGE NAMES ARE PRECEDED '// & + 'BY THE NAME OF THE MODEL CONTAINING THE PACKAGE.' + if (this%iexgmvr == 0) then + write (errmsg, '(4x,a,a)') & + 'MODELNAMES CANNOT BE SPECIFIED UNLESS THE '// & + 'MOVER PACKAGE IS FOR AN EXCHANGE.' call store_error(errmsg) call this%parser%StoreErrorUnit() + end if + case default + write (errmsg, '(4x,a,a)') 'Unknown MVR option: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF MVR OPTIONS' + write (this%iout, '(1x,a)') 'END OF MVR OPTIONS' end if ! ! -- Return return - end subroutine read_options + end subroutine read_options subroutine check_options(this) ! ****************************************************************************** @@ -855,21 +856,21 @@ subroutine check_options(this) ! ! -- Check if not exchange mover but model names are specified if (this%iexgmvr == 0 .and. this%imodelnames == 1) then - write(errmsg,'(4x,a,a)') & - '****ERROR. MODELNAMES CANNOT BE SPECIFIED UNLESS THE ' // & + write (errmsg, '(4x,a,a)') & + '****ERROR. MODELNAMES CANNOT BE SPECIFIED UNLESS THE '// & 'MOVER PACKAGE IS FOR AN EXCHANGE.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Check if exchange mover but model names not specified if (this%iexgmvr /= 0 .and. this%imodelnames == 0) then - write(errmsg,'(4x,a,a)') & - '****ERROR. MODELNAMES OPTION MUST BE SPECIFIED BECAUSE ' // & + write (errmsg, '(4x,a,a)') & + '****ERROR. MODELNAMES OPTION MUST BE SPECIFIED BECAUSE '// & 'MOVER PACKAGE IS FOR AN EXCHANGE.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return @@ -886,9 +887,9 @@ subroutine read_dimensions(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg, keyword + character(len=LINELENGTH) :: errmsg, keyword integer(I4B) :: ierr logical :: isfound, endOfBlock integer(I4B) :: i @@ -902,26 +903,26 @@ subroutine read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING MVR DIMENSIONS' + write (this%iout, '(/1x,a)') 'PROCESSING MVR DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('MAXMVR') - this%maxmvr = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'MAXMVR = ', this%maxmvr - case ('MAXPACKAGES') - this%maxpackages = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'MAXPACKAGES = ', this%maxpackages - case default - write(errmsg,'(4x,a,a)') & - 'Unknown MVR dimension: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('MAXMVR') + this%maxmvr = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'MAXMVR = ', this%maxmvr + case ('MAXPACKAGES') + this%maxpackages = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'MAXPACKAGES = ', this%maxpackages + case default + write (errmsg, '(4x,a,a)') & + 'Unknown MVR dimension: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF MVR DIMENSIONS' + write (this%iout, '(1x,a)') 'END OF MVR DIMENSIONS' else call store_error('Required DIMENSIONS block not found.') call this%parser%StoreErrorUnit() @@ -936,18 +937,18 @@ subroutine read_dimensions(this) end do ! ! -- verify dimensions were set - if(this%maxmvr < 0) then - write(errmsg, '(1x,a)') & + if (this%maxmvr < 0) then + write (errmsg, '(1x,a)') & 'MAXMVR was not specified or was specified incorrectly.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - if(this%maxpackages < 0) then - write(errmsg, '(1x,a)') & + end if + if (this%maxpackages < 0) then + write (errmsg, '(1x,a)') & 'MAXPACKAGES was not specified or was specified incorrectly.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -965,9 +966,9 @@ subroutine read_packages(this) use MemoryHelperModule, only: create_mem_path use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg, word, word1, word2 + character(len=LINELENGTH) :: errmsg, word, word1, word2 integer(I4B) :: lloc, ierr integer(I4B) :: npak logical :: isfound, endOfBlock @@ -980,7 +981,7 @@ subroutine read_packages(this) ! ! -- parse packages block if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING MVR PACKAGES' + write (this%iout, '(/1x,a)') 'PROCESSING MVR PACKAGES' npak = 0 do call this%parser%GetNextLine(endOfBlock) @@ -991,8 +992,8 @@ subroutine read_packages(this) if (npak > this%maxpackages) then call store_error('ERROR. MAXPACKAGES NOT SET LARGE ENOUGH.') call this%parser%StoreErrorUnit() - endif - if(this%iexgmvr == 0) then + end if + if (this%iexgmvr == 0) then this%pckMemPaths(npak) = create_mem_path(this%name_model, word1) word = word1 else @@ -1000,25 +1001,25 @@ subroutine read_packages(this) call this%parser%GetStringCaps(word2) this%pckMemPaths(npak) = create_mem_path(this%pckMemPaths(npak), word2) word = word2 - endif + end if this%paknames(npak) = trim(word) - write(this%iout,'(3x,a,a)')'INCLUDING PACKAGE: ', & + write (this%iout, '(3x,a,a)') 'INCLUDING PACKAGE: ', & trim(this%pckMemPaths(npak)) end do - write(this%iout,'(1x,a)')'END OF MVR PACKAGES' + write (this%iout, '(1x,a)') 'END OF MVR PACKAGES' else call store_error('ERROR. REQUIRED PACKAGES BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() end if ! ! -- Check to make sure npak = this%maxpackages - if(npak /= this%maxpackages) then - write(errmsg, '(a, i0, a, i0, a)') & - 'ERROR. NUMBER OF PACKAGES (', npak, ') DOES NOT EQUAL ' // & + if (npak /= this%maxpackages) then + write (errmsg, '(a, i0, a, i0, a)') & + 'ERROR. NUMBER OF PACKAGES (', npak, ') DOES NOT EQUAL '// & 'MAXPACKAGES (', this%maxpackages, ').' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -1036,9 +1037,9 @@ subroutine check_packages(this) use MemoryManagerModule, only: mem_setptr use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: errmsg integer(I4B) :: i integer(I4B), pointer :: imover_ptr ! -- format @@ -1049,10 +1050,10 @@ subroutine check_packages(this) imover_ptr => null() call mem_setptr(imover_ptr, 'IMOVER', trim(this%pckMemPaths(i))) if (imover_ptr == 0) then - write(errmsg, '(a, a, a)') & - 'ERROR. MODEL AND PACKAGE "', & - trim(this%pckMemPaths(i)), & - '" DOES NOT HAVE MOVER SPECIFIED IN OPTIONS BLOCK.' + write (errmsg, '(a, a, a)') & + 'ERROR. MODEL AND PACKAGE "', & + trim(this%pckMemPaths(i)), & + '" DOES NOT HAVE MOVER SPECIFIED IN OPTIONS BLOCK.' call store_error(errmsg) end if end do @@ -1060,7 +1061,7 @@ subroutine check_packages(this) ! -- Terminate if errors detected. if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -1076,7 +1077,7 @@ subroutine assign_packagemovers(this) ! -- modules use PackageMoverModule, only: set_packagemover_pointer ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local integer(I4B) :: i ! -- format @@ -1133,7 +1134,7 @@ subroutine allocate_scalars(this) this%imodelnames = 0 ! ! -- allocate the period data input object - allocate(this%gwfmvrperioddata) + allocate (this%gwfmvrperioddata) ! ! -- Return return @@ -1157,10 +1158,10 @@ subroutine allocate_arrays(this) ! ------------------------------------------------------------------------------ ! ! -- Allocate - allocate(this%mvr(this%maxmvr)) - allocate(this%pckMemPaths(this%maxpackages)) - allocate(this%paknames(this%maxpackages)) - allocate(this%pakmovers(this%maxpackages)) + allocate (this%mvr(this%maxmvr)) + allocate (this%pckMemPaths(this%maxpackages)) + allocate (this%paknames(this%maxpackages)) + allocate (this%pakmovers(this%maxpackages)) ! ! -- nullify the pakmovers do i = 1, this%maxpackages @@ -1204,14 +1205,14 @@ subroutine mvr_setup_budobj(this) integer(I4B) :: i integer(I4B) :: j integer(I4B) :: naux - character (len=LENMODELNAME) :: modelname1, modelname2 - character (len=LENPACKAGENAME) :: packagename1, packagename2 + character(len=LENMODELNAME) :: modelname1, modelname2 + character(len=LENPACKAGENAME) :: packagename1, packagename2 integer(I4B) :: maxlist integer(I4B) :: idx character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- Determine the number of mover budget terms. These are fixed for + ! -- Determine the number of mover budget terms. These are fixed for ! the simulation and cannot change. A separate term is required ! for each possible provider/receiver combination. nbudterm = 0 @@ -1234,11 +1235,11 @@ subroutine mvr_setup_budobj(this) maxlist = this%maxmvr naux = 0 do i = 1, this%maxpackages - + call split_mem_path(this%pckMemPaths(i), modelname1, packagename1) - - do j = 1, this%maxpackages - + + do j = 1, this%maxpackages + idx = idx + 1 call split_mem_path(this%pckMemPaths(j), modelname2, packagename2) call this%budobj%budterm(idx)%initialize(text, & @@ -1277,9 +1278,9 @@ subroutine mvr_fill_budobj(this) integer(I4B) :: istart integer(I4B) :: istop real(DP) :: rval - character (len=LENMODELNAME) :: modelname1, modelname2 - character (len=LENPACKAGENAME) :: packagename1, packagename2 - character (len=LENMEMPATH) :: pckMemPathsDummy + character(len=LENMODELNAME) :: modelname1, modelname2 + character(len=LENPACKAGENAME) :: packagename1, packagename2 + character(len=LENMEMPATH) :: pckMemPathsDummy real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- @@ -1287,7 +1288,6 @@ subroutine mvr_fill_budobj(this) ! -- initialize counter idx = 0 - do i = 1, this%maxpackages ! -- Retrieve modelname1 and packagename1 lloc = 1 @@ -1300,10 +1300,12 @@ subroutine mvr_fill_budobj(this) do j = 1, this%maxpackages ! -- Retrieve modelname2 and packagename2 lloc = 1 - call urword(this%pckMemPaths(j), lloc, istart, istop, 1, ival, rval, -1, -1) + call urword(this%pckMemPaths(j), lloc, istart, istop, 1, ival, rval, & + -1, -1) pckMemPathsDummy = this%pckMemPaths(j) modelname2 = pckMemPathsDummy(istart:istop) - call urword(this%pckMemPaths(j), lloc, istart, istop, 1, ival, rval, -1, -1) + call urword(this%pckMemPaths(j), lloc, istart, istop, 1, ival, rval, & + -1, -1) pckMemPathsDummy = this%pckMemPaths(j) packagename2 = pckMemPathsDummy(istart:istop) ipos = (i - 1) * this%maxpackages + j @@ -1318,8 +1320,8 @@ subroutine mvr_fill_budobj(this) ! ! -- pname1 is provider, pname2 is receiver ! flow is always negative because it is coming from provider - if(this%pckMemPaths(i) == this%mvr(n)%pckNameSrc) then - if(this%pckMemPaths(j) == this%mvr(n)%pckNameTgt) then + if (this%pckMemPaths(i) == this%mvr(n)%pckNameSrc) then + if (this%pckMemPaths(j) == this%mvr(n)%pckNameTgt) then ! ! -- set q to qpactual q = -this%mvr(n)%qpactual @@ -1354,7 +1356,7 @@ subroutine mvr_setup_outputtab(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -1369,15 +1371,15 @@ subroutine mvr_setup_outputtab(this) ntabcol = 7 ! ! -- initialize the output table object - title = 'WATER MOVER PACKAGE (' // trim(this%packName) // & + title = 'WATER MOVER PACKAGE ('//trim(this%packName)// & ') FLOW RATES' call table_cr(this%outputtab, this%packName, title) - call this%outputtab%table_df(this%maxmvr, ntabcol, this%iout, & - transient=.TRUE.) + call this%outputtab%table_df(this%maxmvr, ntabcol, this%iout, & + transient=.TRUE.) text = 'NUMBER' call this%outputtab%initialize_column(text, 10, alignment=TABCENTER) text = 'PROVIDER LOCATION' - ilen = LENMODELNAME+LENPACKAGENAME+1 + ilen = LENMODELNAME + LENPACKAGENAME + 1 call this%outputtab%initialize_column(text, ilen) text = 'PROVIDER ID' call this%outputtab%initialize_column(text, 10) @@ -1386,11 +1388,11 @@ subroutine mvr_setup_outputtab(this) text = 'PROVIDED RATE' call this%outputtab%initialize_column(text, 10) text = 'RECEIVER LOCATION' - ilen = LENMODELNAME+LENPACKAGENAME+1 + ilen = LENMODELNAME + LENPACKAGENAME + 1 call this%outputtab%initialize_column(text, ilen) text = 'RECEIVER ID' call this%outputtab%initialize_column(text, 10) - + end if ! ! -- return @@ -1407,9 +1409,9 @@ subroutine mvr_print_outputtab(this) ! -- module use TdisModule, only: kstp, kper ! -- dummy - class(GwfMvrType),intent(inout) :: this + class(GwfMvrType), intent(inout) :: this ! -- local - character (len=LINELENGTH) :: title + character(len=LINELENGTH) :: title integer(I4B) :: i ! ------------------------------------------------------------------------------ ! @@ -1417,7 +1419,7 @@ subroutine mvr_print_outputtab(this) call this%outputtab%set_kstpkper(kstp, kper) ! ! -- Add terms and print the table - title = 'WATER MOVER PACKAGE (' // trim(this%packName) // & + title = 'WATER MOVER PACKAGE ('//trim(this%packName)// & ') FLOW RATES' call this%outputtab%set_title(title) call this%outputtab%set_maxbound(this%nmvr) diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index c9756115bbd..b7ad00283d8 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1,20 +1,20 @@ module GwfNpfModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM9, DEM8, DEM7, DEM6, DEM2, & - DHALF, DP9, DONE, DTWO, & - DLNLOW, DLNHIGH, & - DHNOFLO, DHDRY, DEM10 - use SmoothingModule, only: sQuadraticSaturation, & - sQuadraticSaturationDerivative - use NumericalPackageModule, only: NumericalPackageType - use GwfNpfGridDataModule, only: GwfNpfGridDataType - use GwfNpfOptionsModule, only: GwfNpfOptionsType - use BaseDisModule, only: DisBaseType - use GwfIcModule, only: GwfIcType - use Xt3dModule, only: Xt3dType - use BlockParserModule, only: BlockParserType - use InputOutputModule, only: GetUnit, openfile - use TvkModule, only: TvkType, tvk_cr + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DEM9, DEM8, DEM7, DEM6, DEM2, & + DHALF, DP9, DONE, DTWO, & + DLNLOW, DLNHIGH, & + DHNOFLO, DHDRY, DEM10 + use SmoothingModule, only: sQuadraticSaturation, & + sQuadraticSaturationDerivative + use NumericalPackageModule, only: NumericalPackageType + use GwfNpfGridDataModule, only: GwfNpfGridDataType + use GwfNpfOptionsModule, only: GwfNpfOptionsType + use BaseDisModule, only: DisBaseType + use GwfIcModule, only: GwfIcType + use Xt3dModule, only: Xt3dType + use BlockParserModule, only: BlockParserType + use InputOutputModule, only: GetUnit, openfile + use TvkModule, only: TvkType, tvk_cr implicit none @@ -29,117 +29,117 @@ module GwfNpfModule type, extends(NumericalPackageType) :: GwfNpfType - type(GwfIcType), pointer :: ic => null() !< initial conditions object - type(Xt3dType), pointer :: xt3d => null() !< xt3d pointer - integer(I4B), pointer :: iname => null() !< length of variable names - character(len=24), dimension(:), pointer :: aname => null() !< variable names - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - real(DP), dimension(:), pointer, contiguous :: hnew => null() !< pointer to model xnew - integer(I4B), pointer :: ixt3d => null() !< xt3d flag (0 is off, 1 is lhs, 2 is rhs) - integer(I4B), pointer :: iperched => null() !< vertical flow corrections if 1 - integer(I4B), pointer :: ivarcv => null() !< CV is function of water table - integer(I4B), pointer :: idewatcv => null() !< CV may be a discontinuous function of water table - integer(I4B), pointer :: ithickstrt => null() !< thickstrt option flag - integer(I4B), pointer :: igwfnewtonur => null() !< newton head dampening using node bottom option flag - integer(I4B), pointer :: iusgnrhc => null() !< MODFLOW-USG saturation calculation option flag - integer(I4B), pointer :: inwtupw => null() !< MODFLOW-NWT upstream weighting option flag - integer(I4B), pointer :: icalcspdis => null() !< Calculate specific discharge at cell centers - integer(I4B), pointer :: isavspdis => null() !< Save specific discharge at cell centers - integer(I4B), pointer :: isavsat => null() !< Save sat to budget file - real(DP), pointer :: hnoflo => null() !< default is 1.e30 - real(DP), pointer :: satomega => null() !< newton-raphson saturation omega - integer(I4B),pointer :: irewet => null() !< rewetting (0:off, 1:on) - integer(I4B),pointer :: iwetit => null() !< wetting interval (default is 1) - integer(I4B),pointer :: ihdwet => null() !< (0 or not 0) - integer(I4B), pointer :: icellavg => null() !< harmonic(0), logarithmic(1), or arithmetic thick-log K (2) - real(DP), pointer :: wetfct => null() !< wetting factor - real(DP), pointer :: hdry => null() !< default is -1.d30 - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< confined (0) or convertible (1) - integer(I4B), dimension(:), pointer, contiguous:: ithickstartflag => null() !< array of flags for handling the thickstrt option + type(GwfIcType), pointer :: ic => null() !< initial conditions object + type(Xt3dType), pointer :: xt3d => null() !< xt3d pointer + integer(I4B), pointer :: iname => null() !< length of variable names + character(len=24), dimension(:), pointer :: aname => null() !< variable names + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + real(DP), dimension(:), pointer, contiguous :: hnew => null() !< pointer to model xnew + integer(I4B), pointer :: ixt3d => null() !< xt3d flag (0 is off, 1 is lhs, 2 is rhs) + integer(I4B), pointer :: iperched => null() !< vertical flow corrections if 1 + integer(I4B), pointer :: ivarcv => null() !< CV is function of water table + integer(I4B), pointer :: idewatcv => null() !< CV may be a discontinuous function of water table + integer(I4B), pointer :: ithickstrt => null() !< thickstrt option flag + integer(I4B), pointer :: igwfnewtonur => null() !< newton head dampening using node bottom option flag + integer(I4B), pointer :: iusgnrhc => null() !< MODFLOW-USG saturation calculation option flag + integer(I4B), pointer :: inwtupw => null() !< MODFLOW-NWT upstream weighting option flag + integer(I4B), pointer :: icalcspdis => null() !< Calculate specific discharge at cell centers + integer(I4B), pointer :: isavspdis => null() !< Save specific discharge at cell centers + integer(I4B), pointer :: isavsat => null() !< Save sat to budget file + real(DP), pointer :: hnoflo => null() !< default is 1.e30 + real(DP), pointer :: satomega => null() !< newton-raphson saturation omega + integer(I4B), pointer :: irewet => null() !< rewetting (0:off, 1:on) + integer(I4B), pointer :: iwetit => null() !< wetting interval (default is 1) + integer(I4B), pointer :: ihdwet => null() !< (0 or not 0) + integer(I4B), pointer :: icellavg => null() !< harmonic(0), logarithmic(1), or arithmetic thick-log K (2) + real(DP), pointer :: wetfct => null() !< wetting factor + real(DP), pointer :: hdry => null() !< default is -1.d30 + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< confined (0) or convertible (1) + integer(I4B), dimension(:), pointer, contiguous :: ithickstartflag => null() !< array of flags for handling the thickstrt option ! ! K properties - real(DP), dimension(:), pointer, contiguous :: k11 => null() !< hydraulic conductivity; if anisotropic, then this is Kx prior to rotation - real(DP), dimension(:), pointer, contiguous :: k22 => null() !< hydraulic conductivity; if specified then this is Ky prior to rotation - real(DP), dimension(:), pointer, contiguous :: k33 => null() !< hydraulic conductivity; if specified then this is Kz prior to rotation - integer(I4B), pointer :: iavgkeff => null() !< effective conductivity averaging (0: harmonic, 1: arithmetic) - integer(I4B), pointer :: ik22 => null() !< flag that k22 is specified - integer(I4B), pointer :: ik33 => null() !< flag that k33 is specified - integer(I4B), pointer :: ik22overk => null() !< flag that k22 is specified as anisotropy ratio - integer(I4B), pointer :: ik33overk => null() !< flag that k33 is specified as anisotropy ratio - integer(I4B), pointer :: iangle1 => null() !< flag to indicate angle1 was read - integer(I4B), pointer :: iangle2 => null() !< flag to indicate angle2 was read - integer(I4B), pointer :: iangle3 => null() !< flag to indicate angle3 was read - real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< k ellipse rotation in xy plane around z axis (yaw) - real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< k ellipse rotation up from xy plane around y axis (pitch) - real(DP), dimension(:), pointer, contiguous :: angle3 => null() !< k tensor rotation around x axis (roll) - ! - integer(I4B), pointer :: iwetdry => null() !< flag to indicate angle1 was read - real(DP), dimension(:), pointer, contiguous :: wetdry => null() !< wetdry array - real(DP), dimension(:), pointer, contiguous :: sat => null() !< saturation (0. to 1.) for each cell - real(DP), dimension(:), pointer, contiguous :: condsat => null() !< saturated conductance (symmetric array) - real(DP), pointer :: satmin => null() !< minimum saturated thickness - integer(I4B), dimension(:), pointer, contiguous :: ibotnode => null() !< bottom node used if igwfnewtonur /= 0 - ! - real(DP), dimension(:, :), pointer, contiguous :: spdis => null() !< specific discharge : qx, qy, qz (nodes, 3) - integer(I4B), pointer :: nedges => null() !< number of cell edges - integer(I4B), pointer :: lastedge => null() !< last edge number - integer(I4B), dimension(:), pointer, contiguous :: nodedge => null() !< array of node numbers that have edges - integer(I4B), dimension(:), pointer, contiguous :: ihcedge => null() !< edge type (horizontal or vertical) - real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() !< edge properties (Q, area, nx, ny, distance) - ! - integer(I4B), pointer :: intvk => null() ! TVK (time-varying K) unit number (0 if unused) - type(TvkType), pointer :: tvk => null() ! TVK object - integer(I4B), pointer :: kchangeper => null() ! last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) - integer(I4B), pointer :: kchangestp => null() ! last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) - integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() ! grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) + real(DP), dimension(:), pointer, contiguous :: k11 => null() !< hydraulic conductivity; if anisotropic, then this is Kx prior to rotation + real(DP), dimension(:), pointer, contiguous :: k22 => null() !< hydraulic conductivity; if specified then this is Ky prior to rotation + real(DP), dimension(:), pointer, contiguous :: k33 => null() !< hydraulic conductivity; if specified then this is Kz prior to rotation + integer(I4B), pointer :: iavgkeff => null() !< effective conductivity averaging (0: harmonic, 1: arithmetic) + integer(I4B), pointer :: ik22 => null() !< flag that k22 is specified + integer(I4B), pointer :: ik33 => null() !< flag that k33 is specified + integer(I4B), pointer :: ik22overk => null() !< flag that k22 is specified as anisotropy ratio + integer(I4B), pointer :: ik33overk => null() !< flag that k33 is specified as anisotropy ratio + integer(I4B), pointer :: iangle1 => null() !< flag to indicate angle1 was read + integer(I4B), pointer :: iangle2 => null() !< flag to indicate angle2 was read + integer(I4B), pointer :: iangle3 => null() !< flag to indicate angle3 was read + real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< k ellipse rotation in xy plane around z axis (yaw) + real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< k ellipse rotation up from xy plane around y axis (pitch) + real(DP), dimension(:), pointer, contiguous :: angle3 => null() !< k tensor rotation around x axis (roll) + ! + integer(I4B), pointer :: iwetdry => null() !< flag to indicate angle1 was read + real(DP), dimension(:), pointer, contiguous :: wetdry => null() !< wetdry array + real(DP), dimension(:), pointer, contiguous :: sat => null() !< saturation (0. to 1.) for each cell + real(DP), dimension(:), pointer, contiguous :: condsat => null() !< saturated conductance (symmetric array) + real(DP), pointer :: satmin => null() !< minimum saturated thickness + integer(I4B), dimension(:), pointer, contiguous :: ibotnode => null() !< bottom node used if igwfnewtonur /= 0 + ! + real(DP), dimension(:, :), pointer, contiguous :: spdis => null() !< specific discharge : qx, qy, qz (nodes, 3) + integer(I4B), pointer :: nedges => null() !< number of cell edges + integer(I4B), pointer :: lastedge => null() !< last edge number + integer(I4B), dimension(:), pointer, contiguous :: nodedge => null() !< array of node numbers that have edges + integer(I4B), dimension(:), pointer, contiguous :: ihcedge => null() !< edge type (horizontal or vertical) + real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() !< edge properties (Q, area, nx, ny, distance) + ! + integer(I4B), pointer :: intvk => null() ! TVK (time-varying K) unit number (0 if unused) + type(TvkType), pointer :: tvk => null() ! TVK object + integer(I4B), pointer :: kchangeper => null() ! last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) + integer(I4B), pointer :: kchangestp => null() ! last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) + integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() ! grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) ! contains - procedure :: npf_df - procedure :: npf_ac - procedure :: npf_mc - procedure :: npf_ar - procedure :: npf_rp - procedure :: npf_ad - procedure :: npf_cf - procedure :: npf_fc - procedure :: npf_fn - procedure :: npf_cq - procedure :: npf_save_model_flows - procedure :: npf_nur - procedure :: npf_print_model_flows - procedure :: npf_da - procedure, private :: thksat => sgwf_npf_thksat - procedure, private :: qcalc => sgwf_npf_qcalc - procedure, private :: wd => sgwf_npf_wetdry - procedure, private :: wdmsg => sgwf_npf_wdmsg - procedure :: allocate_scalars - procedure, private :: allocate_arrays - procedure, private :: read_options - procedure, private :: set_options - procedure, private :: rewet_options - procedure, private :: check_options - procedure, private :: read_grid_data - procedure, private :: set_grid_data - procedure, private :: prepcheck - procedure, private :: preprocess_input - procedure, private :: calc_condsat - procedure, private :: calc_initial_sat - procedure, public :: rewet_check - procedure, public :: hy_eff - procedure, public :: calc_spdis - procedure, public :: sav_spdis - procedure, public :: sav_sat - procedure, public :: increase_edge_count - procedure, public :: set_edge_properties - procedure, public :: calcSatThickness - endtype - - contains + procedure :: npf_df + procedure :: npf_ac + procedure :: npf_mc + procedure :: npf_ar + procedure :: npf_rp + procedure :: npf_ad + procedure :: npf_cf + procedure :: npf_fc + procedure :: npf_fn + procedure :: npf_cq + procedure :: npf_save_model_flows + procedure :: npf_nur + procedure :: npf_print_model_flows + procedure :: npf_da + procedure, private :: thksat => sgwf_npf_thksat + procedure, private :: qcalc => sgwf_npf_qcalc + procedure, private :: wd => sgwf_npf_wetdry + procedure, private :: wdmsg => sgwf_npf_wdmsg + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: set_options + procedure, private :: rewet_options + procedure, private :: check_options + procedure, private :: read_grid_data + procedure, private :: set_grid_data + procedure, private :: prepcheck + procedure, private :: preprocess_input + procedure, private :: calc_condsat + procedure, private :: calc_initial_sat + procedure, public :: rewet_check + procedure, public :: hy_eff + procedure, public :: calc_spdis + procedure, public :: sav_spdis + procedure, public :: sav_sat + procedure, public :: increase_edge_count + procedure, public :: set_edge_properties + procedure, public :: calcSatThickness + end type + +contains subroutine npf_cr(npfobj, name_model, inunit, iout) ! ****************************************************************************** ! npf_cr -- Create a new NPF object. Pass a inunit value of 0 if npf data will -! initialized from memory +! initialized from memory ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -148,12 +148,12 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) ! -- dummy type(GwfNpftype), pointer :: npfobj character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(npfobj) + allocate (npfobj) ! ! -- create name and memory path call npfobj%set_names(1, name_model, 'NPF', 'NPF') @@ -163,17 +163,17 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) ! ! -- Set variables npfobj%inunit = inunit - npfobj%iout = iout + npfobj%iout = iout ! ! -- Return return end subroutine npf_cr !> @brief define the NPF package instance - !! + !! !! This is a hybrid routine: it either reads the options for this package !! from the input file, or the optional argument @param npf_options - !! should be passed. A consistency check is performed, and finally + !! should be passed. A consistency check is performed, and finally !! xt3d_df is called, when enabled. !< subroutine npf_df(this, dis, xt3d, ingnc, npf_options) @@ -187,15 +187,15 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) use SimModule, only: store_error use Xt3dModule, only: xt3d_cr ! -- dummy - class(GwfNpftype) :: this !< instance of the NPF package - class(DisBaseType), pointer, intent(inout) :: dis !< the pointer to the discretization - type(Xt3dType), pointer :: xt3d !< the pointer to the XT3D 'package' - integer(I4B), intent(in) :: ingnc !< ghostnodes enabled? (>0 means yes) - type(GwfNpfOptionsType), optional, intent(in) :: npf_options !< the optional options, for when not constructing from file + class(GwfNpftype) :: this !< instance of the NPF package + class(DisBaseType), pointer, intent(inout) :: dis !< the pointer to the discretization + type(Xt3dType), pointer :: xt3d !< the pointer to the XT3D 'package' + integer(I4B), intent(in) :: ingnc !< ghostnodes enabled? (>0 means yes) + type(GwfNpfOptionsType), optional, intent(in) :: npf_options !< the optional options, for when not constructing from file ! -- local ! -- formats - character(len=*), parameter :: fmtheader = & - "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & + character(len=*), parameter :: fmtheader = & + "(1x, /1x, 'NPF -- NODE PROPERTY FLOW PACKAGE, VERSION 1, 3/30/2015', & &' INPUT READ FROM UNIT ', i0, //)" ! -- data ! ------------------------------------------------------------------------------ @@ -205,7 +205,7 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) ! if (.not. present(npf_options)) then ! -- Print a message identifying the node property flow package. - write(this%iout, fmtheader) this%inunit + write (this%iout, fmtheader) this%inunit ! ! -- Initialize block parser and read options call this%parser%Initialize(this%inunit, this%iout) @@ -213,7 +213,7 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) else call this%set_options(npf_options) end if - + call this%check_options() ! ! -- Save pointer to xt3d object @@ -223,10 +223,10 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) ! ! -- Ensure GNC and XT3D are not both on at the same time if (this%ixt3d /= 0 .and. ingnc > 0) then - call store_error('Error in model ' // trim(this%name_model) // & - '. The XT3D option cannot be used with the GNC Package.', & - terminate=.TRUE.) - endif + call store_error('Error in model '//trim(this%name_model)// & + '. The XT3D option cannot be used with the GNC & + &Package.', terminate=.TRUE.) + end if ! ! -- Return return @@ -250,7 +250,7 @@ subroutine npf_ac(this, moffset, sparse) ! ------------------------------------------------------------------------------ ! ! -- Add extended neighbors (neighbors of neighbors) - if(this%ixt3d /= 0) call this%xt3d%xt3d_ac(moffset, sparse) + if (this%ixt3d /= 0) call this%xt3d%xt3d_ac(moffset, sparse) ! ! -- Return return @@ -278,7 +278,7 @@ subroutine npf_mc(this, moffset, iasln, jasln) ! -- Return return end subroutine npf_mc - + !> @brief allocate and read this NPF instance !! !! Allocate package arrays, read the grid data either from file or @@ -293,20 +293,20 @@ subroutine npf_ar(this, ic, ibound, hnew, grid_data) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwfNpftype) :: this !< instance of the NPF package - type(GwfIcType), pointer, intent(in) :: ic !< initial conditions - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array - real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array - type(GwfNpfGridDataType), optional, intent(in) :: grid_data !< (optional) data structure with NPF grid data + class(GwfNpftype) :: this !< instance of the NPF package + type(GwfIcType), pointer, intent(in) :: ic !< initial conditions + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array + real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array + type(GwfNpfGridDataType), optional, intent(in) :: grid_data !< (optional) data structure with NPF grid data ! -- local ! -- formats ! -- data ! ------------------------------------------------------------------------------ ! ! -- Store pointers to arguments that were passed in - this%ic => ic - this%ibound => ibound - this%hnew => hnew + this%ic => ic + this%ibound => ibound + this%hnew => hnew ! ! -- allocate arrays call this%allocate_arrays(this%dis%nodes, this%dis%njas) @@ -321,14 +321,14 @@ subroutine npf_ar(this, ic, ibound, hnew, grid_data) end if ! ! -- preprocess data - call this%preprocess_input() + call this%preprocess_input() ! ! -- xt3d if (this%ixt3d /= 0) then - call this%xt3d%xt3d_ar(ibound, this%k11, this%ik33, this%k33, & - this%sat, this%ik22, this%k22, & - this%iangle1, this%iangle2, this%iangle3, & - this%angle1, this%angle2, this%angle3, & + call this%xt3d%xt3d_ar(ibound, this%k11, this%ik33, this%k33, & + this%sat, this%ik22, this%k22, & + this%iangle1, this%iangle2, this%iangle3, & + this%angle1, this%angle2, this%angle3, & this%inewton, this%icelltype) end if ! @@ -379,45 +379,45 @@ subroutine npf_ad(this, nodes, hold, hnew, irestore) ! ------------------------------------------------------------------------------ ! ! -- loop through all cells and set hold=bot if wettable cell is dry - if(this%irewet > 0) then + if (this%irewet > 0) then do n = 1, this%dis%nodes - if(this%wetdry(n) == DZERO) cycle - if(this%ibound(n) /= 0) cycle + if (this%wetdry(n) == DZERO) cycle + if (this%ibound(n) /= 0) cycle hold(n) = this%dis%bot(n) - enddo + end do ! ! -- if restore state, then set hnew to DRY if it is a dry wettable cell do n = 1, this%dis%nodes - if(this%wetdry(n) == DZERO) cycle - if(this%ibound(n) /= 0) cycle + if (this%wetdry(n) == DZERO) cycle + if (this%ibound(n) /= 0) cycle hnew(n) = DHDRY - enddo - endif + end do + end if ! ! -- TVK - if(this%intvk /= 0) then + if (this%intvk /= 0) then call this%tvk%ad() - endif + end if ! ! -- If any K values have changed, we need to update CONDSAT or XT3D arrays - if(this%kchangeper == kper .and. this%kchangestp == kstp) then - if(this%ixt3d == 0) then + if (this%kchangeper == kper .and. this%kchangestp == kstp) then + if (this%ixt3d == 0) then ! ! -- Update the saturated conductance for all connections ! -- of the affected nodes do n = 1, this%dis%nodes - if(this%nodekchange(n) == 1) then + if (this%nodekchange(n) == 1) then call this%calc_condsat(n, .false.) - endif - enddo + end if + end do else ! ! -- Recompute XT3D coefficients for permanently confined connections - if(this%xt3d%lamatsaved .and. .not. this%xt3d%ldispersion) then + if (this%xt3d%lamatsaved .and. .not. this%xt3d%ldispersion) then call this%xt3d%xt3d_fcpc(this%dis%nodes, .true.) - endif - endif - endif + end if + end if + end if ! ! -- Return return @@ -433,8 +433,8 @@ subroutine npf_cf(this, kiter, nodes, hnew) ! -- dummy class(GwfNpfType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - real(DP),intent(inout),dimension(nodes) :: hnew + integer(I4B), intent(in) :: nodes + real(DP), intent(inout), dimension(nodes) :: hnew ! -- local integer(I4B) :: n real(DP) :: satn @@ -447,15 +447,15 @@ subroutine npf_cf(this, kiter, nodes, hnew) ! ! -- Calculate saturation for convertible cells do n = 1, this%dis%nodes - if(this%icelltype(n) /= 0) then - if(this%ibound(n) == 0) then + if (this%icelltype(n) /= 0) then + if (this%ibound(n) == 0) then satn = DZERO else call this%thksat(n, hnew(n), satn) - endif + end if this%sat(n) = satn - endif - enddo + end if + end do ! ! -- Return return @@ -473,11 +473,11 @@ subroutine npf_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! -- dummy class(GwfNpfType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amat + integer(I4B), intent(in), dimension(:) :: idxglo + real(DP), intent(inout), dimension(:) :: rhs + real(DP), intent(inout), dimension(:) :: hnew ! -- local integer(I4B) :: n, m, ii, idiag, ihc integer(I4B) :: isymcon, idiagm @@ -487,96 +487,95 @@ subroutine npf_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! ! -- Calculate conductance and put into amat ! - if(this%ixt3d /= 0) then + if (this%ixt3d /= 0) then call this%xt3d%xt3d_fc(kiter, njasln, amat, idxglo, rhs, hnew) else - ! - do n = 1, this%dis%nodes - do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - if (this%dis%con%mask(ii) == 0) cycle - - m = this%dis%con%ja(ii) - ! - ! -- Calculate conductance only for upper triangle but insert into - ! upper and lower parts of amat. - if (m < n) cycle - ihc = this%dis%con%ihc(this%dis%con%jas(ii)) - hyn = this%hy_eff(n, m, ihc, ipos=ii) - hym = this%hy_eff(m, n, ihc, ipos=ii) - ! - ! -- Vertical connection - if (ihc == 0) then + ! + do n = 1, this%dis%nodes + do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + if (this%dis%con%mask(ii) == 0) cycle + + m = this%dis%con%ja(ii) ! - ! -- Calculate vertical conductance - cond = vcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), this%inewton, & - this%ivarcv, this%idewatcv, & - this%condsat(this%dis%con%jas(ii)), hnew(n), hnew(m), & - hyn, hym, & - this%sat(n), this%sat(m), & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(ii))) + ! -- Calculate conductance only for upper triangle but insert into + ! upper and lower parts of amat. + if (m < n) cycle + ihc = this%dis%con%ihc(this%dis%con%jas(ii)) + hyn = this%hy_eff(n, m, ihc, ipos=ii) + hym = this%hy_eff(m, n, ihc, ipos=ii) ! - ! -- Vertical flow for perched conditions - if (this%iperched /= 0) then - if (this%icelltype(m) /= 0) then - if (hnew(m) < this%dis%top(m)) then - ! - ! -- Fill row n - idiag = this%dis%con%ia(n) - rhs(n) = rhs(n) - cond * this%dis%bot(n) - amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond - ! - ! -- Fill row m - isymcon = this%dis%con%isym(ii) - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond - rhs(m) = rhs(m) + cond * this%dis%bot(n) - ! - ! -- cycle the connection loop - cycle - endif - endif - endif + ! -- Vertical connection + if (ihc == 0) then + ! + ! -- Calculate vertical conductance + cond = vcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), this%inewton, & + this%ivarcv, this%idewatcv, & + this%condsat(this%dis%con%jas(ii)), hnew(n), hnew(m), & + hyn, hym, & + this%sat(n), this%sat(m), & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(ii))) + ! + ! -- Vertical flow for perched conditions + if (this%iperched /= 0) then + if (this%icelltype(m) /= 0) then + if (hnew(m) < this%dis%top(m)) then + ! + ! -- Fill row n + idiag = this%dis%con%ia(n) + rhs(n) = rhs(n) - cond * this%dis%bot(n) + amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond + ! + ! -- Fill row m + isymcon = this%dis%con%isym(ii) + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond + rhs(m) = rhs(m) + cond * this%dis%bot(n) + ! + ! -- cycle the connection loop + cycle + end if + end if + end if + ! + else + ! + ! -- Horizontal conductance + cond = hcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), & + this%inewton, this%inewton, & + this%dis%con%ihc(this%dis%con%jas(ii)), & + this%icellavg, this%iusgnrhc, this%inwtupw, & + this%condsat(this%dis%con%jas(ii)), & + hnew(n), hnew(m), this%sat(n), this%sat(m), hyn, hym, & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(ii)), & + this%dis%con%cl2(this%dis%con%jas(ii)), & + this%dis%con%hwva(this%dis%con%jas(ii)), & + this%satomega, this%satmin) + end if ! - else + ! -- Fill row n + idiag = this%dis%con%ia(n) + amat(idxglo(ii)) = amat(idxglo(ii)) + cond + amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond ! - ! -- Horizontal conductance - cond = hcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), & - this%inewton, this%inewton, & - this%dis%con%ihc(this%dis%con%jas(ii)), & - this%icellavg, this%iusgnrhc, this%inwtupw, & - this%condsat(this%dis%con%jas(ii)), & - hnew(n), hnew(m), this%sat(n), this%sat(m), hyn, hym, & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(ii)), & - this%dis%con%cl2(this%dis%con%jas(ii)), & - this%dis%con%hwva(this%dis%con%jas(ii)), & - this%satomega, this%satmin) - endif - ! - ! -- Fill row n - idiag = this%dis%con%ia(n) - amat(idxglo(ii)) = amat(idxglo(ii)) + cond - amat(idxglo(idiag)) = amat(idxglo(idiag)) - cond - ! - ! -- Fill row m - isymcon = this%dis%con%isym(ii) - idiagm = this%dis%con%ia(m) - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond - amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - cond - enddo - enddo - ! - endif + ! -- Fill row m + isymcon = this%dis%con%isym(ii) + idiagm = this%dis%con%ia(m) + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) + cond + amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - cond + end do + end do + ! + end if ! ! -- Return return end subroutine npf_fc - subroutine npf_fn(this, kiter, njasln, amat, idxglo, rhs, hnew) ! ****************************************************************************** ! npf_fn -- Fill newton terms @@ -587,14 +586,14 @@ subroutine npf_fn(this, kiter, njasln, amat, idxglo, rhs, hnew) ! -- dummy class(GwfNpfType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amat + integer(I4B), intent(in), dimension(:) :: idxglo + real(DP), intent(inout), dimension(:) :: rhs + real(DP), intent(inout), dimension(:) :: hnew ! -- local integer(I4B) :: nodes, nja - integer(I4B) :: n,m,ii,idiag + integer(I4B) :: n, m, ii, idiag integer(I4B) :: isymcon, idiagm integer(I4B) :: iups integer(I4B) :: idn @@ -615,104 +614,104 @@ subroutine npf_fn(this, kiter, njasln, amat, idxglo, rhs, hnew) ! nodes = this%dis%nodes nja = this%dis%con%nja - if(this%ixt3d /= 0) then + if (this%ixt3d /= 0) then call this%xt3d%xt3d_fn(kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) else - ! - do n=1, nodes - idiag=this%dis%con%ia(n) - do ii=this%dis%con%ia(n)+1,this%dis%con%ia(n+1)-1 - if (this%dis%con%mask(ii) == 0) cycle - - m=this%dis%con%ja(ii) - isymcon = this%dis%con%isym(ii) - ! work on upper triangle - if(m < n) cycle - if(this%dis%con%ihc(this%dis%con%jas(ii))==0 .and. & - this%ivarcv == 0) then - !call this%vcond(n,m,hnew(n),hnew(m),ii,cond) - ! do nothing - else - ! determine upstream node - iups = m - if (hnew(m) < hnew(n)) iups = n - idn = n - if (iups == n) idn = m - ! - ! -- no newton terms if upstream cell is confined - if (this%icelltype(iups) == 0) cycle - ! - ! -- Set the upstream top and bot, and then recalculate for a - ! vertically staggered horizontal connection - topup = this%dis%top(iups) - botup = this%dis%bot(iups) - if(this%dis%con%ihc(this%dis%con%jas(ii)) == 2) then - topup = min(this%dis%top(n), this%dis%top(m)) - botup = max(this%dis%bot(n), this%dis%bot(m)) - endif - ! - ! get saturated conductivity for derivative - cond = this%condsat(this%dis%con%jas(ii)) - ! - ! -- if using MODFLOW-NWT upstream weighting option apply - ! factor to remove average thickness - if (this%inwtupw /= 0) then - topdn = this%dis%top(idn) - botdn = this%dis%bot(idn) - afac = DTWO / (DONE + (topdn - botdn) / (topup - botup)) - cond = cond * afac - end if - ! - ! compute additional term - consterm = -cond * (hnew(iups) - hnew(idn)) !needs to use hwadi instead of hnew(idn) - !filledterm = cond - filledterm = amat(idxglo(ii)) - derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups), & - this%satomega, this%satmin) - idiagm = this%dis%con%ia(m) - ! fill jacobian for n being the upstream node - if (iups == n) then - hds = hnew(m) - !isymcon = this%dis%con%isym(ii) - term = consterm * derv - rhs(n) = rhs(n) + term * hnew(n) !+ amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi - rhs(m) = rhs(m) - term * hnew(n) !- amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi - ! fill in row of n - amat(idxglo(idiag)) = amat(idxglo(idiag)) + term - ! fill newton term in off diagonal if active cell - if (this%ibound(n) > 0) then - amat(idxglo(ii)) = amat(idxglo(ii)) !* dwadi !need to add dwadi - end if - !fill row of m - amat(idxglo(idiagm)) = amat(idxglo(idiagm)) !- filledterm * (dwadi - DONE) !need to add dwadi - ! fill newton term in off diagonal if active cell - if (this%ibound(m) > 0) then - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) - term - end if - ! fill jacobian for m being the upstream node + ! + do n = 1, nodes + idiag = this%dis%con%ia(n) + do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + if (this%dis%con%mask(ii) == 0) cycle + + m = this%dis%con%ja(ii) + isymcon = this%dis%con%isym(ii) + ! work on upper triangle + if (m < n) cycle + if (this%dis%con%ihc(this%dis%con%jas(ii)) == 0 .and. & + this%ivarcv == 0) then + !call this%vcond(n,m,hnew(n),hnew(m),ii,cond) + ! do nothing else - hds = hnew(n) - term = -consterm * derv - rhs(n) = rhs(n) + term * hnew(m) !+ amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi - rhs(m) = rhs(m) - term * hnew(m) !- amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi - ! fill in row of n - amat(idxglo(idiag)) = amat(idxglo(idiag)) !- filledterm * (dwadi - DONE) !need to add dwadi - ! fill newton term in off diagonal if active cell - if (this%ibound(n) > 0) then - amat(idxglo(ii)) = amat(idxglo(ii)) + term + ! determine upstream node + iups = m + if (hnew(m) < hnew(n)) iups = n + idn = n + if (iups == n) idn = m + ! + ! -- no newton terms if upstream cell is confined + if (this%icelltype(iups) == 0) cycle + ! + ! -- Set the upstream top and bot, and then recalculate for a + ! vertically staggered horizontal connection + topup = this%dis%top(iups) + botup = this%dis%bot(iups) + if (this%dis%con%ihc(this%dis%con%jas(ii)) == 2) then + topup = min(this%dis%top(n), this%dis%top(m)) + botup = max(this%dis%bot(n), this%dis%bot(m)) + end if + ! + ! get saturated conductivity for derivative + cond = this%condsat(this%dis%con%jas(ii)) + ! + ! -- if using MODFLOW-NWT upstream weighting option apply + ! factor to remove average thickness + if (this%inwtupw /= 0) then + topdn = this%dis%top(idn) + botdn = this%dis%bot(idn) + afac = DTWO / (DONE + (topdn - botdn) / (topup - botup)) + cond = cond * afac end if - !fill row of m - amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - term - ! fill newton term in off diagonal if active cell - if (this%ibound(m) > 0) then - amat(idxglo(isymcon)) = amat(idxglo(isymcon)) !* dwadi !need to add dwadi + ! + ! compute additional term + consterm = -cond * (hnew(iups) - hnew(idn)) !needs to use hwadi instead of hnew(idn) + !filledterm = cond + filledterm = amat(idxglo(ii)) + derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups), & + this%satomega, this%satmin) + idiagm = this%dis%con%ia(m) + ! fill jacobian for n being the upstream node + if (iups == n) then + hds = hnew(m) + !isymcon = this%dis%con%isym(ii) + term = consterm * derv + rhs(n) = rhs(n) + term * hnew(n) !+ amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi + rhs(m) = rhs(m) - term * hnew(n) !- amat(idxglo(isymcon)) * (dwadi * hds - hds) !need to add dwadi + ! fill in row of n + amat(idxglo(idiag)) = amat(idxglo(idiag)) + term + ! fill newton term in off diagonal if active cell + if (this%ibound(n) > 0) then + amat(idxglo(ii)) = amat(idxglo(ii)) !* dwadi !need to add dwadi + end if + !fill row of m + amat(idxglo(idiagm)) = amat(idxglo(idiagm)) !- filledterm * (dwadi - DONE) !need to add dwadi + ! fill newton term in off diagonal if active cell + if (this%ibound(m) > 0) then + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) - term + end if + ! fill jacobian for m being the upstream node + else + hds = hnew(n) + term = -consterm * derv + rhs(n) = rhs(n) + term * hnew(m) !+ amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi + rhs(m) = rhs(m) - term * hnew(m) !- amat(idxglo(ii)) * (dwadi * hds - hds) !need to add dwadi + ! fill in row of n + amat(idxglo(idiag)) = amat(idxglo(idiag)) !- filledterm * (dwadi - DONE) !need to add dwadi + ! fill newton term in off diagonal if active cell + if (this%ibound(n) > 0) then + amat(idxglo(ii)) = amat(idxglo(ii)) + term + end if + !fill row of m + amat(idxglo(idiagm)) = amat(idxglo(idiagm)) - term + ! fill newton term in off diagonal if active cell + if (this%ibound(m) > 0) then + amat(idxglo(isymcon)) = amat(idxglo(isymcon)) !* dwadi !need to add dwadi + end if end if end if - endif - enddo - end do - ! + end do + end do + ! end if ! ! -- Return @@ -755,7 +754,7 @@ subroutine npf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) ! solution head is below the bottom of the model if (x(n) < botm) then inewtonur = 1 - xx = xtemp(n)*(DONE-DP9) + botm*DP9 + xx = xtemp(n) * (DONE - DP9) + botm * DP9 dxx = x(n) - xx if (abs(dxx) > abs(dxmax)) then locmax = n @@ -765,7 +764,7 @@ subroutine npf_nur(this, neqmod, x, xtemp, dx, inewtonur, dxmax, locmax) dx(n) = DZERO end if end if - enddo + end do ! ! -- return return @@ -780,8 +779,8 @@ subroutine npf_cq(this, hnew, flowja) ! ------------------------------------------------------------------------------ ! -- dummy class(GwfNpfType) :: this - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja + real(DP), intent(inout), dimension(:) :: hnew + real(DP), intent(inout), dimension(:) :: flowja ! -- local integer(I4B) :: n, ipos, m real(DP) :: qnm @@ -789,21 +788,21 @@ subroutine npf_cq(this, hnew, flowja) ! ! -- Calculate the flow across each cell face and store in flowja ! - if(this%ixt3d /= 0) then + if (this%ixt3d /= 0) then call this%xt3d%xt3d_flowja(hnew, flowja) else - ! - do n = 1, this%dis%nodes - do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - m = this%dis%con%ja(ipos) - if(m < n) cycle - call this%qcalc(n, m, hnew(n), hnew(m), ipos, qnm) - flowja(ipos) = qnm - flowja(this%dis%con%isym(ipos)) = -qnm - enddo - enddo - ! - endif + ! + do n = 1, this%dis%nodes + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ipos) + if (m < n) cycle + call this%qcalc(n, m, hnew(n), hnew(m), ipos, qnm) + flowja(ipos) = qnm + flowja(this%dis%con%isym(ipos)) = -qnm + end do + end do + ! + end if ! ! -- Return return @@ -818,30 +817,30 @@ subroutine sgwf_npf_thksat(this, n, hn, thksat) ! ------------------------------------------------------------------------------ ! -- dummy class(GwfNpfType) :: this - integer(I4B),intent(in) :: n - real(DP),intent(in) :: hn - real(DP),intent(inout) :: thksat + integer(I4B), intent(in) :: n + real(DP), intent(in) :: hn + real(DP), intent(inout) :: thksat ! ------------------------------------------------------------------------------ ! ! -- Standard Formulation - if(hn >= this%dis%top(n)) then + if (hn >= this%dis%top(n)) then thksat = DONE else thksat = (hn - this%dis%bot(n)) / (this%dis%top(n) - this%dis%bot(n)) - endif + end if ! ! -- Newton-Raphson Formulation - if(this%inewton /= 0) then - thksat = sQuadraticSaturation(this%dis%top(n), this%dis%bot(n), hn, & + if (this%inewton /= 0) then + thksat = sQuadraticSaturation(this%dis%top(n), this%dis%bot(n), hn, & this%satomega, this%satmin) !if (thksat < this%satmin) thksat = this%satmin - endif + end if ! ! -- Return return end subroutine sgwf_npf_thksat - subroutine sgwf_npf_qcalc(this, n, m, hn, hm, icon, qnm) + subroutine sgwf_npf_qcalc(this, n, m, hn, hm, icon, qnm) ! ****************************************************************************** ! sgwf_npf_qcalc -- Flow between two cells ! ****************************************************************************** @@ -850,12 +849,12 @@ subroutine sgwf_npf_qcalc(this, n, m, hn, hm, icon, qnm) ! ------------------------------------------------------------------------------ ! -- dummy class(GwfNpfType) :: this - integer(I4B),intent(in) :: n - integer(I4B),intent(in) :: m - real(DP),intent(in) :: hn - real(DP),intent(in) :: hm - integer(I4B),intent(in) :: icon - real(DP),intent(inout) :: qnm + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: m + real(DP), intent(in) :: hn + real(DP), intent(in) :: hm + integer(I4B), intent(in) :: icon + real(DP), intent(inout) :: qnm ! -- local real(DP) :: hyn, hym real(DP) :: condnm @@ -869,50 +868,50 @@ subroutine sgwf_npf_qcalc(this, n, m, hn, hm, icon, qnm) hym = this%hy_eff(m, n, ihc, ipos=icon) ! ! -- Calculate conductance - if(ihc == 0) then - condnm = vcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), this%inewton, & - this%ivarcv, this%idewatcv, & - this%condsat(this%dis%con%jas(icon)), hn, hm, & - hyn, hym, & - this%sat(n), this%sat(m), & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%hwva(this%dis%con%jas(icon))) + if (ihc == 0) then + condnm = vcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), this%inewton, & + this%ivarcv, this%idewatcv, & + this%condsat(this%dis%con%jas(icon)), hn, hm, & + hyn, hym, & + this%sat(n), this%sat(m), & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%hwva(this%dis%con%jas(icon))) else - condnm = hcond(this%ibound(n), this%ibound(m), & - this%icelltype(n), this%icelltype(m), & - this%inewton, this%inewton, & - this%dis%con%ihc(this%dis%con%jas(icon)), & - this%icellavg, this%iusgnrhc, this%inwtupw, & - this%condsat(this%dis%con%jas(icon)), & - hn, hm, this%sat(n), this%sat(m), hyn, hym, & - this%dis%top(n), this%dis%top(m), & - this%dis%bot(n), this%dis%bot(m), & - this%dis%con%cl1(this%dis%con%jas(icon)), & - this%dis%con%cl2(this%dis%con%jas(icon)), & - this%dis%con%hwva(this%dis%con%jas(icon)), & + condnm = hcond(this%ibound(n), this%ibound(m), & + this%icelltype(n), this%icelltype(m), & + this%inewton, this%inewton, & + this%dis%con%ihc(this%dis%con%jas(icon)), & + this%icellavg, this%iusgnrhc, this%inwtupw, & + this%condsat(this%dis%con%jas(icon)), & + hn, hm, this%sat(n), this%sat(m), hyn, hym, & + this%dis%top(n), this%dis%top(m), & + this%dis%bot(n), this%dis%bot(m), & + this%dis%con%cl1(this%dis%con%jas(icon)), & + this%dis%con%cl2(this%dis%con%jas(icon)), & + this%dis%con%hwva(this%dis%con%jas(icon)), & this%satomega, this%satmin) - endif + end if ! ! -- Initialize hntemp and hmtemp hntemp = hn hmtemp = hm ! ! -- Check and adjust for dewatered conditions - if(this%iperched /= 0) then - if(this%dis%con%ihc(this%dis%con%jas(icon)) == 0) then - if(n > m) then - if(this%icelltype(n) /= 0) then - if(hn < this%dis%top(n)) hntemp = this%dis%bot(m) - endif + if (this%iperched /= 0) then + if (this%dis%con%ihc(this%dis%con%jas(icon)) == 0) then + if (n > m) then + if (this%icelltype(n) /= 0) then + if (hn < this%dis%top(n)) hntemp = this%dis%bot(m) + end if else - if(this%icelltype(m) /= 0) then - if(hm < this%dis%top(m)) hmtemp = this%dis%bot(n) - endif - endif - endif - endif + if (this%icelltype(m) /= 0) then + if (hm < this%dis%top(m)) hmtemp = this%dis%bot(n) + end if + end if + end if + end if ! ! -- Calculate flow positive into cell n qnm = condnm * (hmtemp - hntemp) @@ -930,7 +929,7 @@ subroutine npf_save_model_flows(this, flowja, icbcfl, icbcun) ! ------------------------------------------------------------------------------ ! -- dummy class(GwfNpfType) :: this - real(DP),dimension(:),intent(in) :: flowja + real(DP), dimension(:), intent(in) :: flowja integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: icbcun ! -- local @@ -940,29 +939,29 @@ subroutine npf_save_model_flows(this, flowja, icbcfl, icbcun) ! ------------------------------------------------------------------------------ ! ! -- Set unit number for binary output - if(this%ipakcb < 0) then + if (this%ipakcb < 0) then ibinun = icbcun - elseif(this%ipakcb == 0) then + elseif (this%ipakcb == 0) then ibinun = 0 else ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 + end if + if (icbcfl == 0) ibinun = 0 ! ! -- Write the face flows if requested - if(ibinun /= 0) then + if (ibinun /= 0) then call this%dis%record_connection_array(flowja, ibinun, this%iout) - endif + end if ! ! -- Calculate specific discharge at cell centers and write, if requested if (this%icalcspdis /= 0) then - if(ibinun /= 0) call this%sav_spdis(ibinun) - endif + if (ibinun /= 0) call this%sav_spdis(ibinun) + end if ! ! -- Save saturation, if requested if (this%isavsat /= 0) then - if(ibinun /= 0) call this%sav_sat(ibinun) - endif + if (ibinun /= 0) call this%sav_sat(ibinun) + end if ! ! -- Return return @@ -981,35 +980,35 @@ subroutine npf_print_model_flows(this, ibudfl, flowja) ! -- dummy class(GwfNpfType) :: this integer(I4B), intent(in) :: ibudfl - real(DP),intent(inout),dimension(:) :: flowja + real(DP), intent(inout), dimension(:) :: flowja ! -- local character(len=LENBIGLINE) :: line character(len=30) :: tempstr integer(I4B) :: n, ipos, m real(DP) :: qnm ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(/,4x,'CALCULATED INTERCELL FLOW FOR PERIOD ', i0, ' STEP ', i0)" + character(len=*), parameter :: fmtiprflow = & + &"(/,4x,'CALCULATED INTERCELL FLOW FOR PERIOD ', i0, ' STEP ', i0)" ! ------------------------------------------------------------------------------ ! ! -- Write flowja to list file if requested if (ibudfl /= 0 .and. this%iprflow > 0) then - write(this%iout, fmtiprflow) kper, kstp + write (this%iout, fmtiprflow) kper, kstp do n = 1, this%dis%nodes line = '' call this%dis%noder_to_string(n, tempstr) - line = trim(tempstr) // ':' + line = trim(tempstr)//':' do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) call this%dis%noder_to_string(m, tempstr) - line = trim(line) // ' ' // trim(tempstr) + line = trim(line)//' '//trim(tempstr) qnm = flowja(ipos) - write(tempstr, '(1pg15.6)') qnm - line = trim(line) // ' ' // trim(adjustl(tempstr)) - enddo - write(this%iout, '(a)') trim(line) - enddo - endif + write (tempstr, '(1pg15.6)') qnm + line = trim(line)//' '//trim(adjustl(tempstr)) + end do + write (this%iout, '(a)') trim(line) + end do + end if ! ! -- Return return @@ -1031,7 +1030,7 @@ subroutine npf_da(this) ! -- TVK if (this%intvk /= 0) then call this%tvk%da() - deallocate(this%tvk) + deallocate (this%tvk) end if ! ! -- Strings @@ -1074,7 +1073,7 @@ subroutine npf_da(this) call mem_deallocate(this%kchangestp) ! ! -- Deallocate arrays - deallocate(this%aname) + deallocate (this%aname) call mem_deallocate(this%ithickstartflag) call mem_deallocate(this%icelltype) call mem_deallocate(this%k11) @@ -1153,7 +1152,8 @@ subroutine allocate_scalars(this) call mem_allocate(this%kchangestp, 'KCHANGESTP', this%memoryPath) ! ! -- set pointer to inewtonur - call mem_setptr(this%igwfnewtonur, 'INEWTONUR', create_mem_path(this%name_model)) + call mem_setptr(this%igwfnewtonur, 'INEWTONUR', & + create_mem_path(this%name_model)) ! ! -- Initialize value this%iname = 8 @@ -1215,7 +1215,8 @@ subroutine allocate_arrays(this, ncells, njas) integer(I4B) :: n ! ------------------------------------------------------------------------------ ! - call mem_allocate(this%ithickstartflag, ncells, 'ITHICKSTARTFLAG', this%memoryPath) + call mem_allocate(this%ithickstartflag, ncells, 'ITHICKSTARTFLAG', & + this%memoryPath) call mem_allocate(this%icelltype, ncells, 'ICELLTYPE', this%memoryPath) call mem_allocate(this%k11, ncells, 'K11', this%memoryPath) call mem_allocate(this%sat, ncells, 'SAT', this%memoryPath) @@ -1234,11 +1235,11 @@ subroutine allocate_arrays(this, ncells, njas) ! ! -- Specific discharge if (this%icalcspdis == 1) then - call mem_allocate(this%spdis, 3, ncells, 'SPDIS',this%memoryPath) + call mem_allocate(this%spdis, 3, ncells, 'SPDIS', this%memoryPath) call mem_allocate(this%nodedge, this%nedges, 'NODEDGE', this%memoryPath) call mem_allocate(this%ihcedge, this%nedges, 'IHCEDGE', this%memoryPath) - call mem_allocate(this%propsedge, 5, this%nedges, 'PROPSEDGE', & - this%memoryPath) + call mem_allocate(this%propsedge, 5, this%nedges, 'PROPSEDGE', & + this%memoryPath) do n = 1, ncells this%spdis(:, n) = DZERO end do @@ -1247,7 +1248,7 @@ subroutine allocate_arrays(this, ncells, njas) call mem_allocate(this%nodedge, 0, 'NODEDGE', this%memoryPath) call mem_allocate(this%ihcedge, 0, 'IHCEDGE', this%memoryPath) call mem_allocate(this%propsedge, 0, 0, 'PROPSEDGE', this%memoryPath) - endif + end if ! ! -- Time-varying property flag arrays call mem_allocate(this%nodekchange, ncells, 'NODEKCHANGE', this%memoryPath) @@ -1262,10 +1263,10 @@ subroutine allocate_arrays(this, ncells, njas) end do ! ! -- allocate variable names - allocate(this%aname(this%iname)) - this%aname = [' ICELLTYPE', ' K', & - ' K33', ' K22', & - ' WETDRY', ' ANGLE1', & + allocate (this%aname(this%iname)) + this%aname = [' ICELLTYPE', ' K', & + ' K33', ' K22', & + ' WETDRY', ' ANGLE1', & ' ANGLE2', ' ANGLE3'] ! ! -- return @@ -1280,7 +1281,7 @@ subroutine read_options(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors implicit none ! -- dummy @@ -1290,16 +1291,16 @@ subroutine read_options(this) integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED TO LISTING FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtcellavg = & - "(4x,'ALTERNATIVE CELL AVERAGING HAS BEEN SET TO ', a)" - character(len=*), parameter :: fmtnct = & - "(1x, 'Negative cell thickness at cell: ', a)" + character(len=*), parameter :: fmtiprflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED TO LISTING FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtcellavg = & + &"(4x,'ALTERNATIVE CELL AVERAGING HAS BEEN SET TO ', a)" + character(len=*), parameter :: fmtnct = & + &"(1x, 'Negative cell thickness at cell: ', a)" ! -- data ! ------------------------------------------------------------------------------ ! @@ -1309,152 +1310,152 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING NPF OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING NPF OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout, fmtiprflow) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtisvflow) - case ('ALTERNATIVE_CELL_AVERAGING') - call this%parser%GetStringCaps(keyword) - select case(keyword) - case('LOGARITHMIC') - this%icellavg = 1 - write(this%iout, fmtcellavg) 'LOGARITHMIC' - case('AMT-LMK') - this%icellavg = 2 - write(this%iout, fmtcellavg) 'AMT-LMK' - case('AMT-HMK') - this%icellavg = 3 - write(this%iout, fmtcellavg) 'AMT-HMK' - case default - write(errmsg,'(4x,a,a)')'UNKNOWN CELL AVERAGING METHOD: ', & - keyword - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - write(this%iout,'(4x,a,a)') & - 'CELL AVERAGING METHOD HAS BEEN SET TO: ', keyword - case ('THICKSTRT') - this%ithickstrt = 1 - write(this%iout, '(4x,a)') 'THICKSTRT OPTION HAS BEEN ACTIVATED.' - case ('PERCHED') - this%iperched = 1 - write(this%iout,'(4x,a)') & - 'VERTICAL FLOW WILL BE ADJUSTED FOR PERCHED CONDITIONS.' - case ('VARIABLECV') - this%ivarcv = 1 - write(this%iout,'(4x,a)') & - 'VERTICAL CONDUCTANCE VARIES WITH WATER TABLE.' - call this%parser%GetStringCaps(keyword) - if(keyword == 'DEWATERED') then - this%idewatcv = 1 - write(this%iout,'(4x,a)') & - 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF ' // & - 'AN UNDERLYING CELL.' - endif - case ('REWET') - call this%rewet_options() - case ('XT3D') - this%ixt3d = 1 - write(this%iout, '(4x,a)') & - 'XT3D FORMULATION IS SELECTED.' - call this%parser%GetStringCaps(keyword) - if(keyword == 'RHS') then - this%ixt3d = 2 - endif - case ('SAVE_SPECIFIC_DISCHARGE') - this%icalcspdis = 1 - this%isavspdis = 1 - write(this%iout,'(4x,a)') & - 'SPECIFIC DISCHARGE WILL BE CALCULATED AT CELL CENTERS ' // & - 'AND WRITTEN TO DATA-SPDIS IN BUDGET FILE WHEN REQUESTED.' - case ('SAVE_SATURATION') - this%isavsat = 1 - write(this%iout,'(4x,a)') & - 'SATURATION WILL BE WRITTEN TO DATA-SAT IN BUDGET FILE ' // & - 'WHEN REQUESTED.' - case ('K22OVERK') - this%ik22overk = 1 - write(this%iout,'(4x,a)') & - 'VALUES SPECIFIED FOR K22 ARE ANISOTROPY RATIOS AND ' // & - 'WILL BE MULTIPLIED BY K BEFORE BEING USED IN CALCULATIONS.' - case ('K33OVERK') - this%ik33overk = 1 - write(this%iout,'(4x,a)') & - 'VALUES SPECIFIED FOR K33 ARE ANISOTROPY RATIOS AND ' // & - 'WILL BE MULTIPLIED BY K BEFORE BEING USED IN CALCULATIONS.' - case ('TVK6') - if (this%intvk /= 0) then - errmsg = 'Multiple TVK6 keywords detected in OPTIONS block.' // & - ' Only one TVK6 entry allowed.' - call store_error(errmsg, terminate=.TRUE.) - end if - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TVK6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg, terminate=.TRUE.) - endif - call this%parser%GetString(fname) - this%intvk = GetUnit() - call openfile(this%intvk, this%iout, fname, 'TVK') - call tvk_cr(this%tvk, this%name_model, this%intvk, this%iout) + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, fmtiprflow) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtisvflow) + case ('ALTERNATIVE_CELL_AVERAGING') + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('LOGARITHMIC') + this%icellavg = 1 + write (this%iout, fmtcellavg) 'LOGARITHMIC' + case ('AMT-LMK') + this%icellavg = 2 + write (this%iout, fmtcellavg) 'AMT-LMK' + case ('AMT-HMK') + this%icellavg = 3 + write (this%iout, fmtcellavg) 'AMT-HMK' + case default + write (errmsg, '(4x,a,a)') 'UNKNOWN CELL AVERAGING METHOD: ', & + keyword + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + write (this%iout, '(4x,a,a)') & + 'CELL AVERAGING METHOD HAS BEEN SET TO: ', keyword + case ('THICKSTRT') + this%ithickstrt = 1 + write (this%iout, '(4x,a)') 'THICKSTRT OPTION HAS BEEN ACTIVATED.' + case ('PERCHED') + this%iperched = 1 + write (this%iout, '(4x,a)') & + 'VERTICAL FLOW WILL BE ADJUSTED FOR PERCHED CONDITIONS.' + case ('VARIABLECV') + this%ivarcv = 1 + write (this%iout, '(4x,a)') & + 'VERTICAL CONDUCTANCE VARIES WITH WATER TABLE.' + call this%parser%GetStringCaps(keyword) + if (keyword == 'DEWATERED') then + this%idewatcv = 1 + write (this%iout, '(4x,a)') & + 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF '// & + 'AN UNDERLYING CELL.' + end if + case ('REWET') + call this%rewet_options() + case ('XT3D') + this%ixt3d = 1 + write (this%iout, '(4x,a)') & + 'XT3D FORMULATION IS SELECTED.' + call this%parser%GetStringCaps(keyword) + if (keyword == 'RHS') then + this%ixt3d = 2 + end if + case ('SAVE_SPECIFIC_DISCHARGE') + this%icalcspdis = 1 + this%isavspdis = 1 + write (this%iout, '(4x,a)') & + 'SPECIFIC DISCHARGE WILL BE CALCULATED AT CELL CENTERS '// & + 'AND WRITTEN TO DATA-SPDIS IN BUDGET FILE WHEN REQUESTED.' + case ('SAVE_SATURATION') + this%isavsat = 1 + write (this%iout, '(4x,a)') & + 'SATURATION WILL BE WRITTEN TO DATA-SAT IN BUDGET FILE '// & + 'WHEN REQUESTED.' + case ('K22OVERK') + this%ik22overk = 1 + write (this%iout, '(4x,a)') & + 'VALUES SPECIFIED FOR K22 ARE ANISOTROPY RATIOS AND '// & + 'WILL BE MULTIPLIED BY K BEFORE BEING USED IN CALCULATIONS.' + case ('K33OVERK') + this%ik33overk = 1 + write (this%iout, '(4x,a)') & + 'VALUES SPECIFIED FOR K33 ARE ANISOTROPY RATIOS AND '// & + 'WILL BE MULTIPLIED BY K BEFORE BEING USED IN CALCULATIONS.' + case ('TVK6') + if (this%intvk /= 0) then + errmsg = 'Multiple TVK6 keywords detected in OPTIONS block.'// & + ' Only one TVK6 entry allowed.' + call store_error(errmsg, terminate=.TRUE.) + end if + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TVK6 keyword must be followed by "FILEIN" '// & + 'then by filename.' + call store_error(errmsg, terminate=.TRUE.) + end if + call this%parser%GetString(fname) + this%intvk = GetUnit() + call openfile(this%intvk, this%iout, fname, 'TVK') + call tvk_cr(this%tvk, this%name_model, this%intvk, this%iout) ! ! -- The following are options that are only available in the ! development version and are not included in the documentation. ! These options are only available when IDEVELOPMODE in ! constants module is set to 1 - case ('DEV_NO_NEWTON') - call this%parser%DevOpt() - this%inewton = 0 - write(this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method disabled for unconfined cells' - this%iasym = 0 - case ('DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION') - call this%parser%DevOpt() - this%iusgnrhc = 1 - write(this%iout, '(4x,a)') & - 'MODFLOW-USG saturation calculation method will be used ' - case ('DEV_MODFLOWNWT_UPSTREAM_WEIGHTING') - call this%parser%DevOpt() - this%inwtupw = 1 - write(this%iout, '(4x,a)') & - 'MODFLOW-NWT upstream weighting method will be used ' - case ('DEV_MINIMUM_SATURATED_THICKNESS') - call this%parser%DevOpt() - this%satmin = this%parser%GetDouble() - write(this%iout, '(4x,a,1pg15.6)') & - 'MINIMUM SATURATED THICKNESS HAS BEEN SET TO: ', & - this%satmin - case ('DEV_OMEGA') - call this%parser%DevOpt() - this%satomega = this%parser%GetDouble() - write(this%iout, '(4x,a,1pg15.6)') & - 'SATURATION OMEGA: ', this%satomega + case ('DEV_NO_NEWTON') + call this%parser%DevOpt() + this%inewton = 0 + write (this%iout, '(4x,a)') & + 'NEWTON-RAPHSON method disabled for unconfined cells' + this%iasym = 0 + case ('DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION') + call this%parser%DevOpt() + this%iusgnrhc = 1 + write (this%iout, '(4x,a)') & + 'MODFLOW-USG saturation calculation method will be used ' + case ('DEV_MODFLOWNWT_UPSTREAM_WEIGHTING') + call this%parser%DevOpt() + this%inwtupw = 1 + write (this%iout, '(4x,a)') & + 'MODFLOW-NWT upstream weighting method will be used ' + case ('DEV_MINIMUM_SATURATED_THICKNESS') + call this%parser%DevOpt() + this%satmin = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg15.6)') & + 'MINIMUM SATURATED THICKNESS HAS BEEN SET TO: ', & + this%satmin + case ('DEV_OMEGA') + call this%parser%DevOpt() + this%satomega = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg15.6)') & + 'SATURATION OMEGA: ', this%satomega - case default - write(errmsg,'(4x,a,a)') 'Unknown NPF option: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case default + write (errmsg, '(4x,a,a)') 'Unknown NPF option: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)') 'END OF NPF OPTIONS' + write (this%iout, '(1x,a)') 'END OF NPF OPTIONS' end if ! -- check if this%iusgnrhc has been enabled for a model that is not using ! the Newton-Raphson formulation if (this%iusgnrhc > 0 .and. this%inewton == 0) then this%iusgnrhc = 0 - write(this%iout, '(4x,a,3(1x,a))') & - '****WARNING. MODFLOW-USG saturation calculation not needed', & - 'for a model that is using the standard conductance formulation.', & - 'Resetting DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION OPTION from', & + write (this%iout, '(4x,a,3(1x,a))') & + '****WARNING. MODFLOW-USG saturation calculation not needed', & + 'for a model that is using the standard conductance formulation.', & + 'Resetting DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION OPTION from', & '1 to 0.' end if ! @@ -1462,9 +1463,9 @@ subroutine read_options(this) ! models if (this%inwtupw /= 0 .and. this%inewton == 0) then this%inwtupw = 0 - write(this%iout,'(4x,a,3(1x,a))') & - '****WARNING. The DEV_MODFLOWNWT_UPSTREAM_WEIGHTING option has', & - 'been specified for a model that is using the standard conductance', & + write (this%iout, '(4x,a,3(1x,a))') & + '****WARNING. The DEV_MODFLOWNWT_UPSTREAM_WEIGHTING option has', & + 'been specified for a model that is using the standard conductance', & 'formulation. Resetting DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION from', & '1 to 0.' end if @@ -1472,18 +1473,18 @@ subroutine read_options(this) ! -- check that the transmissivity weighting functions are not specified with ! with the this%inwtupw option if (this%inwtupw /= 0 .and. this%icellavg < 2) then - write(errmsg,'(4x,a,2(1x,a))') & - '****ERROR. THE DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION CAN', & - 'ONLY BE SPECIFIED WITH THE AMT-LMK AND AMT-HMK', & + write (errmsg, '(4x,a,2(1x,a))') & + '****ERROR. THE DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTION CAN', & + 'ONLY BE SPECIFIED WITH THE AMT-LMK AND AMT-HMK', & 'ALTERNATIVE_CELL_AVERAGING OPTIONS IN THE NPF PACKAGE.' call store_error(errmsg) end if ! ! -- check that this%iusgnrhc and this%inwtupw have not both been enabled if (this%iusgnrhc /= 0 .and. this%inwtupw /= 0) then - write(errmsg,'(4x,a,2(1x,a))') & - '****ERROR. THE DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION', & - 'AND DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTIONS CANNOT BE', & + write (errmsg, '(4x,a,2(1x,a))') & + '****ERROR. THE DEV_MODFLOWUSG_UPSTREAM_WEIGHTED_SATURATION', & + 'AND DEV_MODFLOWNWT_UPSTREAM_WEIGHTING OPTIONS CANNOT BE', & 'SPECIFIED IN THE SAME NPF PACKAGE.' call store_error(errmsg) end if @@ -1506,15 +1507,15 @@ subroutine set_options(this, options) class(GwfNpftype) :: this type(GwfNpfOptionsType), intent(in) :: options - this%icellavg = options%icellavg - this%ithickstrt = options%ithickstrt - this%iperched = options%iperched - this%ivarcv = options%ivarcv - this%idewatcv = options%idewatcv - this%irewet = options%irewet - this%wetfct = options%wetfct - this%iwetit = options%iwetit - this%ihdwet = options%ihdwet + this%icellavg = options%icellavg + this%ithickstrt = options%ithickstrt + this%iperched = options%iperched + this%ivarcv = options%ivarcv + this%idewatcv = options%idewatcv + this%irewet = options%irewet + this%wetfct = options%wetfct + this%iwetit = options%iwetit + this%ihdwet = options%ihdwet end subroutine set_options @@ -1538,71 +1539,71 @@ subroutine rewet_options(this) ! ! -- If rewet already set, then terminate with error if (this%irewet == 1) then - write(errmsg, '(a)') 'ERROR WITH NPF REWET OPTION. REWET WAS ' // & - 'ALREADY SET. REMOVE DUPLICATE REWET ENTRIES ' // & - 'FROM NPF OPTIONS BLOCK.' + write (errmsg, '(a)') 'ERROR WITH NPF REWET OPTION. REWET WAS '// & + 'ALREADY SET. REMOVE DUPLICATE REWET ENTRIES '// & + 'FROM NPF OPTIONS BLOCK.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if this%irewet = 1 - write(this%iout,'(4x,a)')'REWETTING IS ACTIVE.' + write (this%iout, '(4x,a)') 'REWETTING IS ACTIVE.' ! ! -- Parse rewet options do call this%parser%GetStringCaps(keyword) if (keyword == '') exit select case (keyword) - case ('WETFCT') - this%wetfct = this%parser%GetDouble() - write(this%iout,'(4x,a,1pg15.6)') & - 'WETTING FACTOR HAS BEEN SET TO: ', this%wetfct - lfound(1) = .true. - case ('IWETIT') - if (.not. lfound(1)) then - write(errmsg,'(4x,a)') & - 'NPF rewetting flags must be specified in order. ' // & - 'Found iwetit but wetfct not specified.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - ival = this%parser%GetInteger() - if(ival <= 0) ival = 1 - this%iwetit = ival - write(this%iout,'(4x,a,i5)') 'IWETIT HAS BEEN SET TO: ', & - this%iwetit - lfound(2) = .true. - case ('IHDWET') - if (.not. lfound(2)) then - write(errmsg,'(4x,a)') & - 'NPF rewetting flags must be specified in order. ' // & - 'Found ihdwet but iwetit not specified.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - this%ihdwet = this%parser%GetInteger() - write(this%iout,'(4x,a,i5)') 'IHDWET HAS BEEN SET TO: ', & - this%ihdwet - lfound(3) = .true. - case default - write(errmsg,'(4x,a,a)') 'Unknown NPF rewet option: ', trim(keyword) + case ('WETFCT') + this%wetfct = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg15.6)') & + 'WETTING FACTOR HAS BEEN SET TO: ', this%wetfct + lfound(1) = .true. + case ('IWETIT') + if (.not. lfound(1)) then + write (errmsg, '(4x,a)') & + 'NPF rewetting flags must be specified in order. '// & + 'Found iwetit but wetfct not specified.' call store_error(errmsg) call this%parser%StoreErrorUnit() + end if + ival = this%parser%GetInteger() + if (ival <= 0) ival = 1 + this%iwetit = ival + write (this%iout, '(4x,a,i5)') 'IWETIT HAS BEEN SET TO: ', & + this%iwetit + lfound(2) = .true. + case ('IHDWET') + if (.not. lfound(2)) then + write (errmsg, '(4x,a)') & + 'NPF rewetting flags must be specified in order. '// & + 'Found ihdwet but iwetit not specified.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + this%ihdwet = this%parser%GetInteger() + write (this%iout, '(4x,a,i5)') 'IHDWET HAS BEEN SET TO: ', & + this%ihdwet + lfound(3) = .true. + case default + write (errmsg, '(4x,a,a)') 'Unknown NPF rewet option: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select - enddo + end do ! if (.not. lfound(3)) then - write(errmsg,'(4x,a)') & - '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. ' // & + write (errmsg, '(4x,a)') & + '****ERROR. NPF REWETTING FLAGS MUST BE SPECIFIED IN ORDER. '// & 'DID NOT FIND IHDWET AS LAST REWET SETTING.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Write rewet settings - write(this%iout, '(4x, a)') 'THE FOLLOWING REWET SETTINGS WILL BE USED.' - write(this%iout, '(6x, a,1pg15.6)') ' WETFCT = ', this%wetfct - write(this%iout, '(6x, a,i0)') ' IWETIT = ', this%iwetit - write(this%iout, '(6x, a,i0)') ' IHDWET = ', this%ihdwet + write (this%iout, '(4x, a)') 'THE FOLLOWING REWET SETTINGS WILL BE USED.' + write (this%iout, '(6x, a,1pg15.6)') ' WETFCT = ', this%wetfct + write (this%iout, '(6x, a,i0)') ' IWETIT = ', this%iwetit + write (this%iout, '(6x, a,i0)') ' IHDWET = ', this%ihdwet ! ! -- Return return @@ -1624,52 +1625,52 @@ subroutine check_options(this) character(len=LINELENGTH) :: errmsg ! ------------------------------------------------------------------------------ ! - if(this%inewton > 0) then - if(this%iperched > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & - 'BE USED WITH PERCHED OPTION.' + if (this%inewton > 0) then + if (this%iperched > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT '// & + 'BE USED WITH PERCHED OPTION.' call store_error(errmsg) - endif - if(this%ivarcv > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & - 'BE USED WITH VARIABLECV OPTION.' + end if + if (this%ivarcv > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT '// & + 'BE USED WITH VARIABLECV OPTION.' call store_error(errmsg) - endif - if(this%irewet > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT ' // & - 'BE USED WITH REWET OPTION.' + end if + if (this%irewet > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. NEWTON OPTION CANNOT '// & + 'BE USED WITH REWET OPTION.' call store_error(errmsg) - endif - endif + end if + end if ! if (this%ixt3d /= 0) then - if(this%icellavg > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. ' // & - 'ALTERNATIVE_CELL_AVERAGING OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' + if (this%icellavg > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. '// & + 'ALTERNATIVE_CELL_AVERAGING OPTION '// & + 'CANNOT BE USED WITH XT3D OPTION.' call store_error(errmsg) - endif - if(this%ithickstrt > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. THICKSTRT OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' + end if + if (this%ithickstrt > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. THICKSTRT OPTION '// & + 'CANNOT BE USED WITH XT3D OPTION.' call store_error(errmsg) - endif - if(this%iperched > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. PERCHED OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' + end if + if (this%iperched > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. PERCHED OPTION '// & + 'CANNOT BE USED WITH XT3D OPTION.' call store_error(errmsg) - endif - if(this%ivarcv > 0) then - write(errmsg, '(a)') 'ERROR IN NPF OPTIONS. VARIABLECV OPTION ' // & - 'CANNOT BE USED WITH XT3D OPTION.' + end if + if (this%ivarcv > 0) then + write (errmsg, '(a)') 'ERROR IN NPF OPTIONS. VARIABLECV OPTION '// & + 'CANNOT BE USED WITH XT3D OPTION.' call store_error(errmsg) - endif + end if end if ! ! -- Terminate if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return @@ -1683,28 +1684,28 @@ subroutine read_grid_data(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH, DONE, DPIO180 + use ConstantsModule, only: LINELENGTH, DONE, DPIO180 use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate, & mem_reassignptr - use SimModule, only: store_error, count_errors + use SimModule, only: store_error, count_errors ! -- dummy class(GwfNpftype) :: this ! -- local character(len=LINELENGTH) :: errmsg integer(I4B) :: n, ierr logical :: isfound - logical, dimension(8) :: lname + logical, dimension(8) :: lname character(len=24), dimension(:), pointer :: aname character(len=24), dimension(8) :: varinames ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED TO LISTING FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtnct = & - "(1x, 'Negative cell thickness at cell: ', a)" + character(len=*), parameter :: fmtiprflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE PRINTED TO LISTING FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtnct = & + &"(1x, 'Negative cell thickness at cell: ', a)" ! -- data !data aname(1) /' ICELLTYPE'/ !data aname(2) /' K'/ @@ -1727,60 +1728,60 @@ subroutine read_grid_data(this) ! -- Read all of the arrays in the GRIDDATA block using the get_block_data ! method, which is part of NumericalPackageType call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' call this%get_block_data(aname, lname, varinames) else - write(errmsg,'(1x,a)') 'Required GRIDDATA block not found.' + write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if ! ! -- Check for ICELLTYPE - if(.not. lname(1)) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(1))), ' not found.' + if (.not. lname(1)) then + write (errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(1))), ' not found.' call store_error(errmsg) - endif + end if ! ! -- Check for K - if(.not. lname(2)) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(2))), ' not found.' + if (.not. lname(2)) then + write (errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(2))), ' not found.' call store_error(errmsg) - endif + end if ! ! -- set ik33 flag - if(lname(3)) then + if (lname(3)) then this%ik33 = 1 else if (this%ik33overk /= 0) then - write(errmsg, '(a)') 'K33OVERK option specified but K33 not specified.' + write (errmsg, '(a)') 'K33OVERK option specified but K33 not specified.' call store_error(errmsg) - endif - write(this%iout, '(1x, a)') 'K33 not provided. Assuming K33 = K.' - call mem_reassignptr(this%k33, 'K33', trim(this%memoryPath), & - 'K11', trim(this%memoryPath)) - endif + end if + write (this%iout, '(1x, a)') 'K33 not provided. Assuming K33 = K.' + call mem_reassignptr(this%k33, 'K33', trim(this%memoryPath), & + 'K11', trim(this%memoryPath)) + end if ! ! -- set ik22 flag - if(lname(4)) then + if (lname(4)) then this%ik22 = 1 else if (this%ik22overk /= 0) then - write(errmsg, '(a)') 'K22OVERK option specified but K22 not specified.' + write (errmsg, '(a)') 'K22OVERK option specified but K22 not specified.' call store_error(errmsg) - endif - write(this%iout, '(1x, a)') 'K22 not provided. Assuming K22 = K.' - call mem_reassignptr(this%k22, 'K22', trim(this%memoryPath), & - 'K11', trim(this%memoryPath)) - endif + end if + write (this%iout, '(1x, a)') 'K22 not provided. Assuming K22 = K.' + call mem_reassignptr(this%k22, 'K22', trim(this%memoryPath), & + 'K11', trim(this%memoryPath)) + end if ! ! -- Set WETDRY if (lname(5)) then this%iwetdry = 1 else - call mem_reallocate(this%wetdry, 1, 'WETDRY', trim(this%memoryPath)) + call mem_reallocate(this%wetdry, 1, 'WETDRY', trim(this%memoryPath)) end if ! ! -- set angle flags @@ -1788,31 +1789,31 @@ subroutine read_grid_data(this) this%iangle1 = 1 else if (this%ixt3d == 0) then - call mem_reallocate(this%angle1, 1, 'ANGLE1', trim(this%memoryPath)) + call mem_reallocate(this%angle1, 1, 'ANGLE1', trim(this%memoryPath)) end if - endif + end if if (lname(7)) then this%iangle2 = 1 else if (this%ixt3d == 0) then - call mem_reallocate(this%angle2, 1, 'ANGLE2', trim(this%memoryPath)) + call mem_reallocate(this%angle2, 1, 'ANGLE2', trim(this%memoryPath)) end if - endif + end if if (lname(8)) then this%iangle3 = 1 else if (this%ixt3d == 0) then - call mem_reallocate(this%angle3, 1, 'ANGLE3', trim(this%memoryPath)) + call mem_reallocate(this%angle3, 1, 'ANGLE3', trim(this%memoryPath)) end if - endif + end if ! ! -- terminate if read errors encountered - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Final NPFDATA message - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' ! ! -- Return return @@ -1833,8 +1834,8 @@ subroutine set_grid_data(this, npf_data) else ! if not present, then K22 = K11 this%ik22 = 0 - call mem_reassignptr(this%k22, 'K22', trim(this%memoryPath), & - 'K11', trim(this%memoryPath)) + call mem_reassignptr(this%k22, 'K22', trim(this%memoryPath), & + 'K11', trim(this%memoryPath)) end if if (npf_data%ik33 == 1) then @@ -1843,8 +1844,8 @@ subroutine set_grid_data(this, npf_data) else ! if not present, then K33 = K11 this%ik33 = 0 - call mem_reassignptr(this%k33, 'K33', trim(this%memoryPath), & - 'K11', trim(this%memoryPath)) + call mem_reassignptr(this%k33, 'K33', trim(this%memoryPath), & + 'K11', trim(this%memoryPath)) end if if (npf_data%iwetdry == 1) then @@ -1891,7 +1892,7 @@ subroutine prepcheck(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH, DPIO180 + use ConstantsModule, only: LINELENGTH, DPIO180 use SimModule, only: store_error, count_errors ! -- dummy class(GwfNpfType) :: this @@ -1900,10 +1901,10 @@ subroutine prepcheck(this) character(len=LINELENGTH) :: cellstr, errmsg integer(I4B) :: nerr, n ! -- format - character(len=*), parameter :: fmtkerr = & - "(1x, 'Hydraulic property ',a,' is <= 0 for cell ',a, ' ', 1pg15.6)" - character(len=*), parameter :: fmtkerr2 = & - "(1x, '... ', i0,' additional errors not shown for ',a)" + character(len=*), parameter :: fmtkerr = & + &"(1x, 'Hydraulic property ',a,' is <= 0 for cell ',a, ' ', 1pg15.6)" + character(len=*), parameter :: fmtkerr2 = & + &"(1x, '... ', i0,' additional errors not shown for ',a)" ! ------------------------------------------------------------------------------ ! ! -- initialize @@ -1912,20 +1913,20 @@ subroutine prepcheck(this) ! -- check k11 nerr = 0 do n = 1, size(this%k11) - if(this%k11(n) <= DZERO) then + if (this%k11(n) <= DZERO) then nerr = nerr + 1 - if(nerr <= 20) then + if (nerr <= 20) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(aname(2))), trim(cellstr), & - this%k11(n) + write (errmsg, fmtkerr) trim(adjustl(aname(2))), trim(cellstr), & + this%k11(n) call store_error(errmsg) - endif - endif - enddo - if(nerr > 20) then - write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(2))) + end if + end if + end do + if (nerr > 20) then + write (errmsg, fmtkerr2) nerr, trim(adjustl(aname(2))) call store_error(errmsg) - endif + end if ! ! -- check k33 because it was read if (this%ik33 /= 0) then @@ -1934,119 +1935,119 @@ subroutine prepcheck(this) nerr = 0 do n = 1, size(this%k33) if (this%ik33overk /= 0) this%k33(n) = this%k33(n) * this%k11(n) - if(this%k33(n) <= DZERO) then + if (this%k33(n) <= DZERO) then nerr = nerr + 1 - if(nerr <= 20) then + if (nerr <= 20) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(aname(3))), trim(cellstr), & - this%k33(n) + write (errmsg, fmtkerr) trim(adjustl(aname(3))), trim(cellstr), & + this%k33(n) call store_error(errmsg) - endif - endif - enddo - if(nerr > 20) then - write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(3))) + end if + end if + end do + if (nerr > 20) then + write (errmsg, fmtkerr2) nerr, trim(adjustl(aname(3))) call store_error(errmsg) - endif + end if end if ! ! -- check k22 because it was read if (this%ik22 /= 0) then ! ! -- Check to make sure that angles are available - if(this%dis%con%ianglex == 0) then - write(errmsg, '(a)') 'Error. ANGLDEGX not provided in ' // & - 'discretization file, but K22 was specified. ' + if (this%dis%con%ianglex == 0) then + write (errmsg, '(a)') 'Error. ANGLDEGX not provided in '// & + 'discretization file, but K22 was specified. ' call store_error(errmsg) - endif + end if ! ! -- Check to make sure values are greater than or equal to zero nerr = 0 do n = 1, size(this%k22) if (this%ik22overk /= 0) this%k22(n) = this%k22(n) * this%k11(n) - if(this%k22(n) <= DZERO) then + if (this%k22(n) <= DZERO) then nerr = nerr + 1 - if(nerr <= 20) then + if (nerr <= 20) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(aname(4))), trim(cellstr), & - this%k22(n) + write (errmsg, fmtkerr) trim(adjustl(aname(4))), trim(cellstr), & + this%k22(n) call store_error(errmsg) - endif - endif - enddo - if(nerr > 20) then - write(errmsg, fmtkerr2) nerr, trim(adjustl(aname(4))) + end if + end if + end do + if (nerr > 20) then + write (errmsg, fmtkerr2) nerr, trim(adjustl(aname(4))) call store_error(errmsg) - endif + end if end if ! ! -- check for wetdry conflicts - if(this%irewet == 1) then - if(this%iwetdry == 0) then - write(errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & - trim(adjustl(aname(5))), ' not found.' + if (this%irewet == 1) then + if (this%iwetdry == 0) then + write (errmsg, '(a, a, a)') 'Error in GRIDDATA block: ', & + trim(adjustl(aname(5))), ' not found.' call store_error(errmsg) end if - endif + end if ! ! -- Check for angle conflicts if (this%iangle1 /= 0) then do n = 1, size(this%angle1) this%angle1(n) = this%angle1(n) * DPIO180 - enddo + end do else - if(this%ixt3d /= 0) then + if (this%ixt3d /= 0) then this%iangle1 = 1 - write(this%iout, '(a)') 'XT3D IN USE, BUT ANGLE1 NOT SPECIFIED. ' // & + write (this%iout, '(a)') 'XT3D IN USE, BUT ANGLE1 NOT SPECIFIED. '// & 'SETTING ANGLE1 TO ZERO.' do n = 1, size(this%angle1) this%angle1(n) = DZERO - enddo - endif - endif + end do + end if + end if if (this%iangle2 /= 0) then if (this%iangle1 == 0) then - write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE1. ' // & - 'ANGLE2 REQUIRES ANGLE1. ' + write (errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE1. '// & + 'ANGLE2 REQUIRES ANGLE1. ' call store_error(errmsg) - endif + end if if (this%iangle3 == 0) then - write(errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE3. ' // & - 'SPECIFY BOTH OR NEITHER ONE. ' + write (errmsg, '(a)') 'ANGLE2 SPECIFIED BUT NOT ANGLE3. '// & + 'SPECIFY BOTH OR NEITHER ONE. ' call store_error(errmsg) - endif + end if do n = 1, size(this%angle2) this%angle2(n) = this%angle2(n) * DPIO180 - enddo - endif + end do + end if if (this%iangle3 /= 0) then if (this%iangle1 == 0) then - write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE1. ' // & - 'ANGLE3 REQUIRES ANGLE1. ' + write (errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE1. '// & + 'ANGLE3 REQUIRES ANGLE1. ' call store_error(errmsg) - endif + end if if (this%iangle2 == 0) then - write(errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE2. ' // & - 'SPECIFY BOTH OR NEITHER ONE. ' + write (errmsg, '(a)') 'ANGLE3 SPECIFIED BUT NOT ANGLE2. '// & + 'SPECIFY BOTH OR NEITHER ONE. ' call store_error(errmsg) - endif + end if do n = 1, size(this%angle3) this%angle3(n) = this%angle3(n) * DPIO180 - enddo - endif + end do + end if ! ! -- terminate if data errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif - + end if + return end subroutine prepcheck !> @brief preprocess the NPF input data !! !! This routine consists of the following steps: - !! + !! !! 1. convert cells to noflow when all transmissive parameters equal zero !! 2. perform initial wetting and drying !! 3. initialize cell saturation @@ -2054,28 +2055,28 @@ end subroutine prepcheck !! 5. If NEWTON under-relaxation, determine lower most node !< subroutine preprocess_input(this) - use ConstantsModule, only: LINELENGTH - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate - use SimModule, only: store_error, count_errors + use ConstantsModule, only: LINELENGTH + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_deallocate + use SimModule, only: store_error, count_errors class(GwfNpfType) :: this !< the instance of the NPF package - ! local + ! local integer(I4B) :: n, m, ii, nn real(DP) :: hyn, hym - real(DP) :: satn, topn, botn + real(DP) :: satn, topn, botn integer(I4B) :: nextn - real(DP) :: minbot, botm + real(DP) :: minbot, botm logical :: finished character(len=LINELENGTH) :: cellstr, errmsg ! format strings - character(len=*),parameter :: fmtcnv = & - "(1X,'CELL ', A, & - &' ELIMINATED BECAUSE ALL HYDRAULIC CONDUCTIVITIES TO NODE ARE 0.')" - character(len=*),parameter :: fmtnct = & - "(1X,'Negative cell thickness at cell ', A)" - character(len=*),parameter :: fmtihbe = & - "(1X,'Initial head, bottom elevation:',1P,2G13.5)" - character(len=*),parameter :: fmttebe = & - "(1X,'Top elevation, bottom elevation:',1P,2G13.5)" + character(len=*), parameter :: fmtcnv = & + "(1X,'CELL ', A, & + &' ELIMINATED BECAUSE ALL HYDRAULIC CONDUCTIVITIES TO NODE ARE 0.')" + character(len=*), parameter :: fmtnct = & + &"(1X,'Negative cell thickness at cell ', A)" + character(len=*), parameter :: fmtihbe = & + &"(1X,'Initial head, bottom elevation:',1P,2G13.5)" + character(len=*), parameter :: fmttebe = & + &"(1X,'Top elevation, bottom elevation:',1P,2G13.5)" ! do n = 1, this%dis%nodes this%ithickstartflag(n) = 0 @@ -2087,41 +2088,41 @@ subroutine preprocess_input(this) nodeloop: do n = 1, this%dis%nodes ! ! -- Skip if already inactive - if(this%ibound(n) == 0) then - if(this%irewet /= 0) then - if(this%wetdry(n) == DZERO) cycle nodeloop + if (this%ibound(n) == 0) then + if (this%irewet /= 0) then + if (this%wetdry(n) == DZERO) cycle nodeloop else cycle nodeloop - endif - endif + end if + end if ! ! -- Cycle if k11 is not zero - if(this%k11(n) /= DZERO) cycle nodeloop + if (this%k11(n) /= DZERO) cycle nodeloop ! ! -- Cycle if at least one vertical connection has non-zero k33 ! for n and m do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ii) - if(this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then + if (this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then hyn = this%k11(n) - if(this%ik33 /= 0) hyn = this%k33(n) - if(hyn /= DZERO) then + if (this%ik33 /= 0) hyn = this%k33(n) + if (hyn /= DZERO) then hym = this%k11(m) - if(this%ik33 /= 0) hym = this%k33(m) - if(hym /= DZERO) cycle - endif - endif - enddo + if (this%ik33 /= 0) hym = this%k33(m) + if (hym /= DZERO) cycle + end if + end if + end do ! ! -- If this part of the loop is reached, then all connections have ! zero transmissivity, so convert to noflow. this%ibound(n) = 0 this%hnew(n) = this%hnoflo - if(this%irewet /= 0) this%wetdry(n) = DZERO + if (this%irewet /= 0) this%wetdry(n) = DZERO call this%dis%noder_to_string(n, cellstr) - write(this%iout, fmtcnv) trim(adjustl(cellstr)) + write (this%iout, fmtcnv) trim(adjustl(cellstr)) ! - enddo nodeloop + end do nodeloop ! ! -- Preprocess cell status and heads based on initial conditions if (this%inewton == 0) then @@ -2148,66 +2149,66 @@ subroutine preprocess_input(this) ! Initialize sat to 1.0 for all other cells in order to calculate ! condsat in next section. do n = 1, this%dis%nodes - if(this%ibound(n) == 0) then + if (this%ibound(n) == 0) then this%sat(n) = DONE - if(this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then + if (this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then this%ithickstartflag(n) = 1 this%icelltype(n) = 0 - endif + end if else topn = this%dis%top(n) botn = this%dis%bot(n) - if(this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then + if (this%icelltype(n) < 0 .and. this%ithickstrt /= 0) then call this%thksat(n, this%ic%strt(n), satn) - if(botn > this%ic%strt(n)) then + if (botn > this%ic%strt(n)) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtnct) trim(adjustl(cellstr)) + write (errmsg, fmtnct) trim(adjustl(cellstr)) call store_error(errmsg) - write(errmsg, fmtihbe) this%ic%strt(n), botn + write (errmsg, fmtihbe) this%ic%strt(n), botn call store_error(errmsg) - endif + end if this%ithickstartflag(n) = 1 this%icelltype(n) = 0 else satn = DONE - if(botn > topn) then + if (botn > topn) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtnct) trim(adjustl(cellstr)) + write (errmsg, fmtnct) trim(adjustl(cellstr)) call store_error(errmsg) - write(errmsg, fmttebe) topn, botn + write (errmsg, fmttebe) topn, botn call store_error(errmsg) - endif - endif + end if + end if this%sat(n) = satn - endif - enddo - if(count_errors() > 0) then + end if + end do + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Calculate condsat, but only if xt3d is not active. If xt3d is ! active, then condsat is allocated to size of zero. if (this%ixt3d == 0) then - ! - ! -- Calculate the saturated conductance for all connections assuming - ! that saturation is 1 (except for case where icelltype was entered - ! as a negative value and THCKSTRT option in effect) - do n = 1, this%dis%nodes - call this%calc_condsat(n, .true.) - enddo - ! - endif + ! + ! -- Calculate the saturated conductance for all connections assuming + ! that saturation is 1 (except for case where icelltype was entered + ! as a negative value and THCKSTRT option in effect) + do n = 1, this%dis%nodes + call this%calc_condsat(n, .true.) + end do + ! + end if ! ! -- Determine the lower most node if (this%igwfnewtonur /= 0) then - call mem_reallocate(this%ibotnode, this%dis%nodes, 'IBOTNODE', & + call mem_reallocate(this%ibotnode, this%dis%nodes, 'IBOTNODE', & trim(this%memoryPath)) do n = 1, this%dis%nodes ! minbot = this%dis%bot(n) nn = n finished = .false. - do while(.not. finished) + do while (.not. finished) nextn = 0 ! ! -- Go through the connecting cells @@ -2218,7 +2219,7 @@ subroutine preprocess_input(this) botm = this%dis%bot(m) ! ! -- select vertical connections: ihc == 0 - if(this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then + if (this%dis%con%ihc(this%dis%con%jas(ii)) == 0) then if (m > nn .and. botm < minbot) then nextn = m minbot = botm @@ -2271,8 +2272,8 @@ subroutine calc_condsat(this, node, upperOnly) ! -- we're not updating both upper and lower matrix parts for this node m = this%dis%con%ja(ii) jj = this%dis%con%jas(ii) - if(m < node) then - if(upperOnly) cycle + if (m < node) then + if (upperOnly) cycle ! m => node, n => neighbour n = m m = node @@ -2296,12 +2297,12 @@ subroutine calc_condsat(this, node, upperOnly) ihc = this%dis%con%ihc(jj) hyn = this%hy_eff(n, m, ihc, ipos=ii) hym = this%hy_eff(m, n, ihc, ipos=ii) - if(this%ithickstartflag(n) == 0) then + if (this%ithickstartflag(n) == 0) then hn = topn else hn = this%ic%strt(n) end if - if(this%ithickstartflag(m) == 0) then + if (this%ithickstartflag(m) == 0) then hm = topm else hm = this%ic%strt(m) @@ -2309,33 +2310,33 @@ subroutine calc_condsat(this, node, upperOnly) ! ! -- Calculate conductance depending on whether connection is ! vertical (0), horizontal (1), or staggered horizontal (2) - if(ihc == 0) then + if (ihc == 0) then ! ! -- Vertical conductance for fully saturated conditions - csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & - botn, botm, & - hyn, hym, & - satn, satm, & - topn, topm, & - botn, botm, & + csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & + botn, botm, & + hyn, hym, & + satn, satm, & + topn, topm, & + botn, botm, & this%dis%con%hwva(jj)) else ! ! -- Horizontal conductance for fully saturated conditions fawidth = this%dis%con%hwva(jj) - csat = hcond(1, 1, 1, 1, this%inewton, 0, & - ihc, & - this%icellavg, this%iusgnrhc, this%inwtupw, & - DONE, & - hn, hm, satn, satm, hyn, hym, & - topn, topm, & - botn, botm, & - this%dis%con%cl1(jj), & - this%dis%con%cl2(jj), & + csat = hcond(1, 1, 1, 1, this%inewton, 0, & + ihc, & + this%icellavg, this%iusgnrhc, this%inwtupw, & + DONE, & + hn, hm, satn, satm, hyn, hym, & + topn, topm, & + botn, botm, & + this%dis%con%cl1(jj), & + this%dis%con%cl2(jj), & fawidth, this%satomega, this%satmin) end if this%condsat(jj) = csat - enddo + end do ! return end subroutine calc_condsat @@ -2355,9 +2356,9 @@ function calc_initial_sat(this, n) result(satn) real(DP) :: satn ! satn = DONE - if(this%ibound(n) /= 0 .and. this%ithickstartflag(n) /= 0) then + if (this%ibound(n) /= 0 .and. this%ithickstartflag(n) /= 0) then call this%thksat(n, this%ic%strt(n), satn) - endif + end if ! return end function calc_initial_sat @@ -2370,34 +2371,34 @@ subroutine sgwf_npf_wetdry(this, kiter, hnew) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only: kstp, kper - use SimModule, only: store_error + use TdisModule, only: kstp, kper + use SimModule, only: store_error use ConstantsModule, only: LINELENGTH ! -- dummy class(GwfNpfType) :: this - integer(I4B),intent(in) :: kiter - real(DP),intent(inout),dimension(:) :: hnew + integer(I4B), intent(in) :: kiter + real(DP), intent(inout), dimension(:) :: hnew ! -- local integer(I4B) :: n, m, ii, ihc real(DP) :: ttop, bbot, thck - integer(I4B) :: ncnvrt,ihdcnv + integer(I4B) :: ncnvrt, ihdcnv character(len=30), dimension(5) :: nodcnvrt character(len=30) :: nodestr - character(len=3),dimension(5) :: acnvrt + character(len=3), dimension(5) :: acnvrt character(len=LINELENGTH) :: errmsg integer(I4B) :: irewet ! -- formats - character(len=*),parameter :: fmtnct = & - "(1X,/1X,'Negative cell thickness at (layer,row,col)', & - &I4,',',I5,',',I5)" - character(len=*),parameter :: fmttopbot = & - "(1X,'Top elevation, bottom elevation:',1P,2G13.5)" - character(len=*),parameter :: fmttopbotthk = & - "(1X,'Top elevation, bottom elevation, thickness:',1P,3G13.5)" - character(len=*),parameter :: fmtdrychd = & - "(1X,/1X,'CONSTANT-HEAD CELL WENT DRY -- SIMULATION ABORTED')" - character(len=*),parameter :: fmtni = & - "(1X,'CELLID=',a,' ITERATION=',I0,' TIME STEP=',I0,' STRESS PERIOD=',I0)" + character(len=*), parameter :: fmtnct = & + "(1X,/1X,'Negative cell thickness at (layer,row,col)', & + &I4,',',I5,',',I5)" + character(len=*), parameter :: fmttopbot = & + &"(1X,'Top elevation, bottom elevation:',1P,2G13.5)" + character(len=*), parameter :: fmttopbotthk = & + &"(1X,'Top elevation, bottom elevation, thickness:',1P,3G13.5)" + character(len=*), parameter :: fmtdrychd = & + &"(1X,/1X,'CONSTANT-HEAD CELL WENT DRY -- SIMULATION ABORTED')" + character(len=*), parameter :: fmtni = & + &"(1X,'CELLID=',a,' ITERATION=',I0,' TIME STEP=',I0,' STRESS PERIOD=',I0)" ! ------------------------------------------------------------------------------ ! -- Initialize ncnvrt = 0 @@ -2405,67 +2406,67 @@ subroutine sgwf_npf_wetdry(this, kiter, hnew) ! ! -- Convert dry cells to wet do n = 1, this%dis%nodes - do ii = this%dis%con%ia(n)+1,this%dis%con%ia(n+1)-1 + do ii = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ii) ihc = this%dis%con%ihc(this%dis%con%jas(ii)) - call this%rewet_check(kiter, n, hnew(m), this%ibound(m), ihc, hnew, & - irewet) - if(irewet == 1) then - call this%wdmsg(2,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) - endif - enddo - enddo + call this%rewet_check(kiter, n, hnew(m), this%ibound(m), ihc, hnew, & + irewet) + if (irewet == 1) then + call this%wdmsg(2, ncnvrt, nodcnvrt, acnvrt, ihdcnv, kiter, n) + end if + end do + end do ! ! -- Perform drying - do n=1,this%dis%nodes + do n = 1, this%dis%nodes ! ! -- cycle if inactive or confined - if(this%ibound(n) == 0) cycle - if(this%icelltype(n) == 0) cycle + if (this%ibound(n) == 0) cycle + if (this%icelltype(n) == 0) cycle ! ! -- check for negative cell thickness - bbot=this%dis%bot(n) - ttop=this%dis%top(n) - if(bbot>ttop) then - write(errmsg, fmtnct) n + bbot = this%dis%bot(n) + ttop = this%dis%top(n) + if (bbot > ttop) then + write (errmsg, fmtnct) n call store_error(errmsg) - write(errmsg, fmttopbot) ttop,bbot + write (errmsg, fmttopbot) ttop, bbot call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Calculate saturated thickness - if(this%icelltype(n)/=0) then - if(hnew(n) 0) then - itflg=mod(kiter, this%iwetit) - if(itflg == 0) then - if(this%ibound(node) == 0 .and. this%wetdry(node) /= DZERO) then + if (this%irewet > 0) then + itflg = mod(kiter, this%iwetit) + if (itflg == 0) then + if (this%ibound(node) == 0 .and. this%wetdry(node) /= DZERO) then ! ! -- Calculate wetting elevation bbot = this%dis%bot(node) wd = this%wetdry(node) awd = wd - if(wd < 0) awd=-wd + if (wd < 0) awd = -wd turnon = bbot + awd ! ! -- Check head in adjacent cells to see if wetting elevation has ! been reached - if(ihc == 0) then + if (ihc == 0) then ! ! -- check cell below - if(ibdm > 0 .and. hm >= turnon) irewet = 1 + if (ibdm > 0 .and. hm >= turnon) irewet = 1 else - if(wd > DZERO) then + if (wd > DZERO) then ! ! -- check horizontally adjacent cells - if(ibdm > 0 .and. hm >= turnon) irewet = 1 + if (ibdm > 0 .and. hm >= turnon) irewet = 1 end if - endif + end if ! - if(irewet == 1) then + if (irewet == 1) then ! -- rewet cell; use equation 3a if ihdwet=0; use equation 3b if ! ihdwet is not 0. - if(this%ihdwet==0) then + if (this%ihdwet == 0) then hnew(node) = bbot + this%wetfct * (hm - bbot) else hnew(node) = bbot + this%wetfct * awd !(hm - bbot) - endif + end if this%ibound(node) = 30000 - endif - endif - endif - endif + end if + end if + end if + end if ! ! -- Return return end subroutine rewet_check - subroutine sgwf_npf_wdmsg(this,icode,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) + subroutine sgwf_npf_wdmsg(this, icode, ncnvrt, nodcnvrt, acnvrt, ihdcnv, & + kiter, n) ! ****************************************************************************** ! sgwf_npf_wdmsg -- Print wet/dry message ! ****************************************************************************** @@ -2556,40 +2558,41 @@ subroutine sgwf_npf_wdmsg(this,icode,ncnvrt,nodcnvrt,acnvrt,ihdcnv,kiter,n) use TdisModule, only: kstp, kper ! -- dummy class(GwfNpfType) :: this - integer(I4B),intent(in) :: icode - integer(I4B),intent(inout) :: ncnvrt + integer(I4B), intent(in) :: icode + integer(I4B), intent(inout) :: ncnvrt character(len=30), dimension(5), intent(inout) :: nodcnvrt - character(len=3),dimension(5),intent(inout) :: acnvrt - integer(I4B),intent(inout) :: ihdcnv - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: n + character(len=3), dimension(5), intent(inout) :: acnvrt + integer(I4B), intent(inout) :: ihdcnv + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: n ! -- local integer(I4B) :: l ! -- formats - character(len=*),parameter :: fmtcnvtn = & - "(1X,/1X,'CELL CONVERSIONS FOR ITER.=',I0, & + character(len=*), parameter :: fmtcnvtn = & + "(1X,/1X,'CELL CONVERSIONS FOR ITER.=',I0, & &' STEP=',I0,' PERIOD=',I0,' (NODE or LRC)')" - character(len=*),parameter :: fmtnode = "(1X,3X,5(A4, A20))" + character(len=*), parameter :: fmtnode = "(1X,3X,5(A4, A20))" ! ------------------------------------------------------------------------------ ! -- Keep track of cell conversions - if(icode>0) then - ncnvrt=ncnvrt+1 + if (icode > 0) then + ncnvrt = ncnvrt + 1 call this%dis%noder_to_string(n, nodcnvrt(ncnvrt)) - if(icode==1) then - acnvrt(ncnvrt)='DRY' + if (icode == 1) then + acnvrt(ncnvrt) = 'DRY' else - acnvrt(ncnvrt)='WET' + acnvrt(ncnvrt) = 'WET' end if end if ! ! -- Print a line if 5 conversions have occurred or if icode indicates that a ! partial line should be printed - if(ncnvrt==5 .or. (icode==0 .and. ncnvrt>0)) then - if(ihdcnv==0) write(this%iout,fmtcnvtn) kiter,kstp,kper - ihdcnv=1 - write(this%iout,fmtnode) (acnvrt(l), trim(adjustl(nodcnvrt(l))),l=1,ncnvrt) - ncnvrt=0 - endif + if (ncnvrt == 5 .or. (icode == 0 .and. ncnvrt > 0)) then + if (ihdcnv == 0) write (this%iout, fmtcnvtn) kiter, kstp, kper + ihdcnv = 1 + write (this%iout, fmtnode) & + (acnvrt(l), trim(adjustl(nodcnvrt(l))), l=1, ncnvrt) + ncnvrt = 0 + end if ! ! -- Return return @@ -2630,80 +2633,80 @@ function hy_eff(this, n, m, ihc, ipos, vg) result(hy) ! ! -- Initialize iipos = 0 - if(present(ipos)) iipos = ipos + if (present(ipos)) iipos = ipos hy11 = this%k11(n) hy22 = this%k11(n) hy33 = this%k11(n) - if(this%ik22 /= 0) hy22 = this%k22(n) - if(this%ik33 /= 0) hy33 = this%k33(n) + if (this%ik22 /= 0) hy22 = this%k22(n) + if (this%ik33 /= 0) hy33 = this%k33(n) ! ! -- Calculate effective K based on whether connection is vertical ! or horizontal - if(ihc == 0) then + if (ihc == 0) then ! ! -- Handle rotated anisotropy case that would affect the effective ! vertical hydraulic conductivity hy = hy33 - if(this%iangle2 > 0) then - if(present(vg)) then + if (this%iangle2 > 0) then + if (present(vg)) then vg1 = vg(1) vg2 = vg(2) vg3 = vg(3) else call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, iipos) - endif + end if ang1 = this%angle1(n) ang2 = this%angle2(n) ang3 = DZERO - if(this%iangle3 > 0) ang3 = this%angle3(n) - hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3, & + if (this%iangle3 > 0) ang3 = this%angle3(n) + hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3, & this%iavgkeff) - endif + end if ! else ! ! -- Handle horizontal case hy = hy11 - if(this%ik22 > 0) then - if(present(vg)) then + if (this%ik22 > 0) then + if (present(vg)) then vg1 = vg(1) vg2 = vg(2) vg3 = vg(3) else call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, iipos) - endif + end if ang1 = DZERO ang2 = DZERO ang3 = DZERO - if(this%iangle1 > 0) then + if (this%iangle1 > 0) then ang1 = this%angle1(n) - if(this%iangle2 > 0) then + if (this%iangle2 > 0) then ang2 = this%angle2(n) - if(this%iangle3 > 0) ang3 = this%angle3(n) - endif - endif - hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3, & + if (this%iangle3 > 0) ang3 = this%angle3(n) + end if + end if + hy = hyeff_calc(hy11, hy22, hy33, ang1, ang2, ang3, vg1, vg2, vg3, & this%iavgkeff) - endif + end if ! - endif + end if ! ! -- Return return end function hy_eff function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & - iupw, condsat, hn, hm, satn, satm, hkn, hkm, topn, topm, & - botn, botm, cln, clm, fawidth, satomega, satminopt) & - result(condnm) + iupw, condsat, hn, hm, satn, satm, hkn, hkm, topn, topm, & + botn, botm, cln, clm, fawidth, satomega, satminopt) & + result(condnm) ! ****************************************************************************** ! hcond -- Horizontal conductance between two cells ! inwtup: if 1, then upstream-weight condsat, otherwise recalculate ! -! hcond function uses a weighted transmissivity in the harmonic mean -! conductance calculations. This differs from the MODFLOW-NWT and MODFLOW-USG -! conductance calculations for the Newton-Raphson formulation which use a -! weighted hydraulic conductivity. +! hcond function uses a weighted transmissivity in the harmonic mean +! conductance calculations. This differs from the MODFLOW-NWT and MODFLOW-USG +! conductance calculations for the Newton-Raphson formulation which use a +! weighted hydraulic conductivity. ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -2757,11 +2760,11 @@ function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & end if ! ! -- If either n or m is inactive then conductance is zero - if(ibdn == 0 .or. ibdm == 0) then + if (ibdn == 0 .or. ibdm == 0) then condnm = DZERO - ! - ! -- if both cells are non-convertible then use condsat - elseif(ictn == 0 .and. ictm == 0) then + ! + ! -- if both cells are non-convertible then use condsat + elseif (ictn == 0 .and. ictm == 0) then if (icellavg /= 4) then condnm = condsat else @@ -2772,15 +2775,15 @@ function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & end if condnm = condnm * condsat end if - ! - ! -- At least one of the cells is convertible, so calculate average saturated - ! thickness and multiply with saturated conductance + ! + ! -- At least one of the cells is convertible, so calculate average saturated + ! thickness and multiply with saturated conductance else if (inwtup == 1) then ! -- set flag use to determine if bottom of cells n and m are ! significantly different indk = 0 - if (abs(botm-botn) < DEM2) indk = 1 + if (abs(botm - botn) < DEM2) indk = 1 ! -- recalculate saturation if using MODFLOW-USG saturation ! calculation approach if (iusg == 1 .and. indk == 0) then @@ -2824,7 +2827,7 @@ function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & ! ! -- If staggered connection, subtract parts of cell that are above and ! below the sill top and bottom elevations - if(ihc == 2) then + if (ihc == 2) then ! ! -- Calculate sill_top and sill_bot sill_top = min(topn, topm) @@ -2837,8 +2840,8 @@ function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & ! -- Calculate saturated thickness for cells n and m thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) - endif - + end if + athk = DONE if (iusg == 1) then if (ihc == 2) then @@ -2850,17 +2853,17 @@ function hcond(ibdn, ibdm, ictn, ictm, inewton, inwtup, ihc, icellavg, iusg, & thksatm = DONE end if ! - condnm = condmean(hkn, hkm, thksatn, thksatm, cln, clm, & + condnm = condmean(hkn, hkm, thksatn, thksatm, cln, clm, & fawidth, icellavg) * athk end if - endif + end if ! ! -- Return return end function hcond - function vcond(ibdn, ibdm, ictn, ictm, inewton, ivarcv, idewatcv, & - condsat, hn, hm, vkn, vkm, satn, satm, topn, topm, botn, & + function vcond(ibdn, ibdm, ictn, ictm, inewton, ivarcv, idewatcv, & + condsat, hn, hm, vkn, vkm, satn, satm, topn, topm, botn, & botm, flowarea) result(condnm) ! ****************************************************************************** ! vcond -- Vertical conductance between two cells @@ -2871,16 +2874,16 @@ function vcond(ibdn, ibdm, ictn, ictm, inewton, ivarcv, idewatcv, & ! -- return real(DP) :: condnm ! -- dummy - integer(I4B),intent(in) :: ibdn - integer(I4B),intent(in) :: ibdm + integer(I4B), intent(in) :: ibdn + integer(I4B), intent(in) :: ibdm integer(I4B), intent(in) :: ictn integer(I4B), intent(in) :: ictm integer(I4B), intent(in) :: inewton integer(I4B), intent(in) :: ivarcv integer(I4B), intent(in) :: idewatcv - real(DP),intent(in) :: condsat - real(DP),intent(in) :: hn - real(DP),intent(in) :: hm + real(DP), intent(in) :: condsat + real(DP), intent(in) :: hn + real(DP), intent(in) :: hm real(DP), intent(in) :: vkn real(DP), intent(in) :: vkm real(DP), intent(in) :: satn @@ -2896,50 +2899,50 @@ function vcond(ibdn, ibdm, ictn, ictm, inewton, ivarcv, idewatcv, & real(DP) :: bovk2 real(DP) :: denom ! ------------------------------------------------------------------------------ - ! - ! -- If either n or m is inactive then conductance is zero - if(ibdn == 0 .or. ibdm == 0) then - condnm = DZERO ! - ! -- if constantcv then use condsat - elseif(ivarcv == 0) then + ! -- If either n or m is inactive then conductance is zero + if (ibdn == 0 .or. ibdm == 0) then + condnm = DZERO + ! + ! -- if constantcv then use condsat + elseif (ivarcv == 0) then condnm = condsat - ! - ! -- if both cells are non-convertible then use condsat - elseif(ictn == 0 .and. ictm == 0) then + ! + ! -- if both cells are non-convertible then use condsat + elseif (ictn == 0 .and. ictm == 0) then condnm = condsat - ! - ! -- if both cells are fully saturated then use condsat - elseif(hn >= topn .and. hm >= topm) then + ! + ! -- if both cells are fully saturated then use condsat + elseif (hn >= topn .and. hm >= topm) then condnm = condsat - ! - ! -- At least one cell is partially saturated, so recalculate vertical - ! -- conductance for this connection - ! -- todo: upstream weighting? + ! + ! -- At least one cell is partially saturated, so recalculate vertical + ! -- conductance for this connection + ! -- todo: upstream weighting? else ! ! -- Default is for CV correction (dewatered option); use underlying ! saturation of 1. satntmp = satn satmtmp = satm - if(idewatcv == 0) then - if(botn > botm) then + if (idewatcv == 0) then + if (botn > botm) then ! -- n is above m satmtmp = DONE else ! -- m is above n satntmp = DONE - endif - endif + end if + end if bovk1 = satntmp * (topn - botn) * DHALF / vkn bovk2 = satmtmp * (topm - botm) * DHALF / vkm denom = (bovk1 + bovk2) - if(denom /= DZERO) then + if (denom /= DZERO) then condnm = flowarea / denom else condnm = DZERO - endif - endif + end if + end if ! ! -- Return return @@ -2992,36 +2995,36 @@ function condmean(k1, k2, thick1, thick2, cl1, cl2, width, iavgmeth) ! ! -- Averaging select case (iavgmeth) - ! - ! -- Harmonic-mean method - case(0) ! - if (t1*t2 > DZERO) then + ! -- Harmonic-mean method + case (0) + ! + if (t1 * t2 > DZERO) then condmean = width * t1 * t2 / (t1 * cl2 + t2 * cl1) else condmean = DZERO end if - ! - ! -- Logarithmic-mean method - case(1) - if (t1*t2 > DZERO) then + ! + ! -- Logarithmic-mean method + case (1) + if (t1 * t2 > DZERO) then tmean = logmean(t1, t2) else tmean = DZERO - endif + end if condmean = tmean * width / (cl1 + cl2) - ! - ! -- Arithmetic-mean thickness and logarithmic-mean hydraulic conductivity - case(2) - if (k1*k2 > DZERO) then + ! + ! -- Arithmetic-mean thickness and logarithmic-mean hydraulic conductivity + case (2) + if (k1 * k2 > DZERO) then kmean = logmean(k1, k2) else kmean = DZERO - endif + end if condmean = kmean * DHALF * (thick1 + thick2) * width / (cl1 + cl2) - ! - ! -- Arithmetic-mean thickness and harmonic-mean hydraulic conductivity - case(3) + ! + ! -- Arithmetic-mean thickness and harmonic-mean hydraulic conductivity + case (3) denom = (k1 * cl2 + k2 * cl1) if (denom > DZERO) then kmean = k1 * k2 / denom @@ -3053,18 +3056,18 @@ function logmean(d1, d2) ! ------------------------------------------------------------------------------ ! drat = d2 / d1 - if(drat <= DLNLOW .or. drat >= DLNHIGH) then + if (drat <= DLNLOW .or. drat >= DLNHIGH) then logmean = (d2 - d1) / log(drat) else logmean = DHALF * (d1 + d2) - endif + end if ! ! -- Return return end function logmean - function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & - iavgmeth) result(hyeff) + function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & + iavgmeth) result(hyeff) ! ****************************************************************************** ! hyeff_calc -- Calculate the effective horizontal hydraulic conductivity from ! an ellipse using a specified direction (unit vector vg1, vg2, vg3). @@ -3077,7 +3080,7 @@ function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & ! downward from the (x, y) plane ! ang3 is the rotation of the conductivity ellipsoid about the major ! axis -! vg1, vg2, and vg3 are the components of a unit vector in model coordinates +! vg1, vg2, and vg3 are the components of a unit vector in model coordinates ! in the direction of the connection between cell n and m ! iavgmeth is the averaging method. If zero, then use harmonic averaging. ! if one, then use arithmetic averaging. @@ -3102,7 +3105,7 @@ function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & integer(I4B), intent(in) :: iavgmeth ! -- local real(DP) :: s1, s2, s3, c1, c2, c3 - real(DP), dimension(3,3) :: r + real(DP), dimension(3, 3) :: r real(DP) :: ve1, ve2, ve3 real(DP) :: denom, dnum, d1, d2, d3 ! ------------------------------------------------------------------------------ @@ -3116,15 +3119,15 @@ function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & c3 = cos(ang3) ! ! -- Rotation matrix - r(1,1) = c1*c2 - r(1,2) = c1*s2*s3 - s1*c3 - r(1,3) = -c1*s2*c3 - s1*s3 - r(2,1) = s1*c2 - r(2,2) = s1*s2*s3 + c1*c3 - r(2,3) = -s1*s2*c3 + c1*s3 - r(3,1) = s2 - r(3,2) = -c2*s3 - r(3,3) = c2*c3 + r(1, 1) = c1 * c2 + r(1, 2) = c1 * s2 * s3 - s1 * c3 + r(1, 3) = -c1 * s2 * c3 - s1 * s3 + r(2, 1) = s1 * c2 + r(2, 2) = s1 * s2 * s3 + c1 * c3 + r(2, 3) = -s1 * s2 * c3 + c1 * s3 + r(3, 1) = s2 + r(3, 2) = -c2 * s3 + r(3, 3) = c2 * c3 ! ! -- Unit vector in direction of n-m connection in a local coordinate ! system aligned with the ellipse axes @@ -3132,7 +3135,7 @@ function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & ve2 = r(1, 2) * vg1 + r(2, 2) * vg2 + r(3, 2) * vg3 ve3 = r(1, 3) * vg1 + r(2, 3) * vg2 + r(3, 3) * vg3 ! - ! -- Effective hydraulic conductivity calculated using harmonic (1) + ! -- Effective hydraulic conductivity calculated using harmonic (1) ! or arithmetic (2) weighting hyeff = DZERO if (iavgmeth == 0) then @@ -3140,9 +3143,9 @@ function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & ! -- Arithmetic weighting. If principal direction corresponds exactly with ! unit vector then set to principal direction. Otherwise weight it. dnum = DONE - d1 = ve1 ** 2 - d2 = ve2 ** 2 - d3 = ve3 ** 2 + d1 = ve1**2 + d2 = ve2**2 + d3 = ve3**2 if (ve1 /= DZERO) then dnum = dnum * k11 d2 = d2 * k11 @@ -3162,7 +3165,7 @@ function hyeff_calc(k11, k22, k33, ang1, ang2, ang3, vg1, vg2, vg3, & if (denom > DZERO) hyeff = dnum / denom else if (iavgmeth == 1) then ! -- arithmetic - hyeff = ve1 ** 2 * k11 + ve2 ** 2 * k22 + ve3 ** 2 * k33 + hyeff = ve1**2 * k11 + ve2**2 * k22 + ve3**2 * k33 end if ! ! -- Return @@ -3171,7 +3174,7 @@ end function hyeff_calc subroutine calc_spdis(this, flowja) ! ****************************************************************************** -! calc_spdis -- Calculate the 3 conmponents of specific discharge +! calc_spdis -- Calculate the 3 conmponents of specific discharge ! at the cell center. ! ****************************************************************************** ! @@ -3229,11 +3232,11 @@ subroutine calc_spdis(this, flowja) ! ------------------------------------------------------------------------------ ! ! -- Ensure dis has necessary information - if(this%icalcspdis /= 0 .and. this%dis%con%ianglex == 0) then - call store_error('Error. ANGLDEGX not provided in ' // & - 'discretization file. ANGLDEGX required for ' // & + if (this%icalcspdis /= 0 .and. this%dis%con%ianglex == 0) then + call store_error('Error. ANGLDEGX not provided in '// & + 'discretization file. ANGLDEGX required for '// & 'calculation of specific discharge.', terminate=.TRUE.) - endif + end if ! ! -- Find max number of connections and allocate weight arrays nc = 0 @@ -3246,30 +3249,30 @@ subroutine calc_spdis(this, flowja) do m = 1, this%nedges if (this%nodedge(m) == n) then ic = ic + 1 - endif - enddo + end if + end do ! ! -- Set max number of connections for any cell if (ic > nc) nc = ic end do ! ! -- Allocate storage arrays needed for cell-centered spdis calculation - allocate(vi(nc)) - allocate(di(nc)) - allocate(viz(nc)) - allocate(diz(nc)) - allocate(nix(nc)) - allocate(niy(nc)) - allocate(wix(nc)) - allocate(wiy(nc)) - allocate(wiz(nc)) - allocate(bix(nc)) - allocate(biy(nc)) + allocate (vi(nc)) + allocate (di(nc)) + allocate (viz(nc)) + allocate (diz(nc)) + allocate (nix(nc)) + allocate (niy(nc)) + allocate (wix(nc)) + allocate (wiy(nc)) + allocate (wiz(nc)) + allocate (bix(nc)) + allocate (biy(nc)) ! ! -- Go through each cell and calculate specific discharge do n = 1, this%dis%nodes ! - ! -- first calculate geometric properties for x and y directions and + ! -- first calculate geometric properties for x and y directions and ! the specific discharge at a face (vi) ic = 0 iz = 0 @@ -3308,7 +3311,7 @@ subroutine calc_spdis(this, flowja) ic = ic + 1 dz = thksatnm(this%ibound(n), this%ibound(m), & this%icelltype(n), this%icelltype(m), & - this%inewton, ihc, this%iusgnrhc, & + this%inewton, ihc, this%iusgnrhc, & this%hnew(n), this%hnew(m), this%sat(n), this%sat(m), & this%dis%top(n), this%dis%top(m), this%dis%bot(n), & this%dis%bot(m), this%satomega, this%satmin) @@ -3330,8 +3333,8 @@ subroutine calc_spdis(this, flowja) vi(ic) = flowja(ipos) / area else vi(ic) = DZERO - endif - endif + end if + end if end do ! ! -- Look through edge flows that may have been provided by an exchange @@ -3355,12 +3358,12 @@ subroutine calc_spdis(this, flowja) vi(ic) = this%propsedge(1, m) / area else vi(ic) = DZERO - endif - endif - endif - enddo + end if + end if + end if + end do ! - ! -- Assign numnber of vertical and horizontal connections + ! -- Assign number of vertical and horizontal connections ncz = iz nc = ic ! @@ -3371,7 +3374,7 @@ subroutine calc_spdis(this, flowja) dsumz = DZERO do iz = 1, ncz dsumz = dsumz + diz(iz) - enddo + end do denom = (ncz - DONE) if (denom < DZERO) denom = DZERO dsumz = dsumz + DEM10 * dsumz @@ -3381,13 +3384,13 @@ subroutine calc_spdis(this, flowja) wiz(iz) = wiz(iz) / denom else wiz(iz) = DZERO - endif - enddo - endif + end if + end do + end if vz = DZERO do iz = 1, ncz vz = vz + wiz(iz) * viz(iz) - enddo + end do ! ! -- distance-based weighting nc = ic @@ -3399,18 +3402,18 @@ subroutine calc_spdis(this, flowja) wiy(ic) = di(ic) * abs(niy(ic)) dsumx = dsumx + wix(ic) dsumy = dsumy + wiy(ic) - enddo + end do ! ! -- Finish computing omega weights. Add a tiny bit ! to dsum so that the normalized omega weight later - ! evaluates to (essentially) 1 in the case of a single + ! evaluates to (essentially) 1 in the case of a single ! relevant connection, avoiding 0/0. dsumx = dsumx + DEM10 * dsumx dsumy = dsumy + DEM10 * dsumy do ic = 1, nc wix(ic) = (dsumx - wix(ic)) * abs(nix(ic)) wiy(ic) = (dsumy - wiy(ic)) * abs(niy(ic)) - enddo + end do ! ! -- compute B weights dsumx = DZERO @@ -3420,7 +3423,7 @@ subroutine calc_spdis(this, flowja) biy(ic) = wiy(ic) * sign(DONE, niy(ic)) dsumx = dsumx + wix(ic) * abs(nix(ic)) dsumy = dsumy + wiy(ic) * abs(niy(ic)) - enddo + end do if (dsumx > DZERO) dsumx = DONE / dsumx if (dsumy > DZERO) dsumy = DONE / dsumy axy = DZERO @@ -3430,7 +3433,7 @@ subroutine calc_spdis(this, flowja) biy(ic) = biy(ic) * dsumy axy = axy + bix(ic) * niy(ic) ayx = ayx + biy(ic) * nix(ic) - enddo + end do ! ! -- Calculate specific discharge. The divide by zero checking below ! is problematic for cells with only one flow, such as can happen @@ -3444,12 +3447,12 @@ subroutine calc_spdis(this, flowja) do ic = 1, nc vx = vx + (bix(ic) - axy * biy(ic)) * vi(ic) vy = vy + (biy(ic) - ayx * bix(ic)) * vi(ic) - enddo + end do denom = DONE - axy * ayx if (denom /= DZERO) then vx = vx / denom vy = vy / denom - endif + end if ! this%spdis(1, n) = vx this%spdis(2, n) = vy @@ -3458,20 +3461,20 @@ subroutine calc_spdis(this, flowja) end do ! ! -- cleanup - deallocate(vi) - deallocate(di) - deallocate(nix) - deallocate(niy) - deallocate(wix) - deallocate(wiy) - deallocate(wiz) - deallocate(bix) - deallocate(biy) + deallocate (vi) + deallocate (di) + deallocate (nix) + deallocate (niy) + deallocate (wix) + deallocate (wiy) + deallocate (wiz) + deallocate (bix) + deallocate (biy) ! ! -- return return end subroutine calc_spdis - + subroutine sav_spdis(this, ibinun) ! ****************************************************************************** ! sav_spdis -- save specific discharge in binary format to ibinun @@ -3494,14 +3497,15 @@ subroutine sav_spdis(this, ibinun) text = ' DATA-SPDIS' naux = 3 auxtxt(:) = [' qx', ' qy', ' qz'] - call this%dis%record_srcdst_list_header(text, this%name_model, this%packName, & - this%name_model, this%packName, naux, auxtxt, ibinun, this%dis%nodes, & - this%iout) + call this%dis%record_srcdst_list_header(text, this%name_model, & + this%packName, this%name_model, & + this%packName, naux, auxtxt, ibinun, & + this%dis%nodes, this%iout) ! ! -- Write a zero for Q, and then write qx, qy, qz as aux variables do n = 1, this%dis%nodes - call this%dis%record_mf6_list_entry(ibinun, n, n, DZERO, naux, & - this%spdis(:, n)) + call this%dis%record_mf6_list_entry(ibinun, n, n, DZERO, naux, & + this%spdis(:, n)) end do ! ! -- return @@ -3531,9 +3535,10 @@ subroutine sav_sat(this, ibinun) text = ' DATA-SAT' naux = 1 auxtxt(:) = [' sat'] - call this%dis%record_srcdst_list_header(text, this%name_model, this%packName, & - this%name_model, this%packName, naux, auxtxt, ibinun, this%dis%nodes, & - this%iout) + call this%dis%record_srcdst_list_header(text, this%name_model, & + this%packName, this%name_model, & + this%packName, naux, auxtxt, ibinun, & + this%dis%nodes, this%iout) ! ! -- Write a zero for Q, and then write saturation as an aux variables do n = 1, this%dis%nodes @@ -3567,7 +3572,7 @@ subroutine increase_edge_count(this, nedges) return end subroutine increase_edge_count - subroutine set_edge_properties(this, nodedge, ihcedge, q, area, nx, ny, & + subroutine set_edge_properties(this, nodedge, ihcedge, q, area, nx, ny, & distance) ! ****************************************************************************** ! edge_count -- provide the npf package with edge properties. @@ -3611,33 +3616,33 @@ end subroutine set_edge_properties !< function calcSatThickness(this, n, m, ihc) result(satThickness) class(GwfNpfType) :: this !< this NPF instance - integer(I4B) :: n !< node n - integer(I4B) :: m !< node m - integer(I4B) :: ihc !< 1 = horizonal connection, 0 for vertical - real(DP) :: satThickness !< saturated thickness - - satThickness = thksatnm(this%ibound(n), & - this%ibound(m), & - this%icelltype(n), & - this%icelltype(m), & - this%inewton, & - ihc, & - this%iusgnrhc, & - this%hnew(n), & - this%hnew(m), & - this%sat(n), & - this%sat(m), & - this%dis%top(n), & - this%dis%top(m), & - this%dis%bot(n), & - this%dis%bot(m), & - this%satomega, & - this%satmin) + integer(I4B) :: n !< node n + integer(I4B) :: m !< node m + integer(I4B) :: ihc !< 1 = horizonal connection, 0 for vertical + real(DP) :: satThickness !< saturated thickness + + satThickness = thksatnm(this%ibound(n), & + this%ibound(m), & + this%icelltype(n), & + this%icelltype(m), & + this%inewton, & + ihc, & + this%iusgnrhc, & + this%hnew(n), & + this%hnew(m), & + this%sat(n), & + this%sat(m), & + this%dis%top(n), & + this%dis%top(m), & + this%dis%bot(n), & + this%dis%bot(m), & + this%satomega, & + this%satmin) end function calcSatThickness - function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & - hn, hm, satn, satm, topn, topm, botn, botm, & + function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & + hn, hm, satn, satm, topn, topm, botn, botm, & satomega, satminopt) result(res) ! ****************************************************************************** ! thksatnm -- calculate saturated thickness at interface between two cells @@ -3684,21 +3689,21 @@ function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & end if ! ! -- If either n or m is inactive then saturated thickness is zero - if(ibdn == 0 .or. ibdm == 0) then + if (ibdn == 0 .or. ibdm == 0) then res = DZERO - ! - ! -- if both cells are non-convertible then use average cell thickness - elseif(ictn == 0 .and. ictm == 0) then + ! + ! -- if both cells are non-convertible then use average cell thickness + elseif (ictn == 0 .and. ictm == 0) then res = DHALF * (topn - botn + topm - botm) - ! - ! -- At least one of the cells is convertible, so calculate average saturated - ! thickness + ! + ! -- At least one of the cells is convertible, so calculate average saturated + ! thickness else if (inwtup == 1) then ! -- set flag used to determine if bottom of cells n and m are ! significantly different indk = 0 - if (abs(botm-botn) < DEM2) indk = 1 + if (abs(botm - botn) < DEM2) indk = 1 ! -- recalculate saturation if using MODFLOW-USG saturation ! calculation approach if (iusg == 1 .and. indk == 0) then @@ -3729,7 +3734,7 @@ function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & ! ! -- If staggered connection, subtract parts of cell that are above and ! below the sill top and bottom elevations - if(ihc == 2) then + if (ihc == 2) then ! ! -- Calculate sill_top and sill_bot sill_top = min(topn, topm) @@ -3742,14 +3747,14 @@ function thksatnm(ibdn, ibdm, ictn, ictm, inwtup, ihc, iusg, & ! -- Calculate saturated thickness for cells n and m thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) - endif + end if ! res = DHALF * (thksatn + thksatm) end if - endif + end if ! ! -- Return return end function thksatnm - + end module GwfNpfModule diff --git a/src/Model/GroundWaterFlow/gwf3obs8.f90 b/src/Model/GroundWaterFlow/gwf3obs8.f90 index 8027f8f3b4b..15490abbcbf 100644 --- a/src/Model/GroundWaterFlow/gwf3obs8.f90 +++ b/src/Model/GroundWaterFlow/gwf3obs8.f90 @@ -1,13 +1,13 @@ module GwfObsModule use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, MAXOBSTYPES - use BaseDisModule, only: DisBaseType - use GwfIcModule, only: GwfIcType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use SimModule, only: count_errors, store_error, & - store_error_unit + use ConstantsModule, only: LINELENGTH, MAXOBSTYPES + use BaseDisModule, only: DisBaseType + use GwfIcModule, only: GwfIcType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, & + store_error_unit implicit none private @@ -15,9 +15,9 @@ module GwfObsModule type, extends(ObsType) :: GwfObsType ! -- Private members - type(GwfIcType), pointer, private :: ic => null() ! initial conditions - real(DP), dimension(:), pointer, contiguous, private :: x => null() ! head - real(DP), dimension(:), pointer, contiguous, private :: flowja => null() ! intercell flows + type(GwfIcType), pointer, private :: ic => null() ! initial conditions + real(DP), dimension(:), pointer, contiguous, private :: x => null() ! head + real(DP), dimension(:), pointer, contiguous, private :: flowja => null() ! intercell flows contains ! -- Public procedures procedure, public :: gwf_obs_ar @@ -42,11 +42,11 @@ subroutine gwf_obs_cr(obs, inobs) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwfObsType), pointer, intent(out) :: obs + type(GwfObsType), pointer, intent(out) :: obs integer(I4B), pointer, intent(in) :: inobs ! ------------------------------------------------------------------------------ ! - allocate(obs) + allocate (obs) call obs%allocate_scalars() obs%active = .false. obs%inputFilename = '' @@ -63,8 +63,8 @@ subroutine gwf_obs_ar(this, ic, x, flowja) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwfObsType), intent(inout) :: this - type(GwfIcType), pointer, intent(in) :: ic + class(GwfObsType), intent(inout) :: this + type(GwfIcType), pointer, intent(in) :: ic real(DP), dimension(:), pointer, contiguous, intent(in) :: x real(DP), dimension(:), pointer, contiguous, intent(in) :: flowja ! ------------------------------------------------------------------------------ @@ -90,7 +90,7 @@ subroutine gwf_obs_df(this, iout, pkgname, filtyp, dis) integer(I4B), intent(in) :: iout character(len=*), intent(in) :: pkgname character(len=*), intent(in) :: filtyp - class(DisBaseType), pointer :: dis + class(DisBaseType), pointer :: dis ! -- local integer(I4B) :: indx ! ------------------------------------------------------------------------------ @@ -124,7 +124,7 @@ subroutine gwf_obs_bd(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwfObsType), intent(inout) :: this + class(GwfObsType), intent(inout) :: this ! -- local integer(I4B) :: i, jaindex, nodenumber real(DP) :: v @@ -149,7 +149,7 @@ subroutine gwf_obs_bd(this) case ('FLOW-JA-FACE') call this%SaveOneSimval(obsrv, this%flowja(jaindex)) case default - msg = 'Error: Unrecognized observation type: ' // trim(obsrv%ObsTypeId) + msg = 'Error: Unrecognized observation type: '//trim(obsrv%ObsTypeId) call store_error(msg) end select end do @@ -188,9 +188,9 @@ subroutine gwf_obs_da(this) class(GwfObsType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! - nullify(this%ic) - nullify(this%x) - nullify(this%flowja) + nullify (this%ic) + nullify (this%x) + nullify (this%flowja) call this%ObsType%obs_da() ! return @@ -226,10 +226,10 @@ subroutine gwf_process_head_drawdown_obs_id(obsrv, dis, inunitobs, iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1 integer(I4B) :: icol, istart, istop @@ -251,7 +251,7 @@ subroutine gwf_process_head_drawdown_obs_id(obsrv, dis, inunitobs, iout) ermsg = 'Error reading data from ID string' call store_error(ermsg) call store_error_unit(inunitobs) - endif + end if ! return end subroutine gwf_process_head_drawdown_obs_id @@ -264,16 +264,16 @@ subroutine gwf_process_intercell_obs_id(obsrv, dis, inunitobs, iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1, nn2 integer(I4B) :: icol, istart, istop, jaidx character(len=LINELENGTH) :: ermsg, strng ! formats - 70 format('Error: No connection exists between cells identified in text: ',a) +70 format('Error: No connection exists between cells identified in text: ', a) ! ------------------------------------------------------------------------------ ! ! -- Initialize variables @@ -288,32 +288,32 @@ subroutine gwf_process_intercell_obs_id(obsrv, dis, inunitobs, iout) if (nn1 > 0) then obsrv%NodeNumber = nn1 else - ermsg = 'Error reading data from ID string: ' // strng(istart:istop) + ermsg = 'Error reading data from ID string: '//strng(istart:istop) call store_error(ermsg) - endif + end if ! ! Get node number, with option for ID string to be either node ! number or lay, row, column (when dis is structured). nn2 = dis%noder_from_string(icol, istart, istop, inunitobs, & - iout, strng, .false.) + iout, strng, .false.) if (nn2 > 0) then obsrv%NodeNumber2 = nn2 else - ermsg = 'Error reading data from ID string: ' // strng(istart:istop) + ermsg = 'Error reading data from ID string: '//strng(istart:istop) call store_error(ermsg) - endif + end if ! ! -- store JA index - jaidx = dis%con%getjaindex(nn1,nn2) - if (jaidx==0) then - write(ermsg,70)trim(strng) + jaidx = dis%con%getjaindex(nn1, nn2) + if (jaidx == 0) then + write (ermsg, 70) trim(strng) call store_error(ermsg) - endif + end if obsrv%JaIndex = jaidx ! if (count_errors() > 0) then call store_error_unit(inunitobs) - endif + end if ! return end subroutine gwf_process_intercell_obs_id diff --git a/src/Model/GroundWaterFlow/gwf3oc8.f90 b/src/Model/GroundWaterFlow/gwf3oc8.f90 index fcf7b037453..12e635b7963 100644 --- a/src/Model/GroundWaterFlow/gwf3oc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3oc8.f90 @@ -1,10 +1,10 @@ module GwfOcModule - use BaseDisModule, only: DisBaseType - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME - use OutputControlModule, only: OutputControlType - use OutputControlDataModule, only: OutputControlDataType, ocd_cr + use BaseDisModule, only: DisBaseType + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME + use OutputControlModule, only: OutputControlType + use OutputControlDataModule, only: OutputControlDataType, ocd_cr implicit none private @@ -19,8 +19,8 @@ module GwfOcModule contains procedure :: oc_ar end type GwfOcType - - contains + +contains !> @ brief Create GwfOcType !! @@ -30,13 +30,13 @@ module GwfOcModule !< subroutine oc_cr(ocobj, name_model, inunit, iout) ! -- dummy - type(GwfOcType), pointer :: ocobj !< GwfOcType object - character(len=*), intent(in) :: name_model !< name of the model - integer(I4B), intent(in) :: inunit !< unit number for input - integer(I4B), intent(in) :: iout !< unit number for output + type(GwfOcType), pointer :: ocobj !< GwfOcType object + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< unit number for input + integer(I4B), intent(in) :: iout !< unit number for output ! ! -- Create the object - allocate(ocobj) + allocate (ocobj) ! ! -- Allocate scalars call ocobj%allocate_scalars(name_model) @@ -59,42 +59,42 @@ end subroutine oc_cr !< subroutine oc_ar(this, head, dis, dnodata) ! -- dummy - class(GwfOcType) :: this !< GwtOcType object - real(DP), dimension(:), pointer, contiguous, intent(in) :: head !< model head - class(DisBaseType), pointer, intent(in) :: dis !< model discretization package - real(DP), intent(in) :: dnodata !< no data value + class(GwfOcType) :: this !< GwtOcType object + real(DP), dimension(:), pointer, contiguous, intent(in) :: head !< model head + class(DisBaseType), pointer, intent(in) :: dis !< model discretization package + real(DP), intent(in) :: dnodata !< no data value ! -- local integer(I4B) :: i, nocdobj, inodata - type(OutputControlDataType), pointer :: ocdobjptr + type(OutputControlDataType), pointer :: ocdobjptr real(DP), dimension(:), pointer, contiguous :: nullvec => null() ! ! -- Initialize variables inodata = 0 nocdobj = 2 - allocate(this%ocdobj(nocdobj)) + allocate (this%ocdobj(nocdobj)) do i = 1, nocdobj call ocd_cr(ocdobjptr) select case (i) case (1) - call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & this%iout, dnodata) case (2) - call ocdobjptr%init_dbl('HEAD', head, dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + call ocdobjptr%init_dbl('HEAD', head, dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & this%iout, dnodata) end select this%ocdobj(i) = ocdobjptr - deallocate(ocdobjptr) - enddo + deallocate (ocdobjptr) + end do ! ! -- Read options or set defaults if this package not on - if(this%inunit > 0) then + if (this%inunit > 0) then call this%read_options() - endif + end if ! ! -- Return return end subroutine oc_ar - + end module GwfOcModule diff --git a/src/Model/GroundWaterFlow/gwf3rch8.f90 b/src/Model/GroundWaterFlow/gwf3rch8.f90 index 1535c408134..a76e4ba895d 100644 --- a/src/Model/GroundWaterFlow/gwf3rch8.f90 +++ b/src/Model/GroundWaterFlow/gwf3rch8.f90 @@ -17,36 +17,36 @@ module RchModule private public :: rch_create ! - character(len=LENFTYPE) :: ftype = 'RCH' - character(len=LENPACKAGENAME) :: text = ' RCH' - character(len=LENPACKAGENAME) :: texta = ' RCHA' + character(len=LENFTYPE) :: ftype = 'RCH' + character(len=LENPACKAGENAME) :: text = ' RCH' + character(len=LENPACKAGENAME) :: texta = ' RCHA' ! type, extends(BndType) :: RchType integer(I4B), pointer :: inirch => NULL() - integer(I4B), dimension(:), pointer, contiguous :: nodesontop => NULL() ! User provided cell numbers; nodelist is cells where recharge is applied) + integer(I4B), dimension(:), pointer, contiguous :: nodesontop => NULL() ! User provided cell numbers; nodelist is cells where recharge is applied) logical, private :: fixed_cell = .false. logical, private :: read_as_arrays = .false. contains procedure :: rch_allocate_scalars - procedure :: bnd_options => rch_options - procedure :: read_dimensions => rch_read_dimensions - procedure :: read_initial_attr => rch_read_initial_attr - procedure :: bnd_rp => rch_rp + procedure :: bnd_options => rch_options + procedure :: read_dimensions => rch_read_dimensions + procedure :: read_initial_attr => rch_read_initial_attr + procedure :: bnd_rp => rch_rp procedure :: set_nodesontop - procedure :: bnd_cf => rch_cf - procedure :: bnd_fc => rch_fc - procedure :: bnd_da => rch_da - procedure :: define_listlabel => rch_define_listlabel - procedure, public :: bnd_rp_ts => rch_rp_ts + procedure :: bnd_cf => rch_cf + procedure :: bnd_fc => rch_fc + procedure :: bnd_da => rch_da + procedure :: define_listlabel => rch_define_listlabel + procedure, public :: bnd_rp_ts => rch_rp_ts procedure, private :: rch_rp_array procedure, private :: rch_rp_list procedure, private :: default_nodelist ! -- for observations - procedure, public :: bnd_obs_supported => rch_obs_supported + procedure, public :: bnd_obs_supported => rch_obs_supported procedure, public :: bnd_df_obs => rch_df_obs end type RchType - contains +contains subroutine rch_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ****************************************************************************** @@ -57,12 +57,12 @@ subroutine rch_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - ! -- dummy + ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -70,7 +70,7 @@ subroutine rch_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate recharge object and scalar variables - allocate(rchobj) + allocate (rchobj) packobj => rchobj ! ! -- create name and memory path @@ -88,8 +88,8 @@ subroutine rch_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%id = id packobj%ibcnum = ibcnum packobj%ncolbnd = 1 - packobj%iscloc = 1 ! sfac applies to recharge rate - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%iscloc = 1 ! sfac applies to recharge rate + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! indxconvertflux is Column index of bound that will be multiplied by ! cell area to convert flux rates to flow rates packobj%indxconvertflux = 1 @@ -109,7 +109,7 @@ subroutine rch_allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(RchType), intent(inout) :: this + class(RchType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! -- call standard BndType allocate scalars @@ -139,39 +139,39 @@ subroutine rch_options(this, option, found) use SimModule, only: store_error implicit none ! -- dummy - class(RchType), intent(inout) :: this + class(RchType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local character(len=MAXCHARLEN) :: ermsg ! -- formats - character(len=*),parameter :: fmtihact = & - "(4x, 'RECHARGE WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" - character(len=*),parameter :: fmtfixedcell = & - "(4x, 'RECHARGE WILL BE APPLIED TO SPECIFIED CELL.')" + character(len=*), parameter :: fmtihact = & + &"(4x, 'RECHARGE WILL BE APPLIED TO HIGHEST ACTIVE CELL.')" + character(len=*), parameter :: fmtfixedcell = & + &"(4x, 'RECHARGE WILL BE APPLIED TO SPECIFIED CELL.')" character(len=*), parameter :: fmtreadasarrays = & - "(4x, 'RECHARGE INPUT WILL BE READ AS ARRAY(S).')" + &"(4x, 'RECHARGE INPUT WILL BE READ AS ARRAY(S).')" ! ------------------------------------------------------------------------------ ! ! -- Check for FIXED_CELL and READASARRAYS select case (option) case ('FIXED_CELL') this%fixed_cell = .true. - write(this%iout, fmtfixedcell) + write (this%iout, fmtfixedcell) found = .true. case ('READASARRAYS') if (this%dis%supports_layers()) then this%read_as_arrays = .true. this%text = texta else - ermsg = 'READASARRAYS option is not compatible with selected' // & + ermsg = 'READASARRAYS option is not compatible with selected'// & ' discretization type.' call store_error(ermsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Write option - write(this%iout, fmtreadasarrays) + write (this%iout, fmtreadasarrays) ! found = .true. case default @@ -194,7 +194,7 @@ subroutine rch_read_dimensions(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit ! -- dummy - class(RchType),intent(inout) :: this + class(RchType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -214,38 +214,39 @@ subroutine rch_read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('MAXBOUND') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - case default - write(errmsg,'(4x,a,a)') & - 'Unknown '//trim(this%text)//' DIMENSION: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('MAXBOUND') + this%maxbound = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'MAXBOUND = ', this%maxbound + case default + write (errmsg, '(4x,a,a)') & + 'Unknown '//trim(this%text)//' DIMENSION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' else call store_error('Required DIMENSIONS block not found.') call this%parser%StoreErrorUnit() - endif - endif + end if + end if ! ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(1x,a)') & + if (this%maxbound <= 0) then + write (errmsg, '(1x,a)') & 'MAXBOUND must be an integer greater than zero.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Call define_listlabel to construct the list label that is written ! when PRINT_INPUT option is used. @@ -264,12 +265,12 @@ subroutine rch_read_initial_attr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(RchType),intent(inout) :: this + class(RchType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! if (this%read_as_arrays) then call this%default_nodelist() - endif + end if ! return end subroutine rch_read_initial_attr @@ -288,7 +289,7 @@ subroutine rch_rp(this) use SimModule, only: store_error implicit none ! -- dummy - class(RchType),intent(inout) :: this + class(RchType), intent(inout) :: this ! -- local integer(I4B) :: ierr integer(I4B) :: node, n @@ -297,19 +298,19 @@ subroutine rch_rp(this) logical :: supportopenclose character(len=LINELENGTH) :: line ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & - &') IS GREATER THAN MAXIMUM(',I6,')')" - character(len=*), parameter :: fmtdimlayered = & - "('When READASARRAYS is specified for the selected discretization" // & - " package, DIMENSIONS block must be omitted.')" + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & + &') IS GREATER THAN MAXIMUM(',I6,')')" + character(len=*), parameter :: fmtdimlayered = & + "('When READASARRAYS is specified for the selected discretization & + &package, DIMENSIONS block must be omitted.')" ! ------------------------------------------------------------------------------ ! - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. @@ -321,7 +322,7 @@ subroutine rch_rp(this) ! so supportOpenClose needs to be false in call the GetBlock. ! When reading as arrays, set supportOpenClose as desired. call this%parser%GetBlock('PERIOD', isfound, ierr) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -334,21 +335,21 @@ subroutine rch_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) if (this%read_as_arrays) then - write(errmsg, fmtdimlayered) + write (errmsg, fmtdimlayered) call store_error(errmsg) - endif + end if call this%parser%StoreErrorUnit() end if - endif + end if end if ! ! -- Read data if ionper == kper inrech = 0 inirch = 0 - if(this%ionper == kper) then + if (this%ionper == kper) then ! ! -- Remove all time-series links associated with this package call this%TsManager%Reset(this%packName) @@ -361,23 +362,23 @@ subroutine rch_rp(this) else ! -- Read RECHARGE, IRCH, and AUX variables as arrays call this%rch_rp_array(line, inrech) - endif - ! + end if + ! else - write(this%iout,fmtlsp) trim(this%filtyp) - endif + write (this%iout, fmtlsp) trim(this%filtyp) + end if ! ! -- If recharge was read, then multiply by cell area. If inrech = 2, then ! recharge is begin managed as a time series, and the time series object ! will multiply the recharge rate by the cell area. - if(inrech == 1) then + if (inrech == 1) then do n = 1, this%nbound node = this%nodelist(n) if (node > 0) then this%bound(1, n) = this%bound(1, n) * this%dis%get_area(node) end if - enddo - endif + end do + end if ! ! -- return return @@ -395,9 +396,9 @@ subroutine rch_rp_array(this, line, inrech) use ArrayHandlersModule, only: ifind implicit none ! -- dummy - class(RchType), intent(inout) :: this + class(RchType), intent(inout) :: this character(len=LINELENGTH), intent(inout) :: line - integer(I4B), intent(inout) :: inrech + integer(I4B), intent(inout) :: inrech ! -- local integer(I4B) :: n integer(I4B) :: ipos @@ -413,14 +414,14 @@ subroutine rch_rp_array(this, line, inrech) real(DP), dimension(:), pointer :: bndArrayPtr => null() real(DP), dimension(:), pointer :: auxArrayPtr => null() real(DP), dimension(:), pointer :: auxMultArray => null() - type(TimeArraySeriesLinkType), pointer :: tasLink => null() + type(TimeArraySeriesLinkType), pointer :: tasLink => null() ! -- formats - character(len=*),parameter :: fmtrchauxmult = & + character(len=*), parameter :: fmtrchauxmult = & "(4x, 'THE RECHARGE ARRAY IS BEING MULTIPLED BY THE AUXILIARY ARRAY WITH & &THE NAME: ', A)" ! -- data - data aname(1) /' LAYER OR NODE INDEX'/ - data aname(2) /' RECHARGE'/ + data aname(1)/' LAYER OR NODE INDEX'/ + data aname(2)/' RECHARGE'/ ! ! ------------------------------------------------------------------------------ ! @@ -444,15 +445,15 @@ subroutine rch_rp_array(this, line, inrech) if (keyword == 'TIMEARRAYSERIES') then ! -- Get time-array series name call this%parser%GetStringCaps(tasName) - jcol = 1 ! for recharge rate - bndArrayPtr => this%bound(jcol,:) + jcol = 1 ! for recharge rate + bndArrayPtr => this%bound(jcol, :) ! Make a time-array-series link and add it to the list of links ! contained in the TimeArraySeriesManagerType object. convertflux = .true. - call this%TasManager%MakeTasLink(this%packName, bndArrayPtr, & - this%iprpak, tasName, 'RECHARGE', & - convertFlux, this%nodelist, & - this%parser%iuactive) + call this%TasManager%MakeTasLink(this%packName, bndArrayPtr, & + this%iprpak, tasName, 'RECHARGE', & + convertFlux, this%nodelist, & + this%parser%iuactive) lpos = this%TasManager%CountLinks() tasLink => this%TasManager%GetLink(lpos) inrech = 2 @@ -461,10 +462,11 @@ subroutine rch_rp_array(this, line, inrech) ! -- Read the recharge array, then indicate ! that recharge was read by setting inrech call this%dis%read_layer_array(this%nodelist, this%bound, & - this%ncolbnd, this%maxbound, 1, aname(2), this%parser%iuactive, & - this%iout) + this%ncolbnd, this%maxbound, 1, & + aname(2), this%parser%iuactive, & + this%iout) inrech = 1 - endif + end if ! case ('IRCH') ! @@ -474,25 +476,26 @@ subroutine rch_rp_array(this, line, inrech) call store_error('IRCH IS NOT FIRST VARIABLE IN & &PERIOD BLOCK OR IT IS SPECIFIED MORE THAN ONCE.') call this%parser%StoreErrorUnit() - endif + end if ! ! -- Read the IRCH array call this%dis%nlarray_to_nodelist(this%nodelist, this%maxbound, & - this%nbound, aname(1), this%parser%iuactive, this%iout) + this%nbound, aname(1), & + this%parser%iuactive, this%iout) ! ! -- set flag to indicate that irch array has been read this%inirch = 1 ! ! -- if fixed_cell option not set, then need to store nodelist ! in the nodesontop array - if(.not. this%fixed_cell) call this%set_nodesontop() + if (.not. this%fixed_cell) call this%set_nodesontop() ! case default ! ! -- Check for auxname, and if found, then read into auxvar array found = .false. ipos = ifind(this%auxname, keyword) - if(ipos > 0) then + if (ipos > 0) then found = .true. atemp = keyword ! @@ -503,37 +506,37 @@ subroutine rch_rp_array(this, line, inrech) ! -- Get time-array series name call this%parser%GetStringCaps(tasName) jauxcol = jauxcol + 1 - auxArrayPtr => this%auxvar(jauxcol,:) + auxArrayPtr => this%auxvar(jauxcol, :) ! Make a time-array-series link and add it to the list of links ! contained in the TimeArraySeriesManagerType object. convertflux = .false. - call this%TasManager%MakeTasLink(this%packName, auxArrayPtr, & - this%iprpak, tasName, & - this%auxname(ipos), convertFlux, & - this%nodelist, & - this%parser%iuactive) + call this%TasManager%MakeTasLink(this%packName, auxArrayPtr, & + this%iprpak, tasName, & + this%auxname(ipos), convertFlux, & + this%nodelist, & + this%parser%iuactive) else ! ! -- Read the aux variable array call this%dis%read_layer_array(this%nodelist, this%auxvar, & - this%naux, this%maxbound, ipos, atemp, this%parser%iuactive, & - this%iout) - endif - endif + this%naux, this%maxbound, ipos, & + atemp, this%parser%iuactive, this%iout) + end if + end if ! ! -- Nothing found - if(.not. found) then + if (.not. found) then call this%parser%GetCurrentLine(line) - errmsg = 'LOOKING FOR VALID VARIABLE NAME. FOUND: ' // trim(line) + errmsg = 'LOOKING FOR VALID VARIABLE NAME. FOUND: '//trim(line) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- If this aux variable has been designated as a multiplier array ! by presence of AUXMULTNAME, set local pointer appropriately. if (this%iauxmultcol > 0 .and. this%iauxmultcol == ipos) then - auxMultArray => this%auxvar(this%iauxmultcol,:) - endif + auxMultArray => this%auxvar(this%iauxmultcol, :) + end if end select ! ! -- Increment the number of variables read @@ -547,18 +550,18 @@ subroutine rch_rp_array(this, line, inrech) if (associated(auxMultArray)) then if (associated(tasLink)) then tasLink%RMultArray => auxMultArray - endif - endif + end if + end if ! ! -- If recharge was read and auxmultcol was specified, then multiply ! the recharge rate by the multplier column - if(inrech == 1 .and. this%iauxmultcol > 0) then - write(this%iout, fmtrchauxmult) this%auxname(this%iauxmultcol) + if (inrech == 1 .and. this%iauxmultcol > 0) then + write (this%iout, fmtrchauxmult) this%auxname(this%iauxmultcol) do n = 1, this%nbound - this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & - this%auxvar(this%iauxmultcol, n) - enddo - endif + this%bound(this%iscloc, n) = this%bound(this%iscloc, n) * & + this%auxvar(this%iauxmultcol, n) + end do + end if ! return end subroutine rch_rp_array @@ -573,7 +576,7 @@ subroutine rch_rp_list(this, inrech) implicit none ! -- dummy class(RchType), intent(inout) :: this - integer(I4B), intent(inout) :: inrech + integer(I4B), intent(inout) :: inrech ! -- local integer(I4B) :: maxboundorig, nlist ! @@ -585,20 +588,20 @@ subroutine rch_rp_list(this, inrech) ! ! -- read the list of recharge values; scale the recharge by auxmultcol ! if it is specified. - call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & - nlist, this%inamedbound, this%iauxmultcol, & - this%nodelist, this%bound, this%auxvar, & - this%auxname, this%boundname, this%listlabel, & - this%packName, this%tsManager, this%iscloc, & - this%indxconvertflux) + call this%dis%read_list(this%parser%iuactive, this%iout, this%iprpak, & + nlist, this%inamedbound, this%iauxmultcol, & + this%nodelist, this%bound, this%auxvar, & + this%auxname, this%boundname, this%listlabel, & + this%packName, this%tsManager, this%iscloc, & + this%indxconvertflux) this%nbound = nlist if (this%maxbound > maxboundorig) then ! -- The arrays that belong to BndType have been extended. ! Now, RCH array nodesontop needs to be recreated. if (associated(this%nodesontop)) then - deallocate(this%nodesontop) - endif - endif + deallocate (this%nodesontop) + end if + end if if (.not. this%fixed_cell) call this%set_nodesontop() inrech = 1 ! @@ -617,21 +620,21 @@ subroutine set_nodesontop(this) ! ------------------------------------------------------------------------------ implicit none ! -- dummy - class(RchType),intent(inout) :: this + class(RchType), intent(inout) :: this ! -- local integer(I4B) :: n ! -- formats ! ------------------------------------------------------------------------------ ! ! -- allocate if necessary - if(.not. associated(this%nodesontop)) then - allocate(this%nodesontop(this%maxbound)) - endif + if (.not. associated(this%nodesontop)) then + allocate (this%nodesontop(this%maxbound)) + end if ! ! -- copy nodelist into nodesontop do n = 1, this%nbound this%nodesontop(n) = this%nodelist(n) - enddo + end do ! ! -- return return @@ -654,7 +657,7 @@ subroutine rch_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! ! -- Return if no recharge - if(this%nbound == 0) return + if (this%nbound == 0) return ! ! -- Calculate hcof and rhs for each recharge entry do i = 1, this%nbound @@ -675,23 +678,23 @@ subroutine rch_cf(this, reset_mover) ! ! -- reset nodelist to highest active if (.not. this%fixed_cell) then - if(this%ibound(node) == 0) & + if (this%ibound(node) == 0) & call this%dis%highest_active(node, this%ibound) this%nodelist(i) = node - endif + end if ! ! -- Set rhs and hcof this%hcof(i) = DZERO - this%rhs(i) = -this%bound(1,i) - if(this%ibound(node) <= 0) then + this%rhs(i) = -this%bound(1, i) + if (this%ibound(node) <= 0) then this%rhs(i) = DZERO cycle - endif - if(this%ibound(node) == 10000) then + end if + if (this%ibound(node) == 10000) then this%rhs(i) = DZERO cycle - endif - enddo + end if + end do ! ! -- return return @@ -727,7 +730,7 @@ subroutine rch_fc(this, rhs, ia, idxglo, amatsln) rhs(n) = rhs(n) + this%rhs(i) ipos = ia(n) amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo + end do ! ! -- return return @@ -753,7 +756,7 @@ subroutine rch_da(this) call mem_deallocate(this%inirch) ! ! -- arrays - if(associated(this%nodesontop)) deallocate(this%nodesontop) + if (associated(this%nodesontop)) deallocate (this%nodesontop) ! ! -- return return @@ -771,23 +774,23 @@ subroutine rch_define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'RECHARGE' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'RECHARGE' ! if(this%multindex > 0) & ! write(this%listlabel, '(a, a16)') trim(this%listlabel), 'MULTIPLIER' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -812,15 +815,15 @@ subroutine default_nodelist(this) ! ------------------------------------------------------------------------------ ! ! -- set variables - if(this%dis%ndim == 3) then + if (this%dis%ndim == 3) then nlay = this%dis%mshape(1) nrow = this%dis%mshape(2) ncol = this%dis%mshape(3) - elseif(this%dis%ndim == 2) then + elseif (this%dis%ndim == 2) then nlay = this%dis%mshape(1) nrow = 1 ncol = this%dis%mshape(2) - endif + end if ! ! -- Populate nodelist ipos = 1 @@ -831,8 +834,8 @@ subroutine default_nodelist(this) noder = this%dis%get_nodenumber(nodeu, 0) this%nodelist(ipos) = noder ipos = ipos + 1 - enddo - enddo + end do + end do ! ! Set flag that indicates IRCH has been assigned, and assign nbound. this%inirch = 1 @@ -840,51 +843,51 @@ subroutine default_nodelist(this) ! ! -- if fixed_cell option not set, then need to store nodelist ! in the nodesontop array - if(.not. this%fixed_cell) call this%set_nodesontop() + if (.not. this%fixed_cell) call this%set_nodesontop() ! ! -- return end subroutine default_nodelist ! -- Procedures related to observations - logical function rch_obs_supported(this) - ! ****************************************************************************** - ! rch_obs_supported - ! -- Return true because RCH package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - class(RchType) :: this - ! ------------------------------------------------------------------------------ - rch_obs_supported = .true. - ! - ! -- return - return - end function rch_obs_supported + logical function rch_obs_supported(this) + ! ****************************************************************************** + ! rch_obs_supported + ! -- Return true because RCH package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + class(RchType) :: this + ! ------------------------------------------------------------------------------ + rch_obs_supported = .true. + ! + ! -- return + return + end function rch_obs_supported - subroutine rch_df_obs(this) - ! ****************************************************************************** - ! rch_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by RCH package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ - implicit none - ! -- dummy - class(RchType) :: this - ! -- local - integer(I4B) :: indx - ! ------------------------------------------------------------------------------ - call this%obs%StoreObsType('rch', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine rch_df_obs + subroutine rch_df_obs(this) + ! ****************************************************************************** + ! rch_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by RCH package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + ! -- dummy + class(RchType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('rch', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine rch_df_obs ! ! -- Procedure related to time series @@ -900,15 +903,15 @@ subroutine rch_rp_ts(this) type(TimeSeriesLinkType), pointer :: tslink => null() ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then select case (tslink%JCol) case (1) tslink%Text = 'RECHARGE' end select - endif - enddo + end if + end do ! return end subroutine rch_rp_ts diff --git a/src/Model/GroundWaterFlow/gwf3riv8.f90 b/src/Model/GroundWaterFlow/gwf3riv8.f90 index 9c2605e9cf1..f14e93fa2f7 100644 --- a/src/Model/GroundWaterFlow/gwf3riv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3riv8.f90 @@ -13,8 +13,8 @@ module rivmodule public :: riv_create public :: RivType ! - character(len=LENFTYPE) :: ftype = 'RIV' - character(len=LENPACKAGENAME) :: text = ' RIV' + character(len=LENFTYPE) :: ftype = 'RIV' + character(len=LENPACKAGENAME) :: text = ' RIV' ! type, extends(BndType) :: RivType contains @@ -43,10 +43,10 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -54,7 +54,7 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(rivobj) + allocate (rivobj) packobj => rivobj ! ! -- create name and memory path @@ -67,17 +67,17 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! -- initialize package call packobj%pack_initialize() - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id packobj%ibcnum = ibcnum - packobj%ncolbnd=3 ! stage, conductance, rbot - packobj%iscloc=2 !sfac applies to conductance - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%ncolbnd = 3 ! stage, conductance, rbot + packobj%iscloc = 2 !sfac applies to conductance + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return return -end subroutine riv_create + end subroutine riv_create subroutine riv_options(this, option, found) ! ****************************************************************************** @@ -90,21 +90,21 @@ subroutine riv_options(this, option, found) ! ------------------------------------------------------------------------------ use InputOutputModule, only: urword ! -- dummy - class(RivType), intent(inout) :: this + class(RivType), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local ! ------------------------------------------------------------------------------ ! select case (option) - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. end select ! ! -- return @@ -122,7 +122,7 @@ subroutine riv_ck(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(RivType),intent(inout) :: this + class(RivType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: errmsg integer(I4B) :: i @@ -132,35 +132,35 @@ subroutine riv_ck(this) real(DP) :: rbot ! -- formats character(len=*), parameter :: fmtriverr = & - "('RIV BOUNDARY (',i0,') RIVER BOTTOM (',f10.4,') IS LESS " // & - "THAN CELL BOTTOM (',f10.4,')')" + "('RIV BOUNDARY (',i0,') RIVER BOTTOM (',f10.4,') IS LESS & + &THAN CELL BOTTOM (',f10.4,')')" character(len=*), parameter :: fmtriverr2 = & - "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS " // & - "THAN RIVER BOTTOM (',f10.4,')')" + "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS & + &THAN RIVER BOTTOM (',f10.4,')')" character(len=*), parameter :: fmtriverr3 = & - "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS " // & - "THAN CELL BOTTOM (',f10.4,')')" + "('RIV BOUNDARY (',i0,') RIVER STAGE (',f10.4,') IS LESS & + &THAN CELL BOTTOM (',f10.4,')')" ! ------------------------------------------------------------------------------ ! ! -- check stress period data do i = 1, this%nbound - node = this%nodelist(i) - bt = this%dis%bot(node) - stage = this%bound(1,i) - rbot = this%bound(3,i) - ! -- accumulate errors - if (rbot < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtriverr) i, rbot, bt - call store_error(errmsg) - end if - if (stage < rbot) then - write(errmsg, fmt=fmtriverr2) i, stage, rbot - call store_error(errmsg) - end if - if (stage < bt .and. this%icelltype(node) /= 0) then - write(errmsg, fmt=fmtriverr3) i, stage, bt - call store_error(errmsg) - end if + node = this%nodelist(i) + bt = this%dis%bot(node) + stage = this%bound(1, i) + rbot = this%bound(3, i) + ! -- accumulate errors + if (rbot < bt .and. this%icelltype(node) /= 0) then + write (errmsg, fmt=fmtriverr) i, rbot, bt + call store_error(errmsg) + end if + if (stage < rbot) then + write (errmsg, fmt=fmtriverr2) i, stage, rbot + call store_error(errmsg) + end if + if (stage < bt .and. this%icelltype(node) /= 0) then + write (errmsg, fmt=fmtriverr3) i, stage, bt + call store_error(errmsg) + end if end do ! ! -- write summary of river package error messages @@ -172,7 +172,7 @@ subroutine riv_ck(this) return end subroutine riv_ck -subroutine riv_cf(this, reset_mover) + subroutine riv_cf(this, reset_mover) ! ****************************************************************************** ! riv_cf -- Formulate the HCOF and RHS terms ! Subroutine: (1) skip in no rivs @@ -191,38 +191,38 @@ subroutine riv_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! ! -- Return if no rivs - if(this%nbound.eq.0) return + if (this%nbound .eq. 0) return ! ! -- pakmvrobj cf lrm = .true. if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then + if (this%imover == 1 .and. lrm) then call this%pakmvrobj%cf() - endif + end if ! ! -- Calculate hcof and rhs for each riv entry - do i=1,this%nbound - node=this%nodelist(i) - if(this%ibound(node)<=0) then - this%hcof(i)=DZERO - this%rhs(i)=DZERO + do i = 1, this%nbound + node = this%nodelist(i) + if (this%ibound(node) <= 0) then + this%hcof(i) = DZERO + this%rhs(i) = DZERO cycle - endif - hriv=this%bound(1,i) - criv=this%bound(2,i) - rbot=this%bound(3,i) - if(this%xnew(node)<=rbot) then - this%rhs(i)=-criv*(hriv-rbot) + end if + hriv = this%bound(1, i) + criv = this%bound(2, i) + rbot = this%bound(3, i) + if (this%xnew(node) <= rbot) then + this%rhs(i) = -criv * (hriv - rbot) this%hcof(i) = DZERO else - this%rhs(i) = -criv*hriv + this%rhs(i) = -criv * hriv this%hcof(i) = -criv - endif - enddo + end if + end do ! ! -- return return -end subroutine riv_cf + end subroutine riv_cf subroutine riv_fc(this, rhs, ia, idxglo, amatsln) ! ************************************************************************** @@ -243,9 +243,9 @@ subroutine riv_fc(this, rhs, ia, idxglo, amatsln) ! -------------------------------------------------------------------------- ! ! -- pakmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() - endif + end if ! ! -- Copy package rhs and hcof into solution rhs and amat do i = 1, this%nbound @@ -256,13 +256,13 @@ subroutine riv_fc(this, rhs, ia, idxglo, amatsln) ! ! -- If mover is active and this river cell is discharging, ! store available water (as positive value). - stage = this%bound(1,i) - if(this%imover == 1 .and. this%xnew(n) > stage) then - cond = this%bound(2,i) + stage = this%bound(1, i) + if (this%imover == 1 .and. this%xnew(n) > stage) then + cond = this%bound(2, i) qriv = cond * (this%xnew(n) - stage) call this%pakmvrobj%accumulate_qformvr(i, qriv) - endif - enddo + end if + end do ! ! -- return return @@ -280,23 +280,23 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOTTOM EL.' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STAGE' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'CONDUCTANCE' + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOTTOM EL.' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -304,7 +304,7 @@ end subroutine define_listlabel ! -- Procedures related to observations -logical function riv_obs_supported(this) + logical function riv_obs_supported(this) ! ****************************************************************************** ! riv_obs_supported ! -- Return true because RIV package supports observations. @@ -313,28 +313,28 @@ logical function riv_obs_supported(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - implicit none - class(RivType) :: this + implicit none + class(RivType) :: this ! ------------------------------------------------------------------------------ - riv_obs_supported = .true. - return -end function riv_obs_supported + riv_obs_supported = .true. + return + end function riv_obs_supported subroutine riv_df_obs(this) - ! ****************************************************************************** - ! riv_df_obs (implements bnd_df_obs) - ! -- Store observation type supported by RIV package. - ! -- Overrides BndType%bnd_df_obs - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! riv_df_obs (implements bnd_df_obs) + ! -- Store observation type supported by RIV package. + ! -- Overrides BndType%bnd_df_obs + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ implicit none ! -- dummy class(RivType) :: this ! -- local integer(I4B) :: indx - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ call this%obs%StoreObsType('riv', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor ! @@ -361,7 +361,7 @@ subroutine riv_rp_ts(this) type(TimeSeriesLinkType), pointer :: tslink => null() ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then select case (tslink%JCol) @@ -372,8 +372,8 @@ subroutine riv_rp_ts(this) case (3) tslink%Text = 'RBOT' end select - endif - enddo + end if + end do ! return end subroutine riv_rp_ts diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index a19d9243379..46e47b7f860 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -7,28 +7,28 @@ module SfrModule ! use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - DZERO, DPREC, DEM30, DEM6, DEM5, DEM4, DEM2, & - DHALF, DP6, DTWOTHIRDS, DP7, DP9, DP99, DP999, & - DONE, D1P1, DFIVETHIRDS, DTWO, DPI, DEIGHT, & - DHUNDRED, DEP20, & - NAMEDBOUNDFLAG, LENBOUNDNAME, LENFTYPE, & - LENPACKAGENAME, LENPAKLOC, MAXCHARLEN, & - LENBUDTXT, & - DHNOFLO, DHDRY, DNODATA, & - TABLEFT, TABCENTER, TABRIGHT, & - MNORMAL - use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & - sQuadraticSaturationDerivative, & - sQSaturationDerivative, & - sCubicSaturation, sChSmooth + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & + DZERO, DPREC, DEM30, DEM6, DEM5, DEM4, DEM2, & + DHALF, DP6, DTWOTHIRDS, DP7, DP9, DP99, DP999, & + DONE, D1P1, DFIVETHIRDS, DTWO, DPI, DEIGHT, & + DHUNDRED, DEP20, & + NAMEDBOUNDFLAG, LENBOUNDNAME, LENFTYPE, & + LENPACKAGENAME, LENPAKLOC, MAXCHARLEN, & + LENBUDTXT, & + DHNOFLO, DHDRY, DNODATA, & + TABLEFT, TABCENTER, TABRIGHT, & + MNORMAL + use SmoothingModule, only: sQuadraticSaturation, sQSaturation, & + sQuadraticSaturationDerivative, & + sQSaturationDerivative, & + sCubicSaturation, sChSmooth use BndModule, only: BndType use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr use TableModule, only: TableType, table_cr use ObserveModule, only: ObserveType use InputOutputModule, only: extract_idnum_or_bndname use BaseDisModule, only: DisBaseType - use SimModule, only: count_errors, store_error, store_error_unit, & + use SimModule, only: count_errors, store_error, store_error_unit, & store_warning use SimVariablesModule, only: errmsg, warnmsg use GwfSfrCrossSectionUtilsModule, only: get_saturated_topwidth, & @@ -40,8 +40,8 @@ module SfrModule ! implicit none ! - character(len=LENFTYPE) :: ftype = 'SFR' !< package ftype string - character(len=LENPACKAGENAME) :: text = ' SFR' !< package budget string + character(len=LENFTYPE) :: ftype = 'SFR' !< package ftype string + character(len=LENPACKAGENAME) :: text = ' SFR' !< package budget string ! private public :: sfr_create @@ -51,5514 +51,5528 @@ module SfrModule ! -- scalars ! -- for budgets ! -- characters - character(len=16), dimension(:), pointer, contiguous :: csfrbudget => NULL() !< advanced package budget names - character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() !< aux names - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: sfrname => null() !< internal SFR reach name + character(len=16), dimension(:), pointer, contiguous :: csfrbudget => NULL() !< advanced package budget names + character(len=16), dimension(:), pointer, contiguous :: cauxcbc => NULL() !< aux names + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: sfrname => null() !< internal SFR reach name ! -- integers - integer(I4B), pointer :: iprhed => null() !< flag for printing stages to listing file - integer(I4B), pointer :: istageout => null() !< flag and unit number for binary stage output - integer(I4B), pointer :: ibudgetout => null() !< flag and unit number for binary sfr budget output - integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file - integer(I4B), pointer :: ipakcsv => null() !< flag and unit number for package convergence information - integer(I4B), pointer :: idiversions => null() !< flag indicating if there are any diversions - integer(I4B), pointer :: nconn => NULL() !< number of reach connections - integer(I4B), pointer :: maxsfrpicard => NULL() !< maximum number of Picard iteration calls to SFR solve - integer(I4B), pointer :: maxsfrit => NULL() !< maximum number of iterations in SFR solve - integer(I4B), pointer :: bditems => NULL() !< number of SFR budget items - integer(I4B), pointer :: cbcauxitems => NULL() !< number of aux items in cell-by-cell budget file - integer(I4B), pointer :: icheck => NULL() !< flag indicating if input should be checked (default is yes) - integer(I4B), pointer :: iconvchk => NULL() !< flag indicating of final convergence run is executed - integer(I4B), pointer :: gwfiss => NULL() !< groundwater model steady-state flag - integer(I4B), pointer :: ianynone => null() !< number of reaches with 'none' connection + integer(I4B), pointer :: iprhed => null() !< flag for printing stages to listing file + integer(I4B), pointer :: istageout => null() !< flag and unit number for binary stage output + integer(I4B), pointer :: ibudgetout => null() !< flag and unit number for binary sfr budget output + integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + integer(I4B), pointer :: ipakcsv => null() !< flag and unit number for package convergence information + integer(I4B), pointer :: idiversions => null() !< flag indicating if there are any diversions + integer(I4B), pointer :: nconn => NULL() !< number of reach connections + integer(I4B), pointer :: maxsfrpicard => NULL() !< maximum number of Picard iteration calls to SFR solve + integer(I4B), pointer :: maxsfrit => NULL() !< maximum number of iterations in SFR solve + integer(I4B), pointer :: bditems => NULL() !< number of SFR budget items + integer(I4B), pointer :: cbcauxitems => NULL() !< number of aux items in cell-by-cell budget file + integer(I4B), pointer :: icheck => NULL() !< flag indicating if input should be checked (default is yes) + integer(I4B), pointer :: iconvchk => NULL() !< flag indicating of final convergence run is executed + integer(I4B), pointer :: gwfiss => NULL() !< groundwater model steady-state flag + integer(I4B), pointer :: ianynone => null() !< number of reaches with 'none' connection ! -- double precision - real(DP), pointer :: unitconv => NULL() !< unit conversion factor (SI to model units) - real(DP), pointer :: dmaxchg => NULL() !< maximum depth change allowed - real(DP), pointer :: deps => NULL() !< perturbation value + real(DP), pointer :: unitconv => NULL() !< unit conversion factor (SI to model units) + real(DP), pointer :: dmaxchg => NULL() !< maximum depth change allowed + real(DP), pointer :: deps => NULL() !< perturbation value ! -- integer vectors - integer(I4B), dimension(:), pointer, contiguous :: isfrorder => null() !< sfr reach order determined from DAG of upstream reaches - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< CRS row pointer for SFR reaches - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< CRS column pointers for SFR reach connections + integer(I4B), dimension(:), pointer, contiguous :: isfrorder => null() !< sfr reach order determined from DAG of upstream reaches + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< CRS row pointer for SFR reaches + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< CRS column pointers for SFR reach connections ! -- double precision output vectors - real(DP), dimension(:), pointer, contiguous :: qoutflow => null() !< reach downstream flow - real(DP), dimension(:), pointer, contiguous :: qextoutflow => null() !< reach discharge to external boundary - real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() !< aux value - real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< temporary vector + real(DP), dimension(:), pointer, contiguous :: qoutflow => null() !< reach downstream flow + real(DP), dimension(:), pointer, contiguous :: qextoutflow => null() !< reach discharge to external boundary + real(DP), dimension(:), pointer, contiguous :: qauxcbc => null() !< aux value + real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< temporary vector ! ! -- sfr budget object - type(BudgetObjectType), pointer :: budobj => null() !< SFR budget object + type(BudgetObjectType), pointer :: budobj => null() !< SFR budget object ! ! -- sfr table objects - type(TableType), pointer :: stagetab => null() !< reach stage table written to the listing file - type(TableType), pointer :: pakcsvtab => null() !< SFR package convergence table + type(TableType), pointer :: stagetab => null() !< reach stage table written to the listing file + type(TableType), pointer :: pakcsvtab => null() !< SFR package convergence table ! ! -- sfr reach data - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !< ibound array for SFR reaches that defines active, inactive, and constant reaches - integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() !< groundwater node connected to SFR reaches - integer(I4B), dimension(:), pointer, contiguous :: igwftopnode => null() !< highest active groundwater node under SFR reaches - real(DP), dimension(:), pointer, contiguous :: length => null() !< reach length - real(DP), dimension(:), pointer, contiguous :: width => null() !< reach width - real(DP), dimension(:), pointer, contiguous :: strtop => null() !< reach bed top elevation - real(DP), dimension(:), pointer, contiguous :: bthick => null() !< reach bed thickness - real(DP), dimension(:), pointer, contiguous :: hk => null() !< vertical hydraulic conductivity of reach bed sediments - real(DP), dimension(:), pointer, contiguous :: slope => null() !< reach slope - integer(I4B), dimension(:), pointer, contiguous :: nconnreach => null() !< number of connections for each reach - real(DP), dimension(:), pointer, contiguous :: ustrf => null() !< upstream flow fraction for upstream connections - real(DP), dimension(:), pointer, contiguous :: ftotnd => null() !< total fraction of connected reaches that are not diversions - integer(I4B), dimension(:), pointer, contiguous :: ndiv => null() !< number of diversions for each reach - real(DP), dimension(:), pointer, contiguous :: usflow => null() !< upstream reach flow - real(DP), dimension(:), pointer, contiguous :: dsflow => null() !< downstream reach flow - real(DP), dimension(:), pointer, contiguous :: depth => null() !< reach depth - real(DP), dimension(:), pointer, contiguous :: stage => null() !< reach stage - real(DP), dimension(:), pointer, contiguous :: gwflow => null() !< flow from groundwater to reach - real(DP), dimension(:), pointer, contiguous :: simevap => null() !< simulated reach evaporation - real(DP), dimension(:), pointer, contiguous :: simrunoff => null() !< simulated reach runoff - real(DP), dimension(:), pointer, contiguous :: stage0 => null() !< previous reach stage iterate - real(DP), dimension(:), pointer, contiguous :: usflow0 => null() !< previous upstream reach flow iterate + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !< ibound array for SFR reaches that defines active, inactive, and constant reaches + integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() !< groundwater node connected to SFR reaches + integer(I4B), dimension(:), pointer, contiguous :: igwftopnode => null() !< highest active groundwater node under SFR reaches + real(DP), dimension(:), pointer, contiguous :: length => null() !< reach length + real(DP), dimension(:), pointer, contiguous :: width => null() !< reach width + real(DP), dimension(:), pointer, contiguous :: strtop => null() !< reach bed top elevation + real(DP), dimension(:), pointer, contiguous :: bthick => null() !< reach bed thickness + real(DP), dimension(:), pointer, contiguous :: hk => null() !< vertical hydraulic conductivity of reach bed sediments + real(DP), dimension(:), pointer, contiguous :: slope => null() !< reach slope + integer(I4B), dimension(:), pointer, contiguous :: nconnreach => null() !< number of connections for each reach + real(DP), dimension(:), pointer, contiguous :: ustrf => null() !< upstream flow fraction for upstream connections + real(DP), dimension(:), pointer, contiguous :: ftotnd => null() !< total fraction of connected reaches that are not diversions + integer(I4B), dimension(:), pointer, contiguous :: ndiv => null() !< number of diversions for each reach + real(DP), dimension(:), pointer, contiguous :: usflow => null() !< upstream reach flow + real(DP), dimension(:), pointer, contiguous :: dsflow => null() !< downstream reach flow + real(DP), dimension(:), pointer, contiguous :: depth => null() !< reach depth + real(DP), dimension(:), pointer, contiguous :: stage => null() !< reach stage + real(DP), dimension(:), pointer, contiguous :: gwflow => null() !< flow from groundwater to reach + real(DP), dimension(:), pointer, contiguous :: simevap => null() !< simulated reach evaporation + real(DP), dimension(:), pointer, contiguous :: simrunoff => null() !< simulated reach runoff + real(DP), dimension(:), pointer, contiguous :: stage0 => null() !< previous reach stage iterate + real(DP), dimension(:), pointer, contiguous :: usflow0 => null() !< previous upstream reach flow iterate ! -- cross-section data - integer(I4B), pointer :: ncrossptstot => null() !< total number of cross-section points - integer(I4B), dimension(:), pointer, contiguous :: ncrosspts => null() !< number of cross-section points for each reach - integer(I4B), dimension(:), pointer, contiguous :: iacross => null() !< pointers to cross-section data for each reach - real(DP), dimension(:), pointer, contiguous :: station => null() !< cross-section station (x-position) data - real(DP), dimension(:), pointer, contiguous :: xsheight => null() !< cross-section height data - real(DP), dimension(:), pointer, contiguous :: xsrough => null() !< cross-section roughness data + integer(I4B), pointer :: ncrossptstot => null() !< total number of cross-section points + integer(I4B), dimension(:), pointer, contiguous :: ncrosspts => null() !< number of cross-section points for each reach + integer(I4B), dimension(:), pointer, contiguous :: iacross => null() !< pointers to cross-section data for each reach + real(DP), dimension(:), pointer, contiguous :: station => null() !< cross-section station (x-position) data + real(DP), dimension(:), pointer, contiguous :: xsheight => null() !< cross-section height data + real(DP), dimension(:), pointer, contiguous :: xsrough => null() !< cross-section roughness data ! -- connection data - integer(I4B), dimension(:), pointer, contiguous :: idir => null() !< reach connection direction - integer(I4B), dimension(:), pointer, contiguous :: idiv => null() !< reach connection diversion number - real(DP), dimension(:), pointer, contiguous :: qconn => null() !< reach connection flow + integer(I4B), dimension(:), pointer, contiguous :: idir => null() !< reach connection direction + integer(I4B), dimension(:), pointer, contiguous :: idiv => null() !< reach connection diversion number + real(DP), dimension(:), pointer, contiguous :: qconn => null() !< reach connection flow ! -- boundary data - real(DP), dimension(:), pointer, contiguous :: rough => null() !< reach Manning's roughness coefficient (SI units) - real(DP), dimension(:), pointer, contiguous :: rain => null() !< reach rainfall - real(DP), dimension(:), pointer, contiguous :: evap => null() !< reach potential evaporation - real(DP), dimension(:), pointer, contiguous :: inflow => null() !< reach upstream inflow - real(DP), dimension(:), pointer, contiguous :: runoff => null() !< reach maximum runoff - real(DP), dimension(:), pointer, contiguous :: sstage => null() !< reach specified stage + real(DP), dimension(:), pointer, contiguous :: rough => null() !< reach Manning's roughness coefficient (SI units) + real(DP), dimension(:), pointer, contiguous :: rain => null() !< reach rainfall + real(DP), dimension(:), pointer, contiguous :: evap => null() !< reach potential evaporation + real(DP), dimension(:), pointer, contiguous :: inflow => null() !< reach upstream inflow + real(DP), dimension(:), pointer, contiguous :: runoff => null() !< reach maximum runoff + real(DP), dimension(:), pointer, contiguous :: sstage => null() !< reach specified stage ! -- reach aux variables - real(DP), dimension(:,:), pointer, contiguous :: rauxvar => null() !< reach aux variable + real(DP), dimension(:, :), pointer, contiguous :: rauxvar => null() !< reach aux variable ! -- diversion data - integer(I4B), dimension(:), pointer, contiguous :: iadiv => null() !< row pointer for reach diversions - integer(I4B), dimension(:), pointer, contiguous :: divreach => null() !< diversion reach - character (len=10), dimension(:), pointer, contiguous :: divcprior => null() !< diversion rule - real(DP), dimension(:), pointer, contiguous :: divflow => null() !< specified diversion flow value - real(DP), dimension(:), pointer, contiguous :: divq => null() !< simulated diversion flow + integer(I4B), dimension(:), pointer, contiguous :: iadiv => null() !< row pointer for reach diversions + integer(I4B), dimension(:), pointer, contiguous :: divreach => null() !< diversion reach + character(len=10), dimension(:), pointer, contiguous :: divcprior => null() !< diversion rule + real(DP), dimension(:), pointer, contiguous :: divflow => null() !< specified diversion flow value + real(DP), dimension(:), pointer, contiguous :: divq => null() !< simulated diversion flow ! ! -- density variables - integer(I4B), pointer :: idense !< flag indicating if density corrections are active - real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() !< density terms + integer(I4B), pointer :: idense !< flag indicating if density corrections are active + real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() !< density terms ! ! -- type bound procedures - contains - procedure :: sfr_allocate_scalars - procedure :: sfr_allocate_arrays - procedure :: bnd_options => sfr_options - procedure :: read_dimensions => sfr_read_dimensions - ! procedure :: set_pointers => sfr_set_pointers - procedure :: bnd_ar => sfr_ar - procedure :: bnd_rp => sfr_rp - procedure :: bnd_ad => sfr_ad - procedure :: bnd_cf => sfr_cf - procedure :: bnd_fc => sfr_fc - procedure :: bnd_fn => sfr_fn - procedure :: bnd_cc => sfr_cc - procedure :: bnd_cq => sfr_cq - procedure :: bnd_ot_package_flows => sfr_ot_package_flows - procedure :: bnd_ot_dv => sfr_ot_dv - procedure :: bnd_ot_bdsummary => sfr_ot_bdsummary - procedure :: bnd_da => sfr_da - procedure :: define_listlabel - ! -- methods for observations - procedure, public :: bnd_obs_supported => sfr_obs_supported - procedure, public :: bnd_df_obs => sfr_df_obs - procedure, public :: bnd_rp_obs => sfr_rp_obs - procedure, public :: bnd_bd_obs => sfr_bd_obs - ! -- private procedures - procedure, private :: sfr_set_stressperiod - procedure, private :: sfr_solve - procedure, private :: sfr_update_flows - procedure, private :: sfr_calc_qgwf - procedure, private :: sfr_calc_cond - procedure, private :: sfr_calc_qman - procedure, private :: sfr_calc_qd - procedure, private :: sfr_calc_qsource - procedure, private :: sfr_calc_div - ! -- geometry - procedure, private :: calc_area_wet - procedure, private :: calc_perimeter_wet - procedure, private :: calc_surface_area - procedure, private :: calc_surface_area_wet - procedure, private :: calc_top_width_wet - ! -- reading - procedure, private :: sfr_read_packagedata - procedure, private :: sfr_read_crossection - procedure, private :: sfr_read_connectiondata - procedure, private :: sfr_read_diversions - ! -- calculations - procedure, private :: sfr_calc_reach_depth - procedure, private :: sfr_calc_xs_depth - ! -- error checking - procedure, private :: sfr_check_reaches - procedure, private :: sfr_check_connections - procedure, private :: sfr_check_diversions - procedure, private :: sfr_check_ustrf - ! -- budget - procedure, private :: sfr_setup_budobj - procedure, private :: sfr_fill_budobj - ! -- table - procedure, private :: sfr_setup_tableobj - ! -- density - procedure :: sfr_activate_density - procedure, private :: sfr_calculate_density_exchange + contains + procedure :: sfr_allocate_scalars + procedure :: sfr_allocate_arrays + procedure :: bnd_options => sfr_options + procedure :: read_dimensions => sfr_read_dimensions + ! procedure :: set_pointers => sfr_set_pointers + procedure :: bnd_ar => sfr_ar + procedure :: bnd_rp => sfr_rp + procedure :: bnd_ad => sfr_ad + procedure :: bnd_cf => sfr_cf + procedure :: bnd_fc => sfr_fc + procedure :: bnd_fn => sfr_fn + procedure :: bnd_cc => sfr_cc + procedure :: bnd_cq => sfr_cq + procedure :: bnd_ot_package_flows => sfr_ot_package_flows + procedure :: bnd_ot_dv => sfr_ot_dv + procedure :: bnd_ot_bdsummary => sfr_ot_bdsummary + procedure :: bnd_da => sfr_da + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => sfr_obs_supported + procedure, public :: bnd_df_obs => sfr_df_obs + procedure, public :: bnd_rp_obs => sfr_rp_obs + procedure, public :: bnd_bd_obs => sfr_bd_obs + ! -- private procedures + procedure, private :: sfr_set_stressperiod + procedure, private :: sfr_solve + procedure, private :: sfr_update_flows + procedure, private :: sfr_calc_qgwf + procedure, private :: sfr_calc_cond + procedure, private :: sfr_calc_qman + procedure, private :: sfr_calc_qd + procedure, private :: sfr_calc_qsource + procedure, private :: sfr_calc_div + ! -- geometry + procedure, private :: calc_area_wet + procedure, private :: calc_perimeter_wet + procedure, private :: calc_surface_area + procedure, private :: calc_surface_area_wet + procedure, private :: calc_top_width_wet + ! -- reading + procedure, private :: sfr_read_packagedata + procedure, private :: sfr_read_crossection + procedure, private :: sfr_read_connectiondata + procedure, private :: sfr_read_diversions + ! -- calculations + procedure, private :: sfr_calc_reach_depth + procedure, private :: sfr_calc_xs_depth + ! -- error checking + procedure, private :: sfr_check_reaches + procedure, private :: sfr_check_connections + procedure, private :: sfr_check_diversions + procedure, private :: sfr_check_ustrf + ! -- budget + procedure, private :: sfr_setup_budobj + procedure, private :: sfr_fill_budobj + ! -- table + procedure, private :: sfr_setup_tableobj + ! -- density + procedure :: sfr_activate_density + procedure, private :: sfr_calculate_density_exchange end type SfrType - contains +contains - !> @ brief Create a new package object + !> @ brief Create a new package object !! !! Create a new SFR Package object !! - !< - subroutine sfr_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) - ! -- modules - use MemoryHelperModule, only: create_mem_path - ! -- dummy variables - class(BndType), pointer :: packobj !< pointer to default package type - integer(I4B),intent(in) :: id !< package id - integer(I4B),intent(in) :: ibcnum !< boundary condition number - integer(I4B),intent(in) :: inunit !< unit number of SFR package input file - integer(I4B),intent(in) :: iout !< unit number of model listing file - character(len=*), intent(in) :: namemodel !< model name - character(len=*), intent(in) :: pakname !< package name - ! -- local variables - type(SfrType), pointer :: sfrobj - ! - ! -- allocate the object and assign values to object variables - allocate(sfrobj) - packobj => sfrobj - ! - ! -- create name and memory path - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call sfrobj%sfr_allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() + !< + subroutine sfr_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) + ! -- modules + use MemoryHelperModule, only: create_mem_path + ! -- dummy variables + class(BndType), pointer :: packobj !< pointer to default package type + integer(I4B), intent(in) :: id !< package id + integer(I4B), intent(in) :: ibcnum !< boundary condition number + integer(I4B), intent(in) :: inunit !< unit number of SFR package input file + integer(I4B), intent(in) :: iout !< unit number of model listing file + character(len=*), intent(in) :: namemodel !< model name + character(len=*), intent(in) :: pakname !< package name + ! -- local variables + type(SfrType), pointer :: sfrobj + ! + ! -- allocate the object and assign values to object variables + allocate (sfrobj) + packobj => sfrobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call sfrobj%sfr_allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() - packobj%inunit = inunit - packobj%iout = iout - packobj%id = id - packobj%ibcnum = ibcnum - packobj%ncolbnd = 4 - packobj%iscloc = 0 ! not supported - packobj%isadvpak = 1 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') - ! - ! -- return - return - end subroutine sfr_create + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 4 + packobj%iscloc = 0 ! not supported + packobj%isadvpak = 1 + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') + ! + ! -- return + return + end subroutine sfr_create - !> @ brief Allocate scalars + !> @ brief Allocate scalars !! !! Allocate and initialize scalars for the SFR package. The base model !! allocate scalars method is also called. !! - !< - subroutine sfr_allocate_scalars(this) - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - use MemoryHelperModule, only: create_mem_path - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%iprhed, 'IPRHED', this%memoryPath) - call mem_allocate(this%istageout, 'ISTAGEOUT', this%memoryPath) - call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%memoryPath) - call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath) - call mem_allocate(this%ipakcsv, 'IPAKCSV', this%memoryPath) - call mem_allocate(this%idiversions, 'IDIVERSIONS', this%memoryPath) - call mem_allocate(this%maxsfrpicard, 'MAXSFRPICARD', this%memoryPath) - call mem_allocate(this%maxsfrit, 'MAXSFRIT', this%memoryPath) - call mem_allocate(this%bditems, 'BDITEMS', this%memoryPath) - call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%memoryPath) - call mem_allocate(this%unitconv, 'UNITCONV', this%memoryPath) - call mem_allocate(this%dmaxchg, 'DMAXCHG', this%memoryPath) - call mem_allocate(this%deps, 'DEPS', this%memoryPath) - call mem_allocate(this%nconn, 'NCONN', this%memoryPath) - call mem_allocate(this%icheck, 'ICHECK', this%memoryPath) - call mem_allocate(this%iconvchk, 'ICONVCHK', this%memoryPath) - call mem_allocate(this%idense, 'IDENSE', this%memoryPath) - call mem_allocate(this%ianynone, 'IANYNONE', this%memoryPath) - call mem_allocate(this%ncrossptstot, 'NCROSSPTSTOT', this%memoryPath) - ! - ! -- set pointer to gwf iss - call mem_setptr(this%gwfiss, 'ISS', create_mem_path(this%name_model)) - ! - ! -- Set values - this%iprhed = 0 - this%istageout = 0 - this%ibudgetout = 0 - this%ibudcsv = 0 - this%ipakcsv = 0 - this%idiversions = 0 - this%maxsfrpicard = 100 - this%maxsfrit = 100 - this%bditems = 8 - this%cbcauxitems = 1 - this%unitconv = DONE - this%dmaxchg = DEM5 - this%deps = DP999 * this%dmaxchg - this%nconn = 0 - this%icheck = 1 - this%iconvchk = 1 - this%idense = 0 - this%ianynone = 0 - this%ncrossptstot = 0 - ! - ! -- return - return - end subroutine sfr_allocate_scalars + !< + subroutine sfr_allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + use MemoryHelperModule, only: create_mem_path + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%iprhed, 'IPRHED', this%memoryPath) + call mem_allocate(this%istageout, 'ISTAGEOUT', this%memoryPath) + call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%memoryPath) + call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath) + call mem_allocate(this%ipakcsv, 'IPAKCSV', this%memoryPath) + call mem_allocate(this%idiversions, 'IDIVERSIONS', this%memoryPath) + call mem_allocate(this%maxsfrpicard, 'MAXSFRPICARD', this%memoryPath) + call mem_allocate(this%maxsfrit, 'MAXSFRIT', this%memoryPath) + call mem_allocate(this%bditems, 'BDITEMS', this%memoryPath) + call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%memoryPath) + call mem_allocate(this%unitconv, 'UNITCONV', this%memoryPath) + call mem_allocate(this%dmaxchg, 'DMAXCHG', this%memoryPath) + call mem_allocate(this%deps, 'DEPS', this%memoryPath) + call mem_allocate(this%nconn, 'NCONN', this%memoryPath) + call mem_allocate(this%icheck, 'ICHECK', this%memoryPath) + call mem_allocate(this%iconvchk, 'ICONVCHK', this%memoryPath) + call mem_allocate(this%idense, 'IDENSE', this%memoryPath) + call mem_allocate(this%ianynone, 'IANYNONE', this%memoryPath) + call mem_allocate(this%ncrossptstot, 'NCROSSPTSTOT', this%memoryPath) + ! + ! -- set pointer to gwf iss + call mem_setptr(this%gwfiss, 'ISS', create_mem_path(this%name_model)) + ! + ! -- Set values + this%iprhed = 0 + this%istageout = 0 + this%ibudgetout = 0 + this%ibudcsv = 0 + this%ipakcsv = 0 + this%idiversions = 0 + this%maxsfrpicard = 100 + this%maxsfrit = 100 + this%bditems = 8 + this%cbcauxitems = 1 + this%unitconv = DONE + this%dmaxchg = DEM5 + this%deps = DP999 * this%dmaxchg + this%nconn = 0 + this%icheck = 1 + this%iconvchk = 1 + this%idense = 0 + this%ianynone = 0 + this%ncrossptstot = 0 + ! + ! -- return + return + end subroutine sfr_allocate_scalars - !> @ brief Allocate arrays + !> @ brief Allocate arrays !! !! Allocate and initialize array for the SFR package. !! - !< - subroutine sfr_allocate_arrays(this) - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - ! - ! -- allocate character array for budget text - allocate(this%csfrbudget(this%bditems)) - call mem_allocate(this%sfrname, LENBOUNDNAME, this%maxbound, & - 'SFRNAME', this%memoryPath) - ! - ! -- variables originally in SfrDataType - call mem_allocate(this%iboundpak, this%maxbound, 'IBOUNDPAK', this%memoryPath) - call mem_allocate(this%igwfnode, this%maxbound, 'IGWFNODE', this%memoryPath) - call mem_allocate(this%igwftopnode, this%maxbound, 'IGWFTOPNODE', this%memoryPath) - call mem_allocate(this%length, this%maxbound, 'LENGTH', this%memoryPath) - call mem_allocate(this%width, this%maxbound, 'WIDTH', this%memoryPath) - call mem_allocate(this%strtop, this%maxbound, 'STRTOP', this%memoryPath) - call mem_allocate(this%bthick, this%maxbound, 'BTHICK', this%memoryPath) - call mem_allocate(this%hk, this%maxbound, 'HK', this%memoryPath) - call mem_allocate(this%slope, this%maxbound, 'SLOPE', this%memoryPath) - call mem_allocate(this%nconnreach, this%maxbound, 'NCONNREACH', this%memoryPath) - call mem_allocate(this%ustrf, this%maxbound, 'USTRF', this%memoryPath) - call mem_allocate(this%ftotnd, this%maxbound, 'FTOTND', this%memoryPath) - call mem_allocate(this%ndiv, this%maxbound, 'NDIV', this%memoryPath) - call mem_allocate(this%usflow, this%maxbound, 'USFLOW', this%memoryPath) - call mem_allocate(this%dsflow, this%maxbound, 'DSFLOW', this%memoryPath) - call mem_allocate(this%depth, this%maxbound, 'DEPTH', this%memoryPath) - call mem_allocate(this%stage, this%maxbound, 'STAGE', this%memoryPath) - call mem_allocate(this%gwflow, this%maxbound, 'GWFLOW', this%memoryPath) - call mem_allocate(this%simevap, this%maxbound, 'SIMEVAP', this%memoryPath) - call mem_allocate(this%simrunoff, this%maxbound, 'SIMRUNOFF', this%memoryPath) - call mem_allocate(this%stage0, this%maxbound, 'STAGE0', this%memoryPath) - call mem_allocate(this%usflow0, this%maxbound, 'USFLOW0', this%memoryPath) - ! - ! -- reach order and connection data - call mem_allocate(this%isfrorder, this%maxbound, 'ISFRORDER', this%memoryPath) - call mem_allocate(this%ia, this%maxbound+1, 'IA', this%memoryPath) - call mem_allocate(this%ja, 0, 'JA', this%memoryPath) - call mem_allocate(this%idir, 0, 'IDIR', this%memoryPath) - call mem_allocate(this%idiv, 0, 'IDIV', this%memoryPath) - call mem_allocate(this%qconn, 0, 'QCONN', this%memoryPath) + !< + subroutine sfr_allocate_arrays(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + ! + ! -- allocate character array for budget text + allocate (this%csfrbudget(this%bditems)) + call mem_allocate(this%sfrname, LENBOUNDNAME, this%maxbound, & + 'SFRNAME', this%memoryPath) + ! + ! -- variables originally in SfrDataType + call mem_allocate(this%iboundpak, this%maxbound, 'IBOUNDPAK', & + this%memoryPath) + call mem_allocate(this%igwfnode, this%maxbound, 'IGWFNODE', this%memoryPath) + call mem_allocate(this%igwftopnode, this%maxbound, 'IGWFTOPNODE', & + this%memoryPath) + call mem_allocate(this%length, this%maxbound, 'LENGTH', this%memoryPath) + call mem_allocate(this%width, this%maxbound, 'WIDTH', this%memoryPath) + call mem_allocate(this%strtop, this%maxbound, 'STRTOP', this%memoryPath) + call mem_allocate(this%bthick, this%maxbound, 'BTHICK', this%memoryPath) + call mem_allocate(this%hk, this%maxbound, 'HK', this%memoryPath) + call mem_allocate(this%slope, this%maxbound, 'SLOPE', this%memoryPath) + call mem_allocate(this%nconnreach, this%maxbound, 'NCONNREACH', & + this%memoryPath) + call mem_allocate(this%ustrf, this%maxbound, 'USTRF', this%memoryPath) + call mem_allocate(this%ftotnd, this%maxbound, 'FTOTND', this%memoryPath) + call mem_allocate(this%ndiv, this%maxbound, 'NDIV', this%memoryPath) + call mem_allocate(this%usflow, this%maxbound, 'USFLOW', this%memoryPath) + call mem_allocate(this%dsflow, this%maxbound, 'DSFLOW', this%memoryPath) + call mem_allocate(this%depth, this%maxbound, 'DEPTH', this%memoryPath) + call mem_allocate(this%stage, this%maxbound, 'STAGE', this%memoryPath) + call mem_allocate(this%gwflow, this%maxbound, 'GWFLOW', this%memoryPath) + call mem_allocate(this%simevap, this%maxbound, 'SIMEVAP', this%memoryPath) + call mem_allocate(this%simrunoff, this%maxbound, 'SIMRUNOFF', & + this%memoryPath) + call mem_allocate(this%stage0, this%maxbound, 'STAGE0', this%memoryPath) + call mem_allocate(this%usflow0, this%maxbound, 'USFLOW0', this%memoryPath) + ! + ! -- reach order and connection data + call mem_allocate(this%isfrorder, this%maxbound, 'ISFRORDER', & + this%memoryPath) + call mem_allocate(this%ia, this%maxbound + 1, 'IA', this%memoryPath) + call mem_allocate(this%ja, 0, 'JA', this%memoryPath) + call mem_allocate(this%idir, 0, 'IDIR', this%memoryPath) + call mem_allocate(this%idiv, 0, 'IDIV', this%memoryPath) + call mem_allocate(this%qconn, 0, 'QCONN', this%memoryPath) + ! + ! -- boundary data + call mem_allocate(this%rough, this%maxbound, 'ROUGH', this%memoryPath) + call mem_allocate(this%rain, this%maxbound, 'RAIN', this%memoryPath) + call mem_allocate(this%evap, this%maxbound, 'EVAP', this%memoryPath) + call mem_allocate(this%inflow, this%maxbound, 'INFLOW', this%memoryPath) + call mem_allocate(this%runoff, this%maxbound, 'RUNOFF', this%memoryPath) + call mem_allocate(this%sstage, this%maxbound, 'SSTAGE', this%memoryPath) + ! + ! -- aux variables + call mem_allocate(this%rauxvar, this%naux, this%maxbound, & + 'RAUXVAR', this%memoryPath) + ! + ! -- diversion variables + call mem_allocate(this%iadiv, this%maxbound + 1, 'IADIV', this%memoryPath) + call mem_allocate(this%divreach, 0, 'DIVREACH', this%memoryPath) + call mem_allocate(this%divflow, 0, 'DIVFLOW', this%memoryPath) + call mem_allocate(this%divq, 0, 'DIVQ', this%memoryPath) + ! + ! -- cross-section data + call mem_allocate(this%ncrosspts, this%maxbound, 'NCROSSPTS', & + this%memoryPath) + call mem_allocate(this%iacross, this%maxbound + 1, 'IACROSS', & + this%memoryPath) + call mem_allocate(this%station, this%ncrossptstot, 'STATION', & + this%memoryPath) + call mem_allocate(this%xsheight, this%ncrossptstot, 'XSHEIGHT', & + this%memoryPath) + call mem_allocate(this%xsrough, this%ncrossptstot, 'XSROUGH', & + this%memoryPath) + ! + ! -- initialize variables + this%iacross(1) = 0 + do i = 1, this%maxbound + this%iboundpak(i) = 1 + this%igwfnode(i) = 0 + this%igwftopnode(i) = 0 + this%length(i) = DZERO + this%width(i) = DZERO + this%strtop(i) = DZERO + this%bthick(i) = DZERO + this%hk(i) = DZERO + this%slope(i) = DZERO + this%nconnreach(i) = 0 + this%ustrf(i) = DZERO + this%ftotnd(i) = DZERO + this%ndiv(i) = 0 + this%usflow(i) = DZERO + this%dsflow(i) = DZERO + this%depth(i) = DZERO + this%stage(i) = DZERO + this%gwflow(i) = DZERO + this%simevap(i) = DZERO + this%simrunoff(i) = DZERO + this%stage0(i) = DZERO + this%usflow0(i) = DZERO ! ! -- boundary data - call mem_allocate(this%rough, this%maxbound, 'ROUGH', this%memoryPath) - call mem_allocate(this%rain, this%maxbound, 'RAIN', this%memoryPath) - call mem_allocate(this%evap, this%maxbound, 'EVAP', this%memoryPath) - call mem_allocate(this%inflow, this%maxbound, 'INFLOW', this%memoryPath) - call mem_allocate(this%runoff, this%maxbound, 'RUNOFF', this%memoryPath) - call mem_allocate(this%sstage, this%maxbound, 'SSTAGE', this%memoryPath) + this%rough(i) = DZERO + this%rain(i) = DZERO + this%evap(i) = DZERO + this%inflow(i) = DZERO + this%runoff(i) = DZERO + this%sstage(i) = DZERO ! ! -- aux variables - call mem_allocate(this%rauxvar, this%naux, this%maxbound, & - 'RAUXVAR', this%memoryPath) - ! - ! -- diversion variables - call mem_allocate(this%iadiv, this%maxbound+1, 'IADIV', this%memoryPath) - call mem_allocate(this%divreach, 0, 'DIVREACH', this%memoryPath) - call mem_allocate(this%divflow, 0, 'DIVFLOW', this%memoryPath) - call mem_allocate(this%divq, 0, 'DIVQ', this%memoryPath) - ! - ! -- cross-section data - call mem_allocate(this%ncrosspts, this%maxbound, 'NCROSSPTS', this%memoryPath) - call mem_allocate(this%iacross, this%maxbound+1, 'IACROSS', this%memoryPath) - call mem_allocate(this%station, this%ncrossptstot, 'STATION', this%memoryPath) - call mem_allocate(this%xsheight, this%ncrossptstot, 'XSHEIGHT', this%memoryPath) - call mem_allocate(this%xsrough, this%ncrossptstot, 'XSROUGH', this%memoryPath) - ! - ! -- initialize variables - this%iacross(1) = 0 - do i = 1, this%maxbound - this%iboundpak(i) = 1 - this%igwfnode(i) = 0 - this%igwftopnode(i) = 0 - this%length(i) = DZERO - this%width(i) = DZERO - this%strtop(i) = DZERO - this%bthick(i) = DZERO - this%hk(i) = DZERO - this%slope(i) = DZERO - this%nconnreach(i) = 0 - this%ustrf(i) = DZERO - this%ftotnd(i) = DZERO - this%ndiv(i) = 0 - this%usflow(i) = DZERO - this%dsflow(i) = DZERO - this%depth(i) = DZERO - this%stage(i) = DZERO - this%gwflow(i) = DZERO - this%simevap(i) = DZERO - this%simrunoff(i) = DZERO - this%stage0(i) = DZERO - this%usflow0(i) = DZERO - ! - ! -- boundary data - this%rough(i) = DZERO - this%rain(i) = DZERO - this%evap(i) = DZERO - this%inflow(i) = DZERO - this%runoff(i) = DZERO - this%sstage(i) = DZERO - ! - ! -- aux variables - do j = 1, this%naux - this%rauxvar(j, i) = DZERO - end do - ! - ! -- cross-section data - this%ncrosspts(i) = 0 - this%iacross(i+1) = 0 + do j = 1, this%naux + this%rauxvar(j, i) = DZERO end do ! - ! -- initialize additional cross-section data - do i = 1, this%ncrossptstot - this%station(i) = DZERO - this%xsheight(i) = DZERO - this%xsrough(i) = DZERO - end do - ! - !-- fill csfrbudget - this%csfrbudget(1) = ' RAINFALL' - this%csfrbudget(2) = ' EVAPORATION' - this%csfrbudget(3) = ' RUNOFF' - this%csfrbudget(4) = ' EXT-INFLOW' - this%csfrbudget(5) = ' GWF' - this%csfrbudget(6) = ' EXT-OUTFLOW' - this%csfrbudget(7) = ' FROM-MVR' - this%csfrbudget(8) = ' TO-MVR' - ! - ! -- allocate and initialize budget output data - call mem_allocate(this%qoutflow, this%maxbound, 'QOUTFLOW', this%memoryPath) - call mem_allocate(this%qextoutflow, this%maxbound, 'QEXTOUTFLOW', this%memoryPath) + ! -- cross-section data + this%ncrosspts(i) = 0 + this%iacross(i + 1) = 0 + end do + ! + ! -- initialize additional cross-section data + do i = 1, this%ncrossptstot + this%station(i) = DZERO + this%xsheight(i) = DZERO + this%xsrough(i) = DZERO + end do + ! + !-- fill csfrbudget + this%csfrbudget(1) = ' RAINFALL' + this%csfrbudget(2) = ' EVAPORATION' + this%csfrbudget(3) = ' RUNOFF' + this%csfrbudget(4) = ' EXT-INFLOW' + this%csfrbudget(5) = ' GWF' + this%csfrbudget(6) = ' EXT-OUTFLOW' + this%csfrbudget(7) = ' FROM-MVR' + this%csfrbudget(8) = ' TO-MVR' + ! + ! -- allocate and initialize budget output data + call mem_allocate(this%qoutflow, this%maxbound, 'QOUTFLOW', this%memoryPath) + call mem_allocate(this%qextoutflow, this%maxbound, 'QEXTOUTFLOW', & + this%memoryPath) + do i = 1, this%maxbound + this%qoutflow(i) = DZERO + this%qextoutflow(i) = DZERO + end do + ! + ! -- allocate and initialize dbuff + if (this%istageout > 0) then + call mem_allocate(this%dbuff, this%maxbound, 'DBUFF', this%memoryPath) do i = 1, this%maxbound - this%qoutflow(i) = DZERO - this%qextoutflow(i) = DZERO - end do - ! - ! -- allocate and initialize dbuff - if (this%istageout > 0) then - call mem_allocate(this%dbuff, this%maxbound, 'DBUFF', this%memoryPath) - do i = 1, this%maxbound - this%dbuff(i) = DZERO - end do - else - call mem_allocate(this%dbuff, 0, 'DBUFF', this%memoryPath) - end if - ! - ! -- allocate character array for budget text - allocate(this%cauxcbc(this%cbcauxitems)) - ! - ! -- allocate and initialize qauxcbc - call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%memoryPath) - do i = 1, this%cbcauxitems - this%qauxcbc(i) = DZERO + this%dbuff(i) = DZERO end do - ! - !-- fill cauxcbc - this%cauxcbc(1) = 'FLOW-AREA ' - ! - ! -- allocate denseterms to size 0 - call mem_allocate(this%denseterms, 3, 0, 'DENSETERMS', this%memoryPath) - ! - ! -- return - return - end subroutine sfr_allocate_arrays + else + call mem_allocate(this%dbuff, 0, 'DBUFF', this%memoryPath) + end if + ! + ! -- allocate character array for budget text + allocate (this%cauxcbc(this%cbcauxitems)) + ! + ! -- allocate and initialize qauxcbc + call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', & + this%memoryPath) + do i = 1, this%cbcauxitems + this%qauxcbc(i) = DZERO + end do + ! + !-- fill cauxcbc + this%cauxcbc(1) = 'FLOW-AREA ' + ! + ! -- allocate denseterms to size 0 + call mem_allocate(this%denseterms, 3, 0, 'DENSETERMS', this%memoryPath) + ! + ! -- return + return + end subroutine sfr_allocate_arrays - !> @ brief Read dimensions for package + !> @ brief Read dimensions for package !! !! Read dimensions for the SFR package. !! - !< - subroutine sfr_read_dimensions(this) - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - character (len=LINELENGTH) :: keyword - integer(I4B) :: ierr - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - ! - ! -- initialize dimensions to 0 - this%maxbound = 0 - ! - ! -- get dimensions block - call this%parser%GetBlock('DIMENSIONS', isFound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse dimensions block if detected - if (isfound) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('NREACHES') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)')'NREACHES = ', this%maxbound - case default - write(errmsg,'(2a)') & - 'Unknown ' // trim(this%text) // ' dimension: ', trim(keyword) - call store_error(errmsg) - end select - end do - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' DIMENSIONS' - else - call store_error('Required dimensions block not found.') - end if - ! - ! -- verify dimensions were set - if(this%maxbound < 1) then - write(errmsg, '(a)') & - 'NREACHES was not specified or was specified incorrectly.' - call store_error(errmsg) - endif - ! - ! -- write summary of error messages for block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() - ! - ! -- Define default cross-section data size - this%ncrossptstot = this%maxbound - ! - ! -- Allocate arrays in package superclass - call this%sfr_allocate_arrays() - ! - ! -- read package data - call this%sfr_read_packagedata() - ! - ! -- read cross-section data - call this%sfr_read_crossection() - ! - ! -- read connection data - call this%sfr_read_connectiondata() - ! - ! -- read diversion data - call this%sfr_read_diversions() - ! - ! -- setup the budget object - call this%sfr_setup_budobj() - ! - ! -- setup the stage table object - call this%sfr_setup_tableobj() - ! - ! -- return - return - end subroutine sfr_read_dimensions + !< + subroutine sfr_read_dimensions(this) + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: keyword + integer(I4B) :: ierr + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + ! + ! -- initialize dimensions to 0 + this%maxbound = 0 + ! + ! -- get dimensions block + call this%parser%GetBlock('DIMENSIONS', isFound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse dimensions block if detected + if (isfound) then + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NREACHES') + this%maxbound = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NREACHES = ', this%maxbound + case default + write (errmsg, '(2a)') & + 'Unknown '//trim(this%text)//' dimension: ', trim(keyword) + call store_error(errmsg) + end select + end do + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('Required dimensions block not found.') + end if + ! + ! -- verify dimensions were set + if (this%maxbound < 1) then + write (errmsg, '(a)') & + 'NREACHES was not specified or was specified incorrectly.' + call store_error(errmsg) + end if + ! + ! -- write summary of error messages for block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- Define default cross-section data size + this%ncrossptstot = this%maxbound + ! + ! -- Allocate arrays in package superclass + call this%sfr_allocate_arrays() + ! + ! -- read package data + call this%sfr_read_packagedata() + ! + ! -- read cross-section data + call this%sfr_read_crossection() + ! + ! -- read connection data + call this%sfr_read_connectiondata() + ! + ! -- read diversion data + call this%sfr_read_diversions() + ! + ! -- setup the budget object + call this%sfr_setup_budobj() + ! + ! -- setup the stage table object + call this%sfr_setup_tableobj() + ! + ! -- return + return + end subroutine sfr_read_dimensions - !> @ brief Read additional options for package + !> @ brief Read additional options for package !! !! Read additional options for SFR package. !! - !< - subroutine sfr_options(this, option, found) - ! -- modules - use OpenSpecModule, only: access, form - use InputOutputModule, only: getunit, openfile - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - character(len=*), intent(inout) :: option !< option keyword string - logical(LGP), intent(inout) :: found !< boolean indicating if option found - ! -- local variables - real(DP) :: r - character(len=MAXCHARLEN) :: fname - character(len=MAXCHARLEN) :: keyword - ! -- formats - character(len=*),parameter :: fmtunitconv = & - "(4x, 'UNIT CONVERSION VALUE (',g0,') SPECIFIED.')" - character(len=*),parameter :: fmtpicard = & - "(4x, 'MAXIMUM SFR PICARD ITERATION VALUE (',i0,') SPECIFIED.')" - character(len=*),parameter :: fmtiter = & - "(4x, 'MAXIMUM SFR ITERATION VALUE (',i0,') SPECIFIED.')" - character(len=*),parameter :: fmtdmaxchg = & - "(4x, 'MAXIMUM DEPTH CHANGE VALUE (',g0,') SPECIFIED.')" - character(len=*),parameter :: fmtsfrbin = & - "(4x, 'SFR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, & - &'OPENED ON UNIT: ', I0)" - ! - ! -- Check for SFR options - select case (option) - case ('PRINT_STAGE') - this%iprhed = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' STAGES WILL BE PRINTED TO LISTING FILE.' - found = .true. - case('STAGE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%istageout = getunit() - call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', MNORMAL) - write(this%iout,fmtsfrbin) & - 'STAGE', trim(adjustl(fname)), this%istageout - found = .true. - else - call store_error('Optional stage keyword must be followed by fileout.') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', MNORMAL) - write(this%iout,fmtsfrbin) & - 'BUDGET', trim(adjustl(fname)), this%ibudgetout - found = .true. - else - call store_error('Optional budget keyword must be ' // & - 'followed by fileout.') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtsfrbin) & - 'BUDGET CSV', trim(adjustl(fname)), this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtsfrbin) & - 'PACKAGE_CONVERGENCE', trim(adjustl(fname)), this%ipakcsv - found = .true. - else - call store_error('Optional package_convergence keyword must be ' // & - 'followed by fileout.') - end if - case('UNIT_CONVERSION') - this%unitconv = this%parser%GetDouble() - write(this%iout, fmtunitconv) this%unitconv - found = .true. - case('MAXIMUM_PICARD_ITERATIONS') - this%maxsfrpicard = this%parser%GetInteger() - write(this%iout, fmtpicard) this%maxsfrpicard - found = .true. - case('MAXIMUM_ITERATIONS') - this%maxsfrit = this%parser%GetInteger() - write(this%iout, fmtiter) this%maxsfrit - found = .true. - case('MAXIMUM_DEPTH_CHANGE') - r = this%parser%GetDouble() - this%dmaxchg = r - this%deps = DP999 * r - write(this%iout, fmtdmaxchg) this%dmaxchg - found = .true. - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - ! - ! -- right now these are options that are only available in the - ! development version and are not included in the documentation. - ! These options are only available when IDEVELOPMODE in - ! constants module is set to 1 - case('DEV_NO_CHECK') - call this%parser%DevOpt() - this%icheck = 0 - write(this%iout, '(4x,A)') 'SFR CHECKS OF REACH GEOMETRY ' // & - 'RELATIVE TO MODEL GRID AND ' // & - 'REASONABLE PARAMETERS WILL NOT ' // & - 'BE PERFORMED.' - found = .true. - case('DEV_NO_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN STREAM FLOW ROUTING ' // & - & 'STAGES AND FLOWS WILL NOT BE MADE' - found = .true. - ! - ! -- no valid options found - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine sfr_options + !< + subroutine sfr_options(this, option, found) + ! -- modules + use OpenSpecModule, only: access, form + use InputOutputModule, only: getunit, openfile + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + character(len=*), intent(inout) :: option !< option keyword string + logical(LGP), intent(inout) :: found !< boolean indicating if option found + ! -- local variables + real(DP) :: r + character(len=MAXCHARLEN) :: fname + character(len=MAXCHARLEN) :: keyword + ! -- formats + character(len=*), parameter :: fmtunitconv = & + &"(4x, 'UNIT CONVERSION VALUE (',g0,') SPECIFIED.')" + character(len=*), parameter :: fmtpicard = & + &"(4x, 'MAXIMUM SFR PICARD ITERATION VALUE (',i0,') SPECIFIED.')" + character(len=*), parameter :: fmtiter = & + &"(4x, 'MAXIMUM SFR ITERATION VALUE (',i0,') SPECIFIED.')" + character(len=*), parameter :: fmtdmaxchg = & + &"(4x, 'MAXIMUM DEPTH CHANGE VALUE (',g0,') SPECIFIED.')" + character(len=*), parameter :: fmtsfrbin = & + "(4x, 'SFR ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, & + &'OPENED ON UNIT: ', I0)" + ! + ! -- Check for SFR options + select case (option) + case ('PRINT_STAGE') + this%iprhed = 1 + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' STAGES WILL BE PRINTED TO LISTING FILE.' + found = .true. + case ('STAGE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%istageout = getunit() + call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', MNORMAL) + write (this%iout, fmtsfrbin) & + 'STAGE', trim(adjustl(fname)), this%istageout + found = .true. + else + call store_error('Optional stage keyword must & + &be followed by fileout.') + end if + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', MNORMAL) + write (this%iout, fmtsfrbin) & + 'BUDGET', trim(adjustl(fname)), this%ibudgetout + found = .true. + else + call store_error('Optional budget keyword must be '// & + 'followed by fileout.') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtsfrbin) & + 'BUDGET CSV', trim(adjustl(fname)), this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case ('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtsfrbin) & + 'PACKAGE_CONVERGENCE', trim(adjustl(fname)), this%ipakcsv + found = .true. + else + call store_error('Optional package_convergence keyword must be '// & + 'followed by fileout.') + end if + case ('UNIT_CONVERSION') + this%unitconv = this%parser%GetDouble() + write (this%iout, fmtunitconv) this%unitconv + found = .true. + case ('MAXIMUM_PICARD_ITERATIONS') + this%maxsfrpicard = this%parser%GetInteger() + write (this%iout, fmtpicard) this%maxsfrpicard + found = .true. + case ('MAXIMUM_ITERATIONS') + this%maxsfrit = this%parser%GetInteger() + write (this%iout, fmtiter) this%maxsfrit + found = .true. + case ('MAXIMUM_DEPTH_CHANGE') + r = this%parser%GetDouble() + this%dmaxchg = r + this%deps = DP999 * r + write (this%iout, fmtdmaxchg) this%dmaxchg + found = .true. + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + ! + ! -- right now these are options that are only available in the + ! development version and are not included in the documentation. + ! These options are only available when IDEVELOPMODE in + ! constants module is set to 1 + case ('DEV_NO_CHECK') + call this%parser%DevOpt() + this%icheck = 0 + write (this%iout, '(4x,A)') 'SFR CHECKS OF REACH GEOMETRY '// & + 'RELATIVE TO MODEL GRID AND '// & + 'REASONABLE PARAMETERS WILL NOT '// & + 'BE PERFORMED.' + found = .true. + case ('DEV_NO_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write (this%iout, '(4x,a)') & + 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN STREAM FLOW ROUTING & + &STAGES AND FLOWS WILL NOT BE MADE' + found = .true. + ! + ! -- no valid options found + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine sfr_options - !> @ brief Allocate and read method for package + !> @ brief Allocate and read method for package !! !! Method to read and prepare period data for the SFR package. !! - !< - subroutine sfr_ar(this) - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - integer(I4B) :: n - integer(I4B) :: ierr - ! - ! -- allocate and read observations - call this%obs%obs_ar() - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_arrays() - ! - ! -- set boundname for each connection - if (this%inamedbound /= 0) then - do n = 1, this%maxbound - this%boundname(n) = this%sfrname(n) - end do - endif - ! - ! -- copy igwfnode into nodelist + !< + subroutine sfr_ar(this) + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + integer(I4B) :: n + integer(I4B) :: ierr + ! + ! -- allocate and read observations + call this%obs%obs_ar() + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_arrays() + ! + ! -- set boundname for each connection + if (this%inamedbound /= 0) then do n = 1, this%maxbound - this%nodelist(n) = this%igwfnode(n) + this%boundname(n) = this%sfrname(n) end do - ! - ! -- check the sfr data - call this%sfr_check_reaches() + end if + ! + ! -- copy igwfnode into nodelist + do n = 1, this%maxbound + this%nodelist(n) = this%igwfnode(n) + end do + ! + ! -- check the sfr data + call this%sfr_check_reaches() - ! -- check the connection data - call this%sfr_check_connections() + ! -- check the connection data + call this%sfr_check_connections() - ! -- check the diversion data - if (this%idiversions /= 0) then - call this%sfr_check_diversions() - end if - ! - ! -- terminate if errors were detected in any of the static sfr data - ierr = count_errors() - if (ierr > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- setup pakmvrobj - if (this%imover /= 0) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%memoryPath) - endif - ! - ! -- return - return - end subroutine sfr_ar + ! -- check the diversion data + if (this%idiversions /= 0) then + call this%sfr_check_diversions() + end if + ! + ! -- terminate if errors were detected in any of the static sfr data + ierr = count_errors() + if (ierr > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- setup pakmvrobj + if (this%imover /= 0) then + allocate (this%pakmvrobj) + call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%memoryPath) + end if + ! + ! -- return + return + end subroutine sfr_ar - !> @ brief Read packagedata for the package + !> @ brief Read packagedata for the package !! !! Method to read packagedata for each reach for the SFR package. !! - !< - subroutine sfr_read_packagedata(this) - ! -- modules - use TimeSeriesManagerModule, only: read_value_or_time_series_adv - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - character(len=LINELENGTH) :: text - character(len=LINELENGTH) :: cellid - character(len=LINELENGTH) :: keyword - character (len=10) :: cnum - character(len=LENBOUNDNAME) :: bndName - character(len=LENBOUNDNAME) :: bndNameTemp - character(len=LENBOUNDNAME) :: manningname - character(len=LENBOUNDNAME) :: ustrfname - character(len=50), dimension(:), allocatable :: caux - integer(I4B) :: n, ierr, ival - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - integer(I4B) :: i - integer(I4B) :: ii - integer(I4B) :: jj - integer(I4B) :: iaux - integer(I4B) :: nconzero - integer(I4B) :: ipos - integer, allocatable, dimension(:) :: nboundchk - real(DP), pointer :: bndElem => null() - ! - ! -- allocate space for checking sfr reach data - allocate(nboundchk(this%maxbound)) - do i = 1, this%maxbound - nboundchk(i) = 0 - enddo - nconzero = 0 - ! - ! -- allocate local storage for aux variables - if (this%naux > 0) then - allocate(caux(this%naux)) - end if - ! - ! -- read reach data - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse reaches block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' PACKAGEDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! -- read reach number - n = this%parser%GetInteger() + !< + subroutine sfr_read_packagedata(this) + ! -- modules + use TimeSeriesManagerModule, only: read_value_or_time_series_adv + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: text + character(len=LINELENGTH) :: cellid + character(len=LINELENGTH) :: keyword + character(len=10) :: cnum + character(len=LENBOUNDNAME) :: bndName + character(len=LENBOUNDNAME) :: bndNameTemp + character(len=LENBOUNDNAME) :: manningname + character(len=LENBOUNDNAME) :: ustrfname + character(len=50), dimension(:), allocatable :: caux + integer(I4B) :: n, ierr, ival + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + integer(I4B) :: i + integer(I4B) :: ii + integer(I4B) :: jj + integer(I4B) :: iaux + integer(I4B) :: nconzero + integer(I4B) :: ipos + integer, allocatable, dimension(:) :: nboundchk + real(DP), pointer :: bndElem => null() + ! + ! -- allocate space for checking sfr reach data + allocate (nboundchk(this%maxbound)) + do i = 1, this%maxbound + nboundchk(i) = 0 + end do + nconzero = 0 + ! + ! -- allocate local storage for aux variables + if (this%naux > 0) then + allocate (caux(this%naux)) + end if + ! + ! -- read reach data + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse reaches block if detected + if (isfound) then + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & + ' PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + ! -- read reach number + n = this%parser%GetInteger() - if (n < 1 .or. n > this%maxbound) then - write(errmsg,'(a,1x,a,1x,i0)') & - 'Reach number (rno) must be greater than 0 and less', & - 'than or equal to', this%maxbound - call store_error(errmsg) - cycle - end if + if (n < 1 .or. n > this%maxbound) then + write (errmsg, '(a,1x,a,1x,i0)') & + 'Reach number (rno) must be greater than 0 and less', & + 'than or equal to', this%maxbound + call store_error(errmsg) + cycle + end if - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - ! - ! -- get model node number - call this%parser%GetCellid(this%dis%ndim, cellid, flag_string=.true.) - this%igwfnode(n) = this%dis%noder_from_cellid(cellid, & - this%inunit, this%iout, flag_string=.true.) - this%igwftopnode(n) = this%igwfnode(n) - ! - ! -- read the cellid string and determine if 'none' is specified - if (this%igwfnode(n) < 1) then - call this%parser%GetStringCaps(keyword) - this%ianynone = this%ianynone + 1 - if (keyword /= 'NONE') then - write(cnum, '(i0)') n - errmsg = 'Cell ID (' // trim(cellid) // & - ') for unconnected reach ' // trim(cnum) // & - ' must be NONE' - call store_error(errmsg) - end if - end if - ! -- get reach length - this%length(n) = this%parser%GetDouble() - ! -- get reach width - this%width(n) = this%parser%GetDouble() - ! -- get reach slope - this%slope(n) = this%parser%GetDouble() - ! -- get reach stream bottom - this%strtop(n) = this%parser%GetDouble() - ! -- get reach bed thickness - this%bthick(n) = this%parser%GetDouble() - ! -- get reach bed hk - this%hk(n) = this%parser%GetDouble() - ! -- get reach roughness - call this%parser%GetStringCaps(manningname) - ! -- get number of connections for reach - ival = this%parser%GetInteger() - this%nconnreach(n) = ival - this%nconn = this%nconn + ival - if (ival < 0) then - write(errmsg, '(a,1x,i0,1x,a,i0,a)') & - 'NCON for reach', n, & - 'must be greater than or equal to 0 (', ival, ').' + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 + ! + ! -- get model node number + call this%parser%GetCellid(this%dis%ndim, cellid, flag_string=.true.) + this%igwfnode(n) = this%dis%noder_from_cellid(cellid, this%inunit, & + this%iout, & + flag_string=.true.) + this%igwftopnode(n) = this%igwfnode(n) + ! + ! -- read the cellid string and determine if 'none' is specified + if (this%igwfnode(n) < 1) then + call this%parser%GetStringCaps(keyword) + this%ianynone = this%ianynone + 1 + if (keyword /= 'NONE') then + write (cnum, '(i0)') n + errmsg = 'Cell ID ('//trim(cellid)// & + ') for unconnected reach '//trim(cnum)// & + ' must be NONE' call store_error(errmsg) - else if (ival == 0) then - nconzero = nconzero + 1 - end if - ! -- get upstream fraction for reach - call this%parser%GetString(ustrfname) - ! -- get number of diversions for reach - ival = this%parser%GetInteger() - this%ndiv(n) = ival - if (ival > 0) then - this%idiversions = 1 - else if (ival < 0) then - ival = 0 end if + end if + ! -- get reach length + this%length(n) = this%parser%GetDouble() + ! -- get reach width + this%width(n) = this%parser%GetDouble() + ! -- get reach slope + this%slope(n) = this%parser%GetDouble() + ! -- get reach stream bottom + this%strtop(n) = this%parser%GetDouble() + ! -- get reach bed thickness + this%bthick(n) = this%parser%GetDouble() + ! -- get reach bed hk + this%hk(n) = this%parser%GetDouble() + ! -- get reach roughness + call this%parser%GetStringCaps(manningname) + ! -- get number of connections for reach + ival = this%parser%GetInteger() + this%nconnreach(n) = ival + this%nconn = this%nconn + ival + if (ival < 0) then + write (errmsg, '(a,1x,i0,1x,a,i0,a)') & + 'NCON for reach', n, & + 'must be greater than or equal to 0 (', ival, ').' + call store_error(errmsg) + else if (ival == 0) then + nconzero = nconzero + 1 + end if + ! -- get upstream fraction for reach + call this%parser%GetString(ustrfname) + ! -- get number of diversions for reach + ival = this%parser%GetInteger() + this%ndiv(n) = ival + if (ival > 0) then + this%idiversions = 1 + else if (ival < 0) then + ival = 0 + end if - ! -- get aux data - do iaux = 1, this%naux - call this%parser%GetString(caux(iaux)) - end do + ! -- get aux data + do iaux = 1, this%naux + call this%parser%GetString(caux(iaux)) + end do - ! -- set default bndName - write(cnum,'(i10.10)') n - bndName = 'Reach' // cnum + ! -- set default bndName + write (cnum, '(i10.10)') n + bndName = 'Reach'//cnum - ! -- get reach name - if (this%inamedbound /= 0) then - call this%parser%GetStringCaps(bndNameTemp) - if (bndNameTemp /= '') then - bndName = bndNameTemp - endif - !this%boundname(n) = bndName + ! -- get reach name + if (this%inamedbound /= 0) then + call this%parser%GetStringCaps(bndNameTemp) + if (bndNameTemp /= '') then + bndName = bndNameTemp end if - this%sfrname(n) = bndName - ! - ! -- set Mannings - text = manningname - jj = 1 !for 'ROUGH' - bndElem => this%rough(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'MANNING') - ! - ! -- set upstream fraction - text = ustrfname - jj = 1 ! For 'USTRF' - bndElem => this%ustrf(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'USTRF') - ! - ! -- get aux data - do jj = 1, this%naux - text = caux(jj) - ii = n - bndElem => this%rauxvar(jj, ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'AUX', this%tsManager, this%iprpak, & - this%auxname(jj)) - end do - ! - ! -- initialize sstage to the top of the reach - ! this value would be used by simple routing reaches - ! on kper = 1 and kstp = 1 if a stage is not specified - ! on the status line for the reach - this%sstage(n) = this%strtop(n) - + !this%boundname(n) = bndName + end if + this%sfrname(n) = bndName + ! + ! -- set Mannings + text = manningname + jj = 1 !for 'ROUGH' + bndElem => this%rough(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & + 'MANNING') + ! + ! -- set upstream fraction + text = ustrfname + jj = 1 ! For 'USTRF' + bndElem => this%ustrf(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'USTRF') + ! + ! -- get aux data + do jj = 1, this%naux + text = caux(jj) + ii = n + bndElem => this%rauxvar(jj, ii) + call read_value_or_time_series_adv(text, ii, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & + this%auxname(jj)) end do - write(this%iout,'(1x,a)') & - 'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' - else - call store_error('REQUIRED PACKAGEDATA BLOCK NOT FOUND.') - end if - ! - ! -- Check to make sure that every reach is specified and that no reach - ! is specified more than once. - do i = 1, this%maxbound - if (nboundchk(i) == 0) then - write(errmsg, '(a,i0,1x,a)') & - 'Information for reach ', i, 'not specified in packagedata block.' - call store_error(errmsg) - else if (nboundchk(i) > 1) then - write(errmsg, '(a,1x,i0,1x,a,1x,i0)') & - 'Reach information specified', nboundchk(i), 'times for reach', i - call store_error(errmsg) - endif - end do - deallocate(nboundchk) - ! - ! -- Submit warning message if any reach has zero connections - if (nconzero > 0) then - write(warnmsg, '(a,1x,a,1x,a,1x,i0,1x, a)') & - 'SFR Package', trim(this%packName), & - 'has', nconzero, 'reach(es) with zero connections.' - call store_warning(warnmsg) - endif - ! - ! -- terminate if errors encountered in reach block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- initialize the cross-section data - ipos = 1 - this%iacross(1) = ipos - do i = 1, this%maxbound - this%ncrosspts(i) = 1 - this%station(ipos) = this%width(i) - this%xsheight(ipos) = DZERO - this%xsrough(ipos) = DONE - ipos = ipos + 1 - this%iacross(i+1) = ipos + ! + ! -- initialize sstage to the top of the reach + ! this value would be used by simple routing reaches + ! on kper = 1 and kstp = 1 if a stage is not specified + ! on the status line for the reach + this%sstage(n) = this%strtop(n) + end do - ! - ! -- deallocate local storage for aux variables - if (this%naux > 0) then - deallocate(caux) + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' + else + call store_error('REQUIRED PACKAGEDATA BLOCK NOT FOUND.') + end if + ! + ! -- Check to make sure that every reach is specified and that no reach + ! is specified more than once. + do i = 1, this%maxbound + if (nboundchk(i) == 0) then + write (errmsg, '(a,i0,1x,a)') & + 'Information for reach ', i, 'not specified in packagedata block.' + call store_error(errmsg) + else if (nboundchk(i) > 1) then + write (errmsg, '(a,1x,i0,1x,a,1x,i0)') & + 'Reach information specified', nboundchk(i), 'times for reach', i + call store_error(errmsg) end if - ! - ! -- return - return - end subroutine sfr_read_packagedata - - !> @ brief Read crosssection block for the package + end do + deallocate (nboundchk) + ! + ! -- Submit warning message if any reach has zero connections + if (nconzero > 0) then + write (warnmsg, '(a,1x,a,1x,a,1x,i0,1x, a)') & + 'SFR Package', trim(this%packName), & + 'has', nconzero, 'reach(es) with zero connections.' + call store_warning(warnmsg) + end if + ! + ! -- terminate if errors encountered in reach block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- initialize the cross-section data + ipos = 1 + this%iacross(1) = ipos + do i = 1, this%maxbound + this%ncrosspts(i) = 1 + this%station(ipos) = this%width(i) + this%xsheight(ipos) = DZERO + this%xsrough(ipos) = DONE + ipos = ipos + 1 + this%iacross(i + 1) = ipos + end do + ! + ! -- deallocate local storage for aux variables + if (this%naux > 0) then + deallocate (caux) + end if + ! + ! -- return + return + end subroutine sfr_read_packagedata + + !> @ brief Read crosssection block for the package !! !! Method to read crosssection data for the SFR package. !! - !< - subroutine sfr_read_crossection(this) - ! -- modules - use MemoryManagerModule, only: mem_reallocate - use sfrCrossSectionManager, only: cross_section_cr, SfrCrossSection - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: line - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - integer(I4B) :: n - integer(I4B) :: ierr - integer(I4B) :: ncrossptstot - integer, allocatable, dimension(:) :: nboundchk - type(SfrCrossSection), pointer :: cross_data => null() + !< + subroutine sfr_read_crossection(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + use sfrCrossSectionManager, only: cross_section_cr, SfrCrossSection + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: line + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + integer(I4B) :: n + integer(I4B) :: ierr + integer(I4B) :: ncrossptstot + integer, allocatable, dimension(:) :: nboundchk + type(SfrCrossSection), pointer :: cross_data => null() + ! + ! -- read cross-section data + call this%parser%GetBlock('CROSSSECTIONS', isfound, ierr, & + supportOpenClose=.true., & + blockRequired=.false.) + ! + ! -- parse reach connectivity block if detected + if (isfound) then + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' CROSSSECTIONS' ! - ! -- read cross-section data - call this%parser%GetBlock('CROSSSECTIONS', isfound, ierr, & - supportOpenClose=.true., & - blockRequired=.false.) + ! -- allocate and initialize local variables for reach cross-sections + allocate (nboundchk(this%maxbound)) + do n = 1, this%maxbound + nboundchk(n) = 0 + end do ! - ! -- parse reach connectivity block if detected - if (isfound) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' CROSSSECTIONS' + ! -- create and initialize cross-section data + call cross_section_cr(cross_data, this%iout, this%iprpak, this%maxbound) + call cross_data%initialize(this%ncrossptstot, this%ncrosspts, & + this%iacross, & + this%station, this%xsheight, & + this%xsrough) + ! + ! -- read all of the entries in the block + readtable: do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit ! - ! -- allocate and initialize local variables for reach cross-sections - allocate(nboundchk(this%maxbound)) - do n = 1, this%maxbound - nboundchk(n) = 0 - end do + ! -- get reach number + n = this%parser%GetInteger() ! - ! -- create and initialize cross-section data - call cross_section_cr(cross_data, this%iout, this%iprpak, this%maxbound) - call cross_data%initialize(this%ncrossptstot, this%ncrosspts, & - this%iacross, & - this%station, this%xsheight, & - this%xsrough) + ! -- check for reach number error + if (n < 1 .or. n > this%maxbound) then + write (errmsg, '(a,1x,a,1x,i0)') & + 'SFR reach in crosssections block is less than one or greater', & + 'than NREACHES:', n + call store_error(errmsg) + cycle readtable + end if ! - ! -- read all of the entries in the block - readtable: do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get reach number - n = this%parser%GetInteger() - ! - ! -- check for reach number error - if (n < 1 .or. n > this%maxbound) then - write(errmsg, '(a,1x,a,1x,i0)') & - 'SFR reach in crosssections block is less than one or greater', & - 'than NREACHES:', n - call store_error(errmsg) - cycle readtable - endif - ! - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - ! - ! -- read FILE keyword - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('TAB6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAB6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - cycle readtable - end if - call this%parser%GetString(line) - call cross_data%read_table(n, this%width(n), & - trim(adjustl(line))) - case default - write(errmsg,'(a,1x,i4,1x,a)') & - 'CROSS-SECTION TABLE ENTRY for REACH ', n, & - 'MUST INCLUDE TAB6 KEYWORD' - call store_error(errmsg) - cycle readtable - end select - end do readtable - - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' CROSSSECTIONS' - + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 ! - ! -- check for duplicate sfr crosssections - do n = 1, this%maxbound - if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'Cross-section data for reach', n, & - 'specified', nboundchk(n), 'times.' + ! -- read FILE keyword + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('TAB6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAB6 keyword must be followed by "FILEIN" '// & + 'then by filename.' call store_error(errmsg) + cycle readtable end if - end do - ! - ! -- terminate if errors encountered in cross-sections block - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- determine the current size of cross-section data - ncrossptstot = cross_data%get_ncrossptstot() - ! - ! -- reallocate sfr package cross-section data - if (ncrossptstot /= this%ncrossptstot) then - this%ncrossptstot = ncrossptstot - call mem_reallocate(this%station, this%ncrossptstot, 'STATION', this%memoryPath) - call mem_reallocate(this%xsheight, this%ncrossptstot, 'XSHEIGHT', this%memoryPath) - call mem_reallocate(this%xsrough, this%ncrossptstot, 'XSROUGH', this%memoryPath) - end if - ! - ! -- write cross-section data to the model listing file - call cross_data%output(this%width, this%rough) - ! - ! -- pack cross-section data - call cross_data%pack(this%ncrossptstot, this%ncrosspts, & - this%iacross, & - this%station, & - this%xsheight, & - this%xsrough) - ! - ! -- deallocate temporary local storage for reach cross-sections - deallocate(nboundchk) - call cross_data%destroy() - deallocate(cross_data) - nullify(cross_data) - end if - ! - ! -- return - return - end subroutine sfr_read_crossection + call this%parser%GetString(line) + call cross_data%read_table(n, this%width(n), & + trim(adjustl(line))) + case default + write (errmsg, '(a,1x,i4,1x,a)') & + 'CROSS-SECTION TABLE ENTRY for REACH ', n, & + 'MUST INCLUDE TAB6 KEYWORD' + call store_error(errmsg) + cycle readtable + end select + end do readtable + + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' CROSSSECTIONS' - !> @ brief Read connectiondata for the package - !! - !! Method to read connectiondata for each reach for the SFR package. - !! - !< - subroutine sfr_read_connectiondata(this) - ! -- modules - use MemoryManagerModule, only: mem_reallocate - use SparseModule, only: sparsematrix - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - character (len=LINELENGTH) :: line - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - integer(I4B) :: n - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jj - integer(I4B) :: jcol - integer(I4B) :: jcol2 - integer(I4B) :: nja - integer(I4B) :: ival - integer(I4B) :: idir - integer(I4B) :: ierr - integer(I4B) :: nconnmax - integer(I4B) :: nup - integer(I4B) :: ipos - integer(I4B) :: istat - integer(I4B), dimension(:), pointer, contiguous :: rowmaxnnz => null() - integer, allocatable, dimension(:) :: nboundchk - integer, allocatable, dimension(:,:) :: iconndata - type(sparsematrix), pointer :: sparse => null() - integer(I4B), dimension(:), allocatable :: iup - integer(I4B), dimension(:), allocatable :: order - type(dag) :: sfr_dag - ! - ! -- allocate and initialize local variables for reach connections - allocate(nboundchk(this%maxbound)) - do n = 1, this%maxbound - nboundchk(n) = 0 - end do ! - ! -- calculate the number of non-zero entries (size of ja maxtrix) - nja = 0 - nconnmax = 0 - allocate(rowmaxnnz(this%maxbound)) + ! -- check for duplicate sfr crosssections do n = 1, this%maxbound - ival = this%nconnreach(n) - if (ival < 0) ival = 0 - rowmaxnnz(n) = ival + 1 - nja = nja + ival + 1 - if (ival > nconnmax) then - nconnmax = ival + if (nboundchk(n) > 1) then + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'Cross-section data for reach', n, & + 'specified', nboundchk(n), 'times.' + call store_error(errmsg) end if end do ! - ! -- reallocate connection data for package - call mem_reallocate(this%ja, nja, 'JA', this%memoryPath) - call mem_reallocate(this%idir, nja, 'IDIR', this%memoryPath) - call mem_reallocate(this%idiv, nja, 'IDIV', this%memoryPath) - call mem_reallocate(this%qconn, nja, 'QCONN', this%memoryPath) - ! - ! -- initialize connection data - do n = 1, nja - this%idir(n) = 0 - this%idiv(n) = 0 - this%qconn(n) = DZERO - end do - ! - ! -- allocate space for iconndata - allocate(iconndata(nconnmax, this%maxbound)) - ! - ! -- initialize iconndata - do n = 1, this%maxbound - do j = 1, nconnmax - iconndata(j, n) = 0 - end do - end do - ! - ! -- allocate space for connectivity - allocate(sparse) - ! - ! -- set up sparse - call sparse%init(this%maxbound, this%maxbound, rowmaxnnz) - ! - ! -- read connection data - call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse reach connectivity block if detected - if (isfound) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' CONNECTIONDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get reach number - n = this%parser%GetInteger() - ! - ! -- check for error - if (n < 1 .or. n > this%maxbound) then - write(errmsg, '(a,1x,a,1x,i0)') & - 'SFR reach in connectiondata block is less than one or greater', & - 'than NREACHES:', n - call store_error(errmsg) - cycle - endif - ! - ! -- increment nboundchk - nboundchk(n) = nboundchk(n) + 1 - ! - ! -- add diagonal connection for reach - call sparse%addconnection(n, n, 1) - ! - ! -- fill off diagonals - do i = 1, this%nconnreach(n) - ! - ! -- get connected reach - ival = this%parser%GetInteger() - ! - ! -- save connection data to temporary iconndata - iconndata(i, n) = ival - ! - ! -- determine idir - if (ival < 0) then - idir = -1 - ival = abs(ival) - elseif (ival == 0) then - call store_error('Missing or zero connection reach in line:') - call store_error(line) - else - idir = 1 - end if - if (ival > this%maxbound) then - call store_error('Reach number exceeds NREACHES in line:') - call store_error(line) - endif - ! - ! -- add connection to sparse - call sparse%addconnection(n, ival, 1) - end do - end do - - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' CONNECTIONDATA' - - do n = 1, this%maxbound - ! - ! -- check for missing or duplicate sfr connections - if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') & - 'No connection data specified for reach', n - call store_error(errmsg) - else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'Connection data for reach', n, & - 'specified', nboundchk(n), 'times.' - call store_error(errmsg) - end if - end do - else - call store_error('Required connectiondata block not found.') - end if - ! - ! -- terminate if errors encountered in connectiondata block + ! -- terminate if errors encountered in cross-sections block if (count_errors() > 0) then call this%parser%StoreErrorUnit() end if ! - ! -- create ia and ja from sparse - call sparse%filliaja(this%ia, this%ja, ierr, sort=.TRUE.) - ! - ! -- test for error condition - if (ierr /= 0) then - write(errmsg, '(a,3(1x,a))') & - 'Could not fill', trim(this%packName), & - 'package IA and JA connection data.', & - 'Check connectivity data in connectiondata block.' - call store_error(errmsg) + ! -- determine the current size of cross-section data + ncrossptstot = cross_data%get_ncrossptstot() + ! + ! -- reallocate sfr package cross-section data + if (ncrossptstot /= this%ncrossptstot) then + this%ncrossptstot = ncrossptstot + call mem_reallocate(this%station, this%ncrossptstot, 'STATION', & + this%memoryPath) + call mem_reallocate(this%xsheight, this%ncrossptstot, 'XSHEIGHT', & + this%memoryPath) + call mem_reallocate(this%xsrough, this%ncrossptstot, 'XSROUGH', & + this%memoryPath) end if ! - ! -- fill flat connection storage - do n = 1, this%maxbound - do j = this%ia(n) + 1, this%ia(n+1) - 1 - jcol = this%ja(j) - do jj = 1, this%nconnreach(n) - jcol2 = iconndata(jj, n) - if (abs(jcol2) == jcol) then - idir = 1 - if (jcol2 < 0) then - idir = -1 - end if - this%idir(j) = idir - exit - end if - end do - end do + ! -- write cross-section data to the model listing file + call cross_data%output(this%width, this%rough) + ! + ! -- pack cross-section data + call cross_data%pack(this%ncrossptstot, this%ncrosspts, & + this%iacross, & + this%station, & + this%xsheight, & + this%xsrough) + ! + ! -- deallocate temporary local storage for reach cross-sections + deallocate (nboundchk) + call cross_data%destroy() + deallocate (cross_data) + nullify (cross_data) + end if + ! + ! -- return + return + end subroutine sfr_read_crossection + + !> @ brief Read connectiondata for the package + !! + !! Method to read connectiondata for each reach for the SFR package. + !! + !< + subroutine sfr_read_connectiondata(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + use SparseModule, only: sparsematrix + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: line + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + integer(I4B) :: n + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jj + integer(I4B) :: jcol + integer(I4B) :: jcol2 + integer(I4B) :: nja + integer(I4B) :: ival + integer(I4B) :: idir + integer(I4B) :: ierr + integer(I4B) :: nconnmax + integer(I4B) :: nup + integer(I4B) :: ipos + integer(I4B) :: istat + integer(I4B), dimension(:), pointer, contiguous :: rowmaxnnz => null() + integer, allocatable, dimension(:) :: nboundchk + integer, allocatable, dimension(:, :) :: iconndata + type(sparsematrix), pointer :: sparse => null() + integer(I4B), dimension(:), allocatable :: iup + integer(I4B), dimension(:), allocatable :: order + type(dag) :: sfr_dag + ! + ! -- allocate and initialize local variables for reach connections + allocate (nboundchk(this%maxbound)) + do n = 1, this%maxbound + nboundchk(n) = 0 + end do + ! + ! -- calculate the number of non-zero entries (size of ja maxtrix) + nja = 0 + nconnmax = 0 + allocate (rowmaxnnz(this%maxbound)) + do n = 1, this%maxbound + ival = this%nconnreach(n) + if (ival < 0) ival = 0 + rowmaxnnz(n) = ival + 1 + nja = nja + ival + 1 + if (ival > nconnmax) then + nconnmax = ival + end if + end do + ! + ! -- reallocate connection data for package + call mem_reallocate(this%ja, nja, 'JA', this%memoryPath) + call mem_reallocate(this%idir, nja, 'IDIR', this%memoryPath) + call mem_reallocate(this%idiv, nja, 'IDIV', this%memoryPath) + call mem_reallocate(this%qconn, nja, 'QCONN', this%memoryPath) + ! + ! -- initialize connection data + do n = 1, nja + this%idir(n) = 0 + this%idiv(n) = 0 + this%qconn(n) = DZERO + end do + ! + ! -- allocate space for iconndata + allocate (iconndata(nconnmax, this%maxbound)) + ! + ! -- initialize iconndata + do n = 1, this%maxbound + do j = 1, nconnmax + iconndata(j, n) = 0 end do - ! - ! -- deallocate temporary local storage for reach connections - deallocate(rowmaxnnz) - deallocate(nboundchk) - deallocate(iconndata) - ! - ! -- destroy sparse - call sparse%destroy() - deallocate(sparse) - ! - ! -- calculate reach order using DAG - ! - ! -- initialize the DAG - call sfr_dag%set_vertices(this%maxbound) - ! - ! -- fill DAG - fill_dag: do n = 1, this%maxbound + end do + ! + ! -- allocate space for connectivity + allocate (sparse) + ! + ! -- set up sparse + call sparse%init(this%maxbound, this%maxbound, rowmaxnnz) + ! + ! -- read connection data + call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse reach connectivity block if detected + if (isfound) then + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' CONNECTIONDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit ! - ! -- determine the number of upstream reaches - nup = 0 - do j = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(j) > 0) then - nup = nup + 1 - end if - end do + ! -- get reach number + n = this%parser%GetInteger() + ! + ! -- check for error + if (n < 1 .or. n > this%maxbound) then + write (errmsg, '(a,1x,a,1x,i0)') & + 'SFR reach in connectiondata block is less than one or greater', & + 'than NREACHES:', n + call store_error(errmsg) + cycle + end if ! - ! -- cycle if nu upstream reacches - if (nup == 0) cycle fill_dag + ! -- increment nboundchk + nboundchk(n) = nboundchk(n) + 1 ! - ! -- allocate local storage - allocate(iup(nup)) + ! -- add diagonal connection for reach + call sparse%addconnection(n, n, 1) ! - ! -- fill local storage - ipos = 1 - do j = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(j) > 0) then - iup(ipos) = this%ja(j) - ipos = ipos + 1 + ! -- fill off diagonals + do i = 1, this%nconnreach(n) + ! + ! -- get connected reach + ival = this%parser%GetInteger() + ! + ! -- save connection data to temporary iconndata + iconndata(i, n) = ival + ! + ! -- determine idir + if (ival < 0) then + idir = -1 + ival = abs(ival) + elseif (ival == 0) then + call store_error('Missing or zero connection reach in line:') + call store_error(line) + else + idir = 1 + end if + if (ival > this%maxbound) then + call store_error('Reach number exceeds NREACHES in line:') + call store_error(line) end if + ! + ! -- add connection to sparse + call sparse%addconnection(n, ival, 1) end do - ! - ! -- add upstream connections to DAG - call sfr_dag%set_edges(n, iup) - ! - ! -- clean up local storage - deallocate(iup) - end do fill_dag - ! - ! -- perform toposort on DAG - call sfr_dag%toposort(order, istat) - ! - ! -- write warning if circular dependency - if (istat == -1) then - write(warnmsg,'(a)') & - trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) // ') cannot calculate a ' // & - 'Directed Asyclic Graph for reach connectivity because ' // & - 'of circular dependency. Using the reach number for ' // & - 'solution ordering.' - call store_warning(warnmsg) - end if - ! - ! -- fill isfrorder - do n = 1, this%maxbound - if (istat == 0) then - this%isfrorder(n) = order(n) - else - this%isfrorder(n) = n - end if end do - ! - ! -- clean up DAG and remaining local storage - call sfr_dag%destroy() - if (istat == 0) then - deallocate(order) - end if - ! - ! -- return - return - end subroutine sfr_read_connectiondata + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA' - !> @ brief Read diversions for the package - !! - !! Method to read diversions for the SFR package. - !! - !< - subroutine sfr_read_diversions(this) - ! -- modules - use MemoryManagerModule, only: mem_reallocate - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - character (len=10) :: cnum - character (len=10) :: cval - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: ierr - integer(I4B) :: ival - integer(I4B) :: i0 - integer(I4B) :: ipos - integer(I4B) :: jpos - integer(I4B) :: ndiv - integer(I4B) :: ndiversions - integer(I4B) :: idivreach - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - integer(I4B) :: idiv - integer, allocatable, dimension(:) :: iachk - integer, allocatable, dimension(:) :: nboundchk - ! - ! -- determine the total number of diversions and fill iadiv - ndiversions = 0 - i0 = 1 - this%iadiv(1) = i0 do n = 1, this%maxbound - ndiversions = ndiversions + this%ndiv(n) - i0 = i0 + this%ndiv(n) - this%iadiv(n+1) = i0 + ! + ! -- check for missing or duplicate sfr connections + if (nboundchk(n) == 0) then + write (errmsg, '(a,1x,i0)') & + 'No connection data specified for reach', n + call store_error(errmsg) + else if (nboundchk(n) > 1) then + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & + 'Connection data for reach', n, & + 'specified', nboundchk(n), 'times.' + call store_error(errmsg) + end if + end do + else + call store_error('Required connectiondata block not found.') + end if + ! + ! -- terminate if errors encountered in connectiondata block + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- create ia and ja from sparse + call sparse%filliaja(this%ia, this%ja, ierr, sort=.TRUE.) + ! + ! -- test for error condition + if (ierr /= 0) then + write (errmsg, '(a,3(1x,a))') & + 'Could not fill', trim(this%packName), & + 'package IA and JA connection data.', & + 'Check connectivity data in connectiondata block.' + call store_error(errmsg) + end if + ! + ! -- fill flat connection storage + do n = 1, this%maxbound + do j = this%ia(n) + 1, this%ia(n + 1) - 1 + jcol = this%ja(j) + do jj = 1, this%nconnreach(n) + jcol2 = iconndata(jj, n) + if (abs(jcol2) == jcol) then + idir = 1 + if (jcol2 < 0) then + idir = -1 + end if + this%idir(j) = idir + exit + end if + end do + end do + end do + ! + ! -- deallocate temporary local storage for reach connections + deallocate (rowmaxnnz) + deallocate (nboundchk) + deallocate (iconndata) + ! + ! -- destroy sparse + call sparse%destroy() + deallocate (sparse) + ! + ! -- calculate reach order using DAG + ! + ! -- initialize the DAG + call sfr_dag%set_vertices(this%maxbound) + ! + ! -- fill DAG + fill_dag: do n = 1, this%maxbound + ! + ! -- determine the number of upstream reaches + nup = 0 + do j = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(j) > 0) then + nup = nup + 1 + end if end do ! - ! -- reallocate memory for diversions - if (ndiversions > 0) then - call mem_reallocate(this%divreach, ndiversions, 'DIVREACH', this%memoryPath) - allocate(this%divcprior(ndiversions)) - call mem_reallocate(this%divflow, ndiversions, 'DIVFLOW', this%memoryPath) - call mem_reallocate(this%divq, ndiversions, 'DIVQ', this%memoryPath) - end if + ! -- cycle if nu upstream reacches + if (nup == 0) cycle fill_dag ! - ! -- inititialize diversion flow - do n = 1, ndiversions - this%divflow(n) = DZERO - this%divq(n) = DZERO + ! -- allocate local storage + allocate (iup(nup)) + ! + ! -- fill local storage + ipos = 1 + do j = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(j) > 0) then + iup(ipos) = this%ja(j) + ipos = ipos + 1 + end if end do ! - ! -- read diversions - call this%parser%GetBlock('DIVERSIONS', isfound, ierr, & - supportOpenClose=.true., & - blockRequired=.false.) + ! -- add upstream connections to DAG + call sfr_dag%set_edges(n, iup) ! - ! -- parse reach connectivity block if detected - if (isfound) then - if (this%idiversions /= 0) then - write(this%iout,'(/1x,a)') 'PROCESSING ' // trim(adjustl(this%text)) // & - ' DIVERSIONS' - ! - ! -- allocate and initialize local variables for diversions - ndiv = 0 - do n = 1, this%maxbound - ndiv = ndiv + this%ndiv(n) - end do - allocate(iachk(this%maxbound+1)) - allocate(nboundchk(ndiv)) - iachk(1) = 1 - do n = 1, this%maxbound - iachk(n+1) = iachk(n) + this%ndiv(n) - end do - do n = 1, ndiv - nboundchk(n) = 0 - end do - ! - ! -- read diversion data - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! - ! -- get reach number - n = this%parser%GetInteger() - if (n < 1 .or. n > this%maxbound) then - write(cnum, '(i0)') n - errmsg = 'Reach number should be between 1 and ' // & - trim(cnum) // '.' - call store_error(errmsg) - cycle - end if - ! - ! -- make sure reach has at least one diversion - if (this%ndiv(n) < 1) then - write(cnum, '(i0)') n - errmsg = 'Diversions cannot be specified ' // & - 'for reach ' // trim(cnum) - call store_error(errmsg) - cycle - end if - ! - ! -- read diversion number - ival = this%parser%GetInteger() - if (ival < 1 .or. ival > this%ndiv(n)) then - write(cnum, '(i0)') n - errmsg = 'Reach ' // trim(cnum) - write(cnum, '(i0)') this%ndiv(n) - errmsg = trim(errmsg) // ' diversion number should be between ' // & - '1 and ' // trim(cnum) // '.' - call store_error(errmsg) - cycle - end if - - ! -- increment nboundchk - ipos = iachk(n) + ival - 1 - nboundchk(ipos) = nboundchk(ipos) + 1 - - idiv = ival - ! - ! -- get target reach for diversion - ival = this%parser%GetInteger() - if (ival < 1 .or. ival > this%maxbound) then - write(cnum, '(i0)') ival - errmsg = 'Diversion target reach number should be ' // & - 'between 1 and ' // trim(cnum) // '.' - call store_error(errmsg) - cycle - end if - idivreach = ival - jpos = this%iadiv(n) + idiv - 1 - this%divreach(jpos) = idivreach - ! - ! -- get cprior - call this%parser%GetStringCaps(cval) - ival = -1 - select case (cval) - case('UPTO') - ival = 0 - case('THRESHOLD') - ival = -1 - case('FRACTION') - ival = -2 - case('EXCESS') - ival = -3 - case default - errmsg = 'Invalid cprior type ' // trim(cval) // '.' - call store_error(errmsg) - end select - ! - ! -- set cprior for diversion - this%divcprior(jpos) = cval - end do - - write(this%iout,'(1x,a)') 'END OF ' // trim(adjustl(this%text)) // & - ' DIVERSIONS' - - do n = 1, this%maxbound - do j = 1, this%ndiv(n) - ipos = iachk(n) + j - 1 - ! - ! -- check for missing or duplicate reach diversions - if (nboundchk(ipos) == 0) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0)') & - 'No data specified for reach', n, 'diversion', j - call store_error(errmsg) - else if (nboundchk(ipos) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & - 'Data for reach', n, 'diversion', j, & - 'specified', nboundchk(ipos), 'times' - call store_error(errmsg) - end if - end do - end do - ! - ! -- deallocate local variables - deallocate(iachk) - deallocate(nboundchk) - else - ! - ! -- error condition - write(errmsg,'(a,1x,a)') & - 'A diversions block should not be', & - 'specified if diversions are not specified.' - call store_error(errmsg) - end if + ! -- clean up local storage + deallocate (iup) + end do fill_dag + ! + ! -- perform toposort on DAG + call sfr_dag%toposort(order, istat) + ! + ! -- write warning if circular dependency + if (istat == -1) then + write (warnmsg, '(a)') & + trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') cannot calculate a '// & + 'Directed Asyclic Graph for reach connectivity because '// & + 'of circular dependency. Using the reach number for '// & + 'solution ordering.' + call store_warning(warnmsg) + end if + ! + ! -- fill isfrorder + do n = 1, this%maxbound + if (istat == 0) then + this%isfrorder(n) = order(n) else - if (this%idiversions /= 0) then - call store_error('REQUIRED DIVERSIONS BLOCK NOT FOUND.') - end if + this%isfrorder(n) = n end if - ! - ! -- write summary of diversion error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- return - return - end subroutine sfr_read_diversions - + end do + ! + ! -- clean up DAG and remaining local storage + call sfr_dag%destroy() + if (istat == 0) then + deallocate (order) + end if + ! + ! -- return + return + end subroutine sfr_read_connectiondata - !> @ brief Read and prepare period data for package + !> @ brief Read diversions for the package !! - !! Method to read and prepare period data for the SFR package. + !! Method to read diversions for the SFR package. !! - !< - subroutine sfr_rp(this) - ! -- modules - use TdisModule, only: kper, nper - use MemoryManagerModule, only: mem_reallocate - use sfrCrossSectionManager, only: cross_section_cr, SfrCrossSection - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: crossfile - integer(I4B) :: ierr - integer(I4B) :: n - integer(I4B) :: ichkustrm - integer(I4B) :: ichkcross - integer(I4B) :: ncrossptstot - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - type(SfrCrossSection), pointer :: cross_data => null() - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - & "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'The number of active ',A,'S (',I6, & - & ') is greater than maximum (',I6,')')" - ! - ! -- initialize flags - ichkustrm = 0 - ichkcross = 0 - if (kper == 1) then - ichkustrm = 1 - end if - ! - ! -- set nbound to maxbound - this%nbound = this%maxbound - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if (this%ionper < kper) then - ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if(isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() - else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - endif - end if - ! - ! -- Read data if ionper == kper - if(this%ionper==kper) then - ! - ! -- create and initialize cross-section data - call cross_section_cr(cross_data, this%iout, this%iprpak, this%maxbound) - call cross_data%initialize(this%ncrossptstot, this%ncrosspts, & - this%iacross, & - this%station, this%xsheight, & - this%xsrough) + !< + subroutine sfr_read_diversions(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + character(len=10) :: cnum + character(len=10) :: cval + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: ierr + integer(I4B) :: ival + integer(I4B) :: i0 + integer(I4B) :: ipos + integer(I4B) :: jpos + integer(I4B) :: ndiv + integer(I4B) :: ndiversions + integer(I4B) :: idivreach + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + integer(I4B) :: idiv + integer, allocatable, dimension(:) :: iachk + integer, allocatable, dimension(:) :: nboundchk + ! + ! -- determine the total number of diversions and fill iadiv + ndiversions = 0 + i0 = 1 + this%iadiv(1) = i0 + do n = 1, this%maxbound + ndiversions = ndiversions + this%ndiv(n) + i0 = i0 + this%ndiv(n) + this%iadiv(n + 1) = i0 + end do + ! + ! -- reallocate memory for diversions + if (ndiversions > 0) then + call mem_reallocate(this%divreach, ndiversions, 'DIVREACH', & + this%memoryPath) + allocate (this%divcprior(ndiversions)) + call mem_reallocate(this%divflow, ndiversions, 'DIVFLOW', this%memoryPath) + call mem_reallocate(this%divq, ndiversions, 'DIVQ', this%memoryPath) + end if + ! + ! -- inititialize diversion flow + do n = 1, ndiversions + this%divflow(n) = DZERO + this%divq(n) = DZERO + end do + ! + ! -- read diversions + call this%parser%GetBlock('DIVERSIONS', isfound, ierr, & + supportOpenClose=.true., & + blockRequired=.false.) + ! + ! -- parse reach connectivity block if detected + if (isfound) then + if (this%idiversions /= 0) then + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & + ' DIVERSIONS' ! - ! -- setup table for period data - if (this%iprpak /= 0) then - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(1, 4, this%iout, finalize=.FALSE.) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'KEYWORD' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - do n = 1, 2 - write(text, '(a,1x,i6)') 'VALUE', n - call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) - end do - end if + ! -- allocate and initialize local variables for diversions + ndiv = 0 + do n = 1, this%maxbound + ndiv = ndiv + this%ndiv(n) + end do + allocate (iachk(this%maxbound + 1)) + allocate (nboundchk(ndiv)) + iachk(1) = 1 + do n = 1, this%maxbound + iachk(n + 1) = iachk(n) + this%ndiv(n) + end do + do n = 1, ndiv + nboundchk(n) = 0 + end do ! - ! -- read data + ! -- read diversion data do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit + ! + ! -- get reach number n = this%parser%GetInteger() if (n < 1 .or. n > this%maxbound) then - write(errmsg,'(a,1x,a,1x,i0,a)') & - 'Reach number (RNO) must be greater than 0 and', & - 'less than or equal to', this%maxbound, '.' + write (cnum, '(i0)') n + errmsg = 'Reach number should be between 1 and '// & + trim(cnum)//'.' call store_error(errmsg) cycle end if ! - ! -- read data from the rest of the line - call this%sfr_set_stressperiod(n, ichkustrm, crossfile) + ! -- make sure reach has at least one diversion + if (this%ndiv(n) < 1) then + write (cnum, '(i0)') n + errmsg = 'Diversions cannot be specified '// & + 'for reach '//trim(cnum) + call store_error(errmsg) + cycle + end if ! - ! -- write line to table - if (this%iprpak /= 0) then - call this%parser%GetCurrentLine(line) - call this%inputtab%line_to_columns(line) + ! -- read diversion number + ival = this%parser%GetInteger() + if (ival < 1 .or. ival > this%ndiv(n)) then + write (cnum, '(i0)') n + errmsg = 'Reach '//trim(cnum) + write (cnum, '(i0)') this%ndiv(n) + errmsg = trim(errmsg)//' diversion number should be between '// & + '1 and '//trim(cnum)//'.' + call store_error(errmsg) + cycle end if + + ! -- increment nboundchk + ipos = iachk(n) + ival - 1 + nboundchk(ipos) = nboundchk(ipos) + 1 + + idiv = ival ! - ! -- process cross-section file - if (trim(adjustl(crossfile)) /= 'NONE') then - call cross_data%read_table(n, this%width(n), & - trim(adjustl(crossfile))) + ! -- get target reach for diversion + ival = this%parser%GetInteger() + if (ival < 1 .or. ival > this%maxbound) then + write (cnum, '(i0)') ival + errmsg = 'Diversion target reach number should be '// & + 'between 1 and '//trim(cnum)//'.' + call store_error(errmsg) + cycle end if + idivreach = ival + jpos = this%iadiv(n) + idiv - 1 + this%divreach(jpos) = idivreach + ! + ! -- get cprior + call this%parser%GetStringCaps(cval) + ival = -1 + select case (cval) + case ('UPTO') + ival = 0 + case ('THRESHOLD') + ival = -1 + case ('FRACTION') + ival = -2 + case ('EXCESS') + ival = -3 + case default + errmsg = 'Invalid cprior type '//trim(cval)//'.' + call store_error(errmsg) + end select + ! + ! -- set cprior for diversion + this%divcprior(jpos) = cval + end do + + write (this%iout, '(1x,a)') 'END OF '//trim(adjustl(this%text))// & + ' DIVERSIONS' + + do n = 1, this%maxbound + do j = 1, this%ndiv(n) + ipos = iachk(n) + j - 1 + ! + ! -- check for missing or duplicate reach diversions + if (nboundchk(ipos) == 0) then + write (errmsg, '(a,1x,i0,1x,a,1x,i0)') & + 'No data specified for reach', n, 'diversion', j + call store_error(errmsg) + else if (nboundchk(ipos) > 1) then + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & + 'Data for reach', n, 'diversion', j, & + 'specified', nboundchk(ipos), 'times' + call store_error(errmsg) + end if + end do end do ! - ! -- write raw period data - if (this%iprpak /= 0) then - call this%inputtab%finalize_table() - end if + ! -- deallocate local variables + deallocate (iachk) + deallocate (nboundchk) + else + ! + ! -- error condition + write (errmsg, '(a,1x,a)') & + 'A diversions block should not be', & + 'specified if diversions are not specified.' + call store_error(errmsg) + end if + else + if (this%idiversions /= 0) then + call store_error('REQUIRED DIVERSIONS BLOCK NOT FOUND.') + end if + end if + ! + ! -- write summary of diversion error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- return + return + end subroutine sfr_read_diversions + + !> @ brief Read and prepare period data for package + !! + !! Method to read and prepare period data for the SFR package. + !! + !< + subroutine sfr_rp(this) + ! -- modules + use TdisModule, only: kper, nper + use MemoryManagerModule, only: mem_reallocate + use sfrCrossSectionManager, only: cross_section_cr, SfrCrossSection + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: crossfile + integer(I4B) :: ierr + integer(I4B) :: n + integer(I4B) :: ichkustrm + integer(I4B) :: ichkcross + integer(I4B) :: ncrossptstot + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + type(SfrCrossSection), pointer :: cross_data => null() + ! -- formats + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'The number of active ',A,'S (',I6, & + &') is greater than maximum (',I6,')')" + ! + ! -- initialize flags + ichkustrm = 0 + ichkcross = 0 + if (kper == 1) then + ichkustrm = 1 + end if + ! + ! -- set nbound to maxbound + this%nbound = this%maxbound + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if (this%ionper < kper) then + ! + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then ! - ! -- finalize cross-sections - + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else ! - ! -- determine the current size of cross-section data - ncrossptstot = cross_data%get_ncrossptstot() + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 + else + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write (errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + end if + end if + ! + ! -- Read data if ionper == kper + if (this%ionper == kper) then + ! + ! -- create and initialize cross-section data + call cross_section_cr(cross_data, this%iout, this%iprpak, this%maxbound) + call cross_data%initialize(this%ncrossptstot, this%ncrosspts, & + this%iacross, & + this%station, this%xsheight, & + this%xsrough) + ! + ! -- setup table for period data + if (this%iprpak /= 0) then ! - ! -- reallocate sfr package cross-section data - if (ncrossptstot /= this%ncrossptstot) then - this%ncrossptstot = ncrossptstot - call mem_reallocate(this%station, this%ncrossptstot, 'STATION', this%memoryPath) - call mem_reallocate(this%xsheight, this%ncrossptstot, 'XSHEIGHT', this%memoryPath) - call mem_reallocate(this%xsrough, this%ncrossptstot, 'XSROUGH', this%memoryPath) + ! -- reset the input table object + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') DATA FOR PERIOD' + write (title, '(a,1x,i6)') trim(adjustl(title)), kper + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(1, 4, this%iout, finalize=.FALSE.) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'KEYWORD' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + do n = 1, 2 + write (text, '(a,1x,i6)') 'VALUE', n + call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) + end do + end if + ! + ! -- read data + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + n = this%parser%GetInteger() + if (n < 1 .or. n > this%maxbound) then + write (errmsg, '(a,1x,a,1x,i0,a)') & + 'Reach number (RNO) must be greater than 0 and', & + 'less than or equal to', this%maxbound, '.' + call store_error(errmsg) + cycle end if ! - ! -- write cross-section data to the model listing file - call cross_data%output(this%width, this%rough, kstp=1, kper=kper) + ! -- read data from the rest of the line + call this%sfr_set_stressperiod(n, ichkustrm, crossfile) ! - ! -- pack cross-section data - call cross_data%pack(this%ncrossptstot, this%ncrosspts, & - this%iacross, & - this%station, & - this%xsheight, & - this%xsrough) + ! -- write line to table + if (this%iprpak /= 0) then + call this%parser%GetCurrentLine(line) + call this%inputtab%line_to_columns(line) + end if ! - ! -- deallocate temporary local storage for reach cross-sections - call cross_data%destroy() - deallocate(cross_data) - nullify(cross_data) - ! - ! -- Reuse data from last stress period - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif + ! -- process cross-section file + if (trim(adjustl(crossfile)) /= 'NONE') then + call cross_data%read_table(n, this%width(n), & + trim(adjustl(crossfile))) + end if + end do ! - ! -- check upstream fraction values - if (ichkustrm /= 0) then - call this%sfr_check_ustrf() + ! -- write raw period data + if (this%iprpak /= 0) then + call this%inputtab%finalize_table() end if ! - ! -- write summary of package block error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- finalize cross-sections + + ! + ! -- determine the current size of cross-section data + ncrossptstot = cross_data%get_ncrossptstot() + ! + ! -- reallocate sfr package cross-section data + if (ncrossptstot /= this%ncrossptstot) then + this%ncrossptstot = ncrossptstot + call mem_reallocate(this%station, this%ncrossptstot, 'STATION', & + this%memoryPath) + call mem_reallocate(this%xsheight, this%ncrossptstot, 'XSHEIGHT', & + this%memoryPath) + call mem_reallocate(this%xsrough, this%ncrossptstot, 'XSROUGH', & + this%memoryPath) end if ! - ! -- return - return - end subroutine sfr_rp + ! -- write cross-section data to the model listing file + call cross_data%output(this%width, this%rough, kstp=1, kper=kper) + ! + ! -- pack cross-section data + call cross_data%pack(this%ncrossptstot, this%ncrosspts, & + this%iacross, & + this%station, & + this%xsheight, & + this%xsrough) + ! + ! -- deallocate temporary local storage for reach cross-sections + call cross_data%destroy() + deallocate (cross_data) + nullify (cross_data) + ! + ! -- Reuse data from last stress period + else + write (this%iout, fmtlsp) trim(this%filtyp) + end if + ! + ! -- check upstream fraction values + if (ichkustrm /= 0) then + call this%sfr_check_ustrf() + end if + ! + ! -- write summary of package block error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- return + return + end subroutine sfr_rp - !> @ brief Advance the package + !> @ brief Advance the package !! !! Advance data in the SFR package. The method sets advances !! time series, time array series, and observation data. !! - !< - subroutine sfr_ad(this) - ! -- modules - use TimeSeriesManagerModule, only: var_timeseries - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - integer(I4B) :: n - integer(I4B) :: iaux - ! - ! -- Most advanced package AD routines have to restore state if - ! the solution failed and the time step is being retried with a smaller - ! step size. This is not needed here because there is no old stage - ! or storage effects in the stream. - ! - ! -- Advance the time series manager - call this%TsManager%ad() - ! - ! -- check upstream fractions if time series are being used to - ! define this variable - if (var_timeseries(this%tsManager, this%packName, 'USTRF')) then - call this%sfr_check_ustrf() - end if - ! - ! -- update auxiliary variables by copying from the derived-type time - ! series variable into the bndpackage auxvar variable so that this - ! information is properly written to the GWF budget file - if (this%naux > 0) then - do n = 1, this%maxbound - do iaux = 1, this%naux - if (this%noupdateauxvar(iaux) /= 0) cycle - this%auxvar(iaux, n) = this%rauxvar(iaux, n) - end do - end do - end if - ! - ! -- reset upstream flow to zero and set specified stage + !< + subroutine sfr_ad(this) + ! -- modules + use TimeSeriesManagerModule, only: var_timeseries + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + integer(I4B) :: n + integer(I4B) :: iaux + ! + ! -- Most advanced package AD routines have to restore state if + ! the solution failed and the time step is being retried with a smaller + ! step size. This is not needed here because there is no old stage + ! or storage effects in the stream. + ! + ! -- Advance the time series manager + call this%TsManager%ad() + ! + ! -- check upstream fractions if time series are being used to + ! define this variable + if (var_timeseries(this%tsManager, this%packName, 'USTRF')) then + call this%sfr_check_ustrf() + end if + ! + ! -- update auxiliary variables by copying from the derived-type time + ! series variable into the bndpackage auxvar variable so that this + ! information is properly written to the GWF budget file + if (this%naux > 0) then do n = 1, this%maxbound - this%usflow(n) = DZERO - if (this%iboundpak(n) < 0) then - this%stage(n) = this%sstage(n) - end if + do iaux = 1, this%naux + if (this%noupdateauxvar(iaux) /= 0) cycle + this%auxvar(iaux, n) = this%rauxvar(iaux, n) + end do end do - ! - ! -- pakmvrobj ad - if(this%imover == 1) then - call this%pakmvrobj%ad() - endif - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - ! -- return - return - end subroutine sfr_ad + end if + ! + ! -- reset upstream flow to zero and set specified stage + do n = 1, this%maxbound + this%usflow(n) = DZERO + if (this%iboundpak(n) < 0) then + this%stage(n) = this%sstage(n) + end if + end do + ! + ! -- pakmvrobj ad + if (this%imover == 1) then + call this%pakmvrobj%ad() + end if + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine sfr_ad - !> @ brief Formulate the package hcof and rhs terms. + !> @ brief Formulate the package hcof and rhs terms. !! !! Formulate the hcof and rhs terms for the WEL package that will be !! added to the coefficient matrix and right-hand side vector. !! - !< - subroutine sfr_cf(this, reset_mover) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover - ! -- local variables - integer(I4B) :: n - integer(I4B) :: igwfnode - logical(LGP) :: lrm - ! - ! -- return if no sfr reaches - if(this%nbound == 0) return - ! - ! -- find highest active cell - do n = 1, this%nbound - igwfnode = this%igwftopnode(n) - if (igwfnode > 0) then - if (this%ibound(igwfnode) == 0) then - call this%dis%highest_active(igwfnode, this%ibound) - end if + !< + subroutine sfr_cf(this, reset_mover) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover + ! -- local variables + integer(I4B) :: n + integer(I4B) :: igwfnode + logical(LGP) :: lrm + ! + ! -- return if no sfr reaches + if (this%nbound == 0) return + ! + ! -- find highest active cell + do n = 1, this%nbound + igwfnode = this%igwftopnode(n) + if (igwfnode > 0) then + if (this%ibound(igwfnode) == 0) then + call this%dis%highest_active(igwfnode, this%ibound) end if - this%igwfnode(n) = igwfnode - this%nodelist(n) = igwfnode - end do - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- return - return - end subroutine sfr_cf + end if + this%igwfnode(n) = igwfnode + this%nodelist(n) = igwfnode + end do + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if (this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + end if + ! + ! -- return + return + end subroutine sfr_cf - !> @ brief Copy hcof and rhs terms into solution. + !> @ brief Copy hcof and rhs terms into solution. !! - !! Add the hcof and rhs terms for the SFR package to the + !! Add the hcof and rhs terms for the SFR package to the !! coefficient matrix and right-hand side vector. !! - !< - subroutine sfr_fc(this, rhs, ia, idxglo, amatsln) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: ipos - integer(I4B) :: node - real(DP) :: s0 - real(DP) :: ds - real(DP) :: dsmax - real(DP) :: hgwf - real(DP) :: v - real(DP) :: hhcof - real(DP) :: rrhs + !< + subroutine sfr_fc(this, rhs, ia, idxglo, amatsln) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: ipos + integer(I4B) :: node + real(DP) :: s0 + real(DP) :: ds + real(DP) :: dsmax + real(DP) :: hgwf + real(DP) :: v + real(DP) :: hhcof + real(DP) :: rrhs + ! + ! -- picard iterations for sfr to achieve good solution regardless + ! of reach order + sfrpicard: do i = 1, this%maxsfrpicard + ! + ! -- initialize maximum stage change for iteration to zero + dsmax = DZERO + ! + ! -- pakmvrobj fc - reset qformvr to zero + if (this%imover == 1) then + call this%pakmvrobj%fc() + end if ! - ! -- picard iterations for sfr to achieve good solution regardless - ! of reach order - sfrpicard: do i = 1, this%maxsfrpicard + ! -- solve for each sfr reach + reachsolve: do j = 1, this%nbound + n = this%isfrorder(j) + node = this%igwfnode(n) + if (node > 0) then + hgwf = this%xnew(node) + else + hgwf = DEP20 + end if ! - ! -- initialize maximum stage change for iteration to zero - dsmax = DZERO + ! -- save previous stage and upstream flow + if (i == 1) then + this%stage0(n) = this%stage(n) + this%usflow0(n) = this%usflow(n) + end if ! - ! -- pakmvrobj fc - reset qformvr to zero - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif + ! -- set initial stage to calculate stage change + s0 = this%stage(n) ! - ! -- solve for each sfr reach - reachsolve: do j = 1, this%nbound - n = this%isfrorder(j) - node = this%igwfnode(n) - if (node > 0) then - hgwf = this%xnew(node) - else - hgwf = DEP20 - end if - ! - ! -- save previous stage and upstream flow - if (i == 1) then - this%stage0(n) = this%stage(n) - this%usflow0(n) = this%usflow(n) - end if - ! - ! -- set initial stage to calculate stage change - s0 = this%stage(n) - ! - ! -- solve for flow in swr - if (this%iboundpak(n) /= 0) then - call this%sfr_solve(n, hgwf, hhcof, rrhs) - else - this%depth(n) = DZERO - this%stage(n) = this%strtop(n) - v = DZERO - call this%sfr_update_flows(n, v, v) - hhcof = DZERO - rrhs = DZERO - end if - ! - ! -- set package hcof and rhs - this%hcof(n) = hhcof - this%rhs(n) = rrhs - ! - ! -- calculate stage change - ds = s0 - this%stage(n) - ! - ! -- evaluate if stage change exceeds dsmax - if (abs(ds) > abs(dsmax)) then - dsmax = ds - end if - - end do reachsolve + ! -- solve for flow in swr + if (this%iboundpak(n) /= 0) then + call this%sfr_solve(n, hgwf, hhcof, rrhs) + else + this%depth(n) = DZERO + this%stage(n) = this%strtop(n) + v = DZERO + call this%sfr_update_flows(n, v, v) + hhcof = DZERO + rrhs = DZERO + end if + ! + ! -- set package hcof and rhs + this%hcof(n) = hhcof + this%rhs(n) = rrhs ! - ! -- evaluate if the sfr picard iterations should be terminated - if (abs(dsmax) <= this%dmaxchg) then - exit sfrpicard + ! -- calculate stage change + ds = s0 - this%stage(n) + ! + ! -- evaluate if stage change exceeds dsmax + if (abs(ds) > abs(dsmax)) then + dsmax = ds end if - - end do sfrpicard - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do n = 1, this%nbound - node = this%nodelist(n) - if (node < 1) cycle - rhs(node) = rhs(node) + this%rhs(n) - ipos = ia(node) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(n) - end do + + end do reachsolve ! - ! -- return - return - end subroutine sfr_fc + ! -- evaluate if the sfr picard iterations should be terminated + if (abs(dsmax) <= this%dmaxchg) then + exit sfrpicard + end if + + end do sfrpicard + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do n = 1, this%nbound + node = this%nodelist(n) + if (node < 1) cycle + rhs(node) = rhs(node) + this%rhs(n) + ipos = ia(node) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(n) + end do + ! + ! -- return + return + end subroutine sfr_fc - !> @ brief Add Newton-Raphson terms for package into solution. + !> @ brief Add Newton-Raphson terms for package into solution. !! - !! Calculate and add the Newton-Raphson terms for the SFR package to the + !! Calculate and add the Newton-Raphson terms for the SFR package to the !! coefficient matrix and right-hand side vector. !! - !< - subroutine sfr_fn(this, rhs, ia, idxglo, amatsln) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n - integer(I4B) :: ipos - real(DP) :: rterm - real(DP) :: drterm - real(DP) :: rhs1 - real(DP) :: hcof1 - real(DP) :: q1 - real(DP) :: q2 - real(DP) :: hgwf - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do j = 1, this%nbound - i = this%isfrorder(j) - ! -- skip inactive reaches - if (this%iboundpak(i) < 1) cycle - ! -- skip if reach is not connected to gwf - n = this%nodelist(i) - if (n < 1) cycle - ipos = ia(n) - rterm = this%hcof(i) * this%xnew(n) - ! -- calculate perturbed head - hgwf = this%xnew(n) + DEM4 - call this%sfr_solve(i, hgwf, hcof1, rhs1, update=.false.) - q1 = rhs1 - hcof1 * hgwf - ! -- calculate unperturbed head - q2 = this%rhs(i) - this%hcof(i) * this%xnew(n) - ! -- calculate derivative - drterm = (q2 - q1) / DEM4 - ! -- add terms to convert conductance formulation into - ! newton-raphson formulation - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(i) - rhs(n) = rhs(n) - rterm + drterm * this%xnew(n) - end do - ! - ! -- return - return - end subroutine sfr_fn + !< + subroutine sfr_fn(this, rhs, ia, idxglo, amatsln) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n + integer(I4B) :: ipos + real(DP) :: rterm + real(DP) :: drterm + real(DP) :: rhs1 + real(DP) :: hcof1 + real(DP) :: q1 + real(DP) :: q2 + real(DP) :: hgwf + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do j = 1, this%nbound + i = this%isfrorder(j) + ! -- skip inactive reaches + if (this%iboundpak(i) < 1) cycle + ! -- skip if reach is not connected to gwf + n = this%nodelist(i) + if (n < 1) cycle + ipos = ia(n) + rterm = this%hcof(i) * this%xnew(n) + ! -- calculate perturbed head + hgwf = this%xnew(n) + DEM4 + call this%sfr_solve(i, hgwf, hcof1, rhs1, update=.false.) + q1 = rhs1 - hcof1 * hgwf + ! -- calculate unperturbed head + q2 = this%rhs(i) - this%hcof(i) * this%xnew(n) + ! -- calculate derivative + drterm = (q2 - q1) / DEM4 + ! -- add terms to convert conductance formulation into + ! newton-raphson formulation + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(i) + rhs(n) = rhs(n) - rterm + drterm * this%xnew(n) + end do + ! + ! -- return + return + end subroutine sfr_fn - !> @ brief Convergence check for package. + !> @ brief Convergence check for package. !! !! Perform additional convergence checks on the flow between the SFR package !! and the model it is attached to. !! - !< - subroutine sfr_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) - ! -- modules - use TdisModule, only: totim, kstp, kper, delt - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - integer(I4B), intent(in) :: innertot !< total number of inner iterations - integer(I4B), intent(in) :: kiter !< Picard iteration number - integer(I4B), intent(in) :: iend !< flag indicating if this is the last Picard iteration - integer(I4B), intent(in) :: icnvgmod !< flag inficating if the model has met specific convergence criteria - character(len=LENPAKLOC), intent(inout) :: cpak !< string for user node - integer(I4B), intent(inout) :: ipak !< location of the maximum dependent variable change - real(DP), intent(inout) :: dpak !< maximum dependent variable change - ! -- local variables - character(len=LENPAKLOC) :: cloc - character(len=LINELENGTH) :: tag - integer(I4B) :: icheck - integer(I4B) :: ipakfail - integer(I4B) :: locdhmax - integer(I4B) :: locrmax - integer(I4B) :: ntabrows - integer(I4B) :: ntabcols - integer(I4B) :: n - real(DP) :: dh - real(DP) :: r - real(DP) :: dhmax - real(DP) :: rmax - ! - ! -- initialize local variables - icheck = this%iconvchk - ipakfail = 0 - locdhmax = 0 - locrmax = 0 - r = DZERO - dhmax = DZERO - rmax = DZERO - ! - ! -- if not saving package convergence data on check convergence if - ! the model is considered converged - if (this%ipakcsv == 0) then - if (icnvgmod == 0) then - icheck = 0 - end if + !< + subroutine sfr_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) + ! -- modules + use TdisModule, only: totim, kstp, kper, delt + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + integer(I4B), intent(in) :: innertot !< total number of inner iterations + integer(I4B), intent(in) :: kiter !< Picard iteration number + integer(I4B), intent(in) :: iend !< flag indicating if this is the last Picard iteration + integer(I4B), intent(in) :: icnvgmod !< flag inficating if the model has met specific convergence criteria + character(len=LENPAKLOC), intent(inout) :: cpak !< string for user node + integer(I4B), intent(inout) :: ipak !< location of the maximum dependent variable change + real(DP), intent(inout) :: dpak !< maximum dependent variable change + ! -- local variables + character(len=LENPAKLOC) :: cloc + character(len=LINELENGTH) :: tag + integer(I4B) :: icheck + integer(I4B) :: ipakfail + integer(I4B) :: locdhmax + integer(I4B) :: locrmax + integer(I4B) :: ntabrows + integer(I4B) :: ntabcols + integer(I4B) :: n + real(DP) :: dh + real(DP) :: r + real(DP) :: dhmax + real(DP) :: rmax + ! + ! -- initialize local variables + icheck = this%iconvchk + ipakfail = 0 + locdhmax = 0 + locrmax = 0 + r = DZERO + dhmax = DZERO + rmax = DZERO + ! + ! -- if not saving package convergence data on check convergence if + ! the model is considered converged + if (this%ipakcsv == 0) then + if (icnvgmod == 0) then + icheck = 0 + end if ! ! -- saving package convergence data - else + else + ! + ! -- header for package csv + if (.not. associated(this%pakcsvtab)) then ! - ! -- header for package csv - if (.not. associated(this%pakcsvtab)) then - ! - ! -- determine the number of columns and rows - ntabrows = 1 - ntabcols = 9 - ! - ! -- setup table - call table_cr(this%pakcsvtab, this%packName, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & - finalize=.FALSE.) - ! - ! -- add columns to package csv - tag = 'total_inner_iterations' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'totim' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kper' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'kstp' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'nouter' - call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) - tag = 'dvmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dvmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dinflowmax' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - tag = 'dinflowmax_loc' - call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) - end if + ! -- determine the number of columns and rows + ntabrows = 1 + ntabcols = 9 + ! + ! -- setup table + call table_cr(this%pakcsvtab, this%packName, '') + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & + finalize=.FALSE.) + ! + ! -- add columns to package csv + tag = 'total_inner_iterations' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'totim' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kper' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'kstp' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'nouter' + call this%pakcsvtab%initialize_column(tag, 10, alignment=TABLEFT) + tag = 'dvmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dvmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dinflowmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dinflowmax_loc' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) end if - ! - ! -- perform package convergence check - if (icheck /= 0) then - final_check: do n = 1, this%maxbound - if (this%iboundpak(n) == 0) cycle - dh = this%stage0(n) - this%stage(n) - ! - ! -- evaluate flow difference if the time step is transient - if (this%gwfiss == 0) then - r = this%usflow0(n) - this%usflow(n) - ! - ! -- normalize flow difference and convert to a depth - r = r * delt / this%calc_surface_area(n) - end if + end if + ! + ! -- perform package convergence check + if (icheck /= 0) then + final_check: do n = 1, this%maxbound + if (this%iboundpak(n) == 0) cycle + dh = this%stage0(n) - this%stage(n) + ! + ! -- evaluate flow difference if the time step is transient + if (this%gwfiss == 0) then + r = this%usflow0(n) - this%usflow(n) ! - ! -- evaluate magnitude of differences - if (n == 1) then + ! -- normalize flow difference and convert to a depth + r = r * delt / this%calc_surface_area(n) + end if + ! + ! -- evaluate magnitude of differences + if (n == 1) then + locdhmax = n + dhmax = dh + locrmax = n + rmax = r + else + if (abs(dh) > abs(dhmax)) then locdhmax = n dhmax = dh + end if + if (abs(r) > abs(rmax)) then locrmax = n rmax = r - else - if (abs(dh) > abs(dhmax)) then - locdhmax = n - dhmax = dh - end if - if (abs(r) > abs(rmax)) then - locrmax = n - rmax = r - end if - end if - end do final_check - ! - ! -- set dpak and cpak - if (ABS(dhmax) > abs(dpak)) then - ipak = locdhmax - dpak = dhmax - write(cloc, "(a,'-',a)") trim(this%packName), 'stage' - cpak = trim(cloc) - end if - if (ABS(rmax) > abs(dpak)) then - ipak = locrmax - dpak = rmax - write(cloc, "(a,'-',a)") trim(this%packName), 'inflow' - cpak = trim(cloc) - end if - ! - ! -- write convergence data to package csv - if (this%ipakcsv /= 0) then - ! - ! -- write the data - call this%pakcsvtab%add_term(innertot) - call this%pakcsvtab%add_term(totim) - call this%pakcsvtab%add_term(kper) - call this%pakcsvtab%add_term(kstp) - call this%pakcsvtab%add_term(kiter) - call this%pakcsvtab%add_term(dhmax) - call this%pakcsvtab%add_term(locdhmax) - call this%pakcsvtab%add_term(rmax) - call this%pakcsvtab%add_term(locrmax) - ! - ! -- finalize the package csv - if (iend == 1) then - call this%pakcsvtab%finalize_table() end if end if + end do final_check + ! + ! -- set dpak and cpak + if (ABS(dhmax) > abs(dpak)) then + ipak = locdhmax + dpak = dhmax + write (cloc, "(a,'-',a)") trim(this%packName), 'stage' + cpak = trim(cloc) + end if + if (ABS(rmax) > abs(dpak)) then + ipak = locrmax + dpak = rmax + write (cloc, "(a,'-',a)") trim(this%packName), 'inflow' + cpak = trim(cloc) end if ! - ! -- return - return - end subroutine sfr_cc - - !> @ brief Calculate package flows. - !! - !! Calculate the flow between connected SFR package control volumes. - !! - !< - subroutine sfr_cq(this, x, flowja, iadv) - ! -- modules - use InputOutputModule, only: ulasav, ubdsv06 - use BudgetModule, only: BudgetType - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - real(DP), dimension(:), intent(in) :: x !< current dependent-variable value - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes - integer(I4B), optional, intent(in) :: iadv !< flag that indicates if this is an advance package - ! -- local variables - integer(I4B) :: i - real(DP) :: qext - ! -- for budget - integer(I4B) :: n - real(DP) :: qoutflow - real(DP) :: qfrommvr - real(DP) :: qtomvr - ! - ! -- call base functionality in bnd_cq. This will calculate sfr-gwf flows - ! and put them into this%simvals - call this%BndType%bnd_cq(x, flowja, iadv=1) - ! - ! -- Calculate qextoutflow and qoutflow for subsequent budgets - do n = 1, this%maxbound - ! - ! -- mover - qfrommvr = DZERO - qtomvr = DZERO - if (this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - qtomvr = this%pakmvrobj%get_qtomvr(n) - if (qtomvr > DZERO) then - qtomvr = -qtomvr - end if - endif + ! -- write convergence data to package csv + if (this%ipakcsv /= 0) then ! - ! -- external downstream stream flow - qext = this%dsflow(n) - qoutflow = DZERO - if (qext > DZERO) then - qext = -qext - end if - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) cycle - qext = DZERO - exit - end do + ! -- write the data + call this%pakcsvtab%add_term(innertot) + call this%pakcsvtab%add_term(totim) + call this%pakcsvtab%add_term(kper) + call this%pakcsvtab%add_term(kstp) + call this%pakcsvtab%add_term(kiter) + call this%pakcsvtab%add_term(dhmax) + call this%pakcsvtab%add_term(locdhmax) + call this%pakcsvtab%add_term(rmax) + call this%pakcsvtab%add_term(locrmax) ! - ! -- adjust external downstream stream flow using qtomvr - if (qext < DZERO) then - if (qtomvr < DZERO) then - qext = qext - qtomvr - end if - else - qoutflow = this%dsflow(n) - if (qoutflow > DZERO) then - qoutflow = -qoutflow - end if + ! -- finalize the package csv + if (iend == 1) then + call this%pakcsvtab%finalize_table() end if - ! - ! -- set qextoutflow and qoutflow for cell by cell budget - ! output and observations - this%qextoutflow(n) = qext - this%qoutflow(n) = qoutflow - ! - end do - ! - ! -- fill the budget object - call this%sfr_fill_budobj() - ! - ! -- return - return - end subroutine sfr_cq + end if + end if + ! + ! -- return + return + end subroutine sfr_cc - !> @ brief Output package flow terms. + !> @ brief Calculate package flows. !! - !! Output SFR package flow terms. + !! Calculate the flow between connected SFR package control volumes. !! - !< - subroutine sfr_ot_package_flows(this, icbcfl, ibudfl) - ! -- modules - use TdisModule, only: kstp, kper, delt, pertim, totim - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output - integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved - ! -- local variables - integer(I4B) :: ibinun - character (len=20), dimension(:), allocatable :: cellidstr - integer(I4B) :: n - integer(I4B) :: node + !< + subroutine sfr_cq(this, x, flowja, iadv) + ! -- modules + use InputOutputModule, only: ulasav, ubdsv06 + use BudgetModule, only: BudgetType + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + real(DP), dimension(:), intent(in) :: x !< current dependent-variable value + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + integer(I4B), optional, intent(in) :: iadv !< flag that indicates if this is an advance package + ! -- local variables + integer(I4B) :: i + real(DP) :: qext + ! -- for budget + integer(I4B) :: n + real(DP) :: qoutflow + real(DP) :: qfrommvr + real(DP) :: qtomvr + ! + ! -- call base functionality in bnd_cq. This will calculate sfr-gwf flows + ! and put them into this%simvals + call this%BndType%bnd_cq(x, flowja, iadv=1) + ! + ! -- Calculate qextoutflow and qoutflow for subsequent budgets + do n = 1, this%maxbound ! - ! -- write the flows from the budobj - ibinun = 0 - if(this%ibudgetout /= 0) then - ibinun = this%ibudgetout + ! -- mover + qfrommvr = DZERO + qtomvr = DZERO + if (this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(n) + qtomvr = this%pakmvrobj%get_qtomvr(n) + if (qtomvr > DZERO) then + qtomvr = -qtomvr + end if end if - if(icbcfl == 0) ibinun = 0 - if (ibinun > 0) then - call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) + ! + ! -- external downstream stream flow + qext = this%dsflow(n) + qoutflow = DZERO + if (qext > DZERO) then + qext = -qext end if + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) cycle + qext = DZERO + exit + end do ! - ! -- Print lake flows table - if (ibudfl /= 0 .and. this%iprflow /= 0) then - ! - ! -- If there are any 'none' gwf connections then need to calculate - ! a vector of cellids and pass that in to the budget flow table because - ! the table assumes that there are maxbound gwf entries, which is not - ! the case if any 'none's are specified. - if (this%ianynone > 0) then - allocate(cellidstr(this%maxbound)) - do n = 1, this%maxbound - node = this%igwfnode(n) - if (node > 0) then - call this%dis%noder_to_string(node, cellidstr(n)) - else - cellidstr(n) = 'NONE' - end if - end do - call this%budobj%write_flowtable(this%dis, kstp, kper, cellidstr) - deallocate(cellidstr) - else - call this%budobj%write_flowtable(this%dis, kstp, kper) + ! -- adjust external downstream stream flow using qtomvr + if (qext < DZERO) then + if (qtomvr < DZERO) then + qext = qext - qtomvr + end if + else + qoutflow = this%dsflow(n) + if (qoutflow > DZERO) then + qoutflow = -qoutflow end if end if ! - ! -- return - return - end subroutine sfr_ot_package_flows + ! -- set qextoutflow and qoutflow for cell by cell budget + ! output and observations + this%qextoutflow(n) = qext + this%qoutflow(n) = qoutflow + ! + end do + ! + ! -- fill the budget object + call this%sfr_fill_budobj() + ! + ! -- return + return + end subroutine sfr_cq - !> @ brief Output package dependent-variable terms. + !> @ brief Output package flow terms. !! - !! Output SFR boundary package dependent-variable terms. + !! Output SFR package flow terms. !! - !< - subroutine sfr_ot_dv(this, idvsave, idvprint) - ! -- modules - use TdisModule, only: kstp, kper, pertim, totim - use InputOutputModule, only: ulasav - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: idvsave !< flag and unit number for dependent-variable output - integer(I4B), intent(in) :: idvprint !< flag indicating if dependent-variable should be written to the model listing file - ! -- local variables - character (len=20) :: cellid - integer(I4B) :: ibinun - integer(I4B) :: n - integer(I4B) :: node - real(DP) :: d - real(DP) :: v - real(DP) :: hgwf - real(DP) :: sbot - real(DP) :: depth - real(DP) :: stage - real(DP) :: w - real(DP) :: cond - real(DP) :: grad - ! - ! -- set unit number for binary dependent variable output - ibinun = 0 - if(this%istageout /= 0) then - ibinun = this%istageout - end if - if(idvsave == 0) ibinun = 0 - ! - ! -- write sfr binary output - if (ibinun > 0) then - do n = 1, this%maxbound - d = this%depth(n) - v = this%stage(n) - if (this%iboundpak(n) == 0) then - v = DHNOFLO - else if (d == DZERO) then - v = DHDRY - end if - this%dbuff(n) = v - end do - call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & - this%maxbound, 1, 1, ibinun) - end if - ! - ! -- print sfr stage and depth table - if (idvprint /= 0 .and. this%iprhed /= 0) then - ! - ! -- set table kstp and kper - call this%stagetab%set_kstpkper(kstp, kper) - ! - ! -- fill stage data + !< + subroutine sfr_ot_package_flows(this, icbcfl, ibudfl) + ! -- modules + use TdisModule, only: kstp, kper, delt, pertim, totim + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output + integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved + ! -- local variables + integer(I4B) :: ibinun + character(len=20), dimension(:), allocatable :: cellidstr + integer(I4B) :: n + integer(I4B) :: node + ! + ! -- write the flows from the budobj + ibinun = 0 + if (this%ibudgetout /= 0) then + ibinun = this%ibudgetout + end if + if (icbcfl == 0) ibinun = 0 + if (ibinun > 0) then + call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & + pertim, totim, this%iout) + end if + ! + ! -- Print lake flows table + if (ibudfl /= 0 .and. this%iprflow /= 0) then + ! + ! -- If there are any 'none' gwf connections then need to calculate + ! a vector of cellids and pass that in to the budget flow table because + ! the table assumes that there are maxbound gwf entries, which is not + ! the case if any 'none's are specified. + if (this%ianynone > 0) then + allocate (cellidstr(this%maxbound)) do n = 1, this%maxbound node = this%igwfnode(n) if (node > 0) then - call this%dis%noder_to_string(node, cellid) - hgwf = this%xnew(node) - else - cellid = 'NONE' - end if - if(this%inamedbound==1) then - call this%stagetab%add_term(this%boundname(n)) - end if - call this%stagetab%add_term(n) - call this%stagetab%add_term(cellid) - depth = this%depth(n) - stage = this%stage(n) - w = this%calc_top_width_wet(n, depth) - call this%stagetab%add_term(stage) - call this%stagetab%add_term(depth) - call this%stagetab%add_term(w) - call this%sfr_calc_cond(n, depth, cond) - if (node > 0) then - sbot = this%strtop(n) - this%bthick(n) - if (hgwf < sbot) then - grad = stage - sbot - else - grad = stage - hgwf - end if - grad = grad / this%bthick(n) - call this%stagetab%add_term(hgwf) - call this%stagetab%add_term(cond) - call this%stagetab%add_term(grad) + call this%dis%noder_to_string(node, cellidstr(n)) else - call this%stagetab%add_term('--') - call this%stagetab%add_term('--') - call this%stagetab%add_term('--') + cellidstr(n) = 'NONE' end if end do + call this%budobj%write_flowtable(this%dis, kstp, kper, cellidstr) + deallocate (cellidstr) + else + call this%budobj%write_flowtable(this%dis, kstp, kper) end if - ! - ! -- return - return - end subroutine sfr_ot_dv - - !> @ brief Output advanced package budget summary. + end if + ! + ! -- return + return + end subroutine sfr_ot_package_flows + + !> @ brief Output package dependent-variable terms. !! - !! Output SFR package budget summary. + !! Output SFR boundary package dependent-variable terms. !! - !< - subroutine sfr_ot_bdsummary(this, kstp, kper, iout, ibudfl) - ! -- module - use TdisModule, only: totim - ! -- dummy - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + !< + subroutine sfr_ot_dv(this, idvsave, idvprint) + ! -- modules + use TdisModule, only: kstp, kper, pertim, totim + use InputOutputModule, only: ulasav + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: idvsave !< flag and unit number for dependent-variable output + integer(I4B), intent(in) :: idvprint !< flag indicating if dependent-variable should be written to the model listing file + ! -- local variables + character(len=20) :: cellid + integer(I4B) :: ibinun + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: d + real(DP) :: v + real(DP) :: hgwf + real(DP) :: sbot + real(DP) :: depth + real(DP) :: stage + real(DP) :: w + real(DP) :: cond + real(DP) :: grad + ! + ! -- set unit number for binary dependent variable output + ibinun = 0 + if (this%istageout /= 0) then + ibinun = this%istageout + end if + if (idvsave == 0) ibinun = 0 + ! + ! -- write sfr binary output + if (ibinun > 0) then + do n = 1, this%maxbound + d = this%depth(n) + v = this%stage(n) + if (this%iboundpak(n) == 0) then + v = DHNOFLO + else if (d == DZERO) then + v = DHDRY + end if + this%dbuff(n) = v + end do + call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, & + this%maxbound, 1, 1, ibinun) + end if + ! + ! -- print sfr stage and depth table + if (idvprint /= 0 .and. this%iprhed /= 0) then ! - call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) + ! -- set table kstp and kper + call this%stagetab%set_kstpkper(kstp, kper) ! - ! -- return - return - end subroutine sfr_ot_bdsummary - - !> @ brief Deallocate package memory + ! -- fill stage data + do n = 1, this%maxbound + node = this%igwfnode(n) + if (node > 0) then + call this%dis%noder_to_string(node, cellid) + hgwf = this%xnew(node) + else + cellid = 'NONE' + end if + if (this%inamedbound == 1) then + call this%stagetab%add_term(this%boundname(n)) + end if + call this%stagetab%add_term(n) + call this%stagetab%add_term(cellid) + depth = this%depth(n) + stage = this%stage(n) + w = this%calc_top_width_wet(n, depth) + call this%stagetab%add_term(stage) + call this%stagetab%add_term(depth) + call this%stagetab%add_term(w) + call this%sfr_calc_cond(n, depth, cond) + if (node > 0) then + sbot = this%strtop(n) - this%bthick(n) + if (hgwf < sbot) then + grad = stage - sbot + else + grad = stage - hgwf + end if + grad = grad / this%bthick(n) + call this%stagetab%add_term(hgwf) + call this%stagetab%add_term(cond) + call this%stagetab%add_term(grad) + else + call this%stagetab%add_term('--') + call this%stagetab%add_term('--') + call this%stagetab%add_term('--') + end if + end do + end if + ! + ! -- return + return + end subroutine sfr_ot_dv + + !> @ brief Output advanced package budget summary. + !! + !! Output SFR package budget summary. + !! + !< + subroutine sfr_ot_bdsummary(this, kstp, kper, iout, ibudfl) + ! -- module + use TdisModule, only: totim + ! -- dummy + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + ! + call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) + ! + ! -- return + return + end subroutine sfr_ot_bdsummary + + !> @ brief Deallocate package memory !! !! Deallocate SFR package scalars and arrays. !! - !< - subroutine sfr_da(this) - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! - ! -- deallocate arrays - call mem_deallocate(this%qoutflow) - call mem_deallocate(this%qextoutflow) - deallocate(this%csfrbudget) - call mem_deallocate(this%sfrname, 'SFRNAME', this%memoryPath) - call mem_deallocate(this%dbuff) - deallocate(this%cauxcbc) - call mem_deallocate(this%qauxcbc) - call mem_deallocate(this%iboundpak) - call mem_deallocate(this%igwfnode) - call mem_deallocate(this%igwftopnode) - call mem_deallocate(this%length) - call mem_deallocate(this%width) - call mem_deallocate(this%strtop) - call mem_deallocate(this%bthick) - call mem_deallocate(this%hk) - call mem_deallocate(this%slope) - call mem_deallocate(this%nconnreach) - call mem_deallocate(this%ustrf) - call mem_deallocate(this%ftotnd) - call mem_deallocate(this%usflow) - call mem_deallocate(this%dsflow) - call mem_deallocate(this%depth) - call mem_deallocate(this%stage) - call mem_deallocate(this%gwflow) - call mem_deallocate(this%simevap) - call mem_deallocate(this%simrunoff) - call mem_deallocate(this%stage0) - call mem_deallocate(this%usflow0) - call mem_deallocate(this%denseterms) - ! - ! -- deallocate reach order and connection data - call mem_deallocate(this%isfrorder) - call mem_deallocate(this%ia) - call mem_deallocate(this%ja) - call mem_deallocate(this%idir) - call mem_deallocate(this%idiv) - call mem_deallocate(this%qconn) - ! - ! -- deallocate boundary data - call mem_deallocate(this%rough) - call mem_deallocate(this%rain) - call mem_deallocate(this%evap) - call mem_deallocate(this%inflow) - call mem_deallocate(this%runoff) - call mem_deallocate(this%sstage) - ! - ! -- deallocate aux variables - call mem_deallocate(this%rauxvar) - ! - ! -- deallocate diversion variables - call mem_deallocate(this%iadiv) - call mem_deallocate(this%divreach) - if (associated(this%divcprior)) then - deallocate(this%divcprior) - end if - call mem_deallocate(this%divflow) - call mem_deallocate(this%divq) - call mem_deallocate(this%ndiv) - ! - ! -- deallocate cross-section data - call mem_deallocate(this%ncrosspts) - call mem_deallocate(this%iacross) - call mem_deallocate(this%station) - call mem_deallocate(this%xsheight) - call mem_deallocate(this%xsrough) - ! - ! -- deallocate budobj - call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) - ! - ! -- deallocate stage table - if (this%iprhed > 0) then - call this%stagetab%table_da() - deallocate(this%stagetab) - nullify(this%stagetab) - end if - ! - ! -- deallocate package csv table - if (this%ipakcsv > 0) then - call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) - end if - ! - ! -- deallocate scalars - call mem_deallocate(this%iprhed) - call mem_deallocate(this%istageout) - call mem_deallocate(this%ibudgetout) - call mem_deallocate(this%ibudcsv) - call mem_deallocate(this%ipakcsv) - call mem_deallocate(this%idiversions) - call mem_deallocate(this%maxsfrpicard) - call mem_deallocate(this%maxsfrit) - call mem_deallocate(this%bditems) - call mem_deallocate(this%cbcauxitems) - call mem_deallocate(this%unitconv) - call mem_deallocate(this%dmaxchg) - call mem_deallocate(this%deps) - call mem_deallocate(this%nconn) - call mem_deallocate(this%icheck) - call mem_deallocate(this%iconvchk) - call mem_deallocate(this%idense) - call mem_deallocate(this%ianynone) - call mem_deallocate(this%ncrossptstot) - nullify(this%gwfiss) - ! - ! -- call base BndType deallocate - call this%BndType%bnd_da() - ! - ! -- return - return - end subroutine sfr_da + !< + subroutine sfr_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! + ! -- deallocate arrays + call mem_deallocate(this%qoutflow) + call mem_deallocate(this%qextoutflow) + deallocate (this%csfrbudget) + call mem_deallocate(this%sfrname, 'SFRNAME', this%memoryPath) + call mem_deallocate(this%dbuff) + deallocate (this%cauxcbc) + call mem_deallocate(this%qauxcbc) + call mem_deallocate(this%iboundpak) + call mem_deallocate(this%igwfnode) + call mem_deallocate(this%igwftopnode) + call mem_deallocate(this%length) + call mem_deallocate(this%width) + call mem_deallocate(this%strtop) + call mem_deallocate(this%bthick) + call mem_deallocate(this%hk) + call mem_deallocate(this%slope) + call mem_deallocate(this%nconnreach) + call mem_deallocate(this%ustrf) + call mem_deallocate(this%ftotnd) + call mem_deallocate(this%usflow) + call mem_deallocate(this%dsflow) + call mem_deallocate(this%depth) + call mem_deallocate(this%stage) + call mem_deallocate(this%gwflow) + call mem_deallocate(this%simevap) + call mem_deallocate(this%simrunoff) + call mem_deallocate(this%stage0) + call mem_deallocate(this%usflow0) + call mem_deallocate(this%denseterms) + ! + ! -- deallocate reach order and connection data + call mem_deallocate(this%isfrorder) + call mem_deallocate(this%ia) + call mem_deallocate(this%ja) + call mem_deallocate(this%idir) + call mem_deallocate(this%idiv) + call mem_deallocate(this%qconn) + ! + ! -- deallocate boundary data + call mem_deallocate(this%rough) + call mem_deallocate(this%rain) + call mem_deallocate(this%evap) + call mem_deallocate(this%inflow) + call mem_deallocate(this%runoff) + call mem_deallocate(this%sstage) + ! + ! -- deallocate aux variables + call mem_deallocate(this%rauxvar) + ! + ! -- deallocate diversion variables + call mem_deallocate(this%iadiv) + call mem_deallocate(this%divreach) + if (associated(this%divcprior)) then + deallocate (this%divcprior) + end if + call mem_deallocate(this%divflow) + call mem_deallocate(this%divq) + call mem_deallocate(this%ndiv) + ! + ! -- deallocate cross-section data + call mem_deallocate(this%ncrosspts) + call mem_deallocate(this%iacross) + call mem_deallocate(this%station) + call mem_deallocate(this%xsheight) + call mem_deallocate(this%xsrough) + ! + ! -- deallocate budobj + call this%budobj%budgetobject_da() + deallocate (this%budobj) + nullify (this%budobj) + ! + ! -- deallocate stage table + if (this%iprhed > 0) then + call this%stagetab%table_da() + deallocate (this%stagetab) + nullify (this%stagetab) + end if + ! + ! -- deallocate package csv table + if (this%ipakcsv > 0) then + call this%pakcsvtab%table_da() + deallocate (this%pakcsvtab) + nullify (this%pakcsvtab) + end if + ! + ! -- deallocate scalars + call mem_deallocate(this%iprhed) + call mem_deallocate(this%istageout) + call mem_deallocate(this%ibudgetout) + call mem_deallocate(this%ibudcsv) + call mem_deallocate(this%ipakcsv) + call mem_deallocate(this%idiversions) + call mem_deallocate(this%maxsfrpicard) + call mem_deallocate(this%maxsfrit) + call mem_deallocate(this%bditems) + call mem_deallocate(this%cbcauxitems) + call mem_deallocate(this%unitconv) + call mem_deallocate(this%dmaxchg) + call mem_deallocate(this%deps) + call mem_deallocate(this%nconn) + call mem_deallocate(this%icheck) + call mem_deallocate(this%iconvchk) + call mem_deallocate(this%idense) + call mem_deallocate(this%ianynone) + call mem_deallocate(this%ncrossptstot) + nullify (this%gwfiss) + ! + ! -- call base BndType deallocate + call this%BndType%bnd_da() + ! + ! -- return + return + end subroutine sfr_da - !> @ brief Define the list label for the package + !> @ brief Define the list label for the package !! !! Method defined the list label for the SFR package. The list label is !! the heading that is written to iout when PRINT_INPUT option is used. !! - !< - subroutine define_listlabel(this) - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif - ! - ! -- return - return - end subroutine define_listlabel - + !< + subroutine define_listlabel(this) + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object ! - ! -- Procedures related to observations (type-bound) - - !> @brief Determine if observations are supported. + ! -- create the header list label + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if + ! + ! -- return + return + end subroutine define_listlabel + + ! + ! -- Procedures related to observations (type-bound) + + !> @brief Determine if observations are supported. !! !! Function to determine if observations are supported by the SFR package. !! Observations are supported by the SFR package. !! !! @return sfr_obs_supported boolean indicating if observations are supported !! - !< - logical function sfr_obs_supported(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! - ! -- set boolean - sfr_obs_supported = .true. - ! - ! -- return - return - end function sfr_obs_supported - + !< + logical function sfr_obs_supported(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! + ! -- set boolean + sfr_obs_supported = .true. + ! + ! -- return + return + end function sfr_obs_supported - !> @brief Define the observation types available in the package + !> @brief Define the observation types available in the package !! !! Method to define the observation types available in the SFR package. !! - !< - subroutine sfr_df_obs(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - integer(I4B) :: indx - ! - ! -- Store obs type and assign procedure pointer - ! for stage observation type. - call this%obs%StoreObsType('stage', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inflow observation type. - call this%obs%StoreObsType('inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for inflow observation type. - call this%obs%StoreObsType('ext-inflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for rainfall observation type. - call this%obs%StoreObsType('rainfall', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for runoff observation type. - call this%obs%StoreObsType('runoff', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for evaporation observation type. - call this%obs%StoreObsType('evaporation', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for outflow observation type. - call this%obs%StoreObsType('outflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for ext-outflow observation type. - call this%obs%StoreObsType('ext-outflow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for sfr-frommvr observation type. - call this%obs%StoreObsType('from-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for sfr observation type. - call this%obs%StoreObsType('sfr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for upstream flow observation type. - call this%obs%StoreObsType('upstream-flow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for downstream flow observation type. - call this%obs%StoreObsType('downstream-flow', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for depth observation type. - call this%obs%StoreObsType('depth', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for wetted-perimeter observation type. - call this%obs%StoreObsType('wet-perimeter', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for wetted-area observation type. - call this%obs%StoreObsType('wet-area', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- Store obs type and assign procedure pointer - ! for wetted-width observation type. - call this%obs%StoreObsType('wet-width', .false., indx) - this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID - ! - ! -- return - return - end subroutine sfr_df_obs - + !< + subroutine sfr_df_obs(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + integer(I4B) :: indx + ! + ! -- Store obs type and assign procedure pointer + ! for stage observation type. + call this%obs%StoreObsType('stage', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('ext-inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rainfall observation type. + call this%obs%StoreObsType('rainfall', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for runoff observation type. + call this%obs%StoreObsType('runoff', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for evaporation observation type. + call this%obs%StoreObsType('evaporation', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for outflow observation type. + call this%obs%StoreObsType('outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ext-outflow observation type. + call this%obs%StoreObsType('ext-outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for sfr-frommvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for sfr observation type. + call this%obs%StoreObsType('sfr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for upstream flow observation type. + call this%obs%StoreObsType('upstream-flow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for downstream flow observation type. + call this%obs%StoreObsType('downstream-flow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for depth observation type. + call this%obs%StoreObsType('depth', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for wetted-perimeter observation type. + call this%obs%StoreObsType('wet-perimeter', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for wetted-area observation type. + call this%obs%StoreObsType('wet-area', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for wetted-width observation type. + call this%obs%StoreObsType('wet-width', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => sfr_process_obsID + ! + ! -- return + return + end subroutine sfr_df_obs - !> @brief Save observations for the package + !> @brief Save observations for the package !! !! Method to save simulated values for the SFR package. !! - !< - subroutine sfr_bd_obs(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: n - real(DP) :: v - character(len=100) :: msg - type(ObserveType), pointer :: obsrv => null() - ! - ! Write simulated values for all sfr observations - if (this%obs%npakobs > 0) then - call this%obs%obs_bd_clear() - do i=1 ,this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - do j = 1, obsrv%indxbnds_count - n = obsrv%indxbnds(j) - v = DZERO - select case (obsrv%ObsTypeId) - case ('STAGE') - v = this%stage(n) - case ('TO-MVR') - v = DNODATA - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(n) - if (v > DZERO) then - v = -v - end if - end if - case ('FROM-MVR') - v = DNODATA - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(n) - end if - case ('EXT-INFLOW') - v = this%inflow(n) - case ('INFLOW') - v = this%usflow(n) - case ('OUTFLOW') - v = this%qoutflow(n) - case ('EXT-OUTFLOW') - v = this%qextoutflow(n) - case ('RAINFALL') - v = this%rain(n) - case ('RUNOFF') - v = this%simrunoff(n) - case ('EVAPORATION') - v = this%simevap(n) - case ('SFR') - v = this%gwflow(n) - case ('UPSTREAM-FLOW') - v = this%usflow(n) - if (this%imover == 1) then - v = v + this%pakmvrobj%get_qfrommvr(n) - end if - case ('DOWNSTREAM-FLOW') - v = this%dsflow(n) - if (v > DZERO) then - v = -v - end if - case ('DEPTH') - v = this%depth(n) - case ('WET-PERIMETER') - v = this%calc_perimeter_wet(n, this%depth(n)) - case ('WET-AREA') - v = this%calc_area_wet(n, this%depth(n)) - case ('WET-WIDTH') - v = this%calc_top_width_wet(n, this%depth(n)) - case default - msg = 'Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(msg) - end select - call this%obs%SaveOneSimval(obsrv, v) - end do + !< + subroutine sfr_bd_obs(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n + real(DP) :: v + character(len=100) :: msg + type(ObserveType), pointer :: obsrv => null() + ! + ! Write simulated values for all sfr observations + if (this%obs%npakobs > 0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + do j = 1, obsrv%indxbnds_count + n = obsrv%indxbnds(j) + v = DZERO + select case (obsrv%ObsTypeId) + case ('STAGE') + v = this%stage(n) + case ('TO-MVR') + v = DNODATA + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(n) + if (v > DZERO) then + v = -v + end if + end if + case ('FROM-MVR') + v = DNODATA + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(n) + end if + case ('EXT-INFLOW') + v = this%inflow(n) + case ('INFLOW') + v = this%usflow(n) + case ('OUTFLOW') + v = this%qoutflow(n) + case ('EXT-OUTFLOW') + v = this%qextoutflow(n) + case ('RAINFALL') + v = this%rain(n) + case ('RUNOFF') + v = this%simrunoff(n) + case ('EVAPORATION') + v = this%simevap(n) + case ('SFR') + v = this%gwflow(n) + case ('UPSTREAM-FLOW') + v = this%usflow(n) + if (this%imover == 1) then + v = v + this%pakmvrobj%get_qfrommvr(n) + end if + case ('DOWNSTREAM-FLOW') + v = this%dsflow(n) + if (v > DZERO) then + v = -v + end if + case ('DEPTH') + v = this%depth(n) + case ('WET-PERIMETER') + v = this%calc_perimeter_wet(n, this%depth(n)) + case ('WET-AREA') + v = this%calc_area_wet(n, this%depth(n)) + case ('WET-WIDTH') + v = this%calc_top_width_wet(n, this%depth(n)) + case default + msg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId) + call store_error(msg) + end select + call this%obs%SaveOneSimval(obsrv, v) end do - ! - ! -- write summary of package error messages - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - end if + end do ! - ! -- return - return - end subroutine sfr_bd_obs - + ! -- write summary of package error messages + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + end if + ! + ! -- return + return + end subroutine sfr_bd_obs - !> @brief Read and prepare observations for a package + !> @brief Read and prepare observations for a package !! !! Method to read and prepare observations for a SFR package. !! - !< - subroutine sfr_rp_obs(this) - ! -- modules - use TdisModule, only: kper - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: nn1 - character(len=LENBOUNDNAME) :: bname - logical(LGP) :: jfound - class(ObserveType), pointer :: obsrv => null() - ! -- formats - 10 format('Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') - 30 format('Boundary name not provided for observation "',a, & - '" in package "',a,'"') - ! - ! -- process each package observation - ! only done the first stress period since boundaries are fixed - ! for the simulation - if (kper == 1) then - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - ! - ! -- get node number 1 - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) then - bname = obsrv%FeatureName - if (bname /= '') then - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - jfound = .false. - do j = 1, this%maxbound - if (this%boundname(j) == bname) then - jfound = .true. - call obsrv%AddObsIndex(j) - endif - enddo - if (.not. jfound) then - write(errmsg,10) trim(bname), trim(obsrv%name), trim(this%packName) - call store_error(errmsg) - endif - else - write(errmsg,30) trim(obsrv%name), trim(this%packName) + !< + subroutine sfr_rp_obs(this) + ! -- modules + use TdisModule, only: kper + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: nn1 + character(len=LENBOUNDNAME) :: bname + logical(LGP) :: jfound + class(ObserveType), pointer :: obsrv => null() + ! -- formats +10 format('Boundary "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') +30 format('Boundary name not provided for observation "', a, & + '" in package "', a, '"') + ! + ! -- process each package observation + ! only done the first stress period since boundaries are fixed + ! for the simulation + if (kper == 1) then + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- get node number 1 + nn1 = obsrv%NodeNumber + if (nn1 == NAMEDBOUNDFLAG) then + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + jfound = .false. + do j = 1, this%maxbound + if (this%boundname(j) == bname) then + jfound = .true. + call obsrv%AddObsIndex(j) + end if + end do + if (.not. jfound) then + write (errmsg, 10) & + trim(bname), trim(obsrv%name), trim(this%packName) call store_error(errmsg) - endif - else if (nn1 < 1 .or. nn1 > this%maxbound) then - write(errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - 'reach must be greater than 0 and less than or equal to', & - this%maxbound, '(specified value is ', nn1, ')' + end if + else + write (errmsg, 30) trim(obsrv%name), trim(this%packName) call store_error(errmsg) + end if + else if (nn1 < 1 .or. nn1 > this%maxbound) then + write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + 'reach must be greater than 0 and less than or equal to', & + this%maxbound, '(specified value is ', nn1, ')' + call store_error(errmsg) + else + if (obsrv%indxbnds_count == 0) then + call obsrv%AddObsIndex(nn1) else - if (obsrv%indxbnds_count == 0) then - call obsrv%AddObsIndex(nn1) - else - errmsg = 'Programming error in sfr_rp_obs' + errmsg = 'Programming error in sfr_rp_obs' + call store_error(errmsg) + end if + end if + ! + ! -- catch non-cumulative observation assigned to observation defined + ! by a boundname that is assigned to more than one element + if (obsrv%ObsTypeId == 'STAGE' .or. & + obsrv%ObsTypeId == 'DEPTH' .or. & + obsrv%ObsTypeId == 'WET-PERIMETER' .or. & + obsrv%ObsTypeId == 'WET-AREA' .or. & + obsrv%ObsTypeId == 'WET-WIDTH') then + nn1 = obsrv%NodeNumber + if (nn1 == NAMEDBOUNDFLAG) then + if (obsrv%indxbnds_count > 1) then + write (errmsg, '(a,3(1x,a))') & + trim(adjustl(obsrv%ObsTypeId)), & + 'for observation', trim(adjustl(obsrv%Name)), & + ' must be assigned to a reach with a unique boundname.' call store_error(errmsg) end if end if - ! - ! -- catch non-cumulative observation assigned to observation defined - ! by a boundname that is assigned to more than one element - if (obsrv%ObsTypeId == 'STAGE' .or. & - obsrv%ObsTypeId == 'DEPTH' .or. & - obsrv%ObsTypeId == 'WET-PERIMETER' .or. & - obsrv%ObsTypeId == 'WET-AREA' .or. & - obsrv%ObsTypeId == 'WET-WIDTH') then - nn1 = obsrv%NodeNumber - if (nn1 == NAMEDBOUNDFLAG) then - if (obsrv%indxbnds_count > 1) then - write(errmsg, '(a,3(1x,a))') & - trim(adjustl(obsrv%ObsTypeId)), & - 'for observation', trim(adjustl(obsrv%Name)), & - ' must be assigned to a reach with a unique boundname.' - call store_error(errmsg) - end if - end if + end if + ! + ! -- check that node number 1 is valid; call store_error if not + do j = 1, obsrv%indxbnds_count + nn1 = obsrv%indxbnds(j) + if (nn1 < 1 .or. nn1 > this%maxbound) then + write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), & + 'reach must be greater than 0 and less than or equal to', & + this%maxbound, '(specified value is ', nn1, ')' + call store_error(errmsg) end if - ! - ! -- check that node number 1 is valid; call store_error if not - do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) - if (nn1 < 1 .or. nn1 > this%maxbound) then - write(errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), & - 'reach must be greater than 0 and less than or equal to', & - this%maxbound, '(specified value is ', nn1, ')' - call store_error(errmsg) - end if - end do end do - ! - ! -- evaluate if there are any observation errors - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - end if + end do ! - ! -- return - return - end subroutine sfr_rp_obs - + ! -- evaluate if there are any observation errors + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + end if ! - ! -- Procedures related to observations (NOT type-bound) + ! -- return + return + end subroutine sfr_rp_obs + + ! + ! -- Procedures related to observations (NOT type-bound) - !> @brief Process observation IDs for a package + !> @brief Process observation IDs for a package !! !! Method to process observation ID strings for a SFR package. !! - !< - subroutine sfr_process_obsID(obsrv, dis, inunitobs, iout) - ! -- dummy variables - type(ObserveType), intent(inout) :: obsrv !< Observation object - class(DisBaseType), intent(in) :: dis !< Discretization object - integer(I4B), intent(in) :: inunitobs !< file unit number for the package observation file - integer(I4B), intent(in) :: iout !< model listing file unit number - ! -- local variables - integer(I4B) :: nn1 - integer(I4B) :: icol - integer(I4B) :: istart - integer(I4B) :: istop - character(len=LINELENGTH) :: strng - character(len=LENBOUNDNAME) :: bndname - ! - ! -- initialize local variables - strng = obsrv%IDstring - ! - ! -- Extract reach number from strng and store it. - ! If 1st item is not an integer(I4B), it should be a - ! boundary name--deal with it. - icol = 1 - ! - ! -- get reach number or boundary name - call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) - if (nn1 == NAMEDBOUNDFLAG) then - obsrv%FeatureName = bndname - endif - ! - ! -- store reach number (NodeNumber) - obsrv%NodeNumber = nn1 - ! - ! -- return - return - end subroutine sfr_process_obsID - + !< + subroutine sfr_process_obsID(obsrv, dis, inunitobs, iout) + ! -- dummy variables + type(ObserveType), intent(inout) :: obsrv !< Observation object + class(DisBaseType), intent(in) :: dis !< Discretization object + integer(I4B), intent(in) :: inunitobs !< file unit number for the package observation file + integer(I4B), intent(in) :: iout !< model listing file unit number + ! -- local variables + integer(I4B) :: nn1 + integer(I4B) :: icol + integer(I4B) :: istart + integer(I4B) :: istop + character(len=LINELENGTH) :: strng + character(len=LENBOUNDNAME) :: bndname + ! + ! -- initialize local variables + strng = obsrv%IDstring + ! + ! -- Extract reach number from strng and store it. + ! If 1st item is not an integer(I4B), it should be a + ! boundary name--deal with it. + icol = 1 ! - ! -- private sfr methods + ! -- get reach number or boundary name + call extract_idnum_or_bndname(strng, icol, istart, istop, nn1, bndname) + if (nn1 == NAMEDBOUNDFLAG) then + obsrv%FeatureName = bndname + end if ! + ! -- store reach number (NodeNumber) + obsrv%NodeNumber = nn1 + ! + ! -- return + return + end subroutine sfr_process_obsID + + ! + ! -- private sfr methods + ! - !> @brief Set period data + !> @brief Set period data !! !! Method to read and set period data for a SFR package reach. !! - !< - subroutine sfr_set_stressperiod(this, n, ichkustrm, crossfile) - ! -- modules - use TimeSeriesManagerModule, only: read_value_or_time_series_adv - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - integer(I4B), intent(inout) :: ichkustrm !< flag indicating if upstream fraction data specified - character(len=LINELENGTH), intent(inout) :: crossfile !< cross-section file name - ! -- local variables - character(len=10) :: cnum - character(len=LINELENGTH) :: text - character(len=LINELENGTH) :: caux - character(len=LINELENGTH) :: keyword - integer(I4B) :: ival - integer(I4B) :: ii - integer(I4B) :: jj - integer(I4B) :: idiv - integer(I4B) :: ixserror - character (len=10) :: cp - real(DP) :: divq - real(DP), pointer :: bndElem => null() + !< + subroutine sfr_set_stressperiod(this, n, ichkustrm, crossfile) + ! -- modules + use TimeSeriesManagerModule, only: read_value_or_time_series_adv + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + integer(I4B), intent(inout) :: ichkustrm !< flag indicating if upstream fraction data specified + character(len=LINELENGTH), intent(inout) :: crossfile !< cross-section file name + ! -- local variables + character(len=10) :: cnum + character(len=LINELENGTH) :: text + character(len=LINELENGTH) :: caux + character(len=LINELENGTH) :: keyword + integer(I4B) :: ival + integer(I4B) :: ii + integer(I4B) :: jj + integer(I4B) :: idiv + integer(I4B) :: ixserror + character(len=10) :: cp + real(DP) :: divq + real(DP), pointer :: bndElem => null() + ! + ! -- initialize variables + crossfile = 'NONE' + ! + ! -- read line + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('STATUS') + ichkustrm = 1 + call this%parser%GetStringCaps(text) + if (text == 'INACTIVE') then + this%iboundpak(n) = 0 + else if (text == 'ACTIVE') then + this%iboundpak(n) = 1 + else if (text == 'SIMPLE') then + this%iboundpak(n) = -1 + else + write (errmsg, '(2a)') & + 'Unknown '//trim(this%text)//' sfr status keyword: ', trim(text) + call store_error(errmsg) + end if + case ('MANNING') + call this%parser%GetString(text) + jj = 1 ! For 'MANNING' + bndElem => this%rough(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & + 'MANNING') + case ('STAGE') + call this%parser%GetString(text) + jj = 1 ! For 'STAGE' + bndElem => this%sstage(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'STAGE') + case ('RAINFALL') + call this%parser%GetString(text) + jj = 1 ! For 'RAIN' + bndElem => this%rain(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'RAIN') + case ('EVAPORATION') + call this%parser%GetString(text) + jj = 1 ! For 'EVAP' + bndElem => this%evap(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & + 'MANNING') + case ('RUNOFF') + call this%parser%GetString(text) + jj = 1 ! For 'RUNOFF' + bndElem => this%runoff(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & + 'RUNOFF') + case ('INFLOW') + call this%parser%GetString(text) + jj = 1 ! For 'INFLOW' + bndElem => this%inflow(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & + 'INFLOW') + case ('DIVERSION') + ! + ! -- make sure reach has at least one diversion + if (this%ndiv(n) < 1) then + write (cnum, '(i0)') n + errmsg = 'diversions cannot be specified for reach '//trim(cnum) + call store_error(errmsg) + end if ! - ! -- initialize variables - crossfile = 'NONE' + ! -- read diversion number + ival = this%parser%GetInteger() + if (ival < 1 .or. ival > this%ndiv(n)) then + write (cnum, '(i0)') n + errmsg = 'Reach '//trim(cnum) + write (cnum, '(i0)') this%ndiv(n) + errmsg = trim(errmsg)//' diversion number should be between 1 '// & + 'and '//trim(cnum)//'.' + call store_error(errmsg) + end if + idiv = ival + ! + ! -- read value + call this%parser%GetString(text) + ii = this%iadiv(n) + idiv - 1 + jj = 1 ! For 'DIVERSION' + bndElem => this%divflow(ii) + call read_value_or_time_series_adv(text, ii, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, & + 'DIVFLOW') + ! + ! -- if diversion cprior is 'fraction', ensure that 0.0 <= fraction <= 1.0 + cp = this%divcprior(ii) + divq = this%divflow(ii) + if (cp == 'FRACTION' .and. (divq < DZERO .or. divq > DONE)) then + write (errmsg, '(a,1x,i0,a)') & + 'cprior is type FRACTION for diversion no.', ii, & + ', but divflow not within the range 0.0 to 1.0' + call store_error(errmsg) + end if + case ('UPSTREAM_FRACTION') + ichkustrm = 1 + call this%parser%GetString(text) + jj = 1 ! For 'USTRF' + bndElem => this%ustrf(n) + call read_value_or_time_series_adv(text, n, jj, bndElem, & + this%packName, 'BND', & + this%tsManager, this%iprpak, 'USTRF') + + case ('CROSS_SECTION') + ixserror = 0 ! - ! -- read line + ! -- read FILE keyword call this%parser%GetStringCaps(keyword) select case (keyword) - case ('STATUS') - ichkustrm = 1 - call this%parser%GetStringCaps(text) - if (text == 'INACTIVE') then - this%iboundpak(n) = 0 - else if (text == 'ACTIVE') then - this%iboundpak(n) = 1 - else if (text == 'SIMPLE') then - this%iboundpak(n) = -1 - else - write(errmsg,'(2a)') & - 'Unknown ' // trim(this%text) // ' sfr status keyword: ', trim(text) - call store_error(errmsg) - end if - case ('MANNING') - call this%parser%GetString(text) - jj = 1 ! For 'MANNING' - bndElem => this%rough(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'MANNING') - case ('STAGE') - call this%parser%GetString(text) - jj = 1 ! For 'STAGE' - bndElem => this%sstage(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'STAGE') - case ('RAINFALL') - call this%parser%GetString(text) - jj = 1 ! For 'RAIN' - bndElem => this%rain(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RAIN') - case ('EVAPORATION') - call this%parser%GetString(text) - jj = 1 ! For 'EVAP' - bndElem => this%evap(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'MANNING') - case ('RUNOFF') - call this%parser%GetString(text) - jj = 1 ! For 'RUNOFF' - bndElem => this%runoff(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RUNOFF') - case ('INFLOW') - call this%parser%GetString(text) - jj = 1 ! For 'INFLOW' - bndElem => this%inflow(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'INFLOW') - case ('DIVERSION') - ! - ! -- make sure reach has at least one diversion - if (this%ndiv(n) < 1) then - write(cnum, '(i0)') n - errmsg = 'diversions cannot be specified for reach ' // trim(cnum) - call store_error(errmsg) - end if - ! - ! -- read diversion number - ival = this%parser%GetInteger() - if (ival < 1 .or. ival > this%ndiv(n)) then - write(cnum, '(i0)') n - errmsg = 'Reach ' // trim(cnum) - write(cnum, '(i0)') this%ndiv(n) - errmsg = trim(errmsg) // ' diversion number should be between 1 ' // & - 'and ' // trim(cnum) // '.' - call store_error(errmsg) - end if - idiv = ival - ! - ! -- read value - call this%parser%GetString(text) - ii = this%iadiv(n) + idiv - 1 - jj = 1 ! For 'DIVERSION' - bndElem => this%divflow(ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'DIVFLOW') - ! - ! -- if diversion cprior is 'fraction', ensure that 0.0 <= fraction <= 1.0 - cp = this%divcprior(ii) - divq = this%divflow(ii) - if (cp == 'FRACTION' .and. (divq < DZERO .or. divq > DONE)) then - write(errmsg,'(a,1x,i0,a)') & - 'cprior is type FRACTION for diversion no.', ii, & - ', but divflow not within the range 0.0 to 1.0' - call store_error(errmsg) - endif - case ('UPSTREAM_FRACTION') - ichkustrm = 1 - call this%parser%GetString(text) - jj = 1 ! For 'USTRF' - bndElem => this%ustrf(n) - call read_value_or_time_series_adv(text, n, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'USTRF') - - case ('CROSS_SECTION') - ixserror = 0 - ! - ! -- read FILE keyword - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('TAB6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAB6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - ixserror = 1 - end if - if (ixserror == 0) then - call this%parser%GetString(crossfile) - end if - case default - write(errmsg,'(a,1x,i4,1x,a)') & - 'CROSS-SECTION TABLE ENTRY for REACH ', n, & - 'MUST INCLUDE TAB6 KEYWORD' - call store_error(errmsg) - end select - - case ('AUXILIARY') - call this%parser%GetStringCaps(caux) - do jj = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle - call this%parser%GetString(text) - ii = n - bndElem => this%rauxvar(jj, ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'AUX', this%tsManager, this%iprpak, & - this%auxname(jj)) - exit - end do - - case default - write(errmsg,'(a,a)') & - 'Unknown ' // trim(this%text) // ' sfr data keyword: ', & - trim(keyword) // '.' + case ('TAB6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAB6 keyword must be followed by "FILEIN" '// & + 'then by filename.' call store_error(errmsg) + ixserror = 1 + end if + if (ixserror == 0) then + call this%parser%GetString(crossfile) + end if + case default + write (errmsg, '(a,1x,i4,1x,a)') & + 'CROSS-SECTION TABLE ENTRY for REACH ', n, & + 'MUST INCLUDE TAB6 KEYWORD' + call store_error(errmsg) end select - ! - ! -- return - return - end subroutine sfr_set_stressperiod + case ('AUXILIARY') + call this%parser%GetStringCaps(caux) + do jj = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle + call this%parser%GetString(text) + ii = n + bndElem => this%rauxvar(jj, ii) + call read_value_or_time_series_adv(text, ii, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & + this%auxname(jj)) + exit + end do + + case default + write (errmsg, '(a,a)') & + 'Unknown '//trim(this%text)//' sfr data keyword: ', & + trim(keyword)//'.' + call store_error(errmsg) + end select + ! + ! -- return + return + end subroutine sfr_set_stressperiod - !> @brief Solve reach continuity equation + !> @brief Solve reach continuity equation !! !! Method to solve the continuity equation for a SFR package reach. !! - !< - subroutine sfr_solve(this, n, h, hcof, rhs, update) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: h !< groundwater head in cell connected to reach - real(DP), intent(inout) :: hcof !< coefficient term added to the diagonal - real(DP), intent(inout) :: rhs !< right-hand side term - logical(LGP), intent(in), optional :: update !< boolean indicating if the reach depth and stage variables should be updated to current iterate - ! -- local variables - logical(LGP) :: lupdate - integer(I4B) :: i - integer(I4B) :: ii - integer(I4B) :: n2 - integer(I4B) :: isolve - integer(I4B) :: iic - integer(I4B) :: iic2 - integer(I4B) :: iic3 - integer(I4B) :: iic4 - integer(I4B) :: ibflg - real(DP) :: hgwf - real(DP) :: sa - real(DP) :: qu - real(DP) :: qi - real(DP) :: qr - real(DP) :: qe - real(DP) :: qro - real(DP) :: qmp - real(DP) :: qsrc - real(DP) :: qfrommvr - real(DP) :: qgwf - real(DP) :: qmpsrc - real(DP) :: qc - real(DP) :: qt - real(DP) :: tp - real(DP) :: bt - real(DP) :: hsfr - real(DP) :: cstr - real(DP) :: qd - real(DP) :: en1 - real(DP) :: en2 - real(DP) :: qen1 - real(DP) :: f1, f2 - real(DP) :: qgwf1 - real(DP) :: qgwf2 - real(DP) :: qgwfp - real(DP) :: qgwfold - real(DP) :: fhstr1 - real(DP) :: fhstr2 - real(DP) :: d1 - real(DP) :: d2 - real(DP) :: dpp - real(DP) :: dx - real(DP) :: q1 - real(DP) :: q2 - real(DP) :: derv - real(DP) :: dlh - real(DP) :: dlhold - real(DP) :: fp - real(DP) :: err - real(DP) :: errold - real(DP) :: sumleak - real(DP) :: sumrch - real(DP) :: gwfhcof - real(DP) :: gwfrhs - ! - ! -- Process optional dummy variables - if (present(update)) then - lupdate = update - else - lupdate = .true. - end if - ! - ! -- calculate hgwf - hgwf = h - ! - ! - hcof = DZERO - rhs = DZERO - ! - ! -- initialize d1, d2, q1, q2, qsrc, and qgwf - d1 = DZERO - d2 = DZERO - q1 = DZERO - q2 = DZERO - qsrc = DZERO - qgwf = DZERO - qgwfold = DZERO - ! - ! -- calculate initial depth assuming a wide cross-section and ignore - ! groundwater leakage - ! -- calculate upstream flow - qu = DZERO - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) < 0) cycle - n2 = this%ja(i) - do ii = this%ia(n2) + 1, this%ia(n2+1) - 1 - if (this%idir(ii) > 0) cycle - if (this%ja(ii) /= n) cycle - qu = qu + this%qconn(ii) - end do + !< + subroutine sfr_solve(this, n, h, hcof, rhs, update) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: h !< groundwater head in cell connected to reach + real(DP), intent(inout) :: hcof !< coefficient term added to the diagonal + real(DP), intent(inout) :: rhs !< right-hand side term + logical(LGP), intent(in), optional :: update !< boolean indicating if the reach depth and stage variables should be updated to current iterate + ! -- local variables + logical(LGP) :: lupdate + integer(I4B) :: i + integer(I4B) :: ii + integer(I4B) :: n2 + integer(I4B) :: isolve + integer(I4B) :: iic + integer(I4B) :: iic2 + integer(I4B) :: iic3 + integer(I4B) :: iic4 + integer(I4B) :: ibflg + real(DP) :: hgwf + real(DP) :: sa + real(DP) :: qu + real(DP) :: qi + real(DP) :: qr + real(DP) :: qe + real(DP) :: qro + real(DP) :: qmp + real(DP) :: qsrc + real(DP) :: qfrommvr + real(DP) :: qgwf + real(DP) :: qmpsrc + real(DP) :: qc + real(DP) :: qt + real(DP) :: tp + real(DP) :: bt + real(DP) :: hsfr + real(DP) :: cstr + real(DP) :: qd + real(DP) :: en1 + real(DP) :: en2 + real(DP) :: qen1 + real(DP) :: f1, f2 + real(DP) :: qgwf1 + real(DP) :: qgwf2 + real(DP) :: qgwfp + real(DP) :: qgwfold + real(DP) :: fhstr1 + real(DP) :: fhstr2 + real(DP) :: d1 + real(DP) :: d2 + real(DP) :: dpp + real(DP) :: dx + real(DP) :: q1 + real(DP) :: q2 + real(DP) :: derv + real(DP) :: dlh + real(DP) :: dlhold + real(DP) :: fp + real(DP) :: err + real(DP) :: errold + real(DP) :: sumleak + real(DP) :: sumrch + real(DP) :: gwfhcof + real(DP) :: gwfrhs + ! + ! -- Process optional dummy variables + if (present(update)) then + lupdate = update + else + lupdate = .true. + end if + ! + ! -- calculate hgwf + hgwf = h + ! + ! + hcof = DZERO + rhs = DZERO + ! + ! -- initialize d1, d2, q1, q2, qsrc, and qgwf + d1 = DZERO + d2 = DZERO + q1 = DZERO + q2 = DZERO + qsrc = DZERO + qgwf = DZERO + qgwfold = DZERO + ! + ! -- calculate initial depth assuming a wide cross-section and ignore + ! groundwater leakage + ! -- calculate upstream flow + qu = DZERO + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) < 0) cycle + n2 = this%ja(i) + do ii = this%ia(n2) + 1, this%ia(n2 + 1) - 1 + if (this%idir(ii) > 0) cycle + if (this%ja(ii) /= n) cycle + qu = qu + this%qconn(ii) end do - this%usflow(n) = qu - ! -- calculate remaining terms - sa = this%calc_surface_area(n) - qi = this%inflow(n) - qr = this%rain(n) * sa - qe = this%evap(n) * sa - qro = this%runoff(n) - ! - ! -- Water mover term; assume that it goes in at the upstream end of the reach - qfrommvr = DZERO - if(this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - endif + end do + this%usflow(n) = qu + ! -- calculate remaining terms + sa = this%calc_surface_area(n) + qi = this%inflow(n) + qr = this%rain(n) * sa + qe = this%evap(n) * sa + qro = this%runoff(n) + ! + ! -- Water mover term; assume that it goes in at the upstream end of the reach + qfrommvr = DZERO + if (this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(n) + end if + ! + ! -- calculate sum of sources to the reach excluding groundwater leakage + qc = qu + qi + qr - qe + qro + qfrommvr + ! + ! -- adjust runoff or evaporation if sum of sources is negative + if (qc < DZERO) then ! - ! -- calculate sum of sources to the reach excluding groundwater leakage - qc = qu + qi + qr - qe + qro + qfrommvr + ! -- calculate sources without et + qt = qu + qi + qr + qro + qfrommvr ! - ! -- adjust runoff or evaporation if sum of sources is negative - if (qc < DZERO) then - ! - ! -- calculate sources without et - qt = qu + qi + qr + qro + qfrommvr - ! - ! -- runoff exceeds sources of water for reach - if (qt < DZERO) then - qro = -(qu + qi + qr + qfrommvr) - qe = DZERO + ! -- runoff exceeds sources of water for reach + if (qt < DZERO) then + qro = -(qu + qi + qr + qfrommvr) + qe = DZERO ! ! -- evaporation exceeds sources of water for reach + else + qe = qu + qi + qr + qro + qfrommvr + end if + qc = qu + qi + qr - qe + qro + qfrommvr + end if + ! + ! -- set simulated evaporation and runoff + this%simevap(n) = qe + this%simrunoff(n) = qro + ! + ! -- calculate flow at the middle of the reach and excluding groundwater leakage + qmp = qu + qi + qfrommvr + DHALF * (qr - qe + qro) + qmpsrc = qmp + ! + ! -- calculate stream depth at the midpoint + if (this%iboundpak(n) > 0) then + call this%sfr_calc_reach_depth(n, qmp, d1) + else + this%stage(n) = this%sstage(n) + d1 = max(DZERO, this%stage(n) - this%strtop(n)) + end if + ! + ! -- calculate sources/sinks for reach excluding groundwater leakage + call this%sfr_calc_qsource(n, d1, qsrc) + ! + ! -- calculate initial reach stage, downstream flow, and groundwater leakage + tp = this%strtop(n) + bt = tp - this%bthick(n) + hsfr = d1 + tp + qd = MAX(qsrc, DZERO) + qgwf = DZERO + ! + ! -- calculate reach conductance for a unit depth of water + ! if equal to zero will skip iterations + call this%sfr_calc_cond(n, d1, cstr) + ! + ! -- set flag to skip iterations + isolve = 1 + if (hsfr <= tp .and. hgwf <= tp) isolve = 0 + if (hgwf <= tp .and. qc < DEM30) isolve = 0 + if (cstr < DEM30) isolve = 0 + if (this%iboundpak(n) < 0) isolve = 0 + ! + ! -- iterate to achieve solution + itersol: if (isolve /= 0) then + ! + ! -- estimate initial end points + en1 = DZERO + if (d1 > DEM30) then + if ((tp - hgwf) > DEM30) then + en2 = DP9 * d1 else - qe = qu + qi + qr + qro + qfrommvr + en2 = D1P1 * d1 - (tp - hgwf) end if - qc = qu + qi + qr - qe + qro + qfrommvr + else if ((tp - hgwf) > DEM30) then + en2 = DONE + else + en2 = DP99 * (hgwf - tp) end if ! - ! -- set simulated evaporation and runoff - this%simevap(n) = qe - this%simrunoff(n) = qro - ! - ! -- calculate flow at the middle of the reach and excluding groundwater leakage - qmp = qu + qi + qfrommvr + DHALF * (qr - qe + qro) - qmpsrc = qmp - ! - ! -- calculate stream depth at the midpoint - if (this%iboundpak(n) > 0) then - call this%sfr_calc_reach_depth(n, qmp, d1) + ! -- estimate flow at end points + ! -- end point 1 + if (hgwf > tp) then + call this%sfr_calc_qgwf(n, DZERO, hgwf, qgwf1) + qgwf1 = -qgwf1 + qen1 = qmp - DHALF * qgwf1 else - this%stage(n) = this%sstage(n) - d1 = max(DZERO, this%stage(n) - this%strtop(n)) + qgwf1 = DZERO + qen1 = qmpsrc end if - ! - ! -- calculate sources/sinks for reach excluding groundwater leakage - call this%sfr_calc_qsource(n, d1, qsrc) - ! - ! -- calculate initial reach stage, downstream flow, and groundwater leakage - tp = this%strtop(n) - bt = tp - this%bthick(n) - hsfr = d1 + tp - qd = MAX(qsrc, DZERO) - qgwf = DZERO - ! - ! -- calculate reach conductance for a unit depth of water - ! if equal to zero will skip iterations - call this%sfr_calc_cond(n, d1, cstr) - ! - ! -- set flag to skip iterations - isolve = 1 - if (hsfr <= tp .and. hgwf <= tp) isolve = 0 - if (hgwf <= tp .and. qc < DEM30) isolve = 0 - if (cstr < DEM30) isolve = 0 - if (this%iboundpak(n) < 0) isolve = 0 - ! - ! -- iterate to achieve solution - itersol: if (isolve /= 0) then - ! - ! -- estimate initial end points + if (hgwf > bt) then + call this%sfr_calc_qgwf(n, en2, hgwf, qgwf2) + qgwf2 = -qgwf2 + else + call this%sfr_calc_qgwf(n, en2, bt, qgwf2) + qgwf2 = -qgwf2 + end if + if (qgwf2 > qsrc) qgwf2 = qsrc + ! -- calculate two depths + call this%sfr_calc_reach_depth(n, (qmpsrc - DHALF * qgwf1), d1) + call this%sfr_calc_reach_depth(n, (qmpsrc - DHALF * qgwf2), d2) + ! -- determine roots + if (d1 > DEM30) then + f1 = en1 - d1 + else en1 = DZERO - if (d1 > DEM30) then - if ((tp - hgwf) > DEM30) then - en2 = DP9 * d1 - else - en2 = D1P1 * d1 - (tp - hgwf) - end if - else if ((tp - hgwf) > DEM30) then - en2 = DONE - else - en2 = DP99 * (hgwf - tp) - end if + f1 = en1 - DZERO + end if + if (d2 > DEM30) then + f2 = en2 - d2 + if (f2 < DEM30) en2 = d2 + else + d2 = DZERO + f2 = en2 - DZERO + end if + ! + ! -- iterate to find a solution + dpp = DHALF * (en1 + en2) + dx = dpp + iic = 0 + iic2 = 0 + iic3 = 0 + fhstr1 = DZERO + fhstr2 = DZERO + qgwfp = DZERO + dlhold = DZERO + do i = 1, this%maxsfrit + ibflg = 0 + d1 = dpp + d2 = d1 + DTWO * this%deps + ! -- calculate q at midpoint at both end points + call this%sfr_calc_qman(n, d1, q1) + call this%sfr_calc_qman(n, d2, q2) + ! -- calculate groundwater leakage at both end points + call this%sfr_calc_qgwf(n, d1, hgwf, qgwf1) + qgwf1 = -qgwf1 + call this%sfr_calc_qgwf(n, d2, hgwf, qgwf2) + qgwf2 = -qgwf2 ! - ! -- estimate flow at end points - ! -- end point 1 - if (hgwf > tp) then - call this%sfr_calc_qgwf(n, DZERO, hgwf, qgwf1) - qgwf1 = -qgwf1 - qen1 = qmp - DHALF * qgwf1 - else - qgwf1 = DZERO - qen1 = qmpsrc - end if - if (hgwf > bt) then - call this%sfr_calc_qgwf(n, en2, hgwf, qgwf2) - qgwf2 = -qgwf2 - else - call this%sfr_calc_qgwf(n, en2, bt, qgwf2) - qgwf2 = -qgwf2 - end if - if (qgwf2 > qsrc) qgwf2 = qsrc - ! -- calculate two depths - call this%sfr_calc_reach_depth(n, (qmpsrc-DHALF*qgwf1), d1) - call this%sfr_calc_reach_depth(n, (qmpsrc-DHALF*qgwf2), d2) - ! -- determine roots - if (d1 > DEM30) then - f1 = en1 - d1 - else - en1 = DZERO - f1 = en1 - DZERO - end if - if (d2 > DEM30) then - f2 = en2 - d2 - if (f2 < DEM30) en2 = d2 + if (qgwf1 >= qsrc) then + en2 = dpp + dpp = DHALF * (en1 + en2) + call this%sfr_calc_qgwf(n, dpp, hgwf, qgwfp) + qgwfp = -qgwfp + if (qgwfp > qsrc) qgwfp = qsrc + call this%sfr_calc_reach_depth(n, (qmpsrc - DHALF * qgwfp), dx) + ibflg = 1 else - d2 = DZERO - f2 = en2 - DZERO - end if - ! - ! -- iterate to find a solution - dpp = DHALF * (en1 + en2) - dx = dpp - iic = 0 - iic2 = 0 - iic3 = 0 - fhstr1 = DZERO - fhstr2 = DZERO - qgwfp = DZERO - dlhold = DZERO - do i = 1, this%maxsfrit - ibflg = 0 - d1 = dpp - d2 = d1 + DTWO * this%deps - ! -- calculate q at midpoint at both end points - call this%sfr_calc_qman(n, d1, q1) - call this%sfr_calc_qman(n, d2, q2) - ! -- calculate groundwater leakage at both end points - call this%sfr_calc_qgwf(n, d1, hgwf, qgwf1) - qgwf1 = -qgwf1 - call this%sfr_calc_qgwf(n, d2, hgwf, qgwf2) - qgwf2 = -qgwf2 - ! - if (qgwf1 >= qsrc) then - en2 = dpp - dpp = DHALF * (en1 + en2) - call this%sfr_calc_qgwf(n, dpp, hgwf, qgwfp) - qgwfp = -qgwfp - if (qgwfp > qsrc) qgwfp = qsrc - call this%sfr_calc_reach_depth(n, (qmpsrc-DHALF*qgwfp), dx) - ibflg = 1 + fhstr1 = (qmpsrc - DHALF * qgwf1) - q1 + fhstr2 = (qmpsrc - DHALF * qgwf2) - q2 + end if + ! + if (ibflg == 0) then + derv = DZERO + if (abs(d1 - d2) > DZERO) then + derv = (fhstr1 - fhstr2) / (d1 - d2) + end if + if (abs(derv) > DEM30) then + dlh = -fhstr1 / derv else - fhstr1 = (qmpsrc-DHALF*qgwf1) - q1 - fhstr2 = (qmpsrc-DHALF*qgwf2) - q2 + dlh = DZERO end if + dpp = d1 + dlh ! - if (ibflg == 0) then - derv = DZERO - if (abs(d1-d2) > DZERO) then - derv = (fhstr1-fhstr2) / (d1 - d2) - end if - if (abs(derv) > DEM30) then - dlh = -fhstr1 / derv - else - dlh = DZERO - end if - dpp = d1 + dlh - ! - ! -- updated depth outside of endpoints - use bisection instead - if ((dpp >= en2) .or. (dpp <= en1)) then - if (abs(dlh) > abs(dlhold) .or. dpp < DEM30) then - ibflg = 1 - dpp = DHALF * (en1 + en2) - end if - end if - ! - ! -- check for slow convergence - ! -- set flags to determine if the Newton-Raphson method oscillates - ! or if convergence is slow - if (qgwf1*qgwfold < DEM30) then - iic2 = iic2 + 1 - else - iic2 = 0 - end if - if (qgwf1 < DEM30) then - iic3 = iic3 + 1 - else - iic3 = 0 - end if - if (dlh*dlhold < DEM30 .or. ABS(dlh) > ABS(dlhold)) then - iic = iic + 1 - end if - iic4 = 0 - if (iic3 > 7 .and. iic > 12) then - iic4 = 1 - end if - ! - ! -- switch to bisection when the Newton-Raphson method oscillates - ! or when convergence is slow - if (iic2 > 7 .or. iic > 12 .or. iic4 == 1) then + ! -- updated depth outside of endpoints - use bisection instead + if ((dpp >= en2) .or. (dpp <= en1)) then + if (abs(dlh) > abs(dlhold) .or. dpp < DEM30) then ibflg = 1 dpp = DHALF * (en1 + en2) end if - ! - ! -- Calculate perturbed gwf flow - call this%sfr_calc_qgwf(n, dpp, hgwf, qgwfp) - qgwfp = -qgwfp - if (qgwfp > qsrc) then - qgwfp = qsrc - if (abs(en1-en2) < this%dmaxchg*DEM6) then - call this%sfr_calc_reach_depth(n, (qmpsrc-DHALF*qgwfp), dpp) - end if - end if - call this%sfr_calc_reach_depth(n, (qmpsrc-DHALF*qgwfp), dx) end if ! - ! -- bisection to update end points - fp = dpp - dx - if (ibflg == 1) then - dlh = fp - ! -- change end points - ! -- root is between f1 and fp - if (f1*fp < DZERO) then - en2 = dpp - f2 = fp - ! -- root is between fp and f2 - else - en1 = dpp - f1 = fp - end if - err = min(abs(fp), abs(en2-en1)) + ! -- check for slow convergence + ! -- set flags to determine if the Newton-Raphson method oscillates + ! or if convergence is slow + if (qgwf1 * qgwfold < DEM30) then + iic2 = iic2 + 1 + else + iic2 = 0 + end if + if (qgwf1 < DEM30) then + iic3 = iic3 + 1 else - err = abs(dlh) + iic3 = 0 + end if + if (dlh * dlhold < DEM30 .or. ABS(dlh) > ABS(dlhold)) then + iic = iic + 1 + end if + iic4 = 0 + if (iic3 > 7 .and. iic > 12) then + iic4 = 1 end if ! - ! -- check for convergence and exit if converged - if (err < this%dmaxchg) then - d1 = dpp - qgwf = qgwfp - qd = qsrc - qgwf - exit + ! -- switch to bisection when the Newton-Raphson method oscillates + ! or when convergence is slow + if (iic2 > 7 .or. iic > 12 .or. iic4 == 1) then + ibflg = 1 + dpp = DHALF * (en1 + en2) end if ! - ! -- save iterates - errold = err - dlhold = dlh - if (ibflg == 1) then - qgwfold = qgwfp - else - qgwfold = qgwf1 + ! -- Calculate perturbed gwf flow + call this%sfr_calc_qgwf(n, dpp, hgwf, qgwfp) + qgwfp = -qgwfp + if (qgwfp > qsrc) then + qgwfp = qsrc + if (abs(en1 - en2) < this%dmaxchg * DEM6) then + call this%sfr_calc_reach_depth(n, (qmpsrc - DHALF * qgwfp), dpp) + end if end if + call this%sfr_calc_reach_depth(n, (qmpsrc - DHALF * qgwfp), dx) + end if ! - ! -- end of iteration - end do - end if itersol - - ! -- simple routing option or where depth = 0 and hgwf < bt - if (isolve == 0) then - call this%sfr_calc_qgwf(n, d1, hgwf, qgwf) - qgwf = -qgwf + ! -- bisection to update end points + fp = dpp - dx + if (ibflg == 1) then + dlh = fp + ! -- change end points + ! -- root is between f1 and fp + if (f1 * fp < DZERO) then + en2 = dpp + f2 = fp + ! -- root is between fp and f2 + else + en1 = dpp + f1 = fp + end if + err = min(abs(fp), abs(en2 - en1)) + else + err = abs(dlh) + end if ! - ! -- leakage exceeds inflow - if (qgwf > qsrc) then - d1 = DZERO - call this%sfr_calc_qsource(n, d1, qsrc) - qgwf = qsrc + ! -- check for convergence and exit if converged + if (err < this%dmaxchg) then + d1 = dpp + qgwf = qgwfp + qd = qsrc - qgwf + exit end if - ! -- set qd - qd = qsrc - qgwf - end if - ! - ! -- update sfr stage - hsfr = tp + d1 - ! - ! -- update stored values - if (lupdate) then ! - ! -- save depth and calculate stage - this%depth(n) = d1 - this%stage(n) = hsfr + ! -- save iterates + errold = err + dlhold = dlh + if (ibflg == 1) then + qgwfold = qgwfp + else + qgwfold = qgwf1 + end if ! - ! -- update flows - call this%sfr_update_flows(n, qd, qgwf) - end if + ! -- end of iteration + end do + end if itersol + + ! -- simple routing option or where depth = 0 and hgwf < bt + if (isolve == 0) then + call this%sfr_calc_qgwf(n, d1, hgwf, qgwf) + qgwf = -qgwf ! - ! -- calculate sumleak and sumrch - sumleak = DZERO - sumrch = DZERO - if (this%gwfiss == 0) then - sumleak = qgwf - else - sumleak = qgwf - end if - if (hgwf < bt) then - sumrch = qgwf + ! -- leakage exceeds inflow + if (qgwf > qsrc) then + d1 = DZERO + call this%sfr_calc_qsource(n, d1, qsrc) + qgwf = qsrc end if + ! -- set qd + qd = qsrc - qgwf + end if + ! + ! -- update sfr stage + hsfr = tp + d1 + ! + ! -- update stored values + if (lupdate) then ! - ! -- make final qgwf calculation and obtain - ! gwfhcof and gwfrhs values - call this%sfr_calc_qgwf(n, d1, hgwf, qgwf, gwfhcof, gwfrhs) - ! + ! -- save depth and calculate stage + this%depth(n) = d1 + this%stage(n) = hsfr ! - if (abs(sumleak) > DZERO) then - ! -- stream leakage is not head dependent - if (hgwf < bt) then - rhs = rhs - sumrch + ! -- update flows + call this%sfr_update_flows(n, qd, qgwf) + end if + ! + ! -- calculate sumleak and sumrch + sumleak = DZERO + sumrch = DZERO + if (this%gwfiss == 0) then + sumleak = qgwf + else + sumleak = qgwf + end if + if (hgwf < bt) then + sumrch = qgwf + end if + ! + ! -- make final qgwf calculation and obtain + ! gwfhcof and gwfrhs values + call this%sfr_calc_qgwf(n, d1, hgwf, qgwf, gwfhcof, gwfrhs) + ! + ! + if (abs(sumleak) > DZERO) then + ! -- stream leakage is not head dependent + if (hgwf < bt) then + rhs = rhs - sumrch ! ! -- stream leakage is head dependent - else if ((sumleak-qsrc) < -DEM30) then - if (this%gwfiss == 0) then - rhs = rhs + gwfrhs - sumrch - else - rhs = rhs + gwfrhs - end if - hcof = gwfhcof + else if ((sumleak - qsrc) < -DEM30) then + if (this%gwfiss == 0) then + rhs = rhs + gwfrhs - sumrch + else + rhs = rhs + gwfrhs + end if + hcof = gwfhcof ! ! -- place holder for UZF + else + if (this%gwfiss == 0) then + rhs = rhs - sumleak - sumrch else - if (this%gwfiss == 0) then - rhs = rhs - sumleak - sumrch - else - rhs = rhs - sumleak - end if + rhs = rhs - sumleak end if - ! - ! -- add groundwater leakage - else if (hgwf < bt) then - rhs = rhs - sumrch end if ! - ! -- return - return - end subroutine sfr_solve + ! -- add groundwater leakage + else if (hgwf < bt) then + rhs = rhs - sumrch + end if + ! + ! -- return + return + end subroutine sfr_solve - !> @brief Update flow terms + !> @brief Update flow terms !! - !! Method to update downstream flow and groundwater leakage terms for + !! Method to update downstream flow and groundwater leakage terms for !! a SFR package reach. !! - !< - subroutine sfr_update_flows(this, n, qd, qgwf) - ! -- dummy variables - class(SfrType), intent(inout) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(inout) :: qd !< downstream reach flow - real(DP), intent(in) :: qgwf !< groundwater leakage for reach - ! -- local variables - integer(I4B) :: i - integer(I4B) :: n2 - integer(I4B) :: idiv - integer(I4B) :: jpos - real(DP) :: qdiv - real(DP) :: f - ! - ! -- update reach terms - ! - ! -- save final downstream stream flow - this%dsflow(n) = qd - ! - ! -- save groundwater leakage - this%gwflow(n) = qgwf + !< + subroutine sfr_update_flows(this, n, qd, qgwf) + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(inout) :: qd !< downstream reach flow + real(DP), intent(in) :: qgwf !< groundwater leakage for reach + ! -- local variables + integer(I4B) :: i + integer(I4B) :: n2 + integer(I4B) :: idiv + integer(I4B) :: jpos + real(DP) :: qdiv + real(DP) :: f + ! + ! -- update reach terms + ! + ! -- save final downstream stream flow + this%dsflow(n) = qd + ! + ! -- save groundwater leakage + this%gwflow(n) = qgwf + ! + ! -- route downstream flow + if (qd > DZERO) then + ! + ! -- route water to diversions + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) cycle + idiv = this%idiv(i) + if (idiv == 0) cycle + jpos = this%iadiv(n) + idiv - 1 + call this%sfr_calc_div(n, idiv, qd, qdiv) + this%qconn(i) = qdiv + this%divq(jpos) = qdiv + end do ! - ! -- route downstream flow - if (qd > DZERO) then - ! - ! -- route water to diversions - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) cycle - idiv = this%idiv(i) - if (idiv == 0) cycle - jpos = this%iadiv(n) + idiv - 1 - call this%sfr_calc_div(n, idiv, qd, qdiv) - this%qconn(i) = qdiv - this%divq(jpos) = qdiv - end do - ! - ! -- Mover terms: store outflow after diversion loss - ! as qformvr and reduce outflow (qd) - ! by how much was actually sent to the mover - if (this%imover == 1) then - call this%pakmvrobj%accumulate_qformvr(n, qd) - qd = MAX(qd - this%pakmvrobj%get_qtomvr(n), DZERO) - endif - ! - ! -- route remaining water to downstream reaches - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) cycle - if (this%idiv(i) > 0) cycle - n2 = this%ja(i) - f = this%ustrf(n2) / this%ftotnd(n) - this%qconn(i) = qd * f - end do - else - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) cycle - this%qconn(i) = DZERO - end do + ! -- Mover terms: store outflow after diversion loss + ! as qformvr and reduce outflow (qd) + ! by how much was actually sent to the mover + if (this%imover == 1) then + call this%pakmvrobj%accumulate_qformvr(n, qd) + qd = MAX(qd - this%pakmvrobj%get_qtomvr(n), DZERO) end if ! - ! -- return - return - end subroutine sfr_update_flows + ! -- route remaining water to downstream reaches + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) cycle + if (this%idiv(i) > 0) cycle + n2 = this%ja(i) + f = this%ustrf(n2) / this%ftotnd(n) + this%qconn(i) = qd * f + end do + else + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) cycle + this%qconn(i) = DZERO + end do + end if + ! + ! -- return + return + end subroutine sfr_update_flows - !> @brief Calculate downstream flow term + !> @brief Calculate downstream flow term !! !! Method to calculate downstream flow for a SFR package reach. !! - !< - subroutine sfr_calc_qd(this, n, depth, hgwf, qgwf, qd) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - real(DP), intent(in) :: hgwf !< groundwater head in connected GWF cell - real(DP), intent(inout) :: qgwf !< groundwater leakage for reach - real(DP), intent(inout) :: qd !< residual - ! -- local variables - real(DP) :: qsrc - ! - ! -- initialize residual - qd = DZERO - ! - ! -- calculate total water sources excluding groundwater leakage - call this%sfr_calc_qsource(n, depth, qsrc) - ! - ! -- estimate groundwater leakage - call this%sfr_calc_qgwf(n, depth, hgwf, qgwf) - if (-qgwf > qsrc) qgwf = -qsrc - ! - ! -- calculate down stream flow - qd = qsrc + qgwf - ! - ! -- limit downstream flow to a positive value - if (qd < DEM30) qd = DZERO - ! - ! -- return - return - end subroutine sfr_calc_qd + !< + subroutine sfr_calc_qd(this, n, depth, hgwf, qgwf, qd) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + real(DP), intent(in) :: hgwf !< groundwater head in connected GWF cell + real(DP), intent(inout) :: qgwf !< groundwater leakage for reach + real(DP), intent(inout) :: qd !< residual + ! -- local variables + real(DP) :: qsrc + ! + ! -- initialize residual + qd = DZERO + ! + ! -- calculate total water sources excluding groundwater leakage + call this%sfr_calc_qsource(n, depth, qsrc) + ! + ! -- estimate groundwater leakage + call this%sfr_calc_qgwf(n, depth, hgwf, qgwf) + if (-qgwf > qsrc) qgwf = -qsrc + ! + ! -- calculate down stream flow + qd = qsrc + qgwf + ! + ! -- limit downstream flow to a positive value + if (qd < DEM30) qd = DZERO + ! + ! -- return + return + end subroutine sfr_calc_qd - !> @brief Calculate sum of sources + !> @brief Calculate sum of sources !! !! Method to calculate the sum of sources for reach, excluding !! reach leakage, for a SFR package reach. !! - !< - subroutine sfr_calc_qsource(this, n, depth, qsrc) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - real(DP), intent(inout) :: qsrc !< sum of sources for reach - ! -- local variables - real(DP) :: qu - real(DP) :: qi - real(DP) :: qr - real(DP) :: qe - real(DP) :: qro - real(DP) :: qfrommvr - real(DP) :: qt - real(DP) :: a - real(DP) :: ae - ! - ! -- initialize residual - qsrc = DZERO - ! - ! -- calculate flow terms - qu = this%usflow(n) - qi = this%inflow(n) - qro = this%runoff(n) - ! - ! -- calculate rainfall and evap - a = this%calc_surface_area(n) - ae = this%calc_surface_area_wet(n, depth) - qr = this%rain(n) * a - qe = this%evap(n) * a - ! - ! -- calculate mover term - qfrommvr = DZERO - if (this%imover == 1) then - qfrommvr = this%pakmvrobj%get_qfrommvr(n) - endif + !< + subroutine sfr_calc_qsource(this, n, depth, qsrc) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + real(DP), intent(inout) :: qsrc !< sum of sources for reach + ! -- local variables + real(DP) :: qu + real(DP) :: qi + real(DP) :: qr + real(DP) :: qe + real(DP) :: qro + real(DP) :: qfrommvr + real(DP) :: qt + real(DP) :: a + real(DP) :: ae + ! + ! -- initialize residual + qsrc = DZERO + ! + ! -- calculate flow terms + qu = this%usflow(n) + qi = this%inflow(n) + qro = this%runoff(n) + ! + ! -- calculate rainfall and evap + a = this%calc_surface_area(n) + ae = this%calc_surface_area_wet(n, depth) + qr = this%rain(n) * a + qe = this%evap(n) * a + ! + ! -- calculate mover term + qfrommvr = DZERO + if (this%imover == 1) then + qfrommvr = this%pakmvrobj%get_qfrommvr(n) + end if + ! + ! -- calculate down stream flow + qsrc = qu + qi + qr - qe + qro + qfrommvr + ! + ! -- adjust runoff or evaporation if sum of sources is negative + if (qsrc < DZERO) then ! - ! -- calculate down stream flow - qsrc = qu + qi + qr - qe + qro + qfrommvr + ! -- calculate sources without et + qt = qu + qi + qr + qro + qfrommvr ! - ! -- adjust runoff or evaporation if sum of sources is negative - if (qsrc < DZERO) then - ! - ! -- calculate sources without et - qt = qu + qi + qr + qro + qfrommvr - ! - ! -- runoff exceeds sources of water for reach - if (qt < DZERO) then - qro = -(qu + qi + qr + qfrommvr) - qe = DZERO + ! -- runoff exceeds sources of water for reach + if (qt < DZERO) then + qro = -(qu + qi + qr + qfrommvr) + qe = DZERO ! ! -- evaporation exceeds sources of water for reach - else - qe = qu + qi + qr + qro + qfrommvr - end if - qsrc = qu + qi + qr - qe + qro + qfrommvr + else + qe = qu + qi + qr + qro + qfrommvr end if - ! - ! -- return - return - end subroutine sfr_calc_qsource - + qsrc = qu + qi + qr - qe + qro + qfrommvr + end if + ! + ! -- return + return + end subroutine sfr_calc_qsource - !> @brief Calculate streamflow + !> @brief Calculate streamflow !! - !! Method to calculate the streamflow using Manning's equation for a + !! Method to calculate the streamflow using Manning's equation for a !! SFR package reach. !! - !< - subroutine sfr_calc_qman(this, n, depth, qman) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - real(DP), intent(inout) :: qman !< streamflow - ! -- local variables - integer(I4B) :: npts - integer(I4B) :: i0 - integer(I4B) :: i1 - real(DP) :: sat - real(DP) :: derv - real(DP) :: s - real(DP) :: r - real(DP) :: aw - real(DP) :: wp - real(DP) :: rh + !< + subroutine sfr_calc_qman(this, n, depth, qman) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + real(DP), intent(inout) :: qman !< streamflow + ! -- local variables + integer(I4B) :: npts + integer(I4B) :: i0 + integer(I4B) :: i1 + real(DP) :: sat + real(DP) :: derv + real(DP) :: s + real(DP) :: r + real(DP) :: aw + real(DP) :: wp + real(DP) :: rh + ! + ! -- initialize variables + qman = DZERO + ! + ! -- calculate Manning's discharge for non-zero depths + if (depth > DZERO) then + npts = this%ncrosspts(n) ! - ! -- initialize variables - qman = DZERO + ! -- set constant terms for Manning's equation + call sChSmooth(depth, sat, derv) + s = this%slope(n) ! - ! -- calculate Manning's discharge for non-zero depths - if (depth > DZERO) then - npts = this%ncrosspts(n) + ! -- calculate the mannings coefficient that is a + ! function of depth + if (npts > 1) then ! - ! -- set constant terms for Manning's equation - call sChSmooth(depth, sat, derv) - s = this%slope(n) + ! -- get the location of the cross-section data for the reach + i0 = this%iacross(n) + i1 = this%iacross(n + 1) - 1 ! - ! -- calculate the mannings coefficient that is a - ! function of depth - if (npts > 1) then - ! - ! -- get the location of the cross-section data for the reach - i0 = this%iacross(n) - i1 = this%iacross(n + 1) - 1 - ! - ! -- get the Manning's sum of the Manning's discharge - ! for each section - qman = get_mannings_section(npts, & - this%station(i0:i1), & - this%xsheight(i0:i1), & - this%xsrough(i0:i1), & - this%rough(n), & - this%unitconv, & - s, & - depth) + ! -- get the Manning's sum of the Manning's discharge + ! for each section + qman = get_mannings_section(npts, & + this%station(i0:i1), & + this%xsheight(i0:i1), & + this%xsrough(i0:i1), & + this%rough(n), & + this%unitconv, & + s, & + depth) + else + r = this%rough(n) + aw = this%calc_area_wet(n, depth) + wp = this%calc_perimeter_wet(n, depth) + if (wp > DZERO) then + rh = aw / wp else - r = this%rough(n) - aw = this%calc_area_wet(n, depth) - wp = this%calc_perimeter_wet(n, depth) - if (wp > DZERO) then - rh = aw / wp - else - rh = DZERO - end if - qman = this%unitconv * aw * (rh**DTWOTHIRDS) * sqrt(s) / r + rh = DZERO end if - ! - ! -- calculate stream flow - qman = sat * qman + qman = this%unitconv * aw * (rh**DTWOTHIRDS) * sqrt(s) / r end if ! - ! -- return - return - end subroutine sfr_calc_qman - + ! -- calculate stream flow + qman = sat * qman + end if + ! + ! -- return + return + end subroutine sfr_calc_qman - !> @brief Calculate reach-aquifer exchange + !> @brief Calculate reach-aquifer exchange !! !! Method to calculate the reach-aquifer exchange for a SFR package reach. !! The reach-aquifer exchange is relative to the reach. Calculated flow !! is positive if flow is from the aquifer to the reach. !! - !< - subroutine sfr_calc_qgwf(this, n, depth, hgwf, qgwf, gwfhcof, gwfrhs) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - real(DP), intent(in) :: hgwf !< head in GWF cell connected to reach - real(DP), intent(inout) :: qgwf !< reach-aquifer exchange - real(DP), intent(inout), optional :: gwfhcof !< diagonal coefficient term for reach - real(DP), intent(inout), optional :: gwfrhs !< right-hand side term for reach - ! -- local variables - integer(I4B) :: node - real(DP) :: tp - real(DP) :: bt - real(DP) :: hsfr - real(DP) :: htmp - real(DP) :: cond - real(DP) :: sat - real(DP) :: derv - real(DP) :: gwfhcof0 - real(DP) :: gwfrhs0 - ! - ! -- initialize qgwf - qgwf = DZERO - ! - ! -- skip sfr-aquifer exchange in external cells - node = this%igwfnode(n) - if (node < 1) return - ! - ! -- skip sfr-aquifer exchange in inactive cells - if (this%ibound(node) == 0) return - ! - ! -- calculate saturation - call sChSmooth(depth, sat, derv) - ! - ! -- calculate conductance - call this%sfr_calc_cond(n, depth, cond) - ! - ! -- calculate groundwater leakage - tp = this%strtop(n) - bt = tp - this%bthick(n) - hsfr = tp + depth - htmp = hgwf - if (htmp < bt) then - htmp = bt - end if - qgwf = sat * cond * (htmp - hsfr) - gwfrhs0 = -sat * cond * hsfr - gwfhcof0 = -sat * cond - ! - ! Add density contributions, if active - if (this%idense /= 0) then - call this%sfr_calculate_density_exchange(n, hsfr, hgwf, cond, tp, & - qgwf, gwfhcof0, gwfrhs0) - end if - ! - ! -- Set gwfhcof and gwfrhs if present - if (present(gwfhcof)) gwfhcof = gwfhcof0 - if (present(gwfrhs)) gwfrhs = gwfrhs0 - ! - ! -- return - return - end subroutine sfr_calc_qgwf + !< + subroutine sfr_calc_qgwf(this, n, depth, hgwf, qgwf, gwfhcof, gwfrhs) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + real(DP), intent(in) :: hgwf !< head in GWF cell connected to reach + real(DP), intent(inout) :: qgwf !< reach-aquifer exchange + real(DP), intent(inout), optional :: gwfhcof !< diagonal coefficient term for reach + real(DP), intent(inout), optional :: gwfrhs !< right-hand side term for reach + ! -- local variables + integer(I4B) :: node + real(DP) :: tp + real(DP) :: bt + real(DP) :: hsfr + real(DP) :: htmp + real(DP) :: cond + real(DP) :: sat + real(DP) :: derv + real(DP) :: gwfhcof0 + real(DP) :: gwfrhs0 + ! + ! -- initialize qgwf + qgwf = DZERO + ! + ! -- skip sfr-aquifer exchange in external cells + node = this%igwfnode(n) + if (node < 1) return + ! + ! -- skip sfr-aquifer exchange in inactive cells + if (this%ibound(node) == 0) return + ! + ! -- calculate saturation + call sChSmooth(depth, sat, derv) + ! + ! -- calculate conductance + call this%sfr_calc_cond(n, depth, cond) + ! + ! -- calculate groundwater leakage + tp = this%strtop(n) + bt = tp - this%bthick(n) + hsfr = tp + depth + htmp = hgwf + if (htmp < bt) then + htmp = bt + end if + qgwf = sat * cond * (htmp - hsfr) + gwfrhs0 = -sat * cond * hsfr + gwfhcof0 = -sat * cond + ! + ! Add density contributions, if active + if (this%idense /= 0) then + call this%sfr_calculate_density_exchange(n, hsfr, hgwf, cond, tp, & + qgwf, gwfhcof0, gwfrhs0) + end if + ! + ! -- Set gwfhcof and gwfrhs if present + if (present(gwfhcof)) gwfhcof = gwfhcof0 + if (present(gwfrhs)) gwfrhs = gwfrhs0 + ! + ! -- return + return + end subroutine sfr_calc_qgwf - !> @brief Calculate reach-aquifer conductance + !> @brief Calculate reach-aquifer conductance !! !! Method to calculate the reach-aquifer conductance for a SFR package reach. !! - !< - subroutine sfr_calc_cond(this, n, depth, cond) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - real(DP), intent(inout) :: cond !< reach-aquifer conductance - ! -- local variables - integer(I4B) :: node - real(DP) :: wp - ! - ! -- initialize conductance - cond = DZERO - ! - ! -- calculate conductance if GWF cell is active - node = this%igwfnode(n) - if (node > 0) then - if (this%ibound(node) > 0) then - wp = this%calc_perimeter_wet(n, depth) - cond = this%hk(n) * this%length(n) * wp / this%bthick(n) - end if + !< + subroutine sfr_calc_cond(this, n, depth, cond) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + real(DP), intent(inout) :: cond !< reach-aquifer conductance + ! -- local variables + integer(I4B) :: node + real(DP) :: wp + ! + ! -- initialize conductance + cond = DZERO + ! + ! -- calculate conductance if GWF cell is active + node = this%igwfnode(n) + if (node > 0) then + if (this%ibound(node) > 0) then + wp = this%calc_perimeter_wet(n, depth) + cond = this%hk(n) * this%length(n) * wp / this%bthick(n) end if - ! - ! -- return - return - end subroutine sfr_calc_cond - + end if + ! + ! -- return + return + end subroutine sfr_calc_cond - !> @brief Calculate diversion flow + !> @brief Calculate diversion flow !! !! Method to calculate the diversion flow for a diversion connected !! to a SFR package reach. The downstream flow for a reach is passed !! in and adjusted by the diversion flow amount calculated in this !! method. !! - !< - subroutine sfr_calc_div(this, n, i, qd, qdiv) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - integer(I4B), intent(in) :: i !< diversion number in reach - real(DP), intent(inout) :: qd !< remaining downstream flow for reach - real(DP), intent(inout) :: qdiv !< diversion flow for diversion i - ! -- local variables - character (len=10) :: cp - integer(I4B) :: jpos - integer(I4B) :: n2 - real(DP) :: v - ! - ! -- set local variables - jpos = this%iadiv(n) + i - 1 - n2 = this%divreach(jpos) - cp = this%divcprior(jpos) - v = this%divflow(jpos) - ! - ! -- calculate diversion - select case(cp) - ! -- flood diversion - case ('EXCESS') - if (qd < v) then - v = DZERO - else - v = qd - v - end if - ! -- diversion percentage - case ('FRACTION') - v = qd * v - ! -- STR priority algorithm - case ('THRESHOLD') - if (qd < v) then - v = DZERO - end if - ! -- specified diversion - case ('UPTO') - if (v > qd) then - v = qd - end if - case default - v = DZERO - end select - ! - ! -- update upstream from for downstream reaches - qd = qd - v - qdiv = v - ! - ! -- return - return - end subroutine sfr_calc_div + !< + subroutine sfr_calc_div(this, n, i, qd, qdiv) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + integer(I4B), intent(in) :: i !< diversion number in reach + real(DP), intent(inout) :: qd !< remaining downstream flow for reach + real(DP), intent(inout) :: qdiv !< diversion flow for diversion i + ! -- local variables + character(len=10) :: cp + integer(I4B) :: jpos + integer(I4B) :: n2 + real(DP) :: v + ! + ! -- set local variables + jpos = this%iadiv(n) + i - 1 + n2 = this%divreach(jpos) + cp = this%divcprior(jpos) + v = this%divflow(jpos) + ! + ! -- calculate diversion + select case (cp) + ! -- flood diversion + case ('EXCESS') + if (qd < v) then + v = DZERO + else + v = qd - v + end if + ! -- diversion percentage + case ('FRACTION') + v = qd * v + ! -- STR priority algorithm + case ('THRESHOLD') + if (qd < v) then + v = DZERO + end if + ! -- specified diversion + case ('UPTO') + if (v > qd) then + v = qd + end if + case default + v = DZERO + end select + ! + ! -- update upstream from for downstream reaches + qd = qd - v + qdiv = v + ! + ! -- return + return + end subroutine sfr_calc_div - - !> @brief Calculate the depth at the midpoint + !> @brief Calculate the depth at the midpoint !! !! Method to calculate the depth at the midpoint of a reach. !! - !< - subroutine sfr_calc_reach_depth(this, n, q1, d1) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: q1 !< streamflow - real(DP), intent(inout) :: d1 !< stream depth at midpoint of reach - ! -- local variables - real(DP) :: w - real(DP) :: s - real(DP) :: r - real(DP) :: qconst - ! - ! -- initialize slope and roughness - s = this%slope(n) - r = this%rough(n) - ! - ! -- calculate stream depth at the midpoint - if (q1 > DZERO) then - if (this%ncrosspts(n) > 1) then - call this%sfr_calc_xs_depth(n, q1, d1) - else - w = this%station(this%iacross(n)) - qconst = this%unitconv * w * sqrt(s) / r - d1 = (q1 / qconst)**DP6 - end if + !< + subroutine sfr_calc_reach_depth(this, n, q1, d1) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: q1 !< streamflow + real(DP), intent(inout) :: d1 !< stream depth at midpoint of reach + ! -- local variables + real(DP) :: w + real(DP) :: s + real(DP) :: r + real(DP) :: qconst + ! + ! -- initialize slope and roughness + s = this%slope(n) + r = this%rough(n) + ! + ! -- calculate stream depth at the midpoint + if (q1 > DZERO) then + if (this%ncrosspts(n) > 1) then + call this%sfr_calc_xs_depth(n, q1, d1) else - d1 = DZERO + w = this%station(this%iacross(n)) + qconst = this%unitconv * w * sqrt(s) / r + d1 = (q1 / qconst)**DP6 end if - ! - ! -- return - return - end subroutine sfr_calc_reach_depth - + else + d1 = DZERO + end if + ! + ! -- return + return + end subroutine sfr_calc_reach_depth - !> @brief Calculate the depth at the midpoint of a irregular cross-section + !> @brief Calculate the depth at the midpoint of a irregular cross-section !! !! Method to calculate the depth at the midpoint of a reach with a !! irregular cross-section using Newton-Raphson. !! - !< - subroutine sfr_calc_xs_depth(this, n, qrch, d) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: qrch !< streamflow - real(DP), intent(inout) :: d !< stream depth at midpoint of reach - ! -- local variables - integer(I4B) :: iter - real(DP) :: perturbation - real(DP) :: q0 - real(DP) :: q1 - real(DP) :: dq - real(DP) :: derv - real(DP) :: dd - real(DP) :: residual - ! - ! -- initialize variables - perturbation = this%deps * DTWO - d = DZERO - q0 = DZERO + !< + subroutine sfr_calc_xs_depth(this, n, qrch, d) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: qrch !< streamflow + real(DP), intent(inout) :: d !< stream depth at midpoint of reach + ! -- local variables + integer(I4B) :: iter + real(DP) :: perturbation + real(DP) :: q0 + real(DP) :: q1 + real(DP) :: dq + real(DP) :: derv + real(DP) :: dd + real(DP) :: residual + ! + ! -- initialize variables + perturbation = this%deps * DTWO + d = DZERO + q0 = DZERO + residual = q0 - qrch + ! + ! -- Newton-Raphson iteration + nriter: do iter = 1, this%maxsfrit + call this%sfr_calc_qman(n, d + perturbation, q1) + dq = (q1 - q0) + if (dq /= DZERO) then + derv = perturbation / (q1 - q0) + else + derv = DZERO + end if + dd = derv * residual + d = d - dd + call this%sfr_calc_qman(n, d, q0) residual = q0 - qrch ! - ! -- Newton-Raphson iteration - nriter: do iter = 1, this%maxsfrit - call this%sfr_calc_qman(n, d + perturbation, q1) - dq = (q1 - q0) - if (dq /= DZERO) then - derv = perturbation / (q1 - q0) - else - derv = DZERO - end if - dd = derv * residual - d = d - dd - call this%sfr_calc_qman(n, d, q0) - residual = q0 - qrch - ! - ! -- check for convergence - if (abs(dd) < this%dmaxchg) then - exit nriter - end if - end do nriter - ! - ! -- return - return - end subroutine sfr_calc_xs_depth - + ! -- check for convergence + if (abs(dd) < this%dmaxchg) then + exit nriter + end if + end do nriter + ! + ! -- return + return + end subroutine sfr_calc_xs_depth - !> @brief Check reach data + !> @brief Check reach data !! - !! Method to check specified data for a SFR package. This method - !! also creates the tables used to print input data, if this + !! Method to check specified data for a SFR package. This method + !! also creates the tables used to print input data, if this !! option in enabled in the SFR package. !! - !< - subroutine sfr_check_reaches(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - character (len= 5) :: crch - character (len=10) :: cval - character (len=30) :: nodestr - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: text - integer(I4B) :: n - integer(I4B) :: nn - real(DP) :: btgwf - real(DP) :: bt - ! - ! -- setup inputtab tableobj - if (this%iprpak /= 0) then - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC REACH DATA' - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(this%maxbound, 10, this%iout) - text = 'NUMBER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) - text = 'LENGTH' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'WIDTH' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'SLOPE' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'TOP' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'THICKNESS' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'HK' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'ROUGHNESS' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) - text = 'UPSTREAM FRACTION' - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + !< + subroutine sfr_check_reaches(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + character(len=5) :: crch + character(len=10) :: cval + character(len=30) :: nodestr + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: n + integer(I4B) :: nn + real(DP) :: btgwf + real(DP) :: bt + ! + ! -- setup inputtab tableobj + if (this%iprpak /= 0) then + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC REACH DATA' + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(this%maxbound, 10, this%iout) + text = 'NUMBER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) + text = 'LENGTH' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'WIDTH' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'SLOPE' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'TOP' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'THICKNESS' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'HK' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'ROUGHNESS' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + text = 'UPSTREAM FRACTION' + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + end if + ! + ! -- check the reach data for simple errors + do n = 1, this%maxbound + write (crch, '(i5)') n + nn = this%igwfnode(n) + if (nn > 0) then + btgwf = this%dis%bot(nn) + call this%dis%noder_to_string(nn, nodestr) + else + nodestr = 'none' end if - ! - ! -- check the reach data for simple errors - do n = 1, this%maxbound - write(crch, '(i5)') n - nn = this%igwfnode(n) - if (nn > 0) then - btgwf = this%dis%bot(nn) - call this%dis%noder_to_string(nn, nodestr) - else - nodestr = 'none' - end if - ! -- check reach length - if (this%length(n) <= DZERO) then - errmsg = 'Reach ' // crch // ' length must be greater than 0.0.' - call store_error(errmsg) - end if - ! -- check reach width - if (this%width(n) <= DZERO) then - errmsg = 'Reach ' // crch // ' width must be greater than 0.0.' - call store_error(errmsg) - end if - ! -- check reach slope - if (this%slope(n) <= DZERO) then - errmsg = 'Reach ' // crch // ' slope must be greater than 0.0.' - call store_error(errmsg) - end if - ! -- check bed thickness and bed hk for reaches connected to GWF - if (nn > 0) then - bt = this%strtop(n) - this%bthick(n) - if (bt <= btgwf .and. this%icheck /= 0) then - write(cval,'(f10.4)') bt - errmsg = 'Reach ' // crch // ' bed bottom (rtp-rbth =' // & - cval // ') must be greater than the bottom of cell (' // & - nodestr - write(cval,'(f10.4)') btgwf - errmsg = trim(adjustl(errmsg)) // '=' // cval // ').' - call store_error(errmsg) - end if - if (this%hk(n) < DZERO) then - errmsg = 'Reach ' // crch // ' hk must be greater than or equal to 0.0.' - call store_error(errmsg) - end if - end if - ! -- check reach roughness - if (this%rough(n) <= DZERO) then - errmsg = 'Reach ' // crch // " Manning's roughness " // & - 'coefficient must be greater than 0.0.' + ! -- check reach length + if (this%length(n) <= DZERO) then + errmsg = 'Reach '//crch//' length must be greater than 0.0.' + call store_error(errmsg) + end if + ! -- check reach width + if (this%width(n) <= DZERO) then + errmsg = 'Reach '//crch//' width must be greater than 0.0.' + call store_error(errmsg) + end if + ! -- check reach slope + if (this%slope(n) <= DZERO) then + errmsg = 'Reach '//crch//' slope must be greater than 0.0.' + call store_error(errmsg) + end if + ! -- check bed thickness and bed hk for reaches connected to GWF + if (nn > 0) then + bt = this%strtop(n) - this%bthick(n) + if (bt <= btgwf .and. this%icheck /= 0) then + write (cval, '(f10.4)') bt + errmsg = 'Reach '//crch//' bed bottom (rtp-rbth ='// & + cval//') must be greater than the bottom of cell ('// & + nodestr + write (cval, '(f10.4)') btgwf + errmsg = trim(adjustl(errmsg))//'='//cval//').' call store_error(errmsg) end if - ! -- check reach upstream fraction - if (this%ustrf(n) < DZERO) then - errmsg = 'Reach ' // crch // ' upstream fraction must be greater ' // & - 'than or equal to 0.0.' + if (this%hk(n) < DZERO) then + errmsg = 'Reach '//crch//' hk must be greater than or equal to 0.0.' call store_error(errmsg) end if - ! -- write summary of reach information - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - call this%inputtab%add_term(nodestr) - call this%inputtab%add_term(this%length(n)) - call this%inputtab%add_term(this%width(n)) - call this%inputtab%add_term(this%slope(n)) - call this%inputtab%add_term(this%strtop(n)) - call this%inputtab%add_term(this%bthick(n)) - call this%inputtab%add_term(this%hk(n)) - call this%inputtab%add_term(this%rough(n)) - call this%inputtab%add_term(this%ustrf(n)) - end if - end do - ! - ! -- return - return - end subroutine sfr_check_reaches - + end if + ! -- check reach roughness + if (this%rough(n) <= DZERO) then + errmsg = 'Reach '//crch//" Manning's roughness "// & + 'coefficient must be greater than 0.0.' + call store_error(errmsg) + end if + ! -- check reach upstream fraction + if (this%ustrf(n) < DZERO) then + errmsg = 'Reach '//crch//' upstream fraction must be greater '// & + 'than or equal to 0.0.' + call store_error(errmsg) + end if + ! -- write summary of reach information + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + call this%inputtab%add_term(nodestr) + call this%inputtab%add_term(this%length(n)) + call this%inputtab%add_term(this%width(n)) + call this%inputtab%add_term(this%slope(n)) + call this%inputtab%add_term(this%strtop(n)) + call this%inputtab%add_term(this%bthick(n)) + call this%inputtab%add_term(this%hk(n)) + call this%inputtab%add_term(this%rough(n)) + call this%inputtab%add_term(this%ustrf(n)) + end if + end do + ! + ! -- return + return + end subroutine sfr_check_reaches - !> @brief Check connection data + !> @brief Check connection data !! - !! Method to check connection data for a SFR package. This method - !! also creates the tables used to print input data, if this + !! Method to check connection data for a SFR package. This method + !! also creates the tables used to print input data, if this !! option in enabled in the SFR package. !! - !< - subroutine sfr_check_connections(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - logical(LGP) :: lreorder - character (len= 5) :: crch - character (len= 5) :: crch2 - character (len=LINELENGTH) :: text - character (len=LINELENGTH) :: title - integer(I4B) :: n - integer(I4B) :: nn - integer(I4B) :: nc - integer(I4B) :: i - integer(I4B) :: ii - integer(I4B) :: j - integer(I4B) :: ifound - integer(I4B) :: ierr - integer(I4B) :: maxconn - integer(I4B) :: ntabcol - ! - ! -- determine if the reaches have been reordered - lreorder = .FALSE. - do j = 1, this%MAXBOUND - n = this%isfrorder(j) - if (n /= j) then - lreorder = .TRUE. - exit - end if - end do - ! - ! -- write message that the solution order h - if (lreorder) then - write(this%iout, '(/,1x,a)') & - trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') REACH SOLUTION HAS BEEN ' // & - 'REORDERED USING A DAG' - ! - ! -- print table - if (this%iprpak /= 0) then - ! - ! -- reset the input table object - ntabcol = 2 - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') REACH SOLUTION ORDER' - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) - text = 'ORDER' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - ! - ! -- upstream connection data - do j = 1, this%maxbound - n = this%isfrorder(j) - call this%inputtab%add_term(j) - call this%inputtab%add_term(n) - end do - end if + !< + subroutine sfr_check_connections(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + logical(LGP) :: lreorder + character(len=5) :: crch + character(len=5) :: crch2 + character(len=LINELENGTH) :: text + character(len=LINELENGTH) :: title + integer(I4B) :: n + integer(I4B) :: nn + integer(I4B) :: nc + integer(I4B) :: i + integer(I4B) :: ii + integer(I4B) :: j + integer(I4B) :: ifound + integer(I4B) :: ierr + integer(I4B) :: maxconn + integer(I4B) :: ntabcol + ! + ! -- determine if the reaches have been reordered + lreorder = .FALSE. + do j = 1, this%MAXBOUND + n = this%isfrorder(j) + if (n /= j) then + lreorder = .TRUE. + exit end if - ! - ! -- create input table for reach connections data + end do + ! + ! -- write message that the solution order h + if (lreorder) then + write (this%iout, '(/,1x,a)') & + trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') REACH SOLUTION HAS BEEN '// & + 'REORDERED USING A DAG' + ! + ! -- print table if (this%iprpak /= 0) then - ! - ! -- calculate the maximum number of connections - maxconn = 0 - do n = 1, this%maxbound - maxconn = max(maxconn, this%nconnreach(n)) - end do - ntabcol = 1 + maxconn ! ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC REACH CONNECTION DATA' + ntabcol = 2 + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') REACH SOLUTION ORDER' call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'ORDER' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) text = 'REACH' call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do n = 1, maxconn - write(text, '(a,1x,i6)') 'CONN', n - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end do - end if - ! - ! -- check the reach connections for simple errors - ! -- connection check - do n = 1, this%MAXBOUND - write(crch, '(i5)') n - eachconn: do i = this%ia(n) + 1, this%ia(n+1) - 1 - nn = this%ja(i) - write(crch2, '(i5)') nn - ifound = 0 - connreach: do ii = this%ia(nn) + 1, this%ia(nn+1) - 1 - nc = this%ja(ii) - if (nc == n) then - ifound = 1 - exit connreach - end if - end do connreach - if (ifound /= 1) then - errmsg = 'Reach ' // crch // ' is connected to ' // & - 'reach ' // crch2 // ' but reach ' // crch2 // & - ' is not connected to reach ' // crch // '.' - call store_error(errmsg) - end if - end do eachconn ! - ! -- write connection data to the table - if (this%iprpak /= 0) then + ! -- upstream connection data + do j = 1, this%maxbound + n = this%isfrorder(j) + call this%inputtab%add_term(j) call this%inputtab%add_term(n) - do i = this%ia(n) + 1, this%ia(n+1) - 1 - call this%inputtab%add_term(this%ja(i)) - end do - nn = maxconn - this%nconnreach(n) - do i = 1, nn - call this%inputtab%add_term(' ') - end do - end if - end do - ! - ! -- check for incorrect connections between upstream connections - ! - ! -- check upstream connections for each reach - ierr = 0 - do n = 1, this%maxbound - write(crch, '(i5)') n - eachconnv: do i = this%ia(n) + 1, this%ia(n + 1) - 1 - ! - ! -- skip downstream connections - if (this%idir(i) < 0) cycle eachconnv - nn = this%ja(i) - write(crch2, '(i5)') nn - connreachv: do ii = this%ia(nn) + 1, this%ia(nn+1) - 1 - ! -- skip downstream connections - if (this%idir(ii) < 0) cycle connreachv - nc = this%ja(ii) - ! - ! -- if nc == n then that means reach n is an upstream connection for - ! reach nn and reach nn is an upstream connection for reach n - if (nc == n) then - ierr = ierr + 1 - errmsg = 'Reach ' // crch // ' is connected to ' // & - 'reach ' // crch2 // ' but streamflow from reach ' // & - crch // ' to reach ' // crch2 // ' is not permitted.' - call store_error(errmsg) - exit connreachv - end if - end do connreachv - end do eachconnv - end do - ! - ! -- terminate if connectivity errors - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + end do end if + end if + ! + ! -- create input table for reach connections data + if (this%iprpak /= 0) then ! - ! -- check that downstream reaches for a reach are - ! the upstream reaches for the reach + ! -- calculate the maximum number of connections + maxconn = 0 do n = 1, this%maxbound - write(crch, '(i5)') n - eachconnds: do i = this%ia(n) + 1, this%ia(n+1) - 1 - nn = this%ja(i) - if (this%idir(i) > 0) cycle eachconnds - write(crch2, '(i5)') nn - ifound = 0 - connreachds: do ii = this%ia(nn) + 1, this%ia(nn+1) - 1 - nc = this%ja(ii) - if (nc == n) then - if (this%idir(i) /= this%idir(ii)) then - ifound = 1 - end if - exit connreachds - end if - end do connreachds - if (ifound /= 1) then - errmsg = 'Reach ' // crch // ' downstream connected reach ' // & - 'is reach ' // crch2 // ' but reach ' // crch // ' is not' // & - ' the upstream connected reach for reach ' // crch2 // '.' - call store_error(errmsg) - end if - end do eachconnds + maxconn = max(maxconn, this%nconnreach(n)) + end do + ntabcol = 1 + maxconn + ! + ! -- reset the input table object + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC REACH CONNECTION DATA' + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do n = 1, maxconn + write (text, '(a,1x,i6)') 'CONN', n + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) end do + end if + ! + ! -- check the reach connections for simple errors + ! -- connection check + do n = 1, this%MAXBOUND + write (crch, '(i5)') n + eachconn: do i = this%ia(n) + 1, this%ia(n + 1) - 1 + nn = this%ja(i) + write (crch2, '(i5)') nn + ifound = 0 + connreach: do ii = this%ia(nn) + 1, this%ia(nn + 1) - 1 + nc = this%ja(ii) + if (nc == n) then + ifound = 1 + exit connreach + end if + end do connreach + if (ifound /= 1) then + errmsg = 'Reach '//crch//' is connected to '// & + 'reach '//crch2//' but reach '//crch2// & + ' is not connected to reach '//crch//'.' + call store_error(errmsg) + end if + end do eachconn ! - ! -- create input table for upstream and downstream connections + ! -- write connection data to the table if (this%iprpak /= 0) then - ! - ! -- calculate the maximum number of upstream connections - maxconn = 0 - do n = 1, this%maxbound - ii = 0 - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) then - ii = ii + 1 - end if - end do - maxconn = max(maxconn, ii) - end do - ntabcol = 1 + maxconn - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC UPSTREAM REACH ' // & - 'CONNECTION DATA' - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do n = 1, maxconn - write(text, '(a,1x,i6)') 'UPSTREAM CONN', n - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end do - ! - ! -- upstream connection data - do n = 1, this%maxbound - call this%inputtab%add_term(n) - ii = 0 - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) then - call this%inputtab%add_term(this%ja(i)) - ii = ii + 1 - end if - end do - nn = maxconn - ii - do i = 1, nn - call this%inputtab%add_term(' ') - end do - end do - ! - ! -- calculate the maximum number of downstream connections - maxconn = 0 - do n = 1, this%maxbound - ii = 0 - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) < 0) then - ii = ii + 1 - end if - end do - maxconn = max(maxconn, ii) - end do - ntabcol = 1 + maxconn - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC DOWNSTREAM ' // & - 'REACH CONNECTION DATA' - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do n = 1, maxconn - write(text, '(a,1x,i6)') 'DOWNSTREAM CONN', n - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + call this%inputtab%add_term(n) + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + call this%inputtab%add_term(this%ja(i)) end do - ! - ! -- downstream connection data - do n = 1, this%maxbound - call this%inputtab%add_term(n) - ii = 0 - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) < 0) then - call this%inputtab%add_term(this%ja(i)) - ii = ii + 1 - end if - end do - nn = maxconn - ii - do i = 1, nn - call this%inputtab%add_term(' ') - end do + nn = maxconn - this%nconnreach(n) + do i = 1, nn + call this%inputtab%add_term(' ') end do end if - ! - ! -- return - return - end subroutine sfr_check_connections - - - !> @brief Check diversions data - !! - !! Method to check diversion data for a SFR package. This method - !! also creates the tables used to print input data, if this - !! option in enabled in the SFR package. - !! - !< - subroutine sfr_check_diversions(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: text - character (len= 5) :: crch - character (len= 5) :: cdiv - character (len= 5) :: crch2 - character (len=10) :: cprior - integer(I4B) :: maxdiv - integer(I4B) :: n - integer(I4B) :: nn - integer(I4B) :: nc - integer(I4B) :: ii - integer(I4B) :: idiv - integer(I4B) :: ifound - integer(I4B) :: jpos - ! -- format - 10 format('Diversion ',i0,' of reach ',i0, & - ' is invalid or has not been defined.') - ! - ! -- write header - if (this%iprpak /= 0) then - ! - ! -- determine the maximum number of diversions - maxdiv = 0 - do n = 1, this%maxbound - maxdiv = maxdiv + this%ndiv(n) - end do + end do + ! + ! -- check for incorrect connections between upstream connections + ! + ! -- check upstream connections for each reach + ierr = 0 + do n = 1, this%maxbound + write (crch, '(i5)') n + eachconnv: do i = this%ia(n) + 1, this%ia(n + 1) - 1 ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') REACH DIVERSION DATA' - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(maxdiv, 4, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'DIVERSION' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'REACH 2' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CPRIOR' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - end if - ! - ! -- check that diversion data are correct - do n = 1, this%maxbound - if (this%ndiv(n) < 1) cycle - write(crch, '(i5)') n - - do idiv = 1, this%ndiv(n) - ! - ! -- determine diversion index - jpos = this%iadiv(n) + idiv - 1 - ! - ! -- write idiv to cdiv - write(cdiv, '(i5)') idiv - ! - ! - nn = this%divreach(jpos) - write(crch2, '(i5)') nn + ! -- skip downstream connections + if (this%idir(i) < 0) cycle eachconnv + nn = this%ja(i) + write (crch2, '(i5)') nn + connreachv: do ii = this%ia(nn) + 1, this%ia(nn + 1) - 1 + ! -- skip downstream connections + if (this%idir(ii) < 0) cycle connreachv + nc = this%ja(ii) ! - ! -- make sure diversion reach is connected to current reach - ifound = 0 - if (nn < 1 .or. nn > this%maxbound) then - write(errmsg,10) idiv, n + ! -- if nc == n then that means reach n is an upstream connection for + ! reach nn and reach nn is an upstream connection for reach n + if (nc == n) then + ierr = ierr + 1 + errmsg = 'Reach '//crch//' is connected to '// & + 'reach '//crch2//' but streamflow from reach '// & + crch//' to reach '//crch2//' is not permitted.' call store_error(errmsg) - cycle + exit connreachv end if - connreach: do ii = this%ia(nn) + 1, this%ia(nn+1) - 1 - nc = this%ja(ii) - if (nc == n) then - if (this%idir(ii) > 0) then - ifound = 1 - end if - exit connreach + end do connreachv + end do eachconnv + end do + ! + ! -- terminate if connectivity errors + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- check that downstream reaches for a reach are + ! the upstream reaches for the reach + do n = 1, this%maxbound + write (crch, '(i5)') n + eachconnds: do i = this%ia(n) + 1, this%ia(n + 1) - 1 + nn = this%ja(i) + if (this%idir(i) > 0) cycle eachconnds + write (crch2, '(i5)') nn + ifound = 0 + connreachds: do ii = this%ia(nn) + 1, this%ia(nn + 1) - 1 + nc = this%ja(ii) + if (nc == n) then + if (this%idir(i) /= this%idir(ii)) then + ifound = 1 end if - end do connreach - if (ifound /= 1) then - errmsg = 'Reach ' // crch // ' is not a upstream reach for ' // & - 'reach ' // crch2 // ' as a result diversion ' // cdiv // & - ' from reach ' // crch //' to reach ' // crch2 // & - ' is not possible. Check reach connectivity.' - call store_error(errmsg) + exit connreachds end if - ! -- iprior - cprior = this%divcprior(jpos) - ! - ! -- add terms to the table - if (this%iprpak /= 0) then - call this%inputtab%add_term(n) - call this%inputtab%add_term(idiv) - call this%inputtab%add_term(nn) - call this%inputtab%add_term(cprior) + end do connreachds + if (ifound /= 1) then + errmsg = 'Reach '//crch//' downstream connected reach '// & + 'is reach '//crch2//' but reach '//crch//' is not'// & + ' the upstream connected reach for reach '//crch2//'.' + call store_error(errmsg) + end if + end do eachconnds + end do + ! + ! -- create input table for upstream and downstream connections + if (this%iprpak /= 0) then + ! + ! -- calculate the maximum number of upstream connections + maxconn = 0 + do n = 1, this%maxbound + ii = 0 + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) then + ii = ii + 1 end if end do + maxconn = max(maxconn, ii) + end do + ntabcol = 1 + maxconn + ! + ! -- reset the input table object + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC UPSTREAM REACH '// & + 'CONNECTION DATA' + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do n = 1, maxconn + write (text, '(a,1x,i6)') 'UPSTREAM CONN', n + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) end do ! - ! -- return - return - end subroutine sfr_check_diversions - - - !> @brief Check upstream fraction data - !! - !! Method to check upstream fraction data for a SFR package. - !! This method also creates the tables used to print input data, - !! if this option in enabled in the SFR package. - !! - !< - subroutine sfr_check_ustrf(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: text - logical(LGP) :: lcycle - logical(LGP) :: ladd - character (len=5) :: crch - character (len=5) :: crch2 - character (len=10) :: cval - integer(I4B) :: maxcols - integer(I4B) :: npairs - integer(I4B) :: ipair - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: n2 - integer(I4B) :: idiv - integer(I4B) :: i0 - integer(I4B) :: i1 - integer(I4B) :: jpos - integer(I4B) :: ids - real(DP) :: f - real(DP) :: rval - ! - ! -- write table header - if (this%iprpak /= 0) then - ! - ! -- determine the maximum number of columns - npairs = 0 - do n = 1, this%maxbound - ipair = 0 - ec: do i = this%ia(n) + 1, this%ia(n+1) - 1 - ! - ! -- skip upstream connections - if (this%idir(i) > 0) cycle ec - n2 = this%ja(i) - ! - ! -- skip inactive downstream reaches - if (this%iboundpak(n2) == 0) cycle ec - ! - ! -- increment ipair and see if it exceeds npairs - ipair = ipair + 1 - npairs = max(npairs, ipair) - end do ec + ! -- upstream connection data + do n = 1, this%maxbound + call this%inputtab%add_term(n) + ii = 0 + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) then + call this%inputtab%add_term(this%ja(i)) + ii = ii + 1 + end if end do - maxcols = 1 + npairs * 2 - ! - ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') CONNECTED REACH UPSTREAM ' // & - 'FRACTION DATA' - call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(this%maxbound, maxcols, this%iout) - text = 'REACH' - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - do i = 1, npairs - write(cval, '(i10)') i - text = 'DOWNSTREAM REACH ' // trim(adjustl(cval)) - call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'FRACTION ' // trim(adjustl(cval)) - call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + nn = maxconn - ii + do i = 1, nn + call this%inputtab%add_term(' ') end do - end if + end do ! - ! -- fill diversion number for each connection + ! -- calculate the maximum number of downstream connections + maxconn = 0 do n = 1, this%maxbound - do idiv = 1, this%ndiv(n) - i0 = this%iadiv(n) - i1 = this%iadiv(n+1) - 1 - do jpos = i0, i1 - do i = this%ia(n) + 1, this%ia(n+1) - 1 - n2 = this%ja(i) - if (this%divreach(jpos) == n2) then - this%idiv(i) = jpos - i0 + 1 - exit - end if - end do - end do + ii = 0 + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) < 0) then + ii = ii + 1 + end if end do + maxconn = max(maxconn, ii) + end do + ntabcol = 1 + maxconn + ! + ! -- reset the input table object + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC DOWNSTREAM '// & + 'REACH CONNECTION DATA' + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(this%maxbound, ntabcol, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do n = 1, maxconn + write (text, '(a,1x,i6)') 'DOWNSTREAM CONN', n + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) end do ! - ! -- check that the upstream fraction for reach connected by - ! a diversion is zero + ! -- downstream connection data do n = 1, this%maxbound - ! - ! -- determine the number of downstream reaches - ids = 0 - do i = this%ia(n) + 1, this%ia(n+1) - 1 + call this%inputtab%add_term(n) + ii = 0 + do i = this%ia(n) + 1, this%ia(n + 1) - 1 if (this%idir(i) < 0) then - ids = ids + 1 + call this%inputtab%add_term(this%ja(i)) + ii = ii + 1 end if end do - ! - ! -- evaluate the diversions - do idiv = 1, this%ndiv(n) - jpos = this%iadiv(n) + idiv - 1 - n2 = this%divreach(jpos) - f = this%ustrf(n2) - if (f /= DZERO) then - write(errmsg, '(a,2(1x,i0,1x,a),1x,a,g0,a,2(1x,a))') & - 'Reach', n, 'is connected to reach', n2, 'by a diversion', & - 'but the upstream fraction is not equal to zero (', f, '). Check', & - trim(this%packName), 'package diversion and package data.' - if (ids > 1) then - call store_error(errmsg) - else - write(warnmsg, '(a,3(1x,a))') & - trim(warnmsg), 'A warning instead of an error is issued because', & - 'the reach is only connected to the diversion reach in the ', & - 'downstream direction.' - call store_warning(warnmsg) - end if - end if + nn = maxconn - ii + do i = 1, nn + call this%inputtab%add_term(' ') end do end do + end if + ! + ! -- return + return + end subroutine sfr_check_connections + + !> @brief Check diversions data + !! + !! Method to check diversion data for a SFR package. This method + !! also creates the tables used to print input data, if this + !! option in enabled in the SFR package. + !! + !< + subroutine sfr_check_diversions(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + character(len=5) :: crch + character(len=5) :: cdiv + character(len=5) :: crch2 + character(len=10) :: cprior + integer(I4B) :: maxdiv + integer(I4B) :: n + integer(I4B) :: nn + integer(I4B) :: nc + integer(I4B) :: ii + integer(I4B) :: idiv + integer(I4B) :: ifound + integer(I4B) :: jpos + ! -- format +10 format('Diversion ', i0, ' of reach ', i0, & + ' is invalid or has not been defined.') + ! + ! -- write header + if (this%iprpak /= 0) then ! - ! -- calculate the total fraction of connected reaches that are - ! not diversions and check that the sum of upstream fractions - ! is equal to 1 for each reach + ! -- determine the maximum number of diversions + maxdiv = 0 do n = 1, this%maxbound - ids = 0 - rval = DZERO - f = DZERO - write(crch, '(i5)') n + maxdiv = maxdiv + this%ndiv(n) + end do + ! + ! -- reset the input table object + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') REACH DIVERSION DATA' + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(maxdiv, 4, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'DIVERSION' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'REACH 2' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CPRIOR' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + end if + ! + ! -- check that diversion data are correct + do n = 1, this%maxbound + if (this%ndiv(n) < 1) cycle + write (crch, '(i5)') n + + do idiv = 1, this%ndiv(n) + ! + ! -- determine diversion index + jpos = this%iadiv(n) + idiv - 1 + ! + ! -- write idiv to cdiv + write (cdiv, '(i5)') idiv + ! + ! + nn = this%divreach(jpos) + write (crch2, '(i5)') nn + ! + ! -- make sure diversion reach is connected to current reach + ifound = 0 + if (nn < 1 .or. nn > this%maxbound) then + write (errmsg, 10) idiv, n + call store_error(errmsg) + cycle + end if + connreach: do ii = this%ia(nn) + 1, this%ia(nn + 1) - 1 + nc = this%ja(ii) + if (nc == n) then + if (this%idir(ii) > 0) then + ifound = 1 + end if + exit connreach + end if + end do connreach + if (ifound /= 1) then + errmsg = 'Reach '//crch//' is not a upstream reach for '// & + 'reach '//crch2//' as a result diversion '//cdiv// & + ' from reach '//crch//' to reach '//crch2// & + ' is not possible. Check reach connectivity.' + call store_error(errmsg) + end if + ! -- iprior + cprior = this%divcprior(jpos) + ! + ! -- add terms to the table if (this%iprpak /= 0) then call this%inputtab%add_term(n) + call this%inputtab%add_term(idiv) + call this%inputtab%add_term(nn) + call this%inputtab%add_term(cprior) end if + end do + end do + ! + ! -- return + return + end subroutine sfr_check_diversions + + !> @brief Check upstream fraction data + !! + !! Method to check upstream fraction data for a SFR package. + !! This method also creates the tables used to print input data, + !! if this option in enabled in the SFR package. + !! + !< + subroutine sfr_check_ustrf(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + logical(LGP) :: lcycle + logical(LGP) :: ladd + character(len=5) :: crch + character(len=5) :: crch2 + character(len=10) :: cval + integer(I4B) :: maxcols + integer(I4B) :: npairs + integer(I4B) :: ipair + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: n2 + integer(I4B) :: idiv + integer(I4B) :: i0 + integer(I4B) :: i1 + integer(I4B) :: jpos + integer(I4B) :: ids + real(DP) :: f + real(DP) :: rval + ! + ! -- write table header + if (this%iprpak /= 0) then + ! + ! -- determine the maximum number of columns + npairs = 0 + do n = 1, this%maxbound ipair = 0 - eachconn: do i = this%ia(n) + 1, this%ia(n+1) - 1 - lcycle = .FALSE. - ! - ! -- initialize downstream connection q - this%qconn(i) = DZERO + ec: do i = this%ia(n) + 1, this%ia(n + 1) - 1 ! ! -- skip upstream connections - if (this%idir(i) > 0) then - lcycle = .TRUE. - end if + if (this%idir(i) > 0) cycle ec n2 = this%ja(i) ! ! -- skip inactive downstream reaches - if (this%iboundpak(n2) == 0) then - lcycle = .TRUE. - end if - if (lcycle) then - cycle eachconn - end if - ipair = ipair + 1 - write(crch2, '(i5)') n2 - ids = ids + 1 - ladd = .true. - f = f + this%ustrf(n2) - write(cval, '(f10.4)') this%ustrf(n2) + if (this%iboundpak(n2) == 0) cycle ec ! - ! -- write upstream fractions - if (this%iprpak /= 0) then - call this%inputtab%add_term(n2) - call this%inputtab%add_term(this%ustrf(n2)) - end if - eachdiv: do idiv = 1, this%ndiv(n) - jpos = this%iadiv(n) + idiv - 1 + ! -- increment ipair and see if it exceeds npairs + ipair = ipair + 1 + npairs = max(npairs, ipair) + end do ec + end do + maxcols = 1 + npairs * 2 + ! + ! -- reset the input table object + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') CONNECTED REACH UPSTREAM '// & + 'FRACTION DATA' + call table_cr(this%inputtab, this%packName, title) + call this%inputtab%table_df(this%maxbound, maxcols, this%iout) + text = 'REACH' + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + do i = 1, npairs + write (cval, '(i10)') i + text = 'DOWNSTREAM REACH '//trim(adjustl(cval)) + call this%inputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'FRACTION '//trim(adjustl(cval)) + call this%inputtab%initialize_column(text, 12, alignment=TABCENTER) + end do + end if + ! + ! -- fill diversion number for each connection + do n = 1, this%maxbound + do idiv = 1, this%ndiv(n) + i0 = this%iadiv(n) + i1 = this%iadiv(n + 1) - 1 + do jpos = i0, i1 + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + n2 = this%ja(i) if (this%divreach(jpos) == n2) then - ladd = .false. - exit eachdiv + this%idiv(i) = jpos - i0 + 1 + exit end if - end do eachdiv - if (ladd) then - rval = rval + this%ustrf(n2) + end do + end do + end do + end do + ! + ! -- check that the upstream fraction for reach connected by + ! a diversion is zero + do n = 1, this%maxbound + ! + ! -- determine the number of downstream reaches + ids = 0 + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) < 0) then + ids = ids + 1 + end if + end do + ! + ! -- evaluate the diversions + do idiv = 1, this%ndiv(n) + jpos = this%iadiv(n) + idiv - 1 + n2 = this%divreach(jpos) + f = this%ustrf(n2) + if (f /= DZERO) then + write (errmsg, '(a,2(1x,i0,1x,a),1x,a,g0,a,2(1x,a))') & + 'Reach', n, 'is connected to reach', n2, 'by a diversion', & + 'but the upstream fraction is not equal to zero (', f, '). Check', & + trim(this%packName), 'package diversion and package data.' + if (ids > 1) then + call store_error(errmsg) + else + write (warnmsg, '(a,3(1x,a))') & + trim(warnmsg), & + 'A warning instead of an error is issued because', & + 'the reach is only connected to the diversion reach in the ', & + 'downstream direction.' + call store_warning(warnmsg) end if - end do eachconn - this%ftotnd(n) = rval + end if + end do + end do + ! + ! -- calculate the total fraction of connected reaches that are + ! not diversions and check that the sum of upstream fractions + ! is equal to 1 for each reach + do n = 1, this%maxbound + ids = 0 + rval = DZERO + f = DZERO + write (crch, '(i5)') n + if (this%iprpak /= 0) then + call this%inputtab%add_term(n) + end if + ipair = 0 + eachconn: do i = this%ia(n) + 1, this%ia(n + 1) - 1 + lcycle = .FALSE. + ! + ! -- initialize downstream connection q + this%qconn(i) = DZERO + ! + ! -- skip upstream connections + if (this%idir(i) > 0) then + lcycle = .TRUE. + end if + n2 = this%ja(i) + ! + ! -- skip inactive downstream reaches + if (this%iboundpak(n2) == 0) then + lcycle = .TRUE. + end if + if (lcycle) then + cycle eachconn + end if + ipair = ipair + 1 + write (crch2, '(i5)') n2 + ids = ids + 1 + ladd = .true. + f = f + this%ustrf(n2) + write (cval, '(f10.4)') this%ustrf(n2) ! - ! -- write remaining table columns + ! -- write upstream fractions if (this%iprpak /= 0) then - ipair = ipair + 1 - do i = ipair, npairs - call this%inputtab%add_term(' ') - call this%inputtab%add_term(' ') - end do + call this%inputtab%add_term(n2) + call this%inputtab%add_term(this%ustrf(n2)) end if - ! - ! -- evaluate if an error condition has occured - ! the sum of fractions is not equal to 1 - if (ids /= 0) then - if (abs(f-DONE) > DEM6) then - write(errmsg, '(a,1x,i0,1x,a,g0,a,3(1x,a))') & - 'Upstream fractions for reach ', n, 'is not equal to one (', f, & - '). Check', trim(this%packName), 'package reach connectivity and', & - 'package data.' - call store_error(errmsg) + eachdiv: do idiv = 1, this%ndiv(n) + jpos = this%iadiv(n) + idiv - 1 + if (this%divreach(jpos) == n2) then + ladd = .false. + exit eachdiv end if + end do eachdiv + if (ladd) then + rval = rval + this%ustrf(n2) end if - end do + end do eachconn + this%ftotnd(n) = rval ! - ! -- return - return - end subroutine sfr_check_ustrf - + ! -- write remaining table columns + if (this%iprpak /= 0) then + ipair = ipair + 1 + do i = ipair, npairs + call this%inputtab%add_term(' ') + call this%inputtab%add_term(' ') + end do + end if + ! + ! -- evaluate if an error condition has occured + ! the sum of fractions is not equal to 1 + if (ids /= 0) then + if (abs(f - DONE) > DEM6) then + write (errmsg, '(a,1x,i0,1x,a,g0,a,3(1x,a))') & + 'Upstream fractions for reach ', n, 'is not equal to one (', f, & + '). Check', trim(this%packName), 'package reach connectivity and', & + 'package data.' + call store_error(errmsg) + end if + end if + end do + ! + ! -- return + return + end subroutine sfr_check_ustrf - !> @brief Setup budget object for package + !> @brief Setup budget object for package !! !! Method to set up the budget object that stores all the sfr flows - !! The terms listed here must correspond in number and order to the ones + !! The terms listed here must correspond in number and order to the ones !! listed in the sfr_fill_budobj method. !! - !< - subroutine sfr_setup_budobj(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - integer(I4B) :: nbudterm - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: n1 - integer(I4B) :: n2 - integer(I4B) :: maxlist - integer(I4B) :: naux - integer(I4B) :: idx - real(DP) :: q - character(len=LENBUDTXT) :: text - character(len=LENBUDTXT), dimension(1) :: auxtxt - ! - ! -- Determine the number of sfr budget terms. These are fixed for - ! the simulation and cannot change. This includes FLOW-JA-FACE - ! so they can be written to the binary budget files, but these internal - ! flows are not included as part of the budget table. - nbudterm = 8 - if (this%imover == 1) nbudterm = nbudterm + 2 - if (this%naux > 0) nbudterm = nbudterm + 1 - ! - ! -- set up budobj - call budgetobject_cr(this%budobj, this%packName) - call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0, & - ibudcsv=this%ibudcsv) - idx = 0 - ! - ! -- Go through and set up each budget term - text = ' FLOW-JA-FACE' - idx = idx + 1 - maxlist = this%nconn - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux, auxtxt) - ! - ! -- store connectivity - call this%budobj%budterm(idx)%reset(this%nconn) - q = DZERO - do n = 1, this%maxbound - n1 = n - do i = this%ia(n) + 1, this%ia(n+1) - 1 - n2 = this%ja(i) - call this%budobj%budterm(idx)%update_term(n1, n2, q) - end do - end do - ! - ! -- - text = ' GWF' - idx = idx + 1 - maxlist = this%maxbound - this%ianynone - naux = 1 - auxtxt(1) = ' FLOW-AREA' - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%name_model, & - maxlist, .false., .true., & - naux, auxtxt) - call this%budobj%budterm(idx)%reset(this%maxbound) - q = DZERO - do n = 1, this%maxbound - n2 = this%igwfnode(n) - if (n2 > 0) then - call this%budobj%budterm(idx)%update_term(n, n2, q) - end if + !< + subroutine sfr_setup_budobj(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + integer(I4B) :: nbudterm + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: n1 + integer(I4B) :: n2 + integer(I4B) :: maxlist + integer(I4B) :: naux + integer(I4B) :: idx + real(DP) :: q + character(len=LENBUDTXT) :: text + character(len=LENBUDTXT), dimension(1) :: auxtxt + ! + ! -- Determine the number of sfr budget terms. These are fixed for + ! the simulation and cannot change. This includes FLOW-JA-FACE + ! so they can be written to the binary budget files, but these internal + ! flows are not included as part of the budget table. + nbudterm = 8 + if (this%imover == 1) nbudterm = nbudterm + 2 + if (this%naux > 0) nbudterm = nbudterm + 1 + ! + ! -- set up budobj + call budgetobject_cr(this%budobj, this%packName) + call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0, & + ibudcsv=this%ibudcsv) + idx = 0 + ! + ! -- Go through and set up each budget term + text = ' FLOW-JA-FACE' + idx = idx + 1 + maxlist = this%nconn + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux, auxtxt) + ! + ! -- store connectivity + call this%budobj%budterm(idx)%reset(this%nconn) + q = DZERO + do n = 1, this%maxbound + n1 = n + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + n2 = this%ja(i) + call this%budobj%budterm(idx)%update_term(n1, n2, q) end do + end do + ! + ! -- + text = ' GWF' + idx = idx + 1 + maxlist = this%maxbound - this%ianynone + naux = 1 + auxtxt(1) = ' FLOW-AREA' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%name_model, & + maxlist, .false., .true., & + naux, auxtxt) + call this%budobj%budterm(idx)%reset(this%maxbound) + q = DZERO + do n = 1, this%maxbound + n2 = this%igwfnode(n) + if (n2 > 0) then + call this%budobj%budterm(idx)%update_term(n, n2, q) + end if + end do + ! + ! -- + text = ' RAINFALL' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EVAPORATION' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' RUNOFF' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-INFLOW' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-OUTFLOW' + idx = idx + 1 + maxlist = this%maxbound + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' STORAGE' + idx = idx + 1 + maxlist = this%maxbound + naux = 1 + auxtxt(1) = ' VOLUME' + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux, auxtxt) + ! + ! -- + if (this%imover == 1) then ! - ! -- - text = ' RAINFALL' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EVAPORATION' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' RUNOFF' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EXT-INFLOW' + ! -- + text = ' FROM-MVR' idx = idx + 1 maxlist = this%maxbound naux = 0 call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' EXT-OUTFLOW' + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' TO-MVR' idx = idx + 1 maxlist = this%maxbound naux = 0 call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + ! + ! -- + naux = this%naux + if (naux > 0) then ! - ! -- - text = ' STORAGE' + ! -- + text = ' AUXILIARY' idx = idx + 1 maxlist = this%maxbound - naux = 1 - auxtxt(1) = ' VOLUME' call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux, auxtxt) - ! - ! -- - if (this%imover == 1) then - ! - ! -- - text = ' FROM-MVR' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! - ! -- - text = ' TO-MVR' - idx = idx + 1 - maxlist = this%maxbound - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - end if - ! - ! -- - naux = this%naux - if (naux > 0) then - ! - ! -- - text = ' AUXILIARY' - idx = idx + 1 - maxlist = this%maxbound - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux, this%auxname) - end if - ! - ! -- if sfr flow for each reach are written to the listing file - if (this%iprflow /= 0) then - call this%budobj%flowtable_df(this%iout, cellids='GWF') - end if - ! - ! -- return - return - end subroutine sfr_setup_budobj + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux, this%auxname) + end if + ! + ! -- if sfr flow for each reach are written to the listing file + if (this%iprflow /= 0) then + call this%budobj%flowtable_df(this%iout, cellids='GWF') + end if + ! + ! -- return + return + end subroutine sfr_setup_budobj - !> @brief Copy flow terms into budget object for package + !> @brief Copy flow terms into budget object for package !! !! Method to copy flows into the budget object that stores all the sfr flows - !! The terms listed here must correspond in number and order to the ones + !! The terms listed here must correspond in number and order to the ones !! added in the sfr_setup_budobj method. !! - !< - subroutine sfr_fill_budobj(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - integer(I4B) :: naux - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: n1 - integer(I4B) :: n2 - integer(I4B) :: ii - integer(I4B) :: idx - integer(I4B) :: idiv - integer(I4B) :: jpos - real(DP) :: q - real(DP) :: qt - real(DP) :: d - real(DP) :: ca - real(DP) :: a - ! - ! -- initialize counter - idx = 0 - ! - ! -- FLOW JA FACE - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%nconn) - do n = 1, this%maxbound - n1 = n - do i = this%ia(n) + 1, this%ia(n+1) - 1 - n2 = this%ja(i) - ! flow to downstream reaches - if (this%idir(i) < 0) then - qt = this%dsflow(n) - q = -this%qconn(i) + !< + subroutine sfr_fill_budobj(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + integer(I4B) :: naux + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: n1 + integer(I4B) :: n2 + integer(I4B) :: ii + integer(I4B) :: idx + integer(I4B) :: idiv + integer(I4B) :: jpos + real(DP) :: q + real(DP) :: qt + real(DP) :: d + real(DP) :: ca + real(DP) :: a + ! + ! -- initialize counter + idx = 0 + ! + ! -- FLOW JA FACE + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%nconn) + do n = 1, this%maxbound + n1 = n + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + n2 = this%ja(i) + ! flow to downstream reaches + if (this%idir(i) < 0) then + qt = this%dsflow(n) + q = -this%qconn(i) ! flow from upstream reaches - else - qt = this%usflow(n) - do ii = this%ia(n2) + 1, this%ia(n2+1) - 1 - if (this%idir(ii) > 0) cycle - if (this%ja(ii) /= n) cycle - q = this%qconn(ii) - exit - end do - end if - ! calculate flow area - call this%sfr_calc_reach_depth(n, qt, d) - ca = this%calc_area_wet(n, d) - this%qauxcbc(1) = ca - call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc) - end do - end do - ! - ! -- GWF (LEAKAGE) - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound - this%ianynone) - do n = 1, this%maxbound - n2 = this%igwfnode(n) - if (n2 > 0) then - a = this%calc_surface_area(n) - this%qauxcbc(1) = a - q = -this%gwflow(n) - call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) + else + qt = this%usflow(n) + do ii = this%ia(n2) + 1, this%ia(n2 + 1) - 1 + if (this%idir(ii) > 0) cycle + if (this%ja(ii) /= n) cycle + q = this%qconn(ii) + exit + end do end if + ! calculate flow area + call this%sfr_calc_reach_depth(n, qt, d) + ca = this%calc_area_wet(n, d) + this%qauxcbc(1) = ca + call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc) end do - ! - ! -- RAIN - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound + end do + ! + ! -- GWF (LEAKAGE) + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound - this%ianynone) + do n = 1, this%maxbound + n2 = this%igwfnode(n) + if (n2 > 0) then a = this%calc_surface_area(n) - q = this%rain(n) * a - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- EVAPORATION - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = -this%simevap(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- RUNOFF - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%simrunoff(n) - call this%budobj%budterm(idx)%update_term(n, n, q) + this%qauxcbc(1) = a + q = -this%gwflow(n) + call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc) + end if + end do + ! + ! -- RAIN + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + a = this%calc_surface_area(n) + q = this%rain(n) * a + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- EVAPORATION + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = -this%simevap(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- RUNOFF + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%simrunoff(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- INFLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = this%inflow(n) + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- EXTERNAL OUTFLOW + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = DZERO + do i = this%ia(n) + 1, this%ia(n + 1) - 1 + if (this%idir(i) > 0) cycle + idiv = this%idiv(i) + if (idiv > 0) then + jpos = this%iadiv(n) + idiv - 1 + q = q + this%divq(jpos) + else + q = q + this%qconn(i) + end if end do + q = q - this%dsflow(n) + if (this%imover == 1) then + q = q + this%pakmvrobj%get_qtomvr(n) + end if + call this%budobj%budterm(idx)%update_term(n, n, q) + end do + ! + ! -- STORAGE + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do n = 1, this%maxbound + q = DZERO + d = this%depth(n) + a = this%calc_surface_area_wet(n, d) + this%qauxcbc(1) = a * d + call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) + end do + ! + ! -- MOVER + if (this%imover == 1) then ! - ! -- INFLOW + ! -- FROM MOVER idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) do n = 1, this%maxbound - q = this%inflow(n) + q = this%pakmvrobj%get_qfrommvr(n) call this%budobj%budterm(idx)%update_term(n, n, q) end do ! - ! -- EXTERNAL OUTFLOW + ! -- TO MOVER idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) do n = 1, this%maxbound - q = DZERO - do i = this%ia(n) + 1, this%ia(n+1) - 1 - if (this%idir(i) > 0) cycle - idiv = this%idiv(i) - if (idiv > 0) then - jpos = this%iadiv(n) + idiv - 1 - q = q + this%divq(jpos) - else - q = q + this%qconn(i) - end if - end do - q = q - this%dsflow(n) - if (this%imover == 1) then - q = q + this%pakmvrobj%get_qtomvr(n) + q = this%pakmvrobj%get_qtomvr(n) + if (q > DZERO) then + q = -q end if call this%budobj%budterm(idx)%update_term(n, n, q) end do - ! - ! -- STORAGE + end if + ! + ! -- AUXILIARY VARIABLES + naux = this%naux + if (naux > 0) then idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) do n = 1, this%maxbound q = DZERO - d = this%depth(n) - a = this%calc_surface_area_wet(n, d) - this%qauxcbc(1) = a * d - call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc) + call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) end do + end if + ! + ! --Terms are filled, now accumulate them for this time step + call this%budobj%accumulate_terms() + ! + ! -- return + return + end subroutine sfr_fill_budobj + + !> @brief Setup stage table object for package + !! + !! Method to set up the table object that is used to write the sfr + !! stage data. The terms listed here must correspond in number and + !! order to the ones written to the stage table in the sfr_ot method. + !! + !< + subroutine sfr_setup_tableobj(this) + ! -- dummy variables + class(SfrType) :: this !< SfrType object + ! -- local variables + integer(I4B) :: nterms + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + ! + ! -- setup stage table + if (this%iprhed > 0) then ! - ! -- MOVER - if (this%imover == 1) then - ! - ! -- FROM MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%pakmvrobj%get_qfrommvr(n) - call this%budobj%budterm(idx)%update_term(n, n, q) - end do - ! - ! -- TO MOVER - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = this%pakmvrobj%get_qtomvr(n) - if (q > DZERO) then - q = -q - end if - call this%budobj%budterm(idx)%update_term(n, n, q) - end do + ! -- Determine the number of sfr budget terms. These are fixed for + ! the simulation and cannot change. This includes FLOW-JA-FACE + ! so they can be written to the binary budget files, but these internal + ! flows are not included as part of the budget table. + nterms = 8 + if (this%inamedbound == 1) then + nterms = nterms + 1 end if ! - ! -- AUXILIARY VARIABLES - naux = this%naux - if (naux > 0) then - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do n = 1, this%maxbound - q = DZERO - call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n)) - end do + ! -- set up table title + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STAGES FOR EACH CONTROL VOLUME' + ! + ! -- set up stage tableobj + call table_cr(this%stagetab, this%packName, title) + call this%stagetab%table_df(this%maxbound, nterms, this%iout, & + transient=.TRUE.) + ! + ! -- Go through and set up table budget term + if (this%inamedbound == 1) then + text = 'NAME' + call this%stagetab%initialize_column(text, LENBOUNDNAME, & + alignment=TABLEFT) end if ! - ! --Terms are filled, now accumulate them for this time step - call this%budobj%accumulate_terms() + ! -- reach number + text = 'NUMBER' + call this%stagetab%initialize_column(text, 10, alignment=TABCENTER) ! - ! -- return - return - end subroutine sfr_fill_budobj - - !> @brief Setup stage table object for package - !! - !! Method to set up the table object that is used to write the sfr - !! stage data. The terms listed here must correspond in number and - !! order to the ones written to the stage table in the sfr_ot method. - !! - !< - subroutine sfr_setup_tableobj(this) - ! -- dummy variables - class(SfrType) :: this !< SfrType object - ! -- local variables - integer(I4B) :: nterms - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text + ! -- cellids + text = 'CELLID' + call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) ! - ! -- setup stage table - if (this%iprhed > 0) then - ! - ! -- Determine the number of sfr budget terms. These are fixed for - ! the simulation and cannot change. This includes FLOW-JA-FACE - ! so they can be written to the binary budget files, but these internal - ! flows are not included as part of the budget table. - nterms = 8 - if (this%inamedbound == 1) then - nterms = nterms + 1 - end if - ! - ! -- set up table title - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STAGES FOR EACH CONTROL VOLUME' - ! - ! -- set up stage tableobj - call table_cr(this%stagetab, this%packName, title) - call this%stagetab%table_df(this%maxbound, nterms, this%iout, & - transient=.TRUE.) - ! - ! -- Go through and set up table budget term - if (this%inamedbound == 1) then - text = 'NAME' - call this%stagetab%initialize_column(text, LENBOUNDNAME, alignment=TABLEFT) - end if - ! - ! -- reach number - text = 'NUMBER' - call this%stagetab%initialize_column(text, 10, alignment=TABCENTER) - ! - ! -- cellids - text = 'CELLID' - call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) - ! - ! -- reach stage - text = 'STAGE' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- reach depth - text = 'DEPTH' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- reach width - text = 'WIDTH' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- gwf head - text = 'GWF HEAD' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- streambed conductance - text = 'STREAMBED CONDUCTANCE' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - ! - ! -- streambed gradient - text = 'STREAMBED GRADIENT' - call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) - end if + ! -- reach stage + text = 'STAGE' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- reach depth + text = 'DEPTH' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) ! - ! -- return - return - end subroutine sfr_setup_tableobj - + ! -- reach width + text = 'WIDTH' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- gwf head + text = 'GWF HEAD' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- streambed conductance + text = 'STREAMBED CONDUCTANCE' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- streambed gradient + text = 'STREAMBED GRADIENT' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + end if + ! + ! -- return + return + end subroutine sfr_setup_tableobj - ! -- reach geometry functions + ! -- reach geometry functions - !> @brief Calculate wetted area + !> @brief Calculate wetted area !! !! Function to calculate the wetted area for a SFR package reach. !! - !< - function calc_area_wet(this, n, depth) - ! -- return variable - real(DP) :: calc_area_wet !< wetted area - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - ! -- local variables - integer(I4B) :: npts - integer(I4B) :: i0 - integer(I4B) :: i1 - ! - ! -- Calculate wetted area - npts = this%ncrosspts(n) - i0 = this%iacross(n) - i1 = this%iacross(n + 1) - 1 - if (npts > 1) then - calc_area_wet = get_cross_section_area(npts, this%station(i0:i1), & - this%xsheight(i0:i1), depth) - else - calc_area_wet = this%station(i0) * depth - end if - ! - ! -- return - return - end function calc_area_wet - - - !> @brief Calculate wetted perimeter + !< + function calc_area_wet(this, n, depth) + ! -- return variable + real(DP) :: calc_area_wet !< wetted area + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + ! -- local variables + integer(I4B) :: npts + integer(I4B) :: i0 + integer(I4B) :: i1 + ! + ! -- Calculate wetted area + npts = this%ncrosspts(n) + i0 = this%iacross(n) + i1 = this%iacross(n + 1) - 1 + if (npts > 1) then + calc_area_wet = get_cross_section_area(npts, this%station(i0:i1), & + this%xsheight(i0:i1), depth) + else + calc_area_wet = this%station(i0) * depth + end if + ! + ! -- return + return + end function calc_area_wet + + !> @brief Calculate wetted perimeter !! !! Function to calculate the wetted perimeter for a SFR package reach. !! - !< - function calc_perimeter_wet(this, n, depth) - ! -- return variable - real(DP) :: calc_perimeter_wet !< wetted perimeter - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - ! -- local variables - integer(I4B) :: npts - integer(I4B) :: i0 - integer(I4B) :: i1 - ! - ! -- Calculate wetted perimeter - npts = this%ncrosspts(n) - i0 = this%iacross(n) - i1 = this%iacross(n + 1) - 1 - if (npts > 1) then - calc_perimeter_wet = get_wetted_perimeter(npts, this%station(i0:i1), & - this%xsheight(i0:i1), depth) - else - calc_perimeter_wet = this%station(i0) ! no depth dependence in original implementation - end if - ! - ! -- return - return - end function calc_perimeter_wet + !< + function calc_perimeter_wet(this, n, depth) + ! -- return variable + real(DP) :: calc_perimeter_wet !< wetted perimeter + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + ! -- local variables + integer(I4B) :: npts + integer(I4B) :: i0 + integer(I4B) :: i1 + ! + ! -- Calculate wetted perimeter + npts = this%ncrosspts(n) + i0 = this%iacross(n) + i1 = this%iacross(n + 1) - 1 + if (npts > 1) then + calc_perimeter_wet = get_wetted_perimeter(npts, this%station(i0:i1), & + this%xsheight(i0:i1), depth) + else + calc_perimeter_wet = this%station(i0) ! no depth dependence in original implementation + end if + ! + ! -- return + return + end function calc_perimeter_wet - !> @brief Calculate maximum surface area + !> @brief Calculate maximum surface area !! !! Function to calculate the maximum surface area for a SFR package reach. !! - !< - function calc_surface_area(this, n) - ! -- return variable - real(DP) :: calc_surface_area !< surface area - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - ! -- local variables - integer(I4B) :: npts - integer(I4B) :: i0 - integer(I4B) :: i1 - real(DP) :: top_width - ! - ! -- Calculate surface area - npts = this%ncrosspts(n) - i0 = this%iacross(n) - i1 = this%iacross(n + 1) - 1 - if (npts > 1) then - top_width = get_saturated_topwidth(npts, this%station(i0:i1)) - else - top_width = this%station(i0) - end if - calc_surface_area = top_width * this%length(n) - ! - ! -- return - return - end function calc_surface_area - - !> @brief Calculate wetted surface area + !< + function calc_surface_area(this, n) + ! -- return variable + real(DP) :: calc_surface_area !< surface area + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + ! -- local variables + integer(I4B) :: npts + integer(I4B) :: i0 + integer(I4B) :: i1 + real(DP) :: top_width + ! + ! -- Calculate surface area + npts = this%ncrosspts(n) + i0 = this%iacross(n) + i1 = this%iacross(n + 1) - 1 + if (npts > 1) then + top_width = get_saturated_topwidth(npts, this%station(i0:i1)) + else + top_width = this%station(i0) + end if + calc_surface_area = top_width * this%length(n) + ! + ! -- return + return + end function calc_surface_area + + !> @brief Calculate wetted surface area !! !! Function to calculate the wetted surface area for a SFR package reach. !! - !< - function calc_surface_area_wet(this, n, depth) - ! -- return variable - real(DP) :: calc_surface_area_wet !< wetted surface area - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - ! -- local variables - real(DP) :: top_width - ! - ! -- Calculate wetted surface area - top_width = this%calc_top_width_wet(n, depth) - calc_surface_area_wet = top_width * this%length(n) - ! - ! -- return - return - end function calc_surface_area_wet - - !> @brief Calculate wetted top width + !< + function calc_surface_area_wet(this, n, depth) + ! -- return variable + real(DP) :: calc_surface_area_wet !< wetted surface area + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + ! -- local variables + real(DP) :: top_width + ! + ! -- Calculate wetted surface area + top_width = this%calc_top_width_wet(n, depth) + calc_surface_area_wet = top_width * this%length(n) + ! + ! -- return + return + end function calc_surface_area_wet + + !> @brief Calculate wetted top width !! !! Function to calculate the wetted top width for a SFR package reach. !! - !< - function calc_top_width_wet(this, n, depth) - ! -- return variable - real(DP) :: calc_top_width_wet !< wetted top width - ! -- dummy variables - class(SfrType) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: depth !< reach depth - ! -- local variables - integer(I4B) :: npts - integer(I4B) :: i0 - integer(I4B) :: i1 - real(DP) :: sat - ! - ! -- Calculate wetted top width - npts = this%ncrosspts(n) - i0 = this%iacross(n) - i1 = this%iacross(n + 1) - 1 - sat = sCubicSaturation(DEM5, DZERO, depth, DEM5) - if (npts > 1) then - calc_top_width_wet = sat * get_wetted_topwidth(npts, & - this%station(i0:i1), & - this%xsheight(i0:i1), & - depth) - else - calc_top_width_wet = sat * this%station(i0) - end if - ! - ! -- return - return - end function calc_top_width_wet + !< + function calc_top_width_wet(this, n, depth) + ! -- return variable + real(DP) :: calc_top_width_wet !< wetted top width + ! -- dummy variables + class(SfrType) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: depth !< reach depth + ! -- local variables + integer(I4B) :: npts + integer(I4B) :: i0 + integer(I4B) :: i1 + real(DP) :: sat + ! + ! -- Calculate wetted top width + npts = this%ncrosspts(n) + i0 = this%iacross(n) + i1 = this%iacross(n + 1) - 1 + sat = sCubicSaturation(DEM5, DZERO, depth, DEM5) + if (npts > 1) then + calc_top_width_wet = sat * get_wetted_topwidth(npts, & + this%station(i0:i1), & + this%xsheight(i0:i1), & + depth) + else + calc_top_width_wet = sat * this%station(i0) + end if + ! + ! -- return + return + end function calc_top_width_wet - !> @brief Activate density terms + !> @brief Activate density terms !! !! Method to activate addition of density terms for a SFR package reach. !! - !< - subroutine sfr_activate_density(this) - ! -- modules - use MemoryManagerModule, only: mem_reallocate - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - ! - ! -- Set idense and reallocate denseterms to be of size MAXBOUND - this%idense = 1 - call mem_reallocate(this%denseterms, 3, this%MAXBOUND, 'DENSETERMS', & - this%memoryPath) - do i = 1, this%maxbound - do j = 1, 3 - this%denseterms(j, i) = DZERO - end do + !< + subroutine sfr_activate_density(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + ! + ! -- Set idense and reallocate denseterms to be of size MAXBOUND + this%idense = 1 + call mem_reallocate(this%denseterms, 3, this%MAXBOUND, 'DENSETERMS', & + this%memoryPath) + do i = 1, this%maxbound + do j = 1, 3 + this%denseterms(j, i) = DZERO end do - write(this%iout,'(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR SFR & - &PACKAGE: ' // trim(adjustl(this%packName)) - ! - ! -- return - return - end subroutine sfr_activate_density + end do + write (this%iout, '(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR SFR & + &PACKAGE: '//trim(adjustl(this%packName)) + ! + ! -- return + return + end subroutine sfr_activate_density - !> @brief Calculate density terms + !> @brief Calculate density terms !! - !! Method to galculate groundwater-reach density exchange terms for a + !! Method to galculate groundwater-reach density exchange terms for a !! SFR package reach. !! !! Member variable used here @@ -5567,94 +5581,94 @@ end subroutine sfr_activate_density !! col 2 is relative density of gwf cell (densegwf / denseref) !! col 3 is elevation of gwf cell !! - !< - subroutine sfr_calculate_density_exchange(this, n, stage, head, cond, & - bots, flow, gwfhcof, gwfrhs) - ! -- dummy variables - class(SfrType),intent(inout) :: this !< SfrType object - integer(I4B), intent(in) :: n !< reach number - real(DP), intent(in) :: stage !< reach stage - real(DP), intent(in) :: head !< head in connected GWF cell - real(DP), intent(in) :: cond !< reach conductance - real(DP), intent(in) :: bots !< bottom elevation of reach - real(DP), intent(inout) :: flow !< calculated flow, updated here with density terms - real(DP), intent(inout) :: gwfhcof !< GWF diagonal coefficient, updated here with density terms - real(DP), intent(inout) :: gwfrhs !< GWF right-hand-side value, updated here with density terms - ! -- local variables - real(DP) :: ss - real(DP) :: hh - real(DP) :: havg - real(DP) :: rdensesfr - real(DP) :: rdensegwf - real(DP) :: rdenseavg - real(DP) :: elevsfr - real(DP) :: elevgwf - real(DP) :: elevavg - real(DP) :: d1 - real(DP) :: d2 - logical(LGP) :: stage_below_bot - logical(LGP) :: head_below_bot + !< + subroutine sfr_calculate_density_exchange(this, n, stage, head, cond, & + bots, flow, gwfhcof, gwfrhs) + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + integer(I4B), intent(in) :: n !< reach number + real(DP), intent(in) :: stage !< reach stage + real(DP), intent(in) :: head !< head in connected GWF cell + real(DP), intent(in) :: cond !< reach conductance + real(DP), intent(in) :: bots !< bottom elevation of reach + real(DP), intent(inout) :: flow !< calculated flow, updated here with density terms + real(DP), intent(inout) :: gwfhcof !< GWF diagonal coefficient, updated here with density terms + real(DP), intent(inout) :: gwfrhs !< GWF right-hand-side value, updated here with density terms + ! -- local variables + real(DP) :: ss + real(DP) :: hh + real(DP) :: havg + real(DP) :: rdensesfr + real(DP) :: rdensegwf + real(DP) :: rdenseavg + real(DP) :: elevsfr + real(DP) :: elevgwf + real(DP) :: elevavg + real(DP) :: d1 + real(DP) :: d2 + logical(LGP) :: stage_below_bot + logical(LGP) :: head_below_bot + ! + ! -- Set sfr density to sfr density or gwf density + if (stage >= bots) then + ss = stage + stage_below_bot = .false. + rdensesfr = this%denseterms(1, n) ! sfr rel density + else + ss = bots + stage_below_bot = .true. + rdensesfr = this%denseterms(2, n) ! gwf rel density + end if + ! + ! -- set hh to head or bots + if (head >= bots) then + hh = head + head_below_bot = .false. + rdensegwf = this%denseterms(2, n) ! gwf rel density + else + hh = bots + head_below_bot = .true. + rdensegwf = this%denseterms(1, n) ! sfr rel density + end if + ! + ! -- todo: hack because denseterms not updated in a cf calculation + if (rdensegwf == DZERO) return + ! + ! -- Update flow + if (stage_below_bot .and. head_below_bot) then ! - ! -- Set sfr density to sfr density or gwf density - if (stage >= bots) then - ss = stage - stage_below_bot = .false. - rdensesfr = this%denseterms(1, n) ! sfr rel density - else - ss = bots - stage_below_bot = .true. - rdensesfr = this%denseterms(2, n) ! gwf rel density - end if + ! -- flow is zero, so no terms are updated ! - ! -- set hh to head or bots - if (head >= bots) then - hh = head - head_below_bot = .false. - rdensegwf = this%denseterms(2, n) ! gwf rel density - else - hh = bots - head_below_bot = .true. - rdensegwf = this%denseterms(1, n) ! sfr rel density - end if + else ! - ! -- todo: hack because denseterms not updated in a cf calculation - if (rdensegwf == DZERO) return + ! -- calulate average relative density + rdenseavg = DHALF * (rdensesfr + rdensegwf) ! - ! -- Update flow - if (stage_below_bot .and. head_below_bot) then - ! - ! -- flow is zero, so no terms are updated - ! - else - ! - ! -- calulate average relative density - rdenseavg = DHALF * (rdensesfr + rdensegwf) - ! - ! -- Add contribution of first density term: - ! cond * (denseavg/denseref - 1) * (hgwf - hsfr) - d1 = cond * (rdenseavg - DONE) - gwfhcof = gwfhcof - d1 - gwfrhs = gwfrhs - d1 * ss - d1 = d1 * (hh - ss) - flow = flow + d1 + ! -- Add contribution of first density term: + ! cond * (denseavg/denseref - 1) * (hgwf - hsfr) + d1 = cond * (rdenseavg - DONE) + gwfhcof = gwfhcof - d1 + gwfrhs = gwfrhs - d1 * ss + d1 = d1 * (hh - ss) + flow = flow + d1 + ! + ! -- Add second density term if stage and head not below bottom + if (.not. stage_below_bot .and. .not. head_below_bot) then ! - ! -- Add second density term if stage and head not below bottom - if (.not. stage_below_bot .and. .not. head_below_bot) then - ! - ! -- Add contribution of second density term: - ! cond * (havg - elevavg) * (densegwf - densesfr) / denseref - elevgwf = this%denseterms(3, n) - elevsfr = bots - elevavg = DHALF * (elevsfr + elevgwf) - havg = DHALF * (hh + ss) - d2 = cond * (havg - elevavg) * (rdensegwf - rdensesfr) - gwfrhs = gwfrhs + d2 - flow = flow + d2 - end if + ! -- Add contribution of second density term: + ! cond * (havg - elevavg) * (densegwf - densesfr) / denseref + elevgwf = this%denseterms(3, n) + elevsfr = bots + elevavg = DHALF * (elevsfr + elevgwf) + havg = DHALF * (hh + ss) + d2 = cond * (havg - elevavg) * (rdensegwf - rdensesfr) + gwfrhs = gwfrhs + d2 + flow = flow + d2 end if - ! - ! -- return - return - end subroutine sfr_calculate_density_exchange + end if + ! + ! -- return + return + end subroutine sfr_calculate_density_exchange end module SfrModule diff --git a/src/Model/GroundWaterFlow/gwf3sto8.f90 b/src/Model/GroundWaterFlow/gwf3sto8.f90 index e2ba2d21035..c1e82e3abb2 100644 --- a/src/Model/GroundWaterFlow/gwf3sto8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sto8.f90 @@ -1,14 +1,14 @@ !> @brief This module contains the storage package methods !! !! This module contains the methods used to add the effects of storage -!! on the groundwater flow equation. The contribution of specific +!! on the groundwater flow equation. The contribution of specific !! storage and specific yield can be represented. !! !< module GwfStoModule use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: DZERO, DEM6, DEM4, DHALF, DONE, DTWO, & + use ConstantsModule, only: DZERO, DEM6, DEM4, DHALF, DONE, DTWO, & LENBUDTXT, LINELENGTH use SimVariablesModule, only: errmsg use SimModule, only: store_error, count_errors @@ -26,26 +26,26 @@ module GwfStoModule public :: GwfStoType, sto_cr character(len=LENBUDTXT), dimension(2) :: budtxt = & !< text labels for budget terms - [' STO-SS', ' STO-SY'] + &[' STO-SS', ' STO-SY'] type, extends(NumericalPackageType) :: GwfStoType - integer(I4B), pointer :: istor_coef => null() !< indicates if ss is the storage coefficient - integer(I4B), pointer :: iconf_ss => null() !< indicates if ss is 0 below the top of a layer - integer(I4B), pointer :: iorig_ss => null() !< indicates if the original storage specific storage formulation should be used - integer(I4B), pointer :: iss => null() !< steady state flag: 1 = steady, 0 = transient - integer(I4B), pointer :: iusesy => null() !< flag set if any cell is convertible (0, 1) - integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !< confined (0) or convertible (1) - real(DP), dimension(:), pointer, contiguous :: ss => null() !< specfic storage or storage coefficient - real(DP), dimension(:), pointer, contiguous :: sy => null() !< specific yield - real(DP), dimension(:), pointer, contiguous :: strgss => null() !< vector of specific storage rates - real(DP), dimension(:), pointer, contiguous :: strgsy => null() !< vector of specific yield rates - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - real(DP), pointer :: satomega => null() !< newton-raphson saturation omega - integer(I4B), pointer :: integratechanges => null() !< indicates if mid-simulation ss and sy changes should be integrated via an additional matrix formulation term - integer(I4B), pointer :: intvs => null() !< TVS (time-varying storage) unit number (0 if unused) - type(TvsType), pointer :: tvs => null() !< TVS object - real(DP), dimension(:), pointer, contiguous, private :: oldss => null() !< previous time step specific storage - real(DP), dimension(:), pointer, contiguous, private :: oldsy => null() !< previous time step specific yield + integer(I4B), pointer :: istor_coef => null() !< indicates if ss is the storage coefficient + integer(I4B), pointer :: iconf_ss => null() !< indicates if ss is 0 below the top of a layer + integer(I4B), pointer :: iorig_ss => null() !< indicates if the original storage specific storage formulation should be used + integer(I4B), pointer :: iss => null() !< steady state flag: 1 = steady, 0 = transient + integer(I4B), pointer :: iusesy => null() !< flag set if any cell is convertible (0, 1) + integer(I4B), dimension(:), pointer, contiguous :: iconvert => null() !< confined (0) or convertible (1) + real(DP), dimension(:), pointer, contiguous :: ss => null() !< specfic storage or storage coefficient + real(DP), dimension(:), pointer, contiguous :: sy => null() !< specific yield + real(DP), dimension(:), pointer, contiguous :: strgss => null() !< vector of specific storage rates + real(DP), dimension(:), pointer, contiguous :: strgsy => null() !< vector of specific yield rates + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + real(DP), pointer :: satomega => null() !< newton-raphson saturation omega + integer(I4B), pointer :: integratechanges => null() !< indicates if mid-simulation ss and sy changes should be integrated via an additional matrix formulation term + integer(I4B), pointer :: intvs => null() !< TVS (time-varying storage) unit number (0 if unused) + type(TvsType), pointer :: tvs => null() !< TVS object + real(DP), dimension(:), pointer, contiguous, private :: oldss => null() !< previous time step specific storage + real(DP), dimension(:), pointer, contiguous, private :: oldsy => null() !< previous time step specific yield contains procedure :: sto_ar procedure :: sto_rp @@ -56,7 +56,7 @@ module GwfStoModule procedure :: sto_bd procedure :: sto_save_model_flows procedure :: sto_da - procedure :: allocate_scalars + procedure :: allocate_scalars procedure, private :: allocate_arrays !procedure, private :: register_handlers procedure, private :: read_options @@ -73,10 +73,10 @@ module GwfStoModule !< subroutine sto_cr(stoobj, name_model, inunit, iout) ! -- dummy variables - type(GwfStoType), pointer :: stoobj !< GwfStoType object - character(len=*), intent(in) :: name_model !< name of model - integer(I4B), intent(in) :: inunit !< package input file unit - integer(I4B), intent(in) :: iout !< model listing file unit + type(GwfStoType), pointer :: stoobj !< GwfStoType object + character(len=*), intent(in) :: name_model !< name of model + integer(I4B), intent(in) :: inunit !< package input file unit + integer(I4B), intent(in) :: iout !< model listing file unit ! ! -- Create the object allocate (stoobj) @@ -108,13 +108,13 @@ subroutine sto_ar(this, dis, ibound) use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object - class(DisBaseType), pointer, intent(in) :: dis !< model discretization object - integer(I4B), dimension(:), pointer, contiguous :: ibound !< model ibound array + class(GwfStoType) :: this !< GwfStoType object + class(DisBaseType), pointer, intent(in) :: dis !< model discretization object + integer(I4B), dimension(:), pointer, contiguous :: ibound !< model ibound array ! -- local variables ! -- formats character(len=*), parameter :: fmtsto = & - "(1x,/1x,'STO -- STORAGE PACKAGE, VERSION 1, 5/19/2014', & + "(1x,/1x,'STO -- STORAGE PACKAGE, VERSION 1, 5/19/2014', & &' INPUT READ FROM UNIT ', i0, //)" ! ! --print a message identifying the storage package. @@ -158,7 +158,7 @@ subroutine sto_rp(this) use TdisModule, only: kper, nper implicit none ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object + class(GwfStoType) :: this !< GwfStoType object ! -- local variables integer(I4B) :: ierr logical :: isfound, readss, readsy, endOfBlock @@ -166,16 +166,16 @@ subroutine sto_rp(this) character(len=LINELENGTH) :: line, keyword ! -- formats character(len=*), parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,' FROM LAST STRESS PERIOD')" + &"(1X,/1X,'REUSING ',A,' FROM LAST STRESS PERIOD')" character(len=*), parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + &"('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" ! -- data data css(0)/' TRANSIENT'/ data css(1)/' STEADY-STATE'/ ! ------------------------------------------------------------------------------ ! ! -- Store ss and sy values from end of last stress period if needed - if(this%integratechanges /= 0) then + if (this%integratechanges /= 0) then call this%save_old_ss_sy() end if ! @@ -255,17 +255,17 @@ subroutine sto_ad(this) ! -- modules use TdisModule, only: kstp ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object + class(GwfStoType) :: this !< GwfStoType object ! ! -- Store ss and sy values from end of last time step if needed - if(this%integratechanges /= 0 .and. kstp > 1) then + if (this%integratechanges /= 0 .and. kstp > 1) then call this%save_old_ss_sy() end if ! ! -- TVS - if(this%intvs /= 0) then + if (this%intvs /= 0) then call this%tvs%ad() - endif + end if ! ! -- return return @@ -280,14 +280,14 @@ subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) ! -- modules use TdisModule, only: delt ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object - integer(I4B), intent(in) :: kiter !< outer iteration number - real(DP), intent(in), dimension(:) :: hold !< previous heads - real(DP), intent(in), dimension(:) :: hnew !< current heads - integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution - real(DP), dimension(njasln), intent(inout) :: amat !< A matrix - integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution - real(DP), intent(inout), dimension(:) :: rhs !< right-hand side + class(GwfStoType) :: this !< GwfStoType object + integer(I4B), intent(in) :: kiter !< outer iteration number + real(DP), intent(in), dimension(:) :: hold !< previous heads + real(DP), intent(in), dimension(:) :: hnew !< current heads + integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution + real(DP), dimension(njasln), intent(inout) :: amat !< A matrix + integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution + real(DP), intent(inout), dimension(:) :: rhs !< right-hand side ! -- local variables integer(I4B) :: n integer(I4B) :: idiag @@ -307,7 +307,7 @@ subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) real(DP) :: aterm real(DP) :: rhsterm ! -- formats - character(len=*), parameter :: fmtsperror = & + character(len=*), parameter :: fmtsperror = & &"('DETECTED TIME STEP LENGTH OF ZERO. GWF STORAGE PACKAGE CANNOT BE ', & &'USED UNLESS DELT IS NON-ZERO.')" ! @@ -321,7 +321,7 @@ subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) end if ! ! -- set variables - tled = DONE/delt + tled = DONE / delt ! ! -- loop through and calculate storage contribution to hcof and rhs do n = 1, this%dis%nodes @@ -345,7 +345,7 @@ subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) sc1 = SsCapacity(this%istor_coef, tp, bt, this%dis%area(n), this%ss(n)) rho1 = sc1 * tled ! - if(this%integratechanges /= 0) then + if (this%integratechanges /= 0) then ! -- Integration of storage changes (e.g. when using TVS): ! separate the old (start of time step) and new (end of time step) ! primary storage capacities @@ -375,15 +375,15 @@ subroutine sto_fc(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) sc2 = SyCapacity(this%dis%area(n), this%sy(n)) rho2 = sc2 * tled ! - if(this%integratechanges /= 0) then - ! -- Integration of storage changes (e.g. when using TVS): - ! separate the old (start of time step) and new (end of time step) - ! secondary storage capacities + if (this%integratechanges /= 0) then + ! -- Integration of storage changes (e.g. when using TVS): + ! separate the old (start of time step) and new (end of time step) + ! secondary storage capacities sc2old = SyCapacity(this%dis%area(n), this%oldsy(n)) rho2old = sc2old * tled else - ! -- No integration of storage changes: old and new values are - ! identical => normal MF6 storage formulation + ! -- No integration of storage changes: old and new values are + ! identical => normal MF6 storage formulation rho2old = rho2 end if ! @@ -411,14 +411,14 @@ subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) ! -- modules use TdisModule, only: delt ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object - integer(I4B), intent(in) :: kiter !< outer iteration number - real(DP), intent(in), dimension(:) :: hold !< previous heads - real(DP), intent(in), dimension(:) :: hnew !< current heads - integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution - real(DP), dimension(njasln), intent(inout) :: amat !< A matrix - integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution - real(DP), intent(inout), dimension(:) :: rhs !< right-hand side + class(GwfStoType) :: this !< GwfStoType object + integer(I4B), intent(in) :: kiter !< outer iteration number + real(DP), intent(in), dimension(:) :: hold !< previous heads + real(DP), intent(in), dimension(:) :: hnew !< current heads + integer(I4B), intent(in) :: njasln !< size of the A matrix for the solution + real(DP), dimension(njasln), intent(inout) :: amat !< A matrix + integer(I4B), intent(in), dimension(:) :: idxglo !< global index model to solution + real(DP), intent(inout), dimension(:) :: rhs !< right-hand side ! -- local variables integer(I4B) :: n integer(I4B) :: idiag @@ -440,7 +440,7 @@ subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) if (this%iss /= 0) return ! ! -- set variables - tled = DONE/delt + tled = DONE / delt ! ! -- loop through and calculate storage contribution to hcof and rhs do n = 1, this%dis%nodes @@ -459,8 +459,8 @@ subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) ! -- storage coefficients sc1 = SsCapacity(this%istor_coef, tp, bt, this%dis%area(n), this%ss(n)) sc2 = SyCapacity(this%dis%area(n), this%sy(n)) - rho1 = sc1*tled - rho2 = sc2*tled + rho1 = sc1 * tled + rho2 = sc2 * tled ! ! -- calculate newton terms for specific storage ! and specific yield @@ -477,7 +477,7 @@ subroutine sto_fn(this, kiter, hold, hnew, njasln, amat, idxglo, rhs) drterm = -(rho1 * derv * h) end if amat(idxglo(idiag)) = amat(idxglo(idiag)) + drterm - rhs(n) = rhs(n) + drterm*h + rhs(n) = rhs(n) + drterm * h end if ! ! -- newton terms for specific yield @@ -509,10 +509,10 @@ subroutine sto_cq(this, flowja, hnew, hold) ! -- modules use TdisModule, only: delt ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< connection flows - real(DP), dimension(:), contiguous, intent(in) :: hnew !< current head - real(DP), dimension(:), contiguous, intent(in) :: hold !< previous head + class(GwfStoType) :: this !< GwfStoType object + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< connection flows + real(DP), dimension(:), contiguous, intent(in) :: hnew !< current head + real(DP), dimension(:), contiguous, intent(in) :: hold !< previous head ! -- local variables integer(I4B) :: n integer(I4B) :: idiag @@ -531,7 +531,7 @@ subroutine sto_cq(this, flowja, hnew, hold) real(DP) :: snold real(DP) :: snnew real(DP) :: aterm - real(DP) :: rhsterm + real(DP) :: rhsterm ! ! -- initialize strg arrays do n = 1, this%dis%nodes @@ -543,7 +543,7 @@ subroutine sto_cq(this, flowja, hnew, hold) if (this%iss == 0) then ! ! -- set variables - tled = DONE/delt + tled = DONE / delt ! ! -- Calculate storage change do n = 1, this%dis%nodes @@ -563,9 +563,9 @@ subroutine sto_cq(this, flowja, hnew, hold) ! ! -- primary storage coefficient sc1 = SsCapacity(this%istor_coef, tp, bt, this%dis%area(n), this%ss(n)) - rho1 = sc1*tled + rho1 = sc1 * tled ! - if(this%integratechanges /= 0) then + if (this%integratechanges /= 0) then ! -- Integration of storage changes (e.g. when using TVS): ! separate the old (start of time step) and new (end of time step) ! primary storage capacities @@ -580,8 +580,8 @@ subroutine sto_cq(this, flowja, hnew, hold) ! ! -- calculate specific storage terms and rate call SsTerms(this%iconvert(n), this%iorig_ss, this%iconf_ss, tp, bt, & - rho1, rho1old, snnew, snold, hnew(n), hold(n), & - aterm, rhsterm, rate) + rho1, rho1old, snnew, snold, hnew(n), hold(n), & + aterm, rhsterm, rate) ! ! -- save rate this%strgss(n) = rate @@ -598,7 +598,7 @@ subroutine sto_cq(this, flowja, hnew, hold) sc2 = SyCapacity(this%dis%area(n), this%sy(n)) rho2 = sc2 * tled ! - if(this%integratechanges /= 0) then + if (this%integratechanges /= 0) then ! -- Integration of storage changes (e.g. when using TVS): ! separate the old (start of time step) and new (end of time ! step) secondary storage capacities @@ -638,9 +638,9 @@ subroutine sto_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object - integer(I4B), intent(in) :: isuppress_output !< flag to suppress model output - type(BudgetType), intent(inout) :: model_budget !< model budget object + class(GwfStoType) :: this !< GwfStoType object + integer(I4B), intent(in) :: isuppress_output !< flag to suppress model output + type(BudgetType), intent(inout) :: model_budget !< model budget object ! -- local variables real(DP) :: rin real(DP) :: rout @@ -668,9 +668,9 @@ end subroutine sto_bd !< subroutine sto_save_model_flows(this, icbcfl, icbcun) ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object - integer(I4B), intent(in) :: icbcfl !< flag to output budget data - integer(I4B), intent(in) :: icbcun !< cell-by-cell file unit number + class(GwfStoType) :: this !< GwfStoType object + integer(I4B), intent(in) :: icbcfl !< flag to output budget data + integer(I4B), intent(in) :: icbcun !< cell-by-cell file unit number ! -- local variables integer(I4B) :: ibinun integer(I4B) :: iprint, nvaluesp, nwidthp @@ -718,12 +718,12 @@ subroutine sto_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object + class(GwfStoType) :: this !< GwfStoType object ! ! -- TVS if (this%intvs /= 0) then call this%tvs%da() - deallocate(this%tvs) + deallocate (this%tvs) end if ! ! -- Deallocate arrays if package is active @@ -735,10 +735,10 @@ subroutine sto_da(this) call mem_deallocate(this%strgsy) ! ! -- deallocate TVS arrays - if(associated(this%oldss)) then + if (associated(this%oldss)) then call mem_deallocate(this%oldss) end if - if(associated(this%oldsy)) then + if (associated(this%oldsy)) then call mem_deallocate(this%oldsy) end if end if @@ -769,7 +769,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object + class(GwfStoType) :: this !< GwfStoType object ! ! -- allocate scalars in NumericalPackageType call this%NumericalPackageType%allocate_scalars() @@ -846,25 +846,25 @@ end subroutine allocate_arrays subroutine read_options(this) ! -- modules ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object + class(GwfStoType) :: this !< GwfStoType object ! -- local variables character(len=LINELENGTH) :: keyword, fname integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE "// & - "WHENEVER ICBCFL IS NOT ZERO.')" + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" character(len=*), parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + &"(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" character(len=*), parameter :: fmtorigss = & - "(4X,'ORIGINAL_SPECIFIC_STORAGE OPTION:',/, & + "(4X,'ORIGINAL_SPECIFIC_STORAGE OPTION:',/, & &1X,'The original specific storage formulation will be used')" character(len=*), parameter :: fmtstoc = & - "(4X,'STORAGECOEFFICIENT OPTION:',/, & + "(4X,'STORAGECOEFFICIENT OPTION:',/, & &1X,'Read storage coefficient rather than specific storage')" character(len=*), parameter :: fmtconfss = & - "(4X,'SS_CONFINED_ONLY OPTION:',/, & + "(4X,'SS_CONFINED_ONLY OPTION:',/, & &1X,'Specific storage changes only occur under confined conditions')" ! ! -- get options block @@ -891,25 +891,25 @@ subroutine read_options(this) write (this%iout, fmtconfss) case ('TVS6') if (this%intvs /= 0) then - errmsg = 'Multiple TVS6 keywords detected in OPTIONS block.' // & + errmsg = 'Multiple TVS6 keywords detected in OPTIONS block.'// & ' Only one TVS6 entry allowed.' call store_error(errmsg, terminate=.TRUE.) end if call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TVS6 keyword must be followed by "FILEIN" ' // & + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TVS6 keyword must be followed by "FILEIN" '// & 'then by filename.' call store_error(errmsg, terminate=.TRUE.) - endif + end if call this%parser%GetString(fname) this%intvs = GetUnit() call openfile(this%intvs, this%iout, fname, 'TVS') call tvs_cr(this%tvs, this%name_model, this%intvs, this%iout) - ! - ! -- right now these are options that are only available in the - ! development version and are not included in the documentation. - ! These options are only available when IDEVELOPMODE in - ! constants module is set to 1 + ! + ! -- right now these are options that are only available in the + ! development version and are not included in the documentation. + ! These options are only available when IDEVELOPMODE in + ! constants module is set to 1 case ('DEV_ORIGINAL_SPECIFIC_STORAGE') this%iorig_ss = 1 write (this%iout, fmtorigss) @@ -944,7 +944,7 @@ end subroutine read_options subroutine read_data(this) ! -- modules ! -- dummy variables - class(GwfStotype) :: this !< GwfStoType object + class(GwfStotype) :: this !< GwfStoType object ! -- local variables character(len=LINELENGTH) :: keyword character(len=:), allocatable :: line @@ -1079,15 +1079,15 @@ subroutine save_old_ss_sy(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy variables - class(GwfStoType) :: this !< GwfStoType object + class(GwfStoType) :: this !< GwfStoType object ! -- local variables integer(I4B) :: n ! ! -- Allocate TVS arrays if needed - if(.not. associated(this%oldss)) then + if (.not. associated(this%oldss)) then call mem_allocate(this%oldss, this%dis%nodes, 'OLDSS', this%memoryPath) end if - if(this%iusesy == 1 .and. .not. associated(this%oldsy)) then + if (this%iusesy == 1 .and. .not. associated(this%oldsy)) then call mem_allocate(this%oldsy, this%dis%nodes, 'OLDSY', this%memoryPath) end if ! @@ -1097,7 +1097,7 @@ subroutine save_old_ss_sy(this) end do ! ! -- Save current specific yield, if used - if(this%iusesy == 1) then + if (this%iusesy == 1) then do n = 1, this%dis%nodes this%oldsy(n) = this%sy(n) end do @@ -1106,5 +1106,5 @@ subroutine save_old_ss_sy(this) ! -- Return return end subroutine save_old_ss_sy - + end module GwfStoModule diff --git a/src/Model/GroundWaterFlow/gwf3tvbase8.f90 b/src/Model/GroundWaterFlow/gwf3tvbase8.f90 index 97a3c306d18..0975f3ddfe8 100644 --- a/src/Model/GroundWaterFlow/gwf3tvbase8.f90 +++ b/src/Model/GroundWaterFlow/gwf3tvbase8.f90 @@ -180,7 +180,7 @@ subroutine tvbase_allocate_scalars(this) call this%NumericalPackageType%allocate_scalars() ! ! -- Allocate time series manager - allocate(this%tsmanager) + allocate (this%tsmanager) ! return end subroutine tvbase_allocate_scalars @@ -202,8 +202,8 @@ subroutine ar(this, dis) ! -- Create time series manager call tsmanager_cr(this%tsmanager, & this%iout, & - removeTsLinksOnCompletion = .true., & - extendTsToEndOfSimulation = .true.) + removeTsLinksOnCompletion=.true., & + extendTsToEndOfSimulation=.true.) ! ! -- Read options call this%read_options() @@ -213,7 +213,7 @@ subroutine ar(this, dis) call this%tsmanager%tsmanager_df() ! ! -- Terminate if any errors were encountered - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() call ustop() end if @@ -238,54 +238,54 @@ subroutine read_options(this) integer(I4B) :: ierr ! -- formats character(len=*), parameter :: fmtts = & - "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + &"(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" ! ! -- Get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & blockRequired=.false., supportOpenClose=.true.) ! ! -- Parse options block if detected - if(isfound) then - write(this%iout, '(1x,a)') & - 'PROCESSING ' // trim(adjustl(this%packName)) // ' OPTIONS' + if (isfound) then + write (this%iout, '(1x,a)') & + 'PROCESSING '//trim(adjustl(this%packName))//' OPTIONS' do call this%parser%GetNextLine(endOfBlock) - if(endOfBlock) then + if (endOfBlock) then exit end if call this%parser%GetStringCaps(keyword) select case (keyword) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'TIME-VARYING INPUT WILL BE PRINTED.' - case ('TS6') - ! - ! -- Add a time series file - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = & - 'TS6 keyword must be followed by "FILEIN" then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - call ustop() - end if - call this%parser%GetString(fname) - write(this%iout, fmtts) trim(fname) - call this%tsmanager%add_tsfile(fname, this%inunit) - case default - ! - ! -- Defer to subtype to read the option; - ! -- if the subtype can't handle it, report an error - if(.not. this%read_option(keyword)) then - write(errmsg, '(a,3(1x,a),a)') & - 'Unknown', trim(adjustl(this%packName)), "option '", & - trim(keyword), "'." - call store_error(errmsg) - end if + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'TIME-VARYING INPUT WILL BE PRINTED.' + case ('TS6') + ! + ! -- Add a time series file + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = & + 'TS6 keyword must be followed by "FILEIN" then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + call ustop() + end if + call this%parser%GetString(fname) + write (this%iout, fmtts) trim(fname) + call this%tsmanager%add_tsfile(fname, this%inunit) + case default + ! + ! -- Defer to subtype to read the option; + ! -- if the subtype can't handle it, report an error + if (.not. this%read_option(keyword)) then + write (errmsg, '(a,3(1x,a),a)') & + 'Unknown', trim(adjustl(this%packName)), "option '", & + trim(keyword), "'." + call store_error(errmsg) + end if end select end do - write(this%iout, '(1x,a)') & - 'END OF ' // trim(adjustl(this%packName)) // ' OPTIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%packName))//' OPTIONS' end if ! return @@ -306,40 +306,40 @@ subroutine rp(this) real(DP), pointer :: bndElem => null() ! -- formats character(len=*), parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" character(len=*), parameter :: fmtvalchg = & "(a, ' package: Setting ', a, ' value for cell ', a, ' at start of & &stress period ', i0, ' = ', g12.5)" ! - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- Get stress period data - if(this%ionper < kper) then + if (this%ionper < kper) then ! ! -- Get PERIOD block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- Read ionper and check for increasing period numbers call this%read_check_ionper() else ! ! -- PERIOD block not found - if(ierr < 0) then + if (ierr < 0) then ! -- End of file found; data applies for remainder of simulation. this%ionper = nper + 1 else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) end if end if end if ! ! -- Read data if ionper == kper - if(this%ionper == kper) then + if (this%ionper == kper) then ! ! -- Reset per-node property change flags call this%reset_change_flags() @@ -347,7 +347,7 @@ subroutine rp(this) haveChanges = .false. do call this%parser%GetNextLine(endOfBlock) - if(endOfBlock) then + if (endOfBlock) then exit end if ! @@ -357,8 +357,8 @@ subroutine rp(this) this%iout) ! ! -- Validate cell ID - if(node < 1 .or. node > this%dis%nodes) then - write(errmsg, '(a,2(1x,a))') & + if (node < 1 .or. node > this%dis%nodes) then + write (errmsg, '(a,2(1x,a))') & 'CELLID', cellid, 'is not in the active model domain.' call store_error(errmsg) cycle @@ -370,8 +370,8 @@ subroutine rp(this) ! -- Get a pointer to the property value given by varName for the node ! -- with the specified cell ID bndElem => this%get_pointer_to_value(node, varName) - if(.not. associated(bndElem)) then - write(errmsg, '(a,3(1x,a),a)') & + if (.not. associated(bndElem)) then + write (errmsg, '(a,3(1x,a),a)') & 'Unknown', trim(adjustl(this%packName)), "variable '", & trim(varName), "'." call store_error(errmsg) @@ -387,7 +387,7 @@ subroutine rp(this) ! ! -- Report value change if (this%iprpak /= 0) then - write(this%iout, fmtvalchg) & + write (this%iout, fmtvalchg) & trim(adjustl(this%packName)), trim(varName), trim(cellid), & kper, bndElem end if @@ -399,13 +399,13 @@ subroutine rp(this) ! ! -- Record that any changes were made at the first time step of the ! -- stress period - if(haveChanges) then + if (haveChanges) then call this%set_changed_at(kper, 1) end if end if ! ! -- Terminate if errors were encountered in the PERIOD block - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() call ustop() end if @@ -432,7 +432,7 @@ subroutine ad(this) ! -- If there are no time series property changes, ! -- there is nothing else to be done numlinks = this%tsmanager%CountLinks('BND') - if(numlinks <= 0) then + if (numlinks <= 0) then return end if ! @@ -442,7 +442,7 @@ subroutine ad(this) ! ! -- Reset node K change flags at all time steps except the first of each ! -- period (the first is done in rp(), to allow non-time series changes) - if(kstp /= 1) then + if (kstp /= 1) then call this%reset_change_flags() end if ! @@ -454,7 +454,7 @@ subroutine ad(this) end do ! ! -- Terminate if there were errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() call ustop() end if @@ -472,7 +472,7 @@ subroutine tvbase_da(this) class(TvBaseType) :: this ! ! -- Deallocate time series manager - deallocate(this%tsmanager) + deallocate (this%tsmanager) ! ! -- Deallocate parent call this%NumericalPackageType%da() diff --git a/src/Model/GroundWaterFlow/gwf3tvk8.f90 b/src/Model/GroundWaterFlow/gwf3tvk8.f90 index dbf48309ca4..f7b36571e4a 100644 --- a/src/Model/GroundWaterFlow/gwf3tvk8.f90 +++ b/src/Model/GroundWaterFlow/gwf3tvk8.f90 @@ -23,13 +23,13 @@ module TvkModule public :: tvk_cr type, extends(TvBaseType) :: TvkType - integer(I4B), pointer :: ik22overk => null() !< NPF flag that k22 is specified as anisotropy ratio - integer(I4B), pointer :: ik33overk => null() !< NPF flag that k33 is specified as anisotropy ratio - real(DP), dimension(:), pointer, contiguous :: k11 => null() !< NPF hydraulic conductivity; if anisotropic, then this is Kx prior to rotation - real(DP), dimension(:), pointer, contiguous :: k22 => null() !< NPF hydraulic conductivity; if specified then this is Ky prior to rotation - real(DP), dimension(:), pointer, contiguous :: k33 => null() !< NPF hydraulic conductivity; if specified then this is Kz prior to rotation - integer(I4B), pointer :: kchangeper => null() !< NPF last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) - integer(I4B), pointer :: kchangestp => null() !< NPF last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) + integer(I4B), pointer :: ik22overk => null() !< NPF flag that k22 is specified as anisotropy ratio + integer(I4B), pointer :: ik33overk => null() !< NPF flag that k33 is specified as anisotropy ratio + real(DP), dimension(:), pointer, contiguous :: k11 => null() !< NPF hydraulic conductivity; if anisotropic, then this is Kx prior to rotation + real(DP), dimension(:), pointer, contiguous :: k22 => null() !< NPF hydraulic conductivity; if specified then this is Ky prior to rotation + real(DP), dimension(:), pointer, contiguous :: k33 => null() !< NPF hydraulic conductivity; if specified then this is Kz prior to rotation + integer(I4B), pointer :: kchangeper => null() !< NPF last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) + integer(I4B), pointer :: kchangestp => null() !< NPF last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() !< NPF grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) contains procedure :: da => tvk_da @@ -55,7 +55,7 @@ subroutine tvk_cr(tvk, name_model, inunit, iout) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! - allocate(tvk) + allocate (tvk) call tvk%init(name_model, 'TVK', 'TVK', inunit, iout) ! return @@ -78,7 +78,7 @@ subroutine tvk_ar_set_pointers(this) &' INPUT READ FROM UNIT ', i0, //)" ! ! -- Print a message identifying the TVK package - write(this%iout, fmttvk) this%inunit + write (this%iout, fmttvk) this%inunit ! ! -- Set pointers to other package variables ! -- NPF @@ -129,14 +129,14 @@ function tvk_get_pointer_to_value(this, n, varName) result(bndElem) real(DP), pointer :: bndElem ! select case (varName) - case ('K') - bndElem => this%k11(n) - case ('K22') - bndElem => this%k22(n) - case ('K33') - bndElem => this%k33(n) - case default - bndElem => null() + case ('K') + bndElem => this%k11(n) + case ('K22') + bndElem => this%k22(n) + case ('K33') + bndElem => this%k33(n) + case default + bndElem => null() end select ! return @@ -205,28 +205,31 @@ subroutine tvk_validate_change(this, n, varName) this%nodekchange(n) = 1 ! ! -- Check the changed value is ok - if(varName == 'K') then - if(this%k11(n) <= DZERO) then + if (varName == 'K') then + if (this%k11(n) <= DZERO) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(this%packName)), 'K', trim(cellstr), this%k11(n) + write (errmsg, fmtkerr) & + trim(adjustl(this%packName)), 'K', trim(cellstr), this%k11(n) call store_error(errmsg) end if - elseif(varName == 'K22') then - if(this%ik22overk == 1) then + elseif (varName == 'K22') then + if (this%ik22overk == 1) then this%k22(n) = this%k22(n) * this%k11(n) end if - if(this%k22(n) <= DZERO) then + if (this%k22(n) <= DZERO) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(this%packName)), 'K22', trim(cellstr), this%k22(n) + write (errmsg, fmtkerr) & + trim(adjustl(this%packName)), 'K22', trim(cellstr), this%k22(n) call store_error(errmsg) end if - elseif(varName == 'K33') then - if(this%ik33overk == 1) then + elseif (varName == 'K33') then + if (this%ik33overk == 1) then this%k33(n) = this%k33(n) * this%k33(n) end if - if(this%k33(n) <= DZERO) then + if (this%k33(n) <= DZERO) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtkerr) trim(adjustl(this%packName)), 'K33', trim(cellstr), this%k33(n) + write (errmsg, fmtkerr) & + trim(adjustl(this%packName)), 'K33', trim(cellstr), this%k33(n) call store_error(errmsg) end if end if @@ -244,14 +247,14 @@ subroutine tvk_da(this) class(TvkType) :: this ! ! -- Nullify pointers to other package variables - nullify(this%ik22overk) - nullify(this%ik33overk) - nullify(this%k11) - nullify(this%k22) - nullify(this%k33) - nullify(this%kchangeper) - nullify(this%kchangestp) - nullify(this%nodekchange) + nullify (this%ik22overk) + nullify (this%ik33overk) + nullify (this%k11) + nullify (this%k22) + nullify (this%k33) + nullify (this%kchangeper) + nullify (this%kchangestp) + nullify (this%nodekchange) ! ! -- Deallocate parent call tvbase_da(this) diff --git a/src/Model/GroundWaterFlow/gwf3tvs8.f90 b/src/Model/GroundWaterFlow/gwf3tvs8.f90 index 071c86135b0..390810b77e2 100644 --- a/src/Model/GroundWaterFlow/gwf3tvs8.f90 +++ b/src/Model/GroundWaterFlow/gwf3tvs8.f90 @@ -23,10 +23,10 @@ module TvsModule public :: tvs_cr type, extends(TvBaseType) :: TvsType - integer(I4B), pointer :: integratechanges => null() !< STO flag indicating if mid-simulation ss and sy changes should be integrated via an additional matrix formulation term - integer(I4B), pointer :: iusesy => null() !< STO flag set if any cell is convertible (0, 1) - real(DP), dimension(:), pointer, contiguous :: ss => null() !< STO specfic storage or storage coefficient - real(DP), dimension(:), pointer, contiguous :: sy => null() !< STO specific yield + integer(I4B), pointer :: integratechanges => null() !< STO flag indicating if mid-simulation ss and sy changes should be integrated via an additional matrix formulation term + integer(I4B), pointer :: iusesy => null() !< STO flag set if any cell is convertible (0, 1) + real(DP), dimension(:), pointer, contiguous :: ss => null() !< STO specfic storage or storage coefficient + real(DP), dimension(:), pointer, contiguous :: sy => null() !< STO specific yield contains procedure :: da => tvs_da procedure :: ar_set_pointers => tvs_ar_set_pointers @@ -51,7 +51,7 @@ subroutine tvs_cr(tvs, name_model, inunit, iout) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! - allocate(tvs) + allocate (tvs) call tvs%init(name_model, 'TVS', 'TVS', inunit, iout) ! return @@ -74,7 +74,7 @@ subroutine tvs_ar_set_pointers(this) &' INPUT READ FROM UNIT ', i0, //)" ! ! -- Print a message identifying the TVS package - write(this%iout, fmttvs) this%inunit + write (this%iout, fmttvs) this%inunit ! ! -- Set pointers to other package variables ! -- STO @@ -108,12 +108,12 @@ function tvs_read_option(this, keyword) result(success) &'Storage derivative terms will not be added to STO matrix formulation')" ! select case (keyword) - case ('DISABLE_STORAGE_CHANGE_INTEGRATION') - success = .true. - this%integratechanges = 0 - write(this%iout, fmtdsci) - case default - success = .false. + case ('DISABLE_STORAGE_CHANGE_INTEGRATION') + success = .true. + this%integratechanges = 0 + write (this%iout, fmtdsci) + case default + success = .false. end select ! return @@ -134,12 +134,12 @@ function tvs_get_pointer_to_value(this, n, varName) result(bndElem) real(DP), pointer :: bndElem ! select case (varName) - case ('SS') - bndElem => this%ss(n) - case ('SY') - bndElem => this%sy(n) - case default - bndElem => null() + case ('SS') + bndElem => this%ss(n) + case ('SY') + bndElem => this%sy(n) + case default + bndElem => null() end select ! return @@ -202,25 +202,25 @@ subroutine tvs_validate_change(this, n, varName) &in this model (all ICONVERT flags are 0).')" ! ! -- Check the changed value is ok and convert to storage capacity - if(varName == 'SS') then - if(this%ss(n) < DZERO) then + if (varName == 'SS') then + if (this%ss(n) < DZERO) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtserr) trim(adjustl(this%packName)), 'SS', & - trim(cellstr), this%ss(n) + write (errmsg, fmtserr) trim(adjustl(this%packName)), 'SS', & + trim(cellstr), this%ss(n) call store_error(errmsg) - endif - elseif(varName == 'SY') then - if(this%iusesy /= 1) then + end if + elseif (varName == 'SY') then + if (this%iusesy /= 1) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtsyerr) trim(adjustl(this%packName)), 'SY', & - trim(cellstr) + write (errmsg, fmtsyerr) trim(adjustl(this%packName)), 'SY', & + trim(cellstr) call store_error(errmsg) - elseif(this%sy(n) < DZERO) then + elseif (this%sy(n) < DZERO) then call this%dis%noder_to_string(n, cellstr) - write(errmsg, fmtserr) trim(adjustl(this%packName)), 'SY', & - trim(cellstr), this%sy(n) + write (errmsg, fmtserr) trim(adjustl(this%packName)), 'SY', & + trim(cellstr), this%sy(n) call store_error(errmsg) - endif + end if end if ! return @@ -236,10 +236,10 @@ subroutine tvs_da(this) class(TvsType) :: this ! ! -- Nullify pointers to other package variables - nullify(this%integratechanges) - nullify(this%iusesy) - nullify(this%ss) - nullify(this%sy) + nullify (this%integratechanges) + nullify (this%iusesy) + nullify (this%ss) + nullify (this%sy) ! ! -- Deallocate parent call tvbase_da(this) diff --git a/src/Model/GroundWaterFlow/gwf3uzf8.f90 b/src/Model/GroundWaterFlow/gwf3uzf8.f90 index c176acdc8a0..382fd509305 100644 --- a/src/Model/GroundWaterFlow/gwf3uzf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3uzf8.f90 @@ -2,16 +2,16 @@ module UzfModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM6, DEM4, DEM2, DEM1, DHALF, & - DONE, DHUNDRED, & - LINELENGTH, LENFTYPE, LENPACKAGENAME, & - LENBOUNDNAME, LENBUDTXT, LENPAKLOC, DNODATA, & - NAMEDBOUNDFLAG, MAXCHARLEN, & - DHNOFLO, DHDRY, & - TABLEFT, TABCENTER, TABRIGHT, & + use ConstantsModule, only: DZERO, DEM6, DEM4, DEM2, DEM1, DHALF, & + DONE, DHUNDRED, & + LINELENGTH, LENFTYPE, LENPACKAGENAME, & + LENBOUNDNAME, LENBUDTXT, LENPAKLOC, DNODATA, & + NAMEDBOUNDFLAG, MAXCHARLEN, & + DHNOFLO, DHDRY, & + TABLEFT, TABCENTER, TABRIGHT, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL use GenericUtilitiesModule, only: sim_message - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & mem_deallocate use MemoryHelperModule, only: create_mem_path use SparseModule, only: sparsematrix @@ -29,8 +29,8 @@ module UzfModule implicit none - character(len=LENFTYPE) :: ftype = 'UZF' - character(len=LENPACKAGENAME) :: text = ' UZF CELLS' + character(len=LENFTYPE) :: ftype = 'UZF' + character(len=LENPACKAGENAME) :: text = ' UZF CELLS' private public :: uzf_create @@ -41,62 +41,62 @@ module UzfModule integer(I4B), pointer :: iprwcont => null() integer(I4B), pointer :: iwcontout => null() integer(I4B), pointer :: ibudgetout => null() - integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file integer(I4B), pointer :: ipakcsv => null() ! - type(BudgetObjectType), pointer :: budobj => null() - integer(I4B), pointer :: bditems => null() !< number of budget items - integer(I4B), pointer :: nbdtxt => null() !< number of budget text items - character(len=LENBUDTXT), dimension(:), pointer, & - contiguous :: bdtxt => null() !< budget items written to cbc file - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: uzfname => null() + type(BudgetObjectType), pointer :: budobj => null() + integer(I4B), pointer :: bditems => null() !< number of budget items + integer(I4B), pointer :: nbdtxt => null() !< number of budget text items + character(len=LENBUDTXT), dimension(:), pointer, & + contiguous :: bdtxt => null() !< budget items written to cbc file + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: uzfname => null() ! ! -- uzf table objects - type(TableType), pointer :: pakcsvtab => null() + type(TableType), pointer :: pakcsvtab => null() ! ! -- uzf kinematic object - type(UzfCellGroupType), pointer :: uzfobj => null() - type(UzfCellGroupType) :: uzfobjwork + type(UzfCellGroupType), pointer :: uzfobj => null() + type(UzfCellGroupType) :: uzfobjwork ! ! -- pointer to gwf variables - integer(I4B), pointer :: gwfiss => null() - real(DP), dimension(:), pointer, contiguous :: gwftop => null() - real(DP), dimension(:), pointer, contiguous :: gwfbot => null() - real(DP), dimension(:), pointer, contiguous :: gwfarea => null() - real(DP), dimension(:), pointer, contiguous :: gwfhcond => null() + integer(I4B), pointer :: gwfiss => null() + real(DP), dimension(:), pointer, contiguous :: gwftop => null() + real(DP), dimension(:), pointer, contiguous :: gwfbot => null() + real(DP), dimension(:), pointer, contiguous :: gwfarea => null() + real(DP), dimension(:), pointer, contiguous :: gwfhcond => null() ! ! -- uzf data - integer(I4B), pointer :: ntrail => null() - integer(I4B), pointer :: nsets => null() - integer(I4B), pointer :: nwav => null() - integer(I4B), pointer :: nodes => null() - integer(I4B), pointer :: readflag => null() - integer(I4B), pointer :: ietflag => null() !< et flag, 0 is off, 1 or 2 are different types - integer(I4B), pointer :: igwetflag => null() - integer(I4B), pointer :: iseepflag => null() - integer(I4B), pointer :: imaxcellcnt => null() - integer(I4B), pointer :: iuzf2uzf => null() + integer(I4B), pointer :: ntrail => null() + integer(I4B), pointer :: nsets => null() + integer(I4B), pointer :: nwav => null() + integer(I4B), pointer :: nodes => null() + integer(I4B), pointer :: readflag => null() + integer(I4B), pointer :: ietflag => null() !< et flag, 0 is off, 1 or 2 are different types + integer(I4B), pointer :: igwetflag => null() + integer(I4B), pointer :: iseepflag => null() + integer(I4B), pointer :: imaxcellcnt => null() + integer(I4B), pointer :: iuzf2uzf => null() ! -- integer vectors - integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() - integer(I4B), dimension(:), pointer, contiguous :: ia => null() - integer(I4B), dimension(:), pointer, contiguous :: ja => null() + integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null() + integer(I4B), dimension(:), pointer, contiguous :: ia => null() + integer(I4B), dimension(:), pointer, contiguous :: ja => null() ! -- double precision output vectors - real(DP), dimension(:), pointer, contiguous :: appliedinf => null() - real(DP), dimension(:), pointer, contiguous :: rejinf => null() - real(DP), dimension(:), pointer, contiguous :: rejinf0 => null() - real(DP), dimension(:), pointer, contiguous :: rejinftomvr => null() - real(DP), dimension(:), pointer, contiguous :: infiltration => null() - real(DP), dimension(:), pointer, contiguous :: gwet => null() - real(DP), dimension(:), pointer, contiguous :: uzet => null() - real(DP), dimension(:), pointer, contiguous :: gwd => null() - real(DP), dimension(:), pointer, contiguous :: gwd0 => null() - real(DP), dimension(:), pointer, contiguous :: gwdtomvr => null() - real(DP), dimension(:), pointer, contiguous :: rch => null() - real(DP), dimension(:), pointer, contiguous :: rch0 => null() - real(DP), dimension(:), pointer, contiguous :: qsto => null() !< change in stored mobile water per time for this time step - real(DP), dimension(:), pointer, contiguous :: wcnew => null() !< water content for this time step - real(DP), dimension(:), pointer, contiguous :: wcold => null() !< water content for previous time step + real(DP), dimension(:), pointer, contiguous :: appliedinf => null() + real(DP), dimension(:), pointer, contiguous :: rejinf => null() + real(DP), dimension(:), pointer, contiguous :: rejinf0 => null() + real(DP), dimension(:), pointer, contiguous :: rejinftomvr => null() + real(DP), dimension(:), pointer, contiguous :: infiltration => null() + real(DP), dimension(:), pointer, contiguous :: gwet => null() + real(DP), dimension(:), pointer, contiguous :: uzet => null() + real(DP), dimension(:), pointer, contiguous :: gwd => null() + real(DP), dimension(:), pointer, contiguous :: gwd0 => null() + real(DP), dimension(:), pointer, contiguous :: gwdtomvr => null() + real(DP), dimension(:), pointer, contiguous :: rch => null() + real(DP), dimension(:), pointer, contiguous :: rch0 => null() + real(DP), dimension(:), pointer, contiguous :: qsto => null() !< change in stored mobile water per time for this time step + real(DP), dimension(:), pointer, contiguous :: wcnew => null() !< water content for this time step + real(DP), dimension(:), pointer, contiguous :: wcold => null() !< water content for previous time step ! ! -- timeseries aware variables real(DP), dimension(:), pointer, contiguous :: sinf => null() @@ -106,7 +106,7 @@ module UzfModule real(DP), dimension(:), pointer, contiguous :: ha => null() real(DP), dimension(:), pointer, contiguous :: hroot => null() real(DP), dimension(:), pointer, contiguous :: rootact => null() - real(DP), dimension(:,:), pointer, contiguous :: uauxvar => null() + real(DP), dimension(:, :), pointer, contiguous :: uauxvar => null() ! ! -- convergence check integer(I4B), pointer :: iconvchk => null() @@ -115,10 +115,10 @@ module UzfModule real(DP), dimension(:), pointer, contiguous :: deriv => null() ! ! budget variables - real(DP), pointer :: totfluxtot => null() - integer(I4B), pointer :: issflag => null() - integer(I4B), pointer :: issflagold => null() - integer(I4B), pointer :: istocb => null() + real(DP), pointer :: totfluxtot => null() + integer(I4B), pointer :: issflag => null() + integer(I4B), pointer :: issflagold => null() + integer(I4B), pointer :: istocb => null() ! ! -- uzf cbc budget items integer(I4B), pointer :: cbcauxitems => NULL() @@ -163,7 +163,7 @@ module UzfModule ! -- budget procedure, private :: uzf_setup_budobj procedure, private :: uzf_fill_budobj - + end type UzfType contains @@ -181,10 +181,10 @@ subroutine uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) use MemoryManagerModule, only: mem_allocate ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -192,7 +192,7 @@ subroutine uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(uzfobj) + allocate (uzfobj) packobj => uzfobj ! ! -- create name and memory path @@ -210,9 +210,9 @@ subroutine uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%id = id packobj%ibcnum = ibcnum packobj%ncolbnd = 1 - packobj%iscloc = 0 ! not supported + packobj%iscloc = 0 ! not supported packobj%isadvpak = 1 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! ! -- return return @@ -240,7 +240,8 @@ subroutine uzf_ar(this) call this%BndType%allocate_arrays() ! ! -- set pointers now that data is available - call mem_setptr(this%gwfhcond, 'CONDSAT', create_mem_path(this%name_model,'NPF')) + call mem_setptr(this%gwfhcond, 'CONDSAT', create_mem_path(this%name_model, & + 'NPF')) call mem_setptr(this%gwfiss, 'ISS', create_mem_path(this%name_model)) ! ! -- set boundname for each connection @@ -248,7 +249,7 @@ subroutine uzf_ar(this) do n = 1, this%nodes this%boundname(n) = this%uzfname(n) end do - endif + end if ! ! -- copy igwfnode into nodelist and set water table do i = 1, this%nodes @@ -260,9 +261,9 @@ subroutine uzf_ar(this) ! ! -- setup pakmvrobj if (this%imover /= 0) then - allocate(this%pakmvrobj) + allocate (this%pakmvrobj) call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%memoryPath) - endif + end if ! ! -- return return @@ -277,10 +278,10 @@ subroutine uzf_allocate_arrays(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(UzfType), intent(inout) :: this + class(UzfType), intent(inout) :: this ! -- local - integer (I4B) :: i - integer (I4B) :: j + integer(I4B) :: i + integer(I4B) :: j ! ------------------------------------------------------------------------------ ! ! -- call standard BndType allocate scalars (now done from AR) @@ -291,8 +292,10 @@ subroutine uzf_allocate_arrays(this) call mem_allocate(this%appliedinf, this%nodes, 'APPLIEDINF', this%memoryPath) call mem_allocate(this%rejinf, this%nodes, 'REJINF', this%memoryPath) call mem_allocate(this%rejinf0, this%nodes, 'REJINF0', this%memoryPath) - call mem_allocate(this%rejinftomvr, this%nodes, 'REJINFTOMVR', this%memoryPath) - call mem_allocate(this%infiltration, this%nodes, 'INFILTRATION', this%memoryPath) + call mem_allocate(this%rejinftomvr, this%nodes, 'REJINFTOMVR', & + this%memoryPath) + call mem_allocate(this%infiltration, this%nodes, 'INFILTRATION', & + this%memoryPath) call mem_allocate(this%gwet, this%nodes, 'GWET', this%memoryPath) call mem_allocate(this%uzet, this%nodes, 'UZET', this%memoryPath) call mem_allocate(this%gwd, this%nodes, 'GWD', this%memoryPath) @@ -304,7 +307,7 @@ subroutine uzf_allocate_arrays(this) call mem_allocate(this%deriv, this%nodes, 'DERIV', this%memoryPath) ! -- integer vectors - call mem_allocate(this%ia, this%dis%nodes+1, 'IA', this%memoryPath) + call mem_allocate(this%ia, this%dis%nodes + 1, 'IA', this%memoryPath) call mem_allocate(this%ja, this%nodes, 'JA', this%memoryPath) ! -- allocate timeseries aware variables @@ -315,8 +318,9 @@ subroutine uzf_allocate_arrays(this) call mem_allocate(this%ha, this%nodes, 'HA', this%memoryPath) call mem_allocate(this%hroot, this%nodes, 'HROOT', this%memoryPath) call mem_allocate(this%rootact, this%nodes, 'ROOTACT', this%memoryPath) - call mem_allocate(this%uauxvar, this%naux, this%nodes, 'UAUXVAR', this%memoryPath) - + call mem_allocate(this%uauxvar, this%naux, this%nodes, 'UAUXVAR', & + this%memoryPath) + ! -- initialize do i = 1, this%nodes this%appliedinf(i) = DZERO @@ -350,12 +354,12 @@ subroutine uzf_allocate_arrays(this) end if end do end do - do i = 1, this%dis%nodes+1 + do i = 1, this%dis%nodes + 1 this%ia(i) = 0 end do ! ! -- allocate and initialize character array for budget text - allocate(this%bdtxt(this%nbdtxt)) + allocate (this%bdtxt(this%nbdtxt)) this%bdtxt(1) = ' UZF-INF' this%bdtxt(2) = ' UZF-GWRCH' this%bdtxt(3) = ' UZF-GWD' @@ -368,11 +372,11 @@ subroutine uzf_allocate_arrays(this) do i = 1, this%nodes this%wcnew(i) = DZERO this%wcold(i) = DZERO - end do + end do ! ! -- allocate character array for aux budget text - allocate(this%cauxcbc(this%cbcauxitems)) - allocate(this%uzfname(this%nodes)) + allocate (this%cauxcbc(this%cbcauxitems)) + allocate (this%uzfname(this%nodes)) ! ! -- allocate and initialize qauxcbc call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%memoryPath) @@ -382,7 +386,7 @@ subroutine uzf_allocate_arrays(this) ! ! -- return return - end subroutine uzf_allocate_arrays + end subroutine uzf_allocate_arrays ! subroutine uzf_options(this, option, found) @@ -400,33 +404,34 @@ subroutine uzf_options(this, option, found) use InputOutputModule, only: urword, getunit, openfile implicit none ! -- dummy - class(uzftype), intent(inout) :: this + class(uzftype), intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical, intent(inout) :: found ! -- local character(len=MAXCHARLEN) :: fname, keyword ! -- formats - character(len=*),parameter :: fmtnotfound= & - "(4x, 'NO UZF OPTIONS WERE FOUND.')" - character(len=*),parameter :: fmtet = & - "(4x, 'ET WILL BE SIMULATED WITHIN UZ AND GW ZONES, WITH LINEAR ', & - &'GWET IF OPTION NOT SPECIFIED OTHERWISE.')" - character(len=*),parameter :: fmtgwetlin = & - "(4x, 'GROUNDWATER ET FUNCTION WILL BE LINEAR.')" - character(len=*),parameter :: fmtgwetsquare = & - "(4x, 'GROUNDWATER ET FUNCTION WILL BE SQUARE WITH SMOOTHING.')" - character(len=*),parameter :: fmtgwseepout = & - "(4x, 'GROUNDWATER DISCHARGE TO LAND SURFACE WILL BE SIMULATED.')" - character(len=*),parameter :: fmtuzetwc = & - "(4x, 'UNSATURATED ET FUNCTION OF WATER CONTENT.')" - character(len=*),parameter :: fmtuzetae = & - "(4x, 'UNSATURATED ET FUNCTION OF AIR ENTRY PRESSURE.')" - character(len=*),parameter :: fmtuznlay = & - "(4x, 'UNSATURATED FLOW WILL BE SIMULATED SEPARATELY IN EACH LAYER.')" - character(len=*),parameter :: fmtuzfbin = & - "(4x, 'UZF ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I0)" - character(len=*),parameter :: fmtuzfopt = & - "(4x, 'UZF ', a, ' VALUE (',g15.7,') SPECIFIED.')" + character(len=*), parameter :: fmtnotfound = & + &"(4x, 'NO UZF OPTIONS WERE FOUND.')" + character(len=*), parameter :: fmtet = & + "(4x, 'ET WILL BE SIMULATED WITHIN UZ AND GW ZONES, WITH LINEAR ', & + &'GWET IF OPTION NOT SPECIFIED OTHERWISE.')" + character(len=*), parameter :: fmtgwetlin = & + &"(4x, 'GROUNDWATER ET FUNCTION WILL BE LINEAR.')" + character(len=*), parameter :: fmtgwetsquare = & + &"(4x, 'GROUNDWATER ET FUNCTION WILL BE SQUARE WITH SMOOTHING.')" + character(len=*), parameter :: fmtgwseepout = & + &"(4x, 'GROUNDWATER DISCHARGE TO LAND SURFACE WILL BE SIMULATED.')" + character(len=*), parameter :: fmtuzetwc = & + &"(4x, 'UNSATURATED ET FUNCTION OF WATER CONTENT.')" + character(len=*), parameter :: fmtuzetae = & + &"(4x, 'UNSATURATED ET FUNCTION OF AIR ENTRY PRESSURE.')" + character(len=*), parameter :: fmtuznlay = & + &"(4x, 'UNSATURATED FLOW WILL BE SIMULATED SEPARATELY IN EACH LAYER.')" + character(len=*), parameter :: fmtuzfbin = & + "(4x, 'UZF ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & + &a, /4x, 'OPENED ON UNIT: ', I0)" + character(len=*), parameter :: fmtuzfopt = & + &"(4x, 'UZF ', a, ' VALUE (',g15.7,') SPECIFIED.')" ! ------------------------------------------------------------------------------ ! @@ -437,93 +442,94 @@ subroutine uzf_options(this, option, found) ! write(this%iout,'(4x,a)') trim(adjustl(this%text))// & ! ' WATERCONTENT WILL BE PRINTED TO LISTING FILE.' ! found = .true. - case('WATER_CONTENT') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%iwcontout = getunit() - call openfile(this%iwcontout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtuzfbin) 'WATER-CONTENT', fname, this%iwcontout - found = .true. - else - call store_error('OPTIONAL WATER_CONTENT KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtuzfbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtuzfbin) 'BUDGET CSV', fname, this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case('PACKAGE_CONVERGENCE') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ipakcsv = getunit() - call openfile(this%ipakcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtuzfbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv - found = .true. - else - call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE ' // & - 'FOLLOWED BY FILEOUT') - end if - case('SIMULATE_ET') - this%ietflag = 1 !default - this%igwetflag = 0 - found = .true. - write(this%iout, fmtet) - case('LINEAR_GWET') - this%igwetflag = 1 + case ('WATER_CONTENT') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%iwcontout = getunit() + call openfile(this%iwcontout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtuzfbin) 'WATER-CONTENT', fname, this%iwcontout found = .true. - write(this%iout, fmtgwetlin) - case('SQUARE_GWET') - this%igwetflag = 2 - found = .true. - write(this%iout, fmtgwetsquare) - case('SIMULATE_GWSEEP') - this%iseepflag = 1 - found = .true. - write(this%iout, fmtgwseepout) - case('UNSAT_ETWC') - this%ietflag = 1 - found = .true. - write(this%iout, fmtuzetwc) - case('UNSAT_ETAE') - this%ietflag = 2 + else + call store_error('OPTIONAL WATER_CONTENT KEYWORD & + &MUST BE FOLLOWED BY FILEOUT') + end if + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtuzfbin) 'BUDGET', fname, this%ibudgetout found = .true. - write(this%iout, fmtuzetae) - case('MOVER') - this%imover = 1 + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtuzfbin) 'BUDGET CSV', fname, this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case ('PACKAGE_CONVERGENCE') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ipakcsv = getunit() + call openfile(this%ipakcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtuzfbin) 'PACKAGE_CONVERGENCE', fname, this%ipakcsv found = .true. + else + call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE '// & + 'FOLLOWED BY FILEOUT') + end if + case ('SIMULATE_ET') + this%ietflag = 1 !default + this%igwetflag = 0 + found = .true. + write (this%iout, fmtet) + case ('LINEAR_GWET') + this%igwetflag = 1 + found = .true. + write (this%iout, fmtgwetlin) + case ('SQUARE_GWET') + this%igwetflag = 2 + found = .true. + write (this%iout, fmtgwetsquare) + case ('SIMULATE_GWSEEP') + this%iseepflag = 1 + found = .true. + write (this%iout, fmtgwseepout) + case ('UNSAT_ETWC') + this%ietflag = 1 + found = .true. + write (this%iout, fmtuzetwc) + case ('UNSAT_ETAE') + this%ietflag = 2 + found = .true. + write (this%iout, fmtuzetae) + case ('MOVER') + this%imover = 1 + found = .true. ! ! -- right now these are options that are available but may not be available in ! the release (or in documentation) - case('DEV_NO_FINAL_CHECK') - call this%parser%DevOpt() - this%iconvchk = 0 - write(this%iout, '(4x,a)') & - & 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN UZF RECHARGE ' // & - & 'WILL NOT BE MADE' - found = .true. + case ('DEV_NO_FINAL_CHECK') + call this%parser%DevOpt() + this%iconvchk = 0 + write (this%iout, '(4x,a)') & + 'A FINAL CONVERGENCE CHECK OF THE CHANGE IN UZF RECHARGE & + &WILL NOT BE MADE' + found = .true. !case('DEV_MAXIMUM_PERCENT_DIFFERENCE') ! call this%parser%DevOpt() ! r = this%parser%GetDouble() @@ -535,9 +541,9 @@ subroutine uzf_options(this, option, found) ! write(this%iout, fmtuzfopt) 'USING DEFAULT MAXIMUM_PERCENT_DIFFERENCE', this%pdmax ! end if ! found = .true. - case default - ! -- No options found - found = .false. + case default + ! -- No options found + found = .false. end select ! -- return return @@ -554,14 +560,14 @@ subroutine uzf_readdimensions(this) ! ------------------------------------------------------------------------------ use InputOutputModule, only: urword use SimModule, only: store_error, count_errors - class(uzftype),intent(inout) :: this + class(uzftype), intent(inout) :: this character(len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! ------------------------------------------------------------------------------ ! ! -- initialize dimensions to -1 - this%nodes= -1 + this%nodes = -1 this%ntrail = 0 this%nsets = 0 ! @@ -571,29 +577,29 @@ subroutine uzf_readdimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NUZFCELLS') - this%nodes = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NUZFCELLS = ', this%nodes - case ('NTRAILWAVES') - this%ntrail = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NTRAILWAVES = ', this%ntrail - case ('NWAVESETS') - this%nsets = this%parser%GetInteger() - write(this%iout,'(4x,a,i0)') 'NTRAILSETS = ', this%nsets - case default - write(errmsg,'(a,a)') & - 'Unknown '// trim(this%text) // ' dimension: ', trim(keyword) - end select + case ('NUZFCELLS') + this%nodes = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NUZFCELLS = ', this%nodes + case ('NTRAILWAVES') + this%ntrail = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NTRAILWAVES = ', this%ntrail + case ('NWAVESETS') + this%nsets = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NTRAILSETS = ', this%nsets + case default + write (errmsg, '(a,a)') & + 'Unknown '//trim(this%text)//' dimension: ', trim(keyword) + end select end do - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(this%text)) // ' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' else call store_error('Required dimensions block not found.') end if @@ -604,19 +610,19 @@ subroutine uzf_readdimensions(this) ! ! -- verify dimensions were set if (this%nodes <= 0) then - write(errmsg, '(a)') & + write (errmsg, '(a)') & 'NUZFCELLS was not specified or was specified incorrectly.' call store_error(errmsg) end if if (this%ntrail <= 0) then - write(errmsg, '(a)') & + write (errmsg, '(a)') & 'NTRAILWAVES was not specified or was specified incorrectly.' call store_error(errmsg) end if ! if (this%nsets <= 0) then - write(errmsg, '(a)') & + write (errmsg, '(a)') & 'NWAVESETS was not specified or was specified incorrectly.' call store_error(errmsg) end if @@ -637,7 +643,7 @@ subroutine uzf_readdimensions(this) call this%uzf_allocate_arrays() ! ! -- initialize uzf group object - allocate(this%uzfobj) + allocate (this%uzfobj) call this%uzfobj%init(this%nodes, this%nwav, this%memoryPath) call this%uzfobjwork%init(1, this%nwav) ! @@ -684,28 +690,28 @@ subroutine uzf_rp(this) character(len=LINELENGTH) :: line logical :: isfound logical :: endOfBlock - integer (I4B) :: i - integer (I4B) :: j - integer (I4B) :: jj + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jj integer(I4B) :: ierr real(DP), pointer :: bndElem => null() ! -- table output - character (len=20) :: cellid + character(len=20) :: cellid character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag integer(I4B) :: ntabrows integer(I4B) :: ntabcols integer(I4B) :: node !-- formats - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*),parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtflow = & + &"(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" ! ------------------------------------------------------------------------------ ! ! -- Set ionper to the stress period number for which a new block of data @@ -731,18 +737,18 @@ subroutine uzf_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - endif + end if end if ! ! -- set steady-state flag based on gwfiss this%issflag = this%gwfiss ! ! -- read data if ionper == kper - if(this%ionper==kper) then + if (this%ionper == kper) then ! ! -- write header if (this%iprpak /= 0) then @@ -763,11 +769,11 @@ subroutine uzf_rp(this) end if ! ! -- initialize table and define columns - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') DATA FOR PERIOD' + write (title, '(a,1x,i6)') trim(adjustl(title)), kper call table_cr(this%inputtab, this%packName, title) - call this%inputtab%table_df(ntabrows, ntabcols, this%iout, & + call this%inputtab%table_df(ntabrows, ntabcols, this%iout, & finalize=.FALSE.) tag = 'NUMBER' call this%inputtab%initialize_column(tag, 10) @@ -793,7 +799,8 @@ subroutine uzf_rp(this) end if if (this%inamedbound == 1) then tag = 'BOUNDNAME' - call this%inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) + call this%inputtab%initialize_column(tag, LENBOUNDNAME, & + alignment=TABLEFT) end if end if ! @@ -805,12 +812,12 @@ subroutine uzf_rp(this) ! -- check for valid uzf node i = this%parser%GetInteger() if (i < 1 .or. i > this%nodes) then - tag = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') DATA FOR PERIOD' - write(tag, '(a,1x,i0)') trim(adjustl(tag)), kper - - write(errmsg,'(a,a,i0,1x,a,i0,a)') & - trim(adjustl(tag)), ': UZFNO ', i, & + tag = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') DATA FOR PERIOD' + write (tag, '(a,1x,i0)') trim(adjustl(tag)), kper + + write (errmsg, '(a,a,i0,1x,a,i0,a)') & + trim(adjustl(tag)), ': UZFNO ', i, & 'must be greater than 0 and less than or equal to ', this%nodes, '.' call store_error(errmsg) cycle @@ -825,65 +832,65 @@ subroutine uzf_rp(this) ! ! -- FINF call this%parser%GetStringCaps(text) - jj = 1 ! For SINF + jj = 1 ! For SINF bndElem => this%sinf(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'SINF') ! ! -- PET call this%parser%GetStringCaps(text) - jj = 1 ! For PET + jj = 1 ! For PET bndElem => this%pet(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'PET') ! ! -- EXTD call this%parser%GetStringCaps(text) - jj = 1 ! For EXTDP + jj = 1 ! For EXTDP bndElem => this%extdp(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'EXTDP') ! ! -- EXTWC call this%parser%GetStringCaps(text) - jj = 1 ! For EXTWC + jj = 1 ! For EXTWC bndElem => this%extwc(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'EXTWC') ! ! -- HA call this%parser%GetStringCaps(text) - jj = 1 ! For HA + jj = 1 ! For HA bndElem => this%ha(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'HA') ! ! -- HROOT call this%parser%GetStringCaps(text) - jj = 1 ! For HROOT + jj = 1 ! For HROOT bndElem => this%hroot(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'HROOT') ! ! -- ROOTACT call this%parser%GetStringCaps(text) - jj = 1 ! For ROOTACT + jj = 1 ! For ROOTACT bndElem => this%rootact(i) - call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, i, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & 'ROOTACT') ! ! -- read auxillary variables do j = 1, this%naux call this%parser%GetStringCaps(text) bndElem => this%uauxvar(j, i) - call read_value_or_time_series_adv(text, i, j, bndElem, this%packName, & + call read_value_or_time_series_adv(text, i, j, bndElem, this%packName, & 'AUX', this%tsManager, this%iprpak, & this%auxname(j)) end do @@ -924,11 +931,11 @@ subroutine uzf_rp(this) if (this%iprpak /= 0) then call this%inputtab%finalize_table() end if - ! - ! -- using stress period data from the previous stress period + ! + ! -- using stress period data from the previous stress period else - write(this%iout,fmtlsp) trim(this%filtyp) - endif + write (this%iout, fmtlsp) trim(this%filtyp) + end if ! ! -- write summary of uzf stress period error messages ierr = count_errors() @@ -937,8 +944,8 @@ subroutine uzf_rp(this) end if ! ! -- set wave data for first stress period and second that follows SS - if ((this%issflag == 0 .AND. kper == 1) .or. & - (kper == 2 .AND. this%issflagold == 1)) then + if ((this%issflag == 0 .AND. kper == 1) .or. & + (kper == 2 .AND. this%issflagold == 1)) then do i = 1, this%nodes call this%uzfobj%setwaves(i) end do @@ -973,7 +980,7 @@ subroutine uzf_ad(this) integer(I4B) :: i integer(I4B) :: ivertflag integer(I4B) :: n, iaux - real (DP) :: rval1, rval2, rval3 + real(DP) :: rval1, rval2, rval3 ! ------------------------------------------------------------------------------ ! ! -- Advance the time series @@ -1006,12 +1013,12 @@ subroutine uzf_ad(this) ! and that doesn't happen until a successful solution is obtained. do i = 1, this%nodes this%wcnew(i) = this%wcold(i) - end do + end do end if ! ! -- advance each uzf obj do i = 1, this%nodes - call this%uzfobj%advance(i) + call this%uzfobj%advance(i) end do ! ! -- update uzf objects with timeseries aware variables @@ -1052,9 +1059,9 @@ subroutine uzf_ad(this) end if ! ! -- pakmvrobj ad - if(this%imover == 1) then - call this%pakmvrobj%ad() - endif + if (this%imover == 1) then + call this%pakmvrobj%ad() + end if ! ! -- For each observation, push simulated value and corresponding ! simulation time from "current" to "preceding" and reset @@ -1084,7 +1091,7 @@ subroutine uzf_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! ! -- Return if no UZF cells - if(this%nodes == 0) return + if (this%nodes == 0) return ! ! -- Store values at start of outer iteration to compare with calculated ! values for convergence check @@ -1097,9 +1104,9 @@ subroutine uzf_cf(this, reset_mover) ! -- pakmvrobj cf lrm = .true. if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then + if (this%imover == 1 .and. lrm) then call this%pakmvrobj%cf() - endif + end if ! ! -- return return @@ -1123,9 +1130,9 @@ subroutine uzf_fc(this, rhs, ia, idxglo, amatsln) ! ------------------------------------------------------------------------------ ! ! -- pakmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() - endif + end if ! ! -- Solve UZF; set reset_state to true so that waves are reset back to ! initial position for each outer iteration @@ -1137,7 +1144,7 @@ subroutine uzf_fc(this, rhs, ia, idxglo, amatsln) rhs(n) = rhs(n) + this%rhs(i) ipos = ia(n) amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - enddo + end do ! ! -- return return @@ -1241,8 +1248,8 @@ subroutine uzf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! ! -- setup table call table_cr(this%pakcsvtab, this%packName, '') - call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & - lineseparator=.FALSE., separator=',', & + call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, & + lineseparator=.FALSE., separator=',', & finalize=.FALSE.) ! ! -- add columns to package csv @@ -1320,20 +1327,20 @@ subroutine uzf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) if (ABS(drejinfmax) > abs(dpak)) then ipak = locdrejinfmax dpak = drejinfmax - write(cloc, "(a,'-',a)") trim(this%packName), 'rejinf' + write (cloc, "(a,'-',a)") trim(this%packName), 'rejinf' cpak = trim(cloc) end if if (ABS(drchmax) > abs(dpak)) then ipak = locdrchmax dpak = drchmax - write(cloc, "(a,'-',a)") trim(this%packName), 'rech' + write (cloc, "(a,'-',a)") trim(this%packName), 'rech' cpak = trim(cloc) end if if (this%iseepflag == 1) then if (ABS(dseepmax) > abs(dpak)) then ipak = locdseepmax dpak = dseepmax - write(cloc, "(a,'-',a)") trim(this%packName), 'seep' + write (cloc, "(a,'-',a)") trim(this%packName), 'seep' cpak = trim(cloc) end if end if @@ -1394,7 +1401,7 @@ subroutine uzf_cq(this, x, flowja, iadv) ! -- for observations ! -- formats character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" + &"(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" ! ------------------------------------------------------------------------------ ! ! -- Make uzf solution for budget calculations, and then reset waves. @@ -1476,7 +1483,7 @@ subroutine uzf_cq(this, x, flowja, iadv) ! -- return return end subroutine uzf_cq - + function get_storage_change(top, bot, carea, hold, hnew, wcold, wcnew, & thtr, delt, iss) result(qsto) real(DP), intent(in) :: top @@ -1519,35 +1526,35 @@ subroutine uzf_bd(this, model_budget) real(DP) :: ratout integer(I4B) :: isuppress_output isuppress_output = 0 - + ! -- Calculate flow from uzf to gwf (UZF-GWRCH) call rate_accumulator(this%rch, ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(2), & + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(2), & isuppress_output, this%packName) ! -- GW discharge and GW discharge to mover if (this%iseepflag == 1) then call rate_accumulator(-this%gwd, ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(3), & + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(3), & isuppress_output, this%packName) if (this%imover == 1) then call rate_accumulator(-this%gwdtomvr, ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(5), & + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(5), & isuppress_output, this%packName) end if end if - + ! -- groundwater et (gwet array is positive, so switch ratin/ratout) if (this%igwetflag /= 0) then call rate_accumulator(-this%gwet, ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, this%bdtxt(4), & + call model_budget%addentry(ratin, ratout, delt, this%bdtxt(4), & isuppress_output, this%packName) end if - + return - end subroutine uzf_bd - - subroutine uzf_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) + end subroutine uzf_bd + + subroutine uzf_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) ! ****************************************************************************** ! bnd_ot_model_flows -- write flows to binary file and/or print flows to budget ! ****************************************************************************** @@ -1564,55 +1571,67 @@ subroutine uzf_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) integer(I4B), intent(in) :: icbcun integer(I4B), dimension(:), optional, intent(in) :: imap ! -- local - character (len=LINELENGTH) :: title + character(len=LINELENGTH) :: title integer(I4B) :: itxt ! -- formats ! ------------------------------------------------------------------------------ ! ! -- UZF-GWRCH itxt = 2 - title = trim(adjustl(this%bdtxt(itxt))) // ' PACKAGE (' // trim(this%packName) // & - ') FLOW RATES' + title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// & + trim(this%packName)//') FLOW RATES' call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, this%rch, & - this%ibound, title, this%bdtxt(itxt), this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, this%boundname) + this%outputtab, this%nbound, this%nodelist, & + this%rch, this%ibound, title, this%bdtxt(itxt), & + this%ipakcb, this%dis, this%naux, & + this%name_model, this%name_model, & + this%name_model, this%packName, this%auxname, & + this%auxvar, this%iout, this%inamedbound, & + this%boundname) ! ! -- UZF-GWD if (this%iseepflag == 1) then itxt = 3 - title = trim(adjustl(this%bdtxt(itxt))) // ' PACKAGE (' // trim(this%packName) // & - ') FLOW RATES' + title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// & + trim(this%packName)//') FLOW RATES' call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, -this%gwd, & - this%ibound, title, this%bdtxt(itxt), this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, this%boundname) + this%outputtab, this%nbound, this%nodelist, & + -this%gwd, this%ibound, title, & + this%bdtxt(itxt), this%ipakcb, this%dis, & + this%naux, this%name_model, this%name_model, & + this%name_model, this%packName, this%auxname, & + this%auxvar, this%iout, this%inamedbound, & + this%boundname) ! ! -- UZF-GWD TO-MVR if (this%imover == 1) then itxt = 5 - title = trim(adjustl(this%bdtxt(itxt))) // ' PACKAGE (' // trim(this%packName) // & - ') FLOW RATES' + title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// & + trim(this%packName)//') FLOW RATES' call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, -this%gwdtomvr, & - this%ibound, title, this%bdtxt(itxt), this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, this%boundname) + this%outputtab, this%nbound, this%nodelist, & + -this%gwdtomvr, this%ibound, title, & + this%bdtxt(itxt), this%ipakcb, this%dis, & + this%naux, this%name_model, this%name_model, & + this%name_model, this%packName, & + this%auxname, this%auxvar, this%iout, & + this%inamedbound, this%boundname) end if end if ! ! -- UZF-GWET if (this%igwetflag /= 0) then itxt = 4 - title = trim(adjustl(this%bdtxt(itxt))) // ' PACKAGE (' // trim(this%packName) // & - ') FLOW RATES' + title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// & + trim(this%packName)//') FLOW RATES' call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, -this%gwet, & - this%ibound, title, this%bdtxt(itxt), this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, this%boundname) + this%outputtab, this%nbound, this%nodelist, & + -this%gwet, this%ibound, title, & + this%bdtxt(itxt), this%ipakcb, this%dis, & + this%naux, this%name_model, this%name_model, & + this%name_model, this%packName, this%auxname, & + this%auxvar, this%iout, this%inamedbound, & + this%boundname) end if ! ! -- return @@ -1628,10 +1647,10 @@ subroutine uzf_ot_package_flows(this, icbcfl, ibudfl) ! ! -- write the flows from the budobj ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & pertim, totim, this%iout) @@ -1641,7 +1660,7 @@ subroutine uzf_ot_package_flows(this, icbcfl, ibudfl) if (ibudfl /= 0 .and. this%iprflow /= 0) then call this%budobj%write_flowtable(this%dis, kstp, kper) end if - + end subroutine uzf_ot_package_flows subroutine uzf_ot_dv(this, idvsave, idvprint) @@ -1654,34 +1673,34 @@ subroutine uzf_ot_dv(this, idvsave, idvprint) ! ! -- set unit number for binary dependent variable output ibinun = 0 - if(this%iwcontout /= 0) then + if (this%iwcontout /= 0) then ibinun = this%iwcontout end if - if(idvsave == 0) ibinun = 0 + if (idvsave == 0) ibinun = 0 ! ! -- write uzf binary moisture-content output if (ibinun > 0) then call ulasav(this%wcnew, ' WATER-CONTENT', kstp, kper, pertim, & totim, this%nodes, 1, 1, ibinun) - end if + end if end subroutine uzf_ot_dv - + subroutine uzf_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- module use TdisModule, only: totim ! -- dummy - class(UzfType) :: this !< UzfType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + class(UzfType) :: this !< UzfType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written ! call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) ! ! -- return return end subroutine uzf_ot_bdsummary - + subroutine uzf_solve(this, reset_state) ! ****************************************************************************** ! uzf_solve -- Formulate the HCOF and RHS terms @@ -1690,8 +1709,8 @@ subroutine uzf_solve(this, reset_state) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only : delt - logical, intent(in) :: reset_state !< flag indicating that waves should be reset after solution + use TdisModule, only: delt + logical, intent(in) :: reset_state !< flag indicating that waves should be reset after solution ! -- dummy class(UzfType) :: this ! -- locals @@ -1727,39 +1746,39 @@ subroutine uzf_solve(this, reset_state) ivertflag = this%uzfobj%ivertcon(i) watabold = this%uzfobj%watabold(i) ! - if ( this%ibound(n) > 0 ) then + if (this%ibound(n) > 0) then ! ! -- Water mover added to infiltration qfrommvr = DZERO qformvr = DZERO - if(this%imover == 1) then + if (this%imover == 1) then qfrommvr = this%pakmvrobj%get_qfrommvr(i) - endif + end if ! hgwf = this%xnew(n) m = n ! ! -- solve for current uzf cell - call this%uzfobj%solve(this%uzfobjwork, ivertflag, i, & - this%totfluxtot, this%ietflag, & - this%issflag,this%iseepflag, hgwf, & - qfrommvr, ierr, & - reset_state=reset_state, & - trhs=trhs1, thcof=thcof1, deriv=uzderiv, & + call this%uzfobj%solve(this%uzfobjwork, ivertflag, i, & + this%totfluxtot, this%ietflag, & + this%issflag, this%iseepflag, hgwf, & + qfrommvr, ierr, & + reset_state=reset_state, & + trhs=trhs1, thcof=thcof1, deriv=uzderiv, & watercontent=wc) ! ! -- terminate if an error condition has occurred if (ierr > 0) then - if ( ierr == 1 ) & - errmsg = 'UZF variable NWAVESETS needs to be increased.' - call store_error(errmsg, terminate=.TRUE.) + if (ierr == 1) & + errmsg = 'UZF variable NWAVESETS needs to be increased.' + call store_error(errmsg, terminate=.TRUE.) end if ! ! -- Calculate gwet - if ( this%igwetflag > 0 ) then + if (this%igwetflag > 0) then call this%uzfobj%setgwpet(i) - call this%uzfobj%simgwet(this%igwetflag,i,hgwf,trhs2,thcof2, & - derivgwet) + call this%uzfobj%simgwet(this%igwetflag, i, hgwf, trhs2, thcof2, & + derivgwet) end if ! ! -- distribute PET to deeper cells @@ -1783,23 +1802,23 @@ subroutine uzf_solve(this, reset_state) this%rhs(i) = -trhs1 + trhs2 ! ! -- add spring discharge and rejected infiltration to mover - if(this%imover == 1) then + if (this%imover == 1) then qformvr = this%gwd(i) + this%rejinf(i) call this%pakmvrobj%accumulate_qformvr(i, qformvr) - endif + end if ! ! -- Store water content this%wcnew(i) = wc ! ! -- Calculate change in mobile storage - this%qsto(i) = get_storage_change(this%uzfobj%celtop(i), & - this%uzfobj%celbot(i), & - this%uzfobj%uzfarea(i), & - watabold, & - this%uzfobj%watab(i), & + this%qsto(i) = get_storage_change(this%uzfobj%celtop(i), & + this%uzfobj%celbot(i), & + this%uzfobj%uzfarea(i), & + watabold, & + this%uzfobj%watab(i), & this%wcold(i), this%wcnew(i), & this%uzfobj%thtr(i), delt, this%issflag) - ! + ! end if end do ! @@ -1819,27 +1838,27 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return end subroutine define_listlabel - subroutine findcellabove(this,n,nml) + subroutine findcellabove(this, n, nml) class(UzfType) :: this integer(I4B), intent(in) :: n integer(I4B), intent(inout) :: nml @@ -1848,23 +1867,23 @@ subroutine findcellabove(this,n,nml) ! ! -- return nml = n if no cell is above it nml = n - do ipos = this%dis%con%ia(n)+1, this%dis%con%ia(n+1)-1 + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) - if(this%dis%con%ihc(ipos) /= 0) then + if (this%dis%con%ihc(ipos) /= 0) then if (n < m) then ! -- m is beneath n else - nml = m ! -- m is above n + nml = m ! -- m is above n exit - endif + end if end if - enddo + end do return - end subroutine findcellabove + end subroutine findcellabove - subroutine read_cell_properties(this) + subroutine read_cell_properties(this) ! ****************************************************************************** -! read_cell_properties -- Read UZF cell properties and set them for +! read_cell_properties -- Read UZF cell properties and set them for ! UzfCellGroup type. ! ****************************************************************************** use InputOutputModule, only: urword @@ -1890,13 +1909,13 @@ subroutine read_cell_properties(this) ! ! ! -- allocate space for node counter and initilize - allocate(rowmaxnnz(this%dis%nodes)) + allocate (rowmaxnnz(this%dis%nodes)) do n = 1, this%dis%nodes rowmaxnnz(n) = 0 end do ! ! -- allocate space for local variables - allocate(nboundchk(this%nodes)) + allocate (nboundchk(this%nodes)) do n = 1, this%nodes nboundchk(n) = 0 end do @@ -1914,33 +1933,33 @@ subroutine read_cell_properties(this) ! ! -- get uzf properties block call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse locations block if detected if (isfound) then - write(this%iout,'(/1x,3a)') 'PROCESSING ', trim(adjustl(this%text)), & - ' PACKAGEDATA' + write (this%iout, '(/1x,3a)') 'PROCESSING ', trim(adjustl(this%text)), & + ' PACKAGEDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit ! ! -- get uzf cell number i = this%parser%GetInteger() - + if (i < 1 .or. i > this%nodes) then - write(errmsg,'(2(a,1x),i0,a)') & - 'IUZNO must be greater than 0 and less than', & - 'or equal to', this%nodes , '.' + write (errmsg, '(2(a,1x),i0,a)') & + 'IUZNO must be greater than 0 and less than', & + 'or equal to', this%nodes, '.' call store_error(errmsg) cycle - end if + end if ! ! -- increment nboundchk nboundchk(i) = nboundchk(i) + 1 ! ! -- store the reduced gwf nodenumber in igwfnode call this%parser%GetCellid(this%dis%ndim, cellid) - ic = this%dis%noder_from_cellid(cellid, & + ic = this%dis%noder_from_cellid(cellid, & this%parser%iuactive, this%iout) this%igwfnode(i) = ic rowmaxnnz(ic) = rowmaxnnz(ic) + 1 @@ -1948,8 +1967,8 @@ subroutine read_cell_properties(this) ! -- landflag landflag = this%parser%GetInteger() if (landflag < 0 .OR. landflag > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,a)') & - 'LANDFLAG for uzf cell', i, & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') & + 'LANDFLAG for uzf cell', i, & 'must be 0 or 1 (specified value is', landflag, ').' call store_error(errmsg) end if @@ -1957,24 +1976,24 @@ subroutine read_cell_properties(this) ! -- ivertcon ivertcon = this%parser%GetInteger() if (ivertcon < 0 .OR. ivertcon > this%nodes) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,a)') & - 'IVERTCON for uzf cell', i, & - 'must be 0 or less than NUZFCELLS (specified value is', & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') & + 'IVERTCON for uzf cell', i, & + 'must be 0 or less than NUZFCELLS (specified value is', & ivertcon, ').' call store_error(errmsg) end if ! ! -- surfdep - surfdep = this%parser%GetDouble() - if (surfdep <= DZERO .and. landflag > 0) then !need to check for cell thickness - write(errmsg,'(a,1x,i0,1x,a,1x,g0,a)') & - 'SURFDEP for uzf cell', i, & + surfdep = this%parser%GetDouble() + if (surfdep <= DZERO .and. landflag > 0) then !need to check for cell thickness + write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') & + 'SURFDEP for uzf cell', i, & 'must be greater than 0 (specified value is', surfdep, ').' call store_error(errmsg) end if - if(surfdep >= this%GWFTOP(ic) - this%GWFBOT(ic)) then - write(errmsg,'(a,1x,i0,1x,a)') & - 'SURFDEP for uzf cell', i, & + if (surfdep >= this%GWFTOP(ic) - this%GWFBOT(ic)) then + write (errmsg, '(a,1x,i0,1x,a)') & + 'SURFDEP for uzf cell', i, & 'cannot be greater than the cell thickness.' call store_error(errmsg) end if @@ -1982,8 +2001,8 @@ subroutine read_cell_properties(this) ! -- vks vks = this%parser%GetDouble() if (vks <= DZERO) then - write(errmsg,'(a,1x,i0,1x,a,1x,g0,a)') & - 'VKS for uzf cell', i, & + write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') & + 'VKS for uzf cell', i, & 'must be greater than 0 (specified value ia', vks, ').' call store_error(errmsg) end if @@ -1991,17 +2010,17 @@ subroutine read_cell_properties(this) ! -- thtr thtr = this%parser%GetDouble() if (thtr <= DZERO) then - write(errmsg,'(a,1x,i0,1x,a,1x,g0,a)') & - 'THTR for uzf cell', i, & - 'must be greater than 0 (specified value is', thtr, ').' + write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') & + 'THTR for uzf cell', i, & + 'must be greater than 0 (specified value is', thtr, ').' call store_error(errmsg) end if ! ! -- thts thts = this%parser%GetDouble() if (thts <= thtr) then - write(errmsg,'(a,1x,i0,1x,a,1x,g0,a)') & - 'THTS for uzf cell', i, & + write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') & + 'THTS for uzf cell', i, & 'must be greater than THTR (specified value is', thts, ').' call store_error(errmsg) end if @@ -2009,9 +2028,9 @@ subroutine read_cell_properties(this) ! -- thti thti = this%parser%GetDouble() if (thti < thtr .OR. thti > thts) then - write(errmsg,'(a,1x,i0,1x,a,1x,a,1x,g0,a)') & - 'THTI for uzf cell', i, & - 'must be greater than or equal to THTR AND less than THTS', & + write (errmsg, '(a,1x,i0,1x,a,1x,a,1x,g0,a)') & + 'THTI for uzf cell', i, & + 'must be greater than or equal to THTR AND less than THTS', & '(specified value is', thti, ').' call store_error(errmsg) end if @@ -2019,8 +2038,8 @@ subroutine read_cell_properties(this) ! -- eps eps = this%parser%GetDouble() if (eps < 3.5 .OR. eps > 14) then - write(errmsg,'(a,1x,i0,1x,a,1x,g0,a)') & - 'EPSILON for uzf cell', i, & + write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') & + 'EPSILON for uzf cell', i, & 'must be between 3.5 and 14.0 (specified value is', eps, ').' call store_error(errmsg) end if @@ -2028,19 +2047,19 @@ subroutine read_cell_properties(this) ! -- boundname if (this%inamedbound == 1) then call this%parser%GetStringCaps(this%uzfname(i)) - endif + end if ! ! -- set data if there are no data errors if (count_errors() == 0) then n = this%igwfnode(i) - call this%uzfobj%setdata(i, this%gwfarea(n), this%gwftop(n), & - this%gwfbot(n), surfdep, vks, thtr, thts, & + call this%uzfobj%setdata(i, this%gwfarea(n), this%gwftop(n), & + this%gwfbot(n), surfdep, vks, thtr, thts, & thti, eps, this%ntrail, landflag, ivertcon) if (ivertcon > 0) then this%iuzf2uzf = 1 end if end if - ! + ! end do else call store_error('Required packagedata block not found.') @@ -2049,11 +2068,11 @@ subroutine read_cell_properties(this) ! -- check for duplicate or missing uzf cells do i = 1, this%nodes if (nboundchk(i) == 0) then - write(errmsg,'(a,1x,i0,a)') & + write (errmsg, '(a,1x,i0,a)') & 'No data specified for uzf cell', i, '.' call store_error(errmsg) else if (nboundchk(i) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'Data for uzf cell', i, 'specified', nboundchk(i), 'times.' call store_error(errmsg) end if @@ -2074,12 +2093,12 @@ subroutine read_cell_properties(this) end do ! ! -- create ia and ja from sparse - call sparse%filliaja(this%ia,this%ja,ierr) + call sparse%filliaja(this%ia, this%ja, ierr) ! ! -- set imaxcellcnt do i = 1, this%dis%nodes jcol = 0 - do j = this%ia(i), this%ia(i+1) - 1 + do j = this%ia(i), this%ia(i + 1) - 1 jcol = jcol + 1 end do if (jcol > this%imaxcellcnt) then @@ -2096,8 +2115,8 @@ subroutine read_cell_properties(this) end if ! ! -- deallocate local variables - deallocate(rowmaxnnz) - deallocate(nboundchk) + deallocate (rowmaxnnz) + deallocate (nboundchk) ! ! -- return return @@ -2105,14 +2124,14 @@ end subroutine read_cell_properties subroutine print_cell_properties(this) ! ****************************************************************************** -! print_cell_properties -- Read UZF cell properties and set them for +! print_cell_properties -- Read UZF cell properties and set them for ! UZFCellGroup type. ! ****************************************************************************** ! ------------------------------------------------------------------------------ ! -- dummy class(UzfType), intent(inout) :: this ! -- local - character (len=20) :: cellid + character(len=20) :: cellid character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag integer(I4B) :: ntabrows @@ -2132,8 +2151,8 @@ subroutine print_cell_properties(this) end if ! ! -- initialize table and define columns - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') STATIC UZF CELL DATA' + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') STATIC UZF CELL DATA' call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(ntabrows, ntabcols, this%iout) tag = 'NUMBER' @@ -2192,7 +2211,7 @@ subroutine print_cell_properties(this) return end subroutine print_cell_properties - subroutine check_cell_area(this) + subroutine check_cell_area(this) ! ****************************************************************************** ! check_cell_area -- Check UZF cell areas. ! ****************************************************************************** @@ -2231,8 +2250,8 @@ subroutine check_cell_area(this) area2 = this%uzfobj%uzfarea(i2) d = abs(area - area2) if (d > DEM6) then - write(errmsg,'(2(a,1x,g0,1x,a,1x,i0,1x),a)') & - 'UZF cell area (', area, ') for cell ', i, & + write (errmsg, '(2(a,1x,g0,1x,a,1x,i0,1x),a)') & + 'UZF cell area (', area, ') for cell ', i, & 'does not equal uzf cell area (', area2, ') for cell ', i2, '.' call store_error(errmsg) end if @@ -2243,7 +2262,7 @@ subroutine check_cell_area(this) ! to the GWF cell area do n = 1, this%dis%nodes i0 = this%ia(n) - i1 = this%ia(n+1) + i1 = this%ia(n + 1) ! -- skip gwf cells with no UZF cells if ((i1 - i0) < 1) cycle sumarea = DZERO @@ -2251,8 +2270,8 @@ subroutine check_cell_area(this) cuzfcells = '' do j = i0, i1 - 1 i = this%ja(j) - write(cuzf,'(i0)') i - cuzfcells = trim(adjustl(cuzfcells)) // ' ' // trim(adjustl(cuzf)) + write (cuzf, '(i0)') i + cuzfcells = trim(adjustl(cuzfcells))//' '//trim(adjustl(cuzf)) sumarea = sumarea + this%uzfobj%uzfarea(i) cellarea = this%uzfobj%cellarea(i) end do @@ -2260,9 +2279,9 @@ subroutine check_cell_area(this) d = abs(sumarea - cellarea) if (d > DEM6) then call this%dis%noder_to_string(n, cellid) - write(errmsg,'(a,1x,g0,1x,a,1x,g0,1x,a,1x,a,1x,a,a,a)') & - 'Total uzf cell area (', sumarea, & - ') exceeds the gwf cell area (', cellarea, ') of cell', cellid, & + write (errmsg, '(a,1x,g0,1x,a,1x,g0,1x,a,1x,a,1x,a,a,a)') & + 'Total uzf cell area (', sumarea, & + ') exceeds the gwf cell area (', cellarea, ') of cell', cellid, & 'which includes uzf cell(s): ', trim(adjustl(cuzfcells)), '.' call store_error(errmsg) end if @@ -2305,7 +2324,7 @@ subroutine uzf_df_obs(this) class(UzfType) :: this ! -- local integer(I4B) :: indx - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ ! ! -- Store obs type and assign procedure pointer ! @@ -2394,61 +2413,61 @@ subroutine uzf_bd_obs(this) n = obsrv%indxbnds(ii) v = DNODATA select case (obsrv%ObsTypeId) - case ('UZF-GWRCH') - v = this%rch(n) - case ('UZF-GWD') - v = this%gwd(n) + case ('UZF-GWRCH') + v = this%rch(n) + case ('UZF-GWD') + v = this%gwd(n) + if (v > DZERO) then + v = -v + end if + case ('UZF-GWD-TO-MVR') + if (this%imover == 1) then + v = this%gwdtomvr(n) if (v > DZERO) then v = -v end if - case ('UZF-GWD-TO-MVR') - if (this%imover == 1) then - v = this%gwdtomvr(n) - if (v > DZERO) then - v = -v - end if - end if - case ('UZF-GWET') - if (this%igwetflag > 0) then - v = this%gwet(n) - if (v > DZERO) then - v = -v - end if - end if - case ('INFILTRATION') - v = this%appliedinf(n) - case ('FROM-MVR') - if (this%imover == 1) then - v = this%pakmvrobj%get_qfrommvr(n) - end if - case ('REJ-INF') - v = this%rejinf(n) + end if + case ('UZF-GWET') + if (this%igwetflag > 0) then + v = this%gwet(n) if (v > DZERO) then v = -v end if - case ('REJ-INF-TO-MVR') - if (this%imover == 1) then - v = this%rejinftomvr(n) - if (v > DZERO) then - v = -v - end if + end if + case ('INFILTRATION') + v = this%appliedinf(n) + case ('FROM-MVR') + if (this%imover == 1) then + v = this%pakmvrobj%get_qfrommvr(n) + end if + case ('REJ-INF') + v = this%rejinf(n) + if (v > DZERO) then + v = -v + end if + case ('REJ-INF-TO-MVR') + if (this%imover == 1) then + v = this%rejinftomvr(n) + if (v > DZERO) then + v = -v end if - case ('UZET') - if (this%ietflag /= 0) then - v = this%uzet(n) - if (v > DZERO) then - v = -v - end if + end if + case ('UZET') + if (this%ietflag /= 0) then + v = this%uzet(n) + if (v > DZERO) then + v = -v end if - case ('STORAGE') - v = -this%qsto(n) - case ('NET-INFILTRATION') - v = this%infiltration(n) - case ('WATER-CONTENT') - v = this%uzfobj%get_water_content_at_depth(n, obsrv%obsDepth) - case default - errmsg = 'Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(errmsg) + end if + case ('STORAGE') + v = -this%qsto(n) + case ('NET-INFILTRATION') + v = this%infiltration(n) + case ('WATER-CONTENT') + v = this%uzfobj%get_water_content_at_depth(n, obsrv%obsDepth) + case default + errmsg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId) + call store_error(errmsg) end select call this%obs%SaveOneSimval(obsrv, v) end do @@ -2477,7 +2496,7 @@ subroutine uzf_rp_obs(this) real(DP) :: obsdepth real(DP) :: dmax character(len=LENBOUNDNAME) :: bname - class(ObserveType), pointer :: obsrv => null() + class(ObserveType), pointer :: obsrv => null() ! -------------------------------------------------------------------------- ! -- formats 60 format('Invalid node number in OBS input: ', i0) @@ -2507,9 +2526,9 @@ subroutine uzf_rp_obs(this) ! -- Define intPak1 so that obs_theta is stored (for first uzf ! cell if multiple cells share the same boundname). obsrv%intPak1 = j - endif - endif - enddo + end if + end if + end do else ! ! -- get node number @@ -2523,7 +2542,7 @@ subroutine uzf_rp_obs(this) call store_error(errmsg) else obsrv%BndFound = .true. - endif + end if obsrv%CurrentTimeStepEndValue = DZERO call obsrv%AddObsIndex(nn) end if @@ -2533,9 +2552,9 @@ subroutine uzf_rp_obs(this) if (obsrv%ObsTypeId == 'WATER-CONTENT') then n = obsrv%indxbnds_count if (n /= 1) then - write (errmsg, '(a,3(1x,a))') & - trim(adjustl(obsrv%ObsTypeId)), 'for observation', & - trim(adjustl(obsrv%Name)), & + write (errmsg, '(a,3(1x,a))') & + trim(adjustl(obsrv%ObsTypeId)), 'for observation', & + trim(adjustl(obsrv%Name)), & 'must be assigned to a UZF cell with a unique boundname.' call store_error(errmsg, terminate=.TRUE.) end if @@ -2555,21 +2574,21 @@ subroutine uzf_rp_obs(this) ! -- need to think about a way to put bounds on this depth ! -- Also, an observation depth of 0.0, whether a landflag == 1 object ! -- or a subsurface object, is not legit since this would be at a - ! -- a layer interface and therefore a discontinuity. + ! -- a layer interface and therefore a discontinuity. if (obsdepth <= DZERO .or. obsdepth > dmax) then - write (errmsg, '(a,3(1x,a),1x,g0,1x,a,1x,g0,a)') & - trim(adjustl(obsrv%ObsTypeId)), 'for observation', & - trim(adjustl(obsrv%Name)), 'specified depth (', obsdepth, & + write (errmsg, '(a,3(1x,a),1x,g0,1x,a,1x,g0,a)') & + trim(adjustl(obsrv%ObsTypeId)), 'for observation', & + trim(adjustl(obsrv%Name)), 'specified depth (', obsdepth, & ') must be greater than 0.0 and less than ', dmax, '.' call store_error(errmsg) - endif + end if else do j = 1, obsrv%indxbnds_count - nn = obsrv%indxbnds(j) + nn = obsrv%indxbnds(j) if (nn < 1 .or. nn > this%maxbound) then - write (errmsg, '(a,2(1x,a),1x,i0,1x,a,1x,i0,a)') & - trim(adjustl(obsrv%ObsTypeId)), 'uzfno must be greater than 0 ', & - 'and less than or equal to', this%maxbound, & + write (errmsg, '(a,2(1x,a),1x,i0,1x,a,1x,i0,a)') & + trim(adjustl(obsrv%ObsTypeId)), 'uzfno must be greater than 0 ', & + 'and less than or equal to', this%maxbound, & '(specified value is ', nn, ').' call store_error(errmsg) end if @@ -2591,10 +2610,10 @@ subroutine uzf_process_obsID(obsrv, dis, inunitobs, iout) ! -- This procedure is pointed to by ObsDataType%ProcesssIdPtr. It processes ! the ID string of an observation definition for UZF-package observations. ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: n, nn real(DP) :: obsdepth @@ -2602,7 +2621,7 @@ subroutine uzf_process_obsID(obsrv, dis, inunitobs, iout) real(DP) :: r character(len=LINELENGTH) :: strng ! formats - 30 format(i10) +30 format(i10) ! strng = obsrv%IDstring ! -- Extract node number from strng and store it. @@ -2612,7 +2631,7 @@ subroutine uzf_process_obsID(obsrv, dis, inunitobs, iout) ! -- get node number call urword(strng, icol, istart, istop, 1, n, r, iout, inunitobs) read (strng(istart:istop), 30, iostat=istat) nn - if (istat==0) then + if (istat == 0) then ! -- store uzf node number (NodeNumber) obsrv%NodeNumber = nn else @@ -2624,15 +2643,15 @@ subroutine uzf_process_obsID(obsrv, dis, inunitobs, iout) ! so assign NodeNumber as a value that indicates observation ! is for a named boundary or group of boundaries. obsrv%NodeNumber = NAMEDBOUNDFLAG - endif + end if ! ! -- for soil water observation, store depth - if (obsrv%ObsTypeId=='WATER-CONTENT' ) then + if (obsrv%ObsTypeId == 'WATER-CONTENT') then call urword(strng, icol, istart, istop, 3, n, r, iout, inunitobs) obsdepth = r ! -- store observations depth obsrv%Obsdepth = obsdepth - endif + end if ! return end subroutine uzf_process_obsID @@ -2722,24 +2741,24 @@ subroutine uzf_da(this) ! ! -- deallocate uzf objects call this%uzfobj%dealloc() - deallocate(this%uzfobj) - nullify(this%uzfobj) + deallocate (this%uzfobj) + nullify (this%uzfobj) call this%uzfobjwork%dealloc() call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) + deallocate (this%budobj) + nullify (this%budobj) ! ! -- character arrays - deallocate(this%bdtxt) - deallocate(this%cauxcbc) - deallocate(this%uzfname) + deallocate (this%bdtxt) + deallocate (this%cauxcbc) + deallocate (this%uzfname) ! ! -- package csv table if (this%ipakcsv > 0) then call this%pakcsvtab%table_da() - deallocate(this%pakcsvtab) - nullify(this%pakcsvtab) + deallocate (this%pakcsvtab) + nullify (this%pakcsvtab) end if ! ! -- deallocate scalars @@ -2813,7 +2832,7 @@ end subroutine uzf_da subroutine uzf_setup_budobj(this) ! ****************************************************************************** ! uzf_setup_budobj -- Set up the budget object that stores all the uzf flows -! The terms listed here must correspond in number and order to the ones +! The terms listed here must correspond in number and order to the ones ! listed in the uzf_fill_budobj routine. ! ****************************************************************************** ! @@ -2844,7 +2863,7 @@ subroutine uzf_setup_budobj(this) end if end do ! - ! -- Determine the number of uzf budget terms. These are fixed for + ! -- Determine the number of uzf budget terms. These are fixed for ! the simulation and cannot change. This includes FLOW-JA-FACE ! so they can be written to the binary budget files, but these internal ! flows are not included as part of the budget table. @@ -2889,10 +2908,10 @@ subroutine uzf_setup_budobj(this) end do end if ! - ! -- + ! -- text = ' GWF' idx = idx + 1 - maxlist = this%nodes + maxlist = this%nodes naux = 1 auxtxt(1) = ' FLOW-AREA' call this%budobj%budterm(idx)%initialize(text, & @@ -2909,7 +2928,7 @@ subroutine uzf_setup_budobj(this) call this%budobj%budterm(idx)%update_term(n, n2, q) end do ! - ! -- + ! -- text = ' INFILTRATION' idx = idx + 1 maxlist = this%nodes @@ -2922,7 +2941,7 @@ subroutine uzf_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' REJ-INF' idx = idx + 1 maxlist = this%nodes @@ -2935,7 +2954,7 @@ subroutine uzf_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' UZET' if (this%ietflag /= 0) then idx = idx + 1 @@ -2950,7 +2969,7 @@ subroutine uzf_setup_budobj(this) naux) end if ! - ! -- + ! -- text = ' STORAGE' idx = idx + 1 maxlist = this%nodes @@ -2964,10 +2983,10 @@ subroutine uzf_setup_budobj(this) maxlist, .false., .false., & naux, auxtxt) ! - ! -- + ! -- if (this%imover == 1) then ! - ! -- + ! -- text = ' FROM-MVR' idx = idx + 1 maxlist = this%nodes @@ -2980,7 +2999,7 @@ subroutine uzf_setup_budobj(this) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' REJ-INF-TO-MVR' idx = idx + 1 maxlist = this%nodes @@ -2994,11 +3013,11 @@ subroutine uzf_setup_budobj(this) naux) end if ! - ! -- + ! -- naux = this%naux if (naux > 0) then ! - ! -- + ! -- text = ' AUXILIARY' idx = idx + 1 maxlist = this%maxbound @@ -3018,7 +3037,7 @@ subroutine uzf_setup_budobj(this) ! ! -- return return - + end subroutine uzf_setup_budobj subroutine uzf_fill_budobj(this) @@ -3054,7 +3073,7 @@ subroutine uzf_fill_budobj(this) nlen = 0 do n = 1, this%nodes ivertflag = this%uzfobj%ivertcon(n) - if ( ivertflag > 0 ) then + if (ivertflag > 0) then nlen = nlen + 1 end if end do @@ -3160,7 +3179,7 @@ subroutine uzf_fill_budobj(this) end if call this%budobj%budterm(idx)%update_term(n, n, q) end do - + end if ! ! -- AUXILIARY VARIABLES diff --git a/src/Model/GroundWaterFlow/gwf3wel8.f90 b/src/Model/GroundWaterFlow/gwf3wel8.f90 index bdd32ea0c83..008580a6475 100644 --- a/src/Model/GroundWaterFlow/gwf3wel8.f90 +++ b/src/Model/GroundWaterFlow/gwf3wel8.f90 @@ -16,12 +16,12 @@ module WelModule ! -- modules used by WelModule methods use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE, DNODATA, MAXCHARLEN - use SimVariablesModule, only: errmsg - use SimModule, only: store_error + use SimVariablesModule, only: errmsg + use SimModule, only: store_error use MemoryHelperModule, only: create_mem_path use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor - use SmoothingModule, only: sQSaturation, sQSaturationDerivative + use SmoothingModule, only: sQSaturation, sQSaturationDerivative use ObserveModule, only: ObserveType use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList @@ -33,13 +33,13 @@ module WelModule private public :: wel_create ! - character(len=LENFTYPE) :: ftype = 'WEL' !< package ftype - character(len=16) :: text = ' WEL' !< package flow text string + character(len=LENFTYPE) :: ftype = 'WEL' !< package ftype + character(len=16) :: text = ' WEL' !< package flow text string ! type, extends(BndType) :: WelType - integer(I4B), pointer :: iflowred => null() !< flag indicating if the AUTO_FLOW_REDUCE option is active - real(DP), pointer :: flowred => null() !< AUTO_FLOW_REDUCE variable - integer(I4B), pointer :: ioutafrcsv => null() !< unit number for CSV output file containing wells with reduced puping rates + integer(I4B), pointer :: iflowred => null() !< flag indicating if the AUTO_FLOW_REDUCE option is active + real(DP), pointer :: flowred => null() !< AUTO_FLOW_REDUCE variable + integer(I4B), pointer :: ioutafrcsv => null() !< unit number for CSV output file containing wells with reduced puping rates contains procedure :: allocate_scalars => wel_allocate_scalars procedure :: bnd_options => wel_options @@ -67,526 +67,527 @@ module WelModule !! !< subroutine wel_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) - ! -- dummy variables - class(BndType), pointer :: packobj !< pointer to default package type - integer(I4B),intent(in) :: id !< package id - integer(I4B),intent(in) :: ibcnum !< boundary condition number - integer(I4B),intent(in) :: inunit !< unit number of WEL package input file - integer(I4B),intent(in) :: iout !< unit number of model listing file - character(len=*), intent(in) :: namemodel !< model name - character(len=*), intent(in) :: pakname !< package name - ! -- local variables - type(WelType), pointer :: welobj - ! - ! -- allocate the object and assign values to object variables - allocate(welobj) - packobj => welobj - ! - ! -- create name and memory path - call packobj%set_names(ibcnum, namemodel, pakname, ftype) - packobj%text = text - ! - ! -- allocate scalars - call welobj%allocate_scalars() - ! - ! -- initialize package - call packobj%pack_initialize() + ! -- dummy variables + class(BndType), pointer :: packobj !< pointer to default package type + integer(I4B), intent(in) :: id !< package id + integer(I4B), intent(in) :: ibcnum !< boundary condition number + integer(I4B), intent(in) :: inunit !< unit number of WEL package input file + integer(I4B), intent(in) :: iout !< unit number of model listing file + character(len=*), intent(in) :: namemodel !< model name + character(len=*), intent(in) :: pakname !< package name + ! -- local variables + type(WelType), pointer :: welobj + ! + ! -- allocate the object and assign values to object variables + allocate (welobj) + packobj => welobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call welobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() - packobj%inunit=inunit - packobj%iout=iout - packobj%id=id - packobj%ibcnum = ibcnum - packobj%ncolbnd=1 - packobj%iscloc=1 - packobj%ictMemPath = create_mem_path(namemodel,'NPF') - ! - ! -- return - return - end subroutine wel_create + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + packobj%ictMemPath = create_mem_path(namemodel, 'NPF') + ! + ! -- return + return + end subroutine wel_create - !> @ brief Deallocate package memory + !> @ brief Deallocate package memory !! !! Deallocate WEL package scalars and arrays. !! - !< - subroutine wel_da(this) - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy variables - class(WelType) :: this !< WelType object - ! - ! -- Deallocate parent package - call this%BndType%bnd_da() - ! - ! -- scalars - call mem_deallocate(this%iflowred) - call mem_deallocate(this%flowred) - call mem_deallocate(this%ioutafrcsv) - ! - ! -- return - return - end subroutine wel_da + !< + subroutine wel_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy variables + class(WelType) :: this !< WelType object + ! + ! -- Deallocate parent package + call this%BndType%bnd_da() + ! + ! -- scalars + call mem_deallocate(this%iflowred) + call mem_deallocate(this%flowred) + call mem_deallocate(this%ioutafrcsv) + ! + ! -- return + return + end subroutine wel_da - !> @ brief Allocate scalars + !> @ brief Allocate scalars !! !! Allocate and initialize scalars for the WEL package. The base model !! allocate scalars method is also called. !! - !< - subroutine wel_allocate_scalars(this) - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy variables - class(WelType) :: this !< WelType object - ! - ! -- call standard BndType allocate scalars - call this%BndType%allocate_scalars() - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%iflowred, 'IFLOWRED', this%memoryPath) - call mem_allocate(this%flowred, 'FLOWRED', this%memoryPath) - call mem_allocate(this%ioutafrcsv, 'IOUTAFRCSV', this%memoryPath) - ! - ! -- Set values - this%iflowred = 0 - this%ioutafrcsv = 0 - this%flowred = DZERO - ! - ! -- return - return - end subroutine wel_allocate_scalars + !< + subroutine wel_allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy variables + class(WelType) :: this !< WelType object + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%iflowred, 'IFLOWRED', this%memoryPath) + call mem_allocate(this%flowred, 'FLOWRED', this%memoryPath) + call mem_allocate(this%ioutafrcsv, 'IOUTAFRCSV', this%memoryPath) + ! + ! -- Set values + this%iflowred = 0 + this%ioutafrcsv = 0 + this%flowred = DZERO + ! + ! -- return + return + end subroutine wel_allocate_scalars - !> @ brief Read additional options for package + !> @ brief Read additional options for package !! !! Read additional options for WEL package. !! - !< - subroutine wel_options(this, option, found) - ! -- modules - use InputOutputModule, only: urword - ! -- dummy variables - class(WelType), intent(inout) :: this !< WelType object - character(len=*), intent(inout) :: option !< option keyword string - logical, intent(inout) :: found !< boolean indicating if option found - ! -- local variables - real(DP) :: r - character(len=MAXCHARLEN) :: fname - character(len=MAXCHARLEN) :: keyword - ! -- formats - character(len=*),parameter :: fmtflowred = & - "(4x, 'AUTOMATIC FLOW REDUCTION OF WELLS IMPLEMENTED.')" - character(len=*),parameter :: fmtflowredv = & - "(4x, 'AUTOMATIC FLOW REDUCTION FRACTION (',g15.7,').')" - ! - ! -- Check for 'AUTO_FLOW_REDUCE' and set this%iflowred - select case (option) - case('AUTO_FLOW_REDUCE') - this%iflowred = 1 - r = this%parser%GetDouble() - if (r <= DZERO) then - r = DEM1 - else if (r > DONE) then - r = DONE - end if - this%flowred = r - ! - ! -- Write option and return with found set to true - if(this%iflowred > 0) & - write(this%iout, fmtflowred) - write(this%iout, fmtflowredv) this%flowred - found = .true. - case('AUTO_FLOW_REDUCE_CSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - call this%wel_afr_csv_init(fname) - else - call store_error('OPTIONAL AUTO_FLOW_REDUCE_CSV KEYWORD MUST BE & - &FOLLOWED BY FILEOUT') - end if - case('MOVER') - this%imover = 1 - write(this%iout, '(4x,A)') 'MOVER OPTION ENABLED' - found = .true. - case default - ! - ! -- No options found - found = .false. - end select - ! - ! -- return - return - end subroutine wel_options + !< + subroutine wel_options(this, option, found) + ! -- modules + use InputOutputModule, only: urword + ! -- dummy variables + class(WelType), intent(inout) :: this !< WelType object + character(len=*), intent(inout) :: option !< option keyword string + logical, intent(inout) :: found !< boolean indicating if option found + ! -- local variables + real(DP) :: r + character(len=MAXCHARLEN) :: fname + character(len=MAXCHARLEN) :: keyword + ! -- formats + character(len=*), parameter :: fmtflowred = & + &"(4x, 'AUTOMATIC FLOW REDUCTION OF WELLS IMPLEMENTED.')" + character(len=*), parameter :: fmtflowredv = & + &"(4x, 'AUTOMATIC FLOW REDUCTION FRACTION (',g15.7,').')" + ! + ! -- Check for 'AUTO_FLOW_REDUCE' and set this%iflowred + select case (option) + case ('AUTO_FLOW_REDUCE') + this%iflowred = 1 + r = this%parser%GetDouble() + if (r <= DZERO) then + r = DEM1 + else if (r > DONE) then + r = DONE + end if + this%flowred = r + ! + ! -- Write option and return with found set to true + if (this%iflowred > 0) & + write (this%iout, fmtflowred) + write (this%iout, fmtflowredv) this%flowred + found = .true. + case ('AUTO_FLOW_REDUCE_CSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + call this%wel_afr_csv_init(fname) + else + call store_error('OPTIONAL AUTO_FLOW_REDUCE_CSV KEYWORD MUST BE & + &FOLLOWED BY FILEOUT') + end if + case ('MOVER') + this%imover = 1 + write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED' + found = .true. + case default + ! + ! -- No options found + found = .false. + end select + ! + ! -- return + return + end subroutine wel_options - !> @ brief Formulate the package hcof and rhs terms. + !> @ brief Formulate the package hcof and rhs terms. !! !! Formulate the hcof and rhs terms for the WEL package that will be !! added to the coefficient matrix and right-hand side vector. !! - !< - subroutine wel_cf(this, reset_mover) - ! -- dummy variables - class(WelType) :: this !< WelType object - logical, intent(in), optional :: reset_mover !< boolean for resetting mover - ! -- local variables - integer(I4B) :: i, node, ict - real(DP) :: qmult - real(DP) :: q - real(DP) :: tp - real(DP) :: bt - real(DP) :: thick - logical :: lrm - ! - ! -- Return if no wells - if(this%nbound == 0) return - ! - ! -- pakmvrobj cf - lrm = .true. - if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then - call this%pakmvrobj%cf() - endif - ! - ! -- Calculate hcof and rhs for each well entry - do i = 1, this%nbound - node = this%nodelist(i) - this%hcof(i) = DZERO - if(this%ibound(node) <= 0) then - this%rhs(i) = DZERO - cycle - end if - q = this%bound(1,i) - if (this%iflowred /= 0 .and. q < DZERO) then - ict = this%icelltype(node) - if (ict /= 0) then - tp = this%dis%top(node) - bt = this%dis%bot(node) - thick = tp - bt - tp = bt + this%flowred * thick - qmult = sQSaturation(tp, bt, this%xnew(node)) - q = q * qmult - endif + !< + subroutine wel_cf(this, reset_mover) + ! -- dummy variables + class(WelType) :: this !< WelType object + logical, intent(in), optional :: reset_mover !< boolean for resetting mover + ! -- local variables + integer(I4B) :: i, node, ict + real(DP) :: qmult + real(DP) :: q + real(DP) :: tp + real(DP) :: bt + real(DP) :: thick + logical :: lrm + ! + ! -- Return if no wells + if (this%nbound == 0) return + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if (this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + end if + ! + ! -- Calculate hcof and rhs for each well entry + do i = 1, this%nbound + node = this%nodelist(i) + this%hcof(i) = DZERO + if (this%ibound(node) <= 0) then + this%rhs(i) = DZERO + cycle + end if + q = this%bound(1, i) + if (this%iflowred /= 0 .and. q < DZERO) then + ict = this%icelltype(node) + if (ict /= 0) then + tp = this%dis%top(node) + bt = this%dis%bot(node) + thick = tp - bt + tp = bt + this%flowred * thick + qmult = sQSaturation(tp, bt, this%xnew(node)) + q = q * qmult end if - this%rhs(i) = -q - enddo - ! - return - end subroutine wel_cf + end if + this%rhs(i) = -q + end do + ! + return + end subroutine wel_cf - !> @ brief Copy hcof and rhs terms into solution. + !> @ brief Copy hcof and rhs terms into solution. !! - !! Add the hcof and rhs terms for the WEL package to the + !! Add the hcof and rhs terms for the WEL package to the !! coefficient matrix and right-hand side vector. !! - !< - subroutine wel_fc(this, rhs, ia, idxglo, amatsln) - ! -- dummy variables - class(WelType) :: this !< WelType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix - ! -- local variables - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: ipos - ! - ! -- pakmvrobj fc - if(this%imover == 1) then - call this%pakmvrobj%fc() - endif - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - ! - ! -- If mover is active and this well is discharging, - ! store available water (as positive value). - if(this%imover == 1 .and. this%rhs(i) > DZERO) then - call this%pakmvrobj%accumulate_qformvr(i, this%rhs(i)) - endif - enddo - ! - ! -- return - return - end subroutine wel_fc + !< + subroutine wel_fc(this, rhs, ia, idxglo, amatsln) + ! -- dummy variables + class(WelType) :: this !< WelType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + ! -- local variables + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: ipos + ! + ! -- pakmvrobj fc + if (this%imover == 1) then + call this%pakmvrobj%fc() + end if + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + ! + ! -- If mover is active and this well is discharging, + ! store available water (as positive value). + if (this%imover == 1 .and. this%rhs(i) > DZERO) then + call this%pakmvrobj%accumulate_qformvr(i, this%rhs(i)) + end if + end do + ! + ! -- return + return + end subroutine wel_fc - !> @ brief Add Newton-Raphson terms for package into solution. + !> @ brief Add Newton-Raphson terms for package into solution. !! - !! Calculate and add the Newton-Raphson terms for the WEL package to the + !! Calculate and add the Newton-Raphson terms for the WEL package to the !! coefficient matrix and right-hand side vector. !! - !< - subroutine wel_fn(this, rhs, ia, idxglo, amatsln) - ! -- dummy variables - class(WelType) :: this !< WelType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix - ! -- local variables - integer(I4B) :: i - integer(I4B) :: node - integer(I4B) :: ipos - integer(I4B) :: ict - real(DP) :: drterm - real(DP) :: q - real(DP) :: tp - real(DP) :: bt - real(DP) :: thick + !< + subroutine wel_fn(this, rhs, ia, idxglo, amatsln) + ! -- dummy variables + class(WelType) :: this !< WelType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + ! -- local variables + integer(I4B) :: i + integer(I4B) :: node + integer(I4B) :: ipos + integer(I4B) :: ict + real(DP) :: drterm + real(DP) :: q + real(DP) :: tp + real(DP) :: bt + real(DP) :: thick + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + node = this%nodelist(i) + ! + ! -- test if node is constant or inactive + if (this%ibound(node) <= 0) then + cycle + end if ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - node = this%nodelist(i) - ! - ! -- test if node is constant or inactive - if(this%ibound(node) <= 0) then - cycle + ! -- well rate is possibly head dependent + ict = this%icelltype(node) + if (this%iflowred /= 0 .and. ict /= 0) then + ipos = ia(node) + q = -this%rhs(i) + if (q < DZERO) then + ! -- calculate derivative for well + tp = this%dis%top(node) + bt = this%dis%bot(node) + thick = tp - bt + tp = bt + this%flowred * thick + drterm = sQSaturationDerivative(tp, bt, this%xnew(node)) + drterm = drterm * this%bound(1, i) + !--fill amat and rhs with newton-raphson terms + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm + rhs(node) = rhs(node) + drterm * this%xnew(node) end if - ! - ! -- well rate is possibly head dependent - ict = this%icelltype(node) - if (this%iflowred /= 0 .and. ict /= 0) then - ipos = ia(node) - q = -this%rhs(i) - if (q < DZERO) then - ! -- calculate derivative for well - tp = this%dis%top(node) - bt = this%dis%bot(node) - thick = tp - bt - tp = bt + this%flowred * thick - drterm = sQSaturationDerivative(tp, bt, this%xnew(node)) - drterm = drterm * this%bound(1,i) - !--fill amat and rhs with newton-raphson terms - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - rhs(node) = rhs(node) + drterm * this%xnew(node) - end if - end if - end do - ! - ! -- return - return - end subroutine wel_fn + end if + end do + ! + ! -- return + return + end subroutine wel_fn - !> @brief Initialize the auto flow reduce csv output file - subroutine wel_afr_csv_init(this, fname) - ! -- dummy variables - class(WelType), intent(inout) :: this !< WelType object - character(len=*), intent(in) :: fname - ! -- format - character(len=*),parameter :: fmtafrcsv = & - "(4x, 'AUTO FLOW REDUCE INFORMATION WILL BE SAVED TO FILE: ', a, /4x, & + !> @brief Initialize the auto flow reduce csv output file + subroutine wel_afr_csv_init(this, fname) + ! -- dummy variables + class(WelType), intent(inout) :: this !< WelType object + character(len=*), intent(in) :: fname + ! -- format + character(len=*), parameter :: fmtafrcsv = & + "(4x, 'AUTO FLOW REDUCE INFORMATION WILL BE SAVED TO FILE: ', a, /4x, & &'OPENED ON UNIT: ', I0)" - - this%ioutafrcsv = getunit() - call openfile(this%ioutafrcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtafrcsv) trim(adjustl(fname)), & - this%ioutafrcsv - write(this%ioutafrcsv, '(a)') & - 'time,period,step,boundnumber,cellnumber,rate-requested,rate-actual,wel-reduction' - return - end subroutine wel_afr_csv_init - - !> @brief Write out auto flow reductions only when & where they occur - subroutine wel_afr_csv_write(this) - ! -- modules - use TdisModule, only: totim, kstp, kper - ! -- dummy variables - class(WelType), intent(inout) :: this !< WelType object - ! -- local - integer(I4B) :: i - integer(I4B) :: nodereduced - integer(I4B) :: nodeuser - real(DP) :: v - ! -- format - do i = 1, this%nbound - nodereduced = this%nodelist(i) - ! - ! -- test if node is constant or inactive - if(this%ibound(nodereduced) <= 0) then - cycle - end if - v = this%bound(1,i) + this%rhs(i) - if (v < DZERO) then - nodeuser = this%dis%get_nodeuser(nodereduced) - write(this%ioutafrcsv,'(*(G0,:,","))') & - totim, kper, kstp, i, nodeuser, this%bound(1,i), this%simvals(i), v - end if - enddo - end subroutine wel_afr_csv_write - - !> @ brief Define the list label for the package + + this%ioutafrcsv = getunit() + call openfile(this%ioutafrcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtafrcsv) trim(adjustl(fname)), & + this%ioutafrcsv + write (this%ioutafrcsv, '(a)') & + 'time,period,step,boundnumber,cellnumber,rate-requested,& + &rate-actual,wel-reduction' + return + end subroutine wel_afr_csv_init + + !> @brief Write out auto flow reductions only when & where they occur + subroutine wel_afr_csv_write(this) + ! -- modules + use TdisModule, only: totim, kstp, kper + ! -- dummy variables + class(WelType), intent(inout) :: this !< WelType object + ! -- local + integer(I4B) :: i + integer(I4B) :: nodereduced + integer(I4B) :: nodeuser + real(DP) :: v + ! -- format + do i = 1, this%nbound + nodereduced = this%nodelist(i) + ! + ! -- test if node is constant or inactive + if (this%ibound(nodereduced) <= 0) then + cycle + end if + v = this%bound(1, i) + this%rhs(i) + if (v < DZERO) then + nodeuser = this%dis%get_nodeuser(nodereduced) + write (this%ioutafrcsv, '(*(G0,:,","))') & + totim, kper, kstp, i, nodeuser, this%bound(1, i), this%simvals(i), v + end if + end do + end subroutine wel_afr_csv_write + + !> @ brief Define the list label for the package !! !! Method defined the list label for the WEL package. The list label is !! the heading that is written to iout when PRINT_INPUT option is used. !! - !< - subroutine define_listlabel(this) - ! -- dummy variables - class(WelType), intent(inout) :: this !< WelType object - ! - ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if (this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' - else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - end if - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if (this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - end if - ! - ! -- return - return - end subroutine define_listlabel + !< + subroutine define_listlabel(this) + ! -- dummy variables + class(WelType), intent(inout) :: this !< WelType object + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if + ! + ! -- return + return + end subroutine define_listlabel - ! -- Procedures related to observations + ! -- Procedures related to observations - !> @brief Determine if observations are supported. + !> @brief Determine if observations are supported. !! !! Function to determine if observations are supported by the WEL package. !! Observations are supported by the WEL package. !! !! @return wel_obs_supported boolean indicating if observations are supported !! - !< - logical function wel_obs_supported(this) - ! -- dummy variables - class(WelType) :: this !< WelType object - ! - ! -- set boolean - wel_obs_supported = .true. - ! - ! -- return - return - end function wel_obs_supported + !< + logical function wel_obs_supported(this) + ! -- dummy variables + class(WelType) :: this !< WelType object + ! + ! -- set boolean + wel_obs_supported = .true. + ! + ! -- return + return + end function wel_obs_supported - !> @brief Define the observation types available in the package + !> @brief Define the observation types available in the package !! !! Method to define the observation types available in the WEL package. !! - !< - subroutine wel_df_obs(this) - ! -- dummy variables - class(WelType) :: this !< WelType object - ! -- local variables - integer(I4B) :: indx - ! - ! -- initialize observations - call this%obs%StoreObsType('wel', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- Store obs type and assign procedure pointer - ! for to-mvr observation type. - call this%obs%StoreObsType('to-mvr', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- Store obs type and assign procedure pointer - ! for wel-reduction observation type. - call this%obs%StoreObsType('wel-reduction', .true., indx) - this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor - ! - ! -- return - return - end subroutine wel_df_obs + !< + subroutine wel_df_obs(this) + ! -- dummy variables + class(WelType) :: this !< WelType object + ! -- local variables + integer(I4B) :: indx + ! + ! -- initialize observations + call this%obs%StoreObsType('wel', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for wel-reduction observation type. + call this%obs%StoreObsType('wel-reduction', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine wel_df_obs - !> @brief Save observations for the package + !> @brief Save observations for the package !! !! Method to save simulated values for the WEL package. !! - !< - subroutine wel_bd_obs(this) - ! -- dummy variables - class(WelType) :: this !< WelType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: jj - real(DP) :: v - type(ObserveType), pointer :: obsrv => null() - ! - ! -- clear the observations - call this%obs%obs_bd_clear() - ! - ! -- Save simulated values for all of package's observations. - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - if (obsrv%BndFound) then - do n = 1, obsrv%indxbnds_count - v = DNODATA - jj = obsrv%indxbnds(n) - select case (obsrv%ObsTypeId) - case ('TO-MVR') - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(jj) - if (v > DZERO) then - v = -v - end if - end if - case ('WEL') - v = this%simvals(jj) - case('WEL-REDUCTION') - if (this%iflowred > 0) then - v = this%bound(1,jj) + this%rhs(jj) + !< + subroutine wel_bd_obs(this) + ! -- dummy variables + class(WelType) :: this !< WelType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: jj + real(DP) :: v + type(ObserveType), pointer :: obsrv => null() + ! + ! -- clear the observations + call this%obs%obs_bd_clear() + ! + ! -- Save simulated values for all of package's observations. + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + if (obsrv%BndFound) then + do n = 1, obsrv%indxbnds_count + v = DNODATA + jj = obsrv%indxbnds(n) + select case (obsrv%ObsTypeId) + case ('TO-MVR') + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(jj) + if (v > DZERO) then + v = -v end if - case default - errmsg = 'Unrecognized observation type: ' // trim(obsrv%ObsTypeId) - call store_error(errmsg) - end select - call this%obs%SaveOneSimval(obsrv, v) - end do - else - call this%obs%SaveOneSimval(obsrv, DNODATA) - endif - end do - ! - ! -- Write the auto flow reduce csv file entries for this step - if (this%ioutafrcsv > 0) then - call this%wel_afr_csv_write() + end if + case ('WEL') + v = this%simvals(jj) + case ('WEL-REDUCTION') + if (this%iflowred > 0) then + v = this%bound(1, jj) + this%rhs(jj) + end if + case default + errmsg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId) + call store_error(errmsg) + end select + call this%obs%SaveOneSimval(obsrv, v) + end do + else + call this%obs%SaveOneSimval(obsrv, DNODATA) end if - ! - ! -- return - return - end subroutine wel_bd_obs + end do + ! + ! -- Write the auto flow reduce csv file entries for this step + if (this%ioutafrcsv > 0) then + call this%wel_afr_csv_write() + end if + ! + ! -- return + return + end subroutine wel_bd_obs - ! -- Procedure related to time series + ! -- Procedure related to time series - !> @brief Assign time series links for the package + !> @brief Assign time series links for the package !! !! Assign the time series links for the WEL package. Only !! the Q variable can be defined with time series. !! - !< - subroutine wel_rp_ts(this) - ! -- dummy variables - class(WelType), intent(inout) :: this !< WelType object - ! -- local variables - integer(I4B) :: i, nlinks - type(TimeSeriesLinkType), pointer :: tslink => null() - ! - ! -- set up the time series links - nlinks = this%TsManager%boundtslinks%Count() - do i = 1, nlinks - tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) - if (associated(tslink)) then - if (tslink%JCol==1) then - tslink%Text = 'Q' - end if + !< + subroutine wel_rp_ts(this) + ! -- dummy variables + class(WelType), intent(inout) :: this !< WelType object + ! -- local variables + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + ! -- set up the time series links + nlinks = this%TsManager%boundtslinks%Count() + do i = 1, nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + if (tslink%JCol == 1) then + tslink%Text = 'Q' end if - end do - ! - ! -- return - return - end subroutine wel_rp_ts + end if + end do + ! + ! -- return + return + end subroutine wel_rp_ts end module WelModule From ae433c447536d51f23989af92d4088d73272d327 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 15:32:05 -0700 Subject: [PATCH 004/212] Updating the contents of the src/Exchange/ directory with the fprettify stuff. 2 files that I wrote need to have fprettify applied. --- src/Exchange/BaseExchange.f90 | 54 +- src/Exchange/DisConnExchange.f90 | 837 ++++++++--------- src/Exchange/GhostNode.f90 | 441 +++++---- src/Exchange/GweGweExchange.f90 | 1358 ++++++++++++++++++++++++++++ src/Exchange/GwfGweExchange.f90 | 526 +++++++++++ src/Exchange/GwfGwfExchange.f90 | 1040 ++++++++++----------- src/Exchange/GwfGwtExchange.f90 | 209 ++--- src/Exchange/GwtGwtExchange.f90 | 619 ++++++------- src/Exchange/NumericalExchange.f90 | 38 +- 9 files changed, 3509 insertions(+), 1613 deletions(-) create mode 100644 src/Exchange/GweGweExchange.f90 create mode 100644 src/Exchange/GwfGweExchange.f90 diff --git a/src/Exchange/BaseExchange.f90 b/src/Exchange/BaseExchange.f90 index 1cf9d630e8f..5b323c6ea52 100644 --- a/src/Exchange/BaseExchange.f90 +++ b/src/Exchange/BaseExchange.f90 @@ -1,20 +1,20 @@ module BaseExchangeModule - - use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LENEXCHANGENAME, LENMEMPATH - use ListModule, only: ListType - use BaseModelModule, only: BaseModelType + + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: LENEXCHANGENAME, LENMEMPATH + use ListModule, only: ListType + use BaseModelModule, only: BaseModelType implicit none - + private public :: BaseExchangeType, AddBaseExchangeToList, GetBaseExchangeFromList private :: CastAsBaseExchangeClass - + type, abstract :: BaseExchangeType - character(len=LENEXCHANGENAME) :: name !< the name of this exchange - character(len=LENMEMPATH) :: memoryPath !< the location in the memory manager where the variables are stored - integer(I4B) :: id + character(len=LENEXCHANGENAME) :: name !< the name of this exchange + character(len=LENMEMPATH) :: memoryPath !< the location in the memory manager where the variables are stored + integer(I4B) :: id contains procedure(exg_df), deferred :: exg_df procedure(exg_ar), deferred :: exg_ar @@ -39,9 +39,9 @@ subroutine exg_ar(this) end subroutine end interface - - contains - + +contains + subroutine exg_rp(this) ! ****************************************************************************** ! exg_rp -- Read and prepare @@ -63,7 +63,7 @@ subroutine exg_rp(this) ! -- Return return end subroutine exg_rp - + subroutine exg_calculate_delt(this) ! ****************************************************************************** ! exg_calculate_delt -- Calculate time step length @@ -81,7 +81,7 @@ subroutine exg_calculate_delt(this) ! -- Return return end subroutine exg_calculate_delt - + subroutine exg_ot(this) ! ****************************************************************************** ! exg_ot -- Output @@ -97,7 +97,7 @@ subroutine exg_ot(this) ! -- Return return end subroutine exg_ot - + subroutine exg_fp(this) ! ****************************************************************************** ! exg_fp -- Final processing @@ -113,7 +113,7 @@ subroutine exg_fp(this) ! -- Return return end subroutine exg_fp - + subroutine exg_da(this) ! ****************************************************************************** ! exg_da -- Deallocate @@ -134,15 +134,15 @@ end subroutine exg_da !! added to the solution where the model resides !< function connects_model(this, model) result(is_connected) - class(BaseExchangeType) :: this !< the instance of the exchange - class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection - logical(LGP) :: is_connected !< true, when connected + class(BaseExchangeType) :: this !< the instance of the exchange + class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection + logical(LGP) :: is_connected !< true, when connected is_connected = .false. end function - function CastAsBaseExchangeClass(obj) result (res) + function CastAsBaseExchangeClass(obj) result(res) ! ****************************************************************************** ! CastAsBaseExchangeClass ! ****************************************************************************** @@ -173,7 +173,7 @@ subroutine AddBaseExchangeToList(list, exchange) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list class(BaseExchangeType), pointer, intent(inout) :: exchange ! -- local class(*), pointer :: obj @@ -184,8 +184,8 @@ subroutine AddBaseExchangeToList(list, exchange) ! return end subroutine AddBaseExchangeToList - - function GetBaseExchangeFromList(list, idx) result (res) + + function GetBaseExchangeFromList(list, idx) result(res) ! ****************************************************************************** ! GetBaseExchangeFromList ! ****************************************************************************** @@ -193,9 +193,9 @@ function GetBaseExchangeFromList(list, idx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(BaseExchangeType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(BaseExchangeType), pointer :: res ! -- local class(*), pointer :: obj ! ------------------------------------------------------------------------------ diff --git a/src/Exchange/DisConnExchange.f90 b/src/Exchange/DisConnExchange.f90 index e81ea496a2e..0f02cdc32de 100644 --- a/src/Exchange/DisConnExchange.f90 +++ b/src/Exchange/DisConnExchange.f90 @@ -1,440 +1,445 @@ module DisConnExchangeModule -use KindModule, only: I4B, DP, LGP -use SimVariablesModule, only: errmsg -use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LINELENGTH -use ListModule, only: ListType -use MemoryManagerModule, only: mem_allocate -use BlockParserModule, only: BlockParserType -use NumericalModelModule, only: NumericalModelType -use NumericalExchangeModule, only: NumericalExchangeType -implicit none - -private -public :: DisConnExchangeType -public :: CastAsDisConnExchangeClass, AddDisConnExchangeToList, & - GetDisConnExchangeFromList - -!> Exchange based on connection between discretizations of DisBaseType. -!! The data specifies the connections, similar to the information stored -!! in the connections object: DisBaseType%con -!< -type, extends(NumericalExchangeType) :: DisConnExchangeType - character(len=LINELENGTH), pointer :: filename => null() !< name of the input file - - class(NumericalModelType), pointer :: model1 => null() !< model 1 - class(NumericalModelType), pointer :: model2 => null() !< model 2 - integer(I4B), pointer :: nexg => null() !< number of exchanges - integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() !< node numbers in model 1 - integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() !< node numbers in model 2 - integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !< horizontal connection indicator array, size: nexg - real(DP), dimension(:), pointer, contiguous :: cl1 => null() !< connection length 1, size: nexg - real(DP), dimension(:), pointer, contiguous :: cl2 => null() !< connection length 2, size: nexg - real(DP), dimension(:), pointer, contiguous :: hwva => null() !< horizontal widths, vertical flow areas, size: nexg - integer(I4B), pointer :: naux => null() !< number of auxiliary variables - character(len=LENBOUNDNAME), dimension(:), & - pointer, contiguous :: boundname => null() !< boundnames - - character(len=LENAUXNAME), dimension(:), & - pointer, contiguous :: auxname => null() !< vector of auxname - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< array of auxiliary variable values - integer(I4B), pointer :: ianglex => null() !< flag indicating anglex was read, if read, ianglex is index in auxvar - integer(I4B), pointer :: icdist => null() !< flag indicating cdist was read, if read, icdist is index in auxvar - integer(I4B), pointer :: iprpak => null() !< print input flag - integer(I4B), pointer :: inamedbound => null() !< flag to read boundnames - - integer(I4B), pointer :: ixt3d => null() !< flag indicating if XT3D should be applied on the interface: 0 = off, 1 = lhs, 2 = rhs - logical(LGP) :: dev_ifmod_on !< development option, forces interface model for this exchange - - type(BlockParserType) :: parser !< block parser for input file (controlled from derived type) + use KindModule, only: I4B, DP, LGP + use SimVariablesModule, only: errmsg + use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LINELENGTH + use ListModule, only: ListType + use MemoryManagerModule, only: mem_allocate, mem_reallocate + use BlockParserModule, only: BlockParserType + use NumericalModelModule, only: NumericalModelType + use NumericalExchangeModule, only: NumericalExchangeType + implicit none + + private + public :: DisConnExchangeType + public :: CastAsDisConnExchangeClass, AddDisConnExchangeToList, & + GetDisConnExchangeFromList + + !> Exchange based on connection between discretizations of DisBaseType. + !! The data specifies the connections, similar to the information stored + !! in the connections object: DisBaseType%con + !< + type, extends(NumericalExchangeType) :: DisConnExchangeType + character(len=LINELENGTH), pointer :: filename => null() !< name of the input file + + class(NumericalModelType), pointer :: model1 => null() !< model 1 + class(NumericalModelType), pointer :: model2 => null() !< model 2 + integer(I4B), pointer :: nexg => null() !< number of exchanges + integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() !< node numbers in model 1 + integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() !< node numbers in model 2 + integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !< horizontal connection indicator array, size: nexg + real(DP), dimension(:), pointer, contiguous :: cl1 => null() !< connection length 1, size: nexg + real(DP), dimension(:), pointer, contiguous :: cl2 => null() !< connection length 2, size: nexg + real(DP), dimension(:), pointer, contiguous :: hwva => null() !< horizontal widths, vertical flow areas, size: nexg + integer(I4B), pointer :: naux => null() !< number of auxiliary variables + character(len=LENBOUNDNAME), dimension(:), & + pointer, contiguous :: boundname => null() !< boundnames + + character(len=LENAUXNAME), dimension(:), & + pointer, contiguous :: auxname => null() !< vector of auxname + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< array of auxiliary variable values + integer(I4B), pointer :: ianglex => null() !< flag indicating anglex was read, if read, ianglex is index in auxvar + integer(I4B), pointer :: icdist => null() !< flag indicating cdist was read, if read, icdist is index in auxvar + integer(I4B), pointer :: iprpak => null() !< print input flag + integer(I4B), pointer :: inamedbound => null() !< flag to read boundnames + + integer(I4B), pointer :: ixt3d => null() !< flag indicating if XT3D should be applied on the interface: 0 = off, 1 = lhs, 2 = rhs + logical(LGP) :: dev_ifmod_on !< development option, forces interface model for this exchange + + type(BlockParserType) :: parser !< block parser for input file (controlled from derived type) contains - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: disconnex_da - procedure :: use_interface_model + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: disconnex_da + procedure :: use_interface_model - ! protected - procedure, pass(this) :: parse_option - procedure, pass(this) :: read_dimensions - procedure, pass(this) :: read_data + ! protected + procedure, pass(this) :: parse_option + procedure, pass(this) :: read_dimensions + procedure, pass(this) :: read_data -end type DisConnExchangeType + end type DisConnExchangeType contains -!> @brief Parse option from exchange file -!< -function parse_option(this, keyword, iout) result(parsed) - use ArrayHandlersModule, only: ifind - use InputOutputModule, only: urdaux - class(DisConnExchangeType) :: this !< instance of exchange object - character(len=LINELENGTH), intent(in) :: keyword !< the option name - integer(I4B), intent(in) :: iout !< for logging - logical(LGP) :: parsed !< true when parsed - ! local - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: lloc - integer(I4B) :: n - integer(I4B) :: ival - - character(len=:), allocatable :: line - character(len=LENAUXNAME), dimension(:), allocatable :: caux - - parsed = .true. - - select case (keyword) - case('AUXILIARY') - call this%parser%GetRemainingLine(line) - lloc = 1 - call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & - istop, caux, line, 'GWF_GWF_Exchange') - call mem_allocate(this%auxname, LENAUXNAME, this%naux, & - 'AUXNAME', trim(this%memoryPath)) - do n = 1, this%naux - this%auxname(n) = caux(n) - end do - deallocate(caux) - ! - ! -- If ANGLDEGX is an auxiliary variable, then anisotropy can be - ! used in either model. Store ANGLDEGX position in this%ianglex - ival = ifind(this%auxname, 'ANGLDEGX') - if (ival > 0) then - this%ianglex = ival - end if - ival = ifind(this%auxname, 'CDIST') - if(ival > 0) then - this%icdist = ival - end if - case ('PRINT_INPUT') - this%iprpak = 1 - write(iout,'(4x,a)') & - 'THE LIST OF EXCHANGES WILL BE PRINTED.' - case ('XT3D') - this%ixt3d = 1 - write(iout, '(4x,a)') 'XT3D WILL BE APPLIED ON THE INTERFACE' - case ('BOUNDNAMES') - this%inamedbound = 1 - write(iout, '(4x,a)') 'EXCHANGE BOUNDARIES HAVE NAMES IN LAST COLUMN' - case('DEV_INTERFACEMODEL_ON') - call this%parser%DevOpt() - this%dev_ifmod_on = .true. - write(iout, '(4x,2a)') 'Interface model coupling approach manually & - &activated for ', trim(this%name) - case default - ! not parsed here, assuming it is in derived type - parsed = .false. - end select - -end function parse_option - -!> @brief Read dimensions from file -!< -subroutine read_dimensions(this, iout) - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error - class(DisConnExchangeType) :: this !< instance of exchange object - integer(I4B), intent(in) :: iout !< output file unit - ! local - character(len=LINELENGTH) :: keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - - ! get dimensions block - call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - - ! parse NEXG - if (isfound) then - write(iout,'(1x,a)') 'PROCESSING EXCHANGE DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) + !> @brief Parse option from exchange file + !< + function parse_option(this, keyword, iout) result(parsed) + use ArrayHandlersModule, only: ifind + use InputOutputModule, only: urdaux + class(DisConnExchangeType) :: this !< instance of exchange object + character(len=LINELENGTH), intent(in) :: keyword !< the option name + integer(I4B), intent(in) :: iout !< for logging + logical(LGP) :: parsed !< true when parsed + ! local + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: lloc + integer(I4B) :: n + integer(I4B) :: ival + + character(len=:), allocatable :: line + character(len=LENAUXNAME), dimension(:), allocatable :: caux + + parsed = .true. + + select case (keyword) + case ('AUXILIARY') + call this%parser%GetRemainingLine(line) + lloc = 1 + call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & + istop, caux, line, 'GWF_GWF_Exchange') + call mem_reallocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', trim(this%memoryPath)) + do n = 1, this%naux + this%auxname(n) = caux(n) + end do + deallocate (caux) + ! + ! -- If ANGLDEGX is an auxiliary variable, then anisotropy can be + ! used in either model. Store ANGLDEGX position in this%ianglex + ival = ifind(this%auxname, 'ANGLDEGX') + if (ival > 0) then + this%ianglex = ival + end if + ival = ifind(this%auxname, 'CDIST') + if (ival > 0) then + this%icdist = ival + end if + case ('PRINT_INPUT') + this%iprpak = 1 + write (iout, '(4x,a)') & + 'THE LIST OF EXCHANGES WILL BE PRINTED.' + case ('XT3D') + this%ixt3d = 1 + write (iout, '(4x,a)') 'XT3D WILL BE APPLIED ON THE INTERFACE' + case ('BOUNDNAMES') + this%inamedbound = 1 + write (iout, '(4x,a)') 'EXCHANGE BOUNDARIES HAVE NAMES IN LAST COLUMN' + case ('DEV_INTERFACEMODEL_ON') + call this%parser%DevOpt() + this%dev_ifmod_on = .true. + write (iout, '(4x,2a)') 'Interface model coupling approach manually & + &activated for ', trim(this%name) + case default + ! not parsed here, assuming it is in derived type + parsed = .false. + end select + + end function parse_option + + !> @brief Read dimensions from file + !< + subroutine read_dimensions(this, iout) + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error + class(DisConnExchangeType) :: this !< instance of exchange object + integer(I4B), intent(in) :: iout !< output file unit + ! local + character(len=LINELENGTH) :: keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + + ! get dimensions block + call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & + supportOpenClose=.true.) + + ! parse NEXG + if (isfound) then + write (iout, '(1x,a)') 'PROCESSING EXCHANGE DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) case ('NEXG') this%nexg = this%parser%GetInteger() - write(iout,'(4x,a,i0)') 'NEXG = ', this%nexg + write (iout, '(4x,a,i0)') 'NEXG = ', this%nexg case default - errmsg = "Unknown dimension '" // trim(keyword) // "'." + errmsg = "Unknown dimension '"//trim(keyword)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() - end select - end do - write(iout,'(1x,a)') 'END OF EXCHANGE DIMENSIONS' - else - call store_error('Required dimensions block not found.') - call this%parser%StoreErrorUnit() - end if - - return -end subroutine read_dimensions - -!> @brief Read exchange data block from file -!< -subroutine read_data(this, iout) - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, store_error_unit, count_errors - class(DisConnExchangeType) :: this !< instance of exchange object - integer(I4B), intent(in) :: iout !< the output file unit - ! local - character(len=LINELENGTH) :: nodestr, node1str, node2str, cellid - character(len=2) :: cnfloat - integer(I4B) :: lloc, ierr, nerr, iaux - integer(I4B) :: iexg, nodem1, nodem2, nodeum1, nodeum2 - logical :: isfound, endOfBlock - - character(len=*), parameter :: fmtexglabel = "(5x, 3a10, 50(a16))" - character(len=*), parameter :: fmtexgdata = & - "(5x, a, 1x, a ,I10, 50(1pg16.6))" - character(len=40) :: fmtexgdata2 - - ! get data block - call this%parser%GetBlock('EXCHANGEDATA', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - write(iout,'(1x,a)')'PROCESSING EXCHANGEDATA' - if(this%iprpak /= 0) then - if (this%inamedbound==0) then - write(iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', & - 'CL1', 'CL2', 'HWVA', (adjustr(this%auxname(iaux)), & - iaux = 1, this%naux) - else - write(iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', 'CL1', 'CL2', & - 'HWVA', (adjustr(this%auxname(iaux)),iaux=1,this%naux), & - ' BOUNDNAME ' - ! Define format suitable for writing input data, - ! any auxiliary variables, and boundname. - write(cnfloat,'(i0)') 3+this%naux - fmtexgdata2 = '(5x, a, 1x, a, i10, ' // trim(cnfloat) // & - '(1pg16.6), 1x, a)' - endif - endif - do iexg = 1, this%nexg - call this%parser%GetNextLine(endOfBlock) - lloc = 1 - ! - ! -- Read and check node 1 - call this%parser%GetCellid(this%model1%dis%ndim, cellid, flag_string=.true.) - nodem1 = this%model1%dis%noder_from_cellid(cellid, this%parser%iuactive, & - iout, flag_string=.true.) - this%nodem1(iexg) = nodem1 - ! - ! -- Read and check node 2 - call this%parser%GetCellid(this%model2%dis%ndim, cellid, flag_string=.true.) - nodem2 = this%model2%dis%noder_from_cellid(cellid, this%parser%iuactive, & - iout, flag_string=.true.) - this%nodem2(iexg) = nodem2 - ! - ! -- Read rest of input line - this%ihc(iexg) = this%parser%GetInteger() - this%cl1(iexg) = this%parser%GetDouble() - this%cl2(iexg) = this%parser%GetDouble() - this%hwva(iexg) = this%parser%GetDouble() - do iaux = 1, this%naux - this%auxvar(iaux, iexg) = this%parser%GetDouble() - enddo - if (this%inamedbound==1) then - call this%parser%GetStringCaps(this%boundname(iexg)) - endif - ! - ! -- Write the data to listing file if requested - if(this%iprpak /= 0) then - nodeum1 = this%model1%dis%get_nodeuser(nodem1) - call this%model1%dis%nodeu_to_string(nodeum1, node1str) - nodeum2 = this%model2%dis%get_nodeuser(nodem2) - call this%model2%dis%nodeu_to_string(nodeum2, node2str) + end select + end do + write (iout, '(1x,a)') 'END OF EXCHANGE DIMENSIONS' + else + call store_error('Required dimensions block not found.') + call this%parser%StoreErrorUnit() + end if + + return + end subroutine read_dimensions + + !> @brief Read exchange data block from file + !< + subroutine read_data(this, iout) + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, store_error_unit, count_errors + class(DisConnExchangeType) :: this !< instance of exchange object + integer(I4B), intent(in) :: iout !< the output file unit + ! local + character(len=LINELENGTH) :: nodestr, node1str, node2str, cellid + character(len=2) :: cnfloat + integer(I4B) :: lloc, ierr, nerr, iaux + integer(I4B) :: iexg, nodem1, nodem2, nodeum1, nodeum2 + logical :: isfound, endOfBlock + + character(len=*), parameter :: fmtexglabel = "(5x, 3a10, 50(a16))" + character(len=*), parameter :: fmtexgdata = & + "(5x, a, 1x, a ,I10, 50(1pg16.6))" + character(len=40) :: fmtexgdata2 + + ! get data block + call this%parser%GetBlock('EXCHANGEDATA', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then + write (iout, '(1x,a)') 'PROCESSING EXCHANGEDATA' + if (this%iprpak /= 0) then if (this%inamedbound == 0) then - write(iout, fmtexgdata) trim(node1str), trim(node2str), & - this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & - this%hwva(iexg), & - (this%auxvar(iaux, iexg), iaux=1,this%naux) + write (iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', & + 'CL1', 'CL2', 'HWVA', (adjustr(this%auxname(iaux)), & + iaux=1, this%naux) else - write(iout, fmtexgdata2) trim(node1str), trim(node2str), & - this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & - this%hwva(iexg), & - (this%auxvar(iaux, iexg), iaux=1,this%naux), & - trim(this%boundname(iexg)) - endif - endif + write (iout, fmtexglabel) 'NODEM1', 'NODEM2', 'IHC', 'CL1', 'CL2', & + 'HWVA', (adjustr(this%auxname(iaux)), iaux=1, this%naux), & + ' BOUNDNAME ' + ! Define format suitable for writing input data, + ! any auxiliary variables, and boundname. + write (cnfloat, '(i0)') 3 + this%naux + fmtexgdata2 = '(5x, a, 1x, a, i10, '//trim(cnfloat)// & + '(1pg16.6), 1x, a)' + end if + end if + do iexg = 1, this%nexg + call this%parser%GetNextLine(endOfBlock) + lloc = 1 + ! + ! -- Read and check node 1 + call this%parser%GetCellid(this%model1%dis%ndim, cellid, & + flag_string=.true.) + nodem1 = this%model1%dis%noder_from_cellid(cellid, this%parser%iuactive, & + iout, flag_string=.true.) + this%nodem1(iexg) = nodem1 + ! + ! -- Read and check node 2 + call this%parser%GetCellid(this%model2%dis%ndim, cellid, & + flag_string=.true.) + nodem2 = this%model2%dis%noder_from_cellid(cellid, this%parser%iuactive, & + iout, flag_string=.true.) + this%nodem2(iexg) = nodem2 + ! + ! -- Read rest of input line + this%ihc(iexg) = this%parser%GetInteger() + this%cl1(iexg) = this%parser%GetDouble() + this%cl2(iexg) = this%parser%GetDouble() + this%hwva(iexg) = this%parser%GetDouble() + do iaux = 1, this%naux + this%auxvar(iaux, iexg) = this%parser%GetDouble() + end do + if (this%inamedbound == 1) then + call this%parser%GetStringCaps(this%boundname(iexg)) + end if + ! + ! -- Write the data to listing file if requested + if (this%iprpak /= 0) then + nodeum1 = this%model1%dis%get_nodeuser(nodem1) + call this%model1%dis%nodeu_to_string(nodeum1, node1str) + nodeum2 = this%model2%dis%get_nodeuser(nodem2) + call this%model2%dis%nodeu_to_string(nodeum2, node2str) + if (this%inamedbound == 0) then + write (iout, fmtexgdata) trim(node1str), trim(node2str), & + this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & + this%hwva(iexg), & + (this%auxvar(iaux, iexg), iaux=1, this%naux) + else + write (iout, fmtexgdata2) trim(node1str), trim(node2str), & + this%ihc(iexg), this%cl1(iexg), this%cl2(iexg), & + this%hwva(iexg), & + (this%auxvar(iaux, iexg), iaux=1, this%naux), & + trim(this%boundname(iexg)) + end if + end if + ! + ! -- Check to see if nodem1 is outside of active domain + if (nodem1 <= 0) then + call this%model1%dis%nodeu_to_string(nodeum1, nodestr) + write (errmsg, *) & + trim(adjustl(this%model1%name))// & + ' Cell is outside active grid domain '// & + trim(adjustl(nodestr))//'.' + call store_error(errmsg) + end if + ! + ! -- Check to see if nodem2 is outside of active domain + if (nodem2 <= 0) then + call this%model2%dis%nodeu_to_string(nodeum2, nodestr) + write (errmsg, *) & + trim(adjustl(this%model2%name))// & + ' Cell is outside active grid domain '// & + trim(adjustl(nodestr))//'.' + call store_error(errmsg) + end if + end do ! - ! -- Check to see if nodem1 is outside of active domain - if(nodem1 <= 0) then - call this%model1%dis%nodeu_to_string(nodeum1, nodestr) - write(errmsg, *) & - trim(adjustl(this%model1%name)) // & - ' Cell is outside active grid domain ' // & - trim(adjustl(nodestr)) // '.' - call store_error(errmsg) - endif + ! -- Stop if errors + nerr = count_errors() + if (nerr > 0) then + call store_error('Errors encountered in exchange input file.') + call this%parser%StoreErrorUnit() + end if ! - ! -- Check to see if nodem2 is outside of active domain - if(nodem2 <= 0) then - call this%model2%dis%nodeu_to_string(nodeum2, nodestr) - write(errmsg, *) & - trim(adjustl(this%model2%name)) // & - ' Cell is outside active grid domain ' // & - trim(adjustl(nodestr)) // '.' - call store_error(errmsg) - endif - enddo - ! - ! -- Stop if errors - nerr = count_errors() - if(nerr > 0) then - call store_error('Errors encountered in exchange input file.') + write (iout, '(1x,a)') 'END OF EXCHANGEDATA' + else + errmsg = 'Required exchangedata block not found.' + call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! - write(iout,'(1x,a)')'END OF EXCHANGEDATA' - else - errmsg = 'Required exchangedata block not found.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - ! - ! -- return - return + ! -- return + return end subroutine read_data -!> @brief Allocate scalars and initialize to defaults -!< -subroutine allocate_scalars(this) - use MemoryManagerModule, only: mem_allocate - class(DisConnExchangeType) :: this !< instance of exchange object - - allocate(this%filename) - this%filename = '' - - call mem_allocate(this%nexg, 'NEXG', this%memoryPath) - call mem_allocate(this%naux, 'NAUX', this%memoryPath) - call mem_allocate(this%ianglex, 'IANGLEX', this%memoryPath) - call mem_allocate(this%icdist, 'ICDIST', this%memoryPath) - call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) - call mem_allocate(this%iprpak, 'IPRPAK', this%memoryPath) - call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%memoryPath) - - this%nexg = 0 - this%naux = 0 - this%ianglex = 0 - this%icdist = 0 - this%ixt3d = 0 - this%inamedbound = 0 - - this%dev_ifmod_on = .false. - -end subroutine allocate_scalars - -!> @brief Allocate array data, using the number of -!! connected nodes @param nexg -!< -subroutine allocate_arrays(this) - use MemoryManagerModule, only: mem_allocate - class(DisConnExchangeType) :: this !< instance of exchange object - - call mem_allocate(this%nodem1, this%nexg, 'NODEM1', this%memoryPath) - call mem_allocate(this%nodem2, this%nexg, 'NODEM2', this%memoryPath) - call mem_allocate(this%ihc, this%nexg, 'IHC', this%memoryPath) - call mem_allocate(this%cl1, this%nexg, 'CL1', this%memoryPath) - call mem_allocate(this%cl2, this%nexg, 'CL2', this%memoryPath) - call mem_allocate(this%hwva, this%nexg, 'HWVA', this%memoryPath) - ! NB: auxname array is allocated while parsing - call mem_allocate(this%auxvar, this%naux, this%nexg, 'AUXVAR', this%memoryPath) - - ! allocate boundname - if(this%inamedbound==1) then - allocate(this%boundname(this%nexg)) - else - allocate(this%boundname(1)) - endif - this%boundname(:) = '' - -end subroutine allocate_arrays - -!> @brief Should interface model be used to handle these -!! exchanges, to be overridden for inheriting types -!< -function use_interface_model(this) result(useIM) - class(DisConnExchangeType) :: this !< instance of exchange object - logical(LGP) :: useIM !< flag whether interface model should be used + !> @brief Allocate scalars and initialize to defaults + !< + subroutine allocate_scalars(this) + use MemoryManagerModule, only: mem_allocate + class(DisConnExchangeType) :: this !< instance of exchange object + + allocate (this%filename) + this%filename = '' + + call mem_allocate(this%nexg, 'NEXG', this%memoryPath) + call mem_allocate(this%naux, 'NAUX', this%memoryPath) + call mem_allocate(this%ianglex, 'IANGLEX', this%memoryPath) + call mem_allocate(this%icdist, 'ICDIST', this%memoryPath) + call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%iprpak, 'IPRPAK', this%memoryPath) + call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%memoryPath) + + call mem_allocate(this%auxname, LENAUXNAME, 0, & + 'AUXNAME', trim(this%memoryPath)) + + this%nexg = 0 + this%naux = 0 + this%ianglex = 0 + this%icdist = 0 + this%ixt3d = 0 + this%inamedbound = 0 + + this%dev_ifmod_on = .false. + + end subroutine allocate_scalars + + !> @brief Allocate array data, using the number of + !! connected nodes @param nexg + !< + subroutine allocate_arrays(this) + class(DisConnExchangeType) :: this !< instance of exchange object + + call mem_allocate(this%nodem1, this%nexg, 'NODEM1', this%memoryPath) + call mem_allocate(this%nodem2, this%nexg, 'NODEM2', this%memoryPath) + call mem_allocate(this%ihc, this%nexg, 'IHC', this%memoryPath) + call mem_allocate(this%cl1, this%nexg, 'CL1', this%memoryPath) + call mem_allocate(this%cl2, this%nexg, 'CL2', this%memoryPath) + call mem_allocate(this%hwva, this%nexg, 'HWVA', this%memoryPath) + ! NB: auxname array is allocated while parsing + call mem_allocate(this%auxvar, this%naux, this%nexg, & + 'AUXVAR', this%memoryPath) + + ! allocate boundname + if (this%inamedbound == 1) then + allocate (this%boundname(this%nexg)) + else + allocate (this%boundname(1)) + end if + this%boundname(:) = '' + + end subroutine allocate_arrays + + !> @brief Should interface model be used to handle these + !! exchanges, to be overridden for inheriting types + !< + function use_interface_model(this) result(useIM) + class(DisConnExchangeType) :: this !< instance of exchange object + logical(LGP) :: useIM !< flag whether interface model should be used !! for this exchange instead - useIM = .false. - -end function use_interface_model - -!> @brief Clean up all scalars and arrays -!< -subroutine disconnex_da(this) - use MemoryManagerModule, only: mem_deallocate - class(DisConnExchangeType) :: this !< instance of exchange object - - ! arrays - call mem_deallocate(this%nodem1) - call mem_deallocate(this%nodem2) - call mem_deallocate(this%ihc) - call mem_deallocate(this%cl1) - call mem_deallocate(this%cl2) - call mem_deallocate(this%hwva) - call mem_deallocate(this%auxvar) - - deallocate(this%boundname) - - ! scalars - call mem_deallocate(this%nexg) - call mem_deallocate(this%naux) - call mem_deallocate(this%auxname, 'AUXNAME', trim(this%memoryPath)) - call mem_deallocate(this%ianglex) - call mem_deallocate(this%icdist) - call mem_deallocate(this%ixt3d) - call mem_deallocate(this%iprpak) - call mem_deallocate(this%inamedbound) - -end subroutine disconnex_da - -function CastAsDisConnExchangeClass(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj - class(DisConnExchangeType), pointer :: res - ! - res => null() - if (.not. associated(obj)) return - ! - select type (obj) - class is (DisConnExchangeType) - res => obj - end select - return -end function CastAsDisConnExchangeClass - -subroutine AddDisConnExchangeToList(list, exchange) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - class(DisConnExchangeType), pointer, intent(in) :: exchange - ! -- local - class(*), pointer :: obj - ! - obj => exchange - call list%Add(obj) - ! - return -end subroutine AddDisConnExchangeToList - -function GetDisConnExchangeFromList(list, idx) result (res) - implicit none - ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(DisConnExchangeType), pointer :: res - ! -- local - class(*), pointer :: obj - ! - obj => list%GetItem(idx) - res => CastAsDisConnExchangeClass(obj) - ! - return -end function GetDisConnExchangeFromList - -end module DisConnExchangeModule \ No newline at end of file + useIM = .false. + + end function use_interface_model + + !> @brief Clean up all scalars and arrays + !< + subroutine disconnex_da(this) + use MemoryManagerModule, only: mem_deallocate + class(DisConnExchangeType) :: this !< instance of exchange object + + ! arrays + call mem_deallocate(this%nodem1) + call mem_deallocate(this%nodem2) + call mem_deallocate(this%ihc) + call mem_deallocate(this%cl1) + call mem_deallocate(this%cl2) + call mem_deallocate(this%hwva) + call mem_deallocate(this%auxvar) + + deallocate (this%boundname) + + ! scalars + call mem_deallocate(this%nexg) + call mem_deallocate(this%naux) + call mem_deallocate(this%auxname, 'AUXNAME', trim(this%memoryPath)) + call mem_deallocate(this%ianglex) + call mem_deallocate(this%icdist) + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%iprpak) + call mem_deallocate(this%inamedbound) + + end subroutine disconnex_da + + function CastAsDisConnExchangeClass(obj) result(res) + implicit none + class(*), pointer, intent(inout) :: obj + class(DisConnExchangeType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (DisConnExchangeType) + res => obj + end select + return + end function CastAsDisConnExchangeClass + + subroutine AddDisConnExchangeToList(list, exchange) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + class(DisConnExchangeType), pointer, intent(in) :: exchange + ! -- local + class(*), pointer :: obj + ! + obj => exchange + call list%Add(obj) + ! + return + end subroutine AddDisConnExchangeToList + + function GetDisConnExchangeFromList(list, idx) result(res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(DisConnExchangeType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsDisConnExchangeClass(obj) + ! + return + end function GetDisConnExchangeFromList + +end module DisConnExchangeModule diff --git a/src/Exchange/GhostNode.f90 b/src/Exchange/GhostNode.f90 index 649ff9814a3..b0831682432 100644 --- a/src/Exchange/GhostNode.f90 +++ b/src/Exchange/GhostNode.f90 @@ -1,10 +1,10 @@ module GhostNodeModule use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH - use NumericalModelModule, only: NumericalModelType + use ConstantsModule, only: LINELENGTH + use NumericalModelModule, only: NumericalModelType use NumericalPackageModule, only: NumericalPackageType - use BlockParserModule, only: BlockParserType + use BlockParserModule, only: BlockParserType implicit none @@ -13,36 +13,36 @@ module GhostNodeModule public :: gnc_cr type, extends(NumericalPackageType) :: GhostNodeType - logical, pointer :: smgnc => null() ! single model gnc - logical, pointer :: implicit => null() ! lhs or rhs - logical, pointer :: i2kn => null() ! not used - integer(I4B), pointer :: nexg => null() ! number of gncs - integer(I4B), pointer :: numjs => null() ! number of connecting nodes - class(NumericalModelType), pointer :: m1 => null() ! pointer to model 1 - class(NumericalModelType), pointer :: m2 => null() ! pointer to model 2 - integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() ! array of nodes in model 1 - integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() ! array of nodes in model 2 - integer(I4B), dimension(:, :), pointer, contiguous :: nodesj => null() ! array of interpolation nodes - real(DP), dimension(:), pointer, contiguous :: cond => null() ! array of conductance - integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() ! connection position in amat - integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() ! symmetric position in amat - real(DP), dimension(:, :), pointer, contiguous :: alphasj => null() ! interpolation factors - integer(I4B), dimension(:), pointer, contiguous :: idiagn => null() ! amat diagonal position of n - integer(I4B), dimension(:), pointer, contiguous :: idiagm => null() ! amat diagonal position of m - integer(I4B), dimension(:,:), pointer, contiguous :: jposinrown => null() ! amat j position in row n - integer(I4B), dimension(:,:), pointer, contiguous :: jposinrowm => null() ! amat j position in row m + logical, pointer :: smgnc => null() ! single model gnc + logical, pointer :: implicit => null() ! lhs or rhs + logical, pointer :: i2kn => null() ! not used + integer(I4B), pointer :: nexg => null() ! number of gncs + integer(I4B), pointer :: numjs => null() ! number of connecting nodes + class(NumericalModelType), pointer :: m1 => null() ! pointer to model 1 + class(NumericalModelType), pointer :: m2 => null() ! pointer to model 2 + integer(I4B), dimension(:), pointer, contiguous :: nodem1 => null() ! array of nodes in model 1 + integer(I4B), dimension(:), pointer, contiguous :: nodem2 => null() ! array of nodes in model 2 + integer(I4B), dimension(:, :), pointer, contiguous :: nodesj => null() ! array of interpolation nodes + real(DP), dimension(:), pointer, contiguous :: cond => null() ! array of conductance + integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() ! connection position in amat + integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() ! symmetric position in amat + real(DP), dimension(:, :), pointer, contiguous :: alphasj => null() ! interpolation factors + integer(I4B), dimension(:), pointer, contiguous :: idiagn => null() ! amat diagonal position of n + integer(I4B), dimension(:), pointer, contiguous :: idiagm => null() ! amat diagonal position of m + integer(I4B), dimension(:, :), pointer, contiguous :: jposinrown => null() ! amat j position in row n + integer(I4B), dimension(:, :), pointer, contiguous :: jposinrowm => null() ! amat j position in row m contains - procedure :: gnc_df - procedure :: gnc_ac - procedure :: gnc_mc + procedure :: gnc_df + procedure :: gnc_ac + procedure :: gnc_mc procedure, private :: gnc_fmsav - procedure :: gnc_fc - procedure :: gnc_fn - procedure :: gnc_cq - procedure :: gnc_ot - procedure :: gnc_da - procedure :: deltaQgnc - procedure :: allocate_scalars + procedure :: gnc_fc + procedure :: gnc_fn + procedure :: gnc_cq + procedure :: gnc_ot + procedure :: gnc_da + procedure :: deltaQgnc + procedure :: allocate_scalars procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: read_dimensions @@ -50,7 +50,7 @@ module GhostNodeModule procedure, private :: nodeu_to_noder end type GhostNodeType - contains +contains subroutine gnc_cr(gncobj, name_parent, inunit, iout) ! ****************************************************************************** @@ -68,7 +68,7 @@ subroutine gnc_cr(gncobj, name_parent, inunit, iout) ! ------------------------------------------------------------------------------ ! ! -- Allocate the gnc exchange object - allocate(gncobj) + allocate (gncobj) ! ! -- create name and memory path. name_parent will either be model name or the ! exchange name. @@ -79,7 +79,7 @@ subroutine gnc_cr(gncobj, name_parent, inunit, iout) ! ! -- Set variables gncobj%inunit = inunit - gncobj%iout = iout + gncobj%iout = iout ! ! -- return return @@ -111,7 +111,7 @@ subroutine gnc_df(this, m1, m2) if (present(m2)) then this%m2 => m2 this%smgnc = .false. - endif + end if ! ! -- Initialize block parser call this%parser%Initialize(this%inunit, this%iout) @@ -129,14 +129,14 @@ subroutine gnc_df(this, m1, m2) call this%read_data() ! ! -- Trap for implicit gnc but models are in different solutions - if(this%m1%idsoln /= this%m2%idsoln) then - if(this%implicit) then - write(errmsg, '(a)') 'Error. GNC is implicit but models are in ' // & - 'different solutions.' + if (this%m1%idsoln /= this%m2%idsoln) then + if (this%implicit) then + write (errmsg, '(a)') 'Error. GNC is implicit but models are in '// & + 'different solutions.' call store_error(errmsg) call store_error_unit(this%inunit) - endif - endif + end if + end if ! ! -- return return @@ -162,21 +162,21 @@ subroutine gnc_ac(this, sparse) ! -- Expand the sparse matrix for ghost node connections. No need to add ! connection between n and m as they must be connected some other way ! that will calculate the conductance. - if(this%implicit) then + if (this%implicit) then do ignc = 1, this%nexg noden = this%nodem1(ignc) + this%m1%moffset nodem = this%nodem2(ignc) + this%m2%moffset jloop: do jidx = 1, this%numjs nodej = this%nodesj(jidx, ignc) - if(nodej == 0) cycle + if (nodej == 0) cycle nodej = nodej + this%m1%moffset call sparse%addconnection(nodem, nodej, 1) call sparse%addconnection(nodej, nodem, 1) call sparse%addconnection(noden, nodej, 1) call sparse%addconnection(nodej, noden, 1) - enddo jloop - enddo - endif + end do jloop + end do + end if ! ! -- return return @@ -205,8 +205,8 @@ subroutine gnc_mc(this, iasln, jasln) character(len=LINELENGTH) :: errmsg integer(I4B) :: noden, nodem, ipos, j, ignc, jidx, nodej ! -- formats - character(len=*),parameter :: fmterr = & - "('GHOST NODE ERROR. Cell ', i0, ' in model ', a, & + character(len=*), parameter :: fmterr = & + "('GHOST NODE ERROR. Cell ', i0, ' in model ', a, & &' is not connected to cell ', i0, ' in model ', a)" ! ------------------------------------------------------------------------------ ! @@ -228,78 +228,76 @@ subroutine gnc_mc(this, iasln, jasln) this%idxglo(ignc) = 0 searchloopnm: do ipos = iasln(noden) + 1, iasln(noden + 1) - 1 j = jasln(ipos) - if(j == nodem) then + if (j == nodem) then this%idxglo(ignc) = ipos exit searchloopnm - endif - enddo searchloopnm + end if + end do searchloopnm ! ! -- find location of n in row m of global solution and store in idxsymglo - !if(this%implicit) then - this%idxsymglo(ignc) = 0 - searchloopmn: do ipos = iasln(nodem), iasln(nodem + 1) - 1 - j = jasln(ipos) - if(j == noden) then - this%idxsymglo(ignc) = ipos - exit searchloopmn - endif - enddo searchloopmn - !endif + this%idxsymglo(ignc) = 0 + searchloopmn: do ipos = iasln(nodem), iasln(nodem + 1) - 1 + j = jasln(ipos) + if (j == noden) then + this%idxsymglo(ignc) = ipos + exit searchloopmn + end if + end do searchloopmn ! ! -- Check to make sure idxglo is non-zero - if(this%idxglo(ignc) == 0) then - write(errmsg, fmterr) this%nodem1(ignc), trim(this%m1%name), & - this%nodem2(ignc), trim(this%m2%name) + if (this%idxglo(ignc) == 0) then + write (errmsg, fmterr) this%nodem1(ignc), trim(this%m1%name), & + this%nodem2(ignc), trim(this%m2%name) call store_error(errmsg) - endif - ! - enddo + end if + ! + end do ! ! -- Stop if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error_unit(this%inunit) - endif + end if ! ! -- find locations of j in rows n and row m of global solution - if(this%implicit) then + if (this%implicit) then do ignc = 1, this%nexg noden = this%nodem1(ignc) + this%m1%moffset nodem = this%nodem2(ignc) + this%m2%moffset ! do jidx = 1, this%numjs nodej = this%nodesj(jidx, ignc) - if(nodej > 0) nodej = nodej + this%m1%moffset + if (nodej > 0) nodej = nodej + this%m1%moffset ! ! -- search for nodej in row n, unless it is 0 - if(nodej == 0) then + if (nodej == 0) then ipos = 0 this%jposinrown(jidx, ignc) = ipos else searchloopn: do ipos = iasln(noden), iasln(noden + 1) - 1 j = jasln(ipos) - if(j == nodej) then + if (j == nodej) then this%jposinrown(jidx, ignc) = ipos exit searchloopn - endif - enddo searchloopn - endif + end if + end do searchloopn + end if ! ! -- search for nodej in row m - if(nodej == 0) then + if (nodej == 0) then ipos = 0 this%jposinrowm(jidx, ignc) = ipos else searchloopm: do ipos = iasln(nodem) + 1, iasln(nodem + 1) - 1 j = jasln(ipos) - if(j == nodej) then + if (j == nodej) then this%jposinrowm(jidx, ignc) = ipos exit searchloopm - endif - enddo searchloopm - endif - enddo - enddo - endif + end if + end do searchloopm + end if + end do + end do + end if ! ! -- return return @@ -328,13 +326,13 @@ subroutine gnc_fmsav(this, kiter, amatsln) ! nodem, and therefore the conductance is zero. gncloop: do ignc = 1, this%nexg ipos = this%idxglo(ignc) - if(ipos > 0) then + if (ipos > 0) then cond = amatsln(ipos) else cond = DZERO - endif + end if this%cond(ignc) = cond - enddo gncloop + end do gncloop ! ! -- return return @@ -362,24 +360,24 @@ subroutine gnc_fc(this, kiter, amatsln) ! ! -- If this is a single model gnc (not an exchange across models), then ! pull conductances out of amatsln and store them in this%cond - if(this%smgnc) call this%gnc_fmsav(kiter, amatsln) + if (this%smgnc) call this%gnc_fmsav(kiter, amatsln) ! ! -- Add gnc terms to rhs or to amat depending on whether gnc is implicit ! or explicit gncloop: do ignc = 1, this%nexg noden = this%nodem1(ignc) nodem = this%nodem2(ignc) - if(this%m1%ibound(noden) == 0 .or. & - this%m2%ibound(nodem) == 0) cycle gncloop + if (this%m1%ibound(noden) == 0 .or. & + this%m2%ibound(nodem) == 0) cycle gncloop ipos = this%idxglo(ignc) cond = this%cond(ignc) jloop: do jidx = 1, this%numjs j = this%nodesj(jidx, ignc) - if(j == 0) cycle + if (j == 0) cycle alpha = this%alphasj(jidx, ignc) if (alpha == DZERO) cycle aterm = alpha * cond - if(this%implicit) then + if (this%implicit) then iposjn = this%jposinrown(jidx, ignc) iposjm = this%jposinrowm(jidx, ignc) amatsln(this%idiagn(ignc)) = amatsln(this%idiagn(ignc)) + aterm @@ -390,16 +388,16 @@ subroutine gnc_fc(this, kiter, amatsln) rterm = aterm * (this%m1%x(noden) - this%m1%x(j)) this%m1%rhs(noden) = this%m1%rhs(noden) - rterm this%m2%rhs(nodem) = this%m2%rhs(nodem) + rterm - endif - enddo jloop - enddo gncloop + end if + end do jloop + end do gncloop ! ! -- return return end subroutine gnc_fc - subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & - ivarcv_opt, ictm1_opt, ictm2_opt) + subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & + ivarcv_opt, ictm1_opt, ictm2_opt) ! ****************************************************************************** ! gnc_fn -- Fill GNC Newton terms ! @@ -448,12 +446,12 @@ subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & gncloop: do ignc = 1, this%nexg noden = this%nodem1(ignc) nodem = this%nodem2(ignc) - if(this%m1%ibound(noden) == 0 .or. & - this%m2%ibound(nodem) == 0) cycle gncloop + if (this%m1%ibound(noden) == 0 .or. & + this%m2%ibound(nodem) == 0) cycle gncloop ! ! -- Assign variables depending on whether single model gnc or exchange ! gnc - if(this%smgnc) then + if (this%smgnc) then ipos = this%m1%dis%con%getjaindex(noden, nodem) isympos = this%m1%dis%con%jas(ipos) ihc = this%m1%dis%con%ihc(isympos) @@ -461,10 +459,10 @@ subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & else ihc = ihc_opt(ignc) csat = condsat(ignc) - endif + end if ! ! If vertical connection and not variable cv, then cycle - if(ihc == 0 .and. ivarcv == 0) cycle + if (ihc == 0 .and. ivarcv == 0) cycle ! ! determine upstream node (0 is noden, 1 is nodem) iups = 0 @@ -472,7 +470,7 @@ subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & ! ! -- Set the upstream top and bot, and then recalculate for a ! vertically staggered horizontal connection - if(iups == 0) then + if (iups == 0) then topup = this%m1%dis%top(noden) botup = this%m1%dis%bot(noden) ictup = 1 @@ -484,45 +482,45 @@ subroutine gnc_fn(this, kiter, njasln, amatsln, condsat, ihc_opt, & ictup = 1 if (present(ictm2_opt)) ictup = ictm2_opt(nodem) xup = this%m2%x(nodem) - endif + end if ! ! -- No newton terms if upstream cell is confined if (ictup == 0) cycle ! ! -- Handle vertically staggered horizontal connection - if(ihc == 2) then + if (ihc == 2) then topup = min(this%m1%dis%top(noden), this%m2%dis%top(nodem)) botup = max(this%m1%dis%bot(noden), this%m2%dis%bot(nodem)) - endif + end if ! ! -- Process each contributing node jloop: do jidx = 1, this%numjs nodej = this%nodesj(jidx, ignc) - if(nodej == 0) cycle - if(this%m1%ibound(nodej) == 0) cycle + if (nodej == 0) cycle + if (this%m1%ibound(nodej) == 0) cycle alpha = this%alphasj(jidx, ignc) if (alpha == DZERO) cycle consterm = csat * alpha * (this%m1%x(noden) - this%m1%x(nodej)) derv = sQuadraticSaturationDerivative(topup, botup, xup) term = consterm * derv - if(iups == 0) then + if (iups == 0) then amatsln(this%idiagn(ignc)) = amatsln(this%idiagn(ignc)) + term - if(this%m2%ibound(nodem) > 0) then - amatsln(this%idxsymglo(ignc)) = amatsln(this%idxsymglo(ignc)) - & + if (this%m2%ibound(nodem) > 0) then + amatsln(this%idxsymglo(ignc)) = amatsln(this%idxsymglo(ignc)) - & term - endif + end if this%m1%rhs(noden) = this%m1%rhs(noden) + term * this%m1%x(noden) this%m2%rhs(nodem) = this%m2%rhs(nodem) - term * this%m1%x(noden) else amatsln(this%idiagm(ignc)) = amatsln(this%idiagm(ignc)) - term - if(this%m1%ibound(noden) > 0) then + if (this%m1%ibound(noden) > 0) then amatsln(this%idxglo(ignc)) = amatsln(this%idxglo(ignc)) + term - endif + end if this%m1%rhs(noden) = this%m1%rhs(noden) + term * this%m2%x(nodem) this%m2%rhs(nodem) = this%m2%rhs(nodem) - term * this%m2%x(nodem) - endif - enddo jloop - enddo gncloop + end if + end do jloop + end do gncloop ! ! -- return return @@ -548,19 +546,19 @@ subroutine gnc_ot(this, ibudfl) ! ------------------------------------------------------------------------------ ! ! -- Process each gnc and output deltaQgnc - if(ibudfl /= 0 .and. this%iprflow /= 0) then - write(this%iout, '(//, a)') 'GHOST NODE CORRECTION RESULTS' - write(this%iout, '(3a10, 2a15)') 'GNC NUM', 'NODEN', 'NODEM', & + if (ibudfl /= 0 .and. this%iprflow /= 0) then + write (this%iout, '(//, a)') 'GHOST NODE CORRECTION RESULTS' + write (this%iout, '(3a10, 2a15)') 'GNC NUM', 'NODEN', 'NODEM', & 'DELTAQGNC', 'CONDNM' do ignc = 1, this%nexg deltaQgnc = this%deltaQgnc(ignc) call this%m1%dis%noder_to_string(this%nodem1(ignc), nodenstr) call this%m2%dis%noder_to_string(this%nodem2(ignc), nodemstr) - write(this%iout, fmtgnc) ignc, trim(adjustl(nodenstr)), & - trim(adjustl(nodemstr)), & - deltaQgnc, this%cond(ignc) - enddo - endif + write (this%iout, fmtgnc) ignc, trim(adjustl(nodenstr)), & + trim(adjustl(nodemstr)), & + deltaQgnc, this%cond(ignc) + end do + end if ! ! -- return return @@ -598,7 +596,7 @@ subroutine gnc_cq(this, flowja) flowja(ipos) = flowja(ipos) + deltaQgnc flowja(isympos) = flowja(isympos) - deltaQgnc ! - enddo + end do ! ! -- return return @@ -632,19 +630,19 @@ function deltaQgnc(this, ignc) nodem = this%nodem2(ignc) ! ! -- calculate deltaQgnc - if(this%m1%ibound(noden) /= 0 .and. this%m2%ibound(nodem) /= 0) then + if (this%m1%ibound(noden) /= 0 .and. this%m2%ibound(nodem) /= 0) then jloop: do jidx = 1, this%numjs nodej = this%nodesj(jidx, ignc) - if(nodej == 0) cycle jloop - if(this%m1%ibound(nodej) == 0) cycle jloop + if (nodej == 0) cycle jloop + if (this%m1%ibound(nodej) == 0) cycle jloop alpha = this%alphasj(jidx, ignc) sigalj = sigalj + alpha hd = hd + alpha * this%m1%x(nodej) - enddo jloop + end do jloop aterm = sigalj * this%m1%x(noden) - hd cond = this%cond(ignc) deltaQgnc = aterm * cond - endif + end if ! ! -- return return @@ -699,24 +697,24 @@ subroutine allocate_arrays(this) ! -- allocate memory for arrays call mem_allocate(this%nodem1, this%nexg, 'NODEM1', this%memoryPath) call mem_allocate(this%nodem2, this%nexg, 'NODEM2', this%memoryPath) - call mem_allocate(this%nodesj, this%numjs, this%nexg, 'NODESJ', & + call mem_allocate(this%nodesj, this%numjs, this%nexg, 'NODESJ', & this%memoryPath) - call mem_allocate(this%alphasj, this%numjs, this%nexg, 'ALPHASJ', & + call mem_allocate(this%alphasj, this%numjs, this%nexg, 'ALPHASJ', & this%memoryPath) call mem_allocate(this%cond, this%nexg, 'COND', this%memoryPath) call mem_allocate(this%idxglo, this%nexg, 'IDXGLO', this%memoryPath) call mem_allocate(this%idiagn, this%nexg, 'IDIAGN', this%memoryPath) call mem_allocate(this%idiagm, this%nexg, 'IDIAGM', this%memoryPath) call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', this%memoryPath) - if(this%implicit) then - call mem_allocate(this%jposinrown, this%numjs, this%nexg, 'JPOSINROWN', & + if (this%implicit) then + call mem_allocate(this%jposinrown, this%numjs, this%nexg, 'JPOSINROWN', & this%memoryPath) - call mem_allocate(this%jposinrowm, this%numjs, this%nexg, 'JPOSINROWM', & + call mem_allocate(this%jposinrowm, this%numjs, this%nexg, 'JPOSINROWM', & this%memoryPath) else call mem_allocate(this%jposinrown, 0, 0, 'JPOSINROWN', this%memoryPath) call mem_allocate(this%jposinrowm, 0, 0, 'JPOSINROWM', this%memoryPath) - endif + end if ! ! -- Return return @@ -754,7 +752,7 @@ subroutine gnc_da(this) call mem_deallocate(this%idxsymglo) call mem_deallocate(this%jposinrown) call mem_deallocate(this%jposinrowm) - endif + end if ! ! -- deallocate NumericalPackageType call this%NumericalPackageType%da() @@ -787,35 +785,35 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING GNC OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING GNC OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') & - 'THE LIST OF GHOST-NODE CORRECTIONS WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') & - 'DELTAQGNC VALUES WILL BE PRINTED TO THE LIST FILE.' - case ('I2KN') - this%i2kn = .true. - write(this%iout,'(4x,a)') & - 'SECOND ORDER CORRECTION WILL BE APPLIED.' - case ('EXPLICIT') - this%implicit = .false. - write(this%iout,'(4x,a)')'GHOST NODE CORRECTION IS EXPLICIT.' - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN GNC OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') & + 'THE LIST OF GHOST-NODE CORRECTIONS WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') & + 'DELTAQGNC VALUES WILL BE PRINTED TO THE LIST FILE.' + case ('I2KN') + this%i2kn = .true. + write (this%iout, '(4x,a)') & + 'SECOND ORDER CORRECTION WILL BE APPLIED.' + case ('EXPLICIT') + this%implicit = .false. + write (this%iout, '(4x,a)') 'GHOST NODE CORRECTION IS EXPLICIT.' + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN GNC OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF GNC OPTIONS' + write (this%iout, '(1x,a)') 'END OF GNC OPTIONS' end if ! ! -- Set the iasym flag if the correction is implicit @@ -849,26 +847,26 @@ subroutine read_dimensions(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING GNC DIMENSIONS' + write (this%iout, '(1x,a)') 'PROCESSING GNC DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('NUMGNC') - this%nexg = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NUMGNC = ', this%nexg - case ('NUMALPHAJ') - this%numjs = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)')'NUMAPHAJ = ', this%numjs - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN GNC DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('NUMGNC') + this%nexg = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NUMGNC = ', this%nexg + case ('NUMALPHAJ') + this%numjs = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'NUMAPHAJ = ', this%numjs + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN GNC DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF GNC DIMENSIONS' + write (this%iout, '(1x,a)') 'END OF GNC DIMENSIONS' else call store_error('Required DIMENSIONS block not found.', terminate=.TRUE.) end if @@ -892,7 +890,7 @@ subroutine read_data(this) ! -- local character(len=LINELENGTH) :: line, errmsg, nodestr, fmtgnc, cellid, & cellidm, cellidn - integer(I4B) :: lloc,ierr,ival + integer(I4B) :: lloc, ierr, ival integer(I4B) :: ignc, jidx, nodeun, nodeum, nerr integer(I4B), dimension(:), allocatable :: nodesuj logical :: isfound, endOfBlock @@ -900,19 +898,19 @@ subroutine read_data(this) ! ------------------------------------------------------------------------------ ! ! -- Construct the fmtgnc format - write(fmtgnc, '("(2i10,",i0,"i10,",i0, "(1pg15.6))")') this%numjs, & - this%numjs + write (fmtgnc, '("(2i10,",i0,"i10,",i0, "(1pg15.6))")') this%numjs, & + this%numjs ! ! -- Allocate the temporary nodesuj, which stores the user-based nodej ! node numbers - allocate(nodesuj(this%numjs)) + allocate (nodesuj(this%numjs)) ! ! -- get GNCDATA block call this%parser%GetBlock('GNCDATA', isfound, ierr, supportOpenClose=.true.) ! ! -- process GNC data if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING GNCDATA' + write (this%iout, '(1x,a)') 'PROCESSING GNCDATA' do ignc = 1, this%nexg call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -921,7 +919,7 @@ subroutine read_data(this) ! ! -- cellidn (read as cellid and convert to user node) call this%parser%GetCellid(this%m1%dis%ndim, cellidn) - nodeun = this%m1%dis%nodeu_from_cellid(cellidn, this%parser%iuactive, & + nodeun = this%m1%dis%nodeu_from_cellid(cellidn, this%parser%iuactive, & this%iout) ! ! -- convert user node to reduced node number @@ -929,87 +927,87 @@ subroutine read_data(this) ! ! -- cellidm (read as cellid and convert to user node) call this%parser%GetCellid(this%m2%dis%ndim, cellidm) - nodeum = this%m2%dis%nodeu_from_cellid(cellidm, this%parser%iuactive, & + nodeum = this%m2%dis%nodeu_from_cellid(cellidm, this%parser%iuactive, & this%iout) ! ! -- convert user node to reduced node number call this%nodeu_to_noder(nodeum, this%nodem2(ignc), this%m2) ! ! -- cellidsj (read as cellid) - do jidx=1, this%numjs + do jidx = 1, this%numjs ! read cellidj as cellid of model 1 call this%parser%GetCellid(this%m1%dis%ndim, cellid) - ival = this%m1%dis%nodeu_from_cellid(cellid, this%parser%iuactive, & + ival = this%m1%dis%nodeu_from_cellid(cellid, this%parser%iuactive, & this%iout, allow_zero=.true.) nodesuj(jidx) = ival - if(ival > 0) then + if (ival > 0) then call this%nodeu_to_noder(ival, this%nodesj(jidx, ignc), this%m1) else this%nodesj(jidx, ignc) = 0 - endif - enddo + end if + end do ! ! -- alphaj - do jidx=1, this%numjs + do jidx = 1, this%numjs this%alphasj(jidx, ignc) = this%parser%GetDouble() - enddo + end do ! ! -- Echo if requested - if(this%iprpak /= 0) & - write(this%iout, fmtgnc) nodeun, nodeum, & - (nodesuj(jidx), jidx = 1, this%numjs), & - (this%alphasj(jidx, ignc), jidx = 1, this%numjs) + if (this%iprpak /= 0) & + write (this%iout, fmtgnc) nodeun, nodeum, & + (nodesuj(jidx), jidx=1, this%numjs), & + (this%alphasj(jidx, ignc), jidx=1, this%numjs) ! ! -- Check to see if noden is outside of active domain - if(this%nodem1(ignc) <= 0) then + if (this%nodem1(ignc) <= 0) then call this%m1%dis%nodeu_to_string(nodeun, nodestr) - write(errmsg, *) & - trim(adjustl(this%m1%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write (errmsg, *) & + trim(adjustl(this%m1%name))// & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) call store_error(errmsg) - endif + end if ! ! -- Check to see if nodem is outside of active domain - if(this%nodem2(ignc) <= 0) then + if (this%nodem2(ignc) <= 0) then call this%m2%dis%nodeu_to_string(nodeum, nodestr) - write(errmsg, *) & - trim(adjustl(this%m2%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write (errmsg, *) & + trim(adjustl(this%m2%name))// & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) call store_error(errmsg) - endif + end if ! ! -- Check to see if any nodejs are outside of active domain do jidx = 1, this%numjs - if(this%nodesj(jidx, ignc) < 0) then + if (this%nodesj(jidx, ignc) < 0) then call this%m1%dis%nodeu_to_string(nodesuj(jidx), nodestr) - write(errmsg, *) & - trim(adjustl(this%m1%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write (errmsg, *) & + trim(adjustl(this%m1%name))// & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) call store_error(errmsg) - endif - enddo + end if + end do ! - enddo + end do ! ! -- Stop if errors nerr = count_errors() - if(nerr > 0) then + if (nerr > 0) then call store_error('Errors encountered in GNC input file.') call this%parser%StoreErrorUnit() - endif + end if ! - write(this%iout,'(1x,a)')'END OF GNCDATA' + write (this%iout, '(1x,a)') 'END OF GNCDATA' else - write(errmsg, '(1x,a)')'ERROR. REQUIRED GNCDATA BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED GNCDATA BLOCK NOT FOUND.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if ! ! -- deallocate nodesuj array - deallocate(nodesuj) + deallocate (nodesuj) ! ! -- return return @@ -1034,18 +1032,17 @@ subroutine nodeu_to_noder(this, nodeu, noder, model) character(len=LINELENGTH) :: errmsg ! ------------------------------------------------------------------------------ ! - if(nodeu < 1 .or. nodeu > model%dis%nodesuser) then - write(errmsg, *) & - trim(adjustl(model%name)) // & - ' node number < 0 or > model nodes: ', nodeu + if (nodeu < 1 .or. nodeu > model%dis%nodesuser) then + write (errmsg, *) & + trim(adjustl(model%name))// & + ' node number < 0 or > model nodes: ', nodeu call store_error(errmsg) else noder = model%dis%get_nodenumber(nodeu, 0) - endif + end if ! ! -- Return return end subroutine nodeu_to_noder - end module GhostNodeModule diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 new file mode 100644 index 00000000000..180b5fb6de5 --- /dev/null +++ b/src/Exchange/GweGweExchange.f90 @@ -0,0 +1,1358 @@ +!> @brief This module contains the GweGweExchangeModule Module +!! +!! This module contains the code for connecting two GWE Models. +!! The methods are based on the simple two point flux approximation +!! with the option to use ghost nodes to improve accuracy. This +!! exchange is used by GweGweConnection with the more sophisticated +!! interface model coupling approach when XT3D is needed. +!! +!< +module GweGweExchangeModule + + use KindModule, only: DP, I4B, LGP + use SimVariablesModule, only: errmsg + use SimModule, only: store_error + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & + TABCENTER, TABLEFT, LENAUXNAME, DNODATA, & + LENMODELNAME + use ListModule, only: ListType + use ListsModule, only: basemodellist + use DisConnExchangeModule, only: DisConnExchangeType + use GweModule, only: GweModelType + use TspMvtModule, only: TspMvtType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use SimVariablesModule, only: errmsg + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr + + implicit none + + private + public :: GweExchangeType + public :: gweexchange_create + public :: GetGweExchangeFromList + public :: CastAsGweExchange + + !> @brief Derived type for GwtExchangeType + !! + !! This derived type contains information and methods for + !! connecting two GWT models. + !! + !< + type, extends(DisConnExchangeType) :: GweExchangeType + ! + ! -- names of the GWF models that are connected by this exchange + character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of gwfmodel that corresponds to gwtmodel1 + character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of gwfmodel that corresponds to gwtmodel2 + ! + ! -- pointers to gwt models + type(GweModelType), pointer :: gwemodel1 => null() !< pointer to GWT Model 1 + type(GweModelType), pointer :: gwemodel2 => null() !< pointer to GWT Model 2 + ! + ! -- GWT specific option block: + integer(I4B), pointer :: inewton => null() !< unneeded newton flag allows for mvt to be used here + integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows + integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows + integer(I4B), pointer :: iAdvScheme !< the advection scheme at the interface: + !! 0 = upstream, 1 = central, 2 = TVD + ! + ! -- Mover transport package + integer(I4B), pointer :: inmvt => null() !< unit number for mover transport (0 if off) + type(TspMvtType), pointer :: mvt => null() !< water mover object + ! + ! -- Observation package + integer(I4B), pointer :: inobs => null() !< unit number for GWT-GWT observations + type(ObsType), pointer :: obs => null() !< observation object + ! + ! -- internal data + real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance + real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange + ! + ! -- table objects + type(TableType), pointer :: outputtab1 => null() + type(TableType), pointer :: outputtab2 => null() + + contains + + procedure :: exg_df => gwe_gwe_df + procedure :: exg_ar => gwe_gwe_ar + procedure :: exg_rp => gwe_gwe_rp + procedure :: exg_ad => gwe_gwe_ad + procedure :: exg_fc => gwe_gwe_fc + procedure :: exg_bd => gwe_gwe_bd + procedure :: exg_ot => gwe_gwe_ot + procedure :: exg_da => gwe_gwe_da + procedure :: exg_fp => gwe_gwe_fp + procedure :: connects_model => gwe_gwe_connects_model + procedure :: use_interface_model + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: parse_option + procedure :: read_mvt + procedure :: gwe_gwe_bdsav + procedure, private :: gwe_gwe_df_obs + procedure, private :: gwe_gwe_rp_obs + procedure, public :: gwe_gwe_save_simvals + procedure, private :: validate_exchange + end type GweExchangeType + +contains + + !> @ brief Create GWT GWT exchange + !! + !! Create a new GWT to GWT exchange object. + !! + !< + subroutine gweexchange_create(filename, id, m1id, m2id) + ! -- modules + use ConstantsModule, only: LINELENGTH + use BaseModelModule, only: BaseModelType + use ListsModule, only: baseexchangelist + use ObsModule, only: obs_cr + use MemoryHelperModule, only: create_mem_path + ! -- dummy + character(len=*),intent(in) :: filename !< filename for reading + integer(I4B), intent(in) :: id !< id for the exchange + integer(I4B), intent(in) :: m1id !< id for model 1 + integer(I4B), intent(in) :: m2id !< id for model 2 + ! -- local + type(GweExchangeType), pointer :: exchange + class(BaseModelType), pointer :: mb + class(BaseExchangeType), pointer :: baseexchange + character(len=20) :: cint + ! + ! -- Create a new exchange and add it to the baseexchangelist container + allocate(exchange) + baseexchange => exchange + call AddBaseExchangeToList(baseexchangelist, baseexchange) + ! + ! -- Assign id and name + exchange%id = id + write(cint, '(i0)') id + exchange%name = 'GWE-GWE_' // trim(adjustl(cint)) + exchange%memoryPath = create_mem_path(exchange%name) + ! + ! -- allocate scalars and set defaults + call exchange%allocate_scalars() + exchange%filename = filename + exchange%typename = 'GWE-GWE' + exchange%iAdvScheme = 0 + exchange%ixt3d = 1 + ! + ! -- set gwtmodel1 + mb => GetBaseModelFromList(basemodellist, m1id) + select type (mb) + type is (GweModelType) + exchange%model1 => mb + exchange%gwemodel1 => mb + end select + ! + ! -- set gwtmodel2 + mb => GetBaseModelFromList(basemodellist, m2id) + select type (mb) + type is (GweModelType) + exchange%model2 => mb + exchange%gwemodel2 => mb + end select + ! + ! -- Verify that gwt model1 is of the correct type + if (.not. associated(exchange%gwemodel1)) then + write(errmsg, '(3a)') 'Problem with GWE-GWE exchange ', & + trim(exchange%name), & + '. First specified GWE Model does not appear to be of the correct type.' + call store_error(errmsg, terminate=.true.) + end if + ! + ! -- Verify that gwf model2 is of the correct type + if (.not. associated(exchange%gwemodel2)) then + write(errmsg, '(3a)') 'Problem with GWE-GWE exchange ', & + trim(exchange%name), & + '. Second specified GWE Model does not appear to be of the correct type.' + call store_error(errmsg, terminate=.true.) + end if + ! + ! -- Create the obs package + call obs_cr(exchange%obs, exchange%inobs) + ! + ! -- return + return + end subroutine gweexchange_create + + !> @ brief Define GWE GWE exchange + !! + !! Define GWE to GWE exchange object. + !! + !< + subroutine gwe_gwe_df(this) + ! -- modules + use SimVariablesModule, only: iout + use InputOutputModule, only: getunit, openfile + use GhostNodeModule, only: gnc_cr + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! -- local + integer(I4B) :: inunit + ! + ! -- open the file + inunit = getunit() + write(iout,'(/a,a)') ' Creating exchange: ', this%name + call openfile(inunit, iout, this%filename, 'GWE-GWE') + ! + call this%parser%Initialize(inunit, iout) + ! + ! -- Ensure models are in same solution + if(this%gwemodel1%idsoln /= this%gwemodel2%idsoln) then + call store_error('ERROR. TWO MODELS ARE CONNECTED ' // & + 'IN A GWE EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. ' // & + 'GWE MODELS MUST BE IN SAME SOLUTION: ' // & + trim(this%gwemodel1%name) // ' ' // trim(this%gwemodel2%name) ) + call this%parser%StoreErrorUnit() + endif + ! + ! -- read options + call this%read_options(iout) + ! + ! -- read dimensions + call this%read_dimensions(iout) + ! + ! -- allocate arrays + call this%allocate_arrays() + ! + ! -- read exchange data + call this%read_data(iout) + ! + ! -- Read mover information + if(this%inmvt > 0) then + call this%read_mvt(iout) + call this%mvt%mvt_df(this%gwemodel1%dis) + endif + ! + ! -- close the file + close(inunit) + ! + ! -- Store obs + call this%gwe_gwe_df_obs() + call this%obs%obs_df(iout, this%name, 'GWE-GWE', this%gwemodel1%dis) + ! + ! -- validate + call this%validate_exchange() + ! + ! -- return + return + end subroutine gwe_gwe_df + + !> @brief validate exchange data after reading + !< + subroutine validate_exchange(this) + class(GweExchangeType) :: this !< GweExchangeType + ! local + + ! Ensure gwfmodel names were entered + if (this%gwfmodelname1 == '') then + write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' requires that GWFMODELNAME1 be entered in the & + &OPTIONS block.' + call store_error(errmsg) + end if + if (this%gwfmodelname2 == '') then + write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' requires that GWFMODELNAME2 be entered in the & + &OPTIONS block.' + call store_error(errmsg) + end if + + ! Periodic boundary condition in exchange don't allow XT3D (=interface model) + if (associated(this%model1, this%model2)) then + if (this%ixt3d > 0) then + write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' is a periodic boundary condition which cannot'// & + ' be configured with XT3D' + call store_error(errmsg) + end if + end if + + ! Check to see if dispersion is on in either model1 or model2. + ! If so, then ANGLDEGX must be provided as an auxiliary variable for this + ! GWE-GWE exchange (this%ianglex > 0). + if(this%gwemodel1%indsp /= 0 .or. this%gwemodel2%indsp /= 0) then + if(this%ianglex == 0) then + write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because dispersion was '// & + 'specified in one or both transport models.' + call store_error(errmsg) + endif + endif + + if (this%ixt3d > 0 .and. this%ianglex == 0) then + write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because XT3D is enabled' + call store_error(errmsg) + end if + + if (count_errors() > 0) then + call ustop() + end if + + end subroutine validate_exchange + + !> @ brief Allocate and read + !! + !! Allocated and read and calculate saturated conductance + !! + !< + subroutine gwe_gwe_ar(this) + ! -- modules + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! -- local + ! + ! -- If mover is active, then call ar routine + if(this%inmvt > 0) call this%mvt%mvt_ar() + ! + ! -- Observation AR + call this%obs%obs_ar() + ! + ! -- Return + return + end subroutine gwe_gwe_ar + + + !> @ brief Read and prepare + !! + !! Read new data for mover and obs + !! + !< + subroutine gwe_gwe_rp(this) + ! -- modules + use TdisModule, only: readnewdata + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + ! + ! -- Check with TDIS on whether or not it is time to RP + if (.not. readnewdata) return + ! + ! -- Read and prepare for mover + if(this%inmvt > 0) call this%mvt%mvt_rp() + ! + ! -- Read and prepare for observations + call this%gwe_gwe_rp_obs() + ! + ! -- Return + return + end subroutine gwe_gwe_rp + + !> @ brief Advance + !! + !! Advance mover and obs + !! + !< + subroutine gwe_gwe_ad(this) + ! -- modules + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + ! -- local + ! + ! -- Advance mover + !if(this%inmvt > 0) call this%mvt%mvt_ad() + ! + ! -- Push simulated values to preceding time step + call this%obs%obs_ad() + ! + ! -- Return + return + end subroutine gwe_gwe_ad + + !> @ brief Fill coefficients + !! + !! Calculate conductance and fill coefficient matrix + !! + !< + subroutine gwe_gwe_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) + ! -- modules + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + integer(I4B), intent(in) :: kiter + integer(I4B), dimension(:), intent(in) :: iasln + real(DP), dimension(:), intent(inout) :: amatsln + real(DP), dimension(:), intent(inout) ::rhssln + integer(I4B), optional, intent(in) :: inwtflag + ! -- local + ! + ! -- Call mvt fc routine + if(this%inmvt > 0) call this%mvt%mvt_fc(this%gwemodel1%x, this%gwemodel2%x) + ! + ! -- Return + return + end subroutine gwe_gwe_fc + + !> @ brief Budget + !! + !! Accumulate budget terms + !! + !< + subroutine gwe_gwe_bd(this, icnvg, isuppress_output, isolnid) + ! -- modules + use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME + use BudgetModule, only: rate_accumulator + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + integer(I4B), intent(inout) :: icnvg + integer(I4B), intent(in) :: isuppress_output + integer(I4B), intent(in) :: isolnid + ! -- local + character(len=LENBUDTXT), dimension(1) :: budtxt + real(DP), dimension(2, 1) :: budterm + real(DP) :: ratin, ratout + ! -- formats + ! + ! -- initialize + budtxt(1) = ' FLOW-JA-FACE' + ! + ! -- Calculate ratin/ratout and pass to model budgets + call rate_accumulator(this%simvals, ratin, ratout) + ! + ! -- Add the budget terms to model 1 + budterm(1, 1) = ratin + budterm(2, 1) = ratout + call this%gwemodel1%model_bdentry(budterm, budtxt, this%name) + ! + ! -- Add the budget terms to model 2 + budterm(1, 1) = ratout + budterm(2, 1) = ratin + call this%gwemodel2%model_bdentry(budterm, budtxt, this%name) + ! + ! -- Call mvt bd routine + if(this%inmvt > 0) call this%mvt%mvt_bd(this%gwemodel1%x, this%gwemodel2%x) + ! + ! -- return + return + end subroutine gwe_gwe_bd + + !> @ brief Budget save + !! + !! Output individual flows to listing file and binary budget files + !! + !< + subroutine gwe_gwe_bdsav(this) + ! -- modules + use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME + use TdisModule, only: kstp, kper + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! -- local + character(len=LENBOUNDNAME) :: bname + character(len=LENPACKAGENAME+4) :: packname1 + character(len=LENPACKAGENAME+4) :: packname2 + character(len=LENBUDTXT), dimension(1) :: budtxt + character(len=20) :: nodestr + integer(I4B) :: ntabrows + integer(I4B) :: nodeu + integer(I4B) :: i, n1, n2, n1u, n2u + integer(I4B) :: ibinun1, ibinun2 + integer(I4B) :: icbcfl, ibudfl + real(DP) :: ratin, ratout, rrate + integer(I4B) :: isuppress_output + ! -- formats + ! + ! -- initialize local variables + isuppress_output = 0 + budtxt(1) = ' FLOW-JA-FACE' + packname1 = 'EXG '//this%name + packname1 = adjustr(packname1) + packname2 = 'EXG '//this%name + packname2 = adjustr(packname2) + ! + ! -- update output tables + if (this%iprflow /= 0) then + ! + ! -- update titles + if (this%gwemodel1%oc%oc_save('BUDGET')) then + call this%outputtab1%set_title(packname1) + end if + if (this%gwemodel2%oc%oc_save('BUDGET')) then + call this%outputtab2%set_title(packname2) + end if + ! + ! -- set table kstp and kper + call this%outputtab1%set_kstpkper(kstp, kper) + call this%outputtab2%set_kstpkper(kstp, kper) + ! + ! -- update maxbound of tables + ntabrows = 0 + do i = 1, this%nexg + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ! + ! -- If both cells are active then calculate flow rate + if (this%gwemodel1%ibound(n1) /= 0 .and. & + this%gwemodel2%ibound(n2) /= 0) then + ntabrows = ntabrows + 1 + end if + end do + if (ntabrows > 0) then + call this%outputtab1%set_maxbound(ntabrows) + call this%outputtab2%set_maxbound(ntabrows) + end if + end if + ! + ! -- Print and write budget terms for model 1 + ! + ! -- Set binary unit numbers for saving flows + if(this%ipakcb /= 0) then + ibinun1 = this%gwemodel1%oc%oc_save_unit('BUDGET') + else + ibinun1 = 0 + endif + ! + ! -- If save budget flag is zero for this stress period, then + ! shut off saving + if(.not. this%gwemodel1%oc%oc_save('BUDGET')) ibinun1 = 0 + if(isuppress_output /= 0) then + ibinun1 = 0 + endif + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun1 /= 0) then + call this%gwemodel1%dis%record_srcdst_list_header(budtxt(1), & + this%gwemodel1%name, this%name, & + this%gwemodel2%name, this%name, & + this%naux, this%auxname, & + ibinun1, this%nexg, this%gwemodel1%iout) + endif + ! + ! Initialize accumulators + ratin = DZERO + ratout = DZERO + ! + ! -- Loop through all exchanges + do i = 1, this%nexg + ! + ! -- Assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- Calculate the flow rate between n1 and n2 + rrate = DZERO + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ! + ! -- If both cells are active then calculate flow rate + if(this%gwemodel1%ibound(n1) /= 0 .and. & + this%gwemodel2%ibound(n2) /= 0) then + rrate = this%simvals(i) + ! + ! -- Print the individual rates to model list files if requested + if(this%iprflow /= 0) then + if(this%gwemodel1%oc%oc_save('BUDGET')) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%gwemodel1%dis%get_nodeuser(n1) + call this%gwemodel1%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & + rrate, bname) + end if + endif + if(rrate < DZERO) then + ratout = ratout - rrate + else + ratin = ratin + rrate + endif + endif + ! + ! -- If saving cell-by-cell flows in list, write flow + n1u = this%gwemodel1%dis%get_nodeuser(n1) + n2u = this%gwemodel2%dis%get_nodeuser(n2) + if(ibinun1 /= 0) & + call this%gwemodel1%dis%record_mf6_list_entry( & + ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & + .false., .false.) + ! + enddo + ! + ! -- Print and write budget terms for model 2 + ! + ! -- Set binary unit numbers for saving flows + if(this%ipakcb /= 0) then + ibinun2 = this%gwemodel2%oc%oc_save_unit('BUDGET') + else + ibinun2 = 0 + endif + ! + ! -- If save budget flag is zero for this stress period, then + ! shut off saving + if(.not. this%gwemodel2%oc%oc_save('BUDGET')) ibinun2 = 0 + if(isuppress_output /= 0) then + ibinun2 = 0 + endif + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if(ibinun2 /= 0) then + call this%gwemodel2%dis%record_srcdst_list_header(budtxt(1), & + this%gwemodel2%name, this%name, & + this%gwemodel1%name, this%name, & + this%naux, this%auxname, & + ibinun2, this%nexg, this%gwemodel2%iout) + endif + ! + ! Initialize accumulators + ratin = DZERO + ratout = DZERO + ! + ! -- Loop through all exchanges + do i = 1, this%nexg + ! + ! -- Assign boundary name + if (this%inamedbound>0) then + bname = this%boundname(i) + else + bname = '' + endif + ! + ! -- Calculate the flow rate between n1 and n2 + rrate = DZERO + n1 = this%nodem1(i) + n2 = this%nodem2(i) + ! + ! -- If both cells are active then calculate flow rate + if(this%gwemodel1%ibound(n1) /= 0 .and. & + this%gwemodel2%ibound(n2) /= 0) then + rrate = this%simvals(i) + ! + ! -- Print the individual rates to model list files if requested + if(this%iprflow /= 0) then + if(this%gwemodel2%oc%oc_save('BUDGET')) then + ! + ! -- set nodestr and write outputtab table + nodeu = this%gwemodel2%dis%get_nodeuser(n2) + call this%gwemodel2%dis%nodeu_to_string(nodeu, nodestr) + call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & + -rrate, bname) + end if + endif + if(rrate < DZERO) then + ratout = ratout - rrate + else + ratin = ratin + rrate + endif + endif + ! + ! -- If saving cell-by-cell flows in list, write flow + n1u = this%gwemodel1%dis%get_nodeuser(n1) + n2u = this%gwemodel2%dis%get_nodeuser(n2) + if(ibinun2 /= 0) & + call this%gwemodel2%dis%record_mf6_list_entry( & + ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & + .false., .false.) + ! + enddo + ! + ! -- Set icbcfl, ibudfl to zero so that flows will be printed and + ! saved, if the options were set in the MVT package + icbcfl = 1 + ibudfl = 1 + ! + ! -- Call mvt bd routine + !cdl todo: if(this%inmvt > 0) call this%mvt%mvt_bdsav(icbcfl, ibudfl, isuppress_output) + ! + ! -- Calculate and write simulated values for observations + if(this%inobs /= 0) then + call this%gwe_gwe_save_simvals() + endif + ! + ! -- return + return + end subroutine gwe_gwe_bdsav + + !> @ brief Output + !! + !! Write output + !! + !< + subroutine gwe_gwe_ot(this) + ! -- modules + use SimVariablesModule, only: iout + use ConstantsModule, only: DZERO, LINELENGTH + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + ! -- local + integer(I4B) :: iexg, n1, n2 + integer(I4B) :: ibudfl + real(DP) :: flow + character(len=LINELENGTH) :: node1str, node2str + ! -- format + character(len=*), parameter :: fmtheader = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + &2a16, 5a16, /, 112('-'))" + character(len=*), parameter :: fmtheader2 = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + &2a16, 4a16, /, 96('-'))" + character(len=*), parameter :: fmtdata = & + "(2a16, 5(1pg16.6))" + ! + ! -- Call bdsave + call this%gwe_gwe_bdsav() + ! + ! -- Write a table of exchanges + if(this%iprflow /= 0) then + write(iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' + do iexg = 1, this%nexg + n1 = this%nodem1(iexg) + n2 = this%nodem2(iexg) + flow = this%simvals(iexg) + call this%gwemodel1%dis%noder_to_string(n1, node1str) + call this%gwemodel2%dis%noder_to_string(n2, node2str) + write(iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%gwemodel1%x(n1), & + this%gwemodel2%x(n2), flow + enddo + endif + ! + !cdl Implement when MVT is ready + ! -- Mover budget output + ibudfl = 1 + if(this%inmvt > 0) call this%mvt%mvt_ot_bdsummary(ibudfl) + ! + ! -- OBS output + call this%obs%obs_ot() + ! + ! -- return + return + end subroutine gwe_gwe_ot + + !> @ brief Read options + !! + !! Read the options block + !! + !< + subroutine read_options(this, iout) + ! -- modules + use ConstantsModule, only: LINELENGTH, LENAUXNAME, DEM6 + use MemoryManagerModule, only: mem_allocate + use SimModule, only: store_error, store_error_unit + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + integer(I4B), intent(in) :: iout + ! -- local + character(len=LINELENGTH) :: keyword + logical :: isfound + logical :: endOfBlock + integer(I4B) :: ierr + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write(iout,'(1x,a)')'PROCESSING GWE-GWE EXCHANGE OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) then + exit + end if + call this%parser%GetStringCaps(keyword) + + ! first parse option in base + if (this%DisConnExchangeType%parse_option(keyword, iout)) then + cycle + end if + + ! it's probably ours + if (this%parse_option(keyword, iout)) then + cycle + end if + + ! unknown option + errmsg = "Unknown GWE-GWE exchange option '" // trim(keyword) // "'." + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end do + + write(iout,'(1x,a)') 'END OF GWE-GWE EXCHANGE OPTIONS' + end if + ! + ! -- return + return + end subroutine read_options + + !> @brief parse option from exchange file + !< + function parse_option(this, keyword, iout) result(parsed) + use InputOutputModule, only: getunit, openfile + class(GweExchangeType) :: this !< GweExchangeType + character(len=LINELENGTH), intent(in) :: keyword !< the option name + integer(I4B), intent(in) :: iout !< for logging + logical(LGP) :: parsed !< true when parsed + ! local + character(len=LINELENGTH) :: fname + integer(I4B) :: inobs, ilen + character(len=LINELENGTH) :: subkey + + parsed = .true. + + select case (keyword) + case ('GWFMODELNAME1') + call this%parser%GetStringCaps(subkey) + ilen = len_trim(subkey) + if (ilen > LENMODELNAME) then + write(errmsg, '(4x,a,a)') & + 'INVALID MODEL NAME: ', trim(subkey) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + if (this%gwfmodelname1 /= '') then + call store_error('GWFMODELNAME1 has already been set to ' & + // trim(this%gwfmodelname1) // '. Cannot set more than once.') + call this%parser%StoreErrorUnit() + end if + this%gwfmodelname1 = subkey(1:LENMODELNAME) + write(iout,'(4x,a,a)') & + 'GWFMODELNAME1 IS SET TO: ', trim(this%gwfmodelname1) + case ('GWFMODELNAME2') + call this%parser%GetStringCaps(subkey) + ilen = len_trim(subkey) + if (ilen > LENMODELNAME) then + write(errmsg, '(4x,a,a)') & + 'INVALID MODEL NAME: ', trim(subkey) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + if (this%gwfmodelname2 /= '') then + call store_error('GWFMODELNAME2 has already been set to ' & + // trim(this%gwfmodelname2) // '. Cannot set more than once.') + call this%parser%StoreErrorUnit() + end if + this%gwfmodelname2 = subkey(1:LENMODELNAME) + write(iout,'(4x,a,a)') & + 'GWFMODELNAME2 IS SET TO: ', trim(this%gwfmodelname2) + case ('PRINT_FLOWS') + this%iprflow = 1 + write(iout,'(4x,a)') & + 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write(iout,'(4x,a)') & + 'EXCHANGE FLOWS WILL BE SAVED TO BINARY BUDGET FILES.' + case ('MVT6') + call this%parser%GetStringCaps(subkey) + if(subkey /= 'FILEIN') then + call store_error('MVT6 KEYWORD MUST BE FOLLOWED BY ' // & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + endif + call this%parser%GetString(fname) + if(fname == '') then + call store_error('NO MVT6 FILE SPECIFIED.') + call this%parser%StoreErrorUnit() + endif + this%inmvt = getunit() + call openfile(this%inmvt, iout, fname, 'MVT') + write(iout,'(4x,a)') & + 'WATER MOVER TRANSPORT INFORMATION WILL BE READ FROM ', trim(fname) + case ('OBS6') + call this%parser%GetStringCaps(subkey) + if(subkey /= 'FILEIN') then + call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY ' // & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + endif + this%obs%active = .true. + call this%parser%GetString(this%obs%inputFilename) + inobs = GetUnit() + call openfile(inobs, iout, this%obs%inputFilename, 'OBS') + this%obs%inUnitObs = inobs + case ('ADVSCHEME') + !cdl todo: change to ADV_SCHEME? + call this%parser%GetStringCaps(subkey) + select case(subkey) + case('UPSTREAM') + this%iAdvScheme = 0 + case('CENTRAL') + this%iAdvScheme = 1 + case('TVD') + this%iAdvScheme = 2 + case default + errmsg = "Unknown weighting method for advection: '" // trim(subkey) // "'." + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + write(iout,'(4x,a,a)') & + 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(subkey) + case ('XT3D_OFF') + !cdl todo: change to DSP_XT3D_OFF? + this%ixt3d = 0 + write(iout, '(4x,a)') 'XT3D FORMULATION HAS BEEN SHUT OFF.' + case ('XT3D_RHS') + !cdl todo: change to DSP_XT3D_RHS? + this%ixt3d = 2 + write(iout, '(4x,a)') 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' + case default + parsed = .false. + end select + + end function parse_option + + !> @ brief Read mover + !! + !! Read and process movers + !! + !< + subroutine read_mvt(this, iout) + ! -- modules + use TspMvtModule, only: mvt_cr + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + integer(I4B), intent(in) :: iout + ! -- local + ! + ! -- Create and initialize the mover object Here, fmi is set to the one + ! for gwtmodel1 so that a call to save flows has an associated dis + ! object. + call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwemodel1%fmi, & + gwfmodelname1=this%gwfmodelname1, & + gwfmodelname2=this%gwfmodelname2, & + fmi2=this%gwemodel2%fmi) + ! + ! -- Return + return + end subroutine read_mvt + + !> @ brief Allocate scalars + !! + !! Allocate scalar variables + !! + !< + subroutine allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: DZERO + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! -- local + ! + call this%DisConnExchangeType%allocate_scalars() + ! + call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) + call mem_allocate(this%iprflow, 'IPRFLOW', this%memoryPath) + call mem_allocate(this%ipakcb, 'IPAKCB', this%memoryPath) + call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + call mem_allocate(this%iAdvScheme, 'IADVSCHEME', this%memoryPath) + this%inewton = 0 + this%iprpak = 0 + this%iprflow = 0 + this%ipakcb = 0 + this%inobs = 0 + this%iAdvScheme = 0 + ! + call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) + this%inmvt = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + !> @ brief Deallocate + !! + !! Deallocate memory associated with this object + !! + !< + subroutine gwe_gwe_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! -- local + ! + ! -- objects + if (this%inmvt > 0) then + call this%mvt%mvt_da() + deallocate(this%mvt) + endif + call this%obs%obs_da() + deallocate(this%obs) + ! + ! -- arrays + call mem_deallocate(this%cond) + call mem_deallocate(this%simvals) + ! + ! -- output table objects + if (associated(this%outputtab1)) then + call this%outputtab1%table_da() + deallocate(this%outputtab1) + nullify(this%outputtab1) + end if + if (associated(this%outputtab2)) then + call this%outputtab2%table_da() + deallocate(this%outputtab2) + nullify(this%outputtab2) + end if + ! + ! -- scalars + deallocate(this%filename) + call mem_deallocate(this%inewton) + call mem_deallocate(this%iprflow) + call mem_deallocate(this%ipakcb) + call mem_deallocate(this%inobs) + call mem_deallocate(this%iAdvScheme) + call mem_deallocate(this%inmvt) + ! + ! -- deallocate base + call this%DisConnExchangeType%disconnex_da() + ! + ! -- return + return + end subroutine gwe_gwe_da + + !> @ brief Allocate arrays + !! + !! Allocate arrays + !! + !< + subroutine allocate_arrays(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + ! -- local + character(len=LINELENGTH) :: text + integer(I4B) :: ntabcol, i + ! + call this%DisConnExchangeType%allocate_arrays() + ! + call mem_allocate(this%cond, this%nexg, 'COND', this%memoryPath) + call mem_allocate(this%simvals, this%nexg, 'SIMVALS', this%memoryPath) + ! + ! -- Initialize + do i = 1, this%nexg + this%cond(i) = DNODATA + end do + ! + ! -- allocate and initialize the output table + if (this%iprflow /= 0) then + ! + ! -- dimension table + ntabcol = 3 + if (this%inamedbound > 0) then + ntabcol = ntabcol + 1 + end if + ! + ! -- initialize the output table objects + ! outouttab1 + call table_cr(this%outputtab1, this%name, ' ') + call this%outputtab1%table_df(this%nexg, ntabcol, this%gwemodel1%iout, & + transient=.TRUE.) + text = 'NUMBER' + call this%outputtab1%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%outputtab1%initialize_column(text, 20, alignment=TABLEFT) + text = 'RATE' + call this%outputtab1%initialize_column(text, 15, alignment=TABCENTER) + if (this%inamedbound > 0) then + text = 'NAME' + call this%outputtab1%initialize_column(text, 20, alignment=TABLEFT) + end if + ! outouttab2 + call table_cr(this%outputtab2, this%name, ' ') + call this%outputtab2%table_df(this%nexg, ntabcol, this%gwemodel2%iout, & + transient=.TRUE.) + text = 'NUMBER' + call this%outputtab2%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%outputtab2%initialize_column(text, 20, alignment=TABLEFT) + text = 'RATE' + call this%outputtab2%initialize_column(text, 15, alignment=TABCENTER) + if (this%inamedbound > 0) then + text = 'NAME' + call this%outputtab2%initialize_column(text, 20, alignment=TABLEFT) + end if + end if + ! + ! -- return + return + end subroutine allocate_arrays + + !> @ brief Define observations + !! + !! Define the observations associated with this object + !! + !< + subroutine gwe_gwe_df_obs(this) + ! -- dummy + class(GweExchangeType) :: this !< GweExchangeType + ! -- local + integer(I4B) :: indx + ! + ! -- Store obs type and assign procedure pointer + ! for gwt-gwt observation type. + call this%obs%StoreObsType('flow-ja-face', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => gwe_gwe_process_obsID + ! + ! -- return + return + end subroutine gwe_gwe_df_obs + + !> @ brief Read and prepare observations + !! + !! Handle observation exchanges exchange-boundary names. + !! + !< + subroutine gwe_gwe_rp_obs(this) + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! -- local + integer(I4B) :: i + integer(I4B) :: j + class(ObserveType), pointer :: obsrv => null() + character(len=LENBOUNDNAME) :: bname + logical :: jfound + ! -- formats +10 format('Exchange "',a,'" for observation "',a, & + '" is invalid in package "',a,'"') +20 format('Exchange id "',i0,'" for observation "',a, & + '" is invalid in package "',a,'"') + ! + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + ! + ! -- indxbnds needs to be reset each stress period because + ! list of boundaries can change each stress period. + ! -- Not true for exchanges, but leave this in for now anyway. + call obsrv%ResetObsIndex() + obsrv%BndFound = .false. + ! + bname = obsrv%FeatureName + if (bname /= '') then + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + jfound = .false. + do j=1,this%nexg + if (this%boundname(j) == bname) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call obsrv%AddObsIndex(j) + endif + enddo + if (.not. jfound) then + write(errmsg, 10) trim(bname), trim(obsrv%ObsTypeId) , trim(this%name) + call store_error(errmsg) + endif + else + ! -- Observation location is a single exchange number + if (obsrv%intPak1 <= this%nexg .and. obsrv%intPak1 > 0) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call obsrv%AddObsIndex(obsrv%intPak1) + else + jfound = .false. + endif + if (.not. jfound) then + write(errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId) , trim(this%name) + call store_error(errmsg) + endif + endif + enddo + ! + ! -- write summary of error messages + if (count_errors() > 0) then + call store_error_unit(this%inobs) + endif + ! + ! -- Return + return + end subroutine gwe_gwe_rp_obs + + !> @ brief Final processing + !! + !! Conduct any final processing + !! + !< + subroutine gwe_gwe_fp(this) + ! -- dummy + class(GweExchangeType) :: this !< GwtExchangeType + ! + return + end subroutine gwe_gwe_fp + + !> @brief Return true when this exchange provides matrix + !! coefficients for solving @param model + !< + function gwe_gwe_connects_model(this, model) result(is_connected) + class(GweExchangeType) :: this !< GweExchangeType + class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection + logical(LGP) :: is_connected !< true, when connected + + is_connected = .false. + ! only connected when model is GwtModelType of course + select type(model) + class is (GweModelType) + if (associated(this%gwemodel1, model)) then + is_connected = .true. + else if (associated(this%gwemodel2, model)) then + is_connected = .true. + end if + end select + + end function gwe_gwe_connects_model + + !> @brief Should interface model be used for this exchange + !< + function use_interface_model(this) result(useIM) + class(GweExchangeType) :: this !< GwtExchangeType + logical(LGP) :: useIM !< true when interface model should be used + + useIM = (this%ixt3d > 0) + + end function + + !> @ brief Save simulated flow observations + !! + !! Save the simulated flows for each exchange + !! + !< + subroutine gwe_gwe_save_simvals(this) + ! -- dummy + use SimModule, only: store_error, store_error_unit + use ConstantsModule, only: DZERO + use ObserveModule, only: ObserveType + class(GweExchangeType), intent(inout) :: this + ! -- local + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: n1 + integer(I4B) :: n2 + integer(I4B) :: iexg + real(DP) :: v + character(len=100) :: msg + type(ObserveType), pointer :: obsrv => null() + ! + ! -- Write simulated values for all gwt-gwt observations + if (this%obs%npakobs > 0) then + call this%obs%obs_bd_clear() + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + do j = 1, obsrv%indxbnds_count + iexg = obsrv%indxbnds(j) + v = DZERO + select case (obsrv%ObsTypeId) + case ('FLOW-JA-FACE') + n1 = this%nodem1(iexg) + n2 = this%nodem2(iexg) + v = this%simvals(iexg) + case default + msg = 'Error: Unrecognized observation type: ' // & + trim(obsrv%ObsTypeId) + call store_error(msg) + call store_error_unit(this%inobs) + end select + call this%obs%SaveOneSimval(obsrv, v) + enddo + enddo + endif + ! + return + end subroutine gwe_gwe_save_simvals + + !> @ brief Obs ID processer + !! + !! Process observations for this exchange + !! + !< + subroutine gwe_gwe_process_obsID(obsrv, dis, inunitobs, iout) + ! -- modules + use ConstantsModule, only: LINELENGTH + use InputOutputModule, only: urword + use ObserveModule, only: ObserveType + use BaseDisModule, only: DisBaseType + ! -- dummy + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout + ! -- local + integer(I4B) :: n, iexg, istat + integer(I4B) :: icol, istart, istop + real(DP) :: r + character(len=LINELENGTH) :: strng + ! + strng = obsrv%IDstring + icol = 1 + ! -- get exchange index + call urword(strng, icol, istart, istop, 0, n, r, iout, inunitobs) + read (strng(istart:istop), '(i10)', iostat=istat) iexg + if (istat == 0) then + obsrv%intPak1 = iexg + else + ! Integer can't be read from strng; it's presumed to be an exchange + ! boundary name (already converted to uppercase) + obsrv%FeatureName = trim(adjustl(strng)) + ! -- Observation may require summing rates from multiple exchange + ! boundaries, so assign intPak1 as a value that indicates observation + ! is for a named exchange boundary or group of exchange boundaries. + obsrv%intPak1 = NAMEDBOUNDFLAG + endif + ! + return + end subroutine gwe_gwe_process_obsID + + !> @ brief Cast polymorphic object as exchange + !! + !! Cast polymorphic object as exchange + !! + !< + function CastAsGweExchange(obj) result (res) + implicit none + class(*), pointer, intent(inout) :: obj + class(GweExchangeType), pointer :: res + ! + res => null() + if (.not. associated(obj)) return + ! + select type (obj) + class is (GweExchangeType) + res => obj + end select + return + end function CastAsGweExchange + + !> @ brief Get exchange from list + !! + !! Return an exchange from the list for specified index + !! + !< + function GetGweExchangeFromList(list, idx) result (res) + implicit none + ! -- dummy + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(GweExchangeType), pointer :: res + ! -- local + class(*), pointer :: obj + ! + obj => list%GetItem(idx) + res => CastAsGweExchange(obj) + ! + return + end function GetGweExchangeFromList + + + +end module GweGweExchangeModule + diff --git a/src/Exchange/GwfGweExchange.f90 b/src/Exchange/GwfGweExchange.f90 new file mode 100644 index 00000000000..baa196b323e --- /dev/null +++ b/src/Exchange/GwfGweExchange.f90 @@ -0,0 +1,526 @@ +module GwfGweExchangeModule + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: LENPACKAGENAME + use ListsModule, only: basemodellist, baseexchangelist, & + baseconnectionlist + use SimModule, only: store_error + use SimVariablesModule, only: errmsg + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use SpatialModelConnectionModule, only: SpatialModelConnectionType, & + GetSpatialModelConnectionFromList + use GweGweConnectionModule, only: GweGweConnectionType, CastAsGweGweConnection + use GwfGwfConnectionModule, only: GwfGwfConnectionType, CastAsGwfGwfConnection + use GwfGwfExchangeModule, only: GwfExchangeType, & + GetGwfExchangeFromList + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use GwfModule, only: GwfModelType + use GweModule, only: GweModelType + use BndModule, only: BndType, GetBndFromList + + + implicit none + public :: GwfGweExchangeType + public :: gwfgwe_cr + + type, extends(BaseExchangeType) :: GwfGweExchangeType + + integer(I4B), pointer :: m1id => null() + integer(I4B), pointer :: m2id => null() + + contains + + procedure :: exg_df + procedure :: exg_ar + procedure :: exg_da + procedure, private :: set_model_pointers + procedure, private :: allocate_scalars + procedure, private :: gwfbnd2gwefmi + procedure, private :: gwfconn2gweconn + procedure, private :: link_connections + + end type GwfGweExchangeType + + contains + + subroutine gwfgwe_cr(filename, id, m1id, m2id) +! ****************************************************************************** +! gwfgwe_cr -- Create a new GWF to GWE exchange object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: m1id + integer(I4B), intent(in) :: m2id + ! -- local + class(BaseExchangeType), pointer :: baseexchange => null() + type(GwfGweExchangeType), pointer :: exchange => null() + character(len=20) :: cint +! ------------------------------------------------------------------------------ + ! + ! -- Create a new exchange and add it to the baseexchangelist container + allocate(exchange) + baseexchange => exchange + call AddBaseExchangeToList(baseexchangelist, baseexchange) + ! + ! -- Assign id and name + exchange%id = id + write(cint, '(i0)') id + exchange%name = 'GWF-GWE_' // trim(adjustl(cint)) + exchange%memoryPath = exchange%name + ! + ! -- allocate scalars + call exchange%allocate_scalars() + exchange%m1id = m1id + exchange%m2id = m2id + ! + ! -- set model pointers + call exchange%set_model_pointers() + ! + ! -- return + return + end subroutine gwfgwe_cr + + subroutine set_model_pointers(this) +! ****************************************************************************** +! set_model_pointers -- allocate and read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfGweExchangeType) :: this + ! -- local + class(BaseModelType), pointer :: mb => null() + type(GwfModelType), pointer :: gwfmodel => null() + type(GweModelType), pointer :: gwemodel => null() +! ------------------------------------------------------------------------------ + ! + ! -- set gwfmodel + gwfmodel => null() + mb => GetBaseModelFromList(basemodellist, this%m1id) + select type (mb) + type is (GwfModelType) + gwfmodel => mb + end select + ! + ! -- set gwemodel + gwemodel => null() + mb => GetBaseModelFromList(basemodellist, this%m2id) + select type (mb) + type is (GweModelType) + gwemodel => mb + end select + ! + ! -- Verify that gwf model is of the correct type + if (.not. associated(gwfmodel)) then + write(errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & + '. Specified GWF Model does not appear to be of the correct type.' + call store_error(errmsg, terminate=.true.) + end if + ! + ! -- Verify that gwe model is of the correct type + if (.not. associated(gwemodel)) then + write(errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & + '. Specified GWF Model does not appear to be of the correct type.' + call store_error(errmsg, terminate=.true.) + end if + ! + ! -- Tell transport model fmi flows are not read from file + gwemodel%fmi%flows_from_file = .false. + ! + ! -- Set a pointer to the GWF bndlist. This will allow the transport model + ! to look through the flow packages and establish a link to GWF flows + gwemodel%fmi%gwfbndlist => gwfmodel%bndlist + ! + ! -- return + return + end subroutine set_model_pointers + + subroutine exg_df(this) +! ****************************************************************************** +! exg_df -- define +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfGweExchangeType) :: this + ! -- local + class(BaseModelType), pointer :: mb => null() + type(GwfModelType), pointer :: gwfmodel => null() + type(GweModelType), pointer :: gwemodel => null() +! ------------------------------------------------------------------------------ + ! + ! + ! -- set gwfmodel + mb => GetBaseModelFromList(basemodellist, this%m1id) + select type (mb) + type is (GwfModelType) + gwfmodel => mb + end select + ! + ! -- set gwemodel + mb => GetBaseModelFromList(basemodellist, this%m2id) + select type (mb) + type is (GweModelType) + gwemodel => mb + end select + ! + ! -- Set pointer to flowja + gwemodel%fmi%gwfflowja => gwfmodel%flowja + ! + ! -- Set the npf flag so that specific discharge is available for + ! transport calculations if dispersion is active + if (gwemodel%indsp > 0) then + gwfmodel%npf%icalcspdis = 1 + end if + ! + ! -- return + return + end subroutine exg_df + + subroutine exg_ar(this) +! ****************************************************************************** +! exg_ar -- +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfGweExchangeType) :: this + ! -- local + class(BaseModelType), pointer :: mb => null() + type(GwfModelType), pointer :: gwfmodel => null() + type(GweModelType), pointer :: gwemodel => null() + ! -- formats + character(len=*),parameter :: fmtdiserr = & + "('GWF and GWE Models do not have the same discretization for exchange& + & ',a,'.& + & GWF Model has ', i0, ' user nodes and ', i0, ' reduced nodes.& + & GWE Model has ', i0, ' user nodes and ', i0, ' reduced nodes.& + & Ensure discretization packages, including IDOMAIN, are identical.')" +! ------------------------------------------------------------------------------ + ! + ! -- set gwfmodel + mb => GetBaseModelFromList(basemodellist, this%m1id) + select type (mb) + type is (GwfModelType) + gwfmodel => mb + end select + ! + ! -- set gwemodel + mb => GetBaseModelFromList(basemodellist, this%m2id) + select type (mb) + type is (GweModelType) + gwemodel => mb + end select + ! + ! -- Check to make sure sizes are identical + if (gwemodel%dis%nodes /= gwfmodel%dis%nodes .or.& + gwemodel%dis%nodesuser /= gwfmodel%dis%nodesuser) then + write(errmsg, fmtdiserr) trim(this%name), & + gwfmodel%dis%nodesuser, & + gwfmodel%dis%nodes, & + gwemodel%dis%nodesuser, & + gwemodel%dis%nodes + call store_error(errmsg, terminate=.TRUE.) + end if + ! + ! -- setup pointers to gwf variables allocated in gwf_ar + gwemodel%fmi%gwfhead => gwfmodel%x + gwemodel%fmi%gwfsat => gwfmodel%npf%sat + gwemodel%fmi%gwfspdis => gwfmodel%npf%spdis + ! + ! -- setup pointers to the flow storage rates. GWF strg arrays are + ! available after the gwf_ar routine is called. + if(gwemodel%inmst > 0) then + if (gwfmodel%insto > 0) then + gwemodel%fmi%gwfstrgss => gwfmodel%sto%strgss + gwemodel%fmi%igwfstrgss = 1 + if (gwfmodel%sto%iusesy == 1) then + gwemodel%fmi%gwfstrgsy => gwfmodel%sto%strgsy + gwemodel%fmi%igwfstrgsy = 1 + endif + endif + endif + ! + ! -- Set a pointer to conc + if (gwfmodel%inbuy > 0) then + call gwfmodel%buy%set_concentration_pointer(gwemodel%name, gwemodel%x, & + gwemodel%ibound) + endif + ! + ! -- transfer the boundary package information from gwf to gwe + call this%gwfbnd2gwefmi() + ! + ! -- if mover package is active, then set a pointer to it's budget object + if (gwfmodel%inmvr /= 0) then + gwemodel%fmi%mvrbudobj => gwfmodel%mvr%budobj + end if + ! + ! -- connect Connections + call this%gwfconn2gweconn(gwfmodel, gwemodel) + ! + ! -- return + return + end subroutine exg_ar + + !> @brief Link GWE connections to GWF connections or exchanges + !< + subroutine gwfconn2gweconn(this, gwfModel, gweModel) + use SimModule, only: store_error + use SimVariablesModule, only: iout + class(GwfGweExchangeType) :: this !< this exchange + type(GwfModelType), pointer :: gwfModel !< the flow model + type(GweModelType), pointer :: gweModel !< the transport model + ! local + class(SpatialModelConnectionType), pointer :: conn => null() + class(*), pointer :: objPtr => null() + class(GweGweConnectionType), pointer :: gweConn => null() + class(GwfGwfConnectionType), pointer :: gwfConn => null() + class(GwfExchangeType), pointer :: gwfEx => null() + integer(I4B) :: ic1, ic2, iex + integer(I4B) :: gwfConnIdx, gwfExIdx + logical(LGP) :: areEqual + + ! loop over all connections + gweloop: do ic1 = 1, baseconnectionlist%Count() + + conn => GetSpatialModelConnectionFromList(baseconnectionlist,ic1) + if (.not. associated(conn%owner, gweModel)) cycle gweloop + + ! start with a GWE conn. + objPtr => conn + gweConn => CastAsGweGweConnection(objPtr) + gwfConnIdx = -1 + gwfExIdx = -1 + + ! find matching GWF conn. in same list + gwfloop: do ic2 = 1, baseconnectionlist%Count() + conn => GetSpatialModelConnectionFromList(baseconnectionlist,ic2) + + if (associated(conn%owner, gwfModel)) then + objPtr => conn + gwfConn => CastAsGwfGwfConnection(objPtr) + + ! for now, connecting the same nodes nrs will be + ! sufficient evidence of equality + areEqual = all(gwfConn%primaryExchange%nodem1 == & + gweConn%primaryExchange%nodem1) + areEqual = areEqual .and. all(gwfConn%primaryExchange%nodem2 == & + gweConn%primaryExchange%nodem2) + if (areEqual) then + ! same DIS, same exchange: link and go to next GWE conn. + write(iout,'(/6a)') 'Linking exchange ', & + trim(gweConn%primaryExchange%name), & + ' to ', trim(gwfConn%primaryExchange%name), & + ' (using interface model) for GWE model ', & + trim(gweModel%name) + gwfConnIdx = ic2 + call this%link_connections(gweConn, gwfConn) + exit gwfloop + end if + end if + end do gwfloop + + ! fallback option: coupling to old gwfgwf exchange, + ! (this will go obsolete at some point) + if (gwfConnIdx == -1) then + gwfloopexg: do iex = 1, baseexchangelist%Count() + gwfEx => GetGwfExchangeFromList(baseexchangelist, iex) + + ! -- There is no guarantee that iex is a gwfExg, in which case + ! it will return as null. cycle if so. + if (.not. associated(gwfEx)) cycle gwfloopexg + + if (associated(gwfEx%model1, gwfModel) .or. & + associated(gwfEx%model2, gwfModel)) then + ! again, connecting the same nodes nrs will be + ! sufficient evidence of equality + areEqual = all(gwfEx%nodem1 == gweConn%primaryExchange%nodem1) + areEqual = areEqual .and. & + all(gwfEx%nodem2 == gweConn%primaryExchange%nodem2) + if (areEqual) then + ! link exchange to connection + write(iout,'(/6a)') 'Linking exchange ', & + trim(gweConn%primaryExchange%name), & + ' to ', trim(gwfEx%name), ' for GWE model ', & + trim(gweModel%name) + gwfExIdx = iex + gweConn%exgflowja => gwfEx%simvals + + !cdl link up mvt to mvr + if (gwfEx%inmvr > 0) then + if (gweConn%exchangeIsOwned) then + !cdl todo: check and make sure gweEx has mvt active + call gweConn%gweExchange%mvt%set_pointer_mvrbudobj(gwfEx%mvr%budobj) + end if + end if + + if (associated(gwfEx%model2, gwfModel)) gweConn%exgflowSign = -1 + gweConn%gweInterfaceModel%fmi%flows_from_file = .false. + + exit gwfloopexg + end if + end if + + + end do gwfloopexg + end if + + if (gwfConnIdx == -1 .and. gwfExIdx == -1) then + ! none found, report + write(errmsg, '(/6a)') 'Missing GWF-GWF exchange when connecting GWE'// & + ' model ', trim(gweModel%name), ' with exchange ', & + trim(gweConn%primaryExchange%name), ' to GWF model ', & + trim(gwfModel%name) + call store_error(errmsg, terminate=.true.) + end if + + end do gweloop + + end subroutine gwfconn2gweconn + + + !> @brief Links a GWE connection to its GWF counterpart + !< + subroutine link_connections(this, gweConn, gwfConn) + class(GwfGweExchangeType) :: this !< this exchange + class(GweGweConnectionType), pointer :: gweConn !< GWE connection + class(GwfGwfConnectionType), pointer :: gwfConn !< GWF connection + + !gweConn%exgflowja => gwfConn%exgflowja + gweConn%exgflowja => gwfConn%gwfExchange%simvals + + !cdl link up mvt to mvr + if (gwfConn%gwfExchange%inmvr > 0) then + if (gweConn%exchangeIsOwned) then + !cdl todo: check and make sure gweEx has mvt active + call gweConn%gweExchange%mvt%set_pointer_mvrbudobj(gwfConn%gwfExchange%mvr%budobj) + end if + end if + + if (associated(gwfConn%gwfExchange%model2, gwfConn%owner)) gweConn%exgflowSign = -1 + + ! fmi flows are not read from file + gweConn%gweInterfaceModel%fmi%flows_from_file = .false. + + ! set concentration pointer for buoyancy + call gwfConn%gwfInterfaceModel%buy%set_concentration_pointer( & + gweConn%gweModel%name, & + gweConn%conc, & + gweConn%icbound) + + end subroutine link_connections + + subroutine exg_da(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GwfGweExchangeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + call mem_deallocate(this%m1id) + call mem_deallocate(this%m2id) + ! + ! -- return + return + end subroutine exg_da + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfGweExchangeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + call mem_allocate(this%m1id, 'M1ID', this%memoryPath) + call mem_allocate(this%m2id, 'M2ID', this%memoryPath) + this%m1id = 0 + this%m2id = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + subroutine gwfbnd2gwefmi(this) +! ****************************************************************************** +! gwfbnd2gwefmi +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfGweExchangeType) :: this + ! -- local + integer(I4B) :: ngwfpack, ip, iterm, imover + class(BaseModelType), pointer :: mb => null() + type(GwfModelType), pointer :: gwfmodel => null() + type(GweModelType), pointer :: gwemodel => null() + class(BndType), pointer :: packobj => null() +! ------------------------------------------------------------------------------ + ! + ! -- set gwfmodel + mb => GetBaseModelFromList(basemodellist, this%m1id) + select type (mb) + type is (GwfModelType) + gwfmodel => mb + end select + ! + ! -- set gwemodel + mb => GetBaseModelFromList(basemodellist, this%m2id) + select type (mb) + type is (GweModelType) + gwemodel => mb + end select + ! + ! -- Call routines in FMI that will set pointers to the necessary flow + ! data (SIMVALS and SIMTOMVR) stored within each GWF flow package + ngwfpack = gwfmodel%bndlist%Count() + iterm = 1 + do ip = 1, ngwfpack + packobj => GetBndFromList(gwfmodel%bndlist, ip) + call gwemodel%fmi%gwfpackages(iterm)%set_pointers( & + 'SIMVALS', & + packobj%memoryPath) + iterm = iterm + 1 + ! + ! -- If a mover is active for this package, then establish a separate + ! pointer link for the mover flows stored in SIMTOMVR + imover = packobj%imover + if (packobj%isadvpak /= 0) imover = 0 + if (imover /= 0) then + call gwemodel%fmi%gwfpackages(iterm)%set_pointers( & + 'SIMTOMVR', & + packobj%memoryPath) + iterm = iterm + 1 + end if + end do + ! + ! -- return + return + end subroutine gwfbnd2gwefmi + +end module GwfGweExchangeModule \ No newline at end of file diff --git a/src/Exchange/GwfGwfExchange.f90 b/src/Exchange/GwfGwfExchange.f90 index 5e2f48b68d2..40b6ec8e07b 100644 --- a/src/Exchange/GwfGwfExchange.f90 +++ b/src/Exchange/GwfGwfExchange.f90 @@ -9,25 +9,25 @@ !< module GwfGwfExchangeModule - use KindModule, only: DP, I4B, LGP - use SimVariablesModule, only: errmsg - use SimModule, only: store_error - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & - TABCENTER, TABLEFT, LENAUXNAME, DNODATA - use ListModule, only: ListType - use ListsModule, only: basemodellist - use DisConnExchangeModule, only: DisConnExchangeType - use GwfModule, only: GwfModelType - use GhostNodeModule, only: GhostNodeType - use GwfMvrModule, only: GwfMvrType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use SimModule, only: count_errors, store_error, store_error_unit - use SimVariablesModule, only: errmsg - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr + use KindModule, only: DP, I4B, LGP + use SimVariablesModule, only: errmsg + use SimModule, only: store_error + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & + TABCENTER, TABLEFT, LENAUXNAME, DNODATA + use ListModule, only: ListType + use ListsModule, only: basemodellist + use DisConnExchangeModule, only: DisConnExchangeType + use GwfModule, only: GwfModelType + use GhostNodeModule, only: GhostNodeType + use GwfMvrModule, only: GwfMvrType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, store_error_unit + use SimVariablesModule, only: errmsg + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr implicit none @@ -37,78 +37,78 @@ module GwfGwfExchangeModule public :: GetGwfExchangeFromList public :: CastAsGwfExchange - !> @brief Derived type for GwfExchangeType + !> @brief Derived type for GwfExchangeType !! !! This derived type contains information and methods for !! connecting two GWF models. !! !< type, extends(DisConnExchangeType) :: GwfExchangeType - type(GwfModelType), pointer :: gwfmodel1 => null() !< pointer to GWF Model 1 - type(GwfModelType), pointer :: gwfmodel2 => null() !< pointer to GWF Model 2 - ! - ! -- GWF specific option block: - integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows - integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows - integer(I4B), pointer :: inewton => null() !< newton flag (1 newton is on) - integer(I4B), pointer :: icellavg => null() !< cell averaging - integer(I4B), pointer :: ivarcv => null() !< variable cv - integer(I4B), pointer :: idewatcv => null() !< dewatered cv - integer(I4B), pointer :: ingnc => null() !< unit number for gnc (0 if off) - type(GhostNodeType), pointer :: gnc => null() !< gnc object - integer(I4B), pointer :: inmvr => null() !< unit number for mover (0 if off) - type(GwfMvrType), pointer :: mvr => null() !< water mover object - integer(I4B), pointer :: inobs => null() !< unit number for GWF-GWF observations - type(ObsType), pointer :: obs => null() !< observation object + type(GwfModelType), pointer :: gwfmodel1 => null() !< pointer to GWF Model 1 + type(GwfModelType), pointer :: gwfmodel2 => null() !< pointer to GWF Model 2 + ! + ! -- GWF specific option block: + integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows + integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows + integer(I4B), pointer :: inewton => null() !< newton flag (1 newton is on) + integer(I4B), pointer :: icellavg => null() !< cell averaging + integer(I4B), pointer :: ivarcv => null() !< variable cv + integer(I4B), pointer :: idewatcv => null() !< dewatered cv + integer(I4B), pointer :: ingnc => null() !< unit number for gnc (0 if off) + type(GhostNodeType), pointer :: gnc => null() !< gnc object + integer(I4B), pointer :: inmvr => null() !< unit number for mover (0 if off) + type(GwfMvrType), pointer :: mvr => null() !< water mover object + integer(I4B), pointer :: inobs => null() !< unit number for GWF-GWF observations + type(ObsType), pointer :: obs => null() !< observation object ! ! -- internal data - real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance - real(DP), dimension(:), pointer, contiguous :: condsat => null() !< saturated conductance - integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() !< mapping to global (solution) amat - integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() !< mapping to global (solution) symmetric amat - real(DP), pointer :: satomega => null() !< saturation smoothing - real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange + real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance + real(DP), dimension(:), pointer, contiguous :: condsat => null() !< saturated conductance + integer(I4B), dimension(:), pointer, contiguous :: idxglo => null() !< mapping to global (solution) amat + integer(I4B), dimension(:), pointer, contiguous :: idxsymglo => null() !< mapping to global (solution) symmetric amat + real(DP), pointer :: satomega => null() !< saturation smoothing + real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange ! ! -- table objects type(TableType), pointer :: outputtab1 => null() - type(TableType), pointer :: outputtab2 => null() + type(TableType), pointer :: outputtab2 => null() contains - procedure :: exg_df => gwf_gwf_df - procedure :: exg_ac => gwf_gwf_ac - procedure :: exg_mc => gwf_gwf_mc - procedure :: exg_ar => gwf_gwf_ar - procedure :: exg_rp => gwf_gwf_rp - procedure :: exg_ad => gwf_gwf_ad - procedure :: exg_cf => gwf_gwf_cf - procedure :: exg_fc => gwf_gwf_fc - procedure :: exg_fn => gwf_gwf_fn - procedure :: exg_cq => gwf_gwf_cq - procedure :: exg_bd => gwf_gwf_bd - procedure :: exg_ot => gwf_gwf_ot - procedure :: exg_da => gwf_gwf_da - procedure :: exg_fp => gwf_gwf_fp - procedure :: get_iasym => gwf_gwf_get_iasym - procedure :: connects_model => gwf_gwf_connects_model - procedure :: use_interface_model - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: parse_option - procedure :: read_gnc - procedure :: read_mvr + procedure :: exg_df => gwf_gwf_df + procedure :: exg_ac => gwf_gwf_ac + procedure :: exg_mc => gwf_gwf_mc + procedure :: exg_ar => gwf_gwf_ar + procedure :: exg_rp => gwf_gwf_rp + procedure :: exg_ad => gwf_gwf_ad + procedure :: exg_cf => gwf_gwf_cf + procedure :: exg_fc => gwf_gwf_fc + procedure :: exg_fn => gwf_gwf_fn + procedure :: exg_cq => gwf_gwf_cq + procedure :: exg_bd => gwf_gwf_bd + procedure :: exg_ot => gwf_gwf_ot + procedure :: exg_da => gwf_gwf_da + procedure :: exg_fp => gwf_gwf_fp + procedure :: get_iasym => gwf_gwf_get_iasym + procedure :: connects_model => gwf_gwf_connects_model + procedure :: use_interface_model + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: parse_option + procedure :: read_gnc + procedure :: read_mvr procedure, private :: condcalc procedure, private :: rewet procedure, private :: qcalc - procedure :: gwf_gwf_bdsav + procedure :: gwf_gwf_bdsav procedure, private :: gwf_gwf_df_obs procedure, private :: gwf_gwf_rp_obs - procedure, public :: gwf_gwf_save_simvals + procedure, public :: gwf_gwf_save_simvals procedure, private :: gwf_gwf_calc_simvals - procedure, public :: gwf_gwf_set_spdis + procedure, public :: gwf_gwf_set_spdis procedure, private :: validate_exchange - procedure :: gwf_gwf_add_to_flowja + procedure :: gwf_gwf_add_to_flowja end type GwfExchangeType contains @@ -126,10 +126,10 @@ subroutine gwfexchange_create(filename, id, m1id, m2id) use ObsModule, only: obs_cr use MemoryHelperModule, only: create_mem_path ! -- dummy - character(len=*),intent(in) :: filename !< filename for reading - integer(I4B), intent(in) :: id !< id for the exchange - integer(I4B), intent(in) :: m1id !< id for model 1 - integer(I4B), intent(in) :: m2id !< id for model 2 + character(len=*), intent(in) :: filename !< filename for reading + integer(I4B), intent(in) :: id !< id for the exchange + integer(I4B), intent(in) :: m1id !< id for model 1 + integer(I4B), intent(in) :: m2id !< id for model 2 ! -- local type(GwfExchangeType), pointer :: exchange class(BaseModelType), pointer :: mb @@ -137,14 +137,14 @@ subroutine gwfexchange_create(filename, id, m1id, m2id) character(len=20) :: cint ! ! -- Create a new exchange and add it to the baseexchangelist container - allocate(exchange) + allocate (exchange) baseexchange => exchange call AddBaseExchangeToList(baseexchangelist, baseexchange) ! ! -- Assign id and name exchange%id = id - write(cint, '(i0)') id - exchange%name = 'GWF-GWF_' // trim(adjustl(cint)) + write (cint, '(i0)') id + exchange%name = 'GWF-GWF_'//trim(adjustl(cint)) exchange%memoryPath = create_mem_path(exchange%name) ! ! -- allocate scalars and set defaults @@ -153,7 +153,7 @@ subroutine gwfexchange_create(filename, id, m1id, m2id) exchange%typename = 'GWF-GWF' ! ! -- set gwfmodel1 - mb => GetBaseModelFromList(basemodellist, m1id) + mb => GetBaseModelFromList(basemodellist, m1id) select type (mb) type is (GwfModelType) exchange%model1 => mb @@ -170,7 +170,7 @@ subroutine gwfexchange_create(filename, id, m1id, m2id) ! ! -- Verify that gwf model1 is of the correct type if (.not. associated(exchange%gwfmodel1)) then - write(errmsg, '(3a)') 'Problem with GWF-GWF exchange ', & + write (errmsg, '(3a)') 'Problem with GWF-GWF exchange ', & trim(exchange%name), & '. First specified GWF Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) @@ -178,7 +178,7 @@ subroutine gwfexchange_create(filename, id, m1id, m2id) ! ! -- Verify that gwf model2 is of the correct type if (.not. associated(exchange%gwfmodel2)) then - write(errmsg, '(3a)') 'Problem with GWF-GWF exchange ', & + write (errmsg, '(3a)') 'Problem with GWF-GWF exchange ', & trim(exchange%name), & '. Second specified GWF Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) @@ -202,25 +202,25 @@ subroutine gwf_gwf_df(this) use InputOutputModule, only: getunit, openfile use GhostNodeModule, only: gnc_cr ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: inunit ! ! -- open the file inunit = getunit() - write(iout,'(/a,a)') ' Creating exchange: ', this%name + write (iout, '(/a,a)') ' Creating exchange: ', this%name call openfile(inunit, iout, this%filename, 'GWF-GWF') ! call this%parser%Initialize(inunit, iout) ! ! -- Ensure models are in same solution - if(this%gwfmodel1%idsoln /= this%gwfmodel2%idsoln) then - call store_error('ERROR. TWO MODELS ARE CONNECTED ' // & - 'IN A GWF EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. ' // & - 'GWF MODELS MUST BE IN SAME SOLUTION: ' // & - trim(this%gwfmodel1%name) // ' ' // trim(this%gwfmodel2%name) ) + if (this%gwfmodel1%idsoln /= this%gwfmodel2%idsoln) then + call store_error('ERROR. TWO MODELS ARE CONNECTED IN A GWF '// & + 'EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. '// & + 'GWF MODELS MUST BE IN SAME SOLUTION: '// & + trim(this%gwfmodel1%name)//' '//trim(this%gwfmodel2%name)) call this%parser%StoreErrorUnit() - endif + end if ! ! -- read options call this%read_options(iout) @@ -239,22 +239,22 @@ subroutine gwf_gwf_df(this) call this%gwfmodel2%npf%increase_edge_count(this%nexg) ! ! -- Create and read ghost node information - if(this%ingnc > 0) then + if (this%ingnc > 0) then call gnc_cr(this%gnc, this%name, this%ingnc, iout) call this%read_gnc() - endif + end if ! ! -- Read mover information - if(this%inmvr > 0) then + if (this%inmvr > 0) then call this%read_mvr(iout) - endif + end if ! ! -- close the file - close(inunit) + close (inunit) ! ! -- Store obs call this%gwf_gwf_df_obs() - call this%obs%obs_df(iout, this%name, 'GWF-GWF', this%gwfmodel1%dis) + call this%obs%obs_df(iout, this%name, 'GWF-GWF', this%gwfmodel1%dis) ! ! -- validate call this%validate_exchange() @@ -266,15 +266,15 @@ end subroutine gwf_gwf_df !> @brief validate exchange data after reading !< subroutine validate_exchange(this) - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! local - + ! Periodic boundary condition in exchange don't allow XT3D (=interface model) if (associated(this%model1, this%model2)) then if (this%ixt3d > 0) then - write(errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & - ' is a periodic boundary condition which cannot'// & - ' be configured with XT3D' + write (errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & + ' is a periodic boundary condition which cannot'// & + ' be configured with XT3D' call store_error(errmsg, terminate=.TRUE.) end if end if @@ -282,43 +282,43 @@ subroutine validate_exchange(this) ! Check to see if horizontal anisotropy is in either model1 or model2. ! If so, then ANGLDEGX must be provided as an auxiliary variable for this ! GWF-GWF exchange (this%ianglex > 0). - if(this%gwfmodel1%npf%ik22 /= 0 .or. this%gwfmodel2%npf%ik22 /= 0) then - if(this%ianglex == 0) then - write(errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because K22 was specified'// & - ' in one or both groundwater models.' + if (this%gwfmodel1%npf%ik22 /= 0 .or. this%gwfmodel2%npf%ik22 /= 0) then + if (this%ianglex == 0) then + write (errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because K22 was specified'// & + ' in one or both groundwater models.' call store_error(errmsg, terminate=.TRUE.) - endif - endif - + end if + end if + ! Check to see if specific discharge is needed for model1 or model2. ! If so, then ANGLDEGX must be provided as an auxiliary variable for this ! GWF-GWF exchange (this%ianglex > 0). - if(this%gwfmodel1%npf%icalcspdis /= 0 .or. & - this%gwfmodel2%npf%icalcspdis /= 0) then - if(this%ianglex == 0) then - write(errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because specific discharge'// & - ' is being calculated in one or both'// & - ' groundwater models.' + if (this%gwfmodel1%npf%icalcspdis /= 0 .or. & + this%gwfmodel2%npf%icalcspdis /= 0) then + if (this%ianglex == 0) then + write (errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because specific discharge'// & + ' is being calculated in one or both'// & + ' groundwater models.' call store_error(errmsg, terminate=.TRUE.) - endif - if(this%icdist == 0) then - write(errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & - ' requires that CDIST be specified as an'// & - ' auxiliary variable because specific discharge'// & - ' is being calculated in one or both'// & - ' groundwater models.' + end if + if (this%icdist == 0) then + write (errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & + ' requires that CDIST be specified as an'// & + ' auxiliary variable because specific discharge'// & + ' is being calculated in one or both'// & + ' groundwater models.' call store_error(errmsg, terminate=.TRUE.) - endif - endif + end if + end if if (this%ixt3d > 0 .and. this%ianglex == 0) then - write(errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because XT3D is enabled' + write (errmsg, '(3a)') 'GWF-GWF exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because XT3D is enabled' call store_error(errmsg, terminate=.TRUE.) end if @@ -331,9 +331,9 @@ end subroutine validate_exchange !< subroutine gwf_gwf_ac(this, sparse) ! -- modules - use SparseModule, only:sparsematrix + use SparseModule, only: sparsematrix ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType type(sparsematrix), intent(inout) :: sparse ! -- local integer(I4B) :: n, iglo, jglo @@ -344,12 +344,12 @@ subroutine gwf_gwf_ac(this, sparse) jglo = this%nodem2(n) + this%gwfmodel2%moffset call sparse%addconnection(iglo, jglo, 1) call sparse%addconnection(jglo, iglo, 1) - enddo + end do ! ! -- add gnc connections - if(this%ingnc > 0) then + if (this%ingnc > 0) then call this%gnc%gnc_ac(sparse) - endif + end if ! ! -- Return return @@ -362,9 +362,9 @@ end subroutine gwf_gwf_ac !< subroutine gwf_gwf_mc(this, iasln, jasln) ! -- modules - use SparseModule, only:sparsematrix + use SparseModule, only: sparsematrix ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), dimension(:), intent(in) :: iasln integer(I4B), dimension(:), intent(in) :: jasln ! -- local @@ -372,28 +372,28 @@ subroutine gwf_gwf_mc(this, iasln, jasln) ! ! -- map exchange connections do n = 1, this%nexg - iglo = this%nodem1(n)+this%gwfmodel1%moffset - jglo = this%nodem2(n)+this%gwfmodel2%moffset + iglo = this%nodem1(n) + this%gwfmodel1%moffset + jglo = this%nodem2(n) + this%gwfmodel2%moffset ! -- find jglobal value in row iglo and store in idxglo do ipos = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(ipos)) then + if (jglo == jasln(ipos)) then this%idxglo(n) = ipos exit - endif - enddo + end if + end do ! -- find and store symmetric location do ipos = iasln(jglo), iasln(jglo + 1) - 1 - if(iglo == jasln(ipos)) then + if (iglo == jasln(ipos)) then this%idxsymglo(n) = ipos exit - endif - enddo - enddo + end if + end do + end do ! ! -- map gnc connections - if(this%ingnc > 0) then + if (this%ingnc > 0) then call this%gnc%gnc_mc(iasln, jasln) - endif + end if ! ! -- Return return @@ -409,7 +409,7 @@ subroutine gwf_gwf_ar(this) use ConstantsModule, only: LINELENGTH, DZERO, DHALF, DONE, DPIO180 use GwfNpfModule, only: condmean, vcond, hcond ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: iexg integer(I4B) :: n, m, ihc @@ -423,7 +423,7 @@ subroutine gwf_gwf_ar(this) real(DP), dimension(3) :: vg ! ! -- If mover is active, then call ar routine - if(this%inmvr > 0) call this%mvr%mvr_ar() + if (this%inmvr > 0) call this%mvr%mvr_ar() ! ! -- Go through each connection and calculate the saturated conductance do iexg = 1, this%nexg @@ -441,7 +441,7 @@ subroutine gwf_gwf_ar(this) thickm = (topm - botm) * satm ! ! -- Calculate conductance depending on connection orientation - if(ihc == 0) then + if (ihc == 0) then ! ! -- Vertical conductance for fully saturated conditions vg(1) = DZERO @@ -449,13 +449,13 @@ subroutine gwf_gwf_ar(this) vg(3) = DONE hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & - botn, botm, & - hyn, hym, & - satn, satm, & - topn, topm, & - botn, botm, & - this%hwva(iexg)) + csat = vcond(1, 1, 1, 1, 0, 1, 1, DONE, & + botn, botm, & + hyn, hym, & + satn, satm, & + topn, topm, & + botn, botm, & + this%hwva(iexg)) else ! ! -- Calculate horizontal conductance @@ -463,44 +463,43 @@ subroutine gwf_gwf_ar(this) hym = this%gwfmodel2%npf%k11(m) ! ! -- Check for anisotropy in models, and recalculate hyn and hym - if(this%ianglex > 0) then + if (this%ianglex > 0) then angle = this%auxvar(this%ianglex, iexg) * DPIO180 vg(1) = abs(cos(angle)) vg(2) = abs(sin(angle)) vg(3) = DZERO ! ! -- anisotropy in model 1 - if(this%gwfmodel1%npf%ik22 /= 0) then + if (this%gwfmodel1%npf%ik22 /= 0) then hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) - endif + end if ! ! -- anisotropy in model 2 - if(this%gwfmodel2%npf%ik22 /= 0) then + if (this%gwfmodel2%npf%ik22 /= 0) then hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - endif - endif + end if + end if ! fawidth = this%hwva(iexg) - csat = hcond(1, 1, 1, 1, this%inewton, 0, ihc, & - this%icellavg, 0, 0, DONE, & - topn, topm, satn, satm, hyn, hym, & - topn, topm, & - botn, botm, & - this%cl1(iexg), this%cl2(iexg), & - fawidth, this%satomega) - endif + csat = hcond(1, 1, 1, 1, this%inewton, 0, ihc, & + this%icellavg, 0, 0, DONE, & + topn, topm, satn, satm, hyn, hym, & + topn, topm, & + botn, botm, & + this%cl1(iexg), this%cl2(iexg), & + fawidth, this%satomega) + end if ! ! -- store csat in condsat this%condsat(iexg) = csat - enddo + end do ! ! -- Observation AR call this%obs%obs_ar() ! ! -- Return return - end subroutine gwf_gwf_ar - + end subroutine gwf_gwf_ar !> @ brief Read and prepare !! @@ -511,13 +510,13 @@ subroutine gwf_gwf_rp(this) ! -- modules use TdisModule, only: readnewdata ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! ! -- Check with TDIS on whether or not it is time to RP if (.not. readnewdata) return ! ! -- Read and prepare for mover - if(this%inmvr > 0) call this%mvr%mvr_rp() + if (this%inmvr > 0) call this%mvr%mvr_rp() ! ! -- Read and prepare for observations call this%gwf_gwf_rp_obs() @@ -534,11 +533,11 @@ end subroutine gwf_gwf_rp subroutine gwf_gwf_ad(this) ! -- modules ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local ! ! -- Advance mover - if(this%inmvr > 0) call this%mvr%mvr_ad() + if (this%inmvr > 0) call this%mvr%mvr_ad() ! ! -- Push simulated values to preceding time step call this%obs%obs_ad() @@ -554,7 +553,7 @@ end subroutine gwf_gwf_ad !< subroutine gwf_gwf_cf(this, kiter) ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: kiter ! -- local ! @@ -565,7 +564,7 @@ subroutine gwf_gwf_cf(this, kiter) ! -- Return return end subroutine gwf_gwf_cf - + !> @ brief Fill coefficients !! !! Calculate conductance and fill coefficient matrix @@ -576,11 +575,11 @@ subroutine gwf_gwf_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) use ConstantsModule, only: DHALF use GwfNpfModule, only: hcond, vcond ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: kiter integer(I4B), dimension(:), intent(in) :: iasln real(DP), dimension(:), intent(inout) :: amatsln - real(DP), dimension(:), intent(inout) ::rhssln + real(DP), dimension(:), intent(inout) :: rhssln integer(I4B), optional, intent(in) :: inwtflag ! -- local integer(I4B) :: inwt, iexg @@ -592,11 +591,11 @@ subroutine gwf_gwf_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) ! ! -- if gnc is active, then copy cond into gnc cond (might consider a ! pointer here in the future) - if(this%ingnc > 0) then + if (this%ingnc > 0) then do iexg = 1, this%nexg this%gnc%cond(iexg) = this%cond(iexg) - enddo - endif + end do + end if ! ! -- Put this%cond into amatsln do i = 1, this%nexg @@ -608,35 +607,35 @@ subroutine gwf_gwf_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) amatsln(idiagsln) = amatsln(idiagsln) - this%cond(i) idiagsln = iasln(nodem2sln) amatsln(idiagsln) = amatsln(idiagsln) - this%cond(i) - enddo + end do ! ! -- Fill the gnc terms in the solution matrix - if(this%ingnc > 0) then + if (this%ingnc > 0) then call this%gnc%gnc_fc(kiter, amatsln) - endif + end if ! ! -- Call mvr fc routine - if(this%inmvr > 0) call this%mvr%mvr_fc() + if (this%inmvr > 0) call this%mvr%mvr_fc() ! ! -- Set inwt to exchange newton, but shut off if requested by caller inwt = this%inewton - if(present(inwtflag)) then + if (present(inwtflag)) then if (inwtflag == 0) inwt = 0 - endif + end if if (inwt /= 0) then call this%exg_fn(kiter, iasln, amatsln) - endif + end if ! ! -- Ghost node Newton-Raphson if (this%ingnc > 0) then if (inwt /= 0) then njasln = size(amatsln) - call this%gnc%gnc_fn(kiter, njasln, amatsln, this%condsat, & - ihc_opt=this%ihc, ivarcv_opt=this%ivarcv, & - ictm1_opt=this%gwfmodel1%npf%icelltype, & - ictm2_opt=this%gwfmodel2%npf%icelltype) - endif - endif + call this%gnc%gnc_fn(kiter, njasln, amatsln, this%condsat, & + ihc_opt=this%ihc, ivarcv_opt=this%ivarcv, & + ictm1_opt=this%gwfmodel1%npf%icelltype, & + ictm2_opt=this%gwfmodel2%npf%icelltype) + end if + end if ! ! -- Return return @@ -651,7 +650,7 @@ subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) ! -- modules use SmoothingModule, only: sQuadraticSaturationDerivative ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: kiter integer(I4B), dimension(:), intent(in) :: iasln real(DP), dimension(:), intent(inout) :: amatsln @@ -685,15 +684,15 @@ subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) botm = this%gwfmodel2%dis%bot(m) hn = this%gwfmodel1%x(n) hm = this%gwfmodel2%x(m) - if(this%ihc(iexg) == 0) then + if (this%ihc(iexg) == 0) then ! -- vertical connection, newton not supported else ! -- determine upstream node nisup = .false. - if(hm < hn) nisup = .true. + if (hm < hn) nisup = .true. ! ! -- set upstream top and bot - if(nisup) then + if (nisup) then topup = topn botup = botn hup = hn @@ -703,7 +702,7 @@ subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) botup = botm hup = hm hdn = hn - endif + end if ! ! -- no newton terms if upstream cell is confined if (nisup) then @@ -713,10 +712,10 @@ subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) end if ! ! -- set topup and botup - if(this%ihc(iexg) == 2) then + if (this%ihc(iexg) == 2) then topup = min(topn, topm) botup = max(botn, botm) - endif + end if ! ! get saturated conductivity for derivative cond = this%condsat(iexg) @@ -728,16 +727,16 @@ subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) derv = sQuadraticSaturationDerivative(topup, botup, hup) idiagnsln = iasln(nodensln) idiagmsln = iasln(nodemsln) - if(nisup) then + if (nisup) then ! ! -- fill jacobian with n being upstream term = consterm * derv this%gwfmodel1%rhs(n) = this%gwfmodel1%rhs(n) + term * hn this%gwfmodel2%rhs(m) = this%gwfmodel2%rhs(m) - term * hn amatsln(idiagnsln) = amatsln(idiagnsln) + term - if(ibdm > 0) then + if (ibdm > 0) then amatsln(this%idxsymglo(iexg)) = amatsln(this%idxsymglo(iexg)) - term - endif + end if else ! ! -- fill jacobian with m being upstream @@ -745,12 +744,12 @@ subroutine gwf_gwf_fn(this, kiter, iasln, amatsln) this%gwfmodel1%rhs(n) = this%gwfmodel1%rhs(n) + term * hm this%gwfmodel2%rhs(m) = this%gwfmodel2%rhs(m) - term * hm amatsln(idiagmsln) = amatsln(idiagmsln) - term - if(ibdn > 0) then + if (ibdn > 0) then amatsln(this%idxglo(iexg)) = amatsln(this%idxglo(iexg)) + term - endif - endif - endif - enddo + end if + end if + end if + end do ! ! -- Return return @@ -765,14 +764,14 @@ end subroutine gwf_gwf_fn subroutine gwf_gwf_cq(this, icnvg, isuppress_output, isolnid) ! -- modules ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(inout) :: icnvg integer(I4B), intent(in) :: isuppress_output integer(I4B), intent(in) :: isolnid ! -- local ! ! -- calculate flow and store in simvals - call this%gwf_gwf_calc_simvals() + call this%gwf_gwf_calc_simvals() ! ! -- calculate specific discharge and set to model call this%gwf_gwf_set_spdis() @@ -788,7 +787,7 @@ end subroutine gwf_gwf_cq !< store them in a member array subroutine gwf_gwf_calc_simvals(this) use ConstantsModule, only: DZERO - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! local integer(I4B) :: i integer(I4B) :: n1, n2 @@ -801,22 +800,22 @@ subroutine gwf_gwf_calc_simvals(this) n2 = this%nodem2(i) ibdn1 = this%gwfmodel1%ibound(n1) ibdn2 = this%gwfmodel2%ibound(n2) - if(ibdn1 /= 0 .and. ibdn2 /= 0) then + if (ibdn1 /= 0 .and. ibdn2 /= 0) then rrate = this%qcalc(i, n1, n2) - if(this%ingnc > 0) then + if (this%ingnc > 0) then rrate = rrate + this%gnc%deltaqgnc(i) - endif - endif + end if + end if this%simvals(i) = rrate end do - + return end subroutine gwf_gwf_calc_simvals !> @brief Add exchange flow to each model flowja diagonal !< position so that residual is calculated correctly. subroutine gwf_gwf_add_to_flowja(this) - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! local integer(I4B) :: i integer(I4B) :: n @@ -824,19 +823,19 @@ subroutine gwf_gwf_add_to_flowja(this) real(DP) :: flow do i = 1, this%nexg - + flow = this%simvals(i) n = this%nodem1(i) idiag = this%gwfmodel1%ia(n) this%gwfmodel1%flowja(idiag) = this%gwfmodel1%flowja(idiag) + flow - + flow = -this%simvals(i) n = this%nodem2(i) idiag = this%gwfmodel2%ia(n) this%gwfmodel2%flowja(idiag) = this%gwfmodel2%flowja(idiag) + flow - + end do - + return end subroutine gwf_gwf_add_to_flowja @@ -845,7 +844,7 @@ end subroutine gwf_gwf_add_to_flowja subroutine gwf_gwf_set_spdis(this) use ConstantsModule, only: DZERO, DPIO180 use GwfNpfModule, only: thksatnm - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! local integer(I4B) :: iusg integer(I4B) :: i @@ -873,8 +872,8 @@ subroutine gwf_gwf_set_spdis(this) ! -- initialize iusg = 0 ! - ! -- Loop through all exchanges using the flow rate - ! stored in simvals + ! -- Loop through all exchanges using the flow rate + ! stored in simvals do i = 1, this%nexg rrate = this%simvals(i) n1 = this%nodem1(i) @@ -895,64 +894,64 @@ subroutine gwf_gwf_set_spdis(this) hn2 = this%gwfmodel2%x(n2) ! ! -- Calculate face normal components - if(ihc == 0) then + if (ihc == 0) then nx = DZERO ny = DZERO area = hwva if (botn1 < botn2) then ! -- n1 is beneath n2, so rate is positive downward. Flip rate ! upward so that points in positive z direction - rrate = - rrate - endif + rrate = -rrate + end if else - if(this%ianglex > 0) then + if (this%ianglex > 0) then angle = this%auxvar(this%ianglex, i) * DPIO180 nx = cos(angle) ny = sin(angle) else ! error? call store_error('error in gwf_gwf_cq', terminate=.TRUE.) - endif + end if ! ! -- Calculate the saturated thickness at interface between n1 and n2 - thksat = thksatnm(ibdn1, ibdn2, ictn1, ictn2, this%inewton, ihc, & - iusg, hn1, hn2, satn1, satn2, & + thksat = thksatnm(ibdn1, ibdn2, ictn1, ictn2, this%inewton, ihc, & + iusg, hn1, hn2, satn1, satn2, & topn1, topn2, botn1, botn2, this%satomega) area = hwva * thksat - endif + end if ! ! -- Submit this connection and flow information to the npf ! package of gwfmodel1 - if(this%icdist > 0) then + if (this%icdist > 0) then dltot = this%auxvar(this%icdist, i) else call store_error('error in gwf_gwf_cq', terminate=.TRUE.) - endif + end if distance = dltot * this%cl1(i) / (this%cl1(i) + this%cl2(i)) if (this%gwfmodel1%npf%icalcspdis == 1) then - call this%gwfmodel1%npf%set_edge_properties(n1, ihc, rrate, area, & + call this%gwfmodel1%npf%set_edge_properties(n1, ihc, rrate, area, & nx, ny, distance) - endif + end if ! ! -- Submit this connection and flow information to the npf ! package of gwfmodel2 - if(this%icdist > 0) then + if (this%icdist > 0) then dltot = this%auxvar(this%icdist, i) else call store_error('error in gwf_gwf_cq', terminate=.TRUE.) - endif + end if if (this%gwfmodel2%npf%icalcspdis == 1) then distance = dltot * this%cl2(i) / (this%cl1(i) + this%cl2(i)) if (ihc /= 0) rrate = -rrate - call this%gwfmodel2%npf%set_edge_properties(n2, ihc, rrate, area, & + call this%gwfmodel2%npf%set_edge_properties(n2, ihc, rrate, area, & -nx, -ny, distance) - endif + end if ! - enddo + end do ! return end subroutine gwf_gwf_set_spdis - + !> @ brief Budget !! !! Accumulate budget terms @@ -963,7 +962,7 @@ subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME use BudgetModule, only: rate_accumulator ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(inout) :: icnvg integer(I4B), intent(in) :: isuppress_output integer(I4B), intent(in) :: isolnid @@ -990,12 +989,12 @@ subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) call this%gwfmodel2%model_bdentry(budterm, budtxt, this%name) ! ! -- Call mvr bd routine - if(this%inmvr > 0) call this%mvr%mvr_bd() + if (this%inmvr > 0) call this%mvr%mvr_bd() ! ! -- return return end subroutine gwf_gwf_bd - + !> @ brief Budget save !! !! Output individual flows to listing file and binary budget files @@ -1006,11 +1005,11 @@ subroutine gwf_gwf_bdsav(this) use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME use TdisModule, only: kstp, kper ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local character(len=LENBOUNDNAME) :: bname - character(len=LENPACKAGENAME+4) :: packname1 - character(len=LENPACKAGENAME+4) :: packname2 + character(len=LENPACKAGENAME + 4) :: packname1 + character(len=LENPACKAGENAME + 4) :: packname2 character(len=LENBUDTXT), dimension(1) :: budtxt character(len=20) :: nodestr integer(I4B) :: ntabrows @@ -1037,7 +1036,7 @@ subroutine gwf_gwf_bdsav(this) if (this%gwfmodel1%oc%oc_save('BUDGET')) then call this%outputtab1%set_title(packname1) end if - if (this%gwfmodel2%oc%oc_save('BUDGET')) then + if (this%gwfmodel2%oc%oc_save('BUDGET')) then call this%outputtab2%set_title(packname2) end if ! @@ -1052,7 +1051,7 @@ subroutine gwf_gwf_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if (this%gwfmodel1%ibound(n1) /= 0 .and. & + if (this%gwfmodel1%ibound(n1) /= 0 .and. & this%gwfmodel2%ibound(n2) /= 0) then ntabrows = ntabrows + 1 end if @@ -1066,27 +1065,30 @@ subroutine gwf_gwf_bdsav(this) ! -- Print and write budget terms for model 1 ! ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then + if (this%ipakcb /= 0) then ibinun1 = this%gwfmodel1%oc%oc_save_unit('BUDGET') else ibinun1 = 0 - endif + end if ! ! -- If save budget flag is zero for this stress period, then ! shut off saving - if(.not. this%gwfmodel1%oc%oc_save('BUDGET')) ibinun1 = 0 - if(isuppress_output /= 0) then + if (.not. this%gwfmodel1%oc%oc_save('BUDGET')) ibinun1 = 0 + if (isuppress_output /= 0) then ibinun1 = 0 - endif + end if ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun1 /= 0) then - call this%gwfmodel1%dis%record_srcdst_list_header(budtxt(1), & - this%gwfmodel1%name, this%name, & - this%gwfmodel2%name, this%name, & - this%naux, this%auxname, & - ibinun1, this%nexg, this%gwfmodel1%iout) - endif + if (ibinun1 /= 0) then + call this%gwfmodel1%dis%record_srcdst_list_header(budtxt(1), & + this%gwfmodel1%name, & + this%name, & + this%gwfmodel2%name, & + this%name, & + this%naux, this%auxname, & + ibinun1, this%nexg, & + this%gwfmodel1%iout) + end if ! ! Initialize accumulators ratin = DZERO @@ -1096,11 +1098,11 @@ subroutine gwf_gwf_bdsav(this) do i = 1, this%nexg ! ! -- Assign boundary name - if (this%inamedbound>0) then + if (this%inamedbound > 0) then bname = this%boundname(i) else bname = '' - endif + end if ! ! -- Calculate the flow rate between n1 and n2 rrate = DZERO @@ -1108,62 +1110,65 @@ subroutine gwf_gwf_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if(this%gwfmodel1%ibound(n1) /= 0 .and. & + if (this%gwfmodel1%ibound(n1) /= 0 .and. & this%gwfmodel2%ibound(n2) /= 0) then rrate = this%simvals(i) ! ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwfmodel1%oc%oc_save('BUDGET')) then + if (this%iprflow /= 0) then + if (this%gwfmodel1%oc%oc_save('BUDGET')) then ! ! -- set nodestr and write outputtab table nodeu = this%gwfmodel1%dis%get_nodeuser(n1) call this%gwfmodel1%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & + call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & rrate, bname) end if - endif - if(rrate < DZERO) then + end if + if (rrate < DZERO) then ratout = ratout - rrate else ratin = ratin + rrate - endif - endif + end if + end if ! ! -- If saving cell-by-cell flows in list, write flow n1u = this%gwfmodel1%dis%get_nodeuser(n1) n2u = this%gwfmodel2%dis%get_nodeuser(n2) - if(ibinun1 /= 0) & - call this%gwfmodel1%dis%record_mf6_list_entry( & - ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & - .false., .false.) + if (ibinun1 /= 0) & + call this%gwfmodel1%dis%record_mf6_list_entry( & + ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & + .false., .false.) ! - enddo + end do ! ! -- Print and write budget terms for model 2 ! ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then + if (this%ipakcb /= 0) then ibinun2 = this%gwfmodel2%oc%oc_save_unit('BUDGET') else ibinun2 = 0 - endif + end if ! ! -- If save budget flag is zero for this stress period, then ! shut off saving - if(.not. this%gwfmodel2%oc%oc_save('BUDGET')) ibinun2 = 0 - if(isuppress_output /= 0) then + if (.not. this%gwfmodel2%oc%oc_save('BUDGET')) ibinun2 = 0 + if (isuppress_output /= 0) then ibinun2 = 0 - endif + end if ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun2 /= 0) then - call this%gwfmodel2%dis%record_srcdst_list_header(budtxt(1), & - this%gwfmodel2%name, this%name, & - this%gwfmodel1%name, this%name, & - this%naux, this%auxname, & - ibinun2, this%nexg, this%gwfmodel2%iout) - endif + if (ibinun2 /= 0) then + call this%gwfmodel2%dis%record_srcdst_list_header(budtxt(1), & + this%gwfmodel2%name, & + this%name, & + this%gwfmodel1%name, & + this%name, & + this%naux, this%auxname, & + ibinun2, this%nexg, & + this%gwfmodel2%iout) + end if ! ! Initialize accumulators ratin = DZERO @@ -1173,11 +1178,11 @@ subroutine gwf_gwf_bdsav(this) do i = 1, this%nexg ! ! -- Assign boundary name - if (this%inamedbound>0) then + if (this%inamedbound > 0) then bname = this%boundname(i) else bname = '' - endif + end if ! ! -- Calculate the flow rate between n1 and n2 rrate = DZERO @@ -1185,37 +1190,37 @@ subroutine gwf_gwf_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if(this%gwfmodel1%ibound(n1) /= 0 .and. & + if (this%gwfmodel1%ibound(n1) /= 0 .and. & this%gwfmodel2%ibound(n2) /= 0) then rrate = this%simvals(i) ! ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwfmodel2%oc%oc_save('BUDGET')) then + if (this%iprflow /= 0) then + if (this%gwfmodel2%oc%oc_save('BUDGET')) then ! ! -- set nodestr and write outputtab table nodeu = this%gwfmodel2%dis%get_nodeuser(n2) call this%gwfmodel2%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & + call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & -rrate, bname) end if - endif - if(rrate < DZERO) then + end if + if (rrate < DZERO) then ratout = ratout - rrate else ratin = ratin + rrate - endif - endif + end if + end if ! ! -- If saving cell-by-cell flows in list, write flow n1u = this%gwfmodel1%dis%get_nodeuser(n1) n2u = this%gwfmodel2%dis%get_nodeuser(n2) - if(ibinun2 /= 0) & - call this%gwfmodel2%dis%record_mf6_list_entry( & - ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & - .false., .false.) + if (ibinun2 /= 0) & + call this%gwfmodel2%dis%record_mf6_list_entry( & + ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & + .false., .false.) ! - enddo + end do ! ! -- Set icbcfl, ibudfl to zero so that flows will be printed and ! saved, if the options were set in the MVR package @@ -1223,17 +1228,17 @@ subroutine gwf_gwf_bdsav(this) ibudfl = 1 ! ! -- Call mvr bd routine - if(this%inmvr > 0) call this%mvr%mvr_bdsav(icbcfl, ibudfl, isuppress_output) + if (this%inmvr > 0) call this%mvr%mvr_bdsav(icbcfl, ibudfl, isuppress_output) ! ! -- Calculate and write simulated values for observations - if(this%inobs /= 0) then + if (this%inobs /= 0) then call this%gwf_gwf_save_simvals() - endif + end if ! ! -- return return end subroutine gwf_gwf_bdsav - + !> @ brief Output !! !! Write output @@ -1244,21 +1249,21 @@ subroutine gwf_gwf_ot(this) use SimVariablesModule, only: iout use ConstantsModule, only: DZERO, LINELENGTH ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: iexg, n1, n2 integer(I4B) :: ibudfl real(DP) :: flow, deltaqgnc character(len=LINELENGTH) :: node1str, node2str ! -- format - character(len=*), parameter :: fmtheader = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + character(len=*), parameter :: fmtheader = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & &2a16, 5a16, /, 112('-'))" - character(len=*), parameter :: fmtheader2 = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + character(len=*), parameter :: fmtheader2 = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & &2a16, 4a16, /, 96('-'))" - character(len=*), parameter :: fmtdata = & - "(2a16, 5(1pg16.6))" + character(len=*), parameter :: fmtdata = & + "(2a16, 5(1pg16.6))" ! ! -- Call bdsave call this%gwf_gwf_bdsav() @@ -1267,39 +1272,39 @@ subroutine gwf_gwf_ot(this) deltaqgnc = DZERO ! ! -- Write a table of exchanges - if(this%iprflow /= 0) then - if(this%ingnc > 0) then - write(iout, fmtheader) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'DELTAQGNC', & - 'FLOW' + if (this%iprflow /= 0) then + if (this%ingnc > 0) then + write (iout, fmtheader) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'DELTAQGNC', & + 'FLOW' else - write(iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' - endif + write (iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' + end if do iexg = 1, this%nexg n1 = this%nodem1(iexg) n2 = this%nodem2(iexg) flow = this%simvals(iexg) call this%gwfmodel1%dis%noder_to_string(n1, node1str) call this%gwfmodel2%dis%noder_to_string(n2, node2str) - if(this%ingnc > 0) then + if (this%ingnc > 0) then deltaqgnc = this%gnc%deltaqgnc(iexg) - write(iout, fmtdata) trim(adjustl(node1str)), & - trim(adjustl(node2str)), & - this%cond(iexg), this%gwfmodel1%x(n1), & - this%gwfmodel2%x(n2), deltaqgnc, flow + write (iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%gwfmodel1%x(n1), & + this%gwfmodel2%x(n2), deltaqgnc, flow else - write(iout, fmtdata) trim(adjustl(node1str)), & - trim(adjustl(node2str)), & - this%cond(iexg), this%gwfmodel1%x(n1), & - this%gwfmodel2%x(n2), flow - endif - enddo - endif + write (iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%gwfmodel1%x(n1), & + this%gwfmodel2%x(n2), flow + end if + end do + end if ! ! -- Mover budget output ibudfl = 1 - if(this%inmvr > 0) call this%mvr%mvr_ot_bdsummary(ibudfl) + if (this%inmvr > 0) call this%mvr%mvr_ot_bdsummary(ibudfl) ! ! -- OBS output call this%obs%obs_ot() @@ -1316,24 +1321,24 @@ end subroutine gwf_gwf_ot subroutine read_options(this, iout) ! -- modules use ConstantsModule, only: LINELENGTH, LENAUXNAME, DEM6 - use MemoryManagerModule, only: mem_allocate + use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: iout ! -- local character(len=LINELENGTH) :: keyword logical :: isfound - logical :: endOfBlock + logical :: endOfBlock integer(I4B) :: ierr ! ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING GWF-GWF EXCHANGE OPTIONS' + write (iout, '(1x,a)') 'PROCESSING GWF-GWF EXCHANGE OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) then @@ -1352,12 +1357,12 @@ subroutine read_options(this, iout) end if ! unknown option - errmsg = "Unknown GWF-GWF exchange option '" // trim(keyword) // "'." + errmsg = "Unknown GWF-GWF exchange option '"//trim(keyword)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end do - write(iout,'(1x,a)') 'END OF GWF-GWF EXCHANGE OPTIONS' + write (iout, '(1x,a)') 'END OF GWF-GWF EXCHANGE OPTIONS' end if ! ! -- set omega value used for saturation calculations @@ -1373,11 +1378,11 @@ end subroutine read_options !< function parse_option(this, keyword, iout) result(parsed) use InputOutputModule, only: getunit, openfile - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType character(len=LINELENGTH), intent(in) :: keyword !< the option name - integer(I4B), intent(in) :: iout !< for logging - logical(LGP) :: parsed !< true when parsed - ! local + integer(I4B), intent(in) :: iout !< for logging + logical(LGP) :: parsed !< true when parsed + ! local character(len=LINELENGTH) :: fname integer(I4B) :: inobs character(len=LINELENGTH) :: subkey @@ -1387,80 +1392,80 @@ function parse_option(this, keyword, iout) result(parsed) select case (keyword) case ('PRINT_FLOWS') this%iprflow = 1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' case ('SAVE_FLOWS') this%ipakcb = -1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'EXCHANGE FLOWS WILL BE SAVED TO BINARY BUDGET FILES.' case ('ALTERNATIVE_CELL_AVERAGING') call this%parser%GetStringCaps(subkey) - select case(subkey) - case('LOGARITHMIC') + select case (subkey) + case ('LOGARITHMIC') this%icellavg = 1 - case('AMT-LMK') + case ('AMT-LMK') this%icellavg = 2 case default - errmsg = "Unknown cell averaging method '" // trim(subkey) // "'." + errmsg = "Unknown cell averaging method '"//trim(subkey)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end select - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(subkey) case ('VARIABLECV') this%ivarcv = 1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'VERTICAL CONDUCTANCE VARIES WITH WATER TABLE.' call this%parser%GetStringCaps(subkey) - if(subkey == 'DEWATERED') then + if (subkey == 'DEWATERED') then this%idewatcv = 1 - write(iout,'(4x,a)') & - 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF ' // & + write (iout, '(4x,a)') & + 'VERTICAL CONDUCTANCE ACCOUNTS FOR DEWATERED PORTION OF '// & 'AN UNDERLYING CELL.' - endif + end if case ('NEWTON') this%inewton = 1 - write(iout, '(4x,a)') & - 'NEWTON-RAPHSON method used for unconfined cells' + write (iout, '(4x,a)') & + 'NEWTON-RAPHSON method used for unconfined cells' case ('GNC6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('GNC6 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('GNC6 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetString(fname) - if(fname == '') then + if (fname == '') then call store_error('NO GNC6 FILE SPECIFIED.') call this%parser%StoreErrorUnit() - endif + end if this%ingnc = getunit() call openfile(this%ingnc, iout, fname, 'GNC') - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'GHOST NODES WILL BE READ FROM ', trim(fname) case ('MVR6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('MVR6 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('MVR6 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetString(fname) - if(fname == '') then + if (fname == '') then call store_error('NO MVR6 FILE SPECIFIED.') call this%parser%StoreErrorUnit() - endif + end if this%inmvr = getunit() call openfile(this%inmvr, iout, fname, 'MVR') - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'WATER MOVER INFORMATION WILL BE READ FROM ', trim(fname) case ('OBS6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if this%obs%active = .true. call this%parser%GetString(this%obs%inputFilename) inobs = GetUnit() @@ -1471,10 +1476,10 @@ function parse_option(this, keyword, iout) result(parsed) end select end function parse_option - + !> @ brief Read ghost nodes !! - !! Read and process ghost nodes + !! Read and process ghost nodes !! !< subroutine read_gnc(this) @@ -1482,54 +1487,55 @@ subroutine read_gnc(this) use SimModule, only: store_error, store_error_unit, count_errors use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: i, nm1, nm2, nmgnc1, nmgnc2 character(len=*), parameter :: fmterr = & - "('EXCHANGE NODES ', i0, ' AND ', i0," // & - "' NOT CONSISTENT WITH GNC NODES ', i0, ' AND ', i0)" + "('EXCHANGE NODES ', i0, ' AND ', i0,"// & + "' NOT CONSISTENT WITH GNC NODES ', "// & + "i0, ' AND ', i0)" ! ! -- If exchange has ghost nodes, then initialize ghost node object ! This will read the ghost node blocks from the gnc input file. call this%gnc%gnc_df(this%gwfmodel1, m2=this%gwfmodel2) ! ! -- Verify gnc is implicit if exchange has Newton Terms - if(.not. this%gnc%implicit .and. this%inewton /= 0) then + if (.not. this%gnc%implicit .and. this%inewton /= 0) then call store_error('GNC IS EXPLICIT, BUT GWF EXCHANGE HAS ACTIVE NEWTON.') - call store_error('ADD IMPLICIT OPTION TO GNC OR REMOVE NEWTON FROM ' // & - 'GWF EXCHANGE.') + call store_error('ADD IMPLICIT OPTION TO GNC OR REMOVE NEWTON FROM '// & + 'GWF EXCHANGE.') call store_error_unit(this%ingnc) - endif + end if ! ! -- Perform checks to ensure GNCs match with GWF-GWF nodes - if(this%nexg /= this%gnc%nexg) then + if (this%nexg /= this%gnc%nexg) then call store_error('NUMBER OF EXCHANGES DOES NOT MATCH NUMBER OF GNCs') call store_error_unit(this%ingnc) - endif + end if ! ! -- Go through each entry and confirm do i = 1, this%nexg - if(this%nodem1(i) /= this%gnc%nodem1(i) .or. & - this%nodem2(i) /= this%gnc%nodem2(i) ) then + if (this%nodem1(i) /= this%gnc%nodem1(i) .or. & + this%nodem2(i) /= this%gnc%nodem2(i)) then nm1 = this%gwfmodel1%dis%get_nodeuser(this%nodem1(i)) nm2 = this%gwfmodel2%dis%get_nodeuser(this%nodem2(i)) nmgnc1 = this%gwfmodel1%dis%get_nodeuser(this%gnc%nodem1(i)) nmgnc2 = this%gwfmodel2%dis%get_nodeuser(this%gnc%nodem2(i)) - write(errmsg, fmterr) nm1, nm2, nmgnc1, nmgnc2 + write (errmsg, fmterr) nm1, nm2, nmgnc1, nmgnc2 call store_error(errmsg) - endif - enddo - if(count_errors() > 0) then + end if + end do + if (count_errors() > 0) then call store_error_unit(this%ingnc) - endif + end if ! ! -- close the file - close(this%ingnc) + close (this%ingnc) ! ! -- return return end subroutine read_gnc - + !> @ brief Read mover !! !! Read and process movers @@ -1539,23 +1545,23 @@ subroutine read_mvr(this, iout) ! -- modules use GwfMvrModule, only: mvr_cr ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: iout ! -- local ! ! -- Create and initialize the mover object Here, dis is set to the one ! for gwfmodel1 so that a call to save flows has an associated dis ! object. Because the conversion flags for the mover are both false, - ! the dis object does not convert from reduced to user node numbers. + ! the dis object does not convert from reduced to user node numbers. ! So in this case, the dis object is just writing unconverted package ! numbers to the binary budget file. - call mvr_cr(this%mvr, this%name, this%inmvr, iout, this%gwfmodel1%dis, & + call mvr_cr(this%mvr, this%name, this%inmvr, iout, this%gwfmodel1%dis, & iexgmvr=1) ! ! -- Return return end subroutine read_mvr - + !> @ brief Rewet !! !! Check if rewetting should propagate from one model to another @@ -1565,7 +1571,7 @@ subroutine rewet(this, kiter) ! -- modules use TdisModule, only: kper, kstp ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: kiter ! -- local integer(I4B) :: iexg @@ -1575,8 +1581,8 @@ subroutine rewet(this, kiter) real(DP) :: hn, hm integer(I4B) :: irewet character(len=30) :: nodestrn, nodestrm - character(len=*),parameter :: fmtrwt = & - "(1x, 'CELL ',A,' REWET FROM GWF MODEL ',A,' CELL ',A, & + character(len=*), parameter :: fmtrwt = & + "(1x, 'CELL ',A,' REWET FROM GWF MODEL ',A,' CELL ',A, & &' FOR ITER. ',I0, ' STEP ',I0, ' PERIOD ', I0)" ! ! -- Use model 1 to rewet model 2 and vice versa @@ -1588,29 +1594,29 @@ subroutine rewet(this, kiter) ibdn = this%gwfmodel1%ibound(n) ibdm = this%gwfmodel2%ibound(m) ihc = this%ihc(iexg) - call this%gwfmodel1%npf%rewet_check(kiter, n, hm, ibdm, ihc, & - this%gwfmodel1%x, irewet) - if(irewet == 1) then + call this%gwfmodel1%npf%rewet_check(kiter, n, hm, ibdm, ihc, & + this%gwfmodel1%x, irewet) + if (irewet == 1) then call this%gwfmodel1%dis%noder_to_string(n, nodestrn) call this%gwfmodel2%dis%noder_to_string(m, nodestrm) - write(this%gwfmodel1%iout, fmtrwt) trim(nodestrn), & + write (this%gwfmodel1%iout, fmtrwt) trim(nodestrn), & trim(this%gwfmodel2%name), trim(nodestrm), kiter, kstp, kper - endif - call this%gwfmodel2%npf%rewet_check(kiter, m, hn, ibdn, ihc, & - this%gwfmodel2%x, irewet) - if(irewet == 1) then + end if + call this%gwfmodel2%npf%rewet_check(kiter, m, hn, ibdn, ihc, & + this%gwfmodel2%x, irewet) + if (irewet == 1) then call this%gwfmodel1%dis%noder_to_string(n, nodestrm) call this%gwfmodel2%dis%noder_to_string(m, nodestrn) - write(this%gwfmodel2%iout, fmtrwt) trim(nodestrn), & + write (this%gwfmodel2%iout, fmtrwt) trim(nodestrn), & trim(this%gwfmodel1%name), trim(nodestrm), kiter, kstp, kper - endif + end if ! - enddo + end do ! ! -- Return return end subroutine rewet - + !> @ brief Calculate the conductance !! !! Calculate the conductance based on state @@ -1621,7 +1627,7 @@ subroutine condcalc(this) use ConstantsModule, only: DHALF, DZERO, DONE use GwfNpfModule, only: hcond, vcond ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: iexg integer(I4B) :: n, m, ihc @@ -1656,7 +1662,7 @@ subroutine condcalc(this) hm = this%gwfmodel2%x(m) ! ! -- Calculate conductance depending on connection orientation - if(ihc == 0) then + if (ihc == 0) then ! ! -- Vertical connection vg(1) = DZERO @@ -1664,8 +1670,8 @@ subroutine condcalc(this) vg(3) = DONE hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - cond = vcond(ibdn, ibdm, ictn, ictm, this%inewton, this%ivarcv, & - this%idewatcv, this%condsat(iexg), hn, hm, hyn, hym, & + cond = vcond(ibdn, ibdm, ictn, ictm, this%inewton, this%ivarcv, & + this%idewatcv, this%condsat(iexg), hn, hm, hyn, hym, & satn, satm, topn, topm, botn, botm, this%hwva(iexg)) else ! @@ -1674,33 +1680,33 @@ subroutine condcalc(this) hym = this%gwfmodel2%npf%k11(m) ! ! -- Check for anisotropy in models, and recalculate hyn and hym - if(this%ianglex > 0) then + if (this%ianglex > 0) then angle = this%auxvar(this%ianglex, iexg) vg(1) = abs(cos(angle)) vg(2) = abs(sin(angle)) vg(3) = DZERO ! ! -- anisotropy in model 1 - if(this%gwfmodel1%npf%ik22 /= 0) then + if (this%gwfmodel1%npf%ik22 /= 0) then hyn = this%gwfmodel1%npf%hy_eff(n, 0, ihc, vg=vg) - endif + end if ! ! -- anisotropy in model 2 - if(this%gwfmodel2%npf%ik22 /= 0) then + if (this%gwfmodel2%npf%ik22 /= 0) then hym = this%gwfmodel2%npf%hy_eff(m, 0, ihc, vg=vg) - endif - endif + end if + end if ! fawidth = this%hwva(iexg) - cond = hcond(ibdn, ibdm, ictn, ictm, this%inewton, this%inewton, & - this%ihc(iexg), this%icellavg, 0, 0, this%condsat(iexg), & - hn, hm, satn, satm, hyn, hym, topn, topm, botn, botm, & + cond = hcond(ibdn, ibdm, ictn, ictm, this%inewton, this%inewton, & + this%ihc(iexg), this%icellavg, 0, 0, this%condsat(iexg), & + hn, hm, satn, satm, hyn, hym, topn, topm, botn, botm, & this%cl1(iexg), this%cl2(iexg), fawidth, this%satomega) - endif + end if ! this%cond(iexg) = cond ! - enddo + end do ! ! -- Return return @@ -1716,7 +1722,7 @@ subroutine allocate_scalars(this) use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local ! call this%DisConnExchangeType%allocate_scalars() @@ -1730,7 +1736,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%icellavg, 'ICELLAVG', this%memoryPath) call mem_allocate(this%ivarcv, 'IVARCV', this%memoryPath) call mem_allocate(this%idewatcv, 'IDEWATCV', this%memoryPath) - call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) + call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) call mem_allocate(this%ingnc, 'INGNC', this%memoryPath) call mem_allocate(this%inmvr, 'INMVR', this%memoryPath) call mem_allocate(this%inobs, 'INOBS', this%memoryPath) @@ -1738,7 +1744,7 @@ subroutine allocate_scalars(this) this%icellavg = 0 this%ivarcv = 0 this%idewatcv = 0 - this%inewton = 0 + this%inewton = 0 this%ingnc = 0 this%inmvr = 0 this%inobs = 0 @@ -1757,23 +1763,23 @@ subroutine gwf_gwf_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local ! ! -- objects - if(this%ingnc > 0) then + if (this%ingnc > 0) then call this%gnc%gnc_da() - deallocate(this%gnc) - endif + deallocate (this%gnc) + end if if (this%inmvr > 0) then call this%mvr%mvr_da() - deallocate(this%mvr) - endif + deallocate (this%mvr) + end if call this%obs%obs_da() - deallocate(this%obs) + deallocate (this%obs) ! ! -- arrays - call mem_deallocate(this%cond) + call mem_deallocate(this%cond) call mem_deallocate(this%condsat) call mem_deallocate(this%idxglo) call mem_deallocate(this%idxsymglo) @@ -1782,17 +1788,17 @@ subroutine gwf_gwf_da(this) ! -- output table objects if (associated(this%outputtab1)) then call this%outputtab1%table_da() - deallocate(this%outputtab1) - nullify(this%outputtab1) + deallocate (this%outputtab1) + nullify (this%outputtab1) end if if (associated(this%outputtab2)) then call this%outputtab2%table_da() - deallocate(this%outputtab2) - nullify(this%outputtab2) + deallocate (this%outputtab2) + nullify (this%outputtab2) end if ! - ! -- scalars - deallocate(this%filename) + ! -- scalars + deallocate (this%filename) call mem_deallocate(this%iprflow) call mem_deallocate(this%ipakcb) ! @@ -1811,7 +1817,7 @@ subroutine gwf_gwf_da(this) ! -- return return end subroutine gwf_gwf_da - + !> @ brief Allocate arrays !! !! Allocate arrays @@ -1821,16 +1827,16 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local character(len=LINELENGTH) :: text integer(I4B) :: ntabcol, i ! call this%DisConnExchangeType%allocate_arrays() - ! + ! call mem_allocate(this%cond, this%nexg, 'COND', this%memoryPath) call mem_allocate(this%idxglo, this%nexg, 'IDXGLO', this%memoryPath) - call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', this%memoryPath) ! + call mem_allocate(this%idxsymglo, this%nexg, 'IDXSYMGLO', this%memoryPath) ! call mem_allocate(this%condsat, this%nexg, 'CONDSAT', this%memoryPath) call mem_allocate(this%simvals, this%nexg, 'SIMVALS', this%memoryPath) ! @@ -1851,7 +1857,7 @@ subroutine allocate_arrays(this) ! -- initialize the output table objects ! outouttab1 call table_cr(this%outputtab1, this%name, ' ') - call this%outputtab1%table_df(this%nexg, ntabcol, this%gwfmodel1%iout, & + call this%outputtab1%table_df(this%nexg, ntabcol, this%gwfmodel1%iout, & transient=.TRUE.) text = 'NUMBER' call this%outputtab1%initialize_column(text, 10, alignment=TABCENTER) @@ -1865,7 +1871,7 @@ subroutine allocate_arrays(this) end if ! outouttab2 call table_cr(this%outputtab2, this%name, ' ') - call this%outputtab2%table_df(this%nexg, ntabcol, this%gwfmodel2%iout, & + call this%outputtab2%table_df(this%nexg, ntabcol, this%gwfmodel2%iout, & transient=.TRUE.) text = 'NUMBER' call this%outputtab2%initialize_column(text, 10, alignment=TABCENTER) @@ -1890,7 +1896,7 @@ end subroutine allocate_arrays !< subroutine gwf_gwf_df_obs(this) ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: indx ! @@ -1902,7 +1908,7 @@ subroutine gwf_gwf_df_obs(this) ! -- return return end subroutine gwf_gwf_df_obs - + !> @ brief Read and prepare observations !! !! Handle observation exchanges exchange-boundary names. @@ -1912,7 +1918,7 @@ subroutine gwf_gwf_rp_obs(this) ! -- modules use ConstantsModule, only: DZERO ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: i integer(I4B) :: j @@ -1920,15 +1926,15 @@ subroutine gwf_gwf_rp_obs(this) character(len=LENBOUNDNAME) :: bname logical :: jfound ! -- formats -10 format('Exchange "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') -20 format('Exchange id "',i0,'" for observation "',a, & - '" is invalid in package "',a,'"') +10 format('Exchange "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') +20 format('Exchange id "', i0, '" for observation "', a, & + '" is invalid in package "', a, '"') ! do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv ! - ! -- indxbnds needs to be reset each stress period because + ! -- indxbnds needs to be reset each stress period because ! list of boundaries can change each stress period. ! -- Not true for exchanges, but leave this in for now anyway. call obsrv%ResetObsIndex() @@ -1940,18 +1946,18 @@ subroutine gwf_gwf_rp_obs(this) ! Iterate through all boundaries to identify and store ! corresponding index(indices) in bound array. jfound = .false. - do j=1,this%nexg + do j = 1, this%nexg if (this%boundname(j) == bname) then jfound = .true. obsrv%BndFound = .true. obsrv%CurrentTimeStepEndValue = DZERO call obsrv%AddObsIndex(j) - endif - enddo + end if + end do if (.not. jfound) then - write(errmsg, 10) trim(bname), trim(obsrv%ObsTypeId) , trim(this%name) + write (errmsg, 10) trim(bname), trim(obsrv%ObsTypeId), trim(this%name) call store_error(errmsg) - endif + end if else ! -- Observation location is a single exchange number if (obsrv%intPak1 <= this%nexg .and. obsrv%intPak1 > 0) then @@ -1961,23 +1967,23 @@ subroutine gwf_gwf_rp_obs(this) call obsrv%AddObsIndex(obsrv%intPak1) else jfound = .false. - endif + end if if (.not. jfound) then - write(errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId) , trim(this%name) + write (errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId), trim(this%name) call store_error(errmsg) - endif - endif - enddo + end if + end if + end do ! ! -- write summary of error messages if (count_errors() > 0) then call store_error_unit(this%inobs) - endif + end if ! ! -- Return return end subroutine gwf_gwf_rp_obs - + !> @ brief Final processing !! !! Conduct any final processing @@ -1985,11 +1991,11 @@ end subroutine gwf_gwf_rp_obs !< subroutine gwf_gwf_fp(this) ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! return end subroutine gwf_gwf_fp - + !> @ brief Calculate flow !! !! Calculate the flow for the specified exchange and node numbers @@ -1999,7 +2005,7 @@ function qcalc(this, iexg, n1, n2) ! -- return real(DP) :: qcalc ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType integer(I4B), intent(in) :: iexg integer(I4B), intent(in) :: n1 integer(I4B), intent(in) :: n2 @@ -2018,9 +2024,9 @@ end function qcalc !! coefficient matrix to be asymmetric. !! !< - function gwf_gwf_get_iasym(this) result (iasym) + function gwf_gwf_get_iasym(this) result(iasym) ! -- dummy - class(GwfExchangeType) :: this !< GwfExchangeType + class(GwfExchangeType) :: this !< GwfExchangeType ! -- local integer(I4B) :: iasym ! @@ -2033,29 +2039,29 @@ function gwf_gwf_get_iasym(this) result (iasym) ! -- GNC if (this%ingnc > 0) then if (this%gnc%iasym /= 0) iasym = 1 - endif + end if ! ! -- return return end function gwf_gwf_get_iasym - !> @brief Return true when this exchange provides matrix + !> @brief Return true when this exchange provides matrix !! coefficients for solving @param model !< function gwf_gwf_connects_model(this, model) result(is_connected) - class(GwfExchangeType) :: this !< GwfExchangeType - class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection - logical(LGP) :: is_connected !< true, when connected + class(GwfExchangeType) :: this !< GwfExchangeType + class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection + logical(LGP) :: is_connected !< true, when connected is_connected = .false. ! only connected when model is GwfModelType of course - select type(model) - class is (GwfModelType) - if (associated(this%gwfmodel1, model)) then - is_connected = .true. - else if (associated(this%gwfmodel2, model)) then - is_connected = .true. - end if + select type (model) + class is (GwfModelType) + if (associated(this%gwfmodel1, model)) then + is_connected = .true. + else if (associated(this%gwfmodel2, model)) then + is_connected = .true. + end if end select end function gwf_gwf_connects_model @@ -2064,10 +2070,10 @@ end function gwf_gwf_connects_model !< function use_interface_model(this) result(useIM) class(GwfExchangeType) :: this !< GwfExchangeType - logical(LGP) :: useIM !< true when interface model should be used - + logical(LGP) :: useIM !< true when interface model should be used + useIM = (this%ixt3d > 0) - + end function !> @ brief Save simulated flow observations @@ -2096,7 +2102,7 @@ subroutine gwf_gwf_save_simvals(this) call this%obs%obs_bd_clear() do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv - do j = 1, obsrv%indxbnds_count + do j = 1, obsrv%indxbnds_count iexg = obsrv%indxbnds(j) v = DZERO select case (obsrv%ObsTypeId) @@ -2105,15 +2111,15 @@ subroutine gwf_gwf_save_simvals(this) n2 = this%nodem2(iexg) v = this%simvals(iexg) case default - msg = 'Error: Unrecognized observation type: ' // & + msg = 'Error: Unrecognized observation type: '// & trim(obsrv%ObsTypeId) call store_error(msg) call store_error_unit(this%inobs) end select call this%obs%SaveOneSimval(obsrv, v) - enddo - enddo - endif + end do + end do + end if ! return end subroutine gwf_gwf_save_simvals @@ -2130,10 +2136,10 @@ subroutine gwf_gwf_process_obsID(obsrv, dis, inunitobs, iout) use ObserveModule, only: ObserveType use BaseDisModule, only: DisBaseType ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: n, iexg, istat integer(I4B) :: icol, istart, istop @@ -2155,7 +2161,7 @@ subroutine gwf_gwf_process_obsID(obsrv, dis, inunitobs, iout) ! boundaries, so assign intPak1 as a value that indicates observation ! is for a named exchange boundary or group of exchange boundaries. obsrv%intPak1 = NAMEDBOUNDFLAG - endif + end if ! return end subroutine gwf_gwf_process_obsID @@ -2165,7 +2171,7 @@ end subroutine gwf_gwf_process_obsID !! Cast polymorphic object as exchange !! !< - function CastAsGwfExchange(obj) result (res) + function CastAsGwfExchange(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj class(GwfExchangeType), pointer :: res @@ -2185,12 +2191,12 @@ end function CastAsGwfExchange !! Return an exchange from the list for specified index !! !< - function GetGwfExchangeFromList(list, idx) result (res) + function GetGwfExchangeFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(GwfExchangeType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(GwfExchangeType), pointer :: res ! -- local class(*), pointer :: obj ! @@ -2200,7 +2206,5 @@ function GetGwfExchangeFromList(list, idx) result (res) return end function GetGwfExchangeFromList - - end module GwfGwfExchangeModule diff --git a/src/Exchange/GwfGwtExchange.f90 b/src/Exchange/GwfGwtExchange.f90 index fde442a6a80..f1780be7158 100644 --- a/src/Exchange/GwfGwtExchange.f90 +++ b/src/Exchange/GwfGwtExchange.f90 @@ -1,34 +1,33 @@ module GwfGwtExchangeModule - use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LENPACKAGENAME - use ListsModule, only: basemodellist, baseexchangelist, & - baseconnectionlist - use SimModule, only: store_error - use SimVariablesModule, only: errmsg - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use SpatialModelConnectionModule, only: SpatialModelConnectionType, & + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: LENPACKAGENAME + use ListsModule, only: basemodellist, baseexchangelist, & + baseconnectionlist + use SimModule, only: store_error + use SimVariablesModule, only: errmsg + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use SpatialModelConnectionModule, only: SpatialModelConnectionType, & GetSpatialModelConnectionFromList - use GwtGwtConnectionModule, only: GwtGwtConnectionType, CastAsGwtGwtConnection - use GwfGwfConnectionModule, only: GwfGwfConnectionType, CastAsGwfGwfConnection - use GwfGwfExchangeModule, only: GwfExchangeType, & - GetGwfExchangeFromList - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use GwfModule, only: GwfModelType - use GwtModule, only: GwtModelType - use BndModule, only: BndType, GetBndFromList - - + use GwtGwtConnectionModule, only: GwtGwtConnectionType, CastAsGwtGwtConnection + use GwfGwfConnectionModule, only: GwfGwfConnectionType, CastAsGwfGwfConnection + use GwfGwfExchangeModule, only: GwfExchangeType, & + GetGwfExchangeFromList + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use GwfModule, only: GwfModelType + use GwtModule, only: GwtModelType + use BndModule, only: BndType, GetBndFromList + implicit none public :: GwfGwtExchangeType public :: gwfgwt_cr - + type, extends(BaseExchangeType) :: GwfGwtExchangeType integer(I4B), pointer :: m1id => null() integer(I4B), pointer :: m2id => null() contains - + procedure :: exg_df procedure :: exg_ar procedure :: exg_da @@ -37,11 +36,11 @@ module GwfGwtExchangeModule procedure, private :: gwfbnd2gwtfmi procedure, private :: gwfconn2gwtconn procedure, private :: link_connections - + end type GwfGwtExchangeType - - contains - + +contains + subroutine gwfgwt_cr(filename, id, m1id, m2id) ! ****************************************************************************** ! gwfgwt_cr -- Create a new GWF to GWT exchange object @@ -62,14 +61,14 @@ subroutine gwfgwt_cr(filename, id, m1id, m2id) ! ------------------------------------------------------------------------------ ! ! -- Create a new exchange and add it to the baseexchangelist container - allocate(exchange) + allocate (exchange) baseexchange => exchange call AddBaseExchangeToList(baseexchangelist, baseexchange) ! ! -- Assign id and name exchange%id = id - write(cint, '(i0)') id - exchange%name = 'GWF-GWT_' // trim(adjustl(cint)) + write (cint, '(i0)') id + exchange%name = 'GWF-GWT_'//trim(adjustl(cint)) exchange%memoryPath = exchange%name ! ! -- allocate scalars @@ -83,7 +82,7 @@ subroutine gwfgwt_cr(filename, id, m1id, m2id) ! -- return return end subroutine gwfgwt_cr - + subroutine set_model_pointers(this) ! ****************************************************************************** ! set_model_pointers -- allocate and read @@ -118,14 +117,14 @@ subroutine set_model_pointers(this) ! ! -- Verify that gwf model is of the correct type if (.not. associated(gwfmodel)) then - write(errmsg, '(3a)') 'Problem with GWF-GWT exchange ', trim(this%name), & + write (errmsg, '(3a)') 'Problem with GWF-GWT exchange ', trim(this%name), & '. Specified GWF Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) end if ! ! -- Verify that gwt model is of the correct type if (.not. associated(gwtmodel)) then - write(errmsg, '(3a)') 'Problem with GWF-GWT exchange ', trim(this%name), & + write (errmsg, '(3a)') 'Problem with GWF-GWT exchange ', trim(this%name), & '. Specified GWF Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) end if @@ -140,7 +139,7 @@ subroutine set_model_pointers(this) ! -- return return end subroutine set_model_pointers - + subroutine exg_df(this) ! ****************************************************************************** ! exg_df -- define @@ -175,7 +174,7 @@ subroutine exg_df(this) ! -- Set pointer to flowja gwtmodel%fmi%gwfflowja => gwfmodel%flowja ! - ! -- Set the npf flag so that specific discharge is available for + ! -- Set the npf flag so that specific discharge is available for ! transport calculations if dispersion is active if (gwtmodel%indsp > 0) then gwfmodel%npf%icalcspdis = 1 @@ -184,10 +183,10 @@ subroutine exg_df(this) ! -- return return end subroutine exg_df - + subroutine exg_ar(this) ! ****************************************************************************** -! exg_ar -- +! exg_ar -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -200,7 +199,7 @@ subroutine exg_ar(this) type(GwfModelType), pointer :: gwfmodel => null() type(GwtModelType), pointer :: gwtmodel => null() ! -- formats - character(len=*),parameter :: fmtdiserr = & + character(len=*), parameter :: fmtdiserr = & "('GWF and GWT Models do not have the same discretization for exchange& & ',a,'.& & GWF Model has ', i0, ' user nodes and ', i0, ' reduced nodes.& @@ -223,39 +222,39 @@ subroutine exg_ar(this) end select ! ! -- Check to make sure sizes are identical - if (gwtmodel%dis%nodes /= gwfmodel%dis%nodes .or.& + if (gwtmodel%dis%nodes /= gwfmodel%dis%nodes .or. & gwtmodel%dis%nodesuser /= gwfmodel%dis%nodesuser) then - write(errmsg, fmtdiserr) trim(this%name), & - gwfmodel%dis%nodesuser, & - gwfmodel%dis%nodes, & - gwtmodel%dis%nodesuser, & - gwtmodel%dis%nodes + write (errmsg, fmtdiserr) trim(this%name), & + gwfmodel%dis%nodesuser, & + gwfmodel%dis%nodes, & + gwtmodel%dis%nodesuser, & + gwtmodel%dis%nodes call store_error(errmsg, terminate=.TRUE.) end if ! ! -- setup pointers to gwf variables allocated in gwf_ar - gwtmodel%fmi%gwfhead => gwfmodel%x - gwtmodel%fmi%gwfsat => gwfmodel%npf%sat - gwtmodel%fmi%gwfspdis => gwfmodel%npf%spdis + gwtmodel%fmi%gwfhead => gwfmodel%x + gwtmodel%fmi%gwfsat => gwfmodel%npf%sat + gwtmodel%fmi%gwfspdis => gwfmodel%npf%spdis ! ! -- setup pointers to the flow storage rates. GWF strg arrays are ! available after the gwf_ar routine is called. - if(gwtmodel%inmst > 0) then + if (gwtmodel%inmst > 0) then if (gwfmodel%insto > 0) then gwtmodel%fmi%gwfstrgss => gwfmodel%sto%strgss gwtmodel%fmi%igwfstrgss = 1 if (gwfmodel%sto%iusesy == 1) then gwtmodel%fmi%gwfstrgsy => gwfmodel%sto%strgsy gwtmodel%fmi%igwfstrgsy = 1 - endif - endif - endif + end if + end if + end if ! ! -- Set a pointer to conc if (gwfmodel%inbuy > 0) then call gwfmodel%buy%set_concentration_pointer(gwtmodel%name, gwtmodel%x, & gwtmodel%ibound) - endif + end if ! ! -- transfer the boundary package information from gwf to gwt call this%gwfbnd2gwtfmi() @@ -271,17 +270,17 @@ subroutine exg_ar(this) ! -- return return end subroutine exg_ar - + !> @brief Link GWT connections to GWF connections or exchanges !< subroutine gwfconn2gwtconn(this, gwfModel, gwtModel) use SimModule, only: store_error use SimVariablesModule, only: iout - class(GwfGwtExchangeType) :: this !< this exchange + class(GwfGwtExchangeType) :: this !< this exchange type(GwfModelType), pointer :: gwfModel !< the flow model type(GwtModelType), pointer :: gwtModel !< the transport model - ! local - class(SpatialModelConnectionType), pointer :: conn => null() + ! local + class(SpatialModelConnectionType), pointer :: conn => null() class(*), pointer :: objPtr => null() class(GwtGwtConnectionType), pointer :: gwtConn => null() class(GwfGwfConnectionType), pointer :: gwfConn => null() @@ -293,7 +292,7 @@ subroutine gwfconn2gwtconn(this, gwfModel, gwtModel) ! loop over all connections gwtloop: do ic1 = 1, baseconnectionlist%Count() - conn => GetSpatialModelConnectionFromList(baseconnectionlist,ic1) + conn => GetSpatialModelConnectionFromList(baseconnectionlist, ic1) if (.not. associated(conn%owner, gwtModel)) cycle gwtloop ! start with a GWT conn. @@ -304,25 +303,25 @@ subroutine gwfconn2gwtconn(this, gwfModel, gwtModel) ! find matching GWF conn. in same list gwfloop: do ic2 = 1, baseconnectionlist%Count() - conn => GetSpatialModelConnectionFromList(baseconnectionlist,ic2) - + conn => GetSpatialModelConnectionFromList(baseconnectionlist, ic2) + if (associated(conn%owner, gwfModel)) then objPtr => conn - gwfConn => CastAsGwfGwfConnection(objPtr) + gwfConn => CastAsGwfGwfConnection(objPtr) - ! for now, connecting the same nodes nrs will be + ! for now, connecting the same nodes nrs will be ! sufficient evidence of equality - areEqual = all(gwfConn%primaryExchange%nodem1 == & - gwtConn%primaryExchange%nodem1) - areEqual = areEqual .and. all(gwfConn%primaryExchange%nodem2 == & - gwtConn%primaryExchange%nodem2) + areEqual = all(gwfConn%primaryExchange%nodem1 == & + gwtConn%primaryExchange%nodem1) + areEqual = areEqual .and. all(gwfConn%primaryExchange%nodem2 == & + gwtConn%primaryExchange%nodem2) if (areEqual) then ! same DIS, same exchange: link and go to next GWT conn. - write(iout,'(/6a)') 'Linking exchange ', & - trim(gwtConn%primaryExchange%name), & - ' to ', trim(gwfConn%primaryExchange%name), & - ' (using interface model) for GWT model ', & - trim(gwtModel%name) + write (iout, '(/6a)') 'Linking exchange ', & + trim(gwtConn%primaryExchange%name), & + ' to ', trim(gwfConn%primaryExchange%name), & + ' (using interface model) for GWT model ', & + trim(gwtModel%name) gwfConnIdx = ic2 call this%link_connections(gwtConn, gwfConn) exit gwfloop @@ -335,35 +334,36 @@ subroutine gwfconn2gwtconn(this, gwfModel, gwtModel) if (gwfConnIdx == -1) then gwfloopexg: do iex = 1, baseexchangelist%Count() gwfEx => GetGwfExchangeFromList(baseexchangelist, iex) - + ! -- There is no guarantee that iex is a gwfExg, in which case ! it will return as null. cycle if so. if (.not. associated(gwfEx)) cycle gwfloopexg - if (associated(gwfEx%model1, gwfModel) .or. & + if (associated(gwfEx%model1, gwfModel) .or. & associated(gwfEx%model2, gwfModel)) then - ! again, connecting the same nodes nrs will be + ! again, connecting the same nodes nrs will be ! sufficient evidence of equality areEqual = all(gwfEx%nodem1 == gwtConn%primaryExchange%nodem1) - areEqual = areEqual .and. & - all(gwfEx%nodem2 == gwtConn%primaryExchange%nodem2) - if (areEqual) then + areEqual = areEqual .and. & + all(gwfEx%nodem2 == gwtConn%primaryExchange%nodem2) + if (areEqual) then ! link exchange to connection - write(iout,'(/6a)') 'Linking exchange ', & - trim(gwtConn%primaryExchange%name), & - ' to ', trim(gwfEx%name), ' for GWT model ', & - trim(gwtModel%name) + write (iout, '(/6a)') 'Linking exchange ', & + trim(gwtConn%primaryExchange%name), & + ' to ', trim(gwfEx%name), ' for GWT model ', & + trim(gwtModel%name) gwfExIdx = iex gwtConn%exgflowja => gwfEx%simvals - + !cdl link up mvt to mvr if (gwfEx%inmvr > 0) then if (gwtConn%exchangeIsOwned) then !cdl todo: check and make sure gwtEx has mvt active - call gwtConn%gwtExchange%mvt%set_pointer_mvrbudobj(gwfEx%mvr%budobj) + call gwtConn%gwtExchange%mvt%set_pointer_mvrbudobj( & + gwfEx%mvr%budobj) end if end if - + if (associated(gwfEx%model2, gwfModel)) gwtConn%exgflowSign = -1 gwtConn%gwtInterfaceModel%fmi%flows_from_file = .false. @@ -371,55 +371,56 @@ subroutine gwfconn2gwtconn(this, gwfModel, gwtModel) end if end if - end do gwfloopexg end if if (gwfConnIdx == -1 .and. gwfExIdx == -1) then ! none found, report - write(errmsg, '(/6a)') 'Missing GWF-GWF exchange when connecting GWT'// & - ' model ', trim(gwtModel%name), ' with exchange ', & - trim(gwtConn%primaryExchange%name), ' to GWF model ', & - trim(gwfModel%name) + write (errmsg, '(/6a)') 'Missing GWF-GWF exchange when connecting GWT'// & + ' model ', trim(gwtModel%name), ' with exchange ', & + trim(gwtConn%primaryExchange%name), ' to GWF model ', & + trim(gwfModel%name) call store_error(errmsg, terminate=.true.) end if end do gwtloop - end subroutine gwfconn2gwtconn - + end subroutine gwfconn2gwtconn !> @brief Links a GWT connection to its GWF counterpart !< subroutine link_connections(this, gwtConn, gwfConn) - class(GwfGwtExchangeType) :: this !< this exchange + class(GwfGwtExchangeType) :: this !< this exchange class(GwtGwtConnectionType), pointer :: gwtConn !< GWT connection class(GwfGwfConnectionType), pointer :: gwfConn !< GWF connection !gwtConn%exgflowja => gwfConn%exgflowja gwtConn%exgflowja => gwfConn%gwfExchange%simvals - + !cdl link up mvt to mvr if (gwfConn%gwfExchange%inmvr > 0) then if (gwtConn%exchangeIsOwned) then !cdl todo: check and make sure gwtEx has mvt active - call gwtConn%gwtExchange%mvt%set_pointer_mvrbudobj(gwfConn%gwfExchange%mvr%budobj) + call gwtConn%gwtExchange%mvt%set_pointer_mvrbudobj( & + gwfConn%gwfExchange%mvr%budobj) end if end if - - if (associated(gwfConn%gwfExchange%model2, gwfConn%owner)) gwtConn%exgflowSign = -1 + + if (associated(gwfConn%gwfExchange%model2, gwfConn%owner)) then + gwtConn%exgflowSign = -1 + end if ! fmi flows are not read from file gwtConn%gwtInterfaceModel%fmi%flows_from_file = .false. ! set concentration pointer for buoyancy - call gwfConn%gwfInterfaceModel%buy%set_concentration_pointer( & - gwtConn%gwtModel%name, & - gwtConn%conc, & - gwtConn%icbound) + call gwfConn%gwfInterfaceModel%buy%set_concentration_pointer( & + gwtConn%gwtModel%name, & + gwtConn%conc, & + gwtConn%icbound) end subroutine link_connections - + subroutine exg_da(this) ! ****************************************************************************** ! allocate_scalars @@ -502,9 +503,9 @@ subroutine gwfbnd2gwtfmi(this) iterm = 1 do ip = 1, ngwfpack packobj => GetBndFromList(gwfmodel%bndlist, ip) - call gwtmodel%fmi%gwfpackages(iterm)%set_pointers( & - 'SIMVALS', & - packobj%memoryPath) + call gwtmodel%fmi%gwfpackages(iterm)%set_pointers( & + 'SIMVALS', & + packobj%memoryPath) iterm = iterm + 1 ! ! -- If a mover is active for this package, then establish a separate @@ -512,9 +513,9 @@ subroutine gwfbnd2gwtfmi(this) imover = packobj%imover if (packobj%isadvpak /= 0) imover = 0 if (imover /= 0) then - call gwtmodel%fmi%gwfpackages(iterm)%set_pointers( & - 'SIMTOMVR', & - packobj%memoryPath) + call gwtmodel%fmi%gwfpackages(iterm)%set_pointers( & + 'SIMTOMVR', & + packobj%memoryPath) iterm = iterm + 1 end if end do @@ -523,4 +524,4 @@ subroutine gwfbnd2gwtfmi(this) return end subroutine gwfbnd2gwtfmi -end module GwfGwtExchangeModule \ No newline at end of file +end module GwfGwtExchangeModule diff --git a/src/Exchange/GwtGwtExchange.f90 b/src/Exchange/GwtGwtExchange.f90 index e6bc50c77f2..695b4ee6d10 100644 --- a/src/Exchange/GwtGwtExchange.f90 +++ b/src/Exchange/GwtGwtExchange.f90 @@ -9,26 +9,26 @@ !< module GwtGwtExchangeModule - use KindModule, only: DP, I4B, LGP - use SimVariablesModule, only: errmsg - use SimModule, only: store_error - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & - TABCENTER, TABLEFT, LENAUXNAME, DNODATA, & - LENMODELNAME - use ListModule, only: ListType - use ListsModule, only: basemodellist - use DisConnExchangeModule, only: DisConnExchangeType - use GwtModule, only: GwtModelType - use GwtMvtModule, only: GwtMvtType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use SimModule, only: count_errors, store_error, & - store_error_unit, ustop - use SimVariablesModule, only: errmsg - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr + use KindModule, only: DP, I4B, LGP + use SimVariablesModule, only: errmsg + use SimModule, only: store_error + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & + TABCENTER, TABLEFT, LENAUXNAME, DNODATA, & + LENMODELNAME + use ListModule, only: ListType + use ListsModule, only: basemodellist + use DisConnExchangeModule, only: DisConnExchangeType + use GwtModule, only: GwtModelType + use TspMvtModule, only: TspMvtType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use SimVariablesModule, only: errmsg + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr implicit none @@ -38,7 +38,7 @@ module GwtGwtExchangeModule public :: GetGwtExchangeFromList public :: CastAsGwtExchange - !> @brief Derived type for GwtExchangeType + !> @brief Derived type for GwtExchangeType !! !! This derived type contains information and methods for !! connecting two GWT models. @@ -47,58 +47,58 @@ module GwtGwtExchangeModule type, extends(DisConnExchangeType) :: GwtExchangeType ! ! -- names of the GWF models that are connected by this exchange - character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of gwfmodel that corresponds to gwtmodel1 - character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of gwfmodel that corresponds to gwtmodel2 + character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of gwfmodel that corresponds to gwtmodel1 + character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of gwfmodel that corresponds to gwtmodel2 ! ! -- pointers to gwt models - type(GwtModelType), pointer :: gwtmodel1 => null() !< pointer to GWT Model 1 - type(GwtModelType), pointer :: gwtmodel2 => null() !< pointer to GWT Model 2 - ! - ! -- GWT specific option block: - integer(I4B), pointer :: inewton => null() !< unneeded newton flag allows for mvt to be used here - integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows - integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows - integer(I4B), pointer :: iAdvScheme !< the advection scheme at the interface: + type(GwtModelType), pointer :: gwtmodel1 => null() !< pointer to GWT Model 1 + type(GwtModelType), pointer :: gwtmodel2 => null() !< pointer to GWT Model 2 + ! + ! -- GWT specific option block: + integer(I4B), pointer :: inewton => null() !< unneeded newton flag allows for mvt to be used here + integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows + integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows + integer(I4B), pointer :: iAdvScheme !< the advection scheme at the interface: !! 0 = upstream, 1 = central, 2 = TVD ! ! -- Mover transport package - integer(I4B), pointer :: inmvt => null() !< unit number for mover transport (0 if off) - type(GwtMvtType), pointer :: mvt => null() !< water mover object + integer(I4B), pointer :: inmvt => null() !< unit number for mover transport (0 if off) + type(TspMvtType), pointer :: mvt => null() !< water mover object ! ! -- Observation package - integer(I4B), pointer :: inobs => null() !< unit number for GWT-GWT observations - type(ObsType), pointer :: obs => null() !< observation object + integer(I4B), pointer :: inobs => null() !< unit number for GWT-GWT observations + type(ObsType), pointer :: obs => null() !< observation object ! ! -- internal data - real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance - real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange + real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance + real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange ! ! -- table objects type(TableType), pointer :: outputtab1 => null() - type(TableType), pointer :: outputtab2 => null() + type(TableType), pointer :: outputtab2 => null() contains - procedure :: exg_df => gwt_gwt_df - procedure :: exg_ar => gwt_gwt_ar - procedure :: exg_rp => gwt_gwt_rp - procedure :: exg_ad => gwt_gwt_ad - procedure :: exg_fc => gwt_gwt_fc - procedure :: exg_bd => gwt_gwt_bd - procedure :: exg_ot => gwt_gwt_ot - procedure :: exg_da => gwt_gwt_da - procedure :: exg_fp => gwt_gwt_fp - procedure :: connects_model => gwt_gwt_connects_model - procedure :: use_interface_model - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: parse_option - procedure :: read_mvt - procedure :: gwt_gwt_bdsav + procedure :: exg_df => gwt_gwt_df + procedure :: exg_ar => gwt_gwt_ar + procedure :: exg_rp => gwt_gwt_rp + procedure :: exg_ad => gwt_gwt_ad + procedure :: exg_fc => gwt_gwt_fc + procedure :: exg_bd => gwt_gwt_bd + procedure :: exg_ot => gwt_gwt_ot + procedure :: exg_da => gwt_gwt_da + procedure :: exg_fp => gwt_gwt_fp + procedure :: connects_model => gwt_gwt_connects_model + procedure :: use_interface_model + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: parse_option + procedure :: read_mvt + procedure :: gwt_gwt_bdsav procedure, private :: gwt_gwt_df_obs procedure, private :: gwt_gwt_rp_obs - procedure, public :: gwt_gwt_save_simvals + procedure, public :: gwt_gwt_save_simvals procedure, private :: validate_exchange end type GwtExchangeType @@ -117,10 +117,10 @@ subroutine gwtexchange_create(filename, id, m1id, m2id) use ObsModule, only: obs_cr use MemoryHelperModule, only: create_mem_path ! -- dummy - character(len=*),intent(in) :: filename !< filename for reading - integer(I4B), intent(in) :: id !< id for the exchange - integer(I4B), intent(in) :: m1id !< id for model 1 - integer(I4B), intent(in) :: m2id !< id for model 2 + character(len=*), intent(in) :: filename !< filename for reading + integer(I4B), intent(in) :: id !< id for the exchange + integer(I4B), intent(in) :: m1id !< id for model 1 + integer(I4B), intent(in) :: m2id !< id for model 2 ! -- local type(GwtExchangeType), pointer :: exchange class(BaseModelType), pointer :: mb @@ -128,14 +128,14 @@ subroutine gwtexchange_create(filename, id, m1id, m2id) character(len=20) :: cint ! ! -- Create a new exchange and add it to the baseexchangelist container - allocate(exchange) + allocate (exchange) baseexchange => exchange call AddBaseExchangeToList(baseexchangelist, baseexchange) ! ! -- Assign id and name exchange%id = id - write(cint, '(i0)') id - exchange%name = 'GWT-GWT_' // trim(adjustl(cint)) + write (cint, '(i0)') id + exchange%name = 'GWT-GWT_'//trim(adjustl(cint)) exchange%memoryPath = create_mem_path(exchange%name) ! ! -- allocate scalars and set defaults @@ -146,7 +146,7 @@ subroutine gwtexchange_create(filename, id, m1id, m2id) exchange%ixt3d = 1 ! ! -- set gwtmodel1 - mb => GetBaseModelFromList(basemodellist, m1id) + mb => GetBaseModelFromList(basemodellist, m1id) select type (mb) type is (GwtModelType) exchange%model1 => mb @@ -163,7 +163,7 @@ subroutine gwtexchange_create(filename, id, m1id, m2id) ! ! -- Verify that gwt model1 is of the correct type if (.not. associated(exchange%gwtmodel1)) then - write(errmsg, '(3a)') 'Problem with GWT-GWT exchange ', & + write (errmsg, '(3a)') 'Problem with GWT-GWT exchange ', & trim(exchange%name), & '. First specified GWT Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) @@ -171,7 +171,7 @@ subroutine gwtexchange_create(filename, id, m1id, m2id) ! ! -- Verify that gwf model2 is of the correct type if (.not. associated(exchange%gwtmodel2)) then - write(errmsg, '(3a)') 'Problem with GWT-GWT exchange ', & + write (errmsg, '(3a)') 'Problem with GWT-GWT exchange ', & trim(exchange%name), & '. Second specified GWT Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) @@ -195,25 +195,25 @@ subroutine gwt_gwt_df(this) use InputOutputModule, only: getunit, openfile use GhostNodeModule, only: gnc_cr ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local integer(I4B) :: inunit ! ! -- open the file inunit = getunit() - write(iout,'(/a,a)') ' Creating exchange: ', this%name + write (iout, '(/a,a)') ' Creating exchange: ', this%name call openfile(inunit, iout, this%filename, 'GWT-GWT') ! call this%parser%Initialize(inunit, iout) ! ! -- Ensure models are in same solution - if(this%gwtmodel1%idsoln /= this%gwtmodel2%idsoln) then - call store_error('ERROR. TWO MODELS ARE CONNECTED ' // & - 'IN A GWT EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. ' // & - 'GWT MODELS MUST BE IN SAME SOLUTION: ' // & - trim(this%gwtmodel1%name) // ' ' // trim(this%gwtmodel2%name) ) + if (this%gwtmodel1%idsoln /= this%gwtmodel2%idsoln) then + call store_error('ERROR. TWO MODELS ARE CONNECTED IN A GWT '// & + 'EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. '// & + 'GWT MODELS MUST BE IN SAME SOLUTION: '// & + trim(this%gwtmodel1%name)//' '//trim(this%gwtmodel2%name)) call this%parser%StoreErrorUnit() - endif + end if ! ! -- read options call this%read_options(iout) @@ -228,17 +228,17 @@ subroutine gwt_gwt_df(this) call this%read_data(iout) ! ! -- Read mover information - if(this%inmvt > 0) then + if (this%inmvt > 0) then call this%read_mvt(iout) call this%mvt%mvt_df(this%gwtmodel1%dis) - endif + end if ! ! -- close the file - close(inunit) + close (inunit) ! ! -- Store obs call this%gwt_gwt_df_obs() - call this%obs%obs_df(iout, this%name, 'GWT-GWT', this%gwtmodel1%dis) + call this%obs%obs_df(iout, this%name, 'GWT-GWT', this%gwtmodel1%dis) ! ! -- validate call this%validate_exchange() @@ -250,29 +250,29 @@ end subroutine gwt_gwt_df !> @brief validate exchange data after reading !< subroutine validate_exchange(this) - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! local - + ! Ensure gwfmodel names were entered if (this%gwfmodelname1 == '') then - write(errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & + write (errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & ' requires that GWFMODELNAME1 be entered in the & &OPTIONS block.' call store_error(errmsg) end if if (this%gwfmodelname2 == '') then - write(errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & + write (errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & ' requires that GWFMODELNAME2 be entered in the & &OPTIONS block.' call store_error(errmsg) end if - + ! Periodic boundary condition in exchange don't allow XT3D (=interface model) if (associated(this%model1, this%model2)) then if (this%ixt3d > 0) then - write(errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & - ' is a periodic boundary condition which cannot'// & - ' be configured with XT3D' + write (errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & + ' is a periodic boundary condition which cannot'// & + ' be configured with XT3D' call store_error(errmsg) end if end if @@ -280,23 +280,23 @@ subroutine validate_exchange(this) ! Check to see if dispersion is on in either model1 or model2. ! If so, then ANGLDEGX must be provided as an auxiliary variable for this ! GWT-GWT exchange (this%ianglex > 0). - if(this%gwtmodel1%indsp /= 0 .or. this%gwtmodel2%indsp /= 0) then - if(this%ianglex == 0) then - write(errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because dispersion was '// & - 'specified in one or both transport models.' + if (this%gwtmodel1%indsp /= 0 .or. this%gwtmodel2%indsp /= 0) then + if (this%ianglex == 0) then + write (errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because dispersion was '// & + 'specified in one or both transport models.' call store_error(errmsg) - endif - endif + end if + end if if (this%ixt3d > 0 .and. this%ianglex == 0) then - write(errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because XT3D is enabled' + write (errmsg, '(3a)') 'GWT-GWT exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because XT3D is enabled' call store_error(errmsg) end if - + if (count_errors() > 0) then call ustop() end if @@ -311,19 +311,18 @@ end subroutine validate_exchange subroutine gwt_gwt_ar(this) ! -- modules ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local ! ! -- If mover is active, then call ar routine - if(this%inmvt > 0) call this%mvt%mvt_ar() + if (this%inmvt > 0) call this%mvt%mvt_ar() ! ! -- Observation AR call this%obs%obs_ar() ! ! -- Return return - end subroutine gwt_gwt_ar - + end subroutine gwt_gwt_ar !> @ brief Read and prepare !! @@ -334,13 +333,13 @@ subroutine gwt_gwt_rp(this) ! -- modules use TdisModule, only: readnewdata ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! ! -- Check with TDIS on whether or not it is time to RP if (.not. readnewdata) return ! ! -- Read and prepare for mover - if(this%inmvt > 0) call this%mvt%mvt_rp() + if (this%inmvt > 0) call this%mvt%mvt_rp() ! ! -- Read and prepare for observations call this%gwt_gwt_rp_obs() @@ -357,7 +356,7 @@ end subroutine gwt_gwt_rp subroutine gwt_gwt_ad(this) ! -- modules ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local ! ! -- Advance mover @@ -378,16 +377,16 @@ end subroutine gwt_gwt_ad subroutine gwt_gwt_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) ! -- modules ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: kiter integer(I4B), dimension(:), intent(in) :: iasln real(DP), dimension(:), intent(inout) :: amatsln - real(DP), dimension(:), intent(inout) ::rhssln + real(DP), dimension(:), intent(inout) :: rhssln integer(I4B), optional, intent(in) :: inwtflag ! -- local ! ! -- Call mvt fc routine - if(this%inmvt > 0) call this%mvt%mvt_fc(this%gwtmodel1%x, this%gwtmodel2%x) + if (this%inmvt > 0) call this%mvt%mvt_fc(this%gwtmodel1%x, this%gwtmodel2%x) ! ! -- Return return @@ -403,7 +402,7 @@ subroutine gwt_gwt_bd(this, icnvg, isuppress_output, isolnid) use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME use BudgetModule, only: rate_accumulator ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType integer(I4B), intent(inout) :: icnvg integer(I4B), intent(in) :: isuppress_output integer(I4B), intent(in) :: isolnid @@ -430,12 +429,12 @@ subroutine gwt_gwt_bd(this, icnvg, isuppress_output, isolnid) call this%gwtmodel2%model_bdentry(budterm, budtxt, this%name) ! ! -- Call mvt bd routine - if(this%inmvt > 0) call this%mvt%mvt_bd(this%gwtmodel1%x, this%gwtmodel2%x) + if (this%inmvt > 0) call this%mvt%mvt_bd(this%gwtmodel1%x, this%gwtmodel2%x) ! ! -- return return end subroutine gwt_gwt_bd - + !> @ brief Budget save !! !! Output individual flows to listing file and binary budget files @@ -446,11 +445,11 @@ subroutine gwt_gwt_bdsav(this) use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME use TdisModule, only: kstp, kper ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local character(len=LENBOUNDNAME) :: bname - character(len=LENPACKAGENAME+4) :: packname1 - character(len=LENPACKAGENAME+4) :: packname2 + character(len=LENPACKAGENAME + 4) :: packname1 + character(len=LENPACKAGENAME + 4) :: packname2 character(len=LENBUDTXT), dimension(1) :: budtxt character(len=20) :: nodestr integer(I4B) :: ntabrows @@ -477,7 +476,7 @@ subroutine gwt_gwt_bdsav(this) if (this%gwtmodel1%oc%oc_save('BUDGET')) then call this%outputtab1%set_title(packname1) end if - if (this%gwtmodel2%oc%oc_save('BUDGET')) then + if (this%gwtmodel2%oc%oc_save('BUDGET')) then call this%outputtab2%set_title(packname2) end if ! @@ -492,7 +491,7 @@ subroutine gwt_gwt_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if (this%gwtmodel1%ibound(n1) /= 0 .and. & + if (this%gwtmodel1%ibound(n1) /= 0 .and. & this%gwtmodel2%ibound(n2) /= 0) then ntabrows = ntabrows + 1 end if @@ -506,27 +505,30 @@ subroutine gwt_gwt_bdsav(this) ! -- Print and write budget terms for model 1 ! ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then + if (this%ipakcb /= 0) then ibinun1 = this%gwtmodel1%oc%oc_save_unit('BUDGET') else ibinun1 = 0 - endif + end if ! ! -- If save budget flag is zero for this stress period, then ! shut off saving - if(.not. this%gwtmodel1%oc%oc_save('BUDGET')) ibinun1 = 0 - if(isuppress_output /= 0) then + if (.not. this%gwtmodel1%oc%oc_save('BUDGET')) ibinun1 = 0 + if (isuppress_output /= 0) then ibinun1 = 0 - endif + end if ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun1 /= 0) then - call this%gwtmodel1%dis%record_srcdst_list_header(budtxt(1), & - this%gwtmodel1%name, this%name, & - this%gwtmodel2%name, this%name, & - this%naux, this%auxname, & - ibinun1, this%nexg, this%gwtmodel1%iout) - endif + if (ibinun1 /= 0) then + call this%gwtmodel1%dis%record_srcdst_list_header(budtxt(1), & + this%gwtmodel1%name, & + this%name, & + this%gwtmodel2%name, & + this%name, & + this%naux, this%auxname, & + ibinun1, this%nexg, & + this%gwtmodel1%iout) + end if ! ! Initialize accumulators ratin = DZERO @@ -536,11 +538,11 @@ subroutine gwt_gwt_bdsav(this) do i = 1, this%nexg ! ! -- Assign boundary name - if (this%inamedbound>0) then + if (this%inamedbound > 0) then bname = this%boundname(i) else bname = '' - endif + end if ! ! -- Calculate the flow rate between n1 and n2 rrate = DZERO @@ -548,62 +550,65 @@ subroutine gwt_gwt_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if(this%gwtmodel1%ibound(n1) /= 0 .and. & + if (this%gwtmodel1%ibound(n1) /= 0 .and. & this%gwtmodel2%ibound(n2) /= 0) then rrate = this%simvals(i) ! ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwtmodel1%oc%oc_save('BUDGET')) then + if (this%iprflow /= 0) then + if (this%gwtmodel1%oc%oc_save('BUDGET')) then ! ! -- set nodestr and write outputtab table nodeu = this%gwtmodel1%dis%get_nodeuser(n1) call this%gwtmodel1%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & + call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & rrate, bname) end if - endif - if(rrate < DZERO) then + end if + if (rrate < DZERO) then ratout = ratout - rrate else ratin = ratin + rrate - endif - endif + end if + end if ! ! -- If saving cell-by-cell flows in list, write flow n1u = this%gwtmodel1%dis%get_nodeuser(n1) n2u = this%gwtmodel2%dis%get_nodeuser(n2) - if(ibinun1 /= 0) & - call this%gwtmodel1%dis%record_mf6_list_entry( & - ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & - .false., .false.) + if (ibinun1 /= 0) & + call this%gwtmodel1%dis%record_mf6_list_entry( & + ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & + .false., .false.) ! - enddo + end do ! ! -- Print and write budget terms for model 2 ! ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then + if (this%ipakcb /= 0) then ibinun2 = this%gwtmodel2%oc%oc_save_unit('BUDGET') else ibinun2 = 0 - endif + end if ! ! -- If save budget flag is zero for this stress period, then ! shut off saving - if(.not. this%gwtmodel2%oc%oc_save('BUDGET')) ibinun2 = 0 - if(isuppress_output /= 0) then + if (.not. this%gwtmodel2%oc%oc_save('BUDGET')) ibinun2 = 0 + if (isuppress_output /= 0) then ibinun2 = 0 - endif + end if ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun2 /= 0) then - call this%gwtmodel2%dis%record_srcdst_list_header(budtxt(1), & - this%gwtmodel2%name, this%name, & - this%gwtmodel1%name, this%name, & - this%naux, this%auxname, & - ibinun2, this%nexg, this%gwtmodel2%iout) - endif + if (ibinun2 /= 0) then + call this%gwtmodel2%dis%record_srcdst_list_header(budtxt(1), & + this%gwtmodel2%name, & + this%name, & + this%gwtmodel1%name, & + this%name, & + this%naux, this%auxname, & + ibinun2, this%nexg, & + this%gwtmodel2%iout) + end if ! ! Initialize accumulators ratin = DZERO @@ -613,11 +618,11 @@ subroutine gwt_gwt_bdsav(this) do i = 1, this%nexg ! ! -- Assign boundary name - if (this%inamedbound>0) then + if (this%inamedbound > 0) then bname = this%boundname(i) else bname = '' - endif + end if ! ! -- Calculate the flow rate between n1 and n2 rrate = DZERO @@ -625,37 +630,37 @@ subroutine gwt_gwt_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if(this%gwtmodel1%ibound(n1) /= 0 .and. & + if (this%gwtmodel1%ibound(n1) /= 0 .and. & this%gwtmodel2%ibound(n2) /= 0) then rrate = this%simvals(i) ! ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwtmodel2%oc%oc_save('BUDGET')) then + if (this%iprflow /= 0) then + if (this%gwtmodel2%oc%oc_save('BUDGET')) then ! ! -- set nodestr and write outputtab table nodeu = this%gwtmodel2%dis%get_nodeuser(n2) call this%gwtmodel2%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & + call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & -rrate, bname) end if - endif - if(rrate < DZERO) then + end if + if (rrate < DZERO) then ratout = ratout - rrate else ratin = ratin + rrate - endif - endif + end if + end if ! ! -- If saving cell-by-cell flows in list, write flow n1u = this%gwtmodel1%dis%get_nodeuser(n1) n2u = this%gwtmodel2%dis%get_nodeuser(n2) - if(ibinun2 /= 0) & - call this%gwtmodel2%dis%record_mf6_list_entry( & - ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & - .false., .false.) + if (ibinun2 /= 0) & + call this%gwtmodel2%dis%record_mf6_list_entry( & + ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & + .false., .false.) ! - enddo + end do ! ! -- Set icbcfl, ibudfl to zero so that flows will be printed and ! saved, if the options were set in the MVT package @@ -666,14 +671,14 @@ subroutine gwt_gwt_bdsav(this) !cdl todo: if(this%inmvt > 0) call this%mvt%mvt_bdsav(icbcfl, ibudfl, isuppress_output) ! ! -- Calculate and write simulated values for observations - if(this%inobs /= 0) then + if (this%inobs /= 0) then call this%gwt_gwt_save_simvals() - endif + end if ! ! -- return return end subroutine gwt_gwt_bdsav - + !> @ brief Output !! !! Write output @@ -684,46 +689,46 @@ subroutine gwt_gwt_ot(this) use SimVariablesModule, only: iout use ConstantsModule, only: DZERO, LINELENGTH ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local integer(I4B) :: iexg, n1, n2 integer(I4B) :: ibudfl real(DP) :: flow character(len=LINELENGTH) :: node1str, node2str ! -- format - character(len=*), parameter :: fmtheader = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + character(len=*), parameter :: fmtheader = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & &2a16, 5a16, /, 112('-'))" - character(len=*), parameter :: fmtheader2 = & - "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & + character(len=*), parameter :: fmtheader2 = & + "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & &2a16, 4a16, /, 96('-'))" - character(len=*), parameter :: fmtdata = & - "(2a16, 5(1pg16.6))" + character(len=*), parameter :: fmtdata = & + "(2a16, 5(1pg16.6))" ! ! -- Call bdsave call this%gwt_gwt_bdsav() ! ! -- Write a table of exchanges - if(this%iprflow /= 0) then - write(iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' + if (this%iprflow /= 0) then + write (iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' do iexg = 1, this%nexg n1 = this%nodem1(iexg) n2 = this%nodem2(iexg) flow = this%simvals(iexg) call this%gwtmodel1%dis%noder_to_string(n1, node1str) call this%gwtmodel2%dis%noder_to_string(n2, node2str) - write(iout, fmtdata) trim(adjustl(node1str)), & - trim(adjustl(node2str)), & - this%cond(iexg), this%gwtmodel1%x(n1), & - this%gwtmodel2%x(n2), flow - enddo - endif + write (iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%gwtmodel1%x(n1), & + this%gwtmodel2%x(n2), flow + end do + end if ! !cdl Implement when MVT is ready ! -- Mover budget output ibudfl = 1 - if(this%inmvt > 0) call this%mvt%mvt_ot_bdsummary(ibudfl) + if (this%inmvt > 0) call this%mvt%mvt_ot_bdsummary(ibudfl) ! ! -- OBS output call this%obs%obs_ot() @@ -740,24 +745,24 @@ end subroutine gwt_gwt_ot subroutine read_options(this, iout) ! -- modules use ConstantsModule, only: LINELENGTH, LENAUXNAME, DEM6 - use MemoryManagerModule, only: mem_allocate + use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: iout ! -- local character(len=LINELENGTH) :: keyword logical :: isfound - logical :: endOfBlock + logical :: endOfBlock integer(I4B) :: ierr ! ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING GWT-GWT EXCHANGE OPTIONS' + write (iout, '(1x,a)') 'PROCESSING GWT-GWT EXCHANGE OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) then @@ -776,12 +781,12 @@ subroutine read_options(this, iout) end if ! unknown option - errmsg = "Unknown GWT-GWT exchange option '" // trim(keyword) // "'." + errmsg = "Unknown GWT-GWT exchange option '"//trim(keyword)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end do - write(iout,'(1x,a)') 'END OF GWT-GWT EXCHANGE OPTIONS' + write (iout, '(1x,a)') 'END OF GWT-GWT EXCHANGE OPTIONS' end if ! ! -- return @@ -792,11 +797,11 @@ end subroutine read_options !< function parse_option(this, keyword, iout) result(parsed) use InputOutputModule, only: getunit, openfile - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType character(len=LINELENGTH), intent(in) :: keyword !< the option name - integer(I4B), intent(in) :: iout !< for logging - logical(LGP) :: parsed !< true when parsed - ! local + integer(I4B), intent(in) :: iout !< for logging + logical(LGP) :: parsed !< true when parsed + ! local character(len=LINELENGTH) :: fname integer(I4B) :: inobs, ilen character(len=LINELENGTH) :: subkey @@ -808,67 +813,69 @@ function parse_option(this, keyword, iout) result(parsed) call this%parser%GetStringCaps(subkey) ilen = len_trim(subkey) if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'INVALID MODEL NAME: ', trim(subkey) + write (errmsg, '(4x,a,a)') & + 'INVALID MODEL NAME: ', trim(subkey) call store_error(errmsg) call this%parser%StoreErrorUnit() end if if (this%gwfmodelname1 /= '') then call store_error('GWFMODELNAME1 has already been set to ' & - // trim(this%gwfmodelname1) // '. Cannot set more than once.') + //trim(this%gwfmodelname1)// & + '. Cannot set more than once.') call this%parser%StoreErrorUnit() end if this%gwfmodelname1 = subkey(1:LENMODELNAME) - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'GWFMODELNAME1 IS SET TO: ', trim(this%gwfmodelname1) case ('GWFMODELNAME2') call this%parser%GetStringCaps(subkey) ilen = len_trim(subkey) if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'INVALID MODEL NAME: ', trim(subkey) + write (errmsg, '(4x,a,a)') & + 'INVALID MODEL NAME: ', trim(subkey) call store_error(errmsg) call this%parser%StoreErrorUnit() end if if (this%gwfmodelname2 /= '') then call store_error('GWFMODELNAME2 has already been set to ' & - // trim(this%gwfmodelname2) // '. Cannot set more than once.') + //trim(this%gwfmodelname2)// & + '. Cannot set more than once.') call this%parser%StoreErrorUnit() end if this%gwfmodelname2 = subkey(1:LENMODELNAME) - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'GWFMODELNAME2 IS SET TO: ', trim(this%gwfmodelname2) case ('PRINT_FLOWS') this%iprflow = 1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' case ('SAVE_FLOWS') this%ipakcb = -1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'EXCHANGE FLOWS WILL BE SAVED TO BINARY BUDGET FILES.' case ('MVT6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('MVT6 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('MVT6 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetString(fname) - if(fname == '') then + if (fname == '') then call store_error('NO MVT6 FILE SPECIFIED.') call this%parser%StoreErrorUnit() - endif + end if this%inmvt = getunit() call openfile(this%inmvt, iout, fname, 'MVT') - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'WATER MOVER TRANSPORT INFORMATION WILL BE READ FROM ', trim(fname) case ('OBS6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if this%obs%active = .true. call this%parser%GetString(this%obs%inputFilename) inobs = GetUnit() @@ -877,34 +884,34 @@ function parse_option(this, keyword, iout) result(parsed) case ('ADVSCHEME') !cdl todo: change to ADV_SCHEME? call this%parser%GetStringCaps(subkey) - select case(subkey) - case('UPSTREAM') + select case (subkey) + case ('UPSTREAM') this%iAdvScheme = 0 - case('CENTRAL') + case ('CENTRAL') this%iAdvScheme = 1 - case('TVD') + case ('TVD') this%iAdvScheme = 2 case default - errmsg = "Unknown weighting method for advection: '" // trim(subkey) // "'." + errmsg = "Unknown weighting method for advection: '"//trim(subkey)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end select - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(subkey) case ('XT3D_OFF') !cdl todo: change to DSP_XT3D_OFF? this%ixt3d = 0 - write(iout, '(4x,a)') 'XT3D FORMULATION HAS BEEN SHUT OFF.' + write (iout, '(4x,a)') 'XT3D FORMULATION HAS BEEN SHUT OFF.' case ('XT3D_RHS') !cdl todo: change to DSP_XT3D_RHS? this%ixt3d = 2 - write(iout, '(4x,a)') 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' + write (iout, '(4x,a)') 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' case default parsed = .false. end select end function parse_option - + !> @ brief Read mover !! !! Read and process movers @@ -912,15 +919,15 @@ end function parse_option !< subroutine read_mvt(this, iout) ! -- modules - use GwtMvtModule, only: mvt_cr + use TspMvtModule, only: mvt_cr ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: iout ! -- local ! ! -- Create and initialize the mover object Here, fmi is set to the one ! for gwtmodel1 so that a call to save flows has an associated dis - ! object. + ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwtmodel1%fmi, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & @@ -929,7 +936,7 @@ subroutine read_mvt(this, iout) ! -- Return return end subroutine read_mvt - + !> @ brief Allocate scalars !! !! Allocate scalar variables @@ -940,12 +947,12 @@ subroutine allocate_scalars(this) use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local ! call this%DisConnExchangeType%allocate_scalars() ! - call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) + call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) call mem_allocate(this%iprflow, 'IPRFLOW', this%memoryPath) call mem_allocate(this%ipakcb, 'IPAKCB', this%memoryPath) call mem_allocate(this%inobs, 'INOBS', this%memoryPath) @@ -973,35 +980,35 @@ subroutine gwt_gwt_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local ! ! -- objects if (this%inmvt > 0) then call this%mvt%mvt_da() - deallocate(this%mvt) - endif + deallocate (this%mvt) + end if call this%obs%obs_da() - deallocate(this%obs) + deallocate (this%obs) ! ! -- arrays - call mem_deallocate(this%cond) + call mem_deallocate(this%cond) call mem_deallocate(this%simvals) ! ! -- output table objects if (associated(this%outputtab1)) then call this%outputtab1%table_da() - deallocate(this%outputtab1) - nullify(this%outputtab1) + deallocate (this%outputtab1) + nullify (this%outputtab1) end if if (associated(this%outputtab2)) then call this%outputtab2%table_da() - deallocate(this%outputtab2) - nullify(this%outputtab2) + deallocate (this%outputtab2) + nullify (this%outputtab2) end if ! - ! -- scalars - deallocate(this%filename) + ! -- scalars + deallocate (this%filename) call mem_deallocate(this%inewton) call mem_deallocate(this%iprflow) call mem_deallocate(this%ipakcb) @@ -1015,7 +1022,7 @@ subroutine gwt_gwt_da(this) ! -- return return end subroutine gwt_gwt_da - + !> @ brief Allocate arrays !! !! Allocate arrays @@ -1025,13 +1032,13 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local character(len=LINELENGTH) :: text integer(I4B) :: ntabcol, i ! call this%DisConnExchangeType%allocate_arrays() - ! + ! call mem_allocate(this%cond, this%nexg, 'COND', this%memoryPath) call mem_allocate(this%simvals, this%nexg, 'SIMVALS', this%memoryPath) ! @@ -1052,7 +1059,7 @@ subroutine allocate_arrays(this) ! -- initialize the output table objects ! outouttab1 call table_cr(this%outputtab1, this%name, ' ') - call this%outputtab1%table_df(this%nexg, ntabcol, this%gwtmodel1%iout, & + call this%outputtab1%table_df(this%nexg, ntabcol, this%gwtmodel1%iout, & transient=.TRUE.) text = 'NUMBER' call this%outputtab1%initialize_column(text, 10, alignment=TABCENTER) @@ -1066,7 +1073,7 @@ subroutine allocate_arrays(this) end if ! outouttab2 call table_cr(this%outputtab2, this%name, ' ') - call this%outputtab2%table_df(this%nexg, ntabcol, this%gwtmodel2%iout, & + call this%outputtab2%table_df(this%nexg, ntabcol, this%gwtmodel2%iout, & transient=.TRUE.) text = 'NUMBER' call this%outputtab2%initialize_column(text, 10, alignment=TABCENTER) @@ -1091,7 +1098,7 @@ end subroutine allocate_arrays !< subroutine gwt_gwt_df_obs(this) ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local integer(I4B) :: indx ! @@ -1103,7 +1110,7 @@ subroutine gwt_gwt_df_obs(this) ! -- return return end subroutine gwt_gwt_df_obs - + !> @ brief Read and prepare observations !! !! Handle observation exchanges exchange-boundary names. @@ -1113,7 +1120,7 @@ subroutine gwt_gwt_rp_obs(this) ! -- modules use ConstantsModule, only: DZERO ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! -- local integer(I4B) :: i integer(I4B) :: j @@ -1121,15 +1128,15 @@ subroutine gwt_gwt_rp_obs(this) character(len=LENBOUNDNAME) :: bname logical :: jfound ! -- formats -10 format('Exchange "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') -20 format('Exchange id "',i0,'" for observation "',a, & - '" is invalid in package "',a,'"') +10 format('Exchange "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') +20 format('Exchange id "', i0, '" for observation "', a, & + '" is invalid in package "', a, '"') ! do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv ! - ! -- indxbnds needs to be reset each stress period because + ! -- indxbnds needs to be reset each stress period because ! list of boundaries can change each stress period. ! -- Not true for exchanges, but leave this in for now anyway. call obsrv%ResetObsIndex() @@ -1141,18 +1148,18 @@ subroutine gwt_gwt_rp_obs(this) ! Iterate through all boundaries to identify and store ! corresponding index(indices) in bound array. jfound = .false. - do j=1,this%nexg + do j = 1, this%nexg if (this%boundname(j) == bname) then jfound = .true. obsrv%BndFound = .true. obsrv%CurrentTimeStepEndValue = DZERO call obsrv%AddObsIndex(j) - endif - enddo + end if + end do if (.not. jfound) then - write(errmsg, 10) trim(bname), trim(obsrv%ObsTypeId) , trim(this%name) + write (errmsg, 10) trim(bname), trim(obsrv%ObsTypeId), trim(this%name) call store_error(errmsg) - endif + end if else ! -- Observation location is a single exchange number if (obsrv%intPak1 <= this%nexg .and. obsrv%intPak1 > 0) then @@ -1162,23 +1169,23 @@ subroutine gwt_gwt_rp_obs(this) call obsrv%AddObsIndex(obsrv%intPak1) else jfound = .false. - endif + end if if (.not. jfound) then - write(errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId) , trim(this%name) + write (errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId), trim(this%name) call store_error(errmsg) - endif - endif - enddo + end if + end if + end do ! ! -- write summary of error messages if (count_errors() > 0) then call store_error_unit(this%inobs) - endif + end if ! ! -- Return return end subroutine gwt_gwt_rp_obs - + !> @ brief Final processing !! !! Conduct any final processing @@ -1186,28 +1193,28 @@ end subroutine gwt_gwt_rp_obs !< subroutine gwt_gwt_fp(this) ! -- dummy - class(GwtExchangeType) :: this !< GwtExchangeType + class(GwtExchangeType) :: this !< GwtExchangeType ! return end subroutine gwt_gwt_fp - - !> @brief Return true when this exchange provides matrix + + !> @brief Return true when this exchange provides matrix !! coefficients for solving @param model !< function gwt_gwt_connects_model(this, model) result(is_connected) - class(GwtExchangeType) :: this !< GwtExchangeType - class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection - logical(LGP) :: is_connected !< true, when connected + class(GwtExchangeType) :: this !< GwtExchangeType + class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection + logical(LGP) :: is_connected !< true, when connected is_connected = .false. ! only connected when model is GwtModelType of course - select type(model) - class is (GwtModelType) - if (associated(this%gwtmodel1, model)) then - is_connected = .true. - else if (associated(this%gwtmodel2, model)) then - is_connected = .true. - end if + select type (model) + class is (GwtModelType) + if (associated(this%gwtmodel1, model)) then + is_connected = .true. + else if (associated(this%gwtmodel2, model)) then + is_connected = .true. + end if end select end function gwt_gwt_connects_model @@ -1216,10 +1223,10 @@ end function gwt_gwt_connects_model !< function use_interface_model(this) result(useIM) class(GwtExchangeType) :: this !< GwtExchangeType - logical(LGP) :: useIM !< true when interface model should be used - + logical(LGP) :: useIM !< true when interface model should be used + useIM = (this%ixt3d > 0) - + end function !> @ brief Save simulated flow observations @@ -1248,7 +1255,7 @@ subroutine gwt_gwt_save_simvals(this) call this%obs%obs_bd_clear() do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv - do j = 1, obsrv%indxbnds_count + do j = 1, obsrv%indxbnds_count iexg = obsrv%indxbnds(j) v = DZERO select case (obsrv%ObsTypeId) @@ -1257,15 +1264,15 @@ subroutine gwt_gwt_save_simvals(this) n2 = this%nodem2(iexg) v = this%simvals(iexg) case default - msg = 'Error: Unrecognized observation type: ' // & + msg = 'Error: Unrecognized observation type: '// & trim(obsrv%ObsTypeId) call store_error(msg) call store_error_unit(this%inobs) end select call this%obs%SaveOneSimval(obsrv, v) - enddo - enddo - endif + end do + end do + end if ! return end subroutine gwt_gwt_save_simvals @@ -1282,10 +1289,10 @@ subroutine gwt_gwt_process_obsID(obsrv, dis, inunitobs, iout) use ObserveModule, only: ObserveType use BaseDisModule, only: DisBaseType ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: n, iexg, istat integer(I4B) :: icol, istart, istop @@ -1307,7 +1314,7 @@ subroutine gwt_gwt_process_obsID(obsrv, dis, inunitobs, iout) ! boundaries, so assign intPak1 as a value that indicates observation ! is for a named exchange boundary or group of exchange boundaries. obsrv%intPak1 = NAMEDBOUNDFLAG - endif + end if ! return end subroutine gwt_gwt_process_obsID @@ -1317,7 +1324,7 @@ end subroutine gwt_gwt_process_obsID !! Cast polymorphic object as exchange !! !< - function CastAsGwtExchange(obj) result (res) + function CastAsGwtExchange(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj class(GwtExchangeType), pointer :: res @@ -1337,12 +1344,12 @@ end function CastAsGwtExchange !! Return an exchange from the list for specified index !! !< - function GetGwtExchangeFromList(list, idx) result (res) + function GetGwtExchangeFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(GwtExchangeType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(GwtExchangeType), pointer :: res ! -- local class(*), pointer :: obj ! @@ -1352,7 +1359,5 @@ function GetGwtExchangeFromList(list, idx) result (res) return end function GetGwtExchangeFromList - - end module GwtGwtExchangeModule diff --git a/src/Exchange/NumericalExchange.f90 b/src/Exchange/NumericalExchange.f90 index bba412b0127..8b9897f86d0 100644 --- a/src/Exchange/NumericalExchange.f90 +++ b/src/Exchange/NumericalExchange.f90 @@ -1,18 +1,18 @@ module NumericalExchangeModule - use KindModule, only: DP, I4B - use BaseModelModule, only: BaseModelType - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use NumericalModelModule, only: NumericalModelType - use ListModule, only: ListType + use KindModule, only: DP, I4B + use BaseModelModule, only: BaseModelType + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use NumericalModelModule, only: NumericalModelType + use ListModule, only: ListType implicit none private - public :: NumericalExchangeType, & + public :: NumericalExchangeType, & AddNumericalExchangeToList, GetNumericalExchangeFromList - type, extends(BaseExchangeType) :: NumericalExchangeType + type, extends(BaseExchangeType) :: NumericalExchangeType character(len=7) :: typename !< name of the type (e.g., 'GWF-GWF') contains procedure :: exg_df @@ -29,7 +29,7 @@ module NumericalExchangeModule procedure :: exg_bd procedure :: exg_ot procedure :: exg_da - procedure :: get_iasym + procedure :: get_iasym end type NumericalExchangeType contains @@ -61,7 +61,7 @@ subroutine exg_ac(this, sparse) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use SparseModule, only:sparsematrix + use SparseModule, only: sparsematrix ! -- dummy class(NumericalExchangeType) :: this type(sparsematrix), intent(inout) :: sparse @@ -80,7 +80,7 @@ subroutine exg_mc(this, iasln, jasln) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- module - use SparseModule, only:sparsematrix + use SparseModule, only: sparsematrix ! -- dummy class(NumericalExchangeType) :: this integer(I4B), dimension(:), intent(in) :: iasln @@ -120,7 +120,7 @@ subroutine exg_ad(this) ! -- return return end subroutine exg_ad - + subroutine exg_cf(this, kiter) ! ****************************************************************************** ! exg_cf -- Calculate conductance, and for explicit exchanges, set the @@ -132,7 +132,7 @@ subroutine exg_cf(this, kiter) ! -- modules ! -- dummy class(NumericalExchangeType) :: this - integer(I4B),intent(in) :: kiter + integer(I4B), intent(in) :: kiter ! -- local ! ------------------------------------------------------------------------------ ! @@ -272,7 +272,7 @@ subroutine exg_da(this) return end subroutine exg_da - function get_iasym(this) result (iasym) + function get_iasym(this) result(iasym) class(NumericalExchangeType) :: this integer(I4B) :: iasym @@ -280,7 +280,7 @@ function get_iasym(this) result (iasym) end function get_iasym - function CastAsNumericalExchangeClass(obj) result (res) + function CastAsNumericalExchangeClass(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj class(NumericalExchangeType), pointer :: res @@ -298,7 +298,7 @@ end function CastAsNumericalExchangeClass subroutine AddNumericalExchangeToList(list, exchange) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list class(NumericalExchangeType), pointer, intent(in) :: exchange ! -- local class(*), pointer :: obj @@ -309,12 +309,12 @@ subroutine AddNumericalExchangeToList(list, exchange) return end subroutine AddNumericalExchangeToList - function GetNumericalExchangeFromList(list, idx) result (res) + function GetNumericalExchangeFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(NumericalExchangeType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(NumericalExchangeType), pointer :: res ! -- local class(*), pointer :: obj ! From 94dd16f5a17340fab2e0abd3c677b5e938daed2e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 16:00:28 -0700 Subject: [PATCH 005/212] Updating the contents of the src/Solution/ directory with the fprettify stuff. Note that a folder name containing the linear solver files was altered and a new file added. Need to update my local solution --- src/Solution/BaseSolution.f90 | 58 +- src/Solution/LinearMethods/ims8base.f90 | 1319 ++++++++++++++++ src/Solution/LinearMethods/ims8linear.f90 | 1016 ++++++++++++ src/Solution/LinearMethods/ims8misc.f90 | 54 + src/Solution/LinearMethods/ims8reordering.f90 | 774 +++++++++ src/Solution/NumericalSolution.f90 | 1378 +++++++++-------- src/Solution/SolutionGroup.f90 | 98 +- src/Solution/SparseMatrixSolver/ims8base.f90 | 1319 ---------------- .../SparseMatrixSolver/ims8linear.f90 | 1017 ------------ .../SparseMatrixSolver/ims8reordering.f90 | 781 ---------- 10 files changed, 3933 insertions(+), 3881 deletions(-) create mode 100644 src/Solution/LinearMethods/ims8base.f90 create mode 100644 src/Solution/LinearMethods/ims8linear.f90 create mode 100644 src/Solution/LinearMethods/ims8misc.f90 create mode 100644 src/Solution/LinearMethods/ims8reordering.f90 delete mode 100644 src/Solution/SparseMatrixSolver/ims8base.f90 delete mode 100644 src/Solution/SparseMatrixSolver/ims8linear.f90 delete mode 100644 src/Solution/SparseMatrixSolver/ims8reordering.f90 diff --git a/src/Solution/BaseSolution.f90 b/src/Solution/BaseSolution.f90 index bcc5ac2b2f8..69a16ada697 100644 --- a/src/Solution/BaseSolution.f90 +++ b/src/Solution/BaseSolution.f90 @@ -5,7 +5,7 @@ module BaseSolutionModule use ConstantsModule, only: LENSOLUTIONNAME use BaseModelModule, only: BaseModelType use BaseExchangeModule, only: BaseExchangeType - use ListModule, only: ListType + use ListModule, only: ListType implicit none private @@ -15,23 +15,23 @@ module BaseSolutionModule type, abstract :: BaseSolutionType character(len=LENSOLUTIONNAME) :: name contains - procedure (sln_df), deferred :: sln_df - procedure (sln_ar), deferred :: sln_ar - procedure (sln_calculate_delt), deferred :: sln_calculate_delt - procedure (sln_ad), deferred :: sln_ad - procedure (sln_ca), deferred :: sln_ca - procedure (sln_ot), deferred :: sln_ot - procedure (sln_fp), deferred :: sln_fp - procedure (sln_da), deferred :: sln_da - procedure (slnsave), deferred :: save - procedure (slnaddmodel), deferred :: add_model - procedure (slnaddexchange), deferred :: add_exchange - procedure (slngetmodels), deferred :: get_models - procedure (slngetexchanges), deferred :: get_exchanges + procedure(sln_df), deferred :: sln_df + procedure(sln_ar), deferred :: sln_ar + procedure(sln_calculate_delt), deferred :: sln_calculate_delt + procedure(sln_ad), deferred :: sln_ad + procedure(sln_ca), deferred :: sln_ca + procedure(sln_ot), deferred :: sln_ot + procedure(sln_fp), deferred :: sln_fp + procedure(sln_da), deferred :: sln_da + procedure(slnsave), deferred :: save + procedure(slnaddmodel), deferred :: add_model + procedure(slnaddexchange), deferred :: add_exchange + procedure(slngetmodels), deferred :: get_models + procedure(slngetexchanges), deferred :: get_exchanges end type BaseSolutionType abstract interface - + subroutine sln_df(this) import BaseSolutionType class(BaseSolutionType) :: this @@ -48,7 +48,7 @@ subroutine assignConnectionsIFace(this) import BaseSolutionType class(BaseSolutionType) :: this end subroutine - + subroutine sln_ar(this) import BaseSolutionType class(BaseSolutionType) :: this @@ -58,12 +58,12 @@ subroutine sln_rp(this) import BaseSolutionType class(BaseSolutionType) :: this end subroutine - + subroutine sln_calculate_delt(this) import BaseSolutionType class(BaseSolutionType) :: this end subroutine - + subroutine sln_ad(this) import BaseSolutionType class(BaseSolutionType) :: this @@ -78,21 +78,21 @@ subroutine sln_ca(this, isgcnvg, isuppress_output) use KindModule, only: DP, I4B import BaseSolutionType class(BaseSolutionType) :: this - integer(I4B),intent(in) :: isuppress_output + integer(I4B), intent(in) :: isuppress_output integer(I4B), intent(inout) :: isgcnvg end subroutine - subroutine slnsave(this,filename) + subroutine slnsave(this, filename) import BaseSolutionType class(BaseSolutionType) :: this character(len=*), intent(in) :: filename end subroutine - subroutine slnaddmodel(this,mp) + subroutine slnaddmodel(this, mp) import BaseSolutionType import BaseModelType class(BaseSolutionType) :: this - class(BaseModelType),pointer,intent(in) :: mp + class(BaseModelType), pointer, intent(in) :: mp end subroutine function slngetmodels(this) result(models) @@ -123,7 +123,7 @@ subroutine sln_da(this) contains - function CastAsBaseSolutionClass(obj) result (res) + function CastAsBaseSolutionClass(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj class(BaseSolutionType), pointer :: res @@ -141,7 +141,7 @@ end function CastAsBaseSolutionClass subroutine AddBaseSolutionToList(list, solution) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list class(BaseSolutionType), pointer, intent(in) :: solution ! -- local class(*), pointer :: obj @@ -151,13 +151,13 @@ subroutine AddBaseSolutionToList(list, solution) ! return end subroutine AddBaseSolutionToList - - function GetBaseSolutionFromList(list, idx) result (res) + + function GetBaseSolutionFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(BaseSolutionType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(BaseSolutionType), pointer :: res ! -- local class(*), pointer :: obj ! diff --git a/src/Solution/LinearMethods/ims8base.f90 b/src/Solution/LinearMethods/ims8base.f90 new file mode 100644 index 00000000000..a78ebccaf5e --- /dev/null +++ b/src/Solution/LinearMethods/ims8base.f90 @@ -0,0 +1,1319 @@ + +!> @brief This module contains the IMS linear accelerator subroutines +!! +!! This module contains the IMS linear accelerator subroutines used by a +!! MODFLOW 6 solution. +!< +MODULE IMSLinearBaseModule + ! -- modules + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, IZERO, & + DZERO, DPREC, DEM6, DEM3, DHALF, DONE + use GenericUtilitiesModule, only: sim_message, is_same + use BlockParserModule, only: BlockParserType + use IMSReorderingModule, only: ims_odrv + + IMPLICIT NONE + + type(BlockParserType), private :: parser + +contains + + !> @ brief Preconditioned Conjugate Gradient linear accelerator + !! + !! Apply the Preconditioned Conjugate Gradient linear accelerator to + !! the current coefficient matrix, right-hand side, using the current + !! dependent-variable. + !! + !< + SUBROUTINE ims_base_cg(ICNVG, ITMAX, INNERIT, & + NEQ, NJA, NIAPC, NJAPC, & + IPC, NITERC, ICNVGOPT, NORTH, & + DVCLOSE, RCLOSE, L2NORM0, EPFACT, & + IA0, JA0, A0, IAPC, JAPC, APC, & + X, B, D, P, Q, Z, & + NJLU, IW, JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + ! -- dummy variables + integer(I4B), INTENT(INOUT) :: ICNVG !< convergence flag (1) non-convergence (0) + integer(I4B), INTENT(IN) :: ITMAX !< maximum number of inner iterations + integer(I4B), INTENT(INOUT) :: INNERIT !< inner iteration count + integer(I4B), INTENT(IN) :: NEQ !< number of equations + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), INTENT(IN) :: NIAPC !< preconditioner number of rows + integer(I4B), INTENT(IN) :: NJAPC !< preconditioner number of non-zero entries + integer(I4B), INTENT(IN) :: IPC !< preconditioner option + integer(I4B), INTENT(INOUT) :: NITERC !< total number of inner iterations + integer(I4B), INTENT(IN) :: ICNVGOPT !< flow convergence criteria option + integer(I4B), INTENT(IN) :: NORTH !< orthogonalization frequency + real(DP), INTENT(IN) :: DVCLOSE !< dependent-variable closure criteria + real(DP), INTENT(IN) :: RCLOSE !< flow closure criteria + real(DP), INTENT(IN) :: L2NORM0 !< initial L-2 norm for system of equations + real(DP), INTENT(IN) :: EPFACT !< factor for decreasing flow convergence criteria for subsequent Picard iterations + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA0 !< CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 !< CRS column pointers + real(DP), DIMENSION(NJA), INTENT(IN) :: A0 !< coefficient matrix + integer(I4B), DIMENSION(NIAPC + 1), INTENT(IN) :: IAPC !< preconditioner CRS row pointers + integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC !< preconditioner CRS column pointers + real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC !< preconditioner matrix + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X !< dependent-variable vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B !< right-hand side vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P !< working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q !< working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Z !< working vector + ! -- ILUT dummy variables + integer(I4B), INTENT(IN) :: NJLU !< preconditioner length of JLU vector + integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW !< preconditioner integer working vector + integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU !< preconditioner JLU working vector + ! -- convergence information dummy variables dummy variables + integer(I4B), INTENT(IN) :: NCONV !< maximum number of inner iterations in a time step (maxiter * maxinner) + integer(I4B), INTENT(IN) :: CONVNMOD !< number of models in the solution + integer(I4B), DIMENSION(CONVNMOD + 1), INTENT(INOUT) :: CONVMODSTART !< pointer to the start of each model in the convmod* arrays + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV !< location of the maximum dependent-variable change in the solution + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR !< location of the maximum flow change in the solution + character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL !< convergence string + integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER !< actual number of inner iterations in each Picard iteration + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV !< location of the maximum dependent-variable change in each model in the solution + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR !< location of the maximum flow change in each model in the solution + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX !< maximum dependent-variable change in the solution + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX !< maximum flow change in the solution + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX !< maximum dependent-variable change in each model in the solution + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX !< maximum flow change in each model in the solution + ! -- local variables + LOGICAL :: lorth + logical :: lsame + character(len=31) :: cval + integer(I4B) :: n + integer(I4B) :: iiter + integer(I4B) :: xloc, rloc + integer(I4B) :: im, im0, im1 + real(DP) :: ddot + real(DP) :: tv + real(DP) :: deltax + real(DP) :: rmax + real(DP) :: l2norm + real(DP) :: rcnvg + real(DP) :: denom + real(DP) :: alpha, beta + real(DP) :: rho, rho0 + ! + ! -- initialize local variables + rho0 = DZERO + rho = DZERO + INNERIT = 0 + ! + ! -- INNER ITERATION + INNER: DO iiter = 1, itmax + INNERIT = INNERIT + 1 + NITERC = NITERC + 1 + ! + ! -- APPLY PRECONDITIONER + SELECT CASE (IPC) + ! + ! -- ILU0 AND MILU0 + CASE (1, 2) + CALL ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, D, Z) + ! + ! -- ILUT AND MILUT + CASE (3, 4) + CALL lusol(NEQ, D, Z, APC, JLU, IW) + END SELECT + rho = ddot(NEQ, D, 1, Z, 1) + ! + ! -- COMPUTE DIRECTIONAL VECTORS + IF (IITER == 1) THEN + DO n = 1, NEQ + P(n) = Z(n) + END DO + ELSE + beta = rho / rho0 + DO n = 1, NEQ + P(n) = Z(n) + beta * P(n) + END DO + END IF + ! + ! -- COMPUTE ITERATES + ! + ! -- UPDATE Q + call amux(NEQ, P, Q, A0, JA0, IA0) + denom = ddot(NEQ, P, 1, Q, 1) + denom = denom + SIGN(DPREC, denom) + alpha = rho / denom + ! + ! -- UPDATE X AND RESIDUAL + deltax = DZERO + rmax = DZERO + l2norm = DZERO + DO im = 1, CONVNMOD + DVMAX(im) = DZERO + DRMAX(im) = DZERO + END DO + im = 1 + im0 = CONVMODSTART(1) + im1 = CONVMODSTART(2) + DO n = 1, NEQ + ! + ! -- determine current model index + if (n == im1) then + im = im + 1 + im0 = CONVMODSTART(im) + im1 = CONVMODSTART(im + 1) + end if + ! + ! -- identify deltax and rmax + tv = alpha * P(n) + X(n) = X(n) + tv + IF (ABS(tv) > ABS(deltax)) THEN + deltax = tv + xloc = n + END IF + IF (ABS(tv) > ABS(DVMAX(im))) THEN + DVMAX(im) = tv + LOCDV(im) = n + END IF + tv = D(n) + tv = tv - alpha * Q(n) + D(n) = tv + IF (ABS(tv) > ABS(rmax)) THEN + rmax = tv + rloc = n + END IF + IF (ABS(tv) > ABS(DRMAX(im))) THEN + DRMAX(im) = tv + LOCDR(im) = n + END IF + l2norm = l2norm + tv * tv + END DO + l2norm = SQRT(l2norm) + ! + ! -- SAVE SOLVER convergence information dummy variables + IF (NCONV > 1) THEN !< + n = NITERC + WRITE (cval, '(g15.7)') alpha + CACCEL(n) = cval + ITINNER(n) = iiter + DO im = 1, CONVNMOD + CONVLOCDV(im, n) = LOCDV(im) + CONVLOCDR(im, n) = LOCDR(im) + CONVDVMAX(im, n) = DVMAX(im) + CONVDRMAX(im, n) = DRMAX(im) + END DO + END IF + ! + ! -- TEST FOR SOLVER CONVERGENCE + IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN + rcnvg = l2norm + ELSE + rcnvg = rmax + END IF + CALL ims_base_testcnvg(ICNVGOPT, ICNVG, INNERIT, & + deltax, rcnvg, & + L2NORM0, EPFACT, DVCLOSE, RCLOSE) + ! + ! -- CHECK FOR EXACT SOLUTION + IF (rcnvg == DZERO) ICNVG = 1 + ! + ! -- CHECK FOR STANDARD CONVERGENCE + IF (ICNVG .NE. 0) EXIT INNER + ! + ! -- CHECK THAT CURRENT AND PREVIOUS rho ARE DIFFERENT + lsame = is_same(rho, rho0) + IF (lsame) THEN + EXIT INNER + END IF + ! + ! -- RECALCULATE THE RESIDUAL + IF (NORTH > 0) THEN + lorth = mod(iiter + 1, NORTH) == 0 + IF (lorth) THEN + call ims_base_residual(NEQ, NJA, X, B, D, A0, IA0, JA0) + END IF + END IF + ! + ! -- exit inner if rho is zero + if (rho == DZERO) then + exit inner + end if + ! + ! -- SAVE CURRENT INNER ITERATES + rho0 = rho + END DO INNER + ! + ! -- RESET ICNVG + IF (ICNVG < 0) ICNVG = 0 + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_cg + + !> @ brief Preconditioned BiConjugate Gradient Stabilized linear accelerator + !! + !! Apply the Preconditioned BiConjugate Gradient Stabilized linear + !! accelerator to the current coefficient matrix, right-hand side, using + !! the currentdependent-variable. + !! + !< + SUBROUTINE ims_base_bcgs(ICNVG, ITMAX, INNERIT, & + NEQ, NJA, NIAPC, NJAPC, & + IPC, NITERC, ICNVGOPT, NORTH, ISCL, DSCALE, & + DVCLOSE, RCLOSE, L2NORM0, EPFACT, & + IA0, JA0, A0, IAPC, JAPC, APC, & + X, B, D, P, Q, & + T, V, DHAT, PHAT, QHAT, & + NJLU, IW, JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + ! -- dummy variables + integer(I4B), INTENT(INOUT) :: ICNVG !< convergence flag (1) non-convergence (0) + integer(I4B), INTENT(IN) :: ITMAX !< maximum number of inner iterations + integer(I4B), INTENT(INOUT) :: INNERIT !< inner iteration count + integer(I4B), INTENT(IN) :: NEQ !< number of equations + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), INTENT(IN) :: NIAPC !< preconditioner number of rows + integer(I4B), INTENT(IN) :: NJAPC !< preconditioner number of non-zero entries + integer(I4B), INTENT(IN) :: IPC !< preconditioner option + integer(I4B), INTENT(INOUT) :: NITERC !< total number of inner iterations + integer(I4B), INTENT(IN) :: ICNVGOPT !< flow convergence criteria option + integer(I4B), INTENT(IN) :: NORTH !< orthogonalization frequency + integer(I4B), INTENT(IN) :: ISCL !< scaling option + real(DP), DIMENSION(NEQ), INTENT(IN) :: DSCALE !< scaling vector + real(DP), INTENT(IN) :: DVCLOSE !< dependent-variable closure criteria + real(DP), INTENT(IN) :: RCLOSE !< flow closure criteria + real(DP), INTENT(IN) :: L2NORM0 !< initial L-2 norm for system of equations + real(DP), INTENT(IN) :: EPFACT !< factor for decreasing flow convergence criteria for subsequent Picard iterations + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA0 !< CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 !< CRS column pointers + real(DP), DIMENSION(NJA), INTENT(IN) :: A0 !< coefficient matrix + integer(I4B), DIMENSION(NIAPC + 1), INTENT(IN) :: IAPC !< preconditioner CRS row pointers + integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC !< preconditioner CRS column pointers + real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC !< preconditioner matrix + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X !< dependent-variable vector + real(DP), DIMENSION(NEQ), INTENT(IN) :: B !< right-hand side vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P !< preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q !< preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: T !< preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: V !< preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DHAT !< BCGS preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: PHAT !< BCGS preconditioner working vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: QHAT !< BCGS preconditioner working vector + ! -- ILUT dummy variables + integer(I4B), INTENT(IN) :: NJLU !< preconditioner length of JLU vector + integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW !< preconditioner integer working vector + integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU !< preconditioner JLU working vector + ! -- convergence information dummy variables + integer(I4B), INTENT(IN) :: NCONV !< maximum number of inner iterations in a time step (maxiter * maxinner) + integer(I4B), INTENT(IN) :: CONVNMOD !< number of models in the solution + integer(I4B), DIMENSION(CONVNMOD + 1), INTENT(INOUT) :: CONVMODSTART !< pointer to the start of each model in the convmod* arrays + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV !< location of the maximum dependent-variable change in the solution + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR !< location of the maximum flow change in the solution + character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL !< convergence string + integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER !< actual number of inner iterations in each Picard iteration + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV !< location of the maximum dependent-variable change in each model in the solution + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR !< location of the maximum flow change in each model in the solution + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX !< maximum dependent-variable change in the solution + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX !< maximum flow change in the solution + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX !< maximum dependent-variable change in each model in the solution + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX !< maximum flow change in each model in the solution + ! -- local variables + LOGICAL :: LORTH + logical :: lsame + character(len=15) :: cval1, cval2 + integer(I4B) :: n + integer(I4B) :: iiter + integer(I4B) :: xloc, rloc + integer(I4B) :: im, im0, im1 + real(DP) :: ddot + real(DP) :: tv + real(DP) :: deltax + real(DP) :: rmax + real(DP) :: l2norm + real(DP) :: rcnvg + real(DP) :: alpha, alpha0 + real(DP) :: beta + real(DP) :: rho, rho0 + real(DP) :: omega, omega0 + real(DP) :: numer, denom + ! + ! -- initialize local variables + INNERIT = 0 + alpha = DZERO + alpha0 = DZERO + beta = DZERO + rho = DZERO + rho0 = DZERO + omega = DZERO + omega0 = DZERO + ! + ! -- SAVE INITIAL RESIDUAL + DO n = 1, NEQ + DHAT(n) = D(n) + END DO + ! + ! -- INNER ITERATION + INNER: DO iiter = 1, itmax + INNERIT = INNERIT + 1 + NITERC = NITERC + 1 + ! + ! -- CALCULATE rho + rho = ddot(NEQ, DHAT, 1, D, 1) + ! + ! -- COMPUTE DIRECTIONAL VECTORS + IF (IITER == 1) THEN + DO n = 1, NEQ + P(n) = D(n) + END DO + ELSE + beta = (rho / rho0) * (alpha0 / omega0) + DO n = 1, NEQ + P(n) = D(n) + beta * (P(n) - omega0 * V(n)) + END DO + END IF + ! + ! -- APPLY PRECONDITIONER TO UPDATE PHAT + SELECT CASE (IPC) + ! + ! -- ILU0 AND MILU0 + CASE (1, 2) + CALL ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, P, PHAT) + ! + ! -- ILUT AND MILUT + CASE (3, 4) + CALL lusol(NEQ, P, PHAT, APC, JLU, IW) + END SELECT + ! + ! -- COMPUTE ITERATES + ! + ! -- UPDATE V WITH A AND PHAT + call amux(NEQ, PHAT, V, A0, JA0, IA0) + ! + ! -- UPDATE alpha WITH DHAT AND V + denom = ddot(NEQ, DHAT, 1, V, 1) + denom = denom + SIGN(DPREC, denom) + alpha = rho / denom + ! + ! -- UPDATE Q + DO n = 1, NEQ + Q(n) = D(n) - alpha * V(n) + END DO + ! + ! ! -- CALCULATE INFINITY NORM OF Q - TEST FOR TERMINATION + ! ! TERMINATE IF rmax IS LESS THAN MACHINE PRECISION (DPREC) + ! rmax = DZERO + ! DO n = 1, NEQ + ! tv = Q(n) + ! IF (ISCL.NE.0 ) tv = tv / DSCALE(n) + ! IF (ABS(tv) > ABS(rmax) ) rmax = tv + ! END DO + ! IF (ABS(rmax).LE.DPREC) THEN + ! deltax = DZERO + ! DO n = 1, NEQ + ! tv = alpha * PHAT(n) + ! IF (ISCL.NE.0) THEN + ! tv = tv * DSCALE(n) + ! END IF + ! X(n) = X(n) + tv + ! IF (ABS(tv) > ABS(deltax) ) deltax = tv + ! END DO + ! CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & + ! deltax, rmax, & + ! rmax, EPFACT, DVCLOSE, RCLOSE ) + ! IF (ICNVG.NE.0 ) EXIT INNER + ! END IF + ! + ! -- APPLY PRECONDITIONER TO UPDATE QHAT + SELECT CASE (IPC) + ! + ! -- ILU0 AND MILU0 + CASE (1, 2) + CALL ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, Q, QHAT) + ! + ! -- ILUT AND MILUT + CASE (3, 4) + CALL lusol(NEQ, Q, QHAT, APC, JLU, IW) + END SELECT + ! + ! -- UPDATE T WITH A AND QHAT + call amux(NEQ, QHAT, T, A0, JA0, IA0) + ! + ! -- UPDATE omega + numer = ddot(NEQ, T, 1, Q, 1) + denom = ddot(NEQ, T, 1, T, 1) + denom = denom + SIGN(DPREC, denom) + omega = numer / denom + ! + ! -- UPDATE X AND RESIDUAL + deltax = DZERO + rmax = DZERO + l2norm = DZERO + DO im = 1, CONVNMOD + DVMAX(im) = DZERO + DRMAX(im) = DZERO + END DO + im = 1 + im0 = CONVMODSTART(1) + im1 = CONVMODSTART(2) + DO n = 1, NEQ + ! + ! -- determine current model index + if (n == im1) then + im = im + 1 + im0 = CONVMODSTART(im) + im1 = CONVMODSTART(im + 1) + end if + ! + ! -- X AND DX + tv = alpha * PHAT(n) + omega * QHAT(n) + X(n) = X(n) + tv + IF (ISCL .NE. 0) THEN + tv = tv * DSCALE(n) + END IF + IF (ABS(tv) > ABS(deltax)) THEN + deltax = tv + xloc = n + END IF + IF (ABS(tv) > ABS(DVMAX(im))) THEN + DVMAX(im) = tv + LOCDV(im) = n + END IF + ! + ! -- RESIDUAL + tv = Q(n) - omega * T(n) + D(n) = tv + IF (ISCL .NE. 0) THEN + tv = tv / DSCALE(n) + END IF + IF (ABS(tv) > ABS(rmax)) THEN + rmax = tv + rloc = n + END IF + IF (ABS(tv) > ABS(DRMAX(im))) THEN + DRMAX(im) = tv + LOCDR(im) = n + END IF + l2norm = l2norm + tv * tv + END DO + l2norm = sqrt(l2norm) + ! + ! -- SAVE SOLVER convergence information dummy variables + IF (NCONV > 1) THEN !< + n = NITERC + WRITE (cval1, '(g15.7)') alpha + WRITE (cval2, '(g15.7)') omega + CACCEL(n) = trim(adjustl(cval1))//','//trim(adjustl(cval2)) + ITINNER(n) = iiter + DO im = 1, CONVNMOD + CONVLOCDV(im, n) = LOCDV(im) + CONVLOCDR(im, n) = LOCDR(im) + CONVDVMAX(im, n) = DVMAX(im) + CONVDRMAX(im, n) = DRMAX(im) + END DO + END IF + ! + ! -- TEST FOR SOLVER CONVERGENCE + IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN + rcnvg = l2norm + ELSE + rcnvg = rmax + END IF + CALL ims_base_testcnvg(ICNVGOPT, ICNVG, INNERIT, & + deltax, rcnvg, & + L2NORM0, EPFACT, DVCLOSE, RCLOSE) + ! + ! -- CHECK FOR EXACT SOLUTION + IF (rcnvg == DZERO) ICNVG = 1 + ! + ! -- CHECK FOR STANDARD CONVERGENCE + IF (ICNVG .NE. 0) EXIT INNER + ! + ! -- CHECK THAT CURRENT AND PREVIOUS rho, alpha, AND omega ARE + ! DIFFERENT + lsame = is_same(rho, rho0) + IF (lsame) THEN + EXIT INNER + END IF + lsame = is_same(alpha, alpha0) + IF (lsame) THEN + EXIT INNER + END IF + lsame = is_same(omega, omega0) + IF (lsame) THEN + EXIT INNER + END IF + ! + ! -- RECALCULATE THE RESIDUAL + IF (NORTH > 0) THEN + LORTH = mod(iiter + 1, NORTH) == 0 + IF (LORTH) THEN + call ims_base_residual(NEQ, NJA, X, B, D, A0, IA0, JA0) + END IF + END IF + ! + ! -- exit inner if rho or omega are zero + if (rho * omega == DZERO) then + exit inner + end if + ! + ! -- SAVE CURRENT INNER ITERATES + rho0 = rho + alpha0 = alpha + omega0 = omega + END DO INNER + ! + ! -- RESET ICNVG + IF (ICNVG < 0) ICNVG = 0 + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_bcgs + + !> @ brief Calculate LORDER AND IORDER + !! + !! Calculate LORDER and IORDER for reordering. + !! + !< + SUBROUTINE ims_base_calc_order(IORD, NEQ, NJA, IA, JA, LORDER, IORDER) + ! -- modules + use SimModule, only: store_error, count_errors + ! -- dummy variables + integer(I4B), INTENT(IN) :: IORD !< reordering optionn + integer(I4B), INTENT(IN) :: NEQ !< number of rows + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< row pointer + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< column pointer + integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: LORDER !< reorder vector + integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IORDER !< inverse of reorder vector + ! -- local variables + character(len=LINELENGTH) :: errmsg + integer(I4B) :: n + integer(I4B) :: nsp + integer(I4B), DIMENSION(:), ALLOCATABLE :: iwork0 + integer(I4B), DIMENSION(:), ALLOCATABLE :: iwork1 + integer(I4B) :: iflag + ! + ! -- initialize lorder and iorder + DO n = 1, NEQ + LORDER(n) = IZERO + IORDER(n) = IZERO + END DO + ! ALLOCATE (iwork0(NEQ)) + SELECT CASE (IORD) + CASE (1) + CALL genrcm(NEQ, NJA, IA, JA, LORDER) + CASE (2) + nsp = 3 * NEQ + 4 * NJA + allocate (iwork0(NEQ)) + allocate (iwork1(nsp)) + CALL ims_odrv(NEQ, NJA, nsp, IA, JA, LORDER, iwork0, & + iwork1, iflag) + IF (iflag .NE. 0) THEN + write (errmsg, '(A,1X,A)') & + 'IMSLINEARSUB_CALC_ORDER ERROR CREATING MINIMUM DEGREE ', & + 'ORDER PERMUTATION ' + call store_error(errmsg) + END IF + ! + ! -- DEALLOCATE TEMPORARY STORAGE + deallocate (iwork0, iwork1) + END SELECT + ! + ! -- GENERATE INVERSE OF LORDER + DO n = 1, NEQ + IORDER(LORDER(n)) = n + END DO + ! + ! -- terminate if errors occured + if (count_errors() > 0) then + call parser%StoreErrorUnit() + end if + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_calc_order + + ! + !> @ brief Scale the coefficient matrix + !! + !! Scale the coefficient matrix (AMAT), the right-hand side (B), + !! and the estimate of the dependent variable (X). + !! + !< + SUBROUTINE ims_base_scale(IOPT, ISCL, NEQ, NJA, IA, JA, AMAT, X, B, & + DSCALE, DSCALE2) + ! -- dummy variables + integer(I4B), INTENT(IN) :: IOPT !< flag to scale (0) or unscale the system of equations + integer(I4B), INTENT(IN) :: ISCL !< scaling option (1) symmetric (2) L-2 norm + integer(I4B), INTENT(IN) :: NEQ !< number of equations + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointer + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointer + real(DP), DIMENSION(NJA), INTENT(INOUT) :: AMAT !< coefficient matrix + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X !< dependent variable + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B !< right-hand side + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE !< first scaling vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE2 !< second scaling vector + ! -- local variables + integer(I4B) :: i, n + integer(I4B) :: id, jc + integer(I4B) :: i0, i1 + real(DP) :: v, c1, c2 + ! + ! -- SCALE SCALE AMAT, X, AND B + IF (IOPT == 0) THEN + ! + ! -- SYMMETRIC SCALING + SELECT CASE (ISCL) + CASE (1) + DO n = 1, NEQ + id = IA(n) + v = AMAT(id) + c1 = DONE / SQRT(ABS(v)) + DSCALE(n) = c1 + DSCALE2(n) = c1 + END DO + ! + ! -- SCALE AMAT -- AMAT = DSCALE(row) * AMAT(i) * DSCALE2(col) + DO n = 1, NEQ + c1 = DSCALE(n) + i0 = IA(n) + i1 = IA(n + 1) - 1 + DO i = i0, i1 + jc = JA(i) + c2 = DSCALE2(jc) + AMAT(i) = c1 * AMAT(i) * c2 + END DO + END DO + ! + ! -- L-2 NORM SCALING + CASE (2) + ! + ! -- SCALE EACH ROW SO THAT THE L-2 NORM IS 1 + DO n = 1, NEQ + c1 = DZERO + i0 = IA(n) + i1 = IA(n + 1) - 1 + DO i = i0, i1 + c1 = c1 + AMAT(i) * AMAT(i) + END DO + c1 = SQRT(c1) + IF (c1 == DZERO) THEN + c1 = DONE + ELSE + c1 = DONE / c1 + END IF + DSCALE(n) = c1 + ! + ! -- INITIAL SCALING OF AMAT -- AMAT = DSCALE(row) * AMAT(i) + DO i = i0, i1 + AMAT(i) = c1 * AMAT(i) + END DO + END DO + ! + ! -- SCALE EACH COLUMN SO THAT THE L-2 NORM IS 1 + DO n = 1, NEQ + DSCALE2(n) = DZERO + END DO + c2 = DZERO + DO n = 1, NEQ + i0 = IA(n) + i1 = IA(n + 1) - 1 + DO i = i0, i1 + jc = JA(i) + c2 = AMAT(i) + DSCALE2(jc) = DSCALE2(jc) + c2 * c2 + END DO + END DO + DO n = 1, NEQ + c2 = DSCALE2(n) + IF (c2 == DZERO) THEN + c2 = DONE + ELSE + c2 = DONE / SQRT(c2) + END IF + DSCALE2(n) = c2 + END DO + ! + ! -- FINAL SCALING OF AMAT -- AMAT = DSCALE2(col) * AMAT(i) + DO n = 1, NEQ + i0 = IA(n) + i1 = IA(n + 1) - 1 + DO i = i0, i1 + jc = JA(i) + c2 = DSCALE2(jc) + AMAT(i) = c2 * AMAT(i) + END DO + END DO + END SELECT + ! + ! -- SCALE X AND B + DO n = 1, NEQ + c1 = DSCALE(n) + c2 = DSCALE2(n) + X(n) = X(n) / c2 + B(n) = B(n) * c1 + END DO + ! + ! -- UNSCALE SCALE AMAT, X, AND B + ELSE + DO n = 1, NEQ + c1 = DSCALE(n) + i0 = IA(n) + i1 = IA(n + 1) - 1 + ! + ! -- UNSCALE AMAT + DO i = i0, i1 + jc = JA(i) + c2 = DSCALE2(jc) + AMAT(i) = (DONE / c1) * AMAT(i) * (DONE / c2) + END DO + ! + ! -- UNSCALE X AND B + c2 = DSCALE2(n) + X(n) = X(n) * c2 + B(n) = B(n) / c1 + END DO + END IF + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_scale + + !> @ brief Update the preconditioner + !! + !! Update the preconditioner using the current coefficient matrix. + !! + !< + SUBROUTINE ims_base_pcu(IOUT, NJA, NEQ, NIAPC, NJAPC, IPC, RELAX, & + AMAT, IA, JA, APC, IAPC, JAPC, IW, W, & + LEVEL, DROPTOL, NJLU, NJW, NWLU, JLU, JW, WLU) + ! -- modules + use SimModule, only: store_error, count_errors + ! -- dummy variables + integer(I4B), INTENT(IN) :: IOUT !< simulation listing file unit + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), INTENT(IN) :: NEQ !< number of equations + integer(I4B), INTENT(IN) :: NIAPC !< preconditioner number of rows + integer(I4B), INTENT(IN) :: NJAPC !< preconditioner number of non-zero entries + integer(I4B), INTENT(IN) :: IPC !< precoditioner (1) ILU0 (2) MILU0 (3) ILUT (4) MILUT + real(DP), INTENT(IN) :: RELAX !< preconditioner relaxation factor for MILU0 and MILUT + real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT !< coefficient matrix + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers + real(DP), DIMENSION(NJAPC), INTENT(INOUT) :: APC !< preconditioner matrix + integer(I4B), DIMENSION(NIAPC + 1), INTENT(INOUT) :: IAPC !< preconditioner CRS row pointers + integer(I4B), DIMENSION(NJAPC), INTENT(INOUT) :: JAPC !< preconditioner CRS column pointers + integer(I4B), DIMENSION(NIAPC), INTENT(INOUT) :: IW !< preconditioner integed work vector + real(DP), DIMENSION(NIAPC), INTENT(INOUT) :: W !< preconditioner work verctor + ! -- ILUT dummy variables + integer(I4B), INTENT(IN) :: LEVEL !< number of levels of fill for ILUT and MILUT + real(DP), INTENT(IN) :: DROPTOL !< drop tolerance + integer(I4B), INTENT(IN) :: NJLU !< length of JLU working vector + integer(I4B), INTENT(IN) :: NJW !< length of JW working vector + integer(I4B), INTENT(IN) :: NWLU !< length of WLU working vector + integer(I4B), DIMENSION(NJLU), INTENT(INOUT) :: JLU !< ILUT/MILUT JLU working vector + integer(I4B), DIMENSION(NJW), INTENT(INOUT) :: JW !< ILUT/MILUT JW working vector + real(DP), DIMENSION(NWLU), INTENT(INOUT) :: WLU !< ILUT/MILUT WLU working vector + ! -- local variables + character(len=LINELENGTH) :: errmsg + character(len=100), dimension(5), parameter :: cerr = & + ["Elimination process has generated a row in L or U whose length is > n.", & + &"The matrix L overflows the array al. ", & + &"The matrix U overflows the array alu. ", & + &"Illegal value for lfil. ", & + &"Zero row encountered. "] + integer(I4B) :: ipcflag + integer(I4B) :: icount + integer(I4B) :: ierr + real(DP) :: delta + ! -- formats +2000 FORMAT(/, ' MATRIX IS SEVERELY NON-DIAGONALLY DOMINANT.', & + /, ' ADDED SMALL VALUE TO PIVOT ', i0, ' TIMES IN', & + ' IMSLINEARSUB_PCU.') + ! + ! -- initialize local variables + ipcflag = 0 + icount = 0 + delta = DZERO + PCSCALE: DO + SELECT CASE (IPC) + ! + ! -- ILU0 AND MILU0 + CASE (1, 2) + CALL ims_base_pcilu0(NJA, NEQ, AMAT, IA, JA, & + APC, IAPC, JAPC, IW, W, & + RELAX, ipcflag, delta) + ! + ! -- ILUT AND MILUT + CASE (3, 4) + ierr = 0 + CALL ilut(NEQ, AMAT, JA, IA, LEVEL, DROPTOL, & + APC, JLU, IW, NJAPC, WLU, JW, ierr, & + relax, ipcflag, delta) + if (ierr /= 0) then + if (ierr > 0) then + write (errmsg, '(a,1x,i0,1x,a)') & + 'ILUT: zero pivot encountered at step number', ierr, '.' + else + write (errmsg, '(a,1x,a)') 'ILUT:', cerr(-ierr) + end if + call store_error(errmsg) + call parser%StoreErrorUnit() + end if + ! + ! -- ADDITIONAL PRECONDITIONERS + CASE DEFAULT + ipcflag = 0 + END SELECT + IF (ipcflag < 1) THEN + EXIT PCSCALE + END IF + delta = 1.5d0 * delta + DEM3 + ipcflag = 0 + IF (delta > DHALF) THEN + delta = DHALF + ipcflag = 2 + END IF + icount = icount + 1 + ! + ! -- terminate pcscale loop if not making progress + if (icount > 10) then + exit PCSCALE + end if + + END DO PCSCALE + ! + ! -- write error message if small value added to pivot + if (icount > 0) then + write (IOUT, 2000) icount + end if + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_pcu + + !> @ brief Jacobi preconditioner + !! + !! Calculate the Jacobi preconditioner (inverse of the diagonal) using + !! the current coefficient matrix. + !! + !< + SUBROUTINE ims_base_pcjac(NJA, NEQ, AMAT, APC, IA, JA) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), INTENT(IN) :: NEQ !< number of equations + real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT !< coefficient matrix + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: APC !< preconditioner matrix + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers + ! -- local variables + integer(I4B) :: i, n + integer(I4B) :: ic0, ic1 + integer(I4B) :: id + real(DP) :: tv + ! -- code + DO n = 1, NEQ + ic0 = IA(n) + ic1 = IA(n + 1) - 1 + id = IA(n) + DO i = ic0, ic1 + IF (JA(i) == n) THEN + id = i + EXIT + END IF + END DO + tv = AMAT(id) + IF (ABS(tv) > DZERO) tv = DONE / tv + APC(n) = tv + END DO + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_pcjac + + !> @ brief Apply the Jacobi preconditioner + !! + !! Apply the Jacobi preconditioner and return the resultant vector. + !! + !< + SUBROUTINE ims_base_jaca(NEQ, A, D1, D2) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NEQ !< number of equations + real(DP), DIMENSION(NEQ), INTENT(IN) :: A !< Jacobi preconditioner + real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 !< input vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D2 !< resultant vector + ! -- local variables + integer(I4B) :: n + real(DP) :: tv + ! -- code + DO n = 1, NEQ + tv = A(n) * D1(n) + D2(n) = tv + END DO + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_jaca + + !> @ brief Update the ILU0 preconditioner + !! + !! Update the ILU0 preconditioner using the current coefficient matrix. + !! + !< + SUBROUTINE ims_base_pcilu0(NJA, NEQ, AMAT, IA, JA, & + APC, IAPC, JAPC, IW, W, & + RELAX, IPCFLAG, DELTA) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), INTENT(IN) :: NEQ !< number of equations + real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT !< coefficient matrix + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers + real(DP), DIMENSION(NJA), INTENT(INOUT) :: APC !< preconditioned matrix + integer(I4B), DIMENSION(NEQ + 1), INTENT(INOUT) :: IAPC !< preconditioner CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC !< preconditioner CRS column pointers + integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IW !< preconditioner integer work vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: W !< preconditioner work vector + real(DP), INTENT(IN) :: RELAX !< MILU0 preconditioner relaxation factor + integer(I4B), INTENT(INOUT) :: IPCFLAG !< preconditioner error flag + real(DP), INTENT(IN) :: DELTA !< factor used to correct non-diagonally dominant matrices + ! -- local variables + integer(I4B) :: ic0, ic1 + integer(I4B) :: iic0, iic1 + integer(I4B) :: iu, iiu + integer(I4B) :: j, n + integer(I4B) :: jj + integer(I4B) :: jcol, jw + integer(I4B) :: jjcol + real(DP) :: drelax + real(DP) :: sd1 + real(DP) :: tl + real(DP) :: rs + real(DP) :: d + ! + ! -- initialize local variables + drelax = RELAX + DO n = 1, NEQ + IW(n) = 0 + W(n) = DZERO + END DO + MAIN: DO n = 1, NEQ + ic0 = IA(n) + ic1 = IA(n + 1) - 1 + DO j = ic0, ic1 + jcol = JA(j) + IW(jcol) = 1 + W(jcol) = W(jcol) + AMAT(j) + END DO + ic0 = IAPC(n) + ic1 = IAPC(n + 1) - 1 + iu = JAPC(n) + rs = DZERO + LOWER: DO j = ic0, iu - 1 + jcol = JAPC(j) + iic0 = IAPC(jcol) + iic1 = IAPC(jcol + 1) - 1 + iiu = JAPC(jcol) + tl = W(jcol) * APC(jcol) + W(jcol) = tl + DO jj = iiu, iic1 + jjcol = JAPC(jj) + jw = IW(jjcol) + IF (jw .NE. 0) THEN + W(jjcol) = W(jjcol) - tl * APC(jj) + ELSE + rs = rs + tl * APC(jj) + END IF + END DO + END DO LOWER + ! + ! -- DIAGONAL - CALCULATE INVERSE OF DIAGONAL FOR SOLUTION + d = W(n) + tl = (DONE + DELTA) * d - (drelax * rs) + ! + ! -- ENSURE THAT THE SIGN OF THE DIAGONAL HAS NOT CHANGED AND IS + sd1 = SIGN(d, tl) + IF (sd1 .NE. d) THEN + ! + ! -- USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR + ! PIVOTS THAT CHANGE THE SIGN OF THE DIAGONAL + IF (IPCFLAG > 1) THEN + tl = SIGN(DEM6, d) + ! + ! -- DIAGONAL SCALING CONTINUES TO BE EFFECTIVE + ELSE + IPCFLAG = 1 + EXIT MAIN + END IF + END IF + IF (ABS(tl) == DZERO) THEN + ! + ! -- USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR + ! ZERO PIVOTS + IF (IPCFLAG > 1) THEN + tl = SIGN(DEM6, d) + ! + ! -- DIAGONAL SCALING CONTINUES TO BE EFFECTIVE FOR ELIMINATING + ELSE + IPCFLAG = 1 + EXIT MAIN + END IF + END IF + APC(n) = DONE / tl + ! + ! -- RESET POINTER FOR IW TO ZERO + IW(n) = 0 + W(n) = DZERO + DO j = ic0, ic1 + jcol = JAPC(j) + APC(j) = W(jcol) + IW(jcol) = 0 + W(jcol) = DZERO + END DO + END DO MAIN + ! + ! -- RESET IPCFLAG IF SUCCESSFUL COMPLETION OF MAIN + IPCFLAG = 0 + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_pcilu0 + + !> @ brief Apply the ILU0 and MILU0 preconditioners + !! + !! Apply the ILU0 and MILU0 preconditioners to the passed vector (R). + !! + !< + SUBROUTINE ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, R, D) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries + integer(I4B), INTENT(IN) :: NEQ !< number of equations + real(DP), DIMENSION(NJA), INTENT(IN) :: APC !< ILU0/MILU0 preconditioner matrix + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IAPC !< ILU0/MILU0 preconditioner CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JAPC !< ILU0/MILU0 preconditioner CRS column pointers + real(DP), DIMENSION(NEQ), INTENT(IN) :: R !< input vector + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< output vector after applying APC to R + ! -- local variables + integer(I4B) :: ic0, ic1 + integer(I4B) :: iu + integer(I4B) :: jcol + integer(I4B) :: j, n + real(DP) :: tv + ! + ! -- FORWARD SOLVE - APC * D = R + FORWARD: DO n = 1, NEQ + tv = R(n) + ic0 = IAPC(n) + ic1 = IAPC(n + 1) - 1 + iu = JAPC(n) - 1 + LOWER: DO j = ic0, iu + jcol = JAPC(j) + tv = tv - APC(j) * D(jcol) + END DO LOWER + D(n) = tv + END DO FORWARD + ! + ! -- BACKWARD SOLVE - D = D / U + BACKWARD: DO n = NEQ, 1, -1 + ic0 = IAPC(n) + ic1 = IAPC(n + 1) - 1 + iu = JAPC(n) + tv = D(n) + UPPER: DO j = iu, ic1 + jcol = JAPC(j) + tv = tv - APC(j) * D(jcol) + END DO UPPER + ! + ! -- COMPUTE D FOR DIAGONAL - D = D / U + D(n) = tv * APC(n) + END DO BACKWARD + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_ilu0a + + !> @ brief Test for solver convergence + !! + !! General routine for testing for solver convergence based on the + !! user-specified convergence option (Icnvgopt). + !< + ! + ! -- TEST FOR SOLVER CONVERGENCE + SUBROUTINE ims_base_testcnvg(Icnvgopt, Icnvg, Iiter, & + Dvmax, Rmax, & + Rmax0, Epfact, Dvclose, Rclose) + ! -- dummy variables + integer(I4B), INTENT(IN) :: Icnvgopt !< convergence option - see documentation for option + integer(I4B), INTENT(INOUT) :: Icnvg !< flag indicating if convergence achieved (1) or not (0) + integer(I4B), INTENT(IN) :: Iiter !< inner iteration number (used for strict convergence option) + real(DP), INTENT(IN) :: Dvmax !< maximum dependent-variable change + real(DP), INTENT(IN) :: Rmax !< maximum flow change + real(DP), INTENT(IN) :: Rmax0 !< initial flow change (initial L2-norm) + real(DP), INTENT(IN) :: Epfact !< factor for reducing convergence criteria in subsequent Picard iterations + real(DP), INTENT(IN) :: Dvclose !< Maximum depenendent-variable change allowed + real(DP), INTENT(IN) :: Rclose !< Maximum flow change alowed + ! -- code + IF (Icnvgopt == 0) THEN + IF (ABS(Dvmax) <= Dvclose .AND. ABS(Rmax) <= Rclose) THEN + Icnvg = 1 + END IF + ELSE IF (Icnvgopt == 1) THEN + IF (ABS(Dvmax) <= Dvclose .AND. ABS(Rmax) <= Rclose) THEN + IF (iiter == 1) THEN + Icnvg = 1 + ELSE + Icnvg = -1 + END IF + END IF + ELSE IF (Icnvgopt == 2) THEN + IF (ABS(Dvmax) <= Dvclose .OR. Rmax <= Rclose) THEN + Icnvg = 1 + ELSE IF (Rmax <= Rmax0 * Epfact) THEN + Icnvg = -1 + END IF + ELSE IF (Icnvgopt == 3) THEN + IF (ABS(Dvmax) <= Dvclose) THEN + Icnvg = 1 + ELSE IF (Rmax <= Rmax0 * Rclose) THEN + Icnvg = -1 + END IF + ELSE IF (Icnvgopt == 4) THEN + IF (ABS(Dvmax) <= Dvclose .AND. Rmax <= Rclose) THEN + Icnvg = 1 + ELSE IF (Rmax <= Rmax0 * Epfact) THEN + Icnvg = -1 + END IF + END IF + ! + ! -- return + RETURN + END SUBROUTINE ims_base_testcnvg + + !> @ brief Generate CRS pointers for the preconditioner + !! + !! Generate the CRS row and column pointers for the preconditioner. + !! JAPC(1:NEQ) hHas the position of the upper entry for a row, + !! JAPC(NEQ+1:NJA) is the column position for entry, + !! APC(1:NEQ) is the preconditioned inverse of the diagonal, and + !! APC(NEQ+1:NJA) are the preconditioned entries for off diagonals. + !< + SUBROUTINE ims_base_pccrs(NEQ, NJA, IA, JA, & + IAPC, JAPC) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NEQ !< + integer(I4B), INTENT(IN) :: NJA !< + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< + integer(I4B), DIMENSION(NEQ + 1), INTENT(INOUT) :: IAPC !< + integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC !< + ! -- local variables + integer(I4B) :: n, j + integer(I4B) :: i0, i1 + integer(I4B) :: nlen + integer(I4B) :: ic, ip + integer(I4B) :: jcol + integer(I4B), DIMENSION(:), ALLOCATABLE :: iarr + ! -- code + ip = NEQ + 1 + DO n = 1, NEQ + i0 = IA(n) + i1 = IA(n + 1) - 1 + nlen = i1 - i0 + ALLOCATE (iarr(nlen)) + ic = 0 + DO j = i0, i1 + jcol = JA(j) + IF (jcol == n) CYCLE + ic = ic + 1 + iarr(ic) = jcol + END DO + CALL ims_base_isort(nlen, iarr) + IAPC(n) = ip + DO j = 1, nlen + jcol = iarr(j) + JAPC(ip) = jcol + ip = ip + 1 + END DO + DEALLOCATE (iarr) + END DO + IAPC(NEQ + 1) = NJA + 1 + ! + ! -- POSITION OF THE FIRST UPPER ENTRY FOR ROW + DO n = 1, NEQ + i0 = IAPC(n) + i1 = IAPC(n + 1) - 1 + JAPC(n) = IAPC(n + 1) + DO j = i0, i1 + jcol = JAPC(j) + IF (jcol > n) THEN + JAPC(n) = j + EXIT + END IF + END DO + END DO + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_pccrs + + !> @brief In-place sorting for an integer array + !! + !! Subroutine sort an integer array in-place. + !! + !< + SUBROUTINE ims_base_isort(NVAL, IARRAY) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NVAL !< length of the interger array + integer(I4B), DIMENSION(NVAL), INTENT(INOUT) :: IARRAY !< integer array to be sorted + ! -- local variables + integer(I4B) :: i, j, itemp + ! -- code + DO i = 1, NVAL - 1 + DO j = i + 1, NVAL + if (IARRAY(i) > IARRAY(j)) then + itemp = IARRAY(j) + IARRAY(j) = IARRAY(i) + IARRAY(i) = itemp + END IF + END DO + END DO + ! + ! -- RETURN + RETURN + END SUBROUTINE ims_base_isort + + !> @brief Calculate residual + !! + !! Subroutine to calculate the residual. + !! + !< + SUBROUTINE ims_base_residual(NEQ, NJA, X, B, D, A, IA, JA) + ! -- dummy variables + integer(I4B), INTENT(IN) :: NEQ !< length of vectors + integer(I4B), INTENT(IN) :: NJA !< length of coefficient matrix + real(DP), DIMENSION(NEQ), INTENT(IN) :: X !< dependent variable + real(DP), DIMENSION(NEQ), INTENT(IN) :: B !< right-hand side + real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< residual + real(DP), DIMENSION(NJA), INTENT(IN) :: A !< coefficient matrix + integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers + integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers + ! -- local variables + integer(I4B) :: n + ! -- code + ! + ! -- calculate matrix-vector product + call amux(NEQ, X, D, A, JA, IA) + ! + ! -- subtract matrix-vector product from right-hand side + DO n = 1, NEQ + D(n) = B(n) - D(n) + END DO + ! + ! -- return + RETURN + END SUBROUTINE ims_base_residual + +END MODULE IMSLinearBaseModule diff --git a/src/Solution/LinearMethods/ims8linear.f90 b/src/Solution/LinearMethods/ims8linear.f90 new file mode 100644 index 00000000000..c1015d69dfe --- /dev/null +++ b/src/Solution/LinearMethods/ims8linear.f90 @@ -0,0 +1,1016 @@ +MODULE IMSLinearModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, LENMEMPATH, & + IZERO, DZERO, DPREC, DSAME, & + DEM8, DEM6, DEM5, DEM4, DEM3, DEM2, DEM1, & + DHALF, DONE, DTWO, & + VDEBUG + use GenericUtilitiesModule, only: sim_message + use IMSLinearBaseModule, only: ims_base_cg, ims_base_bcgs, & + ims_base_pccrs, ims_base_calc_order, & + ims_base_scale, ims_base_pcu, & + ims_base_residual + use BlockParserModule, only: BlockParserType + + IMPLICIT NONE + private + + TYPE, PUBLIC :: ImsLinearDataType + character(len=LENMEMPATH) :: memoryPath !< the path for storing variables in the memory manager + integer(I4B), POINTER :: iout => NULL() !< simulation listing file unit + integer(I4B), POINTER :: IPRIMS => NULL() !< print flag + integer(I4B), POINTER :: ILINMETH => NULL() !< linear accelerator (1) cg, (2) bicgstab + integer(I4B), POINTER :: ITER1 => NULL() !< maximum inner iterations + integer(I4B), POINTER :: IPC => NULL() !< preconditioner flag + integer(I4B), POINTER :: ISCL => NULL() !< scaling flag + integer(I4B), POINTER :: IORD => NULL() !< reordering flag + integer(I4B), POINTER :: NORTH => NULL() !< orthogonalization interval + integer(I4B), POINTER :: ICNVGOPT => NULL() !< rclose convergence option flag + integer(I4B), POINTER :: IACPC => NULL() !< preconditioner CRS row pointers + integer(I4B), POINTER :: NITERC => NULL() !< + integer(I4B), POINTER :: NIABCGS => NULL() !< size of working vectors for BCGS linear accelerator + integer(I4B), POINTER :: NIAPC => NULL() !< preconditioner number of rows + integer(I4B), POINTER :: NJAPC => NULL() !< preconditioner number of non-zero entries + real(DP), POINTER :: DVCLOSE => NULL() !< dependent variable convergence criteria + real(DP), POINTER :: RCLOSE => NULL() !< flow convergence criteria + real(DP), POINTER :: RELAX => NULL() !< preconditioner MILU0/MILUT relaxation factor + real(DP), POINTER :: EPFACT => NULL() !< factor for decreasing convergence criteria in seubsequent Picard iterations + real(DP), POINTER :: L2NORM0 => NULL() !< initial L2 norm + ! -- ilut variables + integer(I4B), POINTER :: LEVEL => NULL() !< preconditioner number of levels + real(DP), POINTER :: DROPTOL => NULL() !< preconditioner drop tolerance + integer(I4B), POINTER :: NJLU => NULL() !< length of jlu work vector + integer(I4B), POINTER :: NJW => NULL() !< length of jw work vector + integer(I4B), POINTER :: NWLU => NULL() !< length of wlu work vector + ! -- pointers to solution variables + integer(I4B), POINTER :: NEQ => NULL() !< number of equations (rows in matrix) + integer(I4B), POINTER :: NJA => NULL() !< number of non-zero values in amat + integer(I4B), dimension(:), pointer, contiguous :: IA => NULL() !< position of start of each row + integer(I4B), dimension(:), pointer, contiguous :: JA => NULL() !< column pointer + real(DP), dimension(:), pointer, contiguous :: AMAT => NULL() !< coefficient matrix + real(DP), dimension(:), pointer, contiguous :: RHS => NULL() !< right-hand side of equation + real(DP), dimension(:), pointer, contiguous :: X => NULL() !< dependent variable + ! VECTORS + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE => NULL() !< scaling factor + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE2 => NULL() !< unscaling factor + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IAPC => NULL() !< position of start of each row in preconditioner matrix + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JAPC => NULL() !< preconditioner matrix column pointer + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: APC => NULL() !< preconditioner coefficient matrix + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: LORDER => NULL() !< reordering mapping + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IORDER => NULL() !< mapping to restore reordered matrix + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IARO => NULL() !< position of start of each row in reordered matrix + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JARO => NULL() !< reordered matrix column pointer + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: ARO => NULL() !< reordered coefficient matrix + ! WORKING ARRAYS + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IW => NULL() !< integer working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: W => NULL() !< real working array + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: ID => NULL() !< integer working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: D => NULL() !< real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: P => NULL() !< real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Q => NULL() !< real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Z => NULL() !< real working array + ! BICGSTAB WORKING ARRAYS + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: T => NULL() !< BICGSTAB real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: V => NULL() !< BICGSTAB real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DHAT => NULL() !< BICGSTAB real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: PHAT => NULL() !< BICGSTAB real working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: QHAT => NULL() !< rBICGSTAB eal working array + ! POINTERS FOR USE WITH BOTH ORIGINAL AND RCM ORDERINGS + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IA0 => NULL() !< pointer to current CRS row pointers + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JA0 => NULL() !< pointer to current CRS column pointers + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: A0 => NULL() !< pointer to current coefficient matrix + ! ILUT WORKING ARRAYS + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JLU => NULL() !< ilut integer working array + integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JW => NULL() !< ilut integer working array + real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: WLU => NULL() !< ilut real working array + + ! PROCEDURES (METHODS) + CONTAINS + PROCEDURE :: IMSLINEAR_ALLOCATE => imslinear_ar + procedure :: imslinear_summary + PROCEDURE :: IMSLINEAR_APPLY => imslinear_ap + procedure :: IMSLINEAR_DA => imslinear_da + procedure, private :: allocate_scalars + ! -- PRIVATE PROCEDURES + PROCEDURE, PRIVATE :: SET_IMSLINEAR_INPUT => imslinear_set_input + END TYPE ImsLinearDataType + +CONTAINS + + !> @ brief Allocate storage and read data + !! + !! Allocate storage for linear accelerators and read data + !! + !< + SUBROUTINE imslinear_ar(this, NAME, parser, IOUT, IPRIMS, MXITER, IFDPARAM, & + IMSLINEARM, NEQ, NJA, IA, JA, AMAT, RHS, X, & + NINNER, LFINDBLOCK) + ! -- modules + use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path + use SimModule, only: store_error, count_errors, & + deprecation_warning + ! -- dummy variables + CLASS(ImsLinearDataType), INTENT(INOUT) :: this !< ImsLinearDataType instance + CHARACTER(LEN=LENSOLUTIONNAME), INTENT(IN) :: NAME !< solution name + type(BlockParserType) :: parser !< block parser + integer(I4B), INTENT(IN) :: IOUT !< simulation listing file unit + integer(I4B), TARGET, INTENT(IN) :: IPRIMS !< print option + integer(I4B), INTENT(IN) :: MXITER !< maximum outer iterations + integer(I4B), INTENT(IN) :: IFDPARAM !< complexity option + integer(I4B), INTENT(INOUT) :: IMSLINEARM !< linear method option (1) CG (2) BICGSTAB + integer(I4B), TARGET, INTENT(IN) :: NEQ !< number of equations + integer(I4B), TARGET, INTENT(IN) :: NJA !< number of non-zero entries in the coefficient matrix + integer(I4B), DIMENSION(NEQ + 1), TARGET, INTENT(IN) :: IA !< pointer to the start of a row in the coefficient matrix + integer(I4B), DIMENSION(NJA), TARGET, INTENT(IN) :: JA !< column pointer + real(DP), DIMENSION(NJA), TARGET, INTENT(IN) :: AMAT !< coefficient matrix + real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: RHS !< right-hand side + real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: X !< dependent variables + integer(I4B), TARGET, INTENT(INOUT) :: NINNER !< maximum number of inner iterations + integer(I4B), INTENT(IN), OPTIONAL :: LFINDBLOCK !< flag indicating if the linear block is present (1) or missing (0) + + ! -- local variables + LOGICAL :: lreaddata + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: warnmsg + character(len=LINELENGTH) :: keyword + integer(I4B) :: i, n + integer(I4B) :: i0 + integer(I4B) :: iscllen, iolen + integer(I4B) :: ierr + real(DP) :: r + logical :: isfound, endOfBlock + integer(I4B) :: ijlu + integer(I4B) :: ijw + integer(I4B) :: iwlu + integer(I4B) :: iwk + ! + ! -- SET LREADDATA + IF (PRESENT(LFINDBLOCK)) THEN + IF (LFINDBLOCK < 1) THEN + lreaddata = .FALSE. + ELSE + lreaddata = .TRUE. + END IF + ELSE + lreaddata = .TRUE. + END IF + ! + ! -- DEFINE NAME + this%memoryPath = create_mem_path(name, 'IMSLINEAR') + ! + ! -- SET POINTERS TO SOLUTION STORAGE + this%IPRIMS => IPRIMS + this%NEQ => NEQ + this%NJA => NJA + this%IA => IA + this%JA => JA + this%AMAT => AMAT + this%RHS => RHS + this%X => X + ! + ! -- ALLOCATE SCALAR VARIABLES + call this%allocate_scalars() + ! + ! -- initialize iout + this%iout = iout + ! + ! -- DEFAULT VALUES + this%IORD = 0 + this%ISCL = 0 + this%IPC = 0 + this%LEVEL = 0 + ! + ! -- TRANSFER COMMON VARIABLES FROM IMS TO IMSLINEAR + this%ILINMETH = 0 + + this%IACPC = 0 + this%RELAX = DZERO !0.97 + + this%DROPTOL = DZERO + + this%NORTH = 0 + + this%ICNVGOPT = 0 + ! + ! -- PRINT A MESSAGE IDENTIFYING IMSLINEAR SOLVER PACKAGE + write (iout, 2000) +02000 FORMAT(1X, /1X, 'IMSLINEAR -- UNSTRUCTURED LINEAR SOLUTION', & + ' PACKAGE, VERSION 8, 04/28/2017') + ! + ! -- SET DEFAULT IMSLINEAR PARAMETERS + CALL this%SET_IMSLINEAR_INPUT(IFDPARAM) + NINNER = this%iter1 + ! + ! -- get IMSLINEAR block + if (lreaddata) then + call parser%GetBlock('LINEAR', isfound, ierr, & + supportOpenClose=.true., blockRequired=.FALSE.) + else + isfound = .FALSE. + end if + ! + ! -- parse IMSLINEAR block if detected + if (isfound) then + write (iout, '(/1x,a)') 'PROCESSING LINEAR DATA' + do + call parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call parser%GetStringCaps(keyword) + ! -- parse keyword + select case (keyword) + case ('INNER_DVCLOSE') + this%DVCLOSE = parser%GetDouble() + case ('INNER_RCLOSE') + this%rclose = parser%GetDouble() + ! -- look for additional key words + call parser%GetStringCaps(keyword) + if (keyword == 'STRICT') then + this%ICNVGOPT = 1 + else if (keyword == 'L2NORM_RCLOSE') then + this%ICNVGOPT = 2 + else if (keyword == 'RELATIVE_RCLOSE') then + this%ICNVGOPT = 3 + else if (keyword == 'L2NORM_RELATIVE_RCLOSE') then + this%ICNVGOPT = 4 + end if + case ('INNER_MAXIMUM') + i = parser%GetInteger() + this%iter1 = i + NINNER = i + case ('LINEAR_ACCELERATION') + call parser%GetStringCaps(keyword) + if (keyword .eq. 'CG') then + this%ILINMETH = 1 + else if (keyword .eq. 'BICGSTAB') then + this%ILINMETH = 2 + else + this%ILINMETH = 0 + write (errmsg, '(3a)') & + 'UNKNOWN IMSLINEAR LINEAR_ACCELERATION METHOD (', & + trim(keyword), ').' + call store_error(errmsg) + end if + case ('SCALING_METHOD') + call parser%GetStringCaps(keyword) + i = 0 + if (keyword .eq. 'NONE') then + i = 0 + else if (keyword .eq. 'DIAGONAL') then + i = 1 + else if (keyword .eq. 'L2NORM') then + i = 2 + else + write (errmsg, '(3a)') & + 'UNKNOWN IMSLINEAR SCALING_METHOD (', trim(keyword), ').' + call store_error(errmsg) + end if + this%ISCL = i + case ('RED_BLACK_ORDERING') + i = 0 + case ('REORDERING_METHOD') + call parser%GetStringCaps(keyword) + i = 0 + if (keyword == 'NONE') then + i = 0 + else if (keyword == 'RCM') then + i = 1 + else if (keyword == 'MD') then + i = 2 + else + write (errmsg, '(3a)') & + 'UNKNOWN IMSLINEAR REORDERING_METHOD (', trim(keyword), ').' + call store_error(errmsg) + end if + this%IORD = i + case ('NUMBER_ORTHOGONALIZATIONS') + this%north = parser%GetInteger() + case ('RELAXATION_FACTOR') + this%relax = parser%GetDouble() + case ('PRECONDITIONER_LEVELS') + i = parser%GetInteger() + this%level = i + if (i < 0) then + write (errmsg, '(a,1x,a)') & + 'IMSLINEAR PRECONDITIONER_LEVELS MUST BE GREATER THAN', & + 'OR EQUAL TO ZERO' + call store_error(errmsg) + end if + case ('PRECONDITIONER_DROP_TOLERANCE') + r = parser%GetDouble() + this%DROPTOL = r + if (r < DZERO) then + write (errmsg, '(a,1x,a)') & + 'IMSLINEAR PRECONDITIONER_DROP_TOLERANCE', & + 'MUST BE GREATER THAN OR EQUAL TO ZERO' + call store_error(errmsg) + end if + ! + ! -- deprecated variables + case ('INNER_HCLOSE') + this%DVCLOSE = parser%GetDouble() + ! + ! -- create warning message + write (warnmsg, '(a)') & + 'SETTING INNER_DVCLOSE TO INNER_HCLOSE VALUE' + ! + ! -- create deprecation warning + call deprecation_warning('LINEAR', 'INNER_HCLOSE', '6.1.1', & + warnmsg, parser%GetUnit()) + ! + ! -- default + case default + write (errmsg, '(3a)') & + 'UNKNOWN IMSLINEAR KEYWORD (', trim(keyword), ').' + call store_error(errmsg) + end select + end do + write (iout, '(1x,a)') 'END OF LINEAR DATA' + else + if (IFDPARAM == 0) THEN + write (errmsg, '(a)') 'NO LINEAR BLOCK DETECTED.' + call store_error(errmsg) + end if + end if + + IMSLINEARM = this%ILINMETH + ! + ! -- DETERMINE PRECONDITIONER + IF (this%LEVEL > 0 .OR. this%DROPTOL > DZERO) THEN + this%IPC = 3 + ELSE + this%IPC = 1 + END IF + IF (this%RELAX > DZERO) THEN + this%IPC = this%IPC + 1 + END IF + ! + ! -- ERROR CHECKING FOR OPTIONS + IF (this%ISCL < 0) this%ISCL = 0 + IF (this%ISCL > 2) THEN + WRITE (errmsg, '(A)') 'IMSLINEAR7AR ISCL MUST BE <= 2' + call store_error(errmsg) + END IF + IF (this%IORD < 0) this%IORD = 0 + IF (this%IORD > 2) THEN + WRITE (errmsg, '(A)') 'IMSLINEAR7AR IORD MUST BE <= 2' + call store_error(errmsg) + END IF + IF (this%NORTH < 0) THEN + WRITE (errmsg, '(A)') 'IMSLINEAR7AR NORTH MUST >= 0' + call store_error(errmsg) + END IF + IF (this%RCLOSE == DZERO) THEN + IF (this%ICNVGOPT /= 3) THEN + WRITE (errmsg, '(A)') 'IMSLINEAR7AR RCLOSE MUST > 0.0' + call store_error(errmsg) + END IF + END IF + IF (this%RELAX < DZERO) THEN + WRITE (errmsg, '(A)') 'IMSLINEAR7AR RELAX MUST BE >= 0.0' + call store_error(errmsg) + END IF + IF (this%RELAX > DONE) THEN + WRITE (errmsg, '(A)') 'IMSLINEAR7AR RELAX MUST BE <= 1.0' + call store_error(errmsg) + END IF + ! + ! -- CHECK FOR ERRORS IN IMSLINEAR + if (count_errors() > 0) then + call parser%StoreErrorUnit() + end if + ! + ! -- INITIALIZE IMSLINEAR VARIABLES + this%NITERC = 0 + ! + ! -- ALLOCATE AND INITIALIZE MEMORY FOR IMSLINEAR + iscllen = 1 + IF (this%ISCL .NE. 0) iscllen = NEQ + CALL mem_allocate(this%DSCALE, iscllen, 'DSCALE', TRIM(this%memoryPath)) + CALL mem_allocate(this%DSCALE2, iscllen, 'DSCALE2', TRIM(this%memoryPath)) + ! + ! -- ALLOCATE MEMORY FOR PRECONDITIONING MATRIX + ijlu = 1 + ijw = 1 + iwlu = 1 + ! + ! -- ILU0 AND MILU0 + this%NIAPC = this%NEQ + this%NJAPC = this%NJA + ! + ! -- ILUT AND MILUT + IF (this%IPC == 3 .OR. this%IPC == 4) THEN + this%NIAPC = this%NEQ + IF (this%LEVEL > 0) THEN + iwk = this%NEQ * (this%LEVEL * 2 + 1) + ELSE + iwk = 0 + DO n = 1, NEQ + i = IA(n + 1) - IA(n) + IF (i > iwk) THEN + iwk = i + END IF + END DO + iwk = this%NEQ * iwk + END IF + this%NJAPC = iwk + ijlu = iwk + ijw = 2 * this%NEQ + iwlu = this%NEQ + 1 + END IF + this%NJLU = ijlu + this%NJW = ijw + this%NWLU = iwlu + ! + ! -- ALLOCATE BASE PRECONDITIONER VECTORS + CALL mem_allocate(this%IAPC, this%NIAPC + 1, 'IAPC', TRIM(this%memoryPath)) + CALL mem_allocate(this%JAPC, this%NJAPC, 'JAPC', TRIM(this%memoryPath)) + CALL mem_allocate(this%APC, this%NJAPC, 'APC', TRIM(this%memoryPath)) + ! + ! -- ALLOCATE MEMORY FOR ILU0 AND MILU0 NON-ZERO ROW ENTRY VECTOR + CALL mem_allocate(this%IW, this%NIAPC, 'IW', TRIM(this%memoryPath)) + CALL mem_allocate(this%W, this%NIAPC, 'W', TRIM(this%memoryPath)) + ! + ! -- ALLOCATE MEMORY FOR ILUT VECTORS + CALL mem_allocate(this%JLU, ijlu, 'JLU', TRIM(this%memoryPath)) + CALL mem_allocate(this%JW, ijw, 'JW', TRIM(this%memoryPath)) + CALL mem_allocate(this%WLU, iwlu, 'WLU', TRIM(this%memoryPath)) + ! + ! -- GENERATE IAPC AND JAPC FOR ILU0 AND MILU0 + IF (this%IPC == 1 .OR. this%IPC == 2) THEN + CALL ims_base_pccrs(this%NEQ, this%NJA, this%IA, this%JA, & + this%IAPC, this%JAPC) + END IF + ! + ! -- ALLOCATE SPACE FOR PERMUTATION VECTOR + i0 = 1 + iolen = 1 + IF (this%IORD .NE. 0) THEN + i0 = this%NEQ + iolen = this%NJA + END IF + CALL mem_allocate(this%LORDER, i0, 'LORDER', TRIM(this%memoryPath)) + CALL mem_allocate(this%IORDER, i0, 'IORDER', TRIM(this%memoryPath)) + CALL mem_allocate(this%IARO, i0 + 1, 'IARO', TRIM(this%memoryPath)) + CALL mem_allocate(this%JARO, iolen, 'JARO', TRIM(this%memoryPath)) + CALL mem_allocate(this%ARO, iolen, 'ARO', TRIM(this%memoryPath)) + ! + ! -- ALLOCATE WORKING VECTORS FOR IMSLINEAR SOLVER + CALL mem_allocate(this%ID, this%NEQ, 'ID', TRIM(this%memoryPath)) + CALL mem_allocate(this%D, this%NEQ, 'D', TRIM(this%memoryPath)) + CALL mem_allocate(this%P, this%NEQ, 'P', TRIM(this%memoryPath)) + CALL mem_allocate(this%Q, this%NEQ, 'Q', TRIM(this%memoryPath)) + CALL mem_allocate(this%Z, this%NEQ, 'Z', TRIM(this%memoryPath)) + ! + ! -- ALLOCATE MEMORY FOR BCGS WORKING ARRAYS + this%NIABCGS = 1 + IF (this%ILINMETH == 2) THEN + this%NIABCGS = this%NEQ + END IF + CALL mem_allocate(this%T, this%NIABCGS, 'T', TRIM(this%memoryPath)) + CALL mem_allocate(this%V, this%NIABCGS, 'V', TRIM(this%memoryPath)) + CALL mem_allocate(this%DHAT, this%NIABCGS, 'DHAT', TRIM(this%memoryPath)) + CALL mem_allocate(this%PHAT, this%NIABCGS, 'PHAT', TRIM(this%memoryPath)) + CALL mem_allocate(this%QHAT, this%NIABCGS, 'QHAT', TRIM(this%memoryPath)) + ! + ! -- INITIALIZE IMSLINEAR VECTORS + DO n = 1, iscllen + this%DSCALE(n) = DONE + this%DSCALE2(n) = DONE + END DO + DO n = 1, this%NJAPC + this%APC(n) = DZERO + END DO + ! + ! -- WORKING VECTORS + DO n = 1, this%NEQ + this%ID(n) = IZERO + this%D(n) = DZERO + this%P(n) = DZERO + this%Q(n) = DZERO + this%Z(n) = DZERO + END DO + DO n = 1, this%NIAPC + this%IW(n) = IZERO + this%W(n) = DZERO + END DO + ! + ! -- BCGS WORKING VECTORS + DO n = 1, this%NIABCGS + this%T(n) = DZERO + this%V(n) = DZERO + this%DHAT(n) = DZERO + this%PHAT(n) = DZERO + this%QHAT(n) = DZERO + END DO + ! + ! -- ILUT AND MILUT WORKING VECTORS + DO n = 1, ijlu + this%JLU(n) = DZERO + END DO + DO n = 1, ijw + this%JW(n) = DZERO + END DO + DO n = 1, iwlu + this%WLU(n) = DZERO + END DO + ! + ! -- REORDERING VECTORS + DO n = 1, i0 + 1 + this%IARO(n) = IZERO + END DO + DO n = 1, iolen + this%JARO(n) = IZERO + this%ARO(n) = DZERO + END DO + ! + ! -- REVERSE CUTHILL MCKEE AND MINIMUM DEGREE ORDERING + IF (this%IORD .NE. 0) THEN + CALL ims_base_calc_order(this%IORD, this%NEQ, this%NJA, this%IA, & + this%JA, this%LORDER, this%IORDER) + END IF + ! + ! -- ALLOCATE MEMORY FOR STORING ITERATION CONVERGENCE DATA + ! + ! -- RETURN + RETURN + END SUBROUTINE imslinear_ar + + !> @ brief Write summary of settings + !! + !! Write summary of linear accelerator settings. + !! + !< + subroutine imslinear_summary(this, mxiter) + ! -- dummy variables + class(ImsLinearDataType), intent(inout) :: this !< ImsLinearDataType instance + integer(I4B), intent(in) :: mxiter !< maximum number of outer iterations + ! -- local variables + CHARACTER(LEN=10) :: clin(0:2) + CHARACTER(LEN=31) :: clintit(0:2) + CHARACTER(LEN=20) :: cipc(0:4) + CHARACTER(LEN=20) :: cscale(0:2) + CHARACTER(LEN=25) :: corder(0:2) + CHARACTER(LEN=16), DIMENSION(0:4) :: ccnvgopt + CHARACTER(LEN=15) :: clevel + CHARACTER(LEN=15) :: cdroptol + integer(I4B) :: i + integer(I4B) :: j + ! -- data + DATA clin/'UNKNOWN ', & + &'CG ', & + &'BCGS '/ + DATA clintit/' UNKNOWN ', & + &' CONJUGATE-GRADIENT ', & + &'BICONJUGATE-GRADIENT STABILIZED'/ + DATA cipc/'UNKNOWN ', & + &'INCOMPLETE LU ', & + &'MOD. INCOMPLETE LU ', & + &'INCOMPLETE LUT ', & + &'MOD. INCOMPLETE LUT '/ + DATA cscale/'NO SCALING ', & + &'SYMMETRIC SCALING ', & + &'L2 NORM SCALING '/ + DATA corder/'ORIGINAL ORDERING ', & + &'RCM ORDERING ', & + &'MINIMUM DEGREE ORDERING '/ + DATA ccnvgopt/'INFINITY NORM ', & + &'INFINITY NORM S ', & + &'L2 NORM ', & + &'RELATIVE L2NORM ', & + &'L2 NORM W. REL. '/ + ! -- formats +02010 FORMAT(1X, /, 7X, 'SOLUTION BY THE', 1X, A31, 1X, 'METHOD', & + /, 1X, 66('-'), /, & + ' MAXIMUM OF ', I0, ' CALLS OF SOLUTION ROUTINE', /, & + ' MAXIMUM OF ', I0, & + ' INTERNAL ITERATIONS PER CALL TO SOLUTION ROUTINE', /, & + ' LINEAR ACCELERATION METHOD =', 1X, A, /, & + ' MATRIX PRECONDITIONING TYPE =', 1X, A, /, & + ' MATRIX SCALING APPROACH =', 1X, A, /, & + ' MATRIX REORDERING APPROACH =', 1X, A, /, & + ' NUMBER OF ORTHOGONALIZATIONS =', 1X, I0, /, & + ' HEAD CHANGE CRITERION FOR CLOSURE =', E15.5, /, & + ' RESIDUAL CHANGE CRITERION FOR CLOSURE =', E15.5, /, & + ' RESIDUAL CONVERGENCE OPTION =', 1X, I0, /, & + ' RESIDUAL CONVERGENCE NORM =', 1X, A, /, & + ' RELAXATION FACTOR =', E15.5) +02015 FORMAT(' NUMBER OF LEVELS =', A15, /, & + ' DROP TOLERANCE =', A15, //) +2030 FORMAT(1X, A20, 1X, 6(I6, 1X)) +2040 FORMAT(1X, 20('-'), 1X, 6(6('-'), 1X)) +2050 FORMAT(1X, 62('-'),/) ! +! -- ----------------------------------------------------------- + ! + ! -- initialize clevel and cdroptol + clevel = '' + cdroptol = '' + ! + ! -- write common variables to all linear accelerators + write (this%iout, 2010) & + clintit(this%ILINMETH), MXITER, this%ITER1, & + clin(this%ILINMETH), cipc(this%IPC), & + cscale(this%ISCL), corder(this%IORD), & + this%NORTH, this%DVCLOSE, this%RCLOSE, & + this%ICNVGOPT, ccnvgopt(this%ICNVGOPT), & + this%RELAX + if (this%level > 0) then + write (clevel, '(i15)') this%level + end if + if (this%droptol > DZERO) then + write (cdroptol, '(e15.5)') this%droptol + end if + IF (this%level > 0 .or. this%droptol > DZERO) THEN + write (this%iout, 2015) trim(adjustl(clevel)), & + trim(adjustl(cdroptol)) + ELSE + write (this%iout, '(//)') + END IF + + if (this%iord /= 0) then + ! + ! -- WRITE SUMMARY OF REORDERING INFORMATION TO LIST FILE + if (this%iprims == 2) then + DO i = 1, this%neq, 6 + write (this%iout, 2030) 'ORIGINAL NODE :', & + (j, j=i, MIN(i + 5, this%neq)) + write (this%iout, 2040) + write (this%iout, 2030) 'REORDERED INDEX :', & + (this%lorder(j), j=i, MIN(i + 5, this%neq)) + write (this%iout, 2030) 'REORDERED NODE :', & + (this%iorder(j), j=i, MIN(i + 5, this%neq)) + write (this%iout, 2050) + END DO + END IF + end if + ! + ! -- return + return + end subroutine imslinear_summary + + !> @ brief Allocate and initialize scalars + !! + !! Allocate and inititialize linear accelerator scalars + !! + !< + subroutine allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy variables + class(ImsLinearDataType), intent(inout) :: this !< ImsLinearDataType instance + ! + ! -- allocate scalars + call mem_allocate(this%iout, 'IOUT', this%memoryPath) + call mem_allocate(this%ilinmeth, 'ILINMETH', this%memoryPath) + call mem_allocate(this%iter1, 'ITER1', this%memoryPath) + call mem_allocate(this%ipc, 'IPC', this%memoryPath) + call mem_allocate(this%iscl, 'ISCL', this%memoryPath) + call mem_allocate(this%iord, 'IORD', this%memoryPath) + call mem_allocate(this%north, 'NORTH', this%memoryPath) + call mem_allocate(this%icnvgopt, 'ICNVGOPT', this%memoryPath) + call mem_allocate(this%iacpc, 'IACPC', this%memoryPath) + call mem_allocate(this%niterc, 'NITERC', this%memoryPath) + call mem_allocate(this%niabcgs, 'NIABCGS', this%memoryPath) + call mem_allocate(this%niapc, 'NIAPC', this%memoryPath) + call mem_allocate(this%njapc, 'NJAPC', this%memoryPath) + call mem_allocate(this%dvclose, 'DVCLOSE', this%memoryPath) + call mem_allocate(this%rclose, 'RCLOSE', this%memoryPath) + call mem_allocate(this%relax, 'RELAX', this%memoryPath) + call mem_allocate(this%epfact, 'EPFACT', this%memoryPath) + call mem_allocate(this%l2norm0, 'L2NORM0', this%memoryPath) + call mem_allocate(this%droptol, 'DROPTOL', this%memoryPath) + call mem_allocate(this%level, 'LEVEL', this%memoryPath) + call mem_allocate(this%njlu, 'NJLU', this%memoryPath) + call mem_allocate(this%njw, 'NJW', this%memoryPath) + call mem_allocate(this%nwlu, 'NWLU', this%memoryPath) + ! + ! -- initialize scalars + this%iout = 0 + this%ilinmeth = 0 + this%iter1 = 0 + this%ipc = 0 + this%iscl = 0 + this%iord = 0 + this%north = 0 + this%icnvgopt = 0 + this%iacpc = 0 + this%niterc = 0 + this%niabcgs = 0 + this%niapc = 0 + this%njapc = 0 + this%dvclose = DZERO + this%rclose = DZERO + this%relax = DZERO + this%epfact = DZERO + this%l2norm0 = 0 + this%droptol = DZERO + this%level = 0 + this%njlu = 0 + this%njw = 0 + this%nwlu = 0 + ! + ! -- return + return + end subroutine allocate_scalars + + !> @ brief Deallocate memory + !! + !! Deallocate linear accelerator memory. + !! + !< + subroutine imslinear_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy variables + class(ImsLinearDataType), intent(inout) :: this !< linear datatype instance + ! + ! -- arrays + call mem_deallocate(this%dscale) + call mem_deallocate(this%dscale2) + call mem_deallocate(this%iapc) + call mem_deallocate(this%japc) + call mem_deallocate(this%apc) + call mem_deallocate(this%iw) + call mem_deallocate(this%w) + call mem_deallocate(this%jlu) + call mem_deallocate(this%jw) + call mem_deallocate(this%wlu) + call mem_deallocate(this%lorder) + call mem_deallocate(this%iorder) + call mem_deallocate(this%iaro) + call mem_deallocate(this%jaro) + call mem_deallocate(this%aro) + call mem_deallocate(this%id) + call mem_deallocate(this%d) + call mem_deallocate(this%p) + call mem_deallocate(this%q) + call mem_deallocate(this%z) + call mem_deallocate(this%t) + call mem_deallocate(this%v) + call mem_deallocate(this%dhat) + call mem_deallocate(this%phat) + call mem_deallocate(this%qhat) + ! + ! -- scalars + call mem_deallocate(this%iout) + call mem_deallocate(this%ilinmeth) + call mem_deallocate(this%iter1) + call mem_deallocate(this%ipc) + call mem_deallocate(this%iscl) + call mem_deallocate(this%iord) + call mem_deallocate(this%north) + call mem_deallocate(this%icnvgopt) + call mem_deallocate(this%iacpc) + call mem_deallocate(this%niterc) + call mem_deallocate(this%niabcgs) + call mem_deallocate(this%niapc) + call mem_deallocate(this%njapc) + call mem_deallocate(this%dvclose) + call mem_deallocate(this%rclose) + call mem_deallocate(this%relax) + call mem_deallocate(this%epfact) + call mem_deallocate(this%l2norm0) + call mem_deallocate(this%droptol) + call mem_deallocate(this%level) + call mem_deallocate(this%njlu) + call mem_deallocate(this%njw) + call mem_deallocate(this%nwlu) + ! + ! -- nullify pointers + nullify (this%iprims) + nullify (this%neq) + nullify (this%nja) + nullify (this%ia) + nullify (this%ja) + nullify (this%amat) + nullify (this%rhs) + nullify (this%x) + ! + ! -- return + return + end subroutine imslinear_da + + !> @ brief Set default settings + !! + !! Set default linear accelerator settings. + !! + !< + SUBROUTINE imslinear_set_input(this, IFDPARAM) + ! -- dummy variables + CLASS(ImsLinearDataType), INTENT(INOUT) :: this !< ImsLinearDataType instance + integer(I4B), INTENT(IN) :: IFDPARAM !< complexity option + ! -- code + SELECT CASE (IFDPARAM) + ! + ! -- Simple option + CASE (1) + this%ITER1 = 50 + this%ILINMETH = 1 + this%IPC = 1 + this%ISCL = 0 + this%IORD = 0 + this%DVCLOSE = DEM3 + this%RCLOSE = DEM1 + this%RELAX = DZERO + this%LEVEL = 0 + this%DROPTOL = DZERO + this%NORTH = 0 + ! + ! -- Moderate + CASE (2) + this%ITER1 = 100 + this%ILINMETH = 2 + this%IPC = 2 + this%ISCL = 0 + this%IORD = 0 + this%DVCLOSE = DEM2 + this%RCLOSE = DEM1 + this%RELAX = 0.97D0 + this%LEVEL = 0 + this%DROPTOL = DZERO + this%NORTH = 0 + ! + ! -- Complex + CASE (3) + this%ITER1 = 500 + this%ILINMETH = 2 + this%IPC = 3 + this%ISCL = 0 + this%IORD = 0 + this%DVCLOSE = DEM1 + this%RCLOSE = DEM1 + this%RELAX = DZERO + this%LEVEL = 5 + this%DROPTOL = DEM4 + this%NORTH = 2 + END SELECT + ! + ! -- return + RETURN + END SUBROUTINE imslinear_set_input + + !> @ brief Base linear accelerator subroutine + !! + !! Base linear accelerator subroutine that scales and reorders + !! the system of equations, if necessary, updates the preconditioner, + !! and calls the appropriate linear accelerator. + !! + !< + SUBROUTINE imslinear_ap(this, ICNVG, KSTP, KITER, IN_ITER, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + ! -- modules + USE SimModule + ! -- dummy variables + CLASS(ImsLinearDataType), INTENT(INOUT) :: this !< ImsLinearDataType instance + integer(I4B), INTENT(INOUT) :: ICNVG !< convergence flag (1) non-convergence (0) + integer(I4B), INTENT(IN) :: KSTP !< time step number + integer(I4B), INTENT(IN) :: KITER !< outer iteration number + integer(I4B), INTENT(INOUT) :: IN_ITER !< inner iteration number + ! -- convergence information dummy variables + integer(I4B), INTENT(IN) :: NCONV !< + integer(I4B), INTENT(IN) :: CONVNMOD !< + integer(I4B), DIMENSION(CONVNMOD + 1), INTENT(INOUT) :: CONVMODSTART !< + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV !< + integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR !< + character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL !< + integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER !< + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV !< + integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR !< + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX !< + real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX !< + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX !< + real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX !< + ! -- local variables + integer(I4B) :: n + integer(I4B) :: innerit + integer(I4B) :: irc + integer(I4B) :: itmax + real(DP) :: dnrm2 + ! + ! -- set epfact based on timestep + IF (this%ICNVGOPT == 2) THEN + IF (KSTP == 1) THEN + this%EPFACT = 0.01 + ELSE + this%EPFACT = 0.10 + END IF + ELSE IF (this%ICNVGOPT == 4) THEN + this%EPFACT = DEM4 + ELSE + this%EPFACT = DONE + END IF + ! + ! -- SCALE PROBLEM + IF (this%ISCL .NE. 0) THEN + CALL ims_base_scale(0, this%ISCL, & + this%NEQ, this%NJA, this%IA, this%JA, & + this%AMAT, this%X, this%RHS, & + this%DSCALE, this%DSCALE2) + END IF + ! + ! -- PERMUTE ROWS, COLUMNS, AND RHS + IF (this%IORD /= 0) THEN + CALL dperm(this%NEQ, this%AMAT, this%JA, this%IA, & + this%ARO, this%JARO, this%IARO, & + this%LORDER, this%ID, 1) + CALL dvperm(this%NEQ, this%X, this%LORDER) + CALL dvperm(this%NEQ, this%RHS, this%LORDER) + this%IA0 => this%IARO + this%JA0 => this%JARO + this%A0 => this%ARO + ELSE + this%IA0 => this%IA + this%JA0 => this%JA + this%A0 => this%AMAT + END IF + ! + ! -- UPDATE PRECONDITIONER + CALL ims_base_pcu(this%iout, this%NJA, this%NEQ, this%NIAPC, this%NJAPC, & + this%IPC, this%RELAX, this%A0, this%IA0, this%JA0, & + this%APC, this%IAPC, this%JAPC, this%IW, this%W, & + this%LEVEL, this%DROPTOL, this%NJLU, this%NJW, & + this%NWLU, this%JLU, this%JW, this%WLU) + ! + ! -- INITIALIZE SOLUTION VARIABLE AND ARRAYS + IF (KITER == 1) this%NITERC = 0 + irc = 1 + ICNVG = 0 + DO n = 1, this%NEQ + this%D(n) = DZERO + this%P(n) = DZERO + this%Q(n) = DZERO + this%Z(n) = DZERO + END DO + ! + ! -- CALCULATE INITIAL RESIDUAL + call ims_base_residual(this%NEQ, this%NJA, this%X, this%RHS, this%D, & + this%A0, this%IA0, this%JA0) + this%L2NORM0 = dnrm2(this%NEQ, this%D, 1) + ! + ! -- CHECK FOR EXACT SOLUTION + itmax = this%ITER1 + IF (this%L2NORM0 == DZERO) THEN + itmax = 0 + ICNVG = 1 + END IF + ! + ! -- SOLUTION BY THE CONJUGATE GRADIENT METHOD + IF (this%ILINMETH == 1) THEN + CALL ims_base_cg(ICNVG, itmax, innerit, & + this%NEQ, this%NJA, this%NIAPC, this%NJAPC, & + this%IPC, this%NITERC, this%ICNVGOPT, this%NORTH, & + this%DVCLOSE, this%RCLOSE, this%L2NORM0, & + this%EPFACT, this%IA0, this%JA0, this%A0, & + this%IAPC, this%JAPC, this%APC, & + this%X, this%RHS, this%D, this%P, this%Q, this%Z, & + this%NJLU, this%IW, this%JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + ! + ! -- SOLUTION BY THE BICONJUGATE GRADIENT STABILIZED METHOD + ELSE IF (this%ILINMETH == 2) THEN + CALL ims_base_bcgs(ICNVG, itmax, innerit, & + this%NEQ, this%NJA, this%NIAPC, this%NJAPC, & + this%IPC, this%NITERC, this%ICNVGOPT, this%NORTH, & + this%ISCL, this%DSCALE, & + this%DVCLOSE, this%RCLOSE, this%L2NORM0, & + this%EPFACT, this%IA0, this%JA0, this%A0, & + this%IAPC, this%JAPC, this%APC, & + this%X, this%RHS, this%D, this%P, this%Q, & + this%T, this%V, this%DHAT, this%PHAT, this%QHAT, & + this%NJLU, this%IW, this%JLU, & + NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & + CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & + DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) + END IF + ! + ! -- BACK PERMUTE AMAT, SOLUTION, AND RHS + IF (this%IORD /= 0) THEN + CALL dperm(this%NEQ, this%A0, this%JA0, this%IA0, & + this%AMAT, this%JA, this%IA, & + this%IORDER, this%ID, 1) + CALL dvperm(this%NEQ, this%X, this%IORDER) + CALL dvperm(this%NEQ, this%RHS, this%IORDER) + END IF + ! + ! -- UNSCALE PROBLEM + IF (this%ISCL .NE. 0) THEN + CALL ims_base_scale(1, this%ISCL, & + this%NEQ, this%NJA, this%IA, this%JA, & + this%AMAT, this%X, this%RHS, & + this%DSCALE, this%DSCALE2) + END IF + ! + ! -- SET IMS INNER ITERATION NUMBER (IN_ITER) TO NUMBER OF + ! IMSLINEAR INNER ITERATIONS (innerit) + IN_ITER = innerit + ! + ! -- RETURN + RETURN + END SUBROUTINE imslinear_ap + +END MODULE IMSLinearModule diff --git a/src/Solution/LinearMethods/ims8misc.f90 b/src/Solution/LinearMethods/ims8misc.f90 new file mode 100644 index 00000000000..0000f7d2ccb --- /dev/null +++ b/src/Solution/LinearMethods/ims8misc.f90 @@ -0,0 +1,54 @@ +MODULE IMSLinearMisc + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DONE + + private + public :: ims_misc_thomas + +CONTAINS + + !> @brief Tridiagonal solve using the Thomas algorithm + !! + !! Subroutine to solve tridiagonal linear equations using the + !! Thomas algorithm. + !! + !< + subroutine ims_misc_thomas(n, tl, td, tu, b, x, w) + implicit none + ! -- dummy variables + integer(I4B), intent(in) :: n !< number of matrix rows + real(DP), dimension(n), intent(in) :: tl !< lower matrix terms + real(DP), dimension(n), intent(in) :: td !< diagonal matrix terms + real(DP), dimension(n), intent(in) :: tu !< upper matrix terms + real(DP), dimension(n), intent(in) :: b !< right-hand side vector + real(DP), dimension(n), intent(inout) :: x !< solution vector + real(DP), dimension(n), intent(inout) :: w !< work vector + ! -- local variables + integer(I4B) :: j + real(DP) :: bet + real(DP) :: beti + ! + ! -- initialize variables + w(1) = DZERO + bet = td(1) + beti = DONE / bet + x(1) = b(1) * beti + ! + ! -- decomposition and forward substitution + do j = 2, n + w(j) = tu(j - 1) * beti + bet = td(j) - tl(j) * w(j) + beti = DONE / bet + x(j) = (b(j) - tl(j) * x(j - 1)) * beti + end do + ! + ! -- backsubstitution + do j = n - 1, 1, -1 + x(j) = x(j) - w(j + 1) * x(j + 1) + end do + ! -- return + return + end subroutine ims_misc_thomas + +END MODULE IMSLinearMisc diff --git a/src/Solution/LinearMethods/ims8reordering.f90 b/src/Solution/LinearMethods/ims8reordering.f90 new file mode 100644 index 00000000000..7b4138ff0d7 --- /dev/null +++ b/src/Solution/LinearMethods/ims8reordering.f90 @@ -0,0 +1,774 @@ +MODULE IMSReorderingModule + use KindModule, only: DP, I4B + private + public :: ims_odrv +contains + + subroutine ims_odrv(n, nja, nsp, ia, ja, p, ip, isp, flag) + ! + ! 3/12/82 + !*********************************************************************** + ! odrv -- driver for sparse matrix reordering routines + !*********************************************************************** + ! + ! description + ! + ! odrv finds a minimum degree ordering of the rows and columns + ! of a matrix m stored in (ia,ja,a) format (see below). for the + ! reordered matrix, the work and storage required to perform + ! gaussian elimination is (usually) significantly less. + ! + ! note.. odrv and its subordinate routines have been modified to + ! compute orderings for general matrices, not necessarily having any + ! symmetry. the minimum degree ordering is computed for the + ! structure of the symmetric matrix m + m-transpose. + ! modifications to the original odrv module have been made in + ! the coding in subroutine mdi, and in the initial comments in + ! subroutines odrv and md. + ! + ! if only the nonzero entries in the upper triangle of m are being + ! stored, then odrv symmetrically reorders (ia,ja,a), (optionally) + ! with the diagonal entries placed first in each row. this is to + ! ensure that if m(i,j) will be in the upper triangle of m with + ! respect to the new ordering, then m(i,j) is stored in row i (and + ! thus m(j,i) is not stored), whereas if m(i,j) will be in the + ! strict lower triangle of m, then m(j,i) is stored in row j (and + ! thus m(i,j) is not stored). + ! + ! + ! storage of sparse matrices + ! + ! the nonzero entries of the matrix m are stored row-by-row in the + ! array a. to identify the individual nonzero entries in each row, + ! we need to know in which column each entry lies. these column + ! indices are stored in the array ja. i.e., if a(k) = m(i,j), then + ! ja(k) = j. to identify the individual rows, we need to know where + ! each row starts. these row pointers are stored in the array ia. + ! i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row + ! and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to + ! the first location following the last element in the last row. + ! thus, the number of entries in the i-th row is ia(i+1) - ia(i), + ! the nonzero entries in the i-th row are stored consecutively in + ! + ! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), + ! + ! and the corresponding column indices are stored consecutively in + ! + ! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). + ! + ! since the coefficient matrix is symmetric, only the nonzero entries + ! in the upper triangle need be stored. for example, the matrix + ! + ! ( 1 0 2 3 0 ) + ! ( 0 4 0 0 0 ) + ! m = ( 2 0 5 6 0 ) + ! ( 3 0 6 7 8 ) + ! ( 0 0 0 8 9 ) + ! + ! could be stored as + ! + ! - 1 2 3 4 5 6 7 8 9 10 11 12 13 + ! ---+-------------------------------------- + ! ia - 1 4 5 8 12 14 + ! ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 + ! a - 1 2 3 4 2 5 6 3 6 7 8 8 9 + ! + ! or (symmetrically) as + ! + ! - 1 2 3 4 5 6 7 8 9 + ! ---+-------------------------- + ! ia - 1 4 5 7 9 10 + ! ja - 1 3 4 2 3 4 4 5 5 + ! a - 1 2 3 4 5 6 7 8 9 . + ! + ! + ! parameters + ! + ! n - order of the matrix + ! + ! nja - number of nonzeroes in the matrix + ! + ! nsp - declared dimension of the one-dimensional array isp. nsp + ! must be at least 3n+4k, where k is the number of nonzeroes + ! in the strict upper triangle of m + ! + ! ia - integer one-dimensional array containing pointers to delimit + ! rows in ja and a. dimension = n+1 + ! + ! ja - integer one-dimensional array containing the column indices + ! corresponding to the elements of a. dimension = number of + ! nonzero entries in (the upper triangle of) m + ! + ! a - real one-dimensional array containing the nonzero entries in + ! (the upper triangle of) m, stored by rows. dimension = + ! number of nonzero entries in (the upper triangle of) m + ! + ! p - integer one-dimensional array used to return the permutation + ! of the rows and columns of m corresponding to the minimum + ! degree ordering. dimension = n + ! + ! ip - integer one-dimensional array used to return the inverse of + ! the permutation returned in p. dimension = n + ! + ! isp - integer one-dimensional array used for working storage. + ! dimension = nsp + ! + ! path - integer path specification. values and their meanings are - + ! 1 find minimum degree ordering only + ! 2 find minimum degree ordering and reorder symmetrically + ! stored matrix (used when only the nonzero entries in + ! the upper triangle of m are being stored) + ! 3 reorder symmetrically stored matrix as specified by + ! input permutation (used when an ordering has already + ! been determined and only the nonzero entries in the + ! upper triangle of m are being stored) + ! 4 same as 2 but put diagonal entries at start of each row + ! 5 same as 3 but put diagonal entries at start of each row + ! + ! flag - integer error flag. values and their meanings are - + ! 0 no errors detected + ! 9n+k insufficient storage in md + ! 10n+1 insufficient storage in odrv + ! 11n+1 illegal path specification + ! + ! + ! conversion from real to double precision + ! + ! change the real declarations in odrv and sro to double precision + ! declarations. + ! + !----------------------------------------------------------------------- + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: nsp + integer(I4B), dimension(n + 1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), dimension(n), intent(inout) :: p + integer(I4B), dimension(n), intent(inout) :: ip + integer(I4B), dimension(nsp), intent(inout) :: isp + integer(I4B), intent(inout) :: flag + + ! -- local + integer(I4B) :: v + integer(I4B) :: l + integer(I4B) :: head + integer(I4B) :: mmax + integer(I4B) :: next + integer(I4B) :: path + ! + ! set path for finding ordering only + ! + path = 1 + ! + ! + ! initialize error flag and validate path specification + flag = 0 + if (path < 1 .or. 5 < path) go to 111 + ! + ! find minimum degree ordering + mmax = (nsp - n) / 2 + v = 1 + l = v + mmax + head = l + mmax + next = head + n + if (mmax < n) go to 110 + ! + call ims_md(n, nja, ia, ja, mmax, isp(v), isp(l), isp(head), p, & + ip, isp(v), flag) + if (flag .ne. 0) go to 100 + ! + return + ! + ! ** error -- error detected in md + ! flag = 9 * n + vi from routine mdi. + ! +100 return + ! ** error -- insufficient storage +110 flag = 10 * n + 1 + return + ! ** error -- illegal path specified +111 flag = 11 * n + 1 + return + end subroutine ims_odrv + + subroutine ims_md(n, nja, ia, ja, mmax, v, l, head, last, next, & + mark, flag) + ! + !***************************************************************** + ! ims_md -- minimum degree algorithm (based on element model) + !***************************************************************** + ! + ! description + ! + ! ims_md finds a minimum degree ordering of the rows and + ! columns of a general sparse matrix m stored in (ia,ja,a) + ! format. when the structure of m is nonsymmetric, the ordering + ! is that obtained for the symmetric matrix m + m-transpose. + ! + ! + ! additional parameters + ! + ! mmax - declared dimension of the one-dimensional arrays v and l. + ! mmax must be at least n+2k, where k is the number of + ! nonzeroes in the strict upper triangle of m + ! + ! v - integer one-dimensional work array. dimension = mmax + ! + ! l - integer one-dimensional work array. dimension = mmax + ! + ! head - integer one-dimensional work array. dimension = n + ! + ! last - integer one-dimensional array used to return the permutation + ! of the rows and columns of m corresponding to the minimum + ! degree ordering. dimension = n + ! + ! next - integer one-dimensional array used to return the inverse of + ! the permutation returned in last. dimension = n + ! + ! mark - integer one-dimensional work array (may be the same as v). + ! dimension = n + ! + ! flag - integer error flag. values and their meanings are - + ! 0 no errors detected + ! 11n+1 insufficient storage in md + ! + ! + ! definitions of internal parameters + ! + ! ---------+--------------------------------------------------------- + ! v(s) - value field of list entry + ! ---------+--------------------------------------------------------- + ! l(s) - link field of list entry (0 =) end of list) + ! ---------+--------------------------------------------------------- + ! l(vi) - pointer to element list of uneliminated vertex vi + ! ---------+--------------------------------------------------------- + ! l(ej) - pointer to boundary list of active element ej + ! ---------+--------------------------------------------------------- + ! head(d) - vj =) vj head of d-list d + ! - 0 =) no vertex in d-list d + ! + ! + ! - vi uneliminated vertex + ! - vi in ek - vi not in ek + ! ---------+-----------------------------+--------------------------- + ! next(vi) - undefined but nonnegative - vj =) vj next in d-list + ! - - 0 =) vi tail of d-list + ! ---------+-----------------------------+--------------------------- + ! last(vi) - (not set until mdp) - -d =) vi head of d-list d + ! --vk =) compute degree - vj =) vj last in d-list + ! - ej =) vi prototype of ej - 0 =) vi not in any d-list + ! - 0 =) do not compute degree - + ! ---------+-----------------------------+--------------------------- + ! mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) + ! + ! + ! - vi eliminated vertex + ! - ei active element - otherwise + ! ---------+-----------------------------+--------------------------- + ! next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex + ! - to be eliminated - to be eliminated + ! ---------+-----------------------------+--------------------------- + ! last(vi) - m =) size of ei = m - undefined + ! ---------+-----------------------------+--------------------------- + ! mark(vi) - -m =) overlap count of ei - undefined + ! - with ek = m - + ! - otherwise nonnegative tag - + ! - .lt. mark(vk) - + ! + !----------------------------------------------------------------------- + ! + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nja + integer(I4B), dimension(n + 1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), intent(in) :: mmax + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + integer(I4B), intent(inout) :: flag + + ! -- local + integer(I4B) :: tag + integer(I4B) :: dmin + integer(I4B) :: vk + integer(I4B) :: ek + integer(I4B) :: tail + integer(I4B) :: k + + equivalence(vk, ek) + ! + ! initialization + tag = 0 + call ims_mdi(n, nja, ia, ja, mmax, v, l, head, last, next, & + mark, tag, flag) + if (flag .ne. 0) return + ! + k = 0 + dmin = 1 + ! + ! while k .lt. n do +1 if (k >= n) go to 4 + ! + ! search for vertex of minimum degree +2 if (head(dmin) > 0) go to 3 + dmin = dmin + 1 + go to 2 + ! + ! remove vertex vk of minimum degree from degree list +3 vk = head(dmin) + head(dmin) = next(vk) + if (head(dmin) > 0) last(head(dmin)) = -dmin + ! + ! number vertex vk, adjust tag, and tag vk + k = k + 1 + next(vk) = -k + last(ek) = dmin - 1 + tag = tag + last(ek) + mark(vk) = tag + ! + ! form element ek from uneliminated neighbors of vk + call ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) + ! + ! purge inactive elements and do mass elimination + call ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) + ! + ! update degrees of uneliminated vertices in ek + call ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) + ! + go to 1 + ! + ! generate inverse permutation from permutation +4 do k = 1, n + next(k) = -next(k) + last(next(k)) = k + end do + ! + return + end subroutine ims_md + + subroutine ims_mdi(n, nja, ia, ja, mmax, v, l, head, last, next, & + mark, tag, flag) + ! + !*********************************************************************** + ! ims_mdi -- initialization + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: nja + integer(I4B), dimension(n + 1), intent(in) :: ia + integer(I4B), dimension(nja), intent(in) :: ja + integer(I4B), intent(in) :: mmax + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + integer(I4B), intent(in) :: tag + integer(I4B), intent(inout) :: flag + + ! -- local + integer(I4B) :: sfs + integer(I4B) :: vi + integer(I4B) :: dvi + integer(I4B) :: vj + integer(I4B) :: jmin + integer(I4B) :: jmax + integer(I4B) :: j + integer(I4B) :: lvk + integer(I4B) :: kmax + integer(I4B) :: k + integer(I4B) :: nextvi + integer(I4B) :: ieval + ! + ! initialize degrees, element lists, and degree lists + do vi = 1, n + mark(vi) = 1 + l(vi) = 0 + head(vi) = 0 + end do + sfs = n + 1 + ! + ! create nonzero structure + ! for each nonzero entry a(vi,vj) + louter: do vi = 1, n + jmin = ia(vi) + jmax = ia(vi + 1) - 1 + if (jmin > jmax) cycle louter + linner1: do j = jmin, jmax !5 + vj = ja(j) + !if (vj-vi) 2, 5, 4 + ieval = vj - vi + if (ieval == 0) cycle linner1 !5 + if (ieval > 0) go to 4 + ! + ! if a(vi,vj) is in strict lower triangle + ! check for previous occurrence of a(vj,vi) + lvk = vi + kmax = mark(vi) - 1 + if (kmax == 0) go to 4 + linner2: do k = 1, kmax + lvk = l(lvk) + if (v(lvk) == vj) cycle linner1 !5 + end do linner2 + ! for unentered entries a(vi,vj) +4 if (sfs >= mmax) go to 101 + ! + ! enter vj in element list for vi + mark(vi) = mark(vi) + 1 + v(sfs) = vj + l(sfs) = l(vi) + l(vi) = sfs + sfs = sfs + 1 + ! + ! enter vi in element list for vj + mark(vj) = mark(vj) + 1 + v(sfs) = vi + l(sfs) = l(vj) + l(vj) = sfs + sfs = sfs + 1 + end do linner1 + end do louter + ! + ! create degree lists and initialize mark vector + do vi = 1, n + dvi = mark(vi) + next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + nextvi = next(vi) + if (nextvi > 0) last(nextvi) = vi + mark(vi) = tag + end do + ! + return + ! + ! ** error- insufficient storage +101 flag = 9 * n + vi + return + end subroutine ims_mdi + + subroutine ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) + ! + !*********************************************************************** + ! ims_mdm -- form element from uneliminated neighbors of vk + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: mmax + integer(I4B), intent(in) :: vk + integer(I4B), intent(inout) :: tail + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + + ! -- local + integer(I4B) :: tag + integer(I4B) :: s + integer(I4B) :: ls + integer(I4B) :: vs + integer(I4B) :: es + integer(I4B) :: b + integer(I4B) :: lb + integer(I4B) :: vb + integer(I4B) :: blp + integer(I4B) :: blpmax + + equivalence(vs, es) + ! + ! initialize tag and list of uneliminated neighbors + tag = mark(vk) + tail = vk + ! + ! for each vertex/element vs/es in element list of vk + ls = l(vk) +1 s = ls + if (s == 0) go to 5 + ls = l(s) + vs = v(s) + if (next(vs) < 0) go to 2 + ! + ! if vs is uneliminated vertex, then tag and append to list of + ! uneliminated neighbors + mark(vs) = tag + l(tail) = s + tail = s + go to 4 + ! + ! if es is active element, then ... + ! for each vertex vb in boundary list of element es +2 lb = l(es) + blpmax = last(es) + louter: do blp = 1, blpmax !3 + b = lb + lb = l(b) + vb = v(b) + ! + ! if vb is untagged vertex, then tag and append to list of + ! uneliminated neighbors + if (mark(vb) >= tag) cycle louter !3 + mark(vb) = tag + l(tail) = b + tail = b + end do louter + ! + ! mark es inactive + mark(es) = tag + ! +4 go to 1 + ! + ! terminate list of uneliminated neighbors +5 l(tail) = 0 + ! + return + end subroutine ims_mdm + + subroutine ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) + ! + !*********************************************************************** + ! ims_mdp -- purge inactive elements and do mass elimination + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: mmax + integer(I4B), intent(inout) :: k + integer(I4B), intent(in) :: ek + integer(I4B), intent(inout) :: tail + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + + ! -- local + integer(I4B) :: tag + integer(I4B) :: free + integer(I4B) :: li + integer(I4B) :: vi + integer(I4B) :: lvi + integer(I4B) :: evi + integer(I4B) :: s + integer(I4B) :: ls + integer(I4B) :: es + integer(I4B) :: ilp + integer(I4B) :: ilpmax + integer(I4B) :: i + ! + ! initialize tag + tag = mark(ek) + ! + ! for each vertex vi in ek + li = ek + ilpmax = last(ek) + if (ilpmax <= 0) go to 12 + louter: do ilp = 1, ilpmax !11 + i = li + li = l(i) + vi = v(li) + ! + ! remove vi from degree list + if (last(vi) == 0) go to 3 + if (last(vi) > 0) go to 1 + head(-last(vi)) = next(vi) + go to 2 +1 next(last(vi)) = next(vi) +2 if (next(vi) > 0) last(next(vi)) = last(vi) + ! + ! remove inactive items from element list of vi +3 ls = vi +4 s = ls + ls = l(s) + if (ls == 0) go to 6 + es = v(ls) + if (mark(es) < tag) go to 5 + free = ls + l(s) = l(ls) + ls = s +5 go to 4 + ! + ! if vi is interior vertex, then remove from list and eliminate + +6 lvi = l(vi) + if (lvi .ne. 0) go to 7 + l(i) = l(li) + li = i + ! + k = k + 1 + next(vi) = -k + last(ek) = last(ek) - 1 + cycle louter !11 + ! + ! else ... + ! classify vertex vi +7 if (l(lvi) .ne. 0) go to 9 + evi = v(lvi) + if (next(evi) >= 0) go to 9 + if (mark(evi) < 0) go to 8 + ! + ! if vi is prototype vertex, then mark as such, initialize + ! overlap count for corresponding element, and move vi to end + ! of boundary list + last(vi) = evi + mark(evi) = -1 + l(tail) = li + tail = li + l(i) = l(li) + li = i + go to 10 + ! + ! else if vi is duplicate vertex, then mark as such and adjust + ! overlap count for corresponding element +8 last(vi) = 0 + mark(evi) = mark(evi) - 1 + go to 10 + ! + ! else mark vi to compute degree +9 last(vi) = -ek + ! + ! insert ek in element list of vi +10 v(free) = ek + l(free) = l(vi) + l(vi) = free + end do louter !11 + ! + ! terminate boundary list +12 l(tail) = 0 + ! + return + end subroutine ims_mdp + + subroutine ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) + ! + !*********************************************************************** + ! ims_mdu -- update degrees of uneliminated vertices in ek + !*********************************************************************** + implicit none + + ! -- dummy variables + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: mmax + integer(I4B), intent(in) :: ek + integer(I4B), intent(inout) :: dmin + integer(I4B), dimension(mmax), intent(inout) :: v + integer(I4B), dimension(mmax), intent(inout) :: l + integer(I4B), dimension(n), intent(inout) :: head + integer(I4B), dimension(n), intent(inout) :: last + integer(I4B), dimension(n), intent(inout) :: next + integer(I4B), dimension(n), intent(inout) :: mark + + ! -- local + integer(I4B) :: tag + integer(I4B) :: vi + integer(I4B) :: evi + integer(I4B) :: dvi + integer(I4B) :: s + integer(I4B) :: vs + integer(I4B) :: es + integer(I4B) :: b + integer(I4B) :: vb + integer(I4B) :: ilp + integer(I4B) :: ilpmax + integer(I4B) :: blp + integer(I4B) :: blpmax + integer(I4B) :: i + + equivalence(vs, es) + ! + ! initialize tag + tag = mark(ek) - last(ek) + ! + ! for each vertex vi in ek + i = ek + ilpmax = last(ek) + if (ilpmax <= 0) go to 11 + louter: do ilp = 1, ilpmax !10 + i = l(i) + vi = v(i) + !if (last(vi)) 1, 10, 8 + if (last(vi) == 0) cycle louter !10 + if (last(vi) > 0) goto 8 + ! + ! if vi neither prototype nor duplicate vertex, then merge elements + ! to compute degree + tag = tag + 1 + dvi = last(ek) + ! + ! for each vertex/element vs/es in element list of vi + s = l(vi) +2 s = l(s) + if (s == 0) go to 9 + vs = v(s) + if (next(vs) < 0) go to 3 + ! + ! if vs is uneliminated vertex, then tag and adjust degree + mark(vs) = tag + dvi = dvi + 1 + go to 5 + ! + ! if es is active element, then expand + ! check for outmatched vertex +3 if (mark(es) < 0) go to 6 + ! + ! for each vertex vb in es + b = es + blpmax = last(es) + linner: do blp = 1, blpmax !4 + b = l(b) + vb = v(b) + ! + ! if vb is untagged, then tag and adjust degree + if (mark(vb) >= tag) cycle linner !4 + mark(vb) = tag + dvi = dvi + 1 + end do linner !4 + ! +5 go to 2 + ! + ! else if vi is outmatched vertex, then adjust overlaps but do not + ! compute degree +6 last(vi) = 0 + mark(es) = mark(es) - 1 +7 s = l(s) + if (s == 0) cycle louter !10 + es = v(s) + if (mark(es) < 0) mark(es) = mark(es) - 1 + go to 7 + ! + ! else if vi is prototype vertex, then calculate degree by + ! inclusion/exclusion and reset overlap count +8 evi = last(vi) + dvi = last(ek) + last(evi) + mark(evi) + mark(evi) = 0 + ! + ! insert vi in appropriate degree list +9 next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + if (next(vi) > 0) last(next(vi)) = vi + if (dvi < dmin) dmin = dvi + ! + end do louter !10 + ! +11 return + end subroutine ims_mdu + +end module IMSReorderingModule diff --git a/src/Solution/NumericalSolution.f90 b/src/Solution/NumericalSolution.f90 index 6cc6c9468f2..be9f0214ae8 100644 --- a/src/Solution/NumericalSolution.f90 +++ b/src/Solution/NumericalSolution.f90 @@ -1,134 +1,134 @@ ! This is the numerical solution module. module NumericalSolutionModule - use KindModule, only: DP, I4B, LGP - use TimerModule, only: code_timer - use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, LENPAKLOC, & - DPREC, DZERO, DEM20, DEM15, DEM6, & - DEM4, DEM3, DEM2, DEM1, DHALF, DONETHIRD, & - DONE, DTHREE, DEP3, DEP6, DEP20, DNODATA, & - TABLEFT, TABRIGHT, & - MNORMAL, MVALIDATE, & - LENMEMPATH - use MemoryHelperModule, only: create_mem_path - use TableModule, only: TableType, table_cr - use GenericUtilitiesModule, only: is_same, sim_message, stop_with_error - use VersionModule, only: IDEVELOPMODE - use BaseModelModule, only: BaseModelType - use BaseExchangeModule, only: BaseExchangeType - use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList - use ListModule, only: ListType - use ListsModule, only: basesolutionlist - use NumericalModelModule, only: NumericalModelType, & - AddNumericalModelToList, & - GetNumericalModelFromList - use NumericalExchangeModule, only: NumericalExchangeType, & - AddNumericalExchangeToList, & + use KindModule, only: DP, I4B, LGP + use TimerModule, only: code_timer + use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, LENPAKLOC, & + DPREC, DZERO, DEM20, DEM15, DEM6, & + DEM4, DEM3, DEM2, DEM1, DHALF, DONETHIRD, & + DONE, DTHREE, DEP3, DEP6, DEP20, DNODATA, & + TABLEFT, TABRIGHT, & + MNORMAL, MVALIDATE, & + LENMEMPATH + use MemoryHelperModule, only: create_mem_path + use TableModule, only: TableType, table_cr + use GenericUtilitiesModule, only: is_same, sim_message, stop_with_error + use VersionModule, only: IDEVELOPMODE + use BaseModelModule, only: BaseModelType + use BaseExchangeModule, only: BaseExchangeType + use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList + use ListModule, only: ListType + use ListsModule, only: basesolutionlist + use NumericalModelModule, only: NumericalModelType, & + AddNumericalModelToList, & + GetNumericalModelFromList + use NumericalExchangeModule, only: NumericalExchangeType, & + AddNumericalExchangeToList, & GetNumericalExchangeFromList - use SparseModule, only: sparsematrix - use SimVariablesModule, only: iout, isim_mode - use BlockParserModule, only: BlockParserType + use SparseModule, only: sparsematrix + use SimVariablesModule, only: iout, isim_mode + use BlockParserModule, only: BlockParserType use IMSLinearModule implicit none private - + public :: solution_create public :: NumericalSolutionType public :: GetNumericalSolutionFromList - + type, extends(BaseSolutionType) :: NumericalSolutionType - character(len=LENMEMPATH) :: memoryPath !< the path for storing solution variables in the memory manager - character(len=LINELENGTH) :: fname !< input file name - 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 :: ttform !< timer - total formulation time - real(DP), pointer :: ttsoln !< timer - total solution time - integer(I4B), pointer :: isymmetric => null() !< flag indicating if matrix symmetry is required - integer(I4B), pointer :: neq => null() !< number of equations - integer(I4B), pointer :: nja => null() !< number of non-zero entries - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< CRS row pointers - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< CRS column pointers - real(DP), dimension(:), pointer, contiguous :: amat => null() !< coefficient matrix - real(DP), dimension(:), pointer, contiguous :: rhs => null() !< right-hand side vector - real(DP), dimension(:), pointer, contiguous :: x => null() !< dependent-variable vector - integer(I4B), dimension(:), pointer, contiguous :: active => null() !< active cell array - real(DP), dimension(:), pointer, contiguous :: xtemp => null() !< temporary vector for previous dependent-variable iterate - type(BlockParserType) :: parser !< block parser object + character(len=LENMEMPATH) :: memoryPath !< the path for storing solution variables in the memory manager + character(len=LINELENGTH) :: fname !< input file name + 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 :: ttform !< timer - total formulation time + real(DP), pointer :: ttsoln !< timer - total solution time + integer(I4B), pointer :: isymmetric => null() !< flag indicating if matrix symmetry is required + integer(I4B), pointer :: neq => null() !< number of equations + integer(I4B), pointer :: nja => null() !< number of non-zero entries + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< CRS row pointers + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< CRS column pointers + real(DP), dimension(:), pointer, contiguous :: amat => null() !< coefficient matrix + real(DP), dimension(:), pointer, contiguous :: rhs => null() !< right-hand side vector + real(DP), dimension(:), pointer, contiguous :: x => null() !< dependent-variable vector + integer(I4B), dimension(:), pointer, contiguous :: active => null() !< active cell array + real(DP), dimension(:), pointer, contiguous :: xtemp => null() !< temporary vector for previous dependent-variable iterate + type(BlockParserType) :: parser !< block parser object ! ! -- sparse matrix data - real(DP), pointer :: theta => null() !< under-relaxation theta - real(DP), pointer :: akappa => null() !< under-relaxation kappa - real(DP), pointer :: gamma => null() !< under-relaxation gamma - real(DP), pointer :: amomentum => null() !< under-relaxation momentum term - real(DP), pointer :: breduc => null() !< backtracking reduction factor - real(DP), pointer :: btol => null() !< backtracking tolerance - real(DP), pointer :: res_lim => null() !< backtracking residual threshold - real(DP), pointer :: dvclose => null() !< dependent-variable closure criteria - real(DP), pointer :: bigchold => null() !< cooley under-relaxation weight - real(DP), pointer :: bigch => null() !< under-relaxation maximum dependent-variable change - real(DP), pointer :: relaxold => null() !< under-relaxation previous relaxation factor - real(DP), pointer :: res_prev => null() !< previous L-2 norm - real(DP), pointer :: res_new => null() !< current L-2 norm - integer(I4B), pointer :: icnvg => null() !< convergence flag (1) non-convergence (0) - integer(I4B), pointer :: itertot_timestep => null() !< total nr. of linear solves per call to sln_ca - integer(I4B), pointer :: iouttot_timestep => null() !< total nr. of outer iterations per call to sln_ca - integer(I4B), pointer :: itertot_sim => null() !< total nr. of inner iterations for simulation - integer(I4B), pointer :: mxiter => null() !< maximum number of Picard iterations - integer(I4B), pointer :: linmeth => null() !< linear acceleration method used - integer(I4B), pointer :: nonmeth => null() !< under-relaxation method used - integer(I4B), pointer :: numtrack => null() !< maximum number of backtracks - integer(I4B), pointer :: iprims => null() !< solver print option - integer(I4B), pointer :: ibflag => null() !< backtracking flag (1) on (0) off - integer(I4B), dimension(:,:), pointer, contiguous:: lrch => null() !< location of the largest dependent-variable change at the end of a Picard iteration - real(DP), dimension(:), pointer, contiguous :: hncg => null() !< largest dependent-variable change at the end of a Picard iteration - real(DP), dimension(:), pointer, contiguous :: dxold => null() !< DBD under-relaxation previous dependent-variable change - real(DP), dimension(:), pointer, contiguous :: deold => null() !< DBD under-relaxation dependent-variable change variable - real(DP), dimension(:), pointer, contiguous :: wsave => null() !< DBD under-relaxation sign-change factor - real(DP), dimension(:), pointer, contiguous :: hchold => null() !< DBD under-relaxation weighted dependent-variable change + real(DP), pointer :: theta => null() !< under-relaxation theta + real(DP), pointer :: akappa => null() !< under-relaxation kappa + real(DP), pointer :: gamma => null() !< under-relaxation gamma + real(DP), pointer :: amomentum => null() !< under-relaxation momentum term + real(DP), pointer :: breduc => null() !< backtracking reduction factor + real(DP), pointer :: btol => null() !< backtracking tolerance + real(DP), pointer :: res_lim => null() !< backtracking residual threshold + real(DP), pointer :: dvclose => null() !< dependent-variable closure criteria + real(DP), pointer :: bigchold => null() !< cooley under-relaxation weight + real(DP), pointer :: bigch => null() !< under-relaxation maximum dependent-variable change + real(DP), pointer :: relaxold => null() !< under-relaxation previous relaxation factor + real(DP), pointer :: res_prev => null() !< previous L-2 norm + real(DP), pointer :: res_new => null() !< current L-2 norm + integer(I4B), pointer :: icnvg => null() !< convergence flag (1) non-convergence (0) + integer(I4B), pointer :: itertot_timestep => null() !< total nr. of linear solves per call to sln_ca + integer(I4B), pointer :: iouttot_timestep => null() !< total nr. of outer iterations per call to sln_ca + integer(I4B), pointer :: itertot_sim => null() !< total nr. of inner iterations for simulation + integer(I4B), pointer :: mxiter => null() !< maximum number of Picard iterations + integer(I4B), pointer :: linmeth => null() !< linear acceleration method used + integer(I4B), pointer :: nonmeth => null() !< under-relaxation method used + integer(I4B), pointer :: numtrack => null() !< maximum number of backtracks + integer(I4B), pointer :: iprims => null() !< solver print option + integer(I4B), pointer :: ibflag => null() !< backtracking flag (1) on (0) off + integer(I4B), dimension(:, :), pointer, contiguous :: lrch => null() !< location of the largest dependent-variable change at the end of a Picard iteration + real(DP), dimension(:), pointer, contiguous :: hncg => null() !< largest dependent-variable change at the end of a Picard iteration + real(DP), dimension(:), pointer, contiguous :: dxold => null() !< DBD under-relaxation previous dependent-variable change + real(DP), dimension(:), pointer, contiguous :: deold => null() !< DBD under-relaxation dependent-variable change variable + real(DP), dimension(:), pointer, contiguous :: wsave => null() !< DBD under-relaxation sign-change factor + real(DP), dimension(:), pointer, contiguous :: hchold => null() !< DBD under-relaxation weighted dependent-variable change ! ! -- convergence summary information - character(len=31), dimension(:), pointer, contiguous :: caccel => null() !< convergence string - integer(I4B), pointer :: icsvouterout => null() !< Picard iteration CSV output flag and file unit - integer(I4B), pointer :: icsvinnerout => null() !< Inner iteration CSV output flag and file unit - integer(I4B), pointer :: nitermax => null() !< maximum number of iterations in a time step (maxiter * maxinner) - integer(I4B), pointer :: convnmod => null() !< number of models in the solution - integer(I4B), dimension(:), pointer, contiguous :: convmodstart => null() !< pointer to the start of each model in the convmod* arrays - integer(I4B), dimension(:), pointer, contiguous :: locdv => null() !< location of the maximum dependent-variable change in the solution - integer(I4B), dimension(:), pointer, contiguous :: locdr => null() !< location of the maximum flow change in the solution - integer(I4B), dimension(:), pointer, contiguous :: itinner => null() !< actual number of inner iterations in each Picard iteration - integer(I4B), pointer, dimension(:,:), contiguous :: convlocdv => null() !< location of the maximum dependent-variable change in each model in the solution - integer(I4B), pointer, dimension(:,:), contiguous :: convlocdr => null() !< location of the maximum flow change in each model in the solution - real(DP), dimension(:), pointer, contiguous :: dvmax => null() !< maximum dependent-variable change in the solution - real(DP), dimension(:), pointer, contiguous :: drmax => null() !< maximum flow change in the solution - real(DP), pointer, dimension(:,:), contiguous :: convdvmax => null() !< maximum dependent-variable change in each model in the solution - real(DP), pointer, dimension(:,:), contiguous :: convdrmax => null() !< maximum flow change in each model in the solution + character(len=31), dimension(:), pointer, contiguous :: caccel => null() !< convergence string + integer(I4B), pointer :: icsvouterout => null() !< Picard iteration CSV output flag and file unit + integer(I4B), pointer :: icsvinnerout => null() !< Inner iteration CSV output flag and file unit + integer(I4B), pointer :: nitermax => null() !< maximum number of iterations in a time step (maxiter * maxinner) + integer(I4B), pointer :: convnmod => null() !< number of models in the solution + integer(I4B), dimension(:), pointer, contiguous :: convmodstart => null() !< pointer to the start of each model in the convmod* arrays + integer(I4B), dimension(:), pointer, contiguous :: locdv => null() !< location of the maximum dependent-variable change in the solution + integer(I4B), dimension(:), pointer, contiguous :: locdr => null() !< location of the maximum flow change in the solution + integer(I4B), dimension(:), pointer, contiguous :: itinner => null() !< actual number of inner iterations in each Picard iteration + integer(I4B), pointer, dimension(:, :), contiguous :: convlocdv => null() !< location of the maximum dependent-variable change in each model in the solution + integer(I4B), pointer, dimension(:, :), contiguous :: convlocdr => null() !< location of the maximum flow change in each model in the solution + real(DP), dimension(:), pointer, contiguous :: dvmax => null() !< maximum dependent-variable change in the solution + real(DP), dimension(:), pointer, contiguous :: drmax => null() !< maximum flow change in the solution + real(DP), pointer, dimension(:, :), contiguous :: convdvmax => null() !< maximum dependent-variable change in each model in the solution + real(DP), pointer, dimension(:, :), contiguous :: convdrmax => null() !< maximum flow change in each model in the solution ! ! -- pseudo-transient continuation - integer(I4B), pointer :: iallowptc => null() !< flag indicating if ptc applied this time step - integer(I4B), pointer :: iptcopt => null() !< option for how to calculate the initial PTC value (ptcdel0) - integer(I4B), pointer :: iptcout => null() !< PTC output flag and file unit - real(DP), pointer :: l2norm0 => null() !< L-2 norm at the start of the first Picard iteration - real(DP), pointer :: ptcdel => null() !< PTC delta value - real(DP), pointer :: ptcdel0 => null() !< initial PTC delta value - real(DP), pointer :: ptcexp => null() !< PTC exponent - real(DP), pointer :: ptcthresh => null() !< PTC threshold value (0.001) - real(DP), pointer :: ptcrat => null() !< ratio of the PTC value and the minimum of the diagonal of AMAT used to determine if the PTC effect has decayed + integer(I4B), pointer :: iallowptc => null() !< flag indicating if ptc applied this time step + integer(I4B), pointer :: iptcopt => null() !< option for how to calculate the initial PTC value (ptcdel0) + integer(I4B), pointer :: iptcout => null() !< PTC output flag and file unit + real(DP), pointer :: l2norm0 => null() !< L-2 norm at the start of the first Picard iteration + real(DP), pointer :: ptcdel => null() !< PTC delta value + real(DP), pointer :: ptcdel0 => null() !< initial PTC delta value + real(DP), pointer :: ptcexp => null() !< PTC exponent + real(DP), pointer :: ptcthresh => null() !< PTC threshold value (0.001) + real(DP), pointer :: ptcrat => null() !< ratio of the PTC value and the minimum of the diagonal of AMAT used to determine if the PTC effect has decayed ! ! -- adaptive time step - real(DP), pointer :: atsfrac => null() !< adaptive time step faction + real(DP), pointer :: atsfrac => null() !< adaptive time step faction ! ! -- linear accelerator storage - type(ImsLinearDataType), pointer :: imslinear => null() !< IMS linear acceleration object + type(ImsLinearDataType), pointer :: imslinear => null() !< IMS linear acceleration object ! ! -- sparse object - type(sparsematrix) :: sparse !< sparse object + type(sparsematrix) :: sparse !< sparse object ! ! -- table objects - type(TableType), pointer :: innertab => null() !< inner iteration table object - type(TableType), pointer :: outertab => null() !< Picard iteration table object + type(TableType), pointer :: innertab => null() !< inner iteration table object + type(TableType), pointer :: outertab => null() !< Picard iteration table object contains procedure :: sln_df @@ -165,30 +165,30 @@ module NumericalSolutionModule procedure, private :: sln_buildsystem procedure, private :: writeCSVHeader procedure, private :: writePTCInfoToFile - + ! Expose these for use through the BMI/XMI: procedure, public :: prepareSolve procedure, public :: solve procedure, public :: finalizeSolve - + end type NumericalSolutionType contains !> @ brief Create a new solution !! -!! Create a new solution using the data in filename, assign this new +!! 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 solution_create(filename, id) + subroutine solution_create(filename, id) ! -- modules use SimVariablesModule, only: iout - use InputOutputModule, only: getunit, openfile + use InputOutputModule, only: getunit, openfile ! -- dummy variables - character(len=*),intent(in) :: filename !< solution input file name - integer(I4B),intent(in) :: id !< solution id + character(len=*), intent(in) :: filename !< solution input file name + integer(I4B), intent(in) :: id !< solution id ! -- local variables integer(I4B) :: inunit type(NumericalSolutionType), pointer :: solution => null() @@ -196,14 +196,14 @@ subroutine solution_create(filename, id) character(len=LENSOLUTIONNAME) :: solutionname ! ! -- Create a new solution and add it to the basesolutionlist container - allocate(solution) + allocate (solution) solbase => solution - write(solutionname,'(a, i0)') 'SLN_', id + write (solutionname, '(a, i0)') 'SLN_', id ! solution%name = solutionname solution%memoryPath = create_mem_path(solutionname) - allocate(solution%modellist) - allocate(solution%exchangelist) + allocate (solution%modellist) + allocate (solution%exchangelist) ! call solution%allocate_scalars() ! @@ -214,11 +214,11 @@ subroutine solution_create(filename, 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) + inquire (file=filename, number=inunit) - if(inunit < 0) inunit = getunit() + if (inunit < 0) inunit = getunit() solution%iu = inunit - write(iout,'(/a,a)') ' Creating solution: ', solution%name + write (iout, '(/a,a)') ' Creating solution: ', solution%name call openfile(solution%iu, iout, filename, 'IMS') ! ! -- Initialize block parser @@ -274,7 +274,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%icsvinnerout, 'ICSVINNEROUT', this%memoryPath) call mem_allocate(this%nitermax, 'NITERMAX', this%memoryPath) call mem_allocate(this%convnmod, 'CONVNMOD', this%memoryPath) - call mem_allocate(this%iallowptc, 'IALLOWPTC', this%memoryPath) + call mem_allocate(this%iallowptc, 'IALLOWPTC', this%memoryPath) call mem_allocate(this%iptcopt, 'IPTCOPT', this%memoryPath) call mem_allocate(this%iptcout, 'IPTCOUT', this%memoryPath) call mem_allocate(this%l2norm0, 'L2NORM0', this%memoryPath) @@ -343,7 +343,7 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! -- local variables class(NumericalModelType), pointer :: mp => null() integer(I4B) :: i @@ -364,16 +364,21 @@ subroutine allocate_arrays(this) call mem_allocate(this%wsave, 0, 'WSAVE', this%memoryPath) call mem_allocate(this%hchold, 0, 'HCHOLD', this%memoryPath) call mem_allocate(this%deold, 0, 'DEOLD', this%memoryPath) - call mem_allocate(this%convmodstart, this%convnmod+1, 'CONVMODSTART', this%memoryPath) + call mem_allocate(this%convmodstart, this%convnmod + 1, 'CONVMODSTART', & + this%memoryPath) call mem_allocate(this%locdv, this%convnmod, 'LOCDV', this%memoryPath) call mem_allocate(this%locdr, this%convnmod, 'LOCDR', this%memoryPath) call mem_allocate(this%itinner, 0, 'ITINNER', this%memoryPath) - call mem_allocate(this%convlocdv, this%convnmod, 0, 'CONVLOCDV', this%memoryPath) - call mem_allocate(this%convlocdr, this%convnmod, 0, 'CONVLOCDR', this%memoryPath) + call mem_allocate(this%convlocdv, this%convnmod, 0, 'CONVLOCDV', & + this%memoryPath) + call mem_allocate(this%convlocdr, this%convnmod, 0, 'CONVLOCDR', & + this%memoryPath) call mem_allocate(this%dvmax, this%convnmod, 'DVMAX', this%memoryPath) call mem_allocate(this%drmax, this%convnmod, 'DRMAX', this%memoryPath) - call mem_allocate(this%convdvmax, this%convnmod, 0, 'CONVDVMAX', this%memoryPath) - call mem_allocate(this%convdrmax, this%convnmod, 0, 'CONVDRMAX', this%memoryPath) + call mem_allocate(this%convdvmax, this%convnmod, 0, 'CONVDVMAX', & + this%memoryPath) + call mem_allocate(this%convdrmax, this%convnmod, 0, 'CONVDRMAX', & + this%memoryPath) ! ! -- initialize allocated arrays do i = 1, this%neq @@ -381,7 +386,7 @@ subroutine allocate_arrays(this) this%xtemp(i) = DZERO this%dxold(i) = DZERO this%active(i) = 1 !default is active - enddo + end do do i = 1, this%convnmod this%locdv(i) = 0 this%locdr(i) = 0 @@ -395,7 +400,7 @@ subroutine allocate_arrays(this) do i = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, i) ieq = ieq + mp%neq - this%convmodstart(i+1) = ieq + this%convmodstart(i + 1) = ieq end do ! ! -- return @@ -404,10 +409,10 @@ end subroutine allocate_arrays !> @ brief Define the solution !! - !! Define a new solution. Must be called after the models and exchanges have + !! Define a new solution. Must be called after the models and exchanges have !! been added to solution. The order of the steps is (1) Allocate neq and nja, - !! (2) Assign model offsets and solution ids, (3) Allocate and initialize - !! the solution arrays, (4) Point each model's x and rhs arrays, and + !! (2) Assign model offsets and solution ids, (3) Allocate and initialize + !! the solution arrays, (4) Point each model's x and rhs arrays, and !! (5) Initialize the sparsematrix instance !! !< @@ -415,7 +420,7 @@ subroutine sln_df(this) ! modules use MemoryManagerModule, only: mem_allocate ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! -- local variables class(NumericalModelType), pointer :: mp => null() integer(I4B) :: i @@ -427,7 +432,7 @@ subroutine sln_df(this) call mp%set_idsoln(this%id) call mp%set_moffset(this%neq) this%neq = this%neq + mp%neq - enddo + end do ! ! -- Allocate and initialize solution arrays call this%allocate_arrays() @@ -438,15 +443,15 @@ subroutine sln_df(this) call mp%set_xptr(this%x, 'X', this%name) call mp%set_rhsptr(this%rhs, 'RHS', this%name) call mp%set_iboundptr(this%active, 'IBOUND', this%name) - enddo + end do ! ! -- Create the sparsematrix instance - allocate(rowmaxnnz(this%neq)) - do i=1,this%neq - rowmaxnnz(i)=4 - enddo + allocate (rowmaxnnz(this%neq)) + do i = 1, this%neq + rowmaxnnz(i) = 4 + end do call this%sparse%init(this%neq, this%neq, rowmaxnnz) - deallocate(rowmaxnnz) + deallocate (rowmaxnnz) ! ! -- Assign connections, fill ia/ja, map connections call this%sln_connect() @@ -467,7 +472,7 @@ subroutine sln_ar(this) use SimModule, only: store_error, count_errors, deprecation_warning use InputOutputModule, only: getunit, openfile ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! -- local variables class(NumericalModelType), pointer :: mp => null() class(NumericalExchangeType), pointer :: cp => null() @@ -484,18 +489,20 @@ subroutine sln_ar(this) logical :: isfound, endOfBlock integer(I4B) :: ival real(DP) :: rval - character(len=*),parameter :: fmtcsvout = & - "(4x, 'CSV OUTPUT WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*),parameter :: fmtptcout = & - "(4x, 'PTC OUTPUT WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtcsvout = & + "(4x, 'CSV OUTPUT WILL BE SAVED TO FILE: ', a, & + &/4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtptcout = & + "(4x, 'PTC OUTPUT WILL BE SAVED TO FILE: ', a, & + &/4x, 'OPENED ON UNIT: ', I7)" character(len=*), parameter :: fmterrasym = & "(a,' **',a,'** PRODUCES AN ASYMMETRIC COEFFICIENT MATRIX, BUT THE & - &CONJUGATE GRADIENT METHOD WAS SELECTED. USE BICGSTAB INSTEAD. ')" + &CONJUGATE GRADIENT METHOD WAS SELECTED. USE BICGSTAB INSTEAD. ')" ! ! identify package and initialize. - WRITE(IOUT,1) this%iu -00001 FORMAT(1X,/1X,'IMS -- ITERATIVE MODEL SOLUTION PACKAGE, VERSION 6', & - & ', 4/28/2017',/,9X,'INPUT READ FROM UNIT',I5) + WRITE (IOUT, 1) this%iu +00001 FORMAT(1X, /1X, 'IMS -- ITERATIVE MODEL SOLUTION PACKAGE, VERSION 6', & + ', 4/28/2017', /, 9X, 'INPUT READ FROM UNIT', I5) ! ! -- initialize i = 1 @@ -505,11 +512,11 @@ subroutine sln_ar(this) ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(/1x,a)')'PROCESSING IMS OPTIONS' + write (iout, '(/1x,a)') 'PROCESSING IMS OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -517,30 +524,30 @@ subroutine sln_ar(this) select case (keyword) case ('PRINT_OPTION') call this%parser%GetStringCaps(keyword) - if (keyword.eq.'NONE') then + if (keyword .eq. 'NONE') then this%iprims = 0 - else if (keyword.eq.'SUMMARY') then + else if (keyword .eq. 'SUMMARY') then this%iprims = 1 - else if (keyword.eq.'ALL') then + else if (keyword .eq. 'ALL') then this%iprims = 2 else - write(errmsg,'(3a)') & + write (errmsg, '(3a)') & 'UNKNOWN IMS PRINT OPTION (', trim(keyword), ').' call store_error(errmsg) end if case ('COMPLEXITY') call this%parser%GetStringCaps(keyword) - if (keyword.eq.'SIMPLE') then + if (keyword .eq. 'SIMPLE') then ifdparam = 1 - WRITE(IOUT,21) - else if (keyword.eq.'MODERATE') then + WRITE (IOUT, 21) + else if (keyword .eq. 'MODERATE') then ifdparam = 2 - WRITE(IOUT,23) - else if (keyword.eq.'COMPLEX') then + WRITE (IOUT, 23) + else if (keyword .eq. 'COMPLEX') then ifdparam = 3 - WRITE(IOUT,25) + WRITE (IOUT, 25) else - write(errmsg,'(3a)') & + write (errmsg, '(3a)') & 'UNKNOWN IMS COMPLEXITY OPTION (', trim(keyword), ').' call store_error(errmsg) end if @@ -549,11 +556,11 @@ subroutine sln_ar(this) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) this%icsvouterout = getunit() - call openfile(this%icsvouterout, iout, fname, 'CSV_OUTER_OUTPUT', & + call openfile(this%icsvouterout, iout, fname, 'CSV_OUTER_OUTPUT', & filstat_opt='REPLACE') - write(iout,fmtcsvout) trim(fname), this%icsvouterout + write (iout, fmtcsvout) trim(fname), this%icsvouterout else - write(errmsg,'(a)') 'OPTIONAL CSV_OUTER_OUTPUT ' // & + write (errmsg, '(a)') 'OPTIONAL CSV_OUTER_OUTPUT '// & 'KEYWORD MUST BE FOLLOWED BY FILEOUT' call store_error(errmsg) end if @@ -562,85 +569,85 @@ subroutine sln_ar(this) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) this%icsvinnerout = getunit() - call openfile(this%icsvinnerout, iout, fname, 'CSV_INNER_OUTPUT', & + call openfile(this%icsvinnerout, iout, fname, 'CSV_INNER_OUTPUT', & filstat_opt='REPLACE') - write(iout,fmtcsvout) trim(fname), this%icsvinnerout + write (iout, fmtcsvout) trim(fname), this%icsvinnerout else - write(errmsg,'(a)') 'OPTIONAL CSV_INNER_OUTPUT ' // & + write (errmsg, '(a)') 'OPTIONAL CSV_INNER_OUTPUT '// & 'KEYWORD MUST BE FOLLOWED BY FILEOUT' call store_error(errmsg) end if case ('NO_PTC') call this%parser%GetStringCaps(keyword) - select case(keyword) - case ('ALL') - ival = 0 - msg = 'ALL' - case ('FIRST') - ival = -1 - msg = 'THE FIRST' - case default - ival = 0 - msg = 'ALL' + select case (keyword) + case ('ALL') + ival = 0 + msg = 'ALL' + case ('FIRST') + ival = -1 + msg = 'THE FIRST' + case default + ival = 0 + msg = 'ALL' end select this%iallowptc = ival - write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION DISABLED FOR' // & - ' ' // trim(adjustl(msg)) // ' STRESS-PERIOD(S)' - case('ATS_OUTER_MAXIMUM_FRACTION') + write (IOUT, '(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION DISABLED FOR'// & + ' '//trim(adjustl(msg))//' STRESS-PERIOD(S)' + case ('ATS_OUTER_MAXIMUM_FRACTION') rval = this%parser%GetDouble() if (rval < DZERO .or. rval > DHALF) then - write(errmsg,'(a,G0)') 'VALUE FOR ATS_OUTER_MAXIMUM_FRAC MUST BE & + write (errmsg, '(a,G0)') 'VALUE FOR ATS_OUTER_MAXIMUM_FRAC MUST BE & &BETWEEN 0 AND 0.5. FOUND ', rval call store_error(errmsg) end if this%atsfrac = rval - write(IOUT,'(1x,A,G0)') 'ADAPTIVE TIME STEP SETTING FOUND. FRACTION & + write (IOUT, '(1x,A,G0)') 'ADAPTIVE TIME STEP SETTING FOUND. FRACTION & &OF OUTER MAXIMUM USED TO INCREASE OR DECREASE TIME STEP SIZE IS ',& &this%atsfrac - ! - ! -- DEPRECATED OPTIONS + ! + ! -- DEPRECATED OPTIONS case ('CSV_OUTPUT') call this%parser%GetStringCaps(keyword) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) this%icsvouterout = getunit() - call openfile(this%icsvouterout, iout, fname, 'CSV_OUTPUT', & + call openfile(this%icsvouterout, iout, fname, 'CSV_OUTPUT', & filstat_opt='REPLACE') - write(iout,fmtcsvout) trim(fname), this%icsvouterout + write (iout, fmtcsvout) trim(fname), this%icsvouterout ! ! -- create warning message - write(warnmsg,'(a)') & - 'OUTER ITERATION INFORMATION WILL BE SAVED TO ' // trim(fname) + write (warnmsg, '(a)') & + 'OUTER ITERATION INFORMATION WILL BE SAVED TO '//trim(fname) ! ! -- create deprecation warning - call deprecation_warning('OPTIONS', 'CSV_OUTPUT', '6.1.1', & + call deprecation_warning('OPTIONS', 'CSV_OUTPUT', '6.1.1', & warnmsg, this%parser%GetUnit()) else - write(errmsg,'(a)') 'OPTIONAL CSV_OUTPUT ' // & + write (errmsg, '(a)') 'OPTIONAL CSV_OUTPUT '// & 'KEYWORD MUST BE FOLLOWED BY FILEOUT' call store_error(errmsg) end if - ! - ! -- right now these are options that are only available in the - ! development version and are not included in the documentation. - ! These options are only available when IDEVELOPMODE in - ! constants module is set to 1 + ! + ! -- right now these are options that are only available in the + ! development version and are not included in the documentation. + ! These options are only available when IDEVELOPMODE in + ! constants module is set to 1 case ('DEV_PTC') call this%parser%DevOpt() this%iallowptc = 1 - write(IOUT,'(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION ENABLED' - case('DEV_PTC_OUTPUT') + write (IOUT, '(1x,A)') 'PSEUDO-TRANSIENT CONTINUATION ENABLED' + case ('DEV_PTC_OUTPUT') call this%parser%DevOpt() this%iallowptc = 1 call this%parser%GetStringCaps(keyword) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) this%iptcout = getunit() - call openfile(this%iptcout, iout, fname, 'PTC-OUT', & + call openfile(this%iptcout, iout, fname, 'PTC-OUT', & filstat_opt='REPLACE') - write(iout,fmtptcout) trim(fname), this%iptcout + write (iout, fmtptcout) trim(fname), this%iptcout else - write(errmsg,'(a)') & + write (errmsg, '(a)') & 'OPTIONAL PTC_OUTPUT KEYWORD MUST BE FOLLOWED BY FILEOUT' call store_error(errmsg) end if @@ -648,62 +655,62 @@ subroutine sln_ar(this) call this%parser%DevOpt() this%iallowptc = 1 this%iptcopt = 1 - write(IOUT,'(1x,A)') & - 'PSEUDO-TRANSIENT CONTINUATION USES BNORM AND L2NORM TO ' // & + write (IOUT, '(1x,A)') & + 'PSEUDO-TRANSIENT CONTINUATION USES BNORM AND L2NORM TO '// & 'SET INITIAL VALUE' case ('DEV_PTC_EXPONENT') call this%parser%DevOpt() rval = this%parser%GetDouble() if (rval < DZERO) then - write(errmsg,'(a)') 'PTC_EXPONENT MUST BE > 0.' + write (errmsg, '(a)') 'PTC_EXPONENT MUST BE > 0.' call store_error(errmsg) else this%iallowptc = 1 this%ptcexp = rval - write(IOUT,'(1x,A,1x,g15.7)') & + write (IOUT, '(1x,A,1x,g15.7)') & 'PSEUDO-TRANSIENT CONTINUATION EXPONENT', this%ptcexp end if case ('DEV_PTC_THRESHOLD') call this%parser%DevOpt() rval = this%parser%GetDouble() if (rval < DZERO) then - write(errmsg,'(a)') 'PTC_THRESHOLD MUST BE > 0.' + write (errmsg, '(a)') 'PTC_THRESHOLD MUST BE > 0.' call store_error(errmsg) else this%iallowptc = 1 this%ptcthresh = rval - write(IOUT,'(1x,A,1x,g15.7)') & + write (IOUT, '(1x,A,1x,g15.7)') & 'PSEUDO-TRANSIENT CONTINUATION THRESHOLD', this%ptcthresh end if case ('DEV_PTC_DEL0') call this%parser%DevOpt() rval = this%parser%GetDouble() if (rval < DZERO) then - write(errmsg,'(a)')'IMS sln_ar: PTC_DEL0 MUST BE > 0.' + write (errmsg, '(a)') 'IMS sln_ar: PTC_DEL0 MUST BE > 0.' call store_error(errmsg) else this%iallowptc = 1 this%ptcdel0 = rval - write(IOUT,'(1x,A,1x,g15.7)') & + write (IOUT, '(1x,A,1x,g15.7)') & 'PSEUDO-TRANSIENT CONTINUATION INITIAL TIMESTEP', this%ptcdel0 end if case default - write(errmsg,'(a,2(1x,a))') & + write (errmsg, '(a,2(1x,a))') & 'UNKNOWN IMS OPTION (', trim(keyword), ').' call store_error(errmsg) end select end do - write(iout,'(1x,a)')'END OF IMS OPTIONS' + write (iout, '(1x,a)') 'END OF IMS OPTIONS' else - write(iout,'(1x,a)')'NO IMS OPTION BLOCK DETECTED.' + write (iout, '(1x,a)') 'NO IMS OPTION BLOCK DETECTED.' end if -00021 FORMAT(1X,'SIMPLE OPTION:',/, & - & 1X,'DEFAULT SOLVER INPUT VALUES FOR FAST SOLUTIONS') -00023 FORMAT(1X,'MODERATE OPTION:',/,1X,'DEFAULT SOLVER', & - & ' INPUT VALUES REFLECT MODERETELY NONLINEAR MODEL') -00025 FORMAT(1X,'COMPLEX OPTION:',/,1X,'DEFAULT SOLVER', & - & ' INPUT VALUES REFLECT STRONGLY NONLINEAR MODEL') +00021 FORMAT(1X, 'SIMPLE OPTION:', /, & + 1X, 'DEFAULT SOLVER INPUT VALUES FOR FAST SOLUTIONS') +00023 FORMAT(1X, 'MODERATE OPTION:', /, 1X, 'DEFAULT SOLVER', & + ' INPUT VALUES REFLECT MODERETELY NONLINEAR MODEL') +00025 FORMAT(1X, 'COMPLEX OPTION:', /, 1X, 'DEFAULT SOLVER', & + ' INPUT VALUES REFLECT STRONGLY NONLINEAR MODEL') !-------READ NONLINEAR ITERATION PARAMETERS AND LINEAR SOLVER SELECTION INDEX ! -- set default nonlinear parameters @@ -711,11 +718,11 @@ subroutine sln_ar(this) ! ! -- get NONLINEAR block call this%parser%GetBlock('NONLINEAR', isfound, ierr, & - supportOpenClose=.true., blockRequired=.FALSE.) + supportOpenClose=.true., blockRequired=.FALSE.) ! ! -- parse NONLINEAR block if detected if (isfound) then - write(iout,'(/1x,a)')'PROCESSING IMS NONLINEAR' + write (iout, '(/1x,a)') 'PROCESSING IMS NONLINEAR' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -723,9 +730,9 @@ subroutine sln_ar(this) ! -- parse keyword select case (keyword) case ('OUTER_DVCLOSE') - this%dvclose = this%parser%GetDouble() + this%dvclose = this%parser%GetDouble() case ('OUTER_MAXIMUM') - this%mxiter = this%parser%GetInteger() + this%mxiter = this%parser%GetInteger() case ('UNDER_RELAXATION') call this%parser%GetStringCaps(keyword) ival = 0 @@ -738,7 +745,7 @@ subroutine sln_ar(this) else if (keyword == 'DBD') then ival = 3 else - write(errmsg,'(3a)') & + write (errmsg, '(3a)') & 'UNKNOWN UNDER_RELAXATION SPECIFIED (', trim(keyword), ').' call store_error(errmsg) end if @@ -746,11 +753,11 @@ subroutine sln_ar(this) case ('LINEAR_SOLVER') call this%parser%GetStringCaps(keyword) ival = 1 - if (keyword.eq.'DEFAULT' .or. & - keyword.eq.'LINEAR') then + if (keyword .eq. 'DEFAULT' .or. & + keyword .eq. 'LINEAR') then ival = 1 else - write(errmsg,'(3a)') & + write (errmsg, '(3a)') & 'UNKNOWN LINEAR_SOLVER SPECIFIED (', trim(keyword), ').' call store_error(errmsg) end if @@ -762,7 +769,7 @@ subroutine sln_ar(this) case ('UNDER_RELAXATION_GAMMA') this%gamma = this%parser%GetDouble() case ('UNDER_RELAXATION_MOMENTUM') - this%amomentum = this%parser%GetDouble() + this%amomentum = this%parser%GetDouble() case ('BACKTRACKING_NUMBER') this%numtrack = this%parser%GetInteger() IF (this%numtrack > 0) this%ibflag = 1 @@ -772,37 +779,37 @@ subroutine sln_ar(this) this%breduc = this%parser%GetDouble() case ('BACKTRACKING_RESIDUAL_LIMIT') this%res_lim = this%parser%GetDouble() - ! - ! -- deprecated variables + ! + ! -- deprecated variables case ('OUTER_HCLOSE') - this%dvclose = this%parser%GetDouble() + this%dvclose = this%parser%GetDouble() ! ! -- create warning message - write(warnmsg,'(a)') & + write (warnmsg, '(a)') & 'SETTING OUTER_DVCLOSE TO OUTER_HCLOSE VALUE' ! ! -- create deprecation warning - call deprecation_warning('NONLINEAR', 'OUTER_HCLOSE', '6.1.1', & + call deprecation_warning('NONLINEAR', 'OUTER_HCLOSE', '6.1.1', & warnmsg, this%parser%GetUnit()) case ('OUTER_RCLOSEBND') ! ! -- create warning message - write(warnmsg,'(a)') & + write (warnmsg, '(a)') & 'OUTER_DVCLOSE IS USED TO EVALUATE PACKAGE CONVERGENCE' ! ! -- create deprecation warning - call deprecation_warning('NONLINEAR', 'OUTER_RCLOSEBND', '6.1.1', & + call deprecation_warning('NONLINEAR', 'OUTER_RCLOSEBND', '6.1.1', & warnmsg, this%parser%GetUnit()) case default - write(errmsg,'(3a)') & + write (errmsg, '(3a)') & 'UNKNOWN IMS NONLINEAR KEYWORD (', trim(keyword), ').' call store_error(errmsg) end select end do - write(iout,'(1x,a)') 'END OF IMS NONLINEAR DATA' + write (iout, '(1x,a)') 'END OF IMS NONLINEAR DATA' else - if (IFDPARAM.EQ.0) then - write(errmsg,'(a)') 'NO IMS NONLINEAR BLOCK DETECTED.' + if (IFDPARAM .EQ. 0) then + write (errmsg, '(a)') 'NO IMS NONLINEAR BLOCK DETECTED.' call store_error(errmsg) end if end if @@ -818,19 +825,19 @@ subroutine sln_ar(this) ! ! -- check that MXITER is greater than zero if (this%mxiter <= 0) then - write(errmsg,'(a)') 'OUTER ITERATION NUMBER MUST BE > 0.' + write (errmsg, '(a)') 'OUTER ITERATION NUMBER MUST BE > 0.' call store_error(errmsg) END IF ! ! -- write under-relaxation option - if ( this%nonmeth > 0 )then - WRITE(IOUT,*) '**UNDER-RELAXATION WILL BE USED***' - WRITE(IOUT,*) - elseif ( this%nonmeth == 0 )then - WRITE(IOUT,*) '***UNDER-RELAXATION WILL NOT BE USED***' - WRITE(IOUT,*) + if (this%nonmeth > 0) then + WRITE (IOUT, *) '**UNDER-RELAXATION WILL BE USED***' + WRITE (IOUT, *) + elseif (this%nonmeth == 0) then + WRITE (IOUT, *) '***UNDER-RELAXATION WILL NOT BE USED***' + WRITE (IOUT, *) else - WRITE(errmsg,'(a)') & + WRITE (errmsg, '(a)') & 'INCORRECT VALUE FOR VARIABLE NONMETH WAS SPECIFIED.' call store_error(errmsg) end if @@ -838,40 +845,40 @@ subroutine sln_ar(this) ! -- ensure gamma is > 0 for simple if (this%nonmeth == 1) then if (this%gamma == 0) then - WRITE(errmsg, '(a)') & + WRITE (errmsg, '(a)') & 'GAMMA must be greater than zero if SIMPLE under-relaxation is used.' call store_error(errmsg) end if end if ! - ! -- call secondary subroutine to initialize and read linear + ! -- call secondary subroutine to initialize and read linear ! solver parameters IMSLINEAR solver - if ( this%linmeth == 1 )then - allocate(this%imslinear) - WRITE(IOUT,*) '***IMS LINEAR SOLVER WILL BE USED***' - call this%imslinear%imslinear_allocate(this%name, this%parser, IOUT, & - this%iprims, this%mxiter, & - ifdparam, imslinear, & - this%neq, this%nja, this%ia, & - this%ja, this%amat, this%rhs, & + if (this%linmeth == 1) then + allocate (this%imslinear) + WRITE (IOUT, *) '***IMS LINEAR SOLVER WILL BE USED***' + call this%imslinear%imslinear_allocate(this%name, this%parser, IOUT, & + this%iprims, this%mxiter, & + ifdparam, imslinear, & + this%neq, this%nja, this%ia, & + this%ja, this%amat, this%rhs, & this%x, this%nitermax) - WRITE(IOUT,*) - if ( imslinear.eq.1 ) then + WRITE (IOUT, *) + if (imslinear .eq. 1) then this%isymmetric = 1 end if - ! - ! -- incorrect linear solver flag + ! + ! -- incorrect linear solver flag ELSE - WRITE(errmsg, '(a)') & + WRITE (errmsg, '(a)') & 'INCORRECT VALUE FOR LINEAR SOLUTION METHOD SPECIFIED.' call store_error(errmsg) END IF ! ! -- write message about matrix symmetry if (this%isymmetric == 1) then - write(iout, '(1x,a,/)') 'A symmetric matrix will be solved' + write (iout, '(1x,a,/)') 'A symmetric matrix will be solved' else - write(iout, '(1x,a,/)') 'An asymmetric matrix will be solved' + write (iout, '(1x,a,/)') 'An asymmetric matrix will be solved' end if ! ! -- If CG, then go through each model and each exchange and check @@ -882,67 +889,67 @@ subroutine sln_ar(this) do i = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, i) if (mp%get_iasym() /= 0) then - write(errmsg, fmterrasym) 'MODEL', trim(adjustl(mp%name)) + write (errmsg, fmterrasym) 'MODEL', trim(adjustl(mp%name)) call store_error(errmsg) - endif - enddo + end if + end do ! ! -- Exchanges do i = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, i) if (cp%get_iasym() /= 0) then - write(errmsg, fmterrasym) 'EXCHANGE', trim(adjustl(cp%name)) + write (errmsg, fmterrasym) 'EXCHANGE', trim(adjustl(cp%name)) call store_error(errmsg) - endif - enddo + end if + end do ! - endif + end if ! ! -- write solver data to output file ! ! -- non-linear solver data - WRITE(IOUT,9002) this%dvclose, this%mxiter, & - this%iprims, this%nonmeth, this%linmeth + WRITE (IOUT, 9002) this%dvclose, this%mxiter, & + this%iprims, this%nonmeth, this%linmeth ! ! -- standard outer iteration formats -9002 FORMAT(1X,'OUTER ITERATION CONVERGENCE CRITERION (DVCLOSE) = ', E15.6, & - & /1X,'MAXIMUM NUMBER OF OUTER ITERATIONS (MXITER) = ', I0, & - & /1X,'SOLVER PRINTOUT INDEX (IPRIMS) = ', I0, & - & /1X,'NONLINEAR ITERATION METHOD (NONLINMETH) = ', I0, & - & /1X,'LINEAR SOLUTION METHOD (LINMETH) = ', I0) +9002 FORMAT(1X, 'OUTER ITERATION CONVERGENCE CRITERION (DVCLOSE) = ', E15.6, & + /1X, 'MAXIMUM NUMBER OF OUTER ITERATIONS (MXITER) = ', I0, & + /1X, 'SOLVER PRINTOUT INDEX (IPRIMS) = ', I0, & + /1X, 'NONLINEAR ITERATION METHOD (NONLINMETH) = ', I0, & + /1X, 'LINEAR SOLUTION METHOD (LINMETH) = ', I0) ! if (this%nonmeth == 1) then ! simple - write(iout, 9003) this%gamma + write (iout, 9003) this%gamma else if (this%nonmeth == 2) then ! cooley - write(iout, 9004) this%gamma + write (iout, 9004) this%gamma else if (this%nonmeth == 3) then ! delta bar delta - write(iout, 9005) this%theta, this%akappa, this%gamma, this%amomentum + write (iout, 9005) this%theta, this%akappa, this%gamma, this%amomentum end if ! ! -- write backtracking information - if(this%numtrack /= 0) write(iout, 9006) this%numtrack, this%btol, & - this%breduc,this%res_lim + if (this%numtrack /= 0) write (iout, 9006) this%numtrack, this%btol, & + this%breduc, this%res_lim ! ! -- under-relaxation formats (simple, cooley, dbd) -9003 FORMAT(1X,'UNDER-RELAXATION FACTOR (GAMMA) = ', E15.6) -9004 FORMAT(1X,'UNDER-RELAXATION PREVIOUS HISTORY FACTOR (GAMMA) = ', E15.6) -9005 FORMAT(1X,'UNDER-RELAXATION WEIGHT REDUCTION FACTOR (THETA) = ', E15.6, & - & /1X,'UNDER-RELAXATION WEIGHT INCREASE INCREMENT (KAPPA) = ', E15.6, & - & /1X,'UNDER-RELAXATION PREVIOUS HISTORY FACTOR (GAMMA) = ', E15.6, & - & /1X,'UNDER-RELAXATION MOMENTUM TERM (AMOMENTUM) = ', E15.6) +9003 FORMAT(1X, 'UNDER-RELAXATION FACTOR (GAMMA) = ', E15.6) +9004 FORMAT(1X, 'UNDER-RELAXATION PREVIOUS HISTORY FACTOR (GAMMA) = ', E15.6) +9005 FORMAT(1X, 'UNDER-RELAXATION WEIGHT REDUCTION FACTOR (THETA) = ', E15.6, & + /1X, 'UNDER-RELAXATION WEIGHT INCREASE INCREMENT (KAPPA) = ', E15.6, & + /1X, 'UNDER-RELAXATION PREVIOUS HISTORY FACTOR (GAMMA) = ', E15.6, & + /1X, 'UNDER-RELAXATION MOMENTUM TERM (AMOMENTUM) = ', E15.6) ! ! -- backtracking formats -9006 FORMAT(1X,'MAXIMUM NUMBER OF BACKTRACKS (NUMTRACK) = ', I0, & - & /1X,'BACKTRACKING TOLERANCE FACTOR (BTOL) = ', E15.6, & - & /1X,'BACKTRACKING REDUCTION FACTOR (BREDUC) = ', E15.6, & - & /1X,'BACKTRACKING RESIDUAL LIMIT (RES_LIM) = ', E15.6) +9006 FORMAT(1X, 'MAXIMUM NUMBER OF BACKTRACKS (NUMTRACK) = ', I0, & + /1X, 'BACKTRACKING TOLERANCE FACTOR (BTOL) = ', E15.6, & + /1X, 'BACKTRACKING REDUCTION FACTOR (BREDUC) = ', E15.6, & + /1X, 'BACKTRACKING RESIDUAL LIMIT (RES_LIM) = ', E15.6) ! ! -- linear solver data call this%imslinear%imslinear_summary(this%mxiter) ! -- write summary of solver error messages ierr = count_errors() - if (ierr>0) then + if (ierr > 0) then call this%parser%StoreErrorUnit() end if ! @@ -951,7 +958,7 @@ subroutine sln_ar(this) call mem_reallocate(this%lrch, 3, this%mxiter, 'LRCH', this%name) ! delta-bar-delta under-relaxation - if(this%nonmeth == 3)then + if (this%nonmeth == 3) then call mem_reallocate(this%wsave, this%neq, 'WSAVE', this%name) call mem_reallocate(this%hchold, this%neq, 'HCHOLD', this%name) call mem_reallocate(this%deold, this%neq, 'DEOLD', this%name) @@ -960,7 +967,7 @@ subroutine sln_ar(this) this%hchold(i) = DZERO this%deold(i) = DZERO end do - endif + end if this%hncg = DZERO this%lrch = 0 @@ -971,18 +978,18 @@ subroutine sln_ar(this) this%nitermax = 1 end if - allocate(this%caccel(this%nitermax)) + allocate (this%caccel(this%nitermax)) im = this%convnmod - call mem_reallocate(this%itinner, this%nitermax, 'ITINNER', & + call mem_reallocate(this%itinner, this%nitermax, 'ITINNER', & trim(this%name)) - call mem_reallocate(this%convlocdv, im, this%nitermax, 'CONVLOCDV', & + call mem_reallocate(this%convlocdv, im, this%nitermax, 'CONVLOCDV', & trim(this%name)) - call mem_reallocate(this%convlocdr, im, this%nitermax, 'CONVLOCDR', & + call mem_reallocate(this%convlocdr, im, this%nitermax, 'CONVLOCDR', & trim(this%name)) - call mem_reallocate(this%convdvmax, im, this%nitermax, 'CONVDVMAX', & + call mem_reallocate(this%convdvmax, im, this%nitermax, 'CONVDVMAX', & trim(this%name)) - call mem_reallocate(this%convdrmax, im, this%nitermax, 'CONVDRMAX', & + call mem_reallocate(this%convdrmax, im, this%nitermax, 'CONVDRMAX', & trim(this%name)) do i = 1, this%nitermax this%itinner(i) = 0 @@ -1018,7 +1025,7 @@ subroutine sln_calculate_delt(this) use AdaptiveTimeStepModule, only: ats_submit_delt use ConstantsModule, only: DTWO, DTHREE ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! -- local variables integer(I4B) :: idir real(DP) :: delt_temp @@ -1035,13 +1042,13 @@ subroutine sln_calculate_delt(this) fact_upper = this%mxiter - fact_lower if (this%iouttot_timestep < int(fact_lower)) then ! -- increase delt according to tsfactats - idir = 1 + idir = 1 else if (this%iouttot_timestep > int(fact_upper)) then ! -- decrease delt according to tsfactats - idir = -1 + idir = -1 else ! -- do not change delt - idir = 0 + idir = 0 end if ! ! -- submit stable dt for upcoming step @@ -1050,7 +1057,7 @@ subroutine sln_calculate_delt(this) ! return end subroutine sln_calculate_delt - + !> @ brief Advance solution !! !! Advance solution. @@ -1060,24 +1067,24 @@ subroutine sln_ad(this) ! -- modules use TdisModule, only: kstp, kper ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! ! -- write headers to CSV file if (kper == 1 .and. kstp == 1) then call this%writeCSVHeader() end if - + ! write PTC info on models to iout call this%writePTCInfoToFile(kper) - + ! reset convergence flag and inner solve counter this%icnvg = 0 - this%itertot_timestep = 0 - this%iouttot_timestep = 0 - + this%itertot_timestep = 0 + this%iouttot_timestep = 0 + return end subroutine sln_ad - + !> @ brief Output solution !! !! Output solution data. Currently does nothing. @@ -1085,7 +1092,7 @@ end subroutine sln_ad !< subroutine sln_ot(this) ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! ! -- Nothing to do here ! @@ -1100,16 +1107,16 @@ end subroutine sln_ot !< subroutine sln_fp(this) ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! - ! -- write timer output + ! -- write timer output if (IDEVELOPMODE == 1) then - write(this%imslinear%iout, '(//1x,a,1x,a,1x,a)') & + write (this%imslinear%iout, '(//1x,a,1x,a,1x,a)') & 'Solution', trim(adjustl(this%name)), 'summary' - write(this%imslinear%iout, "(1x,70('-'))") - write(this%imslinear%iout, '(1x,a,1x,g0,1x,a)') & + write (this%imslinear%iout, "(1x,70('-'))") + write (this%imslinear%iout, '(1x,a,1x,g0,1x,a)') & 'Total formulate time: ', this%ttform, 'seconds' - write(this%imslinear%iout, '(1x,a,1x,g0,1x,a,/)') & + write (this%imslinear%iout, '(1x,a,1x,g0,1x,a,/)') & 'Total solution time: ', this%ttsoln, 'seconds' end if ! @@ -1126,33 +1133,33 @@ subroutine sln_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! ! -- IMSLinearModule call this%imslinear%imslinear_da() - deallocate(this%imslinear) + deallocate (this%imslinear) ! ! -- lists call this%modellist%Clear() call this%exchangelist%Clear() - deallocate(this%modellist) - deallocate(this%exchangelist) + deallocate (this%modellist) + deallocate (this%exchangelist) ! ! -- character arrays - deallocate(this%caccel) + deallocate (this%caccel) ! ! -- inner iteration table object if (associated(this%innertab)) then call this%innertab%table_da() - deallocate(this%innertab) - nullify(this%innertab) + deallocate (this%innertab) + nullify (this%innertab) end if ! ! -- outer iteration table object if (associated(this%outertab)) then call this%outertab%table_da() - deallocate(this%outertab) - nullify(this%outertab) + deallocate (this%outertab) + nullify (this%outertab) end if ! ! -- arrays @@ -1237,102 +1244,102 @@ end subroutine sln_da !< subroutine sln_ca(this, isgcnvg, isuppress_output) ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - integer(I4B), intent(inout) :: isgcnvg !< solution group convergence flag - integer(I4B), intent(in) :: isuppress_output !< flag for suppressing output + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + integer(I4B), intent(inout) :: isgcnvg !< solution group convergence flag + integer(I4B), intent(in) :: isuppress_output !< flag for suppressing output ! -- local variables class(NumericalModelType), pointer :: mp => null() character(len=LINELENGTH) :: line character(len=LINELENGTH) :: fmt integer(I4B) :: im - integer(I4B) :: kiter ! non-linear iteration counter + integer(I4B) :: kiter ! non-linear iteration counter ! ------------------------------------------------------------------------------ - + ! advance the models, exchanges, and solution call this%prepareSolve() - + select case (isim_mode) - case (MVALIDATE) - line = 'mode="validation" -- Skipping matrix assembly and solution.' - fmt = "(/,1x,a,/)" - do im = 1, this%modellist%Count() - mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_message(line, fmt=fmt) - end do - case(MNORMAL) - ! nonlinear iteration loop for this solution - outerloop: do kiter = 1, this%mxiter - - ! perform a single iteration - call this%solve(kiter) - - ! exit if converged - if (this%icnvg == 1) then - exit outerloop - end if - - end do outerloop - - ! finish up, write convergence info, CSV file, budgets and flows, ... - call this%finalizeSolve(kiter, isgcnvg, isuppress_output) + case (MVALIDATE) + line = 'mode="validation" -- Skipping matrix assembly and solution.' + fmt = "(/,1x,a,/)" + do im = 1, this%modellist%Count() + mp => GetNumericalModelFromList(this%modellist, im) + call mp%model_message(line, fmt=fmt) + end do + case (MNORMAL) + ! nonlinear iteration loop for this solution + outerloop: do kiter = 1, this%mxiter + + ! perform a single iteration + call this%solve(kiter) + + ! exit if converged + if (this%icnvg == 1) then + exit outerloop + end if + + end do outerloop + + ! finish up, write convergence info, CSV file, budgets and flows, ... + call this%finalizeSolve(kiter, isgcnvg, isuppress_output) end select ! ! -- return return - + end subroutine sln_ca - + !> @ brief CSV header !! !! Write header for solver output to comma-separated value files. !! !< - subroutine writeCSVHeader(this) - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + subroutine writeCSVHeader(this) + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! local variables integer(I4B) :: im class(NumericalModelType), pointer :: mp => null() ! ! -- outer iteration csv header if (this%icsvouterout > 0) then - write(this%icsvouterout, '(*(G0,:,","))') & - 'total_inner_iterations', 'totim', 'kper', 'kstp', 'nouter', & - 'inner_iterations', 'solution_outer_dvmax', & - 'solution_outer_dvmax_model', 'solution_outer_dvmax_package', & + write (this%icsvouterout, '(*(G0,:,","))') & + 'total_inner_iterations', 'totim', 'kper', 'kstp', 'nouter', & + 'inner_iterations', 'solution_outer_dvmax', & + 'solution_outer_dvmax_model', 'solution_outer_dvmax_package', & 'solution_outer_dvmax_node' end if ! ! -- inner iteration csv header if (this%icsvinnerout > 0) then - write(this%icsvinnerout, '(*(G0,:,","))', advance='NO') & - 'total_inner_iterations', 'totim', 'kper', 'kstp', 'nouter', & - 'ninner', 'solution_inner_dvmax', 'solution_inner_dvmax_model', & + write (this%icsvinnerout, '(*(G0,:,","))', advance='NO') & + 'total_inner_iterations', 'totim', 'kper', 'kstp', 'nouter', & + 'ninner', 'solution_inner_dvmax', 'solution_inner_dvmax_model', & 'solution_inner_dvmax_node' - write(this%icsvinnerout, '(*(G0,:,","))', advance='NO') & - '', 'solution_inner_drmax', 'solution_inner_drmax_model', & + write (this%icsvinnerout, '(*(G0,:,","))', advance='NO') & + '', 'solution_inner_drmax', 'solution_inner_drmax_model', & 'solution_inner_drmax_node', 'solution_inner_alpha' if (this%imslinear%ilinmeth == 2) then - write(this%icsvinnerout, '(*(G0,:,","))', advance='NO') & + write (this%icsvinnerout, '(*(G0,:,","))', advance='NO') & '', 'solution_inner_omega' end if ! -- check for more than one model if (this%convnmod > 1) then - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) - write(this%icsvinnerout, '(*(G0,:,","))', advance='NO') & - '', trim(adjustl(mp%name)) // '_inner_dvmax', & - trim(adjustl(mp%name)) // '_inner_dvmax_node', & - trim(adjustl(mp%name)) // '_inner_drmax', & - trim(adjustl(mp%name)) // '_inner_drmax_node' + write (this%icsvinnerout, '(*(G0,:,","))', advance='NO') & + '', trim(adjustl(mp%name))//'_inner_dvmax', & + trim(adjustl(mp%name))//'_inner_dvmax_node', & + trim(adjustl(mp%name))//'_inner_drmax', & + trim(adjustl(mp%name))//'_inner_drmax_node' end do end if - write(this%icsvinnerout,'(a)') '' + write (this%icsvinnerout, '(a)') '' end if ! ! -- return return end subroutine writeCSVHeader - + !> @ brief PTC header !! !! Write header for pseudo-transient continuation information to a file. @@ -1341,11 +1348,11 @@ end subroutine writeCSVHeader subroutine writePTCInfoToFile(this, kper) ! -- dummy variables class(NumericalSolutionType) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: kper !< current stress period number + integer(I4B), intent(in) :: kper !< current stress period number ! -- local variable integer(I4B) :: n, im, iallowptc, iptc class(NumericalModelType), pointer :: mp => null() - + ! -- determine if PTC will be used in any model n = 1 do im = 1, this%modellist%Count() @@ -1360,24 +1367,24 @@ subroutine writePTCInfoToFile(this, kper) else iallowptc = 0 end if - ! -- no_ptc_option is ALL (0) or using PTC (1) + ! -- no_ptc_option is ALL (0) or using PTC (1) else iallowptc = this%iallowptc end if iptc = iptc * iallowptc if (iptc /= 0) then if (n == 1) then - write(iout, '(//)') + write (iout, '(//)') n = 0 end if - write(iout, '(1x,a,1x,i0,1x,3a)') & - 'PSEUDO-TRANSIENT CONTINUATION WILL BE APPLIED TO MODEL', im, '("', & + write (iout, '(1x,a,1x,i0,1x,3a)') & + 'PSEUDO-TRANSIENT CONTINUATION WILL BE APPLIED TO MODEL', im, '("', & trim(adjustl(mp%name)), '") DURING THIS TIME STEP' end if - enddo - + end do + end subroutine writePTCInfoToFile - + !> @ brief prepare to solve !! !! Prepare for the system solve by advancing the simulation. @@ -1391,29 +1398,29 @@ subroutine prepareSolve(this) integer(I4B) :: im class(NumericalExchangeType), pointer :: cp => null() class(NumericalModelType), pointer :: mp => null() - - ! -- Exchange advance - do ic=1,this%exchangelist%Count() + + ! -- Exchange advance + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_ad() - enddo - + end do + ! -- Model advance do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_ad() - enddo - + end do + ! advance solution call this%sln_ad() - + end subroutine prepareSolve - + !> @ brief Build and solve the simulation !! - !! Builds and solve the system for this numerical solution. + !! Builds and solve the system for this numerical solution. !! It roughly consists of the following steps - !! (1) backtracking, (2) reset amat and rhs (3) calculate matrix + !! (1) backtracking, (2) reset amat and rhs (3) calculate matrix !! terms (*_cf), (4) add coefficients to matrix (*_fc), (6) newton-raphson, !! (6) PTC, (7) linear solve, (8) convergence checks, (9) write output, !! and (10) underrelaxation @@ -1423,11 +1430,11 @@ subroutine solve(this, kiter) ! -- modules use TdisModule, only: kstp, kper, totim ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: kiter !< Picard iteration number + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: kiter !< Picard iteration number ! -- local variables class(NumericalModelType), pointer :: mp => null() - class(NumericalExchangeType), pointer :: cp => null() + class(NumericalExchangeType), pointer :: cp => null() character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag character(len=LINELENGTH) :: line @@ -1438,16 +1445,16 @@ subroutine solve(this, kiter) character(len=25) :: cval character(len=7) :: cmsg integer(I4B) :: ic - integer(I4B) :: im + integer(I4B) :: im integer(I4B) :: icsv0 integer(I4B) :: kcsv0 integer(I4B) :: ntabrows integer(I4B) :: ntabcols - integer(I4B) :: i0, i1 + integer(I4B) :: i0, i1 integer(I4B) :: itestmat, n - integer(I4B) :: iter - integer(I4B) :: inewtonur - integer(I4B) :: locmax_nur + integer(I4B) :: iter + integer(I4B) :: inewtonur + integer(I4B) :: locmax_nur integer(I4B) :: iend integer(I4B) :: icnvgmod integer(I4B) :: iptc @@ -1480,9 +1487,9 @@ subroutine solve(this, kiter) end if ! ! -- initialize table and define columns - title = trim(this%memoryPath) // ' OUTER ITERATION SUMMARY' + title = trim(this%memoryPath)//' OUTER ITERATION SUMMARY' call table_cr(this%outertab, this%name, title) - call this%outertab%table_df(ntabrows, ntabcols, iout, & + call this%outertab%table_df(ntabrows, ntabcols, iout, & finalize=.FALSE.) tag = 'OUTER ITERATION STEP' call this%outertab%initialize_column(tag, 25, alignment=TABLEFT) @@ -1513,35 +1520,35 @@ subroutine solve(this, kiter) if (this%numtrack > 0) then call this%sln_backtracking(mp, cp, kiter) end if - + call code_timer(0, ttform, this%ttform) - + ! (re)build the solution matrix call this%sln_buildsystem(kiter, inewton=1) - + ! ! -- Add exchange Newton-Raphson terms to solution - do ic=1,this%exchangelist%Count() + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_nr(kiter, this%ia, this%amat) - enddo + end do ! ! -- Calculate pseudo-transient continuation factor for each model iptc = 0 ptcf = DZERO - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) - call mp%model_ptc(kiter, this%neq, this%nja, & - this%ia, this%ja, this%x, & - this%rhs, this%amat, & + call mp%model_ptc(kiter, this%neq, this%nja, & + this%ia, this%ja, this%x, & + this%rhs, this%amat, & iptc, ptcf) end do ! ! -- Add model Newton-Raphson terms to solution - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_nr(kiter, this%amat, this%nja, 1) - enddo + end do call code_timer(1, ttform, this%ttform) ! ! -- linear solve @@ -1549,8 +1556,8 @@ subroutine solve(this, kiter) CALL this%sln_ls(kiter, kstp, kper, iter, iptc, ptcf) call code_timer(1, ttsoln, this%ttsoln) ! - ! -- increment counters storing the total number of linear and - ! non-linear iterations for this timestep and the total + ! -- increment counters storing the total number of linear and + ! non-linear iterations for this timestep and the total ! number of linear iterations for all timesteps this%itertot_timestep = this%itertot_timestep + iter this%iouttot_timestep = this%iouttot_timestep + 1 @@ -1561,16 +1568,16 @@ subroutine solve(this, kiter) !------------------------------------------------------- itestmat = 0 if (itestmat /= 0) then - open(99,file='sol_MF6.TXT') - WRITE(99,*) 'MATRIX SOLUTION FOLLOWS' - WRITE(99,'(10(I8,G15.4))') (n, this%x(N), N = 1, this%NEQ) - close(99) + open (99, file='sol_MF6.TXT') + WRITE (99, *) 'MATRIX SOLUTION FOLLOWS' + WRITE (99, '(10(I8,G15.4))') (n, this%x(N), N=1, this%NEQ) + close (99) call stop_with_error() end if !------------------------------------------------------- - ! + ! ! -- check convergence of solution - call this%sln_outer_check(this%hncg(kiter), this%lrch(1,kiter)) + call this%sln_outer_check(this%hncg(kiter), this%lrch(1, kiter)) if (this%icnvg /= 0) then this%icnvg = 0 if (abs(this%hncg(kiter)) <= this%dvclose) then @@ -1598,9 +1605,9 @@ subroutine solve(this, kiter) if (this%icnvg /= 0) then if (this%ptcrat > this%ptcthresh) then this%icnvg = 0 - cmsg = trim(cmsg) // 'PTC' + cmsg = trim(cmsg)//'PTC' if (iend /= 0) then - write(line, '(a)') & + write (line, '(a)') & 'PSEUDO-TRANSIENT CONTINUATION CAUSED CONVERGENCE FAILURE' call sim_message(line) end if @@ -1611,7 +1618,7 @@ subroutine solve(this, kiter) ! -- write maximum dependent-variable change from linear solver to list file if (this%iprims > 0) then cval = 'Model' - call this%sln_get_loc(this%lrch(1,kiter), strh) + call this%sln_get_loc(this%lrch(1, kiter), strh) ! ! -- add data to outertab call this%outertab%add_term(cval) @@ -1629,7 +1636,7 @@ subroutine solve(this, kiter) end if ! ! -- Additional convergence check for exchanges - do ic=1,this%exchangelist%Count() + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_cc(this%icnvg) end do @@ -1642,13 +1649,13 @@ subroutine solve(this, kiter) do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%get_mcellid(0, cmod) - call mp%model_cc(this%itertot_sim, kiter, iend, icnvgmod, & + call mp%model_cc(this%itertot_sim, kiter, iend, icnvgmod, & cpak, ipak, dpak) if (ipak /= 0) then ipos0 = index(cpak, '-', back=.true.) ipos1 = len_trim(cpak) - write(cpakout, '(a,a,"-(",i0,")",a)') & - trim(cmod), cpak(1:ipos0-1), ipak, cpak(ipos0:ipos1) + write (cpakout, '(a,a,"-(",i0,")",a)') & + trim(cmod), cpak(1:ipos0 - 1), ipak, cpak(ipos0:ipos1) else cpakout = ' ' end if @@ -1659,7 +1666,7 @@ subroutine solve(this, kiter) this%icnvg = 0 ! -- write message to stdout if (iend /= 0) then - write(line, '(3a)') & + write (line, '(3a)') & 'PACKAGE (', trim(cpakout), ') CAUSED CONVERGENCE FAILURE' call sim_message(line) end if @@ -1694,22 +1701,22 @@ subroutine solve(this, kiter) ! -- under-relaxation - only done if convergence not achieved if (this%icnvg /= 1) then if (this%nonmeth > 0) then - call this%sln_underrelax(kiter, this%hncg(kiter), this%neq, & + call this%sln_underrelax(kiter, this%hncg(kiter), this%neq, & this%active, this%x, this%xtemp) else - call this%sln_calcdx(this%neq, this%active, & - this%x, this%xtemp, this%dxold) - endif + call this%sln_calcdx(this%neq, this%active, & + this%x, this%xtemp, this%dxold) + end if ! ! -- adjust heads by newton under-relaxation, if necessary inewtonur = 0 dxmax_nur = DZERO locmax_nur = 0 - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) i0 = mp%moffset + 1 i1 = i0 + mp%neq - 1 - call mp%model_nur(mp%neq, this%x(i0:i1), this%xtemp(i0:i1), & + call mp%model_nur(mp%neq, this%x(i0:i1), this%xtemp(i0:i1), & this%dxold(i0:i1), inewtonur, dxmax_nur, locmax_nur) end do ! @@ -1721,20 +1728,20 @@ subroutine solve(this, kiter) call this%sln_maxval(this%neq, this%dxold, dxmax) ! ! -- evaluate convergence - if (abs(dxmax) <= this%dvclose .and. & - abs(this%hncg(kiter)) <= this%dvclose .and. & + if (abs(dxmax) <= this%dvclose .and. & + abs(this%hncg(kiter)) <= this%dvclose .and. & abs(dpak) <= this%dvclose) then this%icnvg = 1 ! ! -- reset outer dependent-variable change and location for output - call this%sln_outer_check(this%hncg(kiter), this%lrch(1,kiter)) + call this%sln_outer_check(this%hncg(kiter), this%lrch(1, kiter)) ! - ! -- write revised dependent-variable change data after + ! -- write revised dependent-variable change data after ! newton under-relaxation if (this%iprims > 0) then cval = 'Newton under-relaxation' cmsg = '*' - call this%sln_get_loc(this%lrch(1,kiter), strh) + call this%sln_get_loc(this%lrch(1, kiter), strh) ! ! -- add data to outertab call this%outertab%add_term(cval) @@ -1760,40 +1767,40 @@ subroutine solve(this, kiter) ! -- set outer dependent-variable change variable outer_hncg = this%hncg(kiter) ! - ! -- model convergence error + ! -- model convergence error if (abs(outer_hncg) > abs(dpak)) then ! ! -- get model number and user node number - call this%sln_get_nodeu(this%lrch(1,kiter), im, nodeu) + call this%sln_get_nodeu(this%lrch(1, kiter), im, nodeu) cpakout = '' - ! - ! -- package convergence error + ! + ! -- package convergence error else ! ! -- set convergence error, model number, user node number, ! and package name outer_hncg = dpak ipos0 = index(cmod, '_') - read(cmod(1:ipos0-1), *) im + read (cmod(1:ipos0 - 1), *) im nodeu = ipak ipos0 = index(cpak, '-', back=.true.) - cpakout = cpak(1:ipos0-1) + cpakout = cpak(1:ipos0 - 1) end if ! ! -- write line to outer iteration csv file - write(this%icsvouterout, '(*(G0,:,","))') & - this%itertot_sim, totim, kper, kstp, kiter, iter, & - outer_hncg, im, trim(cpakout), nodeu + write (this%icsvouterout, '(*(G0,:,","))') & + this%itertot_sim, totim, kper, kstp, kiter, iter, & + outer_hncg, im, trim(cpakout), nodeu end if ! ! -- write to inner iteration csv file if (this%icsvinnerout > 0) then - call this%csv_convergence_summary(this%icsvinnerout, totim, kper, kstp, & + call this%csv_convergence_summary(this%icsvinnerout, totim, kper, kstp, & kiter, iter, icsv0, kcsv0) end if - + end subroutine solve - + !> @ brief finalize a solution !! !! Finalize the solution. Called after the outer iteration loop. @@ -1803,21 +1810,21 @@ subroutine finalizeSolve(this, kiter, isgcnvg, isuppress_output) ! -- modules use TdisModule, only: kper, kstp ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: kiter !< Picard iteration number after convergence or failure - integer(I4B), intent(inout) :: isgcnvg !< solution group convergence flag + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: kiter !< Picard iteration number after convergence or failure + integer(I4B), intent(inout) :: isgcnvg !< solution group convergence flag integer(I4B), intent(in) :: isuppress_output !< flag for suppressing output ! -- local variables integer(I4B) :: ic, im class(NumericalModelType), pointer :: mp => null() class(NumericalExchangeType), pointer :: cp => null() - ! -- formats for convergence info - character(len=*), parameter :: fmtnocnvg = & - &"(1X,'Solution ', i0, ' did not converge for stress period ', i0, & + ! -- formats for convergence info + character(len=*), parameter :: fmtnocnvg = & + "(1X,'Solution ', i0, ' did not converge for stress period ', i0, & &' and time step ', i0)" - character(len=*), parameter :: fmtcnvg = & - &"(1X, I0, ' CALLS TO NUMERICAL SOLUTION ', 'IN TIME STEP ', I0, & - &' STRESS PERIOD ',I0,/1X,I0,' TOTAL ITERATIONS')" + character(len=*), parameter :: fmtcnvg = & + "(1X, I0, ' CALLS TO NUMERICAL SOLUTION ', 'IN TIME STEP ', I0, & + &' STRESS PERIOD ',I0,/1X,I0,' TOTAL ITERATIONS')" ! ! -- finalize the outer iteration table if (this%iprims > 0) then @@ -1829,62 +1836,63 @@ subroutine finalizeSolve(this, kiter, isgcnvg, isuppress_output) ! -- convergence was achieved if (this%icnvg /= 0) then if (this%iprims > 0) then - write(iout, fmtcnvg) kiter, kstp, kper, this%itertot_timestep + write (iout, fmtcnvg) kiter, kstp, kper, this%itertot_timestep end if - ! - ! -- convergence was not achieved + ! + ! -- convergence was not achieved else - write(iout, fmtnocnvg) this%id, kper, kstp + write (iout, fmtnocnvg) this%id, kper, kstp end if ! ! -- write inner iteration convergence summary if (this%iprims == 2) then ! ! -- write summary for each model - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call this%convergence_summary(mp%iout, im, this%itertot_timestep) end do ! ! -- write summary for entire solution - call this%convergence_summary(iout, this%convnmod+1, this%itertot_timestep) + call this%convergence_summary(iout, this%convnmod + 1, & + this%itertot_timestep) end if ! ! -- set solution goup convergence flag if (this%icnvg == 0) isgcnvg = 0 ! ! -- Calculate flow for each model - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_cq(this%icnvg, isuppress_output) - enddo + end do ! ! -- Calculate flow for each exchange do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_cq(isgcnvg, isuppress_output, this%id) - enddo + end do ! ! -- Budget terms for each model - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_bd(this%icnvg, isuppress_output) - enddo + end do ! ! -- Budget terms for each exchange do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_bd(isgcnvg, isuppress_output, this%id) - enddo - + end do + end subroutine finalizeSolve - + ! helper routine to calculate coefficients and setup the solution matrix subroutine sln_buildsystem(this, kiter, inewton) class(NumericalSolutionType) :: this integer(I4B), intent(in) :: kiter integer(I4B), intent(in) :: inewton - + ! local integer(I4B) :: im, ic class(NumericalModelType), pointer :: mp @@ -1892,34 +1900,34 @@ subroutine sln_buildsystem(this, kiter, inewton) ! ! -- Set amat and rhs to zero call this%sln_reset() - + ! ! -- Calculate the matrix terms for each exchange - do ic=1,this%exchangelist%Count() + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_cf(kiter) - enddo + end do ! ! -- Calculate the matrix terms for each model - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_cf(kiter) - enddo + end do ! ! -- Add exchange coefficients to the solution - do ic=1,this%exchangelist%Count() + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_fc(kiter, this%ia, this%amat, this%rhs, inewton) - enddo + end do ! ! -- Add model coefficients to the solution - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_fc(kiter, this%amat, this%nja, inewton) - enddo - + end do + end subroutine sln_buildsystem - + !> @ brief Solution convergence summary !! !! Save convergence summary to a File. @@ -1927,12 +1935,12 @@ end subroutine sln_buildsystem !< subroutine convergence_summary(this, iu, im, itertot_timestep) ! -- modules - use InputOutputModule, only:getunit + use InputOutputModule, only: getunit ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: iu !< file unit number for summary file - integer(I4B), intent(in) :: im !< model number - integer(I4B), intent(in) :: itertot_timestep !< total iteration for the time step + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: iu !< file unit number for summary file + integer(I4B), intent(in) :: im !< model number + integer(I4B), intent(in) :: itertot_timestep !< total iteration for the time step ! -- local variables character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag @@ -1966,7 +1974,7 @@ subroutine convergence_summary(this, iu, im, itertot_timestep) ntabcols = 7 ! ! -- initialize table and define columns - title = trim(this%memoryPath) // ' INNER ITERATION SUMMARY' + title = trim(this%memoryPath)//' INNER ITERATION SUMMARY' call table_cr(this%innertab, this%name, title) call this%innertab%table_df(ntabrows, ntabcols, iu) tag = 'TOTAL ITERATION' @@ -1983,8 +1991,8 @@ subroutine convergence_summary(this, iu, im, itertot_timestep) call this%innertab%initialize_column(tag, 15, alignment=TABRIGHT) tag = 'MAXIMUM RESIDUAL MODEL-(CELLID)' call this%innertab%initialize_column(tag, LENPAKLOC, alignment=TABRIGHT) - ! - ! -- reset the output unit and the number of rows (maxbound) + ! + ! -- reset the output unit and the number of rows (maxbound) else call this%innertab%set_maxbound(itertot_timestep) call this%innertab%set_iout(iu) @@ -2036,26 +2044,25 @@ subroutine convergence_summary(this, iu, im, itertot_timestep) return end subroutine convergence_summary - !> @ brief Solution convergence CSV summary !! !! Save convergence summary to a comma-separated value file. !! !< - subroutine csv_convergence_summary(this, iu, totim, kper, kstp, kouter, & + subroutine csv_convergence_summary(this, iu, totim, kper, kstp, kouter, & niter, istart, kstart) ! -- modules - use InputOutputModule, only:getunit + use InputOutputModule, only: getunit ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: iu !< file unit number - real(DP), intent(in) :: totim !< total simulation time - integer(I4B), intent(in) :: kper !< stress period number - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kouter !< number of outer (Picard) iterations - integer(I4B), intent(in) :: niter !< number of inner iteration in this time step - integer(I4B), intent(in) :: istart !< starting iteration number for this time step - integer(I4B), intent(in) :: kstart !< starting position in the conv* arrays + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: iu !< file unit number + real(DP), intent(in) :: totim !< total simulation time + integer(I4B), intent(in) :: kper !< stress period number + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kouter !< number of outer (Picard) iterations + integer(I4B), intent(in) :: niter !< number of inner iteration in this time step + integer(I4B), intent(in) :: istart !< starting iteration number for this time step + integer(I4B), intent(in) :: kstart !< starting position in the conv* arrays ! -- local integer(I4B) :: itot integer(I4B) :: im @@ -2075,7 +2082,7 @@ subroutine csv_convergence_summary(this, iu, totim, kper, kstp, kouter, & ! -- write inner iteration results to the inner csv output file do k = 1, niter kpos = kstart + k - 1 - write(iu, '(*(G0,:,","))', advance='NO') & + write (iu, '(*(G0,:,","))', advance='NO') & itot, totim, kper, kstp, kouter, k ! ! -- solution summary @@ -2094,14 +2101,14 @@ subroutine csv_convergence_summary(this, iu, totim, kper, kstp, kouter, & ! ! -- get model number and user node number for dv call this%sln_get_nodeu(locdv, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dv, im, nodeu + write (iu, '(*(G0,:,","))', advance='NO') '', dv, im, nodeu ! ! -- get model number and user node number for dr call this%sln_get_nodeu(locdr, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dr, im, nodeu + write (iu, '(*(G0,:,","))', advance='NO') '', dr, im, nodeu ! ! -- write acceleration parameters - write(iu, '(*(G0,:,","))', advance='NO') & + write (iu, '(*(G0,:,","))', advance='NO') & '', trim(adjustl(this%caccel(kpos))) ! ! -- write information for each model @@ -2114,23 +2121,23 @@ subroutine csv_convergence_summary(this, iu, totim, kper, kstp, kouter, & ! ! -- get model number and user node number for dv call this%sln_get_nodeu(locdv, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dv, nodeu + write (iu, '(*(G0,:,","))', advance='NO') '', dv, nodeu ! ! -- get model number and user node number for dr call this%sln_get_nodeu(locdr, im, nodeu) - write(iu, '(*(G0,:,","))', advance='NO') '', dr, nodeu + write (iu, '(*(G0,:,","))', advance='NO') '', dr, nodeu end do end if ! ! -- write line - write(iu,'(a)') '' + write (iu, '(a)') '' ! ! -- update itot itot = itot + 1 end do ! ! -- flush file - flush(iu) + flush (iu) ! ! -- return return @@ -2138,33 +2145,33 @@ end subroutine csv_convergence_summary !> @ brief Save solution data to a file !! - !! Save solution ia vector, ja vector , coefficient matrix, right-hand side + !! Save solution ia vector, ja vector , coefficient matrix, right-hand side !! vector, and the dependent-variable vector to a file. !! !< subroutine save(this, filename) ! -- modules - use InputOutputModule, only:getunit + use InputOutputModule, only: getunit ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - character(len=*), intent(in) :: filename !< filename to save solution data + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + character(len=*), intent(in) :: filename !< filename to save solution data ! -- local variables integer(I4B) :: inunit ! ------------------------------------------------------------------------------ ! inunit = getunit() - open(unit=inunit,file=filename,status='unknown') - write(inunit,*) 'ia' - write(inunit,*) this%ia - write(inunit,*) 'ja' - write(inunit,*) this%ja - write(inunit,*) 'amat' - write(inunit,*) this%amat - write(inunit,*) 'rhs' - write(inunit,*) this%rhs - write(inunit,*) 'x' - write(inunit,*) this%x - close(inunit) + open (unit=inunit, file=filename, status='unknown') + write (inunit, *) 'ia' + write (inunit, *) this%ia + write (inunit, *) 'ja' + write (inunit, *) this%ja + write (inunit, *) 'amat' + write (inunit, *) this%amat + write (inunit, *) 'rhs' + write (inunit, *) this%rhs + write (inunit, *) 'x' + write (inunit, *) this%x + close (inunit) ! ! -- return return @@ -2177,13 +2184,13 @@ end subroutine save !< subroutine add_model(this, mp) ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - class(BaseModelType), pointer, intent(in) :: mp !< model instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(BaseModelType), pointer, intent(in) :: mp !< model instance ! -- local variables class(NumericalModelType), pointer :: m => null() ! ! -- add a model - select type(mp) + select type (mp) class is (NumericalModelType) m => mp call AddNumericalModelToList(this%modellist, m) @@ -2200,7 +2207,7 @@ end subroutine add_model !< function get_models(this) result(models) ! -- return variable - type(ListType), pointer :: models !< pointer to the model list + type(ListType), pointer :: models !< pointer to the model list ! -- dummy variables class(NumericalSolutionType) :: this !< NumericalSolutionType instance @@ -2215,13 +2222,13 @@ end function get_models !< subroutine add_exchange(this, exchange) ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance - class(BaseExchangeType), pointer, intent(in) :: exchange !< model exchange instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(BaseExchangeType), pointer, intent(in) :: exchange !< model exchange instance ! -- local variables class(NumericalExchangeType), pointer :: num_ex => null() ! ! -- add exchange - select type(exchange) + select type (exchange) class is (NumericalExchangeType) num_ex => exchange call AddNumericalExchangeToList(this%exchangelist, num_ex) @@ -2235,17 +2242,17 @@ end subroutine add_exchange !< function get_exchanges(this) result(exchanges) class(NumericalSolutionType) :: this !< instance of the numerical solution - type(ListType), pointer :: exchanges !< pointer to the exchange list + type(ListType), pointer :: exchanges !< pointer to the exchange list exchanges => this%exchangelist end function get_exchanges - + !> @ brief Assign solution connections !! - !! Assign solution connections. This is the main workhorse method for a - !! solution. The method goes through all the models and all the connections - !! and builds up the sparse matrix. Steps are (1) add internal model + !! Assign solution connections. This is the main workhorse method for a + !! solution. The method goes through all the models and all the connections + !! and builds up the sparse matrix. Steps are (1) add internal model !! connections, (2) add cross terms, (3) allocate solution arrays, (4) create !! mapping arrays, and (5) fill cross term values if necessary. !! @@ -2254,7 +2261,7 @@ subroutine sln_connect(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! -- local variables class(NumericalModelType), pointer :: mp => null() class(NumericalExchangeType), pointer :: cp => null() @@ -2263,39 +2270,39 @@ subroutine sln_connect(this) integer(I4B) :: ierror ! ! -- Add internal model connections to sparse - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_ac(this%sparse) - enddo + end do ! ! -- Add the cross terms to sparse - do ic=1,this%exchangelist%Count() + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_ac(this%sparse) - enddo - ! + end do + ! ! -- The number of non-zero array values are now known so ! -- ia and ja can be created from sparse. then destroy sparse - this%nja=this%sparse%nnz + this%nja = this%sparse%nnz call mem_allocate(this%ja, this%nja, 'JA', this%name) call mem_allocate(this%amat, this%nja, 'AMAT', this%name) call this%sparse%sort() - call this%sparse%filliaja(this%ia,this%ja,ierror) + call this%sparse%filliaja(this%ia, this%ja, ierror) call this%sparse%destroy() ! ! -- Create mapping arrays for each model. Mapping assumes ! -- that each row has the diagonal in the first position, ! -- however, rows do not need to be sorted. - do im=1,this%modellist%Count() + do im = 1, this%modellist%Count() mp => GetNumericalModelFromList(this%modellist, im) call mp%model_mc(this%ia, this%ja) - enddo + end do ! ! -- Create arrays for mapping exchange connections to global solution - do ic=1,this%exchangelist%Count() + do ic = 1, this%exchangelist%Count() cp => GetNumericalExchangeFromList(this%exchangelist, ic) call cp%exg_mc(this%ia, this%ja) - enddo + end do ! ! -- return return @@ -2303,13 +2310,13 @@ end subroutine sln_connect !> @ brief Reset the solution !! - !! Reset the solution by setting the coefficient matrix and right-hand side + !! Reset the solution by setting the coefficient matrix and right-hand side !! vectors to zero. !! !< subroutine sln_reset(this) ! -- dummy variables - class(NumericalSolutionType) :: this !< NumericalSolutionType instance + class(NumericalSolutionType) :: this !< NumericalSolutionType instance ! -- local variables integer(I4B) :: i ! @@ -2333,7 +2340,7 @@ end subroutine sln_reset !< subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance integer(I4B), intent(in) :: kiter integer(I4B), intent(in) :: kstp integer(I4B), intent(in) :: kper @@ -2373,9 +2380,9 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) adiag = abs(this%amat(this%ia(n))) if (adiag < DEM15) then this%amat(this%ia(n)) = diagval - this%rhs(n) = this%rhs(n) + diagval * this%x(n) - endif - ! -- Dirichlet boundary or no-flow cell + this%rhs(n) = this%rhs(n) + diagval * this%x(n) + end if + ! -- Dirichlet boundary or no-flow cell else this%amat(this%ia(n)) = DONE this%rhs(n) = this%x(n) @@ -2414,8 +2421,8 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) else iallowptc = 0 end if - ! - ! -- no_ptc_option is ALL (0) or using PTC (1) + ! + ! -- no_ptc_option is ALL (0) or using PTC (1) else iallowptc = this%iallowptc end if @@ -2426,8 +2433,8 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) ! -- calculate or modify pseudo transient continuation terms and add ! to amat diagonals if (iptct /= 0) then - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & this%amat, this%rhs, this%x, l2norm) ! -- confirm that the l2norm exceeds previous l2norm ! if not, there is no need to add ptc terms @@ -2448,9 +2455,9 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) if (iptct /= 0) then if (kiter == 1) then if (this%iptcout > 0) then - write(this%iptcout, '(A10,6(1x,A15),2(1x,A15))') 'OUTER ITER', & - ' PTCDEL', ' L2NORM0', ' L2NORM', & - ' RHSNORM', ' 1/PTCDEL', ' DIAGONAL MIN.', & + write (this%iptcout, '(A10,6(1x,A15),2(1x,A15))') 'OUTER ITER', & + ' PTCDEL', ' L2NORM0', ' L2NORM', & + ' RHSNORM', ' 1/PTCDEL', ' DIAGONAL MIN.', & ' RHSNORM/L2NORM', ' STOPPING CRIT.' end if if (this%ptcdel0 > DZERO) then @@ -2463,7 +2470,7 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) else bnorm = DZERO do n = 1, this%neq - if (this%active(n).gt.0) then + if (this%active(n) .gt. 0) then bnorm = bnorm + this%rhs(n) * this%rhs(n) end if end do @@ -2496,9 +2503,9 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) end do bnorm = sqrt(bnorm) if (this%iptcout > 0) then - write(this%iptcout, '(i10,6(1x,e15.7),2(1x,f15.6))') & - kiter, this%ptcdel, this%l2norm0, l2norm, bnorm, & - ptcval, diagmin, bnorm/l2norm, ptcval / diagmin + write (this%iptcout, '(i10,6(1x,e15.7),2(1x,f15.6))') & + kiter, this%ptcdel, this%l2norm0, l2norm, bnorm, & + ptcval, diagmin, bnorm / l2norm, ptcval / diagmin end if this%l2norm0 = l2norm end if @@ -2508,17 +2515,17 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) !------------------------------------------------------- itestmat = 0 if (itestmat == 1) then - write(fname, fmtfname) this%id, kper, kstp, kiter + write (fname, fmtfname) this%id, kper, kstp, kiter print *, 'Saving amat to: ', trim(adjustl(fname)) - open(99,file=trim(adjustl(fname))) - WRITE(99,*)'NODE, RHS, AMAT FOLLOW' + open (99, file=trim(adjustl(fname))) + WRITE (99, *) 'NODE, RHS, AMAT FOLLOW' DO N = 1, this%NEQ I1 = this%IA(N) - I2 = this%IA(N+1)-1 - WRITE(99,'(*(G0,:,","))') N, this%RHS(N), (this%ja(i),i=i1,i2), & - (this%AMAT(I),I=I1,I2) + I2 = this%IA(N + 1) - 1 + WRITE (99, '(*(G0,:,","))') N, this%RHS(N), (this%ja(i), i=i1, i2), & + (this%AMAT(I), I=I1, I2) END DO - close(99) + close (99) !stop end if !------------------------------------------------------- @@ -2527,13 +2534,13 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) ! ! -- ims linear solver - linmeth option 1 if (this%linmeth == 1) then - call this%imslinear%imslinear_apply(this%icnvg, kstp, kiter, in_iter, & - this%nitermax, & - this%convnmod, this%convmodstart, & - this%locdv, this%locdr, & - this%caccel, this%itinner, & - this%convlocdv, this%convlocdr, & - this%dvmax, this%drmax, & + call this%imslinear%imslinear_apply(this%icnvg, kstp, kiter, in_iter, & + this%nitermax, & + this%convnmod, this%convmodstart, & + this%locdv, this%locdr, & + this%caccel, this%itinner, & + this%convlocdv, this%convlocdr, & + this%dvmax, this%drmax, & this%convdvmax, this%convdrmax) end if ! @@ -2557,12 +2564,12 @@ end subroutine sln_ls !< subroutine sln_setouter(this, ifdparam) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: ifdparam !< complexity option (1) simple (2) moderate (3) complex + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: ifdparam !< complexity option (1) simple (2) moderate (3) complex ! ! -- simple option - select case ( ifdparam ) - case ( 1 ) + select case (ifdparam) + case (1) this%dvclose = dem3 this%mxiter = 25 this%nonmeth = 0 @@ -2574,9 +2581,9 @@ subroutine sln_setouter(this, ifdparam) this%btol = DZERO this%breduc = DZERO this%res_lim = DZERO - ! - ! -- moderate - case ( 2 ) + ! + ! -- moderate + case (2) this%dvclose = dem2 this%mxiter = 50 this%nonmeth = 3 @@ -2588,9 +2595,9 @@ subroutine sln_setouter(this, ifdparam) this%btol = DZERO this%breduc = DZERO this%res_lim = DZERO - ! - ! -- complex - case ( 3 ) + ! + ! -- complex + case (3) this%dvclose = dem1 this%mxiter = 100 this%nonmeth = 3 @@ -2611,16 +2618,16 @@ end subroutine sln_setouter !> @ brief Perform backtracking !! !! Perform backtracking on the solution in the maximum number of backtrack - !! iterations (nbtrack) is greater than 0 and the backtracking criteria + !! iterations (nbtrack) is greater than 0 and the backtracking criteria !! are exceeded. !! !< subroutine sln_backtracking(this, mp, cp, kiter) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - class(NumericalModelType), pointer :: mp !< model pointer (currently null()) - class(NumericalExchangeType), pointer :: cp !< exchange pointer (currently null()) - integer(I4B), intent(in) :: kiter !< Picard iteration number + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + class(NumericalModelType), pointer :: mp !< model pointer (currently null()) + class(NumericalExchangeType), pointer :: cp !< exchange pointer (currently null()) + integer(I4B), intent(in) :: kiter !< Picard iteration number ! -- local variables character(len=7) :: cmsg integer(I4B) :: nb @@ -2631,23 +2638,23 @@ subroutine sln_backtracking(this, mp, cp, kiter) ! ! -- initialize local variables ibflag = 0 - + ! ! -- refill amat and rhs with standard conductance call this%sln_buildsystem(kiter, inewton=0) - + ! ! -- calculate initial l2 norm if (kiter == 1) then - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, this%res_prev) + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, this%res_prev) resin = this%res_prev ibflag = 0 else - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, this%res_new) + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, this%res_new) resin = this%res_new end if ibtcnt = 0 @@ -2667,15 +2674,15 @@ subroutine sln_backtracking(this, mp, cp, kiter) end if ! ibtcnt = nb - + ! recalculate linear system (amat and rhs) call this%sln_buildsystem(kiter, inewton=0) - + ! ! -- calculate updated l2norm - call this%sln_l2norm(this%neq, this%nja, & - this%ia, this%ja, this%active, & - this%amat, this%rhs, this%x, this%res_new) + call this%sln_l2norm(this%neq, this%nja, & + this%ia, this%ja, this%active, & + this%amat, this%rhs, this%x, this%res_new) ! ! -- evaluate if back tracking can be terminated if (nb == this%numtrack) then @@ -2683,7 +2690,7 @@ subroutine sln_backtracking(this, mp, cp, kiter) exit btloop end if if (this%res_new < this%res_prev * this%btol) then - ibflag = 1 + ibflag = 1 exit btloop end if if (this%res_new < this%res_lim) then @@ -2704,7 +2711,7 @@ subroutine sln_backtracking(this, mp, cp, kiter) end if ! ! -- add data to outertab - call this%outertab%add_term( 'Backtracking') + call this%outertab%add_term('Backtracking') call this%outertab%add_term(kiter) call this%outertab%add_term(' ') if (this%numtrack > 0) then @@ -2731,7 +2738,7 @@ end subroutine sln_backtracking subroutine sln_backtracking_xupdate(this, btflag) ! -- dummy variables class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(inout) :: btflag !< backtracking flag (1) backtracking performed (0) backtracking not performed + integer(I4B), intent(inout) :: btflag !< backtracking flag (1) backtracking performed (0) backtracking not performed ! -- local variables integer(I4B) :: n real(DP) :: delx @@ -2745,7 +2752,7 @@ subroutine sln_backtracking_xupdate(this, btflag) chmax = 0.0 do n = 1, this%neq if (this%active(n) < 1) cycle - delx = this%breduc*(this%x(n) - this%xtemp(n)) + delx = this%breduc * (this%x(n) - this%xtemp(n)) absdelx = abs(delx) if (absdelx > chmax) chmax = absdelx end do @@ -2755,7 +2762,7 @@ subroutine sln_backtracking_xupdate(this, btflag) btflag = 1 do n = 1, this%neq if (this%active(n) < 1) cycle - delx = this%breduc*(this%x(n) - this%xtemp(n)) + delx = this%breduc * (this%x(n) - this%xtemp(n)) this%x(n) = this%xtemp(n) + delx end do end if @@ -2772,16 +2779,16 @@ end subroutine sln_backtracking_xupdate !< subroutine sln_l2norm(this, neq, nja, ia, ja, active, amat, rhs, x, l2norm) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: neq !< number of equations - integer(I4B), intent(in) :: nja !< number of non-zero entries - integer(I4B), dimension(neq+1), intent(in) :: ia !< CRS row pointers - integer(I4B), dimension(nja), intent(in) :: ja !< CRS column pointers - integer(I4B), dimension(neq), intent(in) :: active !< active cell flag vector (1) inactive (0) - real(DP), dimension(nja), intent(in) :: amat !< coefficient matrix - real(DP), dimension(neq), intent(in) :: rhs !< right-hand side vector - real(DP), dimension(neq), intent(in) :: x !< dependent-variable vector - real(DP), intent(inout) :: l2norm !< calculated L-2 norm + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: neq !< number of equations + integer(I4B), intent(in) :: nja !< number of non-zero entries + integer(I4B), dimension(neq + 1), intent(in) :: ia !< CRS row pointers + integer(I4B), dimension(nja), intent(in) :: ja !< CRS column pointers + integer(I4B), dimension(neq), intent(in) :: active !< active cell flag vector (1) inactive (0) + real(DP), dimension(nja), intent(in) :: amat !< coefficient matrix + real(DP), dimension(neq), intent(in) :: rhs !< right-hand side vector + real(DP), dimension(neq), intent(in) :: x !< dependent-variable vector + real(DP), intent(inout) :: l2norm !< calculated L-2 norm ! -- local variables integer(I4B) :: n integer(I4B) :: j @@ -2796,7 +2803,7 @@ subroutine sln_l2norm(this, neq, nja, ia, ja, active, amat, rhs, x, l2norm) do n = 1, neq if (active(n) > 0) then rowsum = DZERO - do j = ia(n), ia(n+1)-1 + do j = ia(n), ia(n + 1) - 1 jcol = ja(j) rowsum = rowsum + amat(j) * x(jcol) end do @@ -2818,10 +2825,10 @@ end subroutine sln_l2norm !< subroutine sln_maxval(this, nsize, v, vmax) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: nsize !< length of vector - real(DP), dimension(nsize), intent(in) :: v !< input vector - real(DP), intent(inout) :: vmax !< maximum value + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: nsize !< length of vector + real(DP), dimension(nsize), intent(in) :: v !< input vector + real(DP), intent(inout) :: vmax !< maximum value ! -- local variables integer(I4B) :: n real(DP) :: d @@ -2855,12 +2862,12 @@ end subroutine sln_maxval !< subroutine sln_calcdx(this, neq, active, x, xtemp, dx) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: neq !< number of equations - integer(I4B), dimension(neq), intent(in) :: active !< active cell flag (1) - real(DP), dimension(neq), intent(in) :: x !< current dependent-variable - real(DP), dimension(neq), intent(in) :: xtemp !< previous dependent-variable - real(DP), dimension(neq), intent(inout) :: dx !< dependent-variable change + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: neq !< number of equations + integer(I4B), dimension(neq), intent(in) :: active !< active cell flag (1) + real(DP), dimension(neq), intent(in) :: x !< current dependent-variable + real(DP), dimension(neq), intent(in) :: xtemp !< previous dependent-variable + real(DP), dimension(neq), intent(inout) :: dx !< dependent-variable change ! -- local integer(I4B) :: n ! @@ -2878,7 +2885,6 @@ subroutine sln_calcdx(this, neq, active, x, xtemp, dx) return end subroutine sln_calcdx - !> @ brief Under-relaxation !! !! Under relax using the simple, cooley, or delta-bar-delta methods. @@ -2886,13 +2892,13 @@ end subroutine sln_calcdx !< subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: kiter !< Picard iteration number - real(DP), intent(in) :: bigch !< maximum dependent-variable change - integer(I4B), intent(in) :: neq !< number of equations - integer(I4B), dimension(neq), intent(in) :: active !< active cell flag (1) - real(DP), dimension(neq), intent(inout) :: x !< current dependent-variable - real(DP), dimension(neq), intent(in) :: xtemp !< previous dependent-variable + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: kiter !< Picard iteration number + real(DP), intent(in) :: bigch !< maximum dependent-variable change + integer(I4B), intent(in) :: neq !< number of equations + integer(I4B), dimension(neq), intent(in) :: active !< active cell flag (1) + real(DP), dimension(neq), intent(inout) :: x !< current dependent-variable + real(DP), dimension(neq), intent(in) :: xtemp !< previous dependent-variable ! -- local variables integer(I4B) :: n real(DP) :: ww @@ -2917,8 +2923,8 @@ subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) ! -- dampen dependent variable solution x(n) = xtemp(n) + this%gamma * delx end do - ! - ! -- option for using cooley underrelaxation + ! + ! -- option for using cooley underrelaxation else if (this%nonmeth == 2) then ! ! -- set bigch @@ -2943,7 +2949,7 @@ subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) this%relaxold = relax ! ! -- modify cooley to use weighted average of past changes - this%bigchold = (DONE - this%gamma) * this%bigch + this%gamma * & + this%bigchold = (DONE - this%gamma) * this%bigch + this%gamma * & this%bigchold ! ! -- compute new dependent variable after under-relaxation @@ -2959,8 +2965,8 @@ subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) x(n) = xtemp(n) + relax * delx end do end if - ! - ! -- option for using delta-bar-delta scheme to under-relax for all equations + ! + ! -- option for using delta-bar-delta scheme to under-relax for all equations else if (this%nonmeth == 3) then do n = 1, neq ! @@ -2971,7 +2977,7 @@ subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) delx = x(n) - xtemp(n) ! ! -- initialize values for first iteration - if ( kiter == 1 ) then + if (kiter == 1) then this%wsave(n) = DONE this%hchold(n) = DEM20 this%deold(n) = DZERO @@ -2981,20 +2987,20 @@ subroutine sln_underrelax(this, kiter, bigch, neq, active, x, xtemp) ww = this%wsave(n) ! ! for flip-flop condition, decrease factor - if ( this%deold(n)*delx < DZERO ) then + if (this%deold(n) * delx < DZERO) then ww = this%theta * this%wsave(n) ! -- when change is of same sign, increase factor else ww = this%wsave(n) + this%akappa end if - if ( ww > DONE ) ww = DONE + if (ww > DONE) ww = DONE this%wsave(n) = ww ! ! -- compute weighted average of past changes in hchold if (kiter == 1) then this%hchold(n) = delx else - this%hchold(n) = (DONE - this%gamma) * delx + & + this%hchold(n) = (DONE - this%gamma) * delx + & this%gamma * this%hchold(n) end if ! @@ -3017,15 +3023,15 @@ end subroutine sln_underrelax !> @ brief Determine maximum dependent-variable change !! - !! Determine the maximum dependent-variable change at the end of a + !! Determine the maximum dependent-variable change at the end of a !! Picard iteration. !! !< subroutine sln_outer_check(this, hncg, lrch) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - real(DP), intent(inout) :: hncg !< maximum dependent-variable change - integer(I4B), intent(inout) :: lrch !< location of the maximum dependent-variable change + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + real(DP), intent(inout) :: hncg !< maximum dependent-variable change + integer(I4B), intent(inout) :: lrch !< location of the maximum dependent-variable change ! -- local variables integer(I4B) :: nb real(DP) :: bigch @@ -3039,7 +3045,7 @@ subroutine sln_outer_check(this, hncg, lrch) bigch = DZERO abigch = DZERO do n = 1, this%neq - if(this%active(n) < 1) cycle + if (this%active(n) < 1) cycle hdif = this%x(n) - this%xtemp(n) ahdif = abs(hdif) if (ahdif >= abigch) then @@ -3064,11 +3070,11 @@ end subroutine sln_outer_check !< subroutine sln_get_loc(this, nodesln, str) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: nodesln !< solution node number - character(len=*), intent(inout) :: str !< string with user node number + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: nodesln !< solution node number + character(len=*), intent(inout) :: str !< string with user node number ! -- local variables - class(NumericalModelType), pointer :: mp=> null() + class(NumericalModelType), pointer :: mp => null() integer(I4B) :: i integer(I4B) :: istart integer(I4B) :: iend @@ -3104,12 +3110,12 @@ end subroutine sln_get_loc !< subroutine sln_get_nodeu(this, nodesln, im, nodeu) ! -- dummy variables - class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance - integer(I4B), intent(in) :: nodesln !< solution node number - integer(I4B), intent(inout) :: im !< solution model number - integer(I4B), intent(inout) :: nodeu !< user node number + class(NumericalSolutionType), intent(inout) :: this !< NumericalSolutionType instance + integer(I4B), intent(in) :: nodesln !< solution node number + integer(I4B), intent(inout) :: im !< solution model number + integer(I4B), intent(inout) :: nodeu !< user node number ! -- local variables - class(NumericalModelType),pointer :: mp => null() + class(NumericalModelType), pointer :: mp => null() integer(I4B) :: i integer(I4B) :: istart integer(I4B) :: iend @@ -3141,11 +3147,11 @@ end subroutine sln_get_nodeu !! Get a numerical solution from a list. !! !< - function CastAsNumericalSolutionClass(obj) result (res) + function CastAsNumericalSolutionClass(obj) result(res) ! -- dummy variables - class(*), pointer, intent(inout) :: obj !< generic object + class(*), pointer, intent(inout) :: obj !< generic object ! -- return variable - class(NumericalSolutionType), pointer :: res !< output NumericalSolutionType + class(NumericalSolutionType), pointer :: res !< output NumericalSolutionType ! ! -- initialize return variable res => null() @@ -3162,18 +3168,18 @@ function CastAsNumericalSolutionClass(obj) result (res) ! -- return return end function CastAsNumericalSolutionClass - + !> @ brief Get a numerical solution !! !! Get a numerical solution from a list. !! !< - function GetNumericalSolutionFromList(list, idx) result (res) + function GetNumericalSolutionFromList(list, idx) result(res) ! -- dummy variables - type(ListType), intent(inout) :: list !< list of numerical solutions - integer(I4B), intent(in) :: idx !< value to retrieve from the list + type(ListType), intent(inout) :: list !< list of numerical solutions + integer(I4B), intent(in) :: idx !< value to retrieve from the list ! -- return variables - class(NumericalSolutionType), pointer :: res !< numerical solution + class(NumericalSolutionType), pointer :: res !< numerical solution ! -- local variables class(*), pointer :: obj ! diff --git a/src/Solution/SolutionGroup.f90 b/src/Solution/SolutionGroup.f90 index 92cde54146b..c51076e802c 100644 --- a/src/Solution/SolutionGroup.f90 +++ b/src/Solution/SolutionGroup.f90 @@ -1,10 +1,10 @@ module SolutionGroupModule - use KindModule, only: DP, I4B - use ListsModule, only: basesolutionlist + use KindModule, only: DP, I4B + use ListsModule, only: basesolutionlist use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & GetBaseSolutionFromList - use ListModule, only: ListType - + use ListModule, only: ListType + implicit none private public :: SolutionGroupType, AddSolutionGroupToList, & @@ -12,19 +12,19 @@ module SolutionGroupModule private :: CastAsSolutionGroupClass type :: SolutionGroupType - integer(I4B), pointer :: id - integer(I4B), pointer :: mxiter - integer(I4B), pointer :: nsolutions - integer(I4B), dimension(:), allocatable :: idsolutions !array of solution ids in basesolutionlist + integer(I4B), pointer :: id + integer(I4B), pointer :: mxiter + integer(I4B), pointer :: nsolutions + integer(I4B), dimension(:), allocatable :: idsolutions !array of solution ids in basesolutionlist contains - procedure :: sgp_ca - procedure :: sgp_da + procedure :: sgp_ca + procedure :: sgp_da procedure, private :: allocate_scalars - procedure :: add_solution + procedure :: add_solution end type SolutionGroupType - - contains - + +contains + subroutine solutiongroup_create(sgp, id) ! ****************************************************************************** ! solutiongroup_create -- Create a new solution group @@ -33,17 +33,17 @@ subroutine solutiongroup_create(sgp, id) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ type(SolutionGroupType), pointer :: sgp - integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: id ! ------------------------------------------------------------------------------ ! - allocate(sgp) + allocate (sgp) call sgp%allocate_scalars() sgp%id = id ! ! -- return return end subroutine solutiongroup_create - + subroutine sgp_ca(this) ! ****************************************************************************** ! sgp_ca -- Calculate the solution group @@ -55,27 +55,27 @@ subroutine sgp_ca(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimVariablesModule, only: iout, isimcnvg, lastStepFailed - use TdisModule, only: kstp, kper + use ConstantsModule, only: LINELENGTH + use SimVariablesModule, only: iout, isimcnvg, lastStepFailed + use TdisModule, only: kstp, kper ! -- dummy class(SolutionGroupType) :: this ! -- local - class(BaseSolutionType), pointer :: sp + class(BaseSolutionType), pointer :: sp integer(I4B) :: kpicard, isgcnvg, isuppress_output integer(I4B) :: is, isoln ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1X,'Solution Group ', i0, ' did not converge for stress period ', i0, & + character(len=*), parameter :: fmtnocnvg = & + "(1X,'Solution Group ', i0, ' did not converge for stress period ', i0, & &' and time step ', i0)" ! ------------------------------------------------------------------------------ ! ! -- Suppress output during picard iterations - if(this%mxiter > 1) then + if (this%mxiter > 1) then isuppress_output = 1 else isuppress_output = 0 - endif + end if ! ! -- set failed flag lastStepFailed = 0 @@ -83,35 +83,35 @@ subroutine sgp_ca(this) ! -- Picard loop picardloop: do kpicard = 1, this%mxiter if (this%mxiter > 1) then - write(iout,'(/a,i6/)') 'SOLUTION GROUP PICARD ITERATION: ', kpicard + write (iout, '(/a,i6/)') 'SOLUTION GROUP PICARD ITERATION: ', kpicard end if isgcnvg = 1 do is = 1, this%nsolutions isoln = this%idsolutions(is) sp => GetBaseSolutionFromList(basesolutionlist, isoln) call sp%sln_ca(isgcnvg, isuppress_output) - enddo - if(isgcnvg == 1) exit picardloop - enddo picardloop + end do + if (isgcnvg == 1) exit picardloop + end do picardloop ! ! -- if a picard loop was used and the solution group converged ! then rerun the timestep and save the output. Or if there ! is only one picard iteration, then do nothing as models ! are assumed to be explicitly coupled. - if(isgcnvg == 1) then - if(this%mxiter > 1) then + if (isgcnvg == 1) then + if (this%mxiter > 1) then isuppress_output = 0 do is = 1, this%nsolutions isoln = this%idsolutions(is) sp => GetBaseSolutionFromList(basesolutionlist, isoln) call sp%sln_ca(isgcnvg, isuppress_output) - enddo - endif + end do + end if else isimcnvg = 0 lastStepFailed = 1 - write(iout, fmtnocnvg) this%id, kper, kstp - endif + write (iout, fmtnocnvg) this%id, kper, kstp + end if ! ! -- return return @@ -127,10 +127,10 @@ subroutine sgp_da(this) class(SolutionGroupType) :: this ! ------------------------------------------------------------------------------ ! - deallocate(this%id) - deallocate(this%mxiter) - deallocate(this%nsolutions) - deallocate(this%idsolutions) + deallocate (this%id) + deallocate (this%mxiter) + deallocate (this%nsolutions) + deallocate (this%idsolutions) ! ! -- return return @@ -146,9 +146,9 @@ subroutine allocate_scalars(this) class(SolutionGroupType) :: this ! ------------------------------------------------------------------------------ ! - allocate(this%id) - allocate(this%mxiter) - allocate(this%nsolutions) + allocate (this%id) + allocate (this%mxiter) + allocate (this%nsolutions) this%id = 0 this%mxiter = 1 this%nsolutions = 0 @@ -183,7 +183,7 @@ subroutine add_solution(this, isoln, sp) return end subroutine add_solution - function CastAsSolutionGroupClass(obj) result (res) + function CastAsSolutionGroupClass(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj class(SolutionGroupType), pointer :: res @@ -201,7 +201,7 @@ end function CastAsSolutionGroupClass subroutine AddSolutionGroupToList(list, solutiongroup) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(SolutionGroupType), pointer, intent(inout) :: solutiongroup ! -- local class(*), pointer :: obj @@ -211,13 +211,13 @@ subroutine AddSolutionGroupToList(list, solutiongroup) ! return end subroutine AddSolutionGroupToList - - function GetSolutionGroupFromList(list, idx) result (res) + + function GetSolutionGroupFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(SolutionGroupType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(SolutionGroupType), pointer :: res ! -- local class(*), pointer :: obj ! diff --git a/src/Solution/SparseMatrixSolver/ims8base.f90 b/src/Solution/SparseMatrixSolver/ims8base.f90 deleted file mode 100644 index 3b10e2761b3..00000000000 --- a/src/Solution/SparseMatrixSolver/ims8base.f90 +++ /dev/null @@ -1,1319 +0,0 @@ - -!> @brief This module contains the IMS linear accelerator subroutines -!! -!! This module contains the IMS linear accelerator subroutines used by a -!! MODFLOW 6 solution. -!< -MODULE IMSLinearBaseModule - ! -- modules - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, IZERO, & - DZERO, DPREC, DEM6, DEM3, DHALF, DONE - use GenericUtilitiesModule, only: sim_message, is_same - use BlockParserModule, only: BlockParserType - use IMSReorderingModule, only: ims_odrv - - IMPLICIT NONE - - type(BlockParserType), private :: parser - - contains - - !> @ brief Preconditioned Conjugate Gradient linear accelerator - !! - !! Apply the Preconditioned Conjugate Gradient linear accelerator to - !! the current coefficient matrix, right-hand side, using the current - !! dependent-variable. - !! - !< - SUBROUTINE ims_base_cg(ICNVG, ITMAX, INNERIT, & - NEQ, NJA, NIAPC, NJAPC, & - IPC, NITERC, ICNVGOPT, NORTH, & - DVCLOSE, RCLOSE, L2NORM0, EPFACT, & - IA0, JA0, A0, IAPC, JAPC, APC, & - X, B, D, P, Q, Z, & - NJLU, IW, JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - ! -- dummy variables - integer(I4B), INTENT(INOUT) :: ICNVG !< convergence flag (1) non-convergence (0) - integer(I4B), INTENT(IN) :: ITMAX !< maximum number of inner iterations - integer(I4B), INTENT(INOUT) :: INNERIT !< inner iteration count - integer(I4B), INTENT(IN) :: NEQ !< number of equations - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), INTENT(IN) :: NIAPC !< preconditioner number of rows - integer(I4B), INTENT(IN) :: NJAPC !< preconditioner number of non-zero entries - integer(I4B), INTENT(IN) :: IPC !< preconditioner option - integer(I4B), INTENT(INOUT) :: NITERC !< total number of inner iterations - integer(I4B), INTENT(IN) :: ICNVGOPT !< flow convergence criteria option - integer(I4B), INTENT(IN) :: NORTH !< orthogonalization frequency - real(DP), INTENT(IN) :: DVCLOSE !< dependent-variable closure criteria - real(DP), INTENT(IN) :: RCLOSE !< flow closure criteria - real(DP), INTENT(IN) :: L2NORM0 !< initial L-2 norm for system of equations - real(DP), INTENT(IN) :: EPFACT !< factor for decreasing flow convergence criteria for subsequent Picard iterations - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA0 !< CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 !< CRS column pointers - real(DP), DIMENSION(NJA), INTENT(IN) :: A0 !< coefficient matrix - integer(I4B), DIMENSION(NIAPC + 1), INTENT(IN) :: IAPC !< preconditioner CRS row pointers - integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC !< preconditioner CRS column pointers - real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC !< preconditioner matrix - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X !< dependent-variable vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B !< right-hand side vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P !< working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q !< working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Z !< working vector - ! -- ILUT dummy variables - integer(I4B), INTENT(IN) :: NJLU !< preconditioner length of JLU vector - integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW !< preconditioner integer working vector - integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU !< preconditioner JLU working vector - ! -- convergence information dummy variables dummy variables - integer(I4B), INTENT(IN) :: NCONV !< maximum number of inner iterations in a time step (maxiter * maxinner) - integer(I4B), INTENT(IN) :: CONVNMOD !< number of models in the solution - integer(I4B), DIMENSION(CONVNMOD + 1), INTENT(INOUT) :: CONVMODSTART !< pointer to the start of each model in the convmod* arrays - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV !< location of the maximum dependent-variable change in the solution - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR !< location of the maximum flow change in the solution - character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL !< convergence string - integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER !< actual number of inner iterations in each Picard iteration - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV !< location of the maximum dependent-variable change in each model in the solution - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR !< location of the maximum flow change in each model in the solution - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX !< maximum dependent-variable change in the solution - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX !< maximum flow change in the solution - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX !< maximum dependent-variable change in each model in the solution - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX !< maximum flow change in each model in the solution - ! -- local variables - LOGICAL :: lorth - logical :: lsame - character(len=31) :: cval - integer(I4B) :: n - integer(I4B) :: iiter - integer(I4B) :: xloc, rloc - integer(I4B) :: im, im0, im1 - real(DP) :: ddot - real(DP) :: tv - real(DP) :: deltax - real(DP) :: rmax - real(DP) :: l2norm - real(DP) :: rcnvg - real(DP) :: denom - real(DP) :: alpha, beta - real(DP) :: rho, rho0 - ! - ! -- initialize local variables - rho0 = DZERO - rho = DZERO - INNERIT = 0 - ! - ! -- INNER ITERATION - INNER: DO iiter = 1, itmax - INNERIT = INNERIT + 1 - NITERC = NITERC + 1 - ! - ! -- APPLY PRECONDITIONER - SELECT CASE (IPC) - ! - ! -- ILU0 AND MILU0 - CASE (1, 2) - CALL ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, D, Z) - ! - ! -- ILUT AND MILUT - CASE (3, 4) - CALL lusol(NEQ, D, Z, APC, JLU, IW) - END SELECT - rho = ddot(NEQ, D, 1, Z, 1) - ! - ! -- COMPUTE DIRECTIONAL VECTORS - IF (IITER == 1) THEN - DO n = 1, NEQ - P(n) = Z(n) - END DO - ELSE - beta = rho/rho0 - DO n = 1, NEQ - P(n) = Z(n) + beta*P(n) - END DO - END IF - ! - ! -- COMPUTE ITERATES - ! - ! -- UPDATE Q - call amux( NEQ, P, Q, A0, JA0, IA0 ) - denom = ddot(NEQ, P, 1, Q, 1) - denom = denom + SIGN(DPREC, denom) - alpha = rho/denom - ! - ! -- UPDATE X AND RESIDUAL - deltax = DZERO - rmax = DZERO - l2norm = DZERO - DO im = 1, CONVNMOD - DVMAX(im) = DZERO - DRMAX(im) = DZERO - END DO - im = 1 - im0 = CONVMODSTART(1) - im1 = CONVMODSTART(2) - DO n = 1, NEQ - ! - ! -- determine current model index - if (n == im1) then - im = im + 1 - im0 = CONVMODSTART(im) - im1 = CONVMODSTART(im + 1) - end if - ! - ! -- identify deltax and rmax - tv = alpha*P(n) - X(n) = X(n) + tv - IF (ABS(tv) > ABS(deltax)) THEN - deltax = tv - xloc = n - END IF - IF (ABS(tv) > ABS(DVMAX(im))) THEN - DVMAX(im) = tv - LOCDV(im) = n - END IF - tv = D(n) - tv = tv - alpha*Q(n) - D(n) = tv - IF (ABS(tv) > ABS(rmax)) THEN - rmax = tv - rloc = n - END IF - IF (ABS(tv) > ABS(DRMAX(im))) THEN - DRMAX(im) = tv - LOCDR(im) = n - END IF - l2norm = l2norm + tv*tv - END DO - l2norm = SQRT(l2norm) - ! - ! -- SAVE SOLVER convergence information dummy variables - IF (NCONV > 1) THEN !< - n = NITERC - WRITE (cval, '(g15.7)') alpha - CACCEL(n) = cval - ITINNER(n) = iiter - DO im = 1, CONVNMOD - CONVLOCDV(im, n) = LOCDV(im) - CONVLOCDR(im, n) = LOCDR(im) - CONVDVMAX(im, n) = DVMAX(im) - CONVDRMAX(im, n) = DRMAX(im) - END DO - END IF - ! - ! -- TEST FOR SOLVER CONVERGENCE - IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN - rcnvg = l2norm - ELSE - rcnvg = rmax - END IF - CALL ims_base_testcnvg(ICNVGOPT, ICNVG, INNERIT, & - deltax, rcnvg, & - L2NORM0, EPFACT, DVCLOSE, RCLOSE) - ! - ! -- CHECK FOR EXACT SOLUTION - IF (rcnvg == DZERO) ICNVG = 1 - ! - ! -- CHECK FOR STANDARD CONVERGENCE - IF (ICNVG .NE. 0) EXIT INNER - ! - ! -- CHECK THAT CURRENT AND PREVIOUS rho ARE DIFFERENT - lsame = is_same(rho, rho0) - IF (lsame) THEN - EXIT INNER - END IF - ! - ! -- RECALCULATE THE RESIDUAL - IF (NORTH > 0) THEN - lorth = mod(iiter + 1, NORTH) == 0 - IF (lorth) THEN - call ims_base_residual(NEQ, NJA, X, B, D, A0, IA0, JA0) - END IF - END IF - ! - ! -- exit inner if rho is zero - if (rho == DZERO) then - exit inner - end if - ! - ! -- SAVE CURRENT INNER ITERATES - rho0 = rho - END DO INNER - ! - ! -- RESET ICNVG - IF (ICNVG < 0) ICNVG = 0 - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_cg - - !> @ brief Preconditioned BiConjugate Gradient Stabilized linear accelerator - !! - !! Apply the Preconditioned BiConjugate Gradient Stabilized linear - !! accelerator to the current coefficient matrix, right-hand side, using - !! the currentdependent-variable. - !! - !< - SUBROUTINE ims_base_bcgs(ICNVG, ITMAX, INNERIT, & - NEQ, NJA, NIAPC, NJAPC, & - IPC, NITERC, ICNVGOPT, NORTH, ISCL, DSCALE, & - DVCLOSE, RCLOSE, L2NORM0, EPFACT, & - IA0, JA0, A0, IAPC, JAPC, APC, & - X, B, D, P, Q, & - T, V, DHAT, PHAT, QHAT, & - NJLU, IW, JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - ! -- dummy variables - integer(I4B), INTENT(INOUT) :: ICNVG !< convergence flag (1) non-convergence (0) - integer(I4B), INTENT(IN) :: ITMAX !< maximum number of inner iterations - integer(I4B), INTENT(INOUT) :: INNERIT !< inner iteration count - integer(I4B), INTENT(IN) :: NEQ !< number of equations - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), INTENT(IN) :: NIAPC !< preconditioner number of rows - integer(I4B), INTENT(IN) :: NJAPC !< preconditioner number of non-zero entries - integer(I4B), INTENT(IN) :: IPC !< preconditioner option - integer(I4B), INTENT(INOUT) :: NITERC !< total number of inner iterations - integer(I4B), INTENT(IN) :: ICNVGOPT !< flow convergence criteria option - integer(I4B), INTENT(IN) :: NORTH !< orthogonalization frequency - integer(I4B), INTENT(IN) :: ISCL !< scaling option - real(DP), DIMENSION(NEQ), INTENT(IN) :: DSCALE !< scaling vector - real(DP), INTENT(IN) :: DVCLOSE !< dependent-variable closure criteria - real(DP), INTENT(IN) :: RCLOSE !< flow closure criteria - real(DP), INTENT(IN) :: L2NORM0 !< initial L-2 norm for system of equations - real(DP), INTENT(IN) :: EPFACT !< factor for decreasing flow convergence criteria for subsequent Picard iterations - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA0 !< CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA0 !< CRS column pointers - real(DP), DIMENSION(NJA), INTENT(IN) :: A0 !< coefficient matrix - integer(I4B), DIMENSION(NIAPC + 1), INTENT(IN) :: IAPC !< preconditioner CRS row pointers - integer(I4B), DIMENSION(NJAPC), INTENT(IN) :: JAPC !< preconditioner CRS column pointers - real(DP), DIMENSION(NJAPC), INTENT(IN) :: APC !< preconditioner matrix - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X !< dependent-variable vector - real(DP), DIMENSION(NEQ), INTENT(IN) :: B !< right-hand side vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: P !< preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: Q !< preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: T !< preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: V !< preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DHAT !< BCGS preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: PHAT !< BCGS preconditioner working vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: QHAT !< BCGS preconditioner working vector - ! -- ILUT dummy variables - integer(I4B), INTENT(IN) :: NJLU !< preconditioner length of JLU vector - integer(I4B), DIMENSION(NIAPC), INTENT(IN) :: IW !< preconditioner integer working vector - integer(I4B), DIMENSION(NJLU), INTENT(IN) :: JLU !< preconditioner JLU working vector - ! -- convergence information dummy variables - integer(I4B), INTENT(IN) :: NCONV !< maximum number of inner iterations in a time step (maxiter * maxinner) - integer(I4B), INTENT(IN) :: CONVNMOD !< number of models in the solution - integer(I4B), DIMENSION(CONVNMOD + 1), INTENT(INOUT) :: CONVMODSTART !< pointer to the start of each model in the convmod* arrays - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV !< location of the maximum dependent-variable change in the solution - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR !< location of the maximum flow change in the solution - character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL !< convergence string - integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER !< actual number of inner iterations in each Picard iteration - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV !< location of the maximum dependent-variable change in each model in the solution - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR !< location of the maximum flow change in each model in the solution - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX !< maximum dependent-variable change in the solution - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX !< maximum flow change in the solution - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX !< maximum dependent-variable change in each model in the solution - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX !< maximum flow change in each model in the solution - ! -- local variables - LOGICAL :: LORTH - logical :: lsame - character(len=15) :: cval1, cval2 - integer(I4B) :: n - integer(I4B) :: iiter - integer(I4B) :: xloc, rloc - integer(I4B) :: im, im0, im1 - real(DP) :: ddot - real(DP) :: tv - real(DP) :: deltax - real(DP) :: rmax - real(DP) :: l2norm - real(DP) :: rcnvg - real(DP) :: alpha, alpha0 - real(DP) :: beta - real(DP) :: rho, rho0 - real(DP) :: omega, omega0 - real(DP) :: numer, denom - ! - ! -- initialize local variables - INNERIT = 0 - alpha = DZERO - alpha0 = DZERO - beta = DZERO - rho = DZERO - rho0 = DZERO - omega = DZERO - omega0 = DZERO - ! - ! -- SAVE INITIAL RESIDUAL - DO n = 1, NEQ - DHAT(n) = D(n) - END DO - ! - ! -- INNER ITERATION - INNER: DO iiter = 1, itmax - INNERIT = INNERIT + 1 - NITERC = NITERC + 1 - ! - ! -- CALCULATE rho - rho = ddot(NEQ, DHAT, 1, D, 1) - ! - ! -- COMPUTE DIRECTIONAL VECTORS - IF (IITER == 1) THEN - DO n = 1, NEQ - P(n) = D(n) - END DO - ELSE - beta = (rho/rho0)*(alpha0/omega0) - DO n = 1, NEQ - P(n) = D(n) + beta*(P(n) - omega0*V(n)) - END DO - END IF - ! - ! -- APPLY PRECONDITIONER TO UPDATE PHAT - SELECT CASE (IPC) - ! - ! -- ILU0 AND MILU0 - CASE (1, 2) - CALL ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, P, PHAT) - ! - ! -- ILUT AND MILUT - CASE (3, 4) - CALL lusol(NEQ, P, PHAT, APC, JLU, IW) - END SELECT - ! - ! -- COMPUTE ITERATES - ! - ! -- UPDATE V WITH A AND PHAT - call amux( NEQ, PHAT, V, A0, JA0, IA0 ) - ! - ! -- UPDATE alpha WITH DHAT AND V - denom = ddot(NEQ, DHAT, 1, V, 1) - denom = denom + SIGN(DPREC, denom) - alpha = rho/denom - ! - ! -- UPDATE Q - DO n = 1, NEQ - Q(n) = D(n) - alpha*V(n) - END DO - ! - ! ! -- CALCULATE INFINITY NORM OF Q - TEST FOR TERMINATION - ! ! TERMINATE IF rmax IS LESS THAN MACHINE PRECISION (DPREC) - ! rmax = DZERO - ! DO n = 1, NEQ - ! tv = Q(n) - ! IF (ISCL.NE.0 ) tv = tv / DSCALE(n) - ! IF (ABS(tv) > ABS(rmax) ) rmax = tv - ! END DO - ! IF (ABS(rmax).LE.DPREC) THEN - ! deltax = DZERO - ! DO n = 1, NEQ - ! tv = alpha * PHAT(n) - ! IF (ISCL.NE.0) THEN - ! tv = tv * DSCALE(n) - ! END IF - ! X(n) = X(n) + tv - ! IF (ABS(tv) > ABS(deltax) ) deltax = tv - ! END DO - ! CALL IMSLINEARSUB_TESTCNVG(ICNVGOPT, ICNVG, INNERIT, & - ! deltax, rmax, & - ! rmax, EPFACT, DVCLOSE, RCLOSE ) - ! IF (ICNVG.NE.0 ) EXIT INNER - ! END IF - ! - ! -- APPLY PRECONDITIONER TO UPDATE QHAT - SELECT CASE (IPC) - ! - ! -- ILU0 AND MILU0 - CASE (1, 2) - CALL ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, Q, QHAT) - ! - ! -- ILUT AND MILUT - CASE (3, 4) - CALL lusol(NEQ, Q, QHAT, APC, JLU, IW) - END SELECT - ! - ! -- UPDATE T WITH A AND QHAT - call amux( NEQ, QHAT, T, A0, JA0, IA0 ) - ! - ! -- UPDATE omega - numer = ddot(NEQ, T, 1, Q, 1) - denom = ddot(NEQ, T, 1, T, 1) - denom = denom + SIGN(DPREC, denom) - omega = numer/denom - ! - ! -- UPDATE X AND RESIDUAL - deltax = DZERO - rmax = DZERO - l2norm = DZERO - DO im = 1, CONVNMOD - DVMAX(im) = DZERO - DRMAX(im) = DZERO - END DO - im = 1 - im0 = CONVMODSTART(1) - im1 = CONVMODSTART(2) - DO n = 1, NEQ - ! - ! -- determine current model index - if (n == im1) then - im = im + 1 - im0 = CONVMODSTART(im) - im1 = CONVMODSTART(im + 1) - end if - ! - ! -- X AND DX - tv = alpha*PHAT(n) + omega*QHAT(n) - X(n) = X(n) + tv - IF (ISCL .NE. 0) THEN - tv = tv*DSCALE(n) - END IF - IF (ABS(tv) > ABS(deltax)) THEN - deltax = tv - xloc = n - END IF - IF (ABS(tv) > ABS(DVMAX(im))) THEN - DVMAX(im) = tv - LOCDV(im) = n - END IF - ! - ! -- RESIDUAL - tv = Q(n) - omega*T(n) - D(n) = tv - IF (ISCL .NE. 0) THEN - tv = tv/DSCALE(n) - END IF - IF (ABS(tv) > ABS(rmax)) THEN - rmax = tv - rloc = n - END IF - IF (ABS(tv) > ABS(DRMAX(im))) THEN - DRMAX(im) = tv - LOCDR(im) = n - END IF - l2norm = l2norm + tv*tv - END DO - l2norm = sqrt(l2norm) - ! - ! -- SAVE SOLVER convergence information dummy variables - IF (NCONV > 1) THEN !< - n = NITERC - WRITE (cval1, '(g15.7)') alpha - WRITE (cval2, '(g15.7)') omega - CACCEL(n) = trim(adjustl(cval1))//','//trim(adjustl(cval2)) - ITINNER(n) = iiter - DO im = 1, CONVNMOD - CONVLOCDV(im, n) = LOCDV(im) - CONVLOCDR(im, n) = LOCDR(im) - CONVDVMAX(im, n) = DVMAX(im) - CONVDRMAX(im, n) = DRMAX(im) - END DO - END IF - ! - ! -- TEST FOR SOLVER CONVERGENCE - IF (ICNVGOPT == 2 .OR. ICNVGOPT == 3 .OR. ICNVGOPT == 4) THEN - rcnvg = l2norm - ELSE - rcnvg = rmax - END IF - CALL ims_base_testcnvg(ICNVGOPT, ICNVG, INNERIT, & - deltax, rcnvg, & - L2NORM0, EPFACT, DVCLOSE, RCLOSE) - ! - ! -- CHECK FOR EXACT SOLUTION - IF (rcnvg == DZERO) ICNVG = 1 - ! - ! -- CHECK FOR STANDARD CONVERGENCE - IF (ICNVG .NE. 0) EXIT INNER - ! - ! -- CHECK THAT CURRENT AND PREVIOUS rho, alpha, AND omega ARE - ! DIFFERENT - lsame = is_same(rho, rho0) - IF (lsame) THEN - EXIT INNER - END IF - lsame = is_same(alpha, alpha0) - IF (lsame) THEN - EXIT INNER - END IF - lsame = is_same(omega, omega0) - IF (lsame) THEN - EXIT INNER - END IF - ! - ! -- RECALCULATE THE RESIDUAL - IF (NORTH > 0) THEN - LORTH = mod(iiter + 1, NORTH) == 0 - IF (LORTH) THEN - call ims_base_residual(NEQ, NJA, X, B, D, A0, IA0, JA0) - END IF - END IF - ! - ! -- exit inner if rho or omega are zero - if (rho*omega == DZERO) then - exit inner - end if - ! - ! -- SAVE CURRENT INNER ITERATES - rho0 = rho - alpha0 = alpha - omega0 = omega - END DO INNER - ! - ! -- RESET ICNVG - IF (ICNVG < 0) ICNVG = 0 - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_bcgs - - !> @ brief Calculate LORDER AND IORDER - !! - !! Calculate LORDER and IORDER for reordering. - !! - !< - SUBROUTINE ims_base_calc_order(IORD, NEQ, NJA, IA, JA, LORDER, IORDER) - ! -- modules - use SimModule, only: store_error, count_errors - ! -- dummy variables - integer(I4B), INTENT(IN) :: IORD !< reordering optionn - integer(I4B), INTENT(IN) :: NEQ !< number of rows - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< row pointer - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< column pointer - integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: LORDER !< reorder vector - integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IORDER !< inverse of reorder vector - ! -- local variables - character(len=LINELENGTH) :: errmsg - integer(I4B) :: n - integer(I4B) :: nsp - integer(I4B), DIMENSION(:), ALLOCATABLE :: iwork0 - integer(I4B), DIMENSION(:), ALLOCATABLE :: iwork1 - integer(I4B) :: iflag - ! - ! -- initialize lorder and iorder - DO n = 1, NEQ - LORDER(n) = IZERO - IORDER(n) = IZERO - END DO - ! ALLOCATE (iwork0(NEQ)) - SELECT CASE (IORD) - CASE (1) - CALL genrcm(NEQ, NJA, IA, JA, LORDER) - CASE (2) - nsp = 3*NEQ + 4*NJA - allocate(iwork0(NEQ)) - allocate(iwork1(nsp)) - CALL ims_odrv(NEQ, NJA, nsp, IA, JA, LORDER, iwork0, & - iwork1, iflag) - IF (iflag .NE. 0) THEN - write (errmsg, '(A,1X,A)') & - 'IMSLINEARSUB_CALC_ORDER ERROR CREATING MINIMUM DEGREE ', & - 'ORDER PERMUTATION ' - call store_error(errmsg) - END IF - ! - ! -- DEALLOCATE TEMPORARY STORAGE - deallocate(iwork0, iwork1) - END SELECT - ! - ! -- GENERATE INVERSE OF LORDER - DO n = 1, NEQ - IORDER(LORDER(n)) = n - END DO - ! - ! -- terminate if errors occured - if (count_errors() > 0) then - call parser%StoreErrorUnit() - end if - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_calc_order - - ! - !> @ brief Scale the coefficient matrix - !! - !! Scale the coefficient matrix (AMAT), the right-hand side (B), - !! and the estimate of the dependent variable (X). - !! - !< - SUBROUTINE ims_base_scale(IOPT, ISCL, NEQ, NJA, IA, JA, AMAT, X, B, & - DSCALE, DSCALE2) - ! -- dummy variables - integer(I4B), INTENT(IN) :: IOPT !< flag to scale (0) or unscale the system of equations - integer(I4B), INTENT(IN) :: ISCL !< scaling option (1) symmetric (2) L-2 norm - integer(I4B), INTENT(IN) :: NEQ !< number of equations - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointer - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointer - real(DP), DIMENSION(NJA), INTENT(INOUT) :: AMAT !< coefficient matrix - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: X !< dependent variable - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: B !< right-hand side - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE !< first scaling vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: DSCALE2 !< second scaling vector - ! -- local variables - integer(I4B) :: i, n - integer(I4B) :: id, jc - integer(I4B) :: i0, i1 - real(DP) :: v, c1, c2 - ! - ! -- SCALE SCALE AMAT, X, AND B - IF (IOPT == 0) THEN - ! - ! -- SYMMETRIC SCALING - SELECT CASE (ISCL) - CASE (1) - DO n = 1, NEQ - id = IA(n) - v = AMAT(id) - c1 = DONE/SQRT(ABS(v)) - DSCALE(n) = c1 - DSCALE2(n) = c1 - END DO - ! - ! -- SCALE AMAT -- AMAT = DSCALE(row) * AMAT(i) * DSCALE2(col) - DO n = 1, NEQ - c1 = DSCALE(n) - i0 = IA(n) - i1 = IA(n + 1) - 1 - DO i = i0, i1 - jc = JA(i) - c2 = DSCALE2(jc) - AMAT(i) = c1*AMAT(i)*c2 - END DO - END DO - ! - ! -- L-2 NORM SCALING - CASE (2) - ! - ! -- SCALE EACH ROW SO THAT THE L-2 NORM IS 1 - DO n = 1, NEQ - c1 = DZERO - i0 = IA(n) - i1 = IA(n + 1) - 1 - DO i = i0, i1 - c1 = c1 + AMAT(i)*AMAT(i) - END DO - c1 = SQRT(c1) - IF (c1 == DZERO) THEN - c1 = DONE - ELSE - c1 = DONE/c1 - END IF - DSCALE(n) = c1 - ! - ! -- INITIAL SCALING OF AMAT -- AMAT = DSCALE(row) * AMAT(i) - DO i = i0, i1 - AMAT(i) = c1*AMAT(i) - END DO - END DO - ! - ! -- SCALE EACH COLUMN SO THAT THE L-2 NORM IS 1 - DO n = 1, NEQ - DSCALE2(n) = DZERO - END DO - c2 = DZERO - DO n = 1, NEQ - i0 = IA(n) - i1 = IA(n + 1) - 1 - DO i = i0, i1 - jc = JA(i) - c2 = AMAT(i) - DSCALE2(jc) = DSCALE2(jc) + c2*c2 - END DO - END DO - DO n = 1, NEQ - c2 = DSCALE2(n) - IF (c2 == DZERO) THEN - c2 = DONE - ELSE - c2 = DONE/SQRT(c2) - END IF - DSCALE2(n) = c2 - END DO - ! - ! -- FINAL SCALING OF AMAT -- AMAT = DSCALE2(col) * AMAT(i) - DO n = 1, NEQ - i0 = IA(n) - i1 = IA(n + 1) - 1 - DO i = i0, i1 - jc = JA(i) - c2 = DSCALE2(jc) - AMAT(i) = c2*AMAT(i) - END DO - END DO - END SELECT - ! - ! -- SCALE X AND B - DO n = 1, NEQ - c1 = DSCALE(n) - c2 = DSCALE2(n) - X(n) = X(n)/c2 - B(n) = B(n)*c1 - END DO - ! - ! -- UNSCALE SCALE AMAT, X, AND B - ELSE - DO n = 1, NEQ - c1 = DSCALE(n) - i0 = IA(n) - i1 = IA(n + 1) - 1 - ! - ! -- UNSCALE AMAT - DO i = i0, i1 - jc = JA(i) - c2 = DSCALE2(jc) - AMAT(i) = (DONE/c1)*AMAT(i)*(DONE/c2) - END DO - ! - ! -- UNSCALE X AND B - c2 = DSCALE2(n) - X(n) = X(n)*c2 - B(n) = B(n)/c1 - END DO - END IF - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_scale - - !> @ brief Update the preconditioner - !! - !! Update the preconditioner using the current coefficient matrix. - !! - !< - SUBROUTINE ims_base_pcu(IOUT, NJA, NEQ, NIAPC, NJAPC, IPC, RELAX, & - AMAT, IA, JA, APC, IAPC, JAPC, IW, W, & - LEVEL, DROPTOL, NJLU, NJW, NWLU, JLU, JW, WLU) - ! -- modules - use SimModule, only: store_error, count_errors - ! -- dummy variables - integer(I4B), INTENT(IN) :: IOUT !< simulation listing file unit - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), INTENT(IN) :: NEQ !< number of equations - integer(I4B), INTENT(IN) :: NIAPC !< preconditioner number of rows - integer(I4B), INTENT(IN) :: NJAPC !< preconditioner number of non-zero entries - integer(I4B), INTENT(IN) :: IPC !< precoditioner (1) ILU0 (2) MILU0 (3) ILUT (4) MILUT - real(DP), INTENT(IN) :: RELAX !< preconditioner relaxation factor for MILU0 and MILUT - real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT !< coefficient matrix - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers - real(DP), DIMENSION(NJAPC), INTENT(INOUT) :: APC !< preconditioner matrix - integer(I4B), DIMENSION(NIAPC + 1), INTENT(INOUT) :: IAPC !< preconditioner CRS row pointers - integer(I4B), DIMENSION(NJAPC), INTENT(INOUT) :: JAPC !< preconditioner CRS column pointers - integer(I4B), DIMENSION(NIAPC), INTENT(INOUT) :: IW !< preconditioner integed work vector - real(DP), DIMENSION(NIAPC), INTENT(INOUT) :: W !< preconditioner work verctor - ! -- ILUT dummy variables - integer(I4B), INTENT(IN) :: LEVEL !< number of levels of fill for ILUT and MILUT - real(DP), INTENT(IN) :: DROPTOL !< drop tolerance - integer(I4B), INTENT(IN) :: NJLU !< length of JLU working vector - integer(I4B), INTENT(IN) :: NJW !< length of JW working vector - integer(I4B), INTENT(IN) :: NWLU !< length of WLU working vector - integer(I4B), DIMENSION(NJLU), INTENT(INOUT) :: JLU !< ILUT/MILUT JLU working vector - integer(I4B), DIMENSION(NJW), INTENT(INOUT) :: JW !< ILUT/MILUT JW working vector - real(DP), DIMENSION(NWLU), INTENT(INOUT) :: WLU !< ILUT/MILUT WLU working vector - ! -- local variables - character(len=LINELENGTH) :: errmsg - character(len=100), dimension(5), parameter :: cerr = & - ["Elimination process has generated a row in L or U whose length is > n.", & - "The matrix L overflows the array al. ", & - "The matrix U overflows the array alu. ", & - "Illegal value for lfil. ", & - "Zero row encountered. "] - integer(I4B) :: ipcflag - integer(I4B) :: icount - integer(I4B) :: ierr - real(DP) :: delta - ! -- formats -2000 FORMAT(/, ' MATRIX IS SEVERELY NON-DIAGONALLY DOMINANT.', & - /, ' ADDED SMALL VALUE TO PIVOT ', i0, ' TIMES IN', & - ' IMSLINEARSUB_PCU.') - ! - ! -- initialize local variables - ipcflag = 0 - icount = 0 - delta = DZERO - PCSCALE: DO - SELECT CASE (IPC) - ! - ! -- ILU0 AND MILU0 - CASE (1, 2) - CALL ims_base_pcilu0(NJA, NEQ, AMAT, IA, JA, & - APC, IAPC, JAPC, IW, W, & - RELAX, ipcflag, delta) - ! - ! -- ILUT AND MILUT - CASE (3, 4) - ierr = 0 - CALL ilut(NEQ, AMAT, JA, IA, LEVEL, DROPTOL, & - APC, JLU, IW, NJAPC, WLU, JW, ierr, & - relax, ipcflag, delta) - if (ierr /= 0) then - if (ierr > 0) then - write (errmsg, '(a,1x,i0,1x,a)') & - 'ILUT: zero pivot encountered at step number', ierr, '.' - else - write (errmsg, '(a,1x,a)') 'ILUT:', cerr(-ierr) - end if - call store_error(errmsg) - call parser%StoreErrorUnit() - end if - ! - ! -- ADDITIONAL PRECONDITIONERS - CASE DEFAULT - ipcflag = 0 - END SELECT - IF (ipcflag < 1) THEN - EXIT PCSCALE - END IF - delta = 1.5d0*delta + DEM3 - ipcflag = 0 - IF (delta > DHALF) THEN - delta = DHALF - ipcflag = 2 - END IF - icount = icount + 1 - ! - ! -- terminate pcscale loop if not making progress - if (icount > 10) then - exit PCSCALE - end if - - END DO PCSCALE - ! - ! -- write error message if small value added to pivot - if (icount > 0) then - write (IOUT, 2000) icount - end if - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_pcu - - !> @ brief Jacobi preconditioner - !! - !! Calculate the Jacobi preconditioner (inverse of the diagonal) using - !! the current coefficient matrix. - !! - !< - SUBROUTINE ims_base_pcjac(NJA, NEQ, AMAT, APC, IA, JA) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), INTENT(IN) :: NEQ !< number of equations - real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT !< coefficient matrix - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: APC !< preconditioner matrix - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers - ! -- local variables - integer(I4B) :: i, n - integer(I4B) :: ic0, ic1 - integer(I4B) :: id - real(DP) :: tv - ! -- code - DO n = 1, NEQ - ic0 = IA(n) - ic1 = IA(n + 1) - 1 - id = IA(n) - DO i = ic0, ic1 - IF (JA(i) == n) THEN - id = i - EXIT - END IF - END DO - tv = AMAT(id) - IF (ABS(tv) > DZERO) tv = DONE/tv - APC(n) = tv - END DO - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_pcjac - - !> @ brief Apply the Jacobi preconditioner - !! - !! Apply the Jacobi preconditioner and return the resultant vector. - !! - !< - SUBROUTINE ims_base_jaca(NEQ, A, D1, D2) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NEQ !< number of equations - real(DP), DIMENSION(NEQ), INTENT(IN) :: A !< Jacobi preconditioner - real(DP), DIMENSION(NEQ), INTENT(IN) :: D1 !< input vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D2 !< resultant vector - ! -- local variables - integer(I4B) :: n - real(DP) :: tv - ! -- code - DO n = 1, NEQ - tv = A(n)*D1(n) - D2(n) = tv - END DO - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_jaca - - !> @ brief Update the ILU0 preconditioner - !! - !! Update the ILU0 preconditioner using the current coefficient matrix. - !! - !< - SUBROUTINE ims_base_pcilu0(NJA, NEQ, AMAT, IA, JA, & - APC, IAPC, JAPC, IW, W, & - RELAX, IPCFLAG, DELTA) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), INTENT(IN) :: NEQ !< number of equations - real(DP), DIMENSION(NJA), INTENT(IN) :: AMAT !< coefficient matrix - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers - real(DP), DIMENSION(NJA), INTENT(INOUT) :: APC !< preconditioned matrix - integer(I4B), DIMENSION(NEQ + 1), INTENT(INOUT) :: IAPC !< preconditioner CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC !< preconditioner CRS column pointers - integer(I4B), DIMENSION(NEQ), INTENT(INOUT) :: IW !< preconditioner integer work vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: W !< preconditioner work vector - real(DP), INTENT(IN) :: RELAX !< MILU0 preconditioner relaxation factor - integer(I4B), INTENT(INOUT) :: IPCFLAG !< preconditioner error flag - real(DP), INTENT(IN) :: DELTA !< factor used to correct non-diagonally dominant matrices - ! -- local variables - integer(I4B) :: ic0, ic1 - integer(I4B) :: iic0, iic1 - integer(I4B) :: iu, iiu - integer(I4B) :: j, n - integer(I4B) :: jj - integer(I4B) :: jcol, jw - integer(I4B) :: jjcol - real(DP) :: drelax - real(DP) :: sd1 - real(DP) :: tl - real(DP) :: rs - real(DP) :: d - ! - ! -- initialize local variables - drelax = RELAX - DO n = 1, NEQ - IW(n) = 0 - W(n) = DZERO - END DO - MAIN: DO n = 1, NEQ - ic0 = IA(n) - ic1 = IA(n + 1) - 1 - DO j = ic0, ic1 - jcol = JA(j) - IW(jcol) = 1 - W(jcol) = W(jcol) + AMAT(j) - END DO - ic0 = IAPC(n) - ic1 = IAPC(n + 1) - 1 - iu = JAPC(n) - rs = DZERO - LOWER: DO j = ic0, iu - 1 - jcol = JAPC(j) - iic0 = IAPC(jcol) - iic1 = IAPC(jcol + 1) - 1 - iiu = JAPC(jcol) - tl = W(jcol)*APC(jcol) - W(jcol) = tl - DO jj = iiu, iic1 - jjcol = JAPC(jj) - jw = IW(jjcol) - IF (jw .NE. 0) THEN - W(jjcol) = W(jjcol) - tl*APC(jj) - ELSE - rs = rs + tl*APC(jj) - END IF - END DO - END DO LOWER - ! - ! -- DIAGONAL - CALCULATE INVERSE OF DIAGONAL FOR SOLUTION - d = W(n) - tl = (DONE + DELTA)*d - (drelax*rs) - ! - ! -- ENSURE THAT THE SIGN OF THE DIAGONAL HAS NOT CHANGED AND IS - sd1 = SIGN(d, tl) - IF (sd1 .NE. d) THEN - ! - ! -- USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR - ! PIVOTS THAT CHANGE THE SIGN OF THE DIAGONAL - IF (IPCFLAG > 1) THEN - tl = SIGN(DEM6, d) - ! - ! -- DIAGONAL SCALING CONTINUES TO BE EFFECTIVE - ELSE - IPCFLAG = 1 - EXIT MAIN - END IF - END IF - IF (ABS(tl) == DZERO) THEN - ! - ! -- USE SMALL VALUE IF DIAGONAL SCALING IS NOT EFFECTIVE FOR - ! ZERO PIVOTS - IF (IPCFLAG > 1) THEN - tl = SIGN(DEM6, d) - ! - ! -- DIAGONAL SCALING CONTINUES TO BE EFFECTIVE FOR ELIMINATING - ELSE - IPCFLAG = 1 - EXIT MAIN - END IF - END IF - APC(n) = DONE/tl - ! - ! -- RESET POINTER FOR IW TO ZERO - IW(n) = 0 - W(n) = DZERO - DO j = ic0, ic1 - jcol = JAPC(j) - APC(j) = W(jcol) - IW(jcol) = 0 - W(jcol) = DZERO - END DO - END DO MAIN - ! - ! -- RESET IPCFLAG IF SUCCESSFUL COMPLETION OF MAIN - IPCFLAG = 0 - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_pcilu0 - - !> @ brief Apply the ILU0 and MILU0 preconditioners - !! - !! Apply the ILU0 and MILU0 preconditioners to the passed vector (R). - !! - !< - SUBROUTINE ims_base_ilu0a(NJA, NEQ, APC, IAPC, JAPC, R, D) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NJA !< number of non-zero entries - integer(I4B), INTENT(IN) :: NEQ !< number of equations - real(DP), DIMENSION(NJA), INTENT(IN) :: APC !< ILU0/MILU0 preconditioner matrix - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IAPC !< ILU0/MILU0 preconditioner CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JAPC !< ILU0/MILU0 preconditioner CRS column pointers - real(DP), DIMENSION(NEQ), INTENT(IN) :: R !< input vector - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< output vector after applying APC to R - ! -- local variables - integer(I4B) :: ic0, ic1 - integer(I4B) :: iu - integer(I4B) :: jcol - integer(I4B) :: j, n - real(DP) :: tv - ! - ! -- FORWARD SOLVE - APC * D = R - FORWARD: DO n = 1, NEQ - tv = R(n) - ic0 = IAPC(n) - ic1 = IAPC(n + 1) - 1 - iu = JAPC(n) - 1 - LOWER: DO j = ic0, iu - jcol = JAPC(j) - tv = tv - APC(j)*D(jcol) - END DO LOWER - D(n) = tv - END DO FORWARD - ! - ! -- BACKWARD SOLVE - D = D / U - BACKWARD: DO n = NEQ, 1, -1 - ic0 = IAPC(n) - ic1 = IAPC(n + 1) - 1 - iu = JAPC(n) - tv = D(n) - UPPER: DO j = iu, ic1 - jcol = JAPC(j) - tv = tv - APC(j)*D(jcol) - END DO UPPER - ! - ! -- COMPUTE D FOR DIAGONAL - D = D / U - D(n) = tv*APC(n) - END DO BACKWARD - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_ilu0a - - !> @ brief Test for solver convergence - !! - !! General routine for testing for solver convergence based on the - !! user-specified convergence option (Icnvgopt). - !< - ! - ! -- TEST FOR SOLVER CONVERGENCE - SUBROUTINE ims_base_testcnvg(Icnvgopt, Icnvg, Iiter, & - Dvmax, Rmax, & - Rmax0, Epfact, Dvclose, Rclose) - ! -- dummy variables - integer(I4B), INTENT(IN) :: Icnvgopt !< convergence option - see documentation for option - integer(I4B), INTENT(INOUT) :: Icnvg !< flag indicating if convergence achieved (1) or not (0) - integer(I4B), INTENT(IN) :: Iiter !< inner iteration number (used for strict convergence option) - real(DP), INTENT(IN) :: Dvmax !< maximum dependent-variable change - real(DP), INTENT(IN) :: Rmax !< maximum flow change - real(DP), INTENT(IN) :: Rmax0 !< initial flow change (initial L2-norm) - real(DP), INTENT(IN) :: Epfact !< factor for reducing convergence criteria in subsequent Picard iterations - real(DP), INTENT(IN) :: Dvclose !< Maximum depenendent-variable change allowed - real(DP), INTENT(IN) :: Rclose !< Maximum flow change alowed - ! -- code - IF (Icnvgopt == 0) THEN - IF (ABS(Dvmax) <= Dvclose .AND. ABS(Rmax) <= Rclose) THEN - Icnvg = 1 - END IF - ELSE IF (Icnvgopt == 1) THEN - IF (ABS(Dvmax) <= Dvclose .AND. ABS(Rmax) <= Rclose) THEN - IF (iiter == 1) THEN - Icnvg = 1 - ELSE - Icnvg = -1 - END IF - END IF - ELSE IF (Icnvgopt == 2) THEN - IF (ABS(Dvmax) <= Dvclose .OR. Rmax <= Rclose) THEN - Icnvg = 1 - ELSE IF (Rmax <= Rmax0*Epfact) THEN - Icnvg = -1 - END IF - ELSE IF (Icnvgopt == 3) THEN - IF (ABS(Dvmax) <= Dvclose) THEN - Icnvg = 1 - ELSE IF (Rmax <= Rmax0*Rclose) THEN - Icnvg = -1 - END IF - ELSE IF (Icnvgopt == 4) THEN - IF (ABS(Dvmax) <= Dvclose .AND. Rmax <= Rclose) THEN - Icnvg = 1 - ELSE IF (Rmax <= Rmax0*Epfact) THEN - Icnvg = -1 - END IF - END IF - ! - ! -- return - RETURN - END SUBROUTINE ims_base_testcnvg - - !> @ brief Generate CRS pointers for the preconditioner - !! - !! Generate the CRS row and column pointers for the preconditioner. - !! JAPC(1:NEQ) hHas the position of the upper entry for a row, - !! JAPC(NEQ+1:NJA) is the column position for entry, - !! APC(1:NEQ) is the preconditioned inverse of the diagonal, and - !! APC(NEQ+1:NJA) are the preconditioned entries for off diagonals. - !< - SUBROUTINE ims_base_pccrs(NEQ, NJA, IA, JA, & - IAPC, JAPC) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NEQ !< - integer(I4B), INTENT(IN) :: NJA !< - integer(I4B), DIMENSION(NEQ + 1), INTENT(IN) :: IA !< - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< - integer(I4B), DIMENSION(NEQ + 1), INTENT(INOUT) :: IAPC !< - integer(I4B), DIMENSION(NJA), INTENT(INOUT) :: JAPC !< - ! -- local variables - integer(I4B) :: n, j - integer(I4B) :: i0, i1 - integer(I4B) :: nlen - integer(I4B) :: ic, ip - integer(I4B) :: jcol - integer(I4B), DIMENSION(:), ALLOCATABLE :: iarr - ! -- code - ip = NEQ + 1 - DO n = 1, NEQ - i0 = IA(n) - i1 = IA(n + 1) - 1 - nlen = i1 - i0 - ALLOCATE (iarr(nlen)) - ic = 0 - DO j = i0, i1 - jcol = JA(j) - IF (jcol == n) CYCLE - ic = ic + 1 - iarr(ic) = jcol - END DO - CALL ims_base_isort(nlen, iarr) - IAPC(n) = ip - DO j = 1, nlen - jcol = iarr(j) - JAPC(ip) = jcol - ip = ip + 1 - END DO - DEALLOCATE (iarr) - END DO - IAPC(NEQ + 1) = NJA + 1 - ! - ! -- POSITION OF THE FIRST UPPER ENTRY FOR ROW - DO n = 1, NEQ - i0 = IAPC(n) - i1 = IAPC(n + 1) - 1 - JAPC(n) = IAPC(n + 1) - DO j = i0, i1 - jcol = JAPC(j) - IF (jcol > n) THEN - JAPC(n) = j - EXIT - END IF - END DO - END DO - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_pccrs - - !> @brief In-place sorting for an integer array - !! - !! Subroutine sort an integer array in-place. - !! - !< - SUBROUTINE ims_base_isort(NVAL, IARRAY) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NVAL !< length of the interger array - integer(I4B), DIMENSION(NVAL), INTENT(INOUT) :: IARRAY !< integer array to be sorted - ! -- local variables - integer(I4B) :: i, j, itemp - ! -- code - DO i = 1, NVAL - 1 - DO j = i + 1, NVAL - if (IARRAY(i) > IARRAY(j)) then - itemp = IARRAY(j) - IARRAY(j) = IARRAY(i) - IARRAY(i) = itemp - END IF - END DO - END DO - ! - ! -- RETURN - RETURN - END SUBROUTINE ims_base_isort - - !> @brief Calculate residual - !! - !! Subroutine to calculate the residual. - !! - !< - SUBROUTINE ims_base_residual(NEQ, NJA, X, B, D, A, IA, JA) - ! -- dummy variables - integer(I4B), INTENT(IN) :: NEQ !< length of vectors - integer(I4B), INTENT(IN) :: NJA !< length of coefficient matrix - real(DP), DIMENSION(NEQ), INTENT(IN) :: X !< dependent variable - real(DP), DIMENSION(NEQ), INTENT(IN) :: B !< right-hand side - real(DP), DIMENSION(NEQ), INTENT(INOUT) :: D !< residual - real(DP), DIMENSION(NJA), INTENT(IN) :: A !< coefficient matrix - integer(I4B), DIMENSION(NEQ+1), INTENT(IN) :: IA !< CRS row pointers - integer(I4B), DIMENSION(NJA), INTENT(IN) :: JA !< CRS column pointers - ! -- local variables - integer(I4B) :: n - ! -- code - ! - ! -- calculate matrix-vector product - call amux(NEQ, X, D, A, JA, IA) - ! - ! -- subtract matrix-vector product from right-hand side - DO n = 1, NEQ - D(n) = B(n) - D(n) - END DO - ! - ! -- return - RETURN - END SUBROUTINE ims_base_residual - - END MODULE IMSLinearBaseModule diff --git a/src/Solution/SparseMatrixSolver/ims8linear.f90 b/src/Solution/SparseMatrixSolver/ims8linear.f90 deleted file mode 100644 index b30bebdcdaa..00000000000 --- a/src/Solution/SparseMatrixSolver/ims8linear.f90 +++ /dev/null @@ -1,1017 +0,0 @@ -MODULE IMSLinearModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, LENSOLUTIONNAME, LENMEMPATH, & - IZERO, DZERO, DPREC, DSAME, & - DEM8, DEM6, DEM5, DEM4, DEM3, DEM2, DEM1, & - DHALF, DONE, DTWO, & - VDEBUG - use GenericUtilitiesModule, only: sim_message - use IMSLinearBaseModule, only: ims_base_cg, ims_base_bcgs, & - ims_base_pccrs, ims_base_calc_order, & - ims_base_scale, ims_base_pcu, & - ims_base_residual - use BlockParserModule, only: BlockParserType - - IMPLICIT NONE - private - - TYPE, PUBLIC :: ImsLinearDataType - character(len=LENMEMPATH) :: memoryPath !< the path for storing variables in the memory manager - integer(I4B), POINTER :: iout => NULL() !< simulation listing file unit - integer(I4B), POINTER :: IPRIMS => NULL() !< print flag - integer(I4B), POINTER :: ILINMETH => NULL() !< linear accelerator (1) cg, (2) bicgstab - integer(I4B), POINTER :: ITER1 => NULL() !< maximum inner iterations - integer(I4B), POINTER :: IPC => NULL() !< preconditioner flag - integer(I4B), POINTER :: ISCL => NULL() !< scaling flag - integer(I4B), POINTER :: IORD => NULL() !< reordering flag - integer(I4B), POINTER :: NORTH => NULL() !< orthogonalization interval - integer(I4B), POINTER :: ICNVGOPT => NULL() !< rclose convergence option flag - integer(I4B), POINTER :: IACPC => NULL() !< preconditioner CRS row pointers - integer(I4B), POINTER :: NITERC => NULL() !< - integer(I4B), POINTER :: NIABCGS => NULL() !< size of working vectors for BCGS linear accelerator - integer(I4B), POINTER :: NIAPC => NULL() !< preconditioner number of rows - integer(I4B), POINTER :: NJAPC => NULL() !< preconditioner number of non-zero entries - real(DP), POINTER :: DVCLOSE => NULL() !< dependent variable convergence criteria - real(DP), POINTER :: RCLOSE => NULL() !< flow convergence criteria - real(DP), POINTER :: RELAX => NULL() !< preconditioner MILU0/MILUT relaxation factor - real(DP), POINTER :: EPFACT => NULL() !< factor for decreasing convergence criteria in seubsequent Picard iterations - real(DP), POINTER :: L2NORM0 => NULL() !< initial L2 norm - ! -- ilut variables - integer(I4B), POINTER :: LEVEL => NULL() !< preconditioner number of levels - real(DP), POINTER :: DROPTOL => NULL() !< preconditioner drop tolerance - integer(I4B), POINTER :: NJLU => NULL() !< length of jlu work vector - integer(I4B), POINTER :: NJW => NULL() !< length of jw work vector - integer(I4B), POINTER :: NWLU => NULL() !< length of wlu work vector - ! -- pointers to solution variables - integer(I4B), POINTER :: NEQ => NULL() !< number of equations (rows in matrix) - integer(I4B), POINTER :: NJA => NULL() !< number of non-zero values in amat - integer(I4B), dimension(:), pointer, contiguous :: IA => NULL() !< position of start of each row - integer(I4B), dimension(:), pointer, contiguous :: JA => NULL() !< column pointer - real(DP), dimension(:), pointer, contiguous :: AMAT => NULL() !< coefficient matrix - real(DP), dimension(:), pointer, contiguous :: RHS => NULL() !< right-hand side of equation - real(DP), dimension(:), pointer, contiguous :: X => NULL() !< dependent variable - ! VECTORS - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE => NULL() !< scaling factor - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DSCALE2 => NULL() !< unscaling factor - integer(I4B), POINTER,DIMENSION(:),CONTIGUOUS :: IAPC => NULL() !< position of start of each row in preconditioner matrix - integer(I4B), POINTER,DIMENSION(:),CONTIGUOUS :: JAPC => NULL() !< preconditioner matrix column pointer - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: APC => NULL() !< preconditioner coefficient matrix - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: LORDER => NULL() !< reordering mapping - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IORDER => NULL() !< mapping to restore reordered matrix - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IARO => NULL() !< position of start of each row in reordered matrix - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JARO => NULL() !< reordered matrix column pointer - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: ARO => NULL() !< reordered coefficient matrix - ! WORKING ARRAYS - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IW => NULL() !< integer working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: W => NULL() !< real working array - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: ID => NULL() !< integer working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: D => NULL() !< real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: P => NULL() !< real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Q => NULL() !< real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: Z => NULL() !< real working array - ! BICGSTAB WORKING ARRAYS - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: T => NULL() !< BICGSTAB real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: V => NULL() !< BICGSTAB real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: DHAT => NULL() !< BICGSTAB real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: PHAT => NULL() !< BICGSTAB real working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: QHAT => NULL() !< rBICGSTAB eal working array - ! POINTERS FOR USE WITH BOTH ORIGINAL AND RCM ORDERINGS - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: IA0 => NULL() !< pointer to current CRS row pointers - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JA0 => NULL() !< pointer to current CRS column pointers - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: A0 => NULL() !< pointer to current coefficient matrix - ! ILUT WORKING ARRAYS - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JLU => NULL() !< ilut integer working array - integer(I4B), POINTER, DIMENSION(:), CONTIGUOUS :: JW => NULL() !< ilut integer working array - real(DP), POINTER, DIMENSION(:), CONTIGUOUS :: WLU => NULL() !< ilut real working array - - ! PROCEDURES (METHODS) - CONTAINS - PROCEDURE :: IMSLINEAR_ALLOCATE => imslinear_ar - procedure :: imslinear_summary - PROCEDURE :: IMSLINEAR_APPLY => imslinear_ap - procedure :: IMSLINEAR_DA => imslinear_da - procedure, private :: allocate_scalars - ! -- PRIVATE PROCEDURES - PROCEDURE, PRIVATE :: SET_IMSLINEAR_INPUT => imslinear_set_input - END TYPE ImsLinearDataType - - - CONTAINS - - !> @ brief Allocate storage and read data - !! - !! Allocate storage for linear accelerators and read data - !! - !< - SUBROUTINE imslinear_ar(this, NAME, parser, IOUT, IPRIMS, MXITER, IFDPARAM, & - IMSLINEARM, NEQ, NJA, IA, JA, AMAT, RHS, X, & - NINNER, LFINDBLOCK) - ! -- modules - use MemoryManagerModule, only: mem_allocate - use MemoryHelperModule, only: create_mem_path - use SimModule, only: store_error, count_errors, & - deprecation_warning - ! -- dummy variables - CLASS(ImsLinearDataType), INTENT(INOUT) :: this !< ImsLinearDataType instance - CHARACTER (LEN=LENSOLUTIONNAME), INTENT(IN) :: NAME !< solution name - type(BlockParserType) :: parser !< block parser - integer(I4B), INTENT(IN) :: IOUT !< simulation listing file unit - integer(I4B), TARGET, INTENT(IN) :: IPRIMS !< print option - integer(I4B), INTENT(IN) :: MXITER !< maximum outer iterations - integer(I4B), INTENT(IN) :: IFDPARAM !< complexity option - integer(I4B), INTENT(INOUT) :: IMSLINEARM !< linear method option (1) CG (2) BICGSTAB - integer(I4B), TARGET, INTENT(IN) :: NEQ !< number of equations - integer(I4B), TARGET, INTENT(IN) :: NJA !< number of non-zero entries in the coefficient matrix - integer(I4B), DIMENSION(NEQ+1), TARGET, INTENT(IN) :: IA !< pointer to the start of a row in the coefficient matrix - integer(I4B), DIMENSION(NJA), TARGET, INTENT(IN) :: JA !< column pointer - real(DP), DIMENSION(NJA), TARGET, INTENT(IN) :: AMAT !< coefficient matrix - real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: RHS !< right-hand side - real(DP), DIMENSION(NEQ), TARGET, INTENT(INOUT) :: X !< dependent variables - integer(I4B), TARGET, INTENT(INOUT) :: NINNER !< maximum number of inner iterations - integer(I4B), INTENT(IN), OPTIONAL :: LFINDBLOCK !< flag indicating if the linear block is present (1) or missing (0) - - ! -- local variables - LOGICAL :: lreaddata - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: warnmsg - character(len=LINELENGTH) :: keyword - integer(I4B) :: i, n - integer(I4B) :: i0 - integer(I4B) :: iscllen, iolen - integer(I4B) :: ierr - real(DP) :: r - logical :: isfound, endOfBlock - integer(I4B) :: ijlu - integer(I4B) :: ijw - integer(I4B) :: iwlu - integer(I4B) :: iwk - ! - ! -- SET LREADDATA - IF (PRESENT(LFINDBLOCK)) THEN - IF (LFINDBLOCK < 1) THEN - lreaddata = .FALSE. - ELSE - lreaddata = .TRUE. - END IF - ELSE - lreaddata = .TRUE. - END IF - ! - ! -- DEFINE NAME - this%memoryPath = create_mem_path(name, 'IMSLinear') - ! - ! -- SET POINTERS TO SOLUTION STORAGE - this%IPRIMS => IPRIMS - this%NEQ => NEQ - this%NJA => NJA - this%IA => IA - this%JA => JA - this%AMAT => AMAT - this%RHS => RHS - this%X => X - ! - ! -- ALLOCATE SCALAR VARIABLES - call this%allocate_scalars() - ! - ! -- initialize iout - this%iout = iout - ! - ! -- DEFAULT VALUES - this%IORD = 0 - this%ISCL = 0 - this%IPC = 0 - this%LEVEL = 0 - ! - ! -- TRANSFER COMMON VARIABLES FROM IMS TO IMSLINEAR - this%ILINMETH = 0 - - this%IACPC = 0 - this%RELAX = DZERO !0.97 - - this%DROPTOL = DZERO - - this%NORTH = 0 - - this%ICNVGOPT = 0 - ! - ! -- PRINT A MESSAGE IDENTIFYING IMSLINEAR SOLVER PACKAGE - write(iout,2000) -02000 FORMAT (1X,/1X,'IMSLINEAR -- UNSTRUCTURED LINEAR SOLUTION', & - & ' PACKAGE, VERSION 8, 04/28/2017') - ! - ! -- SET DEFAULT IMSLINEAR PARAMETERS - CALL this%SET_IMSLINEAR_INPUT(IFDPARAM) - NINNER = this%iter1 - ! - ! -- get IMSLINEAR block - if (lreaddata) then - call parser%GetBlock('LINEAR', isfound, ierr, & - supportOpenClose=.true., blockRequired=.FALSE.) - else - isfound = .FALSE. - end if - ! - ! -- parse IMSLINEAR block if detected - if (isfound) then - write(iout,'(/1x,a)')'PROCESSING LINEAR DATA' - do - call parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call parser%GetStringCaps(keyword) - ! -- parse keyword - select case (keyword) - case ('INNER_DVCLOSE') - this%DVCLOSE = parser%GetDouble() - case ('INNER_RCLOSE') - this%rclose = parser%GetDouble() - ! -- look for additional key words - call parser%GetStringCaps(keyword) - if (keyword == 'STRICT') then - this%ICNVGOPT = 1 - else if (keyword == 'L2NORM_RCLOSE') then - this%ICNVGOPT = 2 - else if (keyword == 'RELATIVE_RCLOSE') then - this%ICNVGOPT = 3 - else if (keyword == 'L2NORM_RELATIVE_RCLOSE') then - this%ICNVGOPT = 4 - end if - case ('INNER_MAXIMUM') - i = parser%GetInteger() - this%iter1 = i - NINNER = i - case ('LINEAR_ACCELERATION') - call parser%GetStringCaps(keyword) - if (keyword.eq.'CG') then - this%ILINMETH = 1 - else if (keyword.eq.'BICGSTAB') then - this%ILINMETH = 2 - else - this%ILINMETH = 0 - write(errmsg,'(3a)') & - 'UNKNOWN IMSLINEAR LINEAR_ACCELERATION METHOD (', & - trim(keyword), ').' - call store_error(errmsg) - end if - case ('SCALING_METHOD') - call parser%GetStringCaps(keyword) - i = 0 - if (keyword.eq.'NONE') then - i = 0 - else if (keyword.eq.'DIAGONAL') then - i = 1 - else if (keyword.eq.'L2NORM') then - i = 2 - else - write(errmsg,'(3a)') & - 'UNKNOWN IMSLINEAR SCALING_METHOD (', trim(keyword), ').' - call store_error(errmsg) - end if - this%ISCL = i - case ('RED_BLACK_ORDERING') - i = 0 - case ('REORDERING_METHOD') - call parser%GetStringCaps(keyword) - i = 0 - if (keyword == 'NONE') then - i = 0 - else if (keyword == 'RCM') then - i = 1 - else if (keyword == 'MD') then - i = 2 - else - write(errmsg,'(3a)') & - 'UNKNOWN IMSLINEAR REORDERING_METHOD (', trim(keyword), ').' - call store_error(errmsg) - end if - this%IORD = i - case ('NUMBER_ORTHOGONALIZATIONS') - this%north = parser%GetInteger() - case ('RELAXATION_FACTOR') - this%relax = parser%GetDouble() - case ('PRECONDITIONER_LEVELS') - i = parser%GetInteger() - this%level = i - if (i < 0) then - write(errmsg,'(a,1x,a)') & - 'IMSLINEAR PRECONDITIONER_LEVELS MUST BE GREATER THAN', & - 'OR EQUAL TO ZERO' - call store_error(errmsg) - end if - case ('PRECONDITIONER_DROP_TOLERANCE') - r = parser%GetDouble() - this%DROPTOL = r - if (r < DZERO) then - write(errmsg,'(a,1x,a)') & - 'IMSLINEAR PRECONDITIONER_DROP_TOLERANCE', & - 'MUST BE GREATER THAN OR EQUAL TO ZERO' - call store_error(errmsg) - end if - ! - ! -- deprecated variables - case ('INNER_HCLOSE') - this%DVCLOSE = parser%GetDouble() - ! - ! -- create warning message - write(warnmsg,'(a)') & - 'SETTING INNER_DVCLOSE TO INNER_HCLOSE VALUE' - ! - ! -- create deprecation warning - call deprecation_warning('LINEAR', 'INNER_HCLOSE', '6.1.1', & - warnmsg, parser%GetUnit()) - ! - ! -- default - case default - write(errmsg,'(3a)') & - 'UNKNOWN IMSLINEAR KEYWORD (', trim(keyword), ').' - call store_error(errmsg) - end select - end do - write(iout,'(1x,a)') 'END OF LINEAR DATA' - else - if (IFDPARAM == 0) THEN - write(errmsg,'(a)') 'NO LINEAR BLOCK DETECTED.' - call store_error(errmsg) - end if - end if - - IMSLINEARM = this%ILINMETH - ! - ! -- DETERMINE PRECONDITIONER - IF (this%LEVEL > 0 .OR. this%DROPTOL > DZERO) THEN - this%IPC = 3 - ELSE - this%IPC = 1 - END IF - IF (this%RELAX > DZERO) THEN - this%IPC = this%IPC + 1 - END IF - ! - ! -- ERROR CHECKING FOR OPTIONS - IF (this%ISCL < 0 ) this%ISCL = 0 - IF (this%ISCL > 2 ) THEN - WRITE(errmsg,'(A)') 'IMSLINEAR7AR ISCL MUST BE <= 2' - call store_error(errmsg) - END IF - IF (this%IORD < 0 ) this%IORD = 0 - IF (this%IORD > 2) THEN - WRITE(errmsg,'(A)') 'IMSLINEAR7AR IORD MUST BE <= 2' - call store_error(errmsg) - END IF - IF (this%NORTH < 0) THEN - WRITE(errmsg,'(A)') 'IMSLINEAR7AR NORTH MUST >= 0' - call store_error(errmsg) - END IF - IF (this%RCLOSE == DZERO) THEN - IF (this%ICNVGOPT /= 3) THEN - WRITE(errmsg,'(A)') 'IMSLINEAR7AR RCLOSE MUST > 0.0' - call store_error(errmsg) - END IF - END IF - IF (this%RELAX < DZERO) THEN - WRITE(errmsg,'(A)') 'IMSLINEAR7AR RELAX MUST BE >= 0.0' - call store_error(errmsg) - END IF - IF (this%RELAX > DONE) THEN - WRITE(errmsg,'(A)') 'IMSLINEAR7AR RELAX MUST BE <= 1.0' - call store_error(errmsg) - END IF - ! - ! -- CHECK FOR ERRORS IN IMSLINEAR - if (count_errors() > 0) then - call parser%StoreErrorUnit() - endif - ! - ! -- INITIALIZE IMSLINEAR VARIABLES - this%NITERC = 0 - ! - ! -- ALLOCATE AND INITIALIZE MEMORY FOR IMSLINEAR - iscllen = 1 - IF (this%ISCL.NE.0 ) iscllen = NEQ - CALL mem_allocate(this%DSCALE, iscllen, 'DSCALE', TRIM(this%memoryPath)) - CALL mem_allocate(this%DSCALE2, iscllen, 'DSCALE2', TRIM(this%memoryPath)) - ! - ! -- ALLOCATE MEMORY FOR PRECONDITIONING MATRIX - ijlu = 1 - ijw = 1 - iwlu = 1 - ! - ! -- ILU0 AND MILU0 - this%NIAPC = this%NEQ - this%NJAPC = this%NJA - ! - ! -- ILUT AND MILUT - IF (this%IPC == 3 .OR. this%IPC == 4) THEN - this%NIAPC = this%NEQ - IF (this%LEVEL > 0) THEN - iwk = this%NEQ * (this%LEVEL * 2 + 1) - ELSE - iwk = 0 - DO n = 1, NEQ - i = IA(n+1) - IA(n) - IF (i > iwk) THEN - iwk = i - END IF - END DO - iwk = this%NEQ * iwk - END IF - this%NJAPC = iwk - ijlu = iwk - ijw = 2 * this%NEQ - iwlu = this%NEQ + 1 - END IF - this%NJLU = ijlu - this%NJW = ijw - this%NWLU = iwlu - ! - ! -- ALLOCATE BASE PRECONDITIONER VECTORS - CALL mem_allocate(this%IAPC, this%NIAPC+1, 'IAPC', TRIM(this%memoryPath)) - CALL mem_allocate(this%JAPC, this%NJAPC, 'JAPC', TRIM(this%memoryPath)) - CALL mem_allocate(this%APC, this%NJAPC, 'APC', TRIM(this%memoryPath)) - ! - ! -- ALLOCATE MEMORY FOR ILU0 AND MILU0 NON-ZERO ROW ENTRY VECTOR - CALL mem_allocate(this%IW, this%NIAPC, 'IW', TRIM(this%memoryPath)) - CALL mem_allocate(this%W, this%NIAPC, 'W', TRIM(this%memoryPath)) - ! - ! -- ALLOCATE MEMORY FOR ILUT VECTORS - CALL mem_allocate(this%JLU, ijlu, 'JLU', TRIM(this%memoryPath)) - CALL mem_allocate(this%JW, ijw, 'JW', TRIM(this%memoryPath)) - CALL mem_allocate(this%WLU, iwlu, 'WLU', TRIM(this%memoryPath)) - ! - ! -- GENERATE IAPC AND JAPC FOR ILU0 AND MILU0 - IF (this%IPC == 1 .OR. this%IPC == 2) THEN - CALL ims_base_pccrs(this%NEQ,this%NJA,this%IA,this%JA, & - this%IAPC,this%JAPC) - END IF - ! - ! -- ALLOCATE SPACE FOR PERMUTATION VECTOR - i0 = 1 - iolen = 1 - IF (this%IORD.NE.0) THEN - i0 = this%NEQ - iolen = this%NJA - END IF - CALL mem_allocate(this%LORDER, i0, 'LORDER', TRIM(this%memoryPath)) - CALL mem_allocate(this%IORDER, i0, 'IORDER', TRIM(this%memoryPath)) - CALL mem_allocate(this%IARO, i0+1, 'IARO', TRIM(this%memoryPath)) - CALL mem_allocate(this%JARO, iolen, 'JARO', TRIM(this%memoryPath)) - CALL mem_allocate(this%ARO, iolen, 'ARO', TRIM(this%memoryPath)) - ! - ! -- ALLOCATE WORKING VECTORS FOR IMSLINEAR SOLVER - CALL mem_allocate(this%ID, this%NEQ, 'ID', TRIM(this%memoryPath)) - CALL mem_allocate(this%D, this%NEQ, 'D', TRIM(this%memoryPath)) - CALL mem_allocate(this%P, this%NEQ, 'P', TRIM(this%memoryPath)) - CALL mem_allocate(this%Q, this%NEQ, 'Q', TRIM(this%memoryPath)) - CALL mem_allocate(this%Z, this%NEQ, 'Z', TRIM(this%memoryPath)) - ! - ! -- ALLOCATE MEMORY FOR BCGS WORKING ARRAYS - this%NIABCGS = 1 - IF (this%ILINMETH == 2) THEN - this%NIABCGS = this%NEQ - END IF - CALL mem_allocate(this%T, this%NIABCGS, 'T', TRIM(this%memoryPath)) - CALL mem_allocate(this%V, this%NIABCGS, 'V', TRIM(this%memoryPath)) - CALL mem_allocate(this%DHAT, this%NIABCGS, 'DHAT', TRIM(this%memoryPath)) - CALL mem_allocate(this%PHAT, this%NIABCGS, 'PHAT', TRIM(this%memoryPath)) - CALL mem_allocate(this%QHAT, this%NIABCGS, 'QHAT', TRIM(this%memoryPath)) - ! - ! -- INITIALIZE IMSLINEAR VECTORS - DO n = 1, iscllen - this%DSCALE(n) = DONE - this%DSCALE2(n) = DONE - END DO - DO n = 1, this%NJAPC - this%APC(n) = DZERO - END DO - ! - ! -- WORKING VECTORS - DO n = 1, this%NEQ - this%ID(n) = IZERO - this%D(n) = DZERO - this%P(n) = DZERO - this%Q(n) = DZERO - this%Z(n) = DZERO - END DO - DO n = 1, this%NIAPC - this%IW(n) = IZERO - this%W(n) = DZERO - END DO - ! - ! -- BCGS WORKING VECTORS - DO n = 1, this%NIABCGS - this%T(n) = DZERO - this%V(n) = DZERO - this%DHAT(n) = DZERO - this%PHAT(n) = DZERO - this%QHAT(n) = DZERO - END DO - ! - ! -- ILUT AND MILUT WORKING VECTORS - DO n = 1, ijlu - this%JLU(n) = DZERO - END DO - DO n = 1, ijw - this%JW(n) = DZERO - END DO - DO n = 1, iwlu - this%WLU(n) = DZERO - END DO - ! - ! -- REORDERING VECTORS - DO n = 1, i0 + 1 - this%IARO(n) = IZERO - END DO - DO n = 1, iolen - this%JARO(n) = IZERO - this%ARO(n) = DZERO - END DO - ! - ! -- REVERSE CUTHILL MCKEE AND MINIMUM DEGREE ORDERING - IF (this%IORD.NE.0) THEN - CALL ims_base_calc_order(this%IORD,this%NEQ, this%NJA,this%IA,this%JA, & - this%LORDER,this%IORDER) - END IF - ! - ! -- ALLOCATE MEMORY FOR STORING ITERATION CONVERGENCE DATA - ! - ! -- RETURN - RETURN - END SUBROUTINE imslinear_ar - - !> @ brief Write summary of settings - !! - !! Write summary of linear accelerator settings. - !! - !< - subroutine imslinear_summary(this, mxiter) - ! -- dummy variables - class(ImsLinearDataType), intent(inout) :: this !< ImsLinearDataType instance - integer(I4B), intent(in) :: mxiter !< maximum number of outer iterations - ! -- local variables - CHARACTER (LEN= 10) :: clin(0:2) - CHARACTER (LEN= 31) :: clintit(0:2) - CHARACTER (LEN= 20) :: cipc(0:4) - CHARACTER (LEN= 20) :: cscale(0:2) - CHARACTER (LEN= 25) :: corder(0:2) - CHARACTER (LEN= 16), DIMENSION(0:4) :: ccnvgopt - CHARACTER (LEN= 15) :: clevel - CHARACTER (LEN= 15) :: cdroptol - integer(I4B) :: i - integer(I4B) :: j - ! -- data - DATA clin /'UNKNOWN ', & - 'CG ', & - & 'BCGS '/ - DATA clintit /' UNKNOWN ', & - ' CONJUGATE-GRADIENT ', & - & 'BICONJUGATE-GRADIENT STABILIZED'/ - DATA cipc /'UNKNOWN ', & - & 'INCOMPLETE LU ', & - & 'MOD. INCOMPLETE LU ', & - & 'INCOMPLETE LUT ', & - & 'MOD. INCOMPLETE LUT '/ - DATA cscale/'NO SCALING ', & - & 'SYMMETRIC SCALING ', & - & 'L2 NORM SCALING '/ - DATA corder/'ORIGINAL ORDERING ', & - & 'RCM ORDERING ', & - & 'MINIMUM DEGREE ORDERING '/ - DATA ccnvgopt /'INFINITY NORM ', & - & 'INFINITY NORM S ', & - & 'L2 NORM ', & - & 'RELATIVE L2NORM ', & - 'L2 NORM W. REL. '/ - ! -- formats -02010 FORMAT (1X,/,7X,'SOLUTION BY THE',1X,A31,1X,'METHOD', & - & /,1X,66('-'),/, & - & ' MAXIMUM OF ',I0,' CALLS OF SOLUTION ROUTINE',/, & - & ' MAXIMUM OF ',I0, & - & ' INTERNAL ITERATIONS PER CALL TO SOLUTION ROUTINE',/, & - & ' LINEAR ACCELERATION METHOD =',1X,A,/, & - & ' MATRIX PRECONDITIONING TYPE =',1X,A,/, & - & ' MATRIX SCALING APPROACH =',1X,A,/, & - & ' MATRIX REORDERING APPROACH =',1X,A,/, & - & ' NUMBER OF ORTHOGONALIZATIONS =',1X,I0,/, & - & ' HEAD CHANGE CRITERION FOR CLOSURE =',E15.5,/, & - & ' RESIDUAL CHANGE CRITERION FOR CLOSURE =',E15.5,/, & - & ' RESIDUAL CONVERGENCE OPTION =',1X,I0,/, & - & ' RESIDUAL CONVERGENCE NORM =',1X,A,/, & - & ' RELAXATION FACTOR =',E15.5) -02015 FORMAT (' NUMBER OF LEVELS =',A15,/, & - & ' DROP TOLERANCE =',A15,//) -2030 FORMAT(1X,A20,1X,6(I6,1X)) -2040 FORMAT(1X,20('-'),1X,6(6('-'),1X)) -2050 FORMAT(1X,62('-'),/) ! -! -- ----------------------------------------------------------- - ! - ! -- initialize clevel and cdroptol - clevel = '' - cdroptol = '' - ! - ! -- write common variables to all linear accelerators - write(this%iout,2010) & - clintit(this%ILINMETH), MXITER, this%ITER1, & - clin(this%ILINMETH), cipc(this%IPC), & - cscale(this%ISCL), corder(this%IORD), & - this%NORTH, this%DVCLOSE, this%RCLOSE, & - this%ICNVGOPT, ccnvgopt(this%ICNVGOPT), & - this%RELAX - if (this%level > 0) then - write(clevel, '(i15)') this%level - end if - if (this%droptol > DZERO) then - write(cdroptol, '(e15.5)') this%droptol - end if - IF (this%level > 0 .or. this%droptol > DZERO) THEN - write(this%iout,2015) trim(adjustl(clevel)), & - trim(adjustl(cdroptol)) - ELSE - write(this%iout,'(//)') - END IF - - if (this%iord /= 0) then - ! - ! -- WRITE SUMMARY OF REORDERING INFORMATION TO LIST FILE - if (this%iprims == 2) then - DO i = 1, this%neq, 6 - write(this%iout,2030) 'ORIGINAL NODE :', & - (j,j=i,MIN(i+5,this%neq)) - write(this%iout,2040) - write(this%iout,2030) 'REORDERED INDEX :', & - (this%lorder(j),j=i,MIN(i+5,this%neq)) - write(this%iout,2030) 'REORDERED NODE :', & - (this%iorder(j),j=i,MIN(i+5,this%neq)) - write(this%iout,2050) - END DO - END IF - end if - ! - ! -- return - return - end subroutine imslinear_summary - - !> @ brief Allocate and initialize scalars - !! - !! Allocate and inititialize linear accelerator scalars - !! - !< - subroutine allocate_scalars(this) - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy variables - class(ImsLinearDataType), intent(inout) :: this !< ImsLinearDataType instance - ! - ! -- allocate scalars - call mem_allocate(this%iout, 'IOUT', this%memoryPath) - call mem_allocate(this%ilinmeth, 'ILINMETH', this%memoryPath) - call mem_allocate(this%iter1, 'ITER1', this%memoryPath) - call mem_allocate(this%ipc, 'IPC', this%memoryPath) - call mem_allocate(this%iscl, 'ISCL', this%memoryPath) - call mem_allocate(this%iord, 'IORD', this%memoryPath) - call mem_allocate(this%north, 'NORTH', this%memoryPath) - call mem_allocate(this%icnvgopt, 'ICNVGOPT', this%memoryPath) - call mem_allocate(this%iacpc, 'IACPC', this%memoryPath) - call mem_allocate(this%niterc, 'NITERC', this%memoryPath) - call mem_allocate(this%niabcgs, 'NIABCGS', this%memoryPath) - call mem_allocate(this%niapc, 'NIAPC', this%memoryPath) - call mem_allocate(this%njapc, 'NJAPC', this%memoryPath) - call mem_allocate(this%dvclose, 'DVCLOSE', this%memoryPath) - call mem_allocate(this%rclose, 'RCLOSE', this%memoryPath) - call mem_allocate(this%relax, 'RELAX', this%memoryPath) - call mem_allocate(this%epfact, 'EPFACT', this%memoryPath) - call mem_allocate(this%l2norm0, 'L2NORM0', this%memoryPath) - call mem_allocate(this%droptol, 'DROPTOL', this%memoryPath) - call mem_allocate(this%level, 'LEVEL', this%memoryPath) - call mem_allocate(this%njlu, 'NJLU', this%memoryPath) - call mem_allocate(this%njw, 'NJW', this%memoryPath) - call mem_allocate(this%nwlu, 'NWLU', this%memoryPath) - ! - ! -- initialize scalars - this%iout = 0 - this%ilinmeth = 0 - this%iter1 = 0 - this%ipc = 0 - this%iscl = 0 - this%iord = 0 - this%north = 0 - this%icnvgopt = 0 - this%iacpc = 0 - this%niterc = 0 - this%niabcgs = 0 - this%niapc = 0 - this%njapc = 0 - this%dvclose = DZERO - this%rclose = DZERO - this%relax = DZERO - this%epfact = DZERO - this%l2norm0 = 0 - this%droptol = DZERO - this%level = 0 - this%njlu = 0 - this%njw = 0 - this%nwlu = 0 - ! - ! -- return - return - end subroutine allocate_scalars - - !> @ brief Deallocate memory - !! - !! Deallocate linear accelerator memory. - !! - !< - subroutine imslinear_da(this) - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy variables - class(ImsLinearDataType), intent(inout) :: this !< linear datatype instance - ! - ! -- arrays - call mem_deallocate(this%dscale) - call mem_deallocate(this%dscale2) - call mem_deallocate(this%iapc) - call mem_deallocate(this%japc) - call mem_deallocate(this%apc) - call mem_deallocate(this%iw) - call mem_deallocate(this%w) - call mem_deallocate(this%jlu) - call mem_deallocate(this%jw) - call mem_deallocate(this%wlu) - call mem_deallocate(this%lorder) - call mem_deallocate(this%iorder) - call mem_deallocate(this%iaro) - call mem_deallocate(this%jaro) - call mem_deallocate(this%aro) - call mem_deallocate(this%id) - call mem_deallocate(this%d) - call mem_deallocate(this%p) - call mem_deallocate(this%q) - call mem_deallocate(this%z) - call mem_deallocate(this%t) - call mem_deallocate(this%v) - call mem_deallocate(this%dhat) - call mem_deallocate(this%phat) - call mem_deallocate(this%qhat) - ! - ! -- scalars - call mem_deallocate(this%iout) - call mem_deallocate(this%ilinmeth) - call mem_deallocate(this%iter1) - call mem_deallocate(this%ipc) - call mem_deallocate(this%iscl) - call mem_deallocate(this%iord) - call mem_deallocate(this%north) - call mem_deallocate(this%icnvgopt) - call mem_deallocate(this%iacpc) - call mem_deallocate(this%niterc) - call mem_deallocate(this%niabcgs) - call mem_deallocate(this%niapc) - call mem_deallocate(this%njapc) - call mem_deallocate(this%dvclose) - call mem_deallocate(this%rclose) - call mem_deallocate(this%relax) - call mem_deallocate(this%epfact) - call mem_deallocate(this%l2norm0) - call mem_deallocate(this%droptol) - call mem_deallocate(this%level) - call mem_deallocate(this%njlu) - call mem_deallocate(this%njw) - call mem_deallocate(this%nwlu) - ! - ! -- nullify pointers - nullify(this%iprims) - nullify(this%neq) - nullify(this%nja) - nullify(this%ia) - nullify(this%ja) - nullify(this%amat) - nullify(this%rhs) - nullify(this%x) - ! - ! -- return - return - end subroutine imslinear_da - - !> @ brief Set default settings - !! - !! Set default linear accelerator settings. - !! - !< - SUBROUTINE imslinear_set_input(this, IFDPARAM) - ! -- dummy variables - CLASS(ImsLinearDataType), INTENT(INOUT) :: this !< ImsLinearDataType instance - integer(I4B), INTENT(IN) :: IFDPARAM !< complexity option - ! -- code - SELECT CASE ( IFDPARAM ) - ! - ! -- Simple option - CASE(1) - this%ITER1 = 50 - this%ILINMETH=1 - this%IPC = 1 - this%ISCL = 0 - this%IORD = 0 - this%DVCLOSE = DEM3 - this%RCLOSE = DEM1 - this%RELAX = DZERO - this%LEVEL = 0 - this%DROPTOL = DZERO - this%NORTH = 0 - ! - ! -- Moderate - CASE(2) - this%ITER1 = 100 - this%ILINMETH=2 - this%IPC = 2 - this%ISCL = 0 - this%IORD = 0 - this%DVCLOSE = DEM2 - this%RCLOSE = DEM1 - this%RELAX = 0.97D0 - this%LEVEL = 0 - this%DROPTOL = DZERO - this%NORTH = 0 - ! - ! -- Complex - CASE(3) - this%ITER1 = 500 - this%ILINMETH=2 - this%IPC = 3 - this%ISCL = 0 - this%IORD = 0 - this%DVCLOSE = DEM1 - this%RCLOSE = DEM1 - this%RELAX = DZERO - this%LEVEL = 5 - this%DROPTOL = DEM4 - this%NORTH = 2 - END SELECT - ! - ! -- return - RETURN - END SUBROUTINE imslinear_set_input - - !> @ brief Base linear accelerator subroutine - !! - !! Base linear accelerator subroutine that scales and reorders - !! the system of equations, if necessary, updates the preconditioner, - !! and calls the appropriate linear accelerator. - !! - !< - SUBROUTINE imslinear_ap(this,ICNVG,KSTP,KITER,IN_ITER, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - ! -- modules - USE SimModule - ! -- dummy variables - CLASS(ImsLinearDataType), INTENT(INOUT) :: this !< ImsLinearDataType instance - integer(I4B), INTENT(INOUT) :: ICNVG !< convergence flag (1) non-convergence (0) - integer(I4B), INTENT(IN) :: KSTP !< time step number - integer(I4B), INTENT(IN) :: KITER !< outer iteration number - integer(I4B), INTENT(INOUT) :: IN_ITER !< inner iteration number - ! -- convergence information dummy variables - integer(I4B), INTENT(IN) :: NCONV !< - integer(I4B), INTENT(IN) :: CONVNMOD !< - integer(I4B), DIMENSION(CONVNMOD+1), INTENT(INOUT) ::CONVMODSTART !< - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDV !< - integer(I4B), DIMENSION(CONVNMOD), INTENT(INOUT) :: LOCDR !< - character(len=31), DIMENSION(NCONV), INTENT(INOUT) :: CACCEL !< - integer(I4B), DIMENSION(NCONV), INTENT(INOUT) :: ITINNER !< - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDV !< - integer(I4B), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVLOCDR !< - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DVMAX !< - real(DP), DIMENSION(CONVNMOD), INTENT(INOUT) :: DRMAX !< - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDVMAX !< - real(DP), DIMENSION(CONVNMOD, NCONV), INTENT(INOUT) :: CONVDRMAX !< - ! -- local variables - integer(I4B) :: n - integer(I4B) :: innerit - integer(I4B) :: irc - integer(I4B) :: itmax - real(DP) :: dnrm2 - ! - ! -- set epfact based on timestep - IF (this%ICNVGOPT == 2) THEN - IF (KSTP == 1) THEN - this%EPFACT = 0.01 - ELSE - this%EPFACT = 0.10 - END IF - ELSE IF (this%ICNVGOPT == 4) THEN - this%EPFACT = DEM4 - ELSE - this%EPFACT = DONE - END IF - ! - ! -- SCALE PROBLEM - IF (this%ISCL.NE.0) THEN - CALL ims_base_scale(0,this%ISCL, & - this%NEQ,this%NJA,this%IA,this%JA, & - this%AMAT,this%X,this%RHS, & - this%DSCALE,this%DSCALE2) - END IF - ! - ! -- PERMUTE ROWS, COLUMNS, AND RHS - IF (this%IORD /= 0) THEN - CALL dperm(this%NEQ, this%AMAT, this%JA, this%IA, & - this%ARO, this%JARO, this%IARO, & - this%LORDER, this%ID, 1) - CALL dvperm(this%NEQ, this%X, this%LORDER) - CALL dvperm(this%NEQ, this%RHS, this%LORDER) - this%IA0 => this%IARO - this%JA0 => this%JARO - this%A0 => this%ARO - ELSE - this%IA0 => this%IA - this%JA0 => this%JA - this%A0 => this%AMAT - END IF - ! - ! -- UPDATE PRECONDITIONER - CALL ims_base_pcu(this%iout,this%NJA,this%NEQ,this%NIAPC,this%NJAPC, & - this%IPC, this%RELAX, this%A0, this%IA0, this%JA0, & - this%APC,this%IAPC,this%JAPC,this%IW,this%W, & - this%LEVEL, this%DROPTOL, this%NJLU, this%NJW, & - this%NWLU, this%JLU, this%JW, this%WLU) - ! - ! -- INITIALIZE SOLUTION VARIABLE AND ARRAYS - IF (KITER == 1 ) this%NITERC = 0 - irc = 1 - ICNVG = 0 - DO n = 1, this%NEQ - this%D(n) = DZERO - this%P(n) = DZERO - this%Q(n) = DZERO - this%Z(n) = DZERO - END DO - ! - ! -- CALCULATE INITIAL RESIDUAL - call ims_base_residual(this%NEQ, this%NJA, this%X, this%RHS, this%D, & - this%A0, this%IA0, this%JA0) - this%L2NORM0 = dnrm2(this%NEQ, this%D, 1) - ! - ! -- CHECK FOR EXACT SOLUTION - itmax = this%ITER1 - IF (this%L2NORM0 == DZERO) THEN - itmax = 0 - ICNVG = 1 - END IF - ! - ! -- SOLUTION BY THE CONJUGATE GRADIENT METHOD - IF (this%ILINMETH == 1) THEN - CALL ims_base_cg(ICNVG, itmax, innerit, & - this%NEQ, this%NJA, this%NIAPC, this%NJAPC, & - this%IPC, this%NITERC, this%ICNVGOPT, this%NORTH, & - this%DVCLOSE, this%RCLOSE, this%L2NORM0, & - this%EPFACT, this%IA0, this%JA0, this%A0, & - this%IAPC, this%JAPC, this%APC, & - this%X, this%RHS, this%D, this%P, this%Q, this%Z, & - this%NJLU, this%IW, this%JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - ! - ! -- SOLUTION BY THE BICONJUGATE GRADIENT STABILIZED METHOD - ELSE IF (this%ILINMETH == 2) THEN - CALL ims_base_bcgs(ICNVG, itmax, innerit, & - this%NEQ, this%NJA, this%NIAPC, this%NJAPC, & - this%IPC, this%NITERC, this%ICNVGOPT, this%NORTH,& - this%ISCL, this%DSCALE, & - this%DVCLOSE, this%RCLOSE, this%L2NORM0, & - this%EPFACT, this%IA0, this%JA0, this%A0, & - this%IAPC, this%JAPC, this%APC, & - this%X, this%RHS, this%D, this%P, this%Q, & - this%T, this%V, this%DHAT, this%PHAT, this%QHAT, & - this%NJLU, this%IW, this%JLU, & - NCONV, CONVNMOD, CONVMODSTART, LOCDV, LOCDR, & - CACCEL, ITINNER, CONVLOCDV, CONVLOCDR, & - DVMAX, DRMAX, CONVDVMAX, CONVDRMAX) - END IF - ! - ! -- BACK PERMUTE AMAT, SOLUTION, AND RHS - IF (this%IORD /= 0) THEN - CALL dperm(this%NEQ, this%A0, this%JA0, this%IA0, & - this%AMAT, this%JA, this%IA, & - this%IORDER, this%ID, 1) - CALL dvperm(this%NEQ, this%X, this%IORDER) - CALL dvperm(this%NEQ, this%RHS, this%IORDER) - END IF - ! - ! -- UNSCALE PROBLEM - IF (this%ISCL.NE.0) THEN - CALL ims_base_scale(1, this%ISCL, & - this%NEQ, this%NJA, this%IA, this%JA, & - this%AMAT, this%X, this%RHS, & - this%DSCALE, this%DSCALE2) - END IF - ! - ! -- SET IMS INNER ITERATION NUMBER (IN_ITER) TO NUMBER OF - ! IMSLINEAR INNER ITERATIONS (innerit) - IN_ITER = innerit - ! - ! -- RETURN - RETURN - END SUBROUTINE imslinear_ap - -END MODULE IMSLinearModule diff --git a/src/Solution/SparseMatrixSolver/ims8reordering.f90 b/src/Solution/SparseMatrixSolver/ims8reordering.f90 deleted file mode 100644 index 684f4232594..00000000000 --- a/src/Solution/SparseMatrixSolver/ims8reordering.f90 +++ /dev/null @@ -1,781 +0,0 @@ - MODULE IMSReorderingModule - use KindModule, only: DP, I4B - private - public :: ims_odrv - contains - - subroutine ims_odrv(n, nja, nsp, ia, ja, p, ip, isp, flag) - ! - ! 3/12/82 - !*********************************************************************** - ! odrv -- driver for sparse matrix reordering routines - !*********************************************************************** - ! - ! description - ! - ! odrv finds a minimum degree ordering of the rows and columns - ! of a matrix m stored in (ia,ja,a) format (see below). for the - ! reordered matrix, the work and storage required to perform - ! gaussian elimination is (usually) significantly less. - ! - ! note.. odrv and its subordinate routines have been modified to - ! compute orderings for general matrices, not necessarily having any - ! symmetry. the minimum degree ordering is computed for the - ! structure of the symmetric matrix m + m-transpose. - ! modifications to the original odrv module have been made in - ! the coding in subroutine mdi, and in the initial comments in - ! subroutines odrv and md. - ! - ! if only the nonzero entries in the upper triangle of m are being - ! stored, then odrv symmetrically reorders (ia,ja,a), (optionally) - ! with the diagonal entries placed first in each row. this is to - ! ensure that if m(i,j) will be in the upper triangle of m with - ! respect to the new ordering, then m(i,j) is stored in row i (and - ! thus m(j,i) is not stored), whereas if m(i,j) will be in the - ! strict lower triangle of m, then m(j,i) is stored in row j (and - ! thus m(i,j) is not stored). - ! - ! - ! storage of sparse matrices - ! - ! the nonzero entries of the matrix m are stored row-by-row in the - ! array a. to identify the individual nonzero entries in each row, - ! we need to know in which column each entry lies. these column - ! indices are stored in the array ja. i.e., if a(k) = m(i,j), then - ! ja(k) = j. to identify the individual rows, we need to know where - ! each row starts. these row pointers are stored in the array ia. - ! i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row - ! and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to - ! the first location following the last element in the last row. - ! thus, the number of entries in the i-th row is ia(i+1) - ia(i), - ! the nonzero entries in the i-th row are stored consecutively in - ! - ! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), - ! - ! and the corresponding column indices are stored consecutively in - ! - ! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). - ! - ! since the coefficient matrix is symmetric, only the nonzero entries - ! in the upper triangle need be stored. for example, the matrix - ! - ! ( 1 0 2 3 0 ) - ! ( 0 4 0 0 0 ) - ! m = ( 2 0 5 6 0 ) - ! ( 3 0 6 7 8 ) - ! ( 0 0 0 8 9 ) - ! - ! could be stored as - ! - ! - 1 2 3 4 5 6 7 8 9 10 11 12 13 - ! ---+-------------------------------------- - ! ia - 1 4 5 8 12 14 - ! ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 - ! a - 1 2 3 4 2 5 6 3 6 7 8 8 9 - ! - ! or (symmetrically) as - ! - ! - 1 2 3 4 5 6 7 8 9 - ! ---+-------------------------- - ! ia - 1 4 5 7 9 10 - ! ja - 1 3 4 2 3 4 4 5 5 - ! a - 1 2 3 4 5 6 7 8 9 . - ! - ! - ! parameters - ! - ! n - order of the matrix - ! - ! nja - number of nonzeroes in the matrix - ! - ! nsp - declared dimension of the one-dimensional array isp. nsp - ! must be at least 3n+4k, where k is the number of nonzeroes - ! in the strict upper triangle of m - ! - ! ia - integer one-dimensional array containing pointers to delimit - ! rows in ja and a. dimension = n+1 - ! - ! ja - integer one-dimensional array containing the column indices - ! corresponding to the elements of a. dimension = number of - ! nonzero entries in (the upper triangle of) m - ! - ! a - real one-dimensional array containing the nonzero entries in - ! (the upper triangle of) m, stored by rows. dimension = - ! number of nonzero entries in (the upper triangle of) m - ! - ! p - integer one-dimensional array used to return the permutation - ! of the rows and columns of m corresponding to the minimum - ! degree ordering. dimension = n - ! - ! ip - integer one-dimensional array used to return the inverse of - ! the permutation returned in p. dimension = n - ! - ! isp - integer one-dimensional array used for working storage. - ! dimension = nsp - ! - ! path - integer path specification. values and their meanings are - - ! 1 find minimum degree ordering only - ! 2 find minimum degree ordering and reorder symmetrically - ! stored matrix (used when only the nonzero entries in - ! the upper triangle of m are being stored) - ! 3 reorder symmetrically stored matrix as specified by - ! input permutation (used when an ordering has already - ! been determined and only the nonzero entries in the - ! upper triangle of m are being stored) - ! 4 same as 2 but put diagonal entries at start of each row - ! 5 same as 3 but put diagonal entries at start of each row - ! - ! flag - integer error flag. values and their meanings are - - ! 0 no errors detected - ! 9n+k insufficient storage in md - ! 10n+1 insufficient storage in odrv - ! 11n+1 illegal path specification - ! - ! - ! conversion from real to double precision - ! - ! change the real declarations in odrv and sro to double precision - ! declarations. - ! - !----------------------------------------------------------------------- - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: nsp - integer(I4B), dimension(n+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), dimension(n), intent(inout) :: p - integer(I4B), dimension(n), intent(inout) :: ip - integer(I4B), dimension(nsp), intent(inout) :: isp - integer(I4B), intent(inout) :: flag - - ! -- local - integer(I4B) :: v - integer(I4B) :: l - integer(I4B) :: head - integer(I4B) :: mmax - integer(I4B) :: next - integer(I4B) :: path - ! - ! set path for finding ordering only - ! - path = 1 - ! - ! - ! initialize error flag and validate path specification - flag = 0 - if (path < 1 .or. 5 < path) go to 111 - ! - ! find minimum degree ordering - mmax = (nsp-n)/2 - v = 1 - l = v + mmax - head = l + mmax - next = head + n - if (mmax < n) go to 110 - ! - call ims_md(n, nja, ia, ja, mmax, isp(v), isp(l), isp(head), p, & - ip, isp(v), flag) - if (flag.ne.0) go to 100 - ! - return - ! - ! ** error -- error detected in md - ! flag = 9 * n + vi from routine mdi. - ! -100 return - ! ** error -- insufficient storage -110 flag = 10*n + 1 - return - ! ** error -- illegal path specified -111 flag = 11*n + 1 - return - end subroutine ims_odrv - - - - subroutine ims_md(n, nja, ia, ja, mmax, v, l, head, last, next, & - mark, flag) - ! - !***************************************************************** - ! ims_md -- minimum degree algorithm (based on element model) - !***************************************************************** - ! - ! description - ! - ! ims_md finds a minimum degree ordering of the rows and - ! columns of a general sparse matrix m stored in (ia,ja,a) - ! format. when the structure of m is nonsymmetric, the ordering - ! is that obtained for the symmetric matrix m + m-transpose. - ! - ! - ! additional parameters - ! - ! mmax - declared dimension of the one-dimensional arrays v and l. - ! mmax must be at least n+2k, where k is the number of - ! nonzeroes in the strict upper triangle of m - ! - ! v - integer one-dimensional work array. dimension = mmax - ! - ! l - integer one-dimensional work array. dimension = mmax - ! - ! head - integer one-dimensional work array. dimension = n - ! - ! last - integer one-dimensional array used to return the permutation - ! of the rows and columns of m corresponding to the minimum - ! degree ordering. dimension = n - ! - ! next - integer one-dimensional array used to return the inverse of - ! the permutation returned in last. dimension = n - ! - ! mark - integer one-dimensional work array (may be the same as v). - ! dimension = n - ! - ! flag - integer error flag. values and their meanings are - - ! 0 no errors detected - ! 11n+1 insufficient storage in md - ! - ! - ! definitions of internal parameters - ! - ! ---------+--------------------------------------------------------- - ! v(s) - value field of list entry - ! ---------+--------------------------------------------------------- - ! l(s) - link field of list entry (0 =) end of list) - ! ---------+--------------------------------------------------------- - ! l(vi) - pointer to element list of uneliminated vertex vi - ! ---------+--------------------------------------------------------- - ! l(ej) - pointer to boundary list of active element ej - ! ---------+--------------------------------------------------------- - ! head(d) - vj =) vj head of d-list d - ! - 0 =) no vertex in d-list d - ! - ! - ! - vi uneliminated vertex - ! - vi in ek - vi not in ek - ! ---------+-----------------------------+--------------------------- - ! next(vi) - undefined but nonnegative - vj =) vj next in d-list - ! - - 0 =) vi tail of d-list - ! ---------+-----------------------------+--------------------------- - ! last(vi) - (not set until mdp) - -d =) vi head of d-list d - ! --vk =) compute degree - vj =) vj last in d-list - ! - ej =) vi prototype of ej - 0 =) vi not in any d-list - ! - 0 =) do not compute degree - - ! ---------+-----------------------------+--------------------------- - ! mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) - ! - ! - ! - vi eliminated vertex - ! - ei active element - otherwise - ! ---------+-----------------------------+--------------------------- - ! next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex - ! - to be eliminated - to be eliminated - ! ---------+-----------------------------+--------------------------- - ! last(vi) - m =) size of ei = m - undefined - ! ---------+-----------------------------+--------------------------- - ! mark(vi) - -m =) overlap count of ei - undefined - ! - with ek = m - - ! - otherwise nonnegative tag - - ! - .lt. mark(vk) - - ! - !----------------------------------------------------------------------- - ! - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nja - integer(I4B), dimension(n+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), intent(in) :: mmax - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - integer(I4B), intent(inout) :: flag - - ! -- local - integer(I4B) :: tag - integer(I4B) :: dmin - integer(I4B) :: vk - integer(I4B) :: ek - integer(I4B) :: tail - integer(I4B) :: k - - equivalence(vk, ek) - ! - ! initialization - tag = 0 - call ims_mdi(n, nja, ia, ja, mmax ,v, l, head, last, next, & - mark, tag, flag) - if (flag.ne.0) return - ! - k = 0 - dmin = 1 - ! - ! while k .lt. n do -1 if (k >= n) go to 4 - ! - ! search for vertex of minimum degree -2 if (head(dmin) > 0) go to 3 - dmin = dmin + 1 - go to 2 - ! - ! remove vertex vk of minimum degree from degree list -3 vk = head(dmin) - head(dmin) = next(vk) - if (head(dmin) > 0) last(head(dmin)) = -dmin - ! - ! number vertex vk, adjust tag, and tag vk - k = k+1 - next(vk) = -k - last(ek) = dmin - 1 - tag = tag + last(ek) - mark(vk) = tag - ! - ! form element ek from uneliminated neighbors of vk - call ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) - ! - ! purge inactive elements and do mass elimination - call ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) - ! - ! update degrees of uneliminated vertices in ek - call ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) - ! - go to 1 - ! - ! generate inverse permutation from permutation -4 do k = 1, n - next(k) = -next(k) - last(next(k)) = k - end do - ! - return - end subroutine ims_md - - - subroutine ims_mdi(n, nja, ia, ja, mmax, v, l, head, last, next, & - mark, tag, flag) - ! - !*********************************************************************** - ! ims_mdi -- initialization - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: nja - integer(I4B), dimension(n+1), intent(in) :: ia - integer(I4B), dimension(nja), intent(in) :: ja - integer(I4B), intent(in) :: mmax - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - integer(I4B), intent(in) :: tag - integer(I4B), intent(inout) :: flag - - ! -- local - integer(I4B) :: sfs - integer(I4B) :: vi - integer(I4B) :: dvi - integer(I4B) :: vj - integer(I4B) :: jmin - integer(I4B) :: jmax - integer(I4B) :: j - integer(I4B) :: lvk - integer(I4B) :: kmax - integer(I4B) :: k - integer(I4B) :: nextvi - integer(I4B) :: ieval - ! - ! initialize degrees, element lists, and degree lists - do vi = 1, n - mark(vi) = 1 - l(vi) = 0 - head(vi) = 0 - end do - sfs = n + 1 - ! - ! create nonzero structure - ! for each nonzero entry a(vi,vj) - louter: do vi = 1, n - jmin = ia(vi) - jmax = ia(vi+1) - 1 - if (jmin > jmax) cycle louter - linner1: do j = jmin, jmax !5 - vj = ja(j) - !if (vj-vi) 2, 5, 4 - ieval = vj - vi - if (ieval == 0) cycle linner1 !5 - if (ieval > 0) go to 4 - ! - ! if a(vi,vj) is in strict lower triangle - ! check for previous occurrence of a(vj,vi) - lvk = vi - kmax = mark(vi) - 1 - if (kmax == 0) go to 4 - linner2: do k = 1, kmax - lvk = l(lvk) - if (v(lvk) == vj) cycle linner1 !5 - end do linner2 - ! for unentered entries a(vi,vj) -4 if (sfs >= mmax) go to 101 - ! - ! enter vj in element list for vi - mark(vi) = mark(vi) + 1 - v(sfs) = vj - l(sfs) = l(vi) - l(vi) = sfs - sfs = sfs+1 - ! - ! enter vi in element list for vj - mark(vj) = mark(vj) + 1 - v(sfs) = vi - l(sfs) = l(vj) - l(vj) = sfs - sfs = sfs + 1 - end do linner1 - end do louter - ! - ! create degree lists and initialize mark vector - do vi = 1, n - dvi = mark(vi) - next(vi) = head(dvi) - head(dvi) = vi - last(vi) = -dvi - nextvi = next(vi) - if (nextvi > 0) last(nextvi) = vi - mark(vi) = tag - end do - ! - return - ! - ! ** error- insufficient storage -101 flag = 9*n + vi - return - end subroutine ims_mdi - - - - subroutine ims_mdm(n, mmax, vk, tail, v, l, last, next, mark) - ! - !*********************************************************************** - ! ims_mdm -- form element from uneliminated neighbors of vk - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: mmax - integer(I4B), intent(in) :: vk - integer(I4B), intent(inout) :: tail - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - - ! -- local - integer(I4B) :: tag - integer(I4B) :: s - integer(I4B) :: ls - integer(I4B) :: vs - integer(I4B) :: es - integer(I4B) :: b - integer(I4B) :: lb - integer(I4B) :: vb - integer(I4B) :: blp - integer(I4B) :: blpmax - - equivalence (vs, es) - ! - ! initialize tag and list of uneliminated neighbors - tag = mark(vk) - tail = vk - ! - ! for each vertex/element vs/es in element list of vk - ls = l(vk) -1 s = ls - if (s == 0) go to 5 - ls = l(s) - vs = v(s) - if (next(vs) < 0) go to 2 - ! - ! if vs is uneliminated vertex, then tag and append to list of - ! uneliminated neighbors - mark(vs) = tag - l(tail) = s - tail = s - go to 4 - ! - ! if es is active element, then ... - ! for each vertex vb in boundary list of element es -2 lb = l(es) - blpmax = last(es) - louter: do blp = 1, blpmax !3 - b = lb - lb = l(b) - vb = v(b) - ! - ! if vb is untagged vertex, then tag and append to list of - ! uneliminated neighbors - if (mark(vb) >= tag) cycle louter !3 - mark(vb) = tag - l(tail) = b - tail = b - end do louter - ! - ! mark es inactive - mark(es) = tag - ! -4 go to 1 - ! - ! terminate list of uneliminated neighbors -5 l(tail) = 0 - ! - return - end subroutine ims_mdm - - - subroutine ims_mdp(n, mmax, k, ek, tail, v, l, head, last, next, mark) - ! - !*********************************************************************** - ! ims_mdp -- purge inactive elements and do mass elimination - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: mmax - integer(I4B), intent(inout) :: k - integer(I4B), intent(in) :: ek - integer(I4B), intent(inout) :: tail - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - - ! -- local - integer(I4B) :: tag - integer(I4B) :: free - integer(I4B) :: li - integer(I4B) :: vi - integer(I4B) :: lvi - integer(I4B) :: evi - integer(I4B) :: s - integer(I4B) :: ls - integer(I4B) :: es - integer(I4B) :: ilp - integer(I4B) :: ilpmax - integer(I4B) :: i - ! - ! initialize tag - tag = mark(ek) - ! - ! for each vertex vi in ek - li = ek - ilpmax = last(ek) - if (ilpmax <= 0) go to 12 - louter: do ilp = 1, ilpmax !11 - i = li - li = l(i) - vi = v(li) - ! - ! remove vi from degree list - if (last(vi) == 0) go to 3 - if (last(vi) > 0) go to 1 - head(-last(vi)) = next(vi) - go to 2 -1 next(last(vi)) = next(vi) -2 if (next(vi) > 0) last(next(vi)) = last(vi) - ! - ! remove inactive items from element list of vi -3 ls = vi -4 s = ls - ls = l(s) - if (ls == 0) go to 6 - es = v(ls) - if (mark(es) < tag) go to 5 - free = ls - l(s) = l(ls) - ls = s -5 go to 4 - ! - ! if vi is interior vertex, then remove from list and eliminate - -6 lvi = l(vi) - if (lvi.ne.0) go to 7 - l(i) = l(li) - li = i - ! - k = k + 1 - next(vi) = -k - last(ek) = last(ek) - 1 - cycle louter !11 - ! - ! else ... - ! classify vertex vi -7 if (l(lvi).ne.0) go to 9 - evi = v(lvi) - if (next(evi) >= 0) go to 9 - if (mark(evi) < 0) go to 8 - ! - ! if vi is prototype vertex, then mark as such, initialize - ! overlap count for corresponding element, and move vi to end - ! of boundary list - last(vi) = evi - mark(evi) = -1 - l(tail) = li - tail = li - l(i) = l(li) - li = i - go to 10 - ! - ! else if vi is duplicate vertex, then mark as such and adjust - ! overlap count for corresponding element -8 last(vi) = 0 - mark(evi) = mark(evi) - 1 - go to 10 - ! - ! else mark vi to compute degree -9 last(vi) = -ek - ! - ! insert ek in element list of vi -10 v(free) = ek - l(free) = l(vi) - l(vi) = free - end do louter !11 - ! - ! terminate boundary list -12 l(tail) = 0 - ! - return - end subroutine ims_mdp - - - subroutine ims_mdu(n, mmax, ek, dmin, v, l, head, last, next, mark) - ! - !*********************************************************************** - ! ims_mdu -- update degrees of uneliminated vertices in ek - !*********************************************************************** - implicit none - - ! -- dummy variables - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: mmax - integer(I4B), intent(in) :: ek - integer(I4B), intent(inout) :: dmin - integer(I4B), dimension(mmax), intent(inout) :: v - integer(I4B), dimension(mmax), intent(inout) :: l - integer(I4B), dimension(n), intent(inout) :: head - integer(I4B), dimension(n), intent(inout) :: last - integer(I4B), dimension(n), intent(inout) :: next - integer(I4B), dimension(n), intent(inout) :: mark - - ! -- local - integer(I4B) :: tag - integer(I4B) :: vi - integer(I4B) :: evi - integer(I4B) :: dvi - integer(I4B) :: s - integer(I4B) :: vs - integer(I4B) :: es - integer(I4B) :: b - integer(I4B) :: vb - integer(I4B) :: ilp - integer(I4B) :: ilpmax - integer(I4B) :: blp - integer(I4B) :: blpmax - integer(I4B) :: i - - equivalence (vs, es) - ! - ! initialize tag - tag = mark(ek) - last(ek) - ! - ! for each vertex vi in ek - i = ek - ilpmax = last(ek) - if (ilpmax <= 0) go to 11 - louter: do ilp = 1, ilpmax !10 - i = l(i) - vi = v(i) - !if (last(vi)) 1, 10, 8 - if (last(vi) == 0) cycle louter !10 - if (last(vi) > 0) goto 8 - ! - ! if vi neither prototype nor duplicate vertex, then merge elements - ! to compute degree - tag = tag + 1 - dvi = last(ek) - ! - ! for each vertex/element vs/es in element list of vi - s = l(vi) -2 s = l(s) - if (s == 0) go to 9 - vs = v(s) - if (next(vs) < 0) go to 3 - ! - ! if vs is uneliminated vertex, then tag and adjust degree - mark(vs) = tag - dvi = dvi + 1 - go to 5 - ! - ! if es is active element, then expand - ! check for outmatched vertex -3 if (mark(es) < 0) go to 6 - ! - ! for each vertex vb in es - b = es - blpmax = last(es) - linner: do blp = 1, blpmax !4 - b = l(b) - vb = v(b) - ! - ! if vb is untagged, then tag and adjust degree - if (mark(vb) >= tag) cycle linner !4 - mark(vb) = tag - dvi = dvi + 1 - end do linner !4 - ! -5 go to 2 - ! - ! else if vi is outmatched vertex, then adjust overlaps but do not - ! compute degree -6 last(vi) = 0 - mark(es) = mark(es) - 1 -7 s = l(s) - if (s == 0) cycle louter !10 - es = v(s) - if (mark(es) < 0) mark(es) = mark(es) - 1 - go to 7 - ! - ! else if vi is prototype vertex, then calculate degree by - ! inclusion/exclusion and reset overlap count -8 evi = last(vi) - dvi = last(ek) + last(evi) + mark(evi) - mark(evi) = 0 - ! - ! insert vi in appropriate degree list -9 next(vi) = head(dvi) - head(dvi) = vi - last(vi) = -dvi - if (next(vi) > 0) last(next(vi)) = vi - if (dvi < dmin) dmin = dvi - ! - end do louter !10 - ! -11 return - end subroutine ims_mdu - - end module IMSReorderingModule \ No newline at end of file From 20074687d4d1f0e84045797a102038ff60cc1ee1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 16:11:52 -0700 Subject: [PATCH 006/212] Updating the contents of the src/Utilities/ directory with the fprettify stuff. I didn't have any local changes in this directory. --- src/Utilities/ArrayHandlers.f90 | 158 +-- src/Utilities/ArrayReaders.f90 | 584 ++++---- src/Utilities/BlockParser.f90 | 232 ++-- src/Utilities/Budget.f90 | 496 +++---- src/Utilities/BudgetFileReader.f90 | 148 +-- src/Utilities/BudgetObject.f90 | 142 +- src/Utilities/BudgetTerm.f90 | 200 +-- src/Utilities/Constants.f90 | 265 ++-- src/Utilities/HashTable.f90 | 74 +- src/Utilities/HeadFileReader.f90 | 66 +- src/Utilities/Iunit.f90 | 70 +- src/Utilities/List.f90 | 150 +-- src/Utilities/ListReader.f90 | 423 +++--- src/Utilities/Memory/Memory.f90 | 84 +- src/Utilities/Memory/MemoryHelper.f90 | 84 +- src/Utilities/Memory/MemoryList.f90 | 16 +- src/Utilities/Memory/MemoryManager.f90 | 1175 +++++++++-------- src/Utilities/Memory/MemorySetHandler.f90 | 36 +- src/Utilities/Message.f90 | 401 +++--- src/Utilities/NameFile.f90 | 127 +- src/Utilities/Observation/Obs3.f90 | 314 ++--- src/Utilities/Observation/ObsContainer.f90 | 2 +- src/Utilities/Observation/ObsOutput.f90 | 16 +- src/Utilities/Observation/ObsOutputList.f90 | 34 +- src/Utilities/Observation/ObsUtility.f90 | 58 +- src/Utilities/Observation/Observe.f90 | 90 +- src/Utilities/OpenSpec.f90 | 10 +- src/Utilities/OutputControl/OutputControl.f90 | 236 ++-- .../OutputControl/OutputControlData.f90 | 252 ++-- .../OutputControl/PrintSaveManager.f90 | 222 ++-- src/Utilities/PackageBudget.f90 | 120 +- src/Utilities/Sim.f90 | 972 +++++++------- src/Utilities/SimVariables.f90 | 36 +- src/Utilities/SmoothingFunctions.f90 | 206 ++- src/Utilities/Sparse.f90 | 511 +++---- src/Utilities/StringList.f90 | 16 +- src/Utilities/Table.f90 | 270 ++-- src/Utilities/TableTerm.f90 | 104 +- src/Utilities/TimeSeries/TimeArray.f90 | 26 +- src/Utilities/TimeSeries/TimeArraySeries.f90 | 326 ++--- .../TimeSeries/TimeArraySeriesLink.f90 | 34 +- .../TimeSeries/TimeArraySeriesManager.f90 | 141 +- src/Utilities/TimeSeries/TimeSeries.f90 | 442 ++++--- .../TimeSeries/TimeSeriesFileList.f90 | 32 +- src/Utilities/TimeSeries/TimeSeriesLink.f90 | 20 +- .../TimeSeries/TimeSeriesManager.f90 | 473 +++---- src/Utilities/TimeSeries/TimeSeriesRecord.f90 | 6 +- src/Utilities/Timer.f90 | 192 +-- src/Utilities/VectorInt.f90 | 111 +- src/Utilities/comarg.f90 | 278 ++-- src/Utilities/compilerversion.F90 | 16 +- src/Utilities/genericutils.f90 | 170 +-- src/Utilities/kind.f90 | 93 +- src/Utilities/sort.f90 | 911 +++++++------ src/Utilities/version.f90 | 252 ++-- 55 files changed, 5993 insertions(+), 5930 deletions(-) diff --git a/src/Utilities/ArrayHandlers.f90 b/src/Utilities/ArrayHandlers.f90 index f2aa62a396c..7759fb1f9ab 100644 --- a/src/Utilities/ArrayHandlers.f90 +++ b/src/Utilities/ArrayHandlers.f90 @@ -8,7 +8,7 @@ module ArrayHandlersModule public :: ExpandArray, ExpandArrayWrapper, ExtendPtrArray public :: ifind public :: remove_character - + interface ExpandArrayWrapper module procedure expand_integer_wrapper end interface @@ -18,8 +18,8 @@ module ArrayHandlersModule ! IMPORTANT: Do not use pointers to elements of arrays when using ! ExpandArray to increase the array size! The locations of array ! elements in memory are changed when ExpandArray is invoked. - module procedure expand_integer, expand_double, & - expand_character !, expand_real + module procedure expand_integer, expand_double, & + expand_character !, expand_real end interface ExpandArray interface ExtendPtrArray @@ -70,11 +70,11 @@ subroutine expand_integer_wrapper(nsize, array, minvalue, loginc) if (loginc) then increment = int(log10(real(nsize, DP)), I4B) increment = int(DTEN**increment, I4B) - ! - ! -- increase increment by a multiplier and a value no - ! smaller than a default or specified minimum size + ! + ! -- increase increment by a multiplier and a value no + ! smaller than a default or specified minimum size else - increment = int(nsize * 0.2_DP) + increment = int(nsize * 0.2_DP) increment = max(minimum_increment, increment) end if ! @@ -97,7 +97,7 @@ subroutine expand_integer(array, increment) implicit none ! -- dummy integer(I4B), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment + integer(I4B), optional, intent(in) :: increment ! -- local integer(I4B) :: inclocal, isize, newsize integer(I4B), allocatable, dimension(:) :: array_temp @@ -107,20 +107,20 @@ subroutine expand_integer(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (allocated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize)) + allocate (array_temp(newsize)) array_temp(1:isize) = array - deallocate(array) + deallocate (array) call move_alloc(array_temp, array) else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! return end subroutine expand_integer @@ -129,7 +129,7 @@ subroutine expand_double(array, increment) implicit none ! -- dummy real(DP), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment + integer(I4B), optional, intent(in) :: increment ! -- local integer(I4B) :: inclocal, isize, newsize real(DP), allocatable, dimension(:) :: array_temp @@ -139,20 +139,20 @@ subroutine expand_double(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (allocated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize)) + allocate (array_temp(newsize)) array_temp(1:isize) = array - deallocate(array) + deallocate (array) call move_alloc(array_temp, array) else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! return end subroutine expand_double @@ -161,7 +161,7 @@ subroutine expand_character(array, increment) implicit none ! -- dummy character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), optional, intent(in) :: increment + integer(I4B), optional, intent(in) :: increment ! -- local character(len=LINELENGTH) :: line character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp @@ -172,13 +172,13 @@ subroutine expand_character(array, increment) ! -- check character length lenc = len(array) if (lenc > MAXCHARLEN) then - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Need to increase MAXCHARLEN' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Need to increase MAXCHARLEN' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) @@ -189,7 +189,7 @@ subroutine expand_character(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data @@ -198,22 +198,22 @@ subroutine expand_character(array, increment) if (allocated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(isize)) - do i=1,isize + allocate (array_temp(isize)) + do i = 1, isize array_temp(i) = array(i) - enddo - deallocate(array) - allocate(array(newsize)) - do i=1,isize + end do + deallocate (array) + allocate (array(newsize)) + do i = 1, isize array(i) = array_temp(i) - enddo - do i=isize+1,newsize + end do + do i = isize + 1, newsize array(i) = '' - enddo - deallocate(array_temp) + end do + deallocate (array_temp) else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! return end subroutine expand_character @@ -238,32 +238,32 @@ subroutine extend_double(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (associated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize), stat=istat, errmsg=ermsg) + allocate (array_temp(newsize), stat=istat, errmsg=ermsg) if (istat /= 0) goto 99 - do i=1,isize + do i = 1, isize array_temp(i) = array(i) - enddo - deallocate(array) + end do + deallocate (array) array => array_temp else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! ! -- normal return - return + return ! ! -- Error reporting 99 continue - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Could not increase array size' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Could not increase array size' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! @@ -272,11 +272,11 @@ subroutine extend_double(array, increment) call sim_message(ermsg) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) - + end subroutine extend_double subroutine extend_integer(array, increment) @@ -297,23 +297,23 @@ subroutine extend_integer(array, increment) inclocal = increment else inclocal = 1 - endif + end if ! ! -- increase size of array by inclocal, retaining ! contained data if (associated(array)) then isize = size(array) newsize = isize + inclocal - allocate(array_temp(newsize), stat=istat, errmsg=ermsg) + allocate (array_temp(newsize), stat=istat, errmsg=ermsg) if (istat /= 0) goto 99 - do i=1,isize + do i = 1, isize array_temp(i) = array(i) - enddo - deallocate(array) + end do + deallocate (array) array => array_temp else - allocate(array(inclocal)) - endif + allocate (array(inclocal)) + end if ! ! -- normal return return @@ -321,8 +321,8 @@ subroutine extend_integer(array, increment) ! -- Error reporting 99 continue - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Could not increase array size' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Could not increase array size' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! @@ -331,11 +331,11 @@ subroutine extend_integer(array, increment) call sim_message(ermsg) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) - + end subroutine extend_integer function ifind_character(array, str) @@ -350,12 +350,12 @@ function ifind_character(array, str) ! -- local integer(I4B) :: i ifind_character = -1 - findloop: do i=1,size(array) - if(array(i) == str) then + findloop: do i = 1, size(array) + if (array(i) == str) then ifind_character = i exit findloop - endif - enddo findloop + end if + end do findloop return end function ifind_character @@ -372,11 +372,11 @@ function ifind_integer(iarray, ival) integer(I4B) :: i ifind_integer = -1 findloop: do i = 1, size(iarray) - if(iarray(i) == ival) then + if (iarray(i) == ival) then ifind_integer = i exit findloop - endif - enddo findloop + end if + end do findloop return end function ifind_integer @@ -385,7 +385,7 @@ subroutine remove_character(array, ipos) implicit none ! -- dummy character(len=*), allocatable, intent(inout) :: array(:) - integer(I4B), intent(in) :: ipos + integer(I4B), intent(in) :: ipos ! -- local character(len=LINELENGTH) :: line character(len=MAXCHARLEN), allocatable, dimension(:) :: array_temp @@ -397,38 +397,38 @@ subroutine remove_character(array, ipos) lenc = len(array) if (lenc > MAXCHARLEN) then - write(line, '(a)') 'Error in ArrayHandlersModule: ' // & - 'Need to increase MAXCHARLEN' + write (line, '(a)') 'Error in ArrayHandlersModule: '// & + 'Need to increase MAXCHARLEN' call sim_message(line, iunit=iout, fmt=stdfmt) call sim_message(line, fmt=stdfmt) ! ! -- stop message - write(line, '(a)') 'Stopping...' + write (line, '(a)') 'Stopping...' call sim_message(line, iunit=iout) call sim_message(line) call stop_with_error(138) - endif + end if ! ! -- calculate sizes isize = size(array) newsize = isize - 1 ! ! -- copy array to array_temp - allocate(array_temp(isize)) + allocate (array_temp(isize)) do i = 1, isize array_temp(i) = array(i) - enddo + end do ! - deallocate(array) - allocate(array(newsize)) + deallocate (array) + allocate (array(newsize)) inew = 1 do i = 1, isize - if(i /= ipos) then + if (i /= ipos) then array(inew) = array_temp(i) inew = inew + 1 - endif - enddo - deallocate(array_temp) + end if + end do + deallocate (array_temp) ! return end subroutine remove_character diff --git a/src/Utilities/ArrayReaders.f90 b/src/Utilities/ArrayReaders.f90 index 17125833ea5..973e4d5087e 100644 --- a/src/Utilities/ArrayReaders.f90 +++ b/src/Utilities/ArrayReaders.f90 @@ -1,27 +1,27 @@ module ArrayReadersModule - - use ConstantsModule, only: DONE, LINELENGTH, LENBIGLINE, LENBOUNDNAME, & - NAMEDBOUNDFLAG, LINELENGTH, DZERO, MAXCHARLEN, & - DZERO + + use ConstantsModule, only: DONE, LINELENGTH, LENBIGLINE, LENBOUNDNAME, & + NAMEDBOUNDFLAG, LINELENGTH, DZERO, MAXCHARLEN, & + DZERO use InputOutputModule, only: openfile, u8rdcom, urword, ucolno, ulaprw, & BuildFixedFormat, BuildFloatFormat, & BuildIntFormat - use KindModule, only: DP, I4B - use OpenSpecModule, only: ACCESS, FORM - use SimModule, only: store_error, store_error_unit + use KindModule, only: DP, I4B + use OpenSpecModule, only: ACCESS, FORM + use SimModule, only: store_error, store_error_unit implicit none private public :: ReadArray - + interface ReadArray module procedure read_array_int1d, read_array_int2d, read_array_int3d, & - read_array_dbl1d, read_array_dbl2d, read_array_dbl3d, & - read_array_dbl1d_layered, read_array_int1d_layered, & - read_array_dbl3d_all, read_array_int3d_all + read_array_dbl1d, read_array_dbl2d, read_array_dbl3d, & + read_array_dbl1d_layered, read_array_int1d_layered, & + read_array_dbl3d_all, read_array_int3d_all end interface ReadArray - + ! Integer readers ! read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) ! read_array_int1d_layered(iu, iarr, aname, ndim, ncol, nrow, nlay, nval, iout, k1, k2) @@ -35,19 +35,19 @@ module ArrayReadersModule ! read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, k1, k2) ! read_array_dbl3d_all(iu, darr, aname, ndim, nvals, iout) - + contains ! -- Procedures that are part of ReadArray interface (integer data) subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj integer(I4B), dimension(jj), intent(inout) :: iarr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: iclose, iconst, iprn, j, locat, ncpl, ndig integer(I4B) :: nval, nvalt @@ -57,8 +57,8 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',i0, ' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',i0) +2 format(/, 1x, a, ' = ', i0, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', i0) ! ! -- Read array control record. call read_control_int(iu, iout, aname, locat, iconst, iclose, iprn) @@ -66,60 +66,61 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do j=1,jj + do j = 1, jj iarr(j) = iconst - enddo + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), iconst, k + write (iout, 2) trim(aname), iconst, k else - write(iout,3) trim(aname), iconst - endif - endif + write (iout, 3) trim(aname), iconst + end if + end if elseif (locat > 0) then ! -- Read data as text - read(locat,*,iostat=istat,iomsg=ermsgr) (iarr(j),j=1,jj) + read (locat, *, iostat=istat, iomsg=ermsgr) (iarr(j), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj + end if + do j = 1, jj iarr(j) = iarr(j) * iconst - enddo + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat nvalt = 0 do call read_binary_header(locat, iout, aname, nval) - read(locat,iostat=istat,iomsg=ermsgr) (iarr(j), j=nvalt+1, nvalt+nval) + read (locat, iostat=istat, iomsg=ermsgr) & + (iarr(j), j=nvalt + 1, nvalt + nval) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if nvalt = nvalt + nval if (nvalt == size(iarr)) exit - enddo + end do ! ! -- multiply array by constant - do j=1,jj + do j = 1, jj iarr(j) = iarr(j) * iconst - enddo + end do ! ! -- close the file if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -127,19 +128,19 @@ subroutine read_array_int1d(iu, iarr, aname, ndim, jj, iout, k) call build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_int(iarr, aname, iout, jj, 1, k, prfmt, ncpl, ndig, & prowcolnum) - endif + end if ! return end subroutine read_array_int1d subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj, ii - integer(I4B), dimension(jj,ii), intent(inout) :: iarr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj, ii + integer(I4B), dimension(jj, ii), intent(inout) :: iarr + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: i, iclose, iconst, iprn, j, locat, ncpl, ndig integer(I4B) :: nval @@ -149,8 +150,8 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',i0, ' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',i0) +2 format(/, 1x, a, ' = ', i0, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', i0) ! ! -- Read array control record. call read_control_int(iu, iout, aname, locat, iconst, iclose, iprn) @@ -158,57 +159,57 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do i=1,ii - do j=1,jj - iarr(j,i) = iconst - enddo - enddo + do i = 1, ii + do j = 1, jj + iarr(j, i) = iconst + end do + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), iconst, k + write (iout, 2) trim(aname), iconst, k else - write(iout,3) trim(aname), iconst - endif - endif + write (iout, 3) trim(aname), iconst + end if + end if elseif (locat > 0) then ! -- Read data as text - do i=1,ii - read(locat,*,iostat=istat,iomsg=ermsgr) (iarr(j,i),j=1,jj) + do i = 1, ii + read (locat, *, iostat=istat, iomsg=ermsgr) (iarr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj - iarr(j,i) = iarr(j,i) * iconst - enddo - enddo + end if + do j = 1, jj + iarr(j, i) = iarr(j, i) * iconst + end do + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat call read_binary_header(locat, iout, aname, nval) - do i=1,ii - read(locat,iostat=istat,iomsg=ermsgr) (iarr(j,i),j=1,jj) + do i = 1, ii + read (locat, iostat=istat, iomsg=ermsgr) (iarr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj - iarr(j,i) = iarr(j,i) * iconst - enddo - enddo + end if + do j = 1, jj + iarr(j, i) = iarr(j, i) * iconst + end do + end do if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -216,11 +217,11 @@ subroutine read_array_int2d(iu, iarr, aname, ndim, jj, ii, iout, k) call build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_int(iarr, aname, iout, jj, ii, k, prfmt, ncpl, & ndig, prowcolnum) - endif + end if ! return end subroutine read_array_int2d - + subroutine read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, & k1, k2) ! ****************************************************************************** @@ -237,7 +238,7 @@ subroutine read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, & integer(I4B), intent(in) :: nrow integer(I4B), intent(in) :: nlay integer(I4B), intent(in) :: k1, k2 - integer(I4B), dimension(ncol,nrow,nlay), intent(inout) :: iarr + integer(I4B), dimension(ncol, nrow, nlay), intent(inout) :: iarr character(len=*), intent(in) :: aname ! -- local integer(I4B) :: k, kk @@ -247,12 +248,12 @@ subroutine read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, & kk = 1 else kk = k - endif - call read_array_int2d(iu, iarr(:,:,kk), aname, ndim, ncol, nrow, iout, k) - enddo + end if + call read_array_int2d(iu, iarr(:, :, kk), aname, ndim, ncol, nrow, iout, k) + end do return end subroutine read_array_int3d - + subroutine read_array_int3d_all(iu, iarr, aname, ndim, nvals, iout) ! ****************************************************************************** ! Read three-dimensional integer array, all at once. @@ -264,7 +265,7 @@ subroutine read_array_int3d_all(iu, iarr, aname, ndim, nvals, iout) integer(I4B), intent(in) :: iout integer(I4B), intent(in) :: ndim integer(I4B), intent(in) :: nvals - integer(I4B), dimension(nvals,1,1), intent(inout) :: iarr + integer(I4B), dimension(nvals, 1, 1), intent(inout) :: iarr character(len=*), intent(in) :: aname ! -- local ! ------------------------------------------------------------------------------ @@ -277,29 +278,29 @@ end subroutine read_array_int3d_all subroutine read_array_int1d_layered(iu, iarr, aname, ndim, ncol, nrow, & nlay, nval, iout, k1, k2) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: ncol, nrow, nlay, nval + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: ncol, nrow, nlay, nval integer(I4B), dimension(nval), intent(inout) :: iarr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k1, k2 + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k1, k2 ! -- local ! call read_array_int3d(iu, iarr, aname, ndim, ncol, nrow, nlay, iout, k1, k2) ! return end subroutine read_array_int1d_layered - + ! -- Procedures that are part of ReadArray interface (floating-point data) - + subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj real(DP), dimension(jj), intent(inout) :: darr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: j, iclose, iprn, locat, ncpl, ndig real(DP) :: cnstnt @@ -310,8 +311,8 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',g14.7,' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',g14.7) +2 format(/, 1x, a, ' = ', g14.7, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', g14.7) ! ! -- Read array control record. call read_control_dbl(iu, iout, aname, locat, cnstnt, iclose, iprn) @@ -319,60 +320,61 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do j=1,jj + do j = 1, jj darr(j) = cnstnt - enddo + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), cnstnt, k + write (iout, 2) trim(aname), cnstnt, k else - write(iout,3) trim(aname), cnstnt - endif - endif + write (iout, 3) trim(aname), cnstnt + end if + end if elseif (locat > 0) then ! -- Read data as text - read(locat,*,iostat=istat,iomsg=ermsgr) (darr(j),j=1,jj) + read (locat, *, iostat=istat, iomsg=ermsgr) (darr(j), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj + end if + do j = 1, jj darr(j) = darr(j) * cnstnt - enddo + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat nvalt = 0 do call read_binary_header(locat, iout, aname, nval) - read(locat,iostat=istat,iomsg=ermsgr) (darr(j), j=nvalt+1, nvalt+nval) + read (locat, iostat=istat, iomsg=ermsgr) & + (darr(j), j=nvalt + 1, nvalt + nval) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if nvalt = nvalt + nval if (nvalt == size(darr)) exit - enddo + end do ! ! -- multiply entire array by constant do j = 1, jj darr(j) = darr(j) * cnstnt - enddo + end do ! ! -- close the file if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -380,19 +382,19 @@ subroutine read_array_dbl1d(iu, darr, aname, ndim, jj, iout, k) call build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_dbl(darr, aname, iout, jj, 1, k, prfmt, ncpl, ndig, & prowcolnum) - endif + end if ! return end subroutine read_array_dbl1d subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: jj, ii - real(DP), dimension(jj,ii), intent(inout) :: darr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k ! layer number; 0 to not print + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: jj, ii + real(DP), dimension(jj, ii), intent(inout) :: darr + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k ! layer number; 0 to not print ! -- local integer(I4B) :: i, iclose, iprn, j, locat, ncpl, ndig integer(I4B) :: nval @@ -403,8 +405,8 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) character(len=30) :: arrname character(len=MAXCHARLEN) :: ermsg, ermsgr ! -- formats - 2 format(/,1x,a,' = ',g14.7, ' FOR LAYER ',i0) - 3 format(/,1x,a,' = ',g14.7) +2 format(/, 1x, a, ' = ', g14.7, ' FOR LAYER ', i0) +3 format(/, 1x, a, ' = ', g14.7) ! ! -- Read array control record. call read_control_dbl(iu, iout, aname, locat, cnstnt, iclose, iprn) @@ -412,57 +414,57 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) ! -- Read or assign array data. if (locat == 0) then ! -- Assign constant - do i=1,ii - do j=1,jj - darr(j,i) = cnstnt - enddo - enddo + do i = 1, ii + do j = 1, jj + darr(j, i) = cnstnt + end do + end do if (iout > 0) then if (k > 0) then - write(iout,2) trim(aname), cnstnt, k + write (iout, 2) trim(aname), cnstnt, k else - write(iout,3) trim(aname), cnstnt - endif - endif + write (iout, 3) trim(aname), cnstnt + end if + end if elseif (locat > 0) then ! -- Read data as text - do i=1,ii - read(locat,*,iostat=istat,iomsg=ermsgr) (darr(j,i),j=1,jj) + do i = 1, ii + read (locat, *, iostat=istat, iomsg=ermsgr) (darr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif - do j=1,jj - darr(j,i) = darr(j,i) * cnstnt - enddo - enddo + end if + do j = 1, jj + darr(j, i) = darr(j, i) * cnstnt + end do + end do if (iclose == 1) then - close(locat) - endif + close (locat) + end if else ! -- Read data as binary locat = -locat call read_binary_header(locat, iout, aname, nval) do i = 1, ii - read(locat,iostat=istat,iomsg=ermsgr) (darr(j,i), j = 1, jj) + read (locat, iostat=istat, iomsg=ermsgr) (darr(j, i), j=1, jj) if (istat /= 0) then arrname = adjustl(aname) - ermsg = 'Error reading data for array: ' // trim(arrname) + ermsg = 'Error reading data for array: '//trim(arrname) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if do j = 1, jj - darr(j,i) = darr(j,i) * cnstnt - enddo - enddo + darr(j, i) = darr(j, i) * cnstnt + end do + end do if (iclose == 1) then - close(locat) - endif - endif + close (locat) + end if + end if ! ! -- Print array if requested. if (iprn >= 0 .and. locat /= 0) then @@ -470,11 +472,11 @@ subroutine read_array_dbl2d(iu, darr, aname, ndim, jj, ii, iout, k) call build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) call print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, ncpl, & ndig, prowcolnum) - endif + end if ! return end subroutine read_array_dbl2d - + subroutine read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, & k1, k2) ! ****************************************************************************** @@ -491,24 +493,24 @@ subroutine read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, & integer(I4B), intent(in) :: nrow integer(I4B), intent(in) :: nlay integer(I4B), intent(in) :: k1, k2 - real(DP), dimension(ncol,nrow,nlay), intent(inout) :: darr + real(DP), dimension(ncol, nrow, nlay), intent(inout) :: darr character(len=*), intent(in) :: aname ! -- local integer(I4B) :: k, kk ! ------------------------------------------------------------------------------ ! - do k=k1,k2 + do k = k1, k2 if (k <= 0) then kk = 1 else kk = k - endif - call read_array_dbl2d(iu, darr(:,:,kk), aname, ndim, ncol, nrow, iout, k) - enddo + end if + call read_array_dbl2d(iu, darr(:, :, kk), aname, ndim, ncol, nrow, iout, k) + end do ! return end subroutine read_array_dbl3d - + subroutine read_array_dbl3d_all(iu, darr, aname, ndim, nvals, iout) ! ****************************************************************************** ! Read three-dimensional real array, consisting of one or more 2d arrays with @@ -521,7 +523,7 @@ subroutine read_array_dbl3d_all(iu, darr, aname, ndim, nvals, iout) integer(I4B), intent(in) :: iout integer(I4B), intent(in) :: ndim integer(I4B), intent(in) :: nvals - real(DP), dimension(nvals,1,1), intent(inout) :: darr + real(DP), dimension(nvals, 1, 1), intent(inout) :: darr character(len=*), intent(in) :: aname ! -- local ! ------------------------------------------------------------------------------ @@ -534,12 +536,12 @@ end subroutine read_array_dbl3d_all subroutine read_array_dbl1d_layered(iu, darr, aname, ndim, ncol, nrow, & nlay, nval, iout, k1, k2) ! -- dummy - integer(I4B), intent(in) :: iu, iout - integer(I4B), intent(in) :: ncol, nrow, nlay, nval + integer(I4B), intent(in) :: iu, iout + integer(I4B), intent(in) :: ncol, nrow, nlay, nval real(DP), dimension(nval), intent(inout) :: darr - character(len=*), intent(in) :: aname - integer(I4B), intent(in) :: ndim ! dis%ndim - integer(I4B), intent(in) :: k1, k2 + character(len=*), intent(in) :: aname + integer(I4B), intent(in) :: ndim ! dis%ndim + integer(I4B), intent(in) :: k1, k2 ! -- local ! call read_array_dbl3d(iu, darr, aname, ndim, ncol, nrow, nlay, iout, k1, k2) @@ -548,23 +550,23 @@ subroutine read_array_dbl1d_layered(iu, darr, aname, ndim, ncol, nrow, & end subroutine read_array_dbl1d_layered ! -- Utility procedures - + subroutine read_control_int(iu, iout, aname, locat, iconst, & iclose, iprn) ! Read an array-control record for an integer array. ! Open an input file if needed. ! If CONSTANT is specified in input, locat is returned as 0. - ! If (BINARY) is specified, locat is returned as the negative of + ! If (BINARY) is specified, locat is returned as the negative of ! the unit number opened for binary read. ! If OPEN/CLOSE is specified, iclose is returned as 1, otherwise 0. ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: aname - integer(I4B), intent(out) :: locat - integer(I4B), intent(out) :: iconst - integer(I4B), intent(out) :: iclose - integer(I4B), intent(out) :: iprn + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: aname + integer(I4B), intent(out) :: locat + integer(I4B), intent(out) :: iconst + integer(I4B), intent(out) :: iclose + integer(I4B), intent(out) :: iprn ! -- local integer(I4B) :: icol, icol1, istart, istop, n real(DP) :: r @@ -574,23 +576,23 @@ subroutine read_control_int(iu, iout, aname, locat, iconst, & call read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) if (locat == 0) then ! CONSTANT was found -- read value and return - call urword(line,icol,istart,istop,2,iconst,r,iout,iu) + call urword(line, icol, istart, istop, 2, iconst, r, iout, iu) iprn = -1 return - endif + end if icol1 = icol iconst = 1 ! ! -- Read FACTOR option from array control record. call urword(line, icol, istart, istop, 1, n, r, iout, iu) if (line(istart:istop) == 'FACTOR') then - call urword(line,icol,istart,istop,2,iconst,r,iout,iu) + call urword(line, icol, istart, istop, 2, iconst, r, iout, iu) if (iconst == 0) iconst = 1 else icol = icol1 - endif + end if ! - ! -- Read (BINARY) and IPRN options from array control record, + ! -- Read (BINARY) and IPRN options from array control record, ! and open an OPEN/CLOSE file if specified. call read_control_2(iu, iout, fname, line, icol, locat, iclose, iprn) ! @@ -602,17 +604,17 @@ subroutine read_control_dbl(iu, iout, aname, locat, cnstnt, & ! Read an array-control record for a double-precision array. ! Open an input file if needed. ! If CONSTANT is specified in input, locat is returned as 0. - ! If (BINARY) is specified, locat is returned as the negative of + ! If (BINARY) is specified, locat is returned as the negative of ! the unit number opened for binary read. ! If OPEN/CLOSE is specified, iclose is returned as 1, otherwise 0. ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: aname - integer(I4B), intent(out) :: locat - real(DP), intent(out) :: cnstnt - integer(I4B), intent(out) :: iclose - integer(I4B), intent(out) :: iprn + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: aname + integer(I4B), intent(out) :: locat + real(DP), intent(out) :: cnstnt + integer(I4B), intent(out) :: iclose + integer(I4B), intent(out) :: iprn ! ! -- local integer(I4B) :: icol, icol1, istart, istop, n @@ -623,41 +625,41 @@ subroutine read_control_dbl(iu, iout, aname, locat, cnstnt, & call read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) if (locat == 0) then ! CONSTANT was found -- read value and return - call urword(line,icol,istart,istop,3,n,cnstnt,iout,iu) + call urword(line, icol, istart, istop, 3, n, cnstnt, iout, iu) iprn = -1 return - endif + end if icol1 = icol cnstnt = DONE ! ! -- Read FACTOR option from array control record. call urword(line, icol, istart, istop, 1, n, r, iout, iu) if (line(istart:istop) == 'FACTOR') then - call urword(line,icol,istart,istop,3,n,cnstnt,iout,iu) + call urword(line, icol, istart, istop, 3, n, cnstnt, iout, iu) if (cnstnt == DZERO) cnstnt = DONE else icol = icol1 - endif + end if ! - ! -- Read (BINARY) and IPRN options from array control record, + ! -- Read (BINARY) and IPRN options from array control record, ! and open an OPEN/CLOSE file if specified. call read_control_2(iu, iout, fname, line, icol, locat, iclose, iprn) ! return end subroutine read_control_dbl - + subroutine read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) ! -- Read CONSTANT, INTERNAL, or OPEN/CLOSE from array control record. ! -- dummy - integer(I4B), intent(in) :: iu - integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: aname - integer(I4B), intent(out) :: locat - integer(I4B), intent(out) :: iclose + integer(I4B), intent(in) :: iu + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: aname + integer(I4B), intent(out) :: locat + integer(I4B), intent(out) :: iclose character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: icol + integer(I4B), intent(inout) :: icol character(len=*), intent(inout) :: fname - + ! -- local integer(I4B) :: istart, istop, n integer(I4B) :: ierr @@ -665,43 +667,43 @@ subroutine read_control_1(iu, iout, aname, locat, iclose, line, icol, fname) character(len=MAXCHARLEN) :: ermsg ! ! -- Read array control record. - call u8rdcom(iu,iout,line,ierr) + call u8rdcom(iu, iout, line, ierr) ! iclose = 0 icol = 1 ! -- Read first token of array control record. - call urword(line,icol,istart,istop,1,n,r,iout,iu) - if (line(istart:istop).eq.'CONSTANT') then + call urword(line, icol, istart, istop, 1, n, r, iout, iu) + if (line(istart:istop) .eq. 'CONSTANT') then locat = 0 - elseif (line(istart:istop).eq.'INTERNAL') then + elseif (line(istart:istop) .eq. 'INTERNAL') then locat = iu - elseif (line(istart:istop).eq.'OPEN/CLOSE') then - call urword(line,icol,istart,istop,0,n,r,iout,iu) + elseif (line(istart:istop) .eq. 'OPEN/CLOSE') then + call urword(line, icol, istart, istop, 0, n, r, iout, iu) fname = line(istart:istop) locat = -1 iclose = 1 else - write(ermsg, *) 'ERROR READING CONTROL RECORD FOR ' // & - trim(adjustl(aname)) + write (ermsg, *) 'ERROR READING CONTROL RECORD FOR '// & + trim(adjustl(aname)) call store_error(ermsg) call store_error(trim(adjustl(line))) - write(ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.' + write (ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.' call store_error(ermsg) call store_error_unit(iu) - endif + end if ! return end subroutine read_control_1 - + subroutine read_control_2(iu, iout, fname, line, icol, & locat, iclose, iprn) - ! -- Read (BINARY) and IPRN options from array control record, + ! -- Read (BINARY) and IPRN options from array control record, ! and open an OPEN/CLOSE file if specified. ! -- dummy - integer(I4B), intent(in) :: iu, iout, iclose - character(len=*), intent(in) :: fname + integer(I4B), intent(in) :: iu, iout, iclose + character(len=*), intent(in) :: fname character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: icol, iprn, locat + integer(I4B), intent(inout) :: icol, iprn, locat ! -- local integer(I4B) :: i, n, istart, istop, lenkey real(DP) :: r @@ -709,38 +711,38 @@ subroutine read_control_2(iu, iout, fname, line, icol, & character(len=LENBIGLINE) :: ermsg logical :: binary ! - iprn = -1 ! Printing is turned off by default + iprn = -1 ! Printing is turned off by default binary = .false. ! - if (locat.ne.0) then + if (locat .ne. 0) then ! -- CONSTANT has not been specified; array data will be read. ! -- Read at most two options. - do i=1,2 - call urword(line,icol,istart,istop,1,n,r,iout,iu) + do i = 1, 2 + call urword(line, icol, istart, istop, 1, n, r, iout, iu) keyword = line(istart:istop) lenkey = len_trim(keyword) select case (keyword) case ('(BINARY)') if (iclose == 0) then - ermsg = '"(BINARY)" option for array input is valid only if' // & + ermsg = '"(BINARY)" option for array input is valid only if'// & ' OPEN/CLOSE is also specified.' call store_error(ermsg) call store_error_unit(iu) - endif + end if binary = .true. case ('IPRN') ! -- Read IPRN value - call urword(line,icol,istart,istop,2,iprn,r,iout,iu) + call urword(line, icol, istart, istop, 2, iprn, r, iout, iu) exit case ('') exit case default ermsg = 'Invalid option found in array-control record: "' & - // trim(keyword) // '"' + //trim(keyword)//'"' call store_error(ermsg) call store_error_unit(iu) end select - enddo + end do ! if (iclose == 0) then ! -- Array data will be read from current input file. @@ -753,9 +755,9 @@ subroutine read_control_2(iu, iout, fname, line, icol, & locat = -locat else call openfile(locat, iout, fname, 'OPEN/CLOSE') - endif - endif - endif + end if + end if + end if ! return end subroutine read_control_2 @@ -763,17 +765,17 @@ end subroutine read_control_2 subroutine build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) ! -- Build a print format for integers based on IPRN. ! -- dummy - integer(I4B), intent(inout) :: iprn + integer(I4B), intent(inout) :: iprn character(len=*), intent(out) :: prfmt - logical, intent(in) :: prowcolnum - integer(I4B), intent(out) :: ncpl, ndig + logical, intent(in) :: prowcolnum + integer(I4B), intent(out) :: ncpl, ndig ! -- local integer(I4B) :: nwidp ! if (iprn < 0) then prfmt = '' return - endif + end if ! if (iprn > 9) iprn = 0 ! @@ -815,14 +817,14 @@ subroutine build_format_int(iprn, prfmt, prowcolnum, ncpl, ndig) ! return end subroutine build_format_int - + subroutine build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) ! -- Build a print format for reals based on IPRN. ! -- dummy - integer(I4B), intent(inout) :: iprn + integer(I4B), intent(inout) :: iprn character(len=*), intent(out) :: prfmt - logical, intent(in) :: prowcolnum - integer(I4B), intent(out) :: ncpl, ndig + logical, intent(in) :: prowcolnum + integer(I4B), intent(out) :: ncpl, ndig ! -- local integer(I4B) :: nwidp character(len=1) :: editdesc @@ -830,7 +832,7 @@ subroutine build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) if (iprn < 0) then prfmt = '' return - endif + end if ! if (iprn > 21) iprn = 0 ! @@ -951,7 +953,7 @@ subroutine build_format_dbl(iprn, prfmt, prowcolnum, ncpl, ndig) call BuildFixedFormat(ncpl, nwidp, ndig, prfmt, prowcolnum) else call BuildFloatFormat(ncpl, nwidp, ndig, editdesc, prfmt, prowcolnum) - endif + end if ! ndig = nwidp + 1 ! @@ -961,28 +963,28 @@ end subroutine build_format_dbl subroutine print_array_int(iarr, aname, iout, jj, ii, k, prfmt, & ncpl, ndig, prowcolnum) ! -- dummy - integer(I4B), intent(in) :: iout, jj, ii, k - integer(I4B), intent(in) :: ncpl ! # values to print per line - integer(I4B), intent(in) :: ndig ! # characters in each field - integer(I4B), dimension(jj,ii), intent(in) :: iarr ! Integer array to be printed - character(len=*), intent(in) :: aname ! Array name - character(len=*), intent(in) :: prfmt ! Print format, no row # - logical, intent(in) :: prowcolnum ! Print row & column numbers + integer(I4B), intent(in) :: iout, jj, ii, k + integer(I4B), intent(in) :: ncpl ! # values to print per line + integer(I4B), intent(in) :: ndig ! # characters in each field + integer(I4B), dimension(jj, ii), intent(in) :: iarr ! Integer array to be printed + character(len=*), intent(in) :: aname ! Array name + character(len=*), intent(in) :: prfmt ! Print format, no row # + logical, intent(in) :: prowcolnum ! Print row & column numbers ! -- local integer(I4B) :: i, j character(len=MAXCHARLEN) :: ermsg ! -- formats - 2 format(/,1x,a,1x,'FOR LAYER ',i0) - 3 format(/,1x,a) +2 format(/, 1x, a, 1x, 'FOR LAYER ', i0) +3 format(/, 1x, a) ! if (iout <= 0) return ! ! -- Write name of array if (k > 0) then - write(iout,2)trim(aname),k + write (iout, 2) trim(aname), k else - write(iout,3)trim(aname) - endif + write (iout, 3) trim(aname) + end if ! ! -- Write array if (prowcolnum) then @@ -990,19 +992,19 @@ subroutine print_array_int(iarr, aname, iout, jj, ii, k, prfmt, & call ucolno(1, jj, 4, ncpl, ndig, iout) ! ! -- Write array values, including row numbers - do i=1,ii - write(iout, prfmt) i, (iarr(j,i),j=1,jj) - enddo + do i = 1, ii + write (iout, prfmt) i, (iarr(j, i), j=1, jj) + end do else if (ii > 1) then - ermsg = 'Program error printing array ' // trim(aname) // & + ermsg = 'Program error printing array '//trim(aname)// & ': ii > 1 when prowcolnum is false.' call store_error(ermsg, terminate=.TRUE.) - endif + end if ! ! -- Write array values, without row numbers - write(iout, prfmt) (iarr(j,1),j=1,jj) - endif + write (iout, prfmt) (iarr(j, 1), j=1, jj) + end if ! return end subroutine print_array_int @@ -1010,28 +1012,28 @@ end subroutine print_array_int subroutine print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, & ncpl, ndig, prowcolnum) ! -- dummy - integer(I4B), intent(in) :: iout, jj, ii, k - integer(I4B), intent(in) :: ncpl ! # values to print per line - integer(I4B), intent(in) :: ndig ! # characters in each field - real(DP), dimension(jj,ii), intent(in) :: darr ! Real array to be printed - character(len=*), intent(in) :: aname ! Array name - character(len=*), intent(in) :: prfmt ! Print format, no row # - logical, intent(in) :: prowcolnum ! Print row & column numbers + integer(I4B), intent(in) :: iout, jj, ii, k + integer(I4B), intent(in) :: ncpl ! # values to print per line + integer(I4B), intent(in) :: ndig ! # characters in each field + real(DP), dimension(jj, ii), intent(in) :: darr ! Real array to be printed + character(len=*), intent(in) :: aname ! Array name + character(len=*), intent(in) :: prfmt ! Print format, no row # + logical, intent(in) :: prowcolnum ! Print row & column numbers ! -- local integer(I4B) :: i, j character(len=MAXCHARLEN) :: ermsg ! -- formats - 2 format(/,1x,a,1x,'FOR LAYER ',i0) - 3 format(/,1x,a) +2 format(/, 1x, a, 1x, 'FOR LAYER ', i0) +3 format(/, 1x, a) ! if (iout <= 0) return ! ! -- Write name of array if (k > 0) then - write(iout,2)trim(aname),k + write (iout, 2) trim(aname), k else - write(iout,3)trim(aname) - endif + write (iout, 3) trim(aname) + end if ! ! -- Write array if (prowcolnum) then @@ -1039,19 +1041,19 @@ subroutine print_array_dbl(darr, aname, iout, jj, ii, k, prfmt, & call ucolno(1, jj, 4, ncpl, ndig, iout) ! ! -- Write array values, including row numbers - do i=1,ii - write(iout, prfmt) i, (darr(j,i),j=1,jj) - enddo + do i = 1, ii + write (iout, prfmt) i, (darr(j, i), j=1, jj) + end do else if (ii > 1) then - ermsg = 'Program error printing array ' // trim(aname) // & + ermsg = 'Program error printing array '//trim(aname)// & ': ii > 1 when prowcolnum is false.' call store_error(ermsg, terminate=.TRUE.) - endif + end if ! ! -- Write array values, without row numbers - write(iout, prfmt) (darr(j,1),j=1,jj) - endif + write (iout, prfmt) (darr(j, 1), j=1, jj) + end if ! return end subroutine print_array_dbl @@ -1076,21 +1078,21 @@ subroutine read_binary_header(locat, iout, arrname, nval) &/,4X,'MSIZE 1: ',I0,' MSIZE 2: ',I0,' MSIZE 3: ',I0)" ! ! -- Read the header line from the binary file - read(locat, iostat=istat, iomsg=ermsgr) kstp, kper, pertim, totim, text, & + read (locat, iostat=istat, iomsg=ermsgr) kstp, kper, pertim, totim, text, & m1, m2, m3 ! ! -- Check for errors if (istat /= 0) then - ermsg = 'Error reading data for array: ' // adjustl(trim(arrname)) + ermsg = 'Error reading data for array: '//adjustl(trim(arrname)) call store_error(ermsg) call store_error(ermsgr) call store_error_unit(locat) - endif + end if ! ! -- Write message about the binary header if (iout > 0) then - write(iout, fmthdr) kstp, kper, pertim, totim, text, m1, m2, m3 - endif + write (iout, fmthdr) kstp, kper, pertim, totim, text, m1, m2, m3 + end if ! ! -- Assign the number of values that follow the header nval = m1 * m2 @@ -1098,5 +1100,5 @@ subroutine read_binary_header(locat, iout, arrname, nval) ! -- return return end subroutine read_binary_header - + end module ArrayReadersModule diff --git a/src/Utilities/BlockParser.f90 b/src/Utilities/BlockParser.f90 index eb29c678af0..2cc5159db58 100644 --- a/src/Utilities/BlockParser.f90 +++ b/src/Utilities/BlockParser.f90 @@ -5,31 +5,31 @@ !! !< module BlockParserModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENHUGELINE, LINELENGTH, MAXCHARLEN - use VersionModule, only: IDEVELOPMODE - use InputOutputModule, only: uget_block, uget_any_block, uterminate_block, & - u9rdcom, urword, upcase - use SimModule, only: store_error, store_error_unit + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENHUGELINE, LINELENGTH, MAXCHARLEN + use VersionModule, only: IDEVELOPMODE + use InputOutputModule, only: uget_block, uget_any_block, uterminate_block, & + u9rdcom, urword, upcase + use SimModule, only: store_error, store_error_unit use SimVariablesModule, only: errmsg - + implicit none - + private public :: BlockParserType - + type :: BlockParserType - integer(I4B), public :: iuactive !< flag indicating if a file unit is active, variable is not used internally - integer(I4B), private :: inunit !< file unit number - integer(I4B), private :: iuext !< external file unit number - integer(I4B), private :: iout !< listing file unit number - integer(I4B), private :: linesRead !< number of lines read - integer(I4B), private :: lloc !< line location counter - character(len=LINELENGTH), private :: blockName !< block name - character(len=LINELENGTH), private :: blockNameFound !< block name found - character(len=LENHUGELINE), private :: laststring !< last string read - character(len=:), allocatable, private :: line !< current line + integer(I4B), public :: iuactive !< flag indicating if a file unit is active, variable is not used internally + integer(I4B), private :: inunit !< file unit number + integer(I4B), private :: iuext !< external file unit number + integer(I4B), private :: iout !< listing file unit number + integer(I4B), private :: linesRead !< number of lines read + integer(I4B), private :: lloc !< line location counter + character(len=LINELENGTH), private :: blockName !< block name + character(len=LINELENGTH), private :: blockNameFound !< block name found + character(len=LENHUGELINE), private :: laststring !< last string read + character(len=:), allocatable, private :: line !< current line contains procedure, public :: Initialize procedure, public :: Clear @@ -49,7 +49,7 @@ module BlockParserModule procedure, public :: DevOpt procedure, private :: ReadScalarError end type BlockParserType - + contains !> @ brief Initialize the block parser @@ -59,9 +59,9 @@ module BlockParserModule !< subroutine Initialize(this, inunit, iout) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - integer(I4B), intent(in) :: inunit !< input file unit number - integer(I4B), intent(in) :: iout !< listing file unit number + class(BlockParserType), intent(inout) :: this !< BlockParserType object + integer(I4B), intent(in) :: inunit !< input file unit number + integer(I4B), intent(in) :: iout !< listing file unit number ! ! -- initialize values this%inunit = inunit @@ -74,7 +74,7 @@ subroutine Initialize(this, inunit, iout) ! -- return return end subroutine Initialize - + !> @ brief Close the block parser !! !! Method to clear the block parser, which closes file(s) and clears member @@ -83,24 +83,24 @@ end subroutine Initialize !< subroutine Clear(this) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables logical :: lop ! ! Close any connected files if (this%inunit > 0) then - inquire(unit=this%inunit, opened=lop) + inquire (unit=this%inunit, opened=lop) if (lop) then - close(this%inunit) - endif - endif + close (this%inunit) + end if + end if ! if (this%iuext /= this%inunit .and. this%iuext > 0) then - inquire(unit=this%iuext, opened=lop) + inquire (unit=this%iuext, opened=lop) if (lop) then - close(this%iuext) - endif - endif + close (this%iuext) + end if + end if ! ! Clear all member variables this%inunit = 0 @@ -111,12 +111,12 @@ subroutine Clear(this) this%linesRead = 0 this%blockName = '' this%line = '' - deallocate(this%line) + deallocate (this%line) ! ! -- return return end subroutine Clear - + !> @ brief Get block !! !! Method to get the block from a file. The file is read until the blockname @@ -126,13 +126,13 @@ end subroutine Clear subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & blockRequired, blockNameFound) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(in) :: blockName !< block name to search for - logical, intent(out) :: isFound !< boolean indicating if the block name was found - integer(I4B), intent(out) :: ierr !< return error code, 0 indicates block was found - logical, intent(in), optional :: supportOpenClose !< boolean indicating if the block supports open/close, default false - logical, intent(in), optional :: blockRequired !< boolean indicating if the block is required, default true - character(len=*), intent(inout), optional :: blockNameFound !< optional return value of block name found + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(in) :: blockName !< block name to search for + logical, intent(out) :: isFound !< boolean indicating if the block name was found + integer(I4B), intent(out) :: ierr !< return error code, 0 indicates block was found + logical, intent(in), optional :: supportOpenClose !< boolean indicating if the block supports open/close, default false + logical, intent(in), optional :: blockRequired !< boolean indicating if the block is required, default true + character(len=*), intent(inout), optional :: blockNameFound !< optional return value of block name found ! -- local variables logical :: continueRead logical :: supportOpenCloseLocal @@ -143,13 +143,13 @@ subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & supportOpenCloseLocal = supportOpenClose else supportOpenCloseLocal = .false. - endif + end if ! if (present(blockRequired)) then blockRequiredLocal = blockRequired else blockRequiredLocal = .true. - endif + end if continueRead = blockRequiredLocal this%blockName = blockName this%blockNameFound = '' @@ -162,13 +162,13 @@ subroutine GetBlock(this, blockName, isFound, ierr, supportOpenClose, & ierr = 0 else ierr = 1 - endif + end if else call uget_block(this%inunit, this%iout, this%blockName, ierr, isFound, & this%lloc, this%line, this%iuext, continueRead, & supportOpenCloseLocal) if (isFound) this%blockNameFound = this%blockName - endif + end if this%iuactive = this%iuext this%linesRead = 0 ! @@ -183,8 +183,8 @@ end subroutine GetBlock !< subroutine GetNextLine(this, endOfBlock) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - logical, intent(out) :: endOfBlock !< boolean indicating if the end of the block was read + class(BlockParserType), intent(inout) :: this !< BlockParserType object + logical, intent(out) :: endOfBlock !< boolean indicating if the end of the block was read ! -- local variables integer(I4B) :: ierr integer(I4B) :: ival @@ -216,24 +216,24 @@ subroutine GetNextLine(this, endOfBlock) endOfBlock = .true. lineread = .true. elseif (key == '') then - ! End of file reached. - ! If this is an OPEN/CLOSE file, close the file and read the next + ! End of file reached. + ! If this is an OPEN/CLOSE file, close the file and read the next ! line from this%inunit. if (this%iuext /= this%inunit) then - close(this%iuext) + close (this%iuext) this%iuext = this%inunit this%iuactive = this%inunit else errmsg = 'Unexpected end of file reached.' call store_error(errmsg) call this%StoreErrorUnit() - endif + end if else this%lloc = 1 this%linesRead = this%linesRead + 1 lineread = .true. - endif - enddo loop1 + end if + end do loop1 ! ! -- return return @@ -246,9 +246,9 @@ end subroutine GetNextLine !< function GetInteger(this) result(i) ! -- return variable - integer(I4B) :: i !< integer variable + integer(I4B) :: i !< integer variable ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables integer(I4B) :: istart integer(I4B) :: istop @@ -261,12 +261,12 @@ function GetInteger(this) result(i) ! -- Make sure variable was read before end of line if (istart == istop .and. istop == len(this%line)) then call this%ReadScalarError('INTEGER') - endif + end if ! ! -- return return end function GetInteger - + !> @ brief Get the number of lines read !! !! Function to get the number of lines read from the current block. @@ -274,28 +274,28 @@ end function GetInteger !< function GetLinesRead(this) result(nlines) ! -- return variable - integer(I4B) :: nlines !< number of lines read + integer(I4B) :: nlines !< number of lines read ! -- dummy variable - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! ! -- number of lines read - nlines = this%linesRead + nlines = this%linesRead ! ! -- return return end function GetLinesRead - + !> @ brief Get a double precision real !! - !! Function to get adouble precision floating point number from + !! Function to get adouble precision floating point number from !! the current line. !! !< function GetDouble(this) result(r) ! -- return variable - real(DP) :: r !< double precision real variable + real(DP) :: r !< double precision real variable ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables integer(I4B) :: istart integer(I4B) :: istop @@ -308,12 +308,12 @@ function GetDouble(this) result(r) ! -- Make sure variable was read before end of line if (istart == istop .and. istop == len(this%line)) then call this%ReadScalarError('DOUBLE PRECISION') - endif + end if ! ! -- return return end function GetDouble - + !> @ brief Issue a read error !! !! Method to issue an unable to read error. @@ -321,20 +321,20 @@ end function GetDouble !< subroutine ReadScalarError(this, vartype) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(in) :: vartype !< string of variable type + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(in) :: vartype !< string of variable type ! -- local variables - character(len=MAXCHARLEN-100) :: linetemp + character(len=MAXCHARLEN - 100) :: linetemp ! ! -- use linetemp as line may be longer than MAXCHARLEN linetemp = this%line ! ! -- write the message - write(errmsg, '(3a)') 'Error in block ', trim(this%blockName), '.' - write(errmsg, '(4a)') & - trim(errmsg), ' Could not read variable of type ', trim(vartype), & - " from the following line: '" - write(errmsg, '(3a)') & + write (errmsg, '(3a)') 'Error in block ', trim(this%blockName), '.' + write (errmsg, '(4a)') & + trim(errmsg), ' Could not read variable of type ', trim(vartype), & + " from the following line: '" + write (errmsg, '(3a)') & trim(errmsg), trim(adjustl(this%line)), "'." call store_error(errmsg) call this%StoreErrorUnit() @@ -342,7 +342,7 @@ subroutine ReadScalarError(this, vartype) ! -- return return end subroutine ReadScalarError - + !> @ brief Get a string !! !! Method to get a string from the current line and optionally convert it @@ -351,8 +351,8 @@ end subroutine ReadScalarError !< subroutine GetString(this, string, convertToUpper) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(out) :: string !< string + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(out) :: string !< string logical, optional, intent(in) :: convertToUpper !< boolean indicating if the string should be converted to upper case, default false ! -- local variables integer(I4B) :: istart @@ -367,10 +367,10 @@ subroutine GetString(this, string, convertToUpper) ncode = 1 else ncode = 0 - endif + end if else ncode = 0 - endif + end if ! call urword(this%line, this%lloc, istart, istop, ncode, & ival, rval, this%iout, this%iuext) @@ -389,8 +389,8 @@ end subroutine GetString !< subroutine GetStringCaps(this, string) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(out) :: string !< upper case string + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(out) :: string !< upper case string ! ! -- call base GetString method with convertToUpper variable call this%GetString(string, convertToUpper=.true.) @@ -406,8 +406,8 @@ end subroutine GetStringCaps !< subroutine GetRemainingLine(this, line) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=:), allocatable, intent(out) :: line !< remainder of the line + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=:), allocatable, intent(out) :: line !< remainder of the line ! -- local variables integer(I4B) :: lastpos integer(I4B) :: newlinelen @@ -416,14 +416,14 @@ subroutine GetRemainingLine(this, line) lastpos = len_trim(this%line) newlinelen = lastpos - this%lloc + 2 newlinelen = max(newlinelen, 1) - allocate(character(len=newlinelen) :: line) - line(:) = this%line(this%lloc:lastpos) + allocate (character(len=newlinelen) :: line) + line(:) = this%line(this%lloc:lastpos) line(newlinelen:newlinelen) = ' ' ! ! -- return return end subroutine GetRemainingLine - + !> @ brief Ensure that the block is closed !! !! Method to ensure that the block is closed with an "end". @@ -431,18 +431,18 @@ end subroutine GetRemainingLine !< subroutine terminateblock(this) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! -- local variables logical :: endofblock ! ! -- look for block termination call this%GetNextLine(endofblock) if (.not. endofblock) then - errmsg = "LOOKING FOR 'END " // trim(this%blockname) // & - "'. FOUND: " // "'" // trim(this%line) // "'." + errmsg = "LOOKING FOR 'END "//trim(this%blockname)// & + "'. FOUND: "//"'"//trim(this%line)//"'." call store_error(errmsg) call this%StoreErrorUnit() - endif + end if ! ! -- return return @@ -455,10 +455,10 @@ end subroutine terminateblock !< subroutine GetCellid(this, ndim, cellid, flag_string) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - integer(I4B), intent(in) :: ndim !< number of dimensions (1, 2, or 3) - character(len=*), intent(out) :: cellid !< cell =id - logical, optional, intent(in) :: flag_string !< boolean indicating id cellid is a string + class(BlockParserType), intent(inout) :: this !< BlockParserType object + integer(I4B), intent(in) :: ndim !< number of dimensions (1, 2, or 3) + character(len=*), intent(out) :: cellid !< cell =id + logical, optional, intent(in) :: flag_string !< boolean indicating id cellid is a string ! -- local variables integer(I4B) :: i integer(I4B) :: j @@ -477,24 +477,24 @@ subroutine GetCellid(this, ndim, cellid, flag_string) call urword(this%line, lloc, istart, istop, 0, ival, rval, this%iout, & this%iuext) firsttoken = this%line(istart:istop) - read(firsttoken,*,iostat=istat) ival + read (firsttoken, *, iostat=istat) ival if (istat > 0) then call upcase(firsttoken) cellid = firsttoken return - endif - endif + end if + end if ! cellid = '' - do i=1,ndim + do i = 1, ndim j = this%GetInteger() - write(cint,'(i0)') j + write (cint, '(i0)') j if (i == 1) then cellid = cint else - cellid = trim(cellid) // ' ' // cint - endif - enddo + cellid = trim(cellid)//' '//cint + end if + end do ! ! -- return return @@ -507,8 +507,8 @@ end subroutine GetCellid !< subroutine GetCurrentLine(this, line) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object - character(len=*), intent(out) :: line !< current line + class(BlockParserType), intent(inout) :: this !< BlockParserType object + character(len=*), intent(out) :: line !< current line ! ! -- get the current line line = this%line @@ -525,8 +525,8 @@ end subroutine GetCurrentLine !< subroutine StoreErrorUnit(this, terminate) ! -- dummy variable - class(BlockParserType), intent(inout) :: this !< BlockParserType object - logical, intent(in), optional :: terminate !< boolean indicating if the simulation should be terminated + class(BlockParserType), intent(inout) :: this !< BlockParserType object + logical, intent(in), optional :: terminate !< boolean indicating if the simulation should be terminated ! -- loacl variables logical :: lterminate ! @@ -536,7 +536,7 @@ subroutine StoreErrorUnit(this, terminate) else lterminate = .TRUE. end if - ! + ! ! -- store error unit call store_error_unit(this%iuext, terminate=lterminate) ! @@ -551,9 +551,9 @@ end subroutine StoreErrorUnit !< function GetUnit(this) result(i) ! -- return variable - integer(I4B) :: i !< unit number for the block parser + integer(I4B) :: i !< unit number for the block parser ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! ! -- block parser unit number i = this%iuext @@ -564,7 +564,7 @@ end function GetUnit !> @ brief Development option !! - !! Method that will cause the program to terminate with an error if the + !! Method that will cause the program to terminate with an error if the !! IDEVELOPMODE flag is set to 1. This is used to allow develop options !! to be specified for development testing but not for the public release. !! For the public release, IDEVELOPMODE is set to zero. @@ -572,16 +572,16 @@ end function GetUnit !< subroutine DevOpt(this) ! -- dummy variables - class(BlockParserType), intent(inout) :: this !< BlockParserType object + class(BlockParserType), intent(inout) :: this !< BlockParserType object ! ! -- If release mode (not develop mode), then option not available. ! Terminate with an error. if (IDEVELOPMODE == 0) then - errmsg = "Invalid keyword '" // trim(this%laststring) // & - "' detected in block '" // trim(this%blockname) // "'." + errmsg = "Invalid keyword '"//trim(this%laststring)// & + "' detected in block '"//trim(this%blockname)//"'." call store_error(errmsg) call this%StoreErrorUnit() - endif + end if ! ! -- Return return diff --git a/src/Utilities/Budget.f90 b/src/Utilities/Budget.f90 index 7098d3a2714..e3947909e80 100644 --- a/src/Utilities/Budget.f90 +++ b/src/Utilities/Budget.f90 @@ -1,14 +1,14 @@ -!> @brief This module contains the BudgetModule +!> @brief This module contains the BudgetModule !! !! New entries can be added for each time step, however, the same number of !! entries must be provided, and they must be provided in the same order. If not, !! the module will terminate with an error. -!! +!! !! Maxsize is required as part of the df method and the arrays will be allocated !! to maxsize. If additional entries beyond maxsize are added, the arrays !! will dynamically increase in size, however, to avoid allocation and copying, !! it is best to set maxsize large enough up front. -!! +!! !! vbvl(1, :) contains cumulative rate in !! vbvl(2, :) contains cumulative rate out !! vbvl(3, :) contains rate in @@ -20,20 +20,20 @@ module BudgetModule use KindModule, only: DP, I4B - use SimModule, only: store_error, count_errors + use SimModule, only: store_error, count_errors use ConstantsModule, only: LINELENGTH, LENBUDTXT, LENBUDROWLABEL, DZERO, & DTWO, DHUNDRED - + implicit none private public :: BudgetType public :: budget_cr public :: rate_accumulator - !> @brief Derived type for the Budget object + !> @brief Derived type for the Budget object !! - !! This derived type stores and prints information about a - !! model budget. + !! This derived type stores and prints information about a + !! model budget. !! !< type BudgetType @@ -41,11 +41,12 @@ module BudgetModule integer(I4B), pointer :: maxsize => null() real(DP), pointer :: budperc => null() logical, pointer :: written_once => null() - real(DP), dimension(:,:), pointer :: vbvl => null() + real(DP), dimension(:, :), pointer :: vbvl => null() character(len=LENBUDTXT), dimension(:), pointer, contiguous :: vbnm => null() character(len=20), pointer :: bdtype => null() character(len=5), pointer :: bddim => null() - character(len=LENBUDROWLABEL), dimension(:), pointer, contiguous :: rowlabel => null() + character(len=LENBUDROWLABEL), & + dimension(:), pointer, contiguous :: rowlabel => null() character(len=16), pointer :: labeltitle => null() character(len=20), pointer :: bdzone => null() logical, pointer :: labeled => null() @@ -53,7 +54,7 @@ module BudgetModule ! -- csv output integer(I4B), pointer :: ibudcsv => null() integer(I4B), pointer :: icsvheader => null() - + contains procedure :: budget_df procedure :: budget_ot @@ -65,28 +66,28 @@ module BudgetModule generic :: addentry => add_single_entry, add_multi_entry procedure :: writecsv ! -- private - procedure :: allocate_scalars + procedure :: allocate_scalars procedure, private :: allocate_arrays procedure, private :: resize procedure, private :: write_csv_header end type BudgetType - contains +contains !> @ brief Create a new budget object !! - !! Create a new budget object. + !! Create a new budget object. !! !< subroutine budget_cr(this, name_model) ! -- modules ! -- dummy - type(BudgetType), pointer :: this !< BudgetType object - character(len=*), intent(in) :: name_model !< name of the model + type(BudgetType), pointer :: this !< BudgetType object + character(len=*), intent(in) :: name_model !< name of the model ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- Allocate scalars call this%allocate_scalars(name_model) @@ -97,16 +98,16 @@ end subroutine budget_cr !> @ brief Define information for this object !! - !! Allocate arrays and set member variables + !! Allocate arrays and set member variables !! !< subroutine budget_df(this, maxsize, bdtype, bddim, labeltitle, bdzone) - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: maxsize !< maximum size of budget arrays - character(len=*), optional :: bdtype !< type of budget, default is VOLUME - character(len=*), optional :: bddim !< dimensions of terms, default is L**3 - character(len=*), optional :: labeltitle !< budget label, default is PACKAGE NAME - character(len=*), optional :: bdzone !< corresponding zone, default is ENTIRE MODEL + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: maxsize !< maximum size of budget arrays + character(len=*), optional :: bdtype !< type of budget, default is VOLUME + character(len=*), optional :: bddim !< dimensions of terms, default is L**3 + character(len=*), optional :: labeltitle !< budget label, default is PACKAGE NAME + character(len=*), optional :: bdzone !< corresponding zone, default is ENTIRE MODEL ! ! -- Set values this%maxsize = maxsize @@ -115,62 +116,62 @@ subroutine budget_df(this, maxsize, bdtype, bddim, labeltitle, bdzone) call this%allocate_arrays() ! ! -- Set the budget type - if(present(bdtype)) then + if (present(bdtype)) then this%bdtype = bdtype else this%bdtype = 'VOLUME' - endif + end if ! ! -- Set the budget dimension - if(present(bddim)) then + if (present(bddim)) then this%bddim = bddim else this%bddim = 'L**3' - endif + end if ! ! -- Set the budget zone - if(present(bdzone)) then + if (present(bdzone)) then this%bdzone = bdzone else this%bdzone = 'ENTIRE MODEL' - endif + end if ! ! -- Set the label title - if(present(labeltitle)) then + if (present(labeltitle)) then this%labeltitle = labeltitle else this%labeltitle = 'PACKAGE NAME' - endif + end if ! ! -- Return return end subroutine budget_df - + !> @ brief Convert a number to a string !! - !! This is sometimes needed to avoid numbers that do not fit + !! This is sometimes needed to avoid numbers that do not fit !! correctly into a text string !! !< subroutine value_to_string(val, string, big, small) - real(DP), intent(in) :: val !< value to convert - character(len=*), intent(out) :: string !< string to fill - real(DP), intent(in) :: big !< big value - real(DP), intent(in) :: small !< small value + real(DP), intent(in) :: val !< value to convert + character(len=*), intent(out) :: string !< string to fill + real(DP), intent(in) :: big !< big value + real(DP), intent(in) :: small !< small value real(DP) :: absval ! absval = abs(val) if (val /= DZERO .and. (absval >= big .or. absval < small)) then if (absval >= 1.D100 .or. absval <= 1.D-100) then - ! -- if exponent has 3 digits, then need to explicitly use the ES + ! -- if exponent has 3 digits, then need to explicitly use the ES ! format to force writing the E character - write(string, '(es17.4E3)') val + write (string, '(es17.4E3)') val else - write(string, '(1pe17.4)') val + write (string, '(1pe17.4)') val end if else ! -- value is within range where number looks good with F format - write(string, '(f17.4)') val + write (string, '(f17.4)') val end if return end subroutine value_to_string @@ -182,14 +183,14 @@ end subroutine value_to_string !! !< subroutine budget_ot(this, kstp, kper, iout) - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: kstp !< time step - integer(I4B), intent(in) :: kper !< stress period - integer(I4B), intent(in) :: iout !< output unit number + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: kstp !< time step + integer(I4B), intent(in) :: kper !< stress period + integer(I4B), intent(in) :: iout !< output unit number character(len=17) :: val1, val2 integer(I4B) :: msum1, l - real(DP) :: two, hund, bigvl1, bigvl2, small, & - totrin, totrot, totvin, totvot, diffr, adiffr, & + real(DP) :: two, hund, bigvl1, bigvl2, small, & + totrin, totrot, totvin, totvot, diffr, adiffr, & pdiffr, pdiffv, avgrat, diffv, adiffv, avgvol ! ! -- Set constants @@ -202,7 +203,7 @@ subroutine budget_ot(this, kstp, kper, iout) ! -- Determine number of individual budget entries. this%budperc = DZERO msum1 = this%msum - 1 - if(msum1 <= 0) return + if (msum1 <= 0) return ! ! -- Clear rate and volume accumulators. totrin = DZERO @@ -211,65 +212,65 @@ subroutine budget_ot(this, kstp, kper, iout) totvot = DZERO ! ! -- Add rates and volumes (in and out) to accumulators. - do l=1,msum1 - totrin = totrin + this%vbvl(3,l) - totrot = totrot + this%vbvl(4,l) - totvin = totvin + this%vbvl(1,l) - totvot = totvot + this%vbvl(2,l) - enddo + do l = 1, msum1 + totrin = totrin + this%vbvl(3, l) + totrot = totrot + this%vbvl(4, l) + totvin = totvin + this%vbvl(1, l) + totvot = totvot + this%vbvl(2, l) + end do ! ! -- Print time step number and stress period number. - if(this%labeled) then - write(iout,261) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & - kstp, kper - write(iout,266) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & - trim(adjustl(this%bddim)),this%labeltitle + if (this%labeled) then + write (iout, 261) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & + kstp, kper + write (iout, 266) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & + trim(adjustl(this%bddim)), this%labeltitle else - write(iout,260) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & - kstp, kper - write(iout,265) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & - trim(adjustl(this%bddim)) - endif + write (iout, 260) trim(adjustl(this%bdtype)), trim(adjustl(this%bdzone)), & + kstp, kper + write (iout, 265) trim(adjustl(this%bdtype)), trim(adjustl(this%bddim)), & + trim(adjustl(this%bddim)) + end if ! ! -- Print individual inflow rates and volumes and their totals. - do l=1,msum1 + do l = 1, msum1 call value_to_string(this%vbvl(1, l), val1, bigvl1, small) call value_to_string(this%vbvl(3, l), val2, bigvl1, small) - if(this%labeled) then - write(iout,276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) + if (this%labeled) then + write (iout, 276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) else - write(iout,275) this%vbnm(l), val1, this%vbnm(l), val2 - endif - enddo + write (iout, 275) this%vbnm(l), val1, this%vbnm(l), val2 + end if + end do call value_to_string(totvin, val1, bigvl1, small) call value_to_string(totrin, val2, bigvl1, small) - write(iout,286) val1, val2 + write (iout, 286) val1, val2 ! ! -- Print individual outflow rates and volumes and their totals. - write(iout,287) - do l=1,msum1 - call value_to_string(this%vbvl(2,l), val1, bigvl1, small) - call value_to_string(this%vbvl(4,l), val2, bigvl1, small) - if(this%labeled) then - write(iout,276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) + write (iout, 287) + do l = 1, msum1 + call value_to_string(this%vbvl(2, l), val1, bigvl1, small) + call value_to_string(this%vbvl(4, l), val2, bigvl1, small) + if (this%labeled) then + write (iout, 276) this%vbnm(l), val1, this%vbnm(l), val2, this%rowlabel(l) else - write(iout,275) this%vbnm(l), val1, this%vbnm(l), val2 - endif - enddo + write (iout, 275) this%vbnm(l), val1, this%vbnm(l), val2 + end if + end do call value_to_string(totvot, val1, bigvl1, small) call value_to_string(totrot, val2, bigvl1, small) - write(iout,298) val1, val2 + write (iout, 298) val1, val2 ! ! -- Calculate the difference between inflow and outflow. ! ! -- Calculate difference between rate in and rate out. - diffr=totrin-totrot - adiffr=abs(diffr) + diffr = totrin - totrot + adiffr = abs(diffr) ! ! -- Calculate percent difference between rate in and rate out. pdiffr = DZERO - avgrat=(totrin+totrot)/two - if(avgrat /= DZERO) pdiffr = hund * diffr / avgrat + avgrat = (totrin + totrot) / two + if (avgrat /= DZERO) pdiffr = hund * diffr / avgrat this%budperc = pdiffr ! ! -- Calculate difference between volume in and volume out. @@ -278,42 +279,42 @@ subroutine budget_ot(this, kstp, kper, iout) ! ! -- Get percent difference between volume in and volume out. pdiffv = DZERO - avgvol=(totvin+totvot)/two - if(avgvol /= DZERO) pdiffv= hund * diffv / avgvol + avgvol = (totvin + totvot) / two + if (avgvol /= DZERO) pdiffv = hund * diffv / avgvol ! ! -- Print differences and percent differences between input ! -- and output rates and volumes. call value_to_string(diffv, val1, bigvl2, small) call value_to_string(diffr, val2, bigvl2, small) - write(iout,299) val1, val2 - write(iout,300) pdiffv, pdiffr + write (iout, 299) val1, val2 + write (iout, 300) pdiffv, pdiffr ! ! -- flush the file - flush(iout) + flush (iout) ! ! -- set written_once to .true. this%written_once = .true. ! ! -- formats - 260 FORMAT(//2X,a,' BUDGET FOR ',a,' AT END OF' & - ,' TIME STEP',I5,', STRESS PERIOD',I4/2X,78('-')) - 261 FORMAT(//2X,a,' BUDGET FOR ',a,' AT END OF' & - ,' TIME STEP',I5,', STRESS PERIOD',I4/2X,99('-')) - 265 FORMAT(1X,/5X,'CUMULATIVE ',a,6X,a,7X & - ,'RATES FOR THIS TIME STEP',6X,a,'/T'/5X,18('-'),17X,24('-') & - //11X,'IN:',38X,'IN:'/11X,'---',38X,'---') - 266 FORMAT(1X,/5X,'CUMULATIVE ',a,6X,a,7X & - ,'RATES FOR THIS TIME STEP',6X,a,'/T',10X,A16, & - /5X,18('-'),17X,24('-'),21X,16('-') & - //11X,'IN:',38X,'IN:'/11X,'---',38X,'---') - 275 FORMAT(1X,3X,A16,' =',A17,6X,A16,' =',A17) - 276 FORMAT(1X,3X,A16,' =',A17,6X,A16,' =',A17,5X,A) - 286 FORMAT(1X,/12X,'TOTAL IN =',A,14X,'TOTAL IN =',A) - 287 FORMAT(1X,/10X,'OUT:',37X,'OUT:'/10X,4('-'),37X,4('-')) - 298 FORMAT(1X,/11X,'TOTAL OUT =',A,13X,'TOTAL OUT =',A) - 299 FORMAT(1X,/12X,'IN - OUT =',A,14X,'IN - OUT =',A) - 300 FORMAT(1X,/1X,'PERCENT DISCREPANCY =',F15.2 & - ,5X,'PERCENT DISCREPANCY =',F15.2/) +260 FORMAT(//2X, a, ' BUDGET FOR ', a, ' AT END OF' & + , ' TIME STEP', I5, ', STRESS PERIOD', I4 / 2X, 78('-')) +261 FORMAT(//2X, a, ' BUDGET FOR ', a, ' AT END OF' & + , ' TIME STEP', I5, ', STRESS PERIOD', I4 / 2X, 99('-')) +265 FORMAT(1X, /5X, 'CUMULATIVE ', a, 6X, a, 7X & + , 'RATES FOR THIS TIME STEP', 6X, a, '/T'/5X, 18('-'), 17X, 24('-') & + //11X, 'IN:', 38X, 'IN:'/11X, '---', 38X, '---') +266 FORMAT(1X, /5X, 'CUMULATIVE ', a, 6X, a, 7X & + , 'RATES FOR THIS TIME STEP', 6X, a, '/T', 10X, A16, & + /5X, 18('-'), 17X, 24('-'), 21X, 16('-') & + //11X, 'IN:', 38X, 'IN:'/11X, '---', 38X, '---') +275 FORMAT(1X, 3X, A16, ' =', A17, 6X, A16, ' =', A17) +276 FORMAT(1X, 3X, A16, ' =', A17, 6X, A16, ' =', A17, 5X, A) +286 FORMAT(1X, /12X, 'TOTAL IN =', A, 14X, 'TOTAL IN =', A) +287 FORMAT(1X, /10X, 'OUT:', 37X, 'OUT:'/10X, 4('-'), 37X, 4('-')) +298 FORMAT(1X, /11X, 'TOTAL OUT =', A, 13X, 'TOTAL OUT =', A) +299 FORMAT(1X, /12X, 'IN - OUT =', A, 14X, 'IN - OUT =', A) +300 FORMAT(1X, /1X, 'PERCENT DISCREPANCY =', F15.2 & + , 5X, 'PERCENT DISCREPANCY =', F15.2/) ! ! -- Return return @@ -325,25 +326,25 @@ end subroutine budget_ot !! !< subroutine budget_da(this) - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! ! -- Scalars - deallocate(this%msum) - deallocate(this%maxsize) - deallocate(this%budperc) - deallocate(this%written_once) - deallocate(this%labeled) - deallocate(this%bdtype) - deallocate(this%bddim) - deallocate(this%labeltitle) - deallocate(this%bdzone) - deallocate(this%ibudcsv) - deallocate(this%icsvheader) + deallocate (this%msum) + deallocate (this%maxsize) + deallocate (this%budperc) + deallocate (this%written_once) + deallocate (this%labeled) + deallocate (this%bdtype) + deallocate (this%bddim) + deallocate (this%labeltitle) + deallocate (this%bdzone) + deallocate (this%ibudcsv) + deallocate (this%icsvheader) ! ! -- Arrays - deallocate(this%vbvl) - deallocate(this%vbnm) - deallocate(this%rowlabel) + deallocate (this%vbvl) + deallocate (this%vbnm) + deallocate (this%rowlabel) ! ! -- Return return @@ -357,7 +358,7 @@ end subroutine budget_da subroutine reset(this) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! -- local integer(I4B) :: i ! @@ -366,13 +367,13 @@ subroutine reset(this) do i = 1, this%maxsize this%vbvl(3, i) = DZERO this%vbvl(4, i) = DZERO - enddo + end do ! ! -- Return return end subroutine reset - !> @ brief Add a single row of information + !> @ brief Add a single row of information !! !! Add information corresponding to one row in the budget table !! rin the inflow rate @@ -381,32 +382,32 @@ end subroutine reset !! text is the name of the entry !! isupress_accumulate is an optional flag. If specified as 1, then !! the volume is NOT added to the accumulators on vbvl(1, :) and vbvl(2, :). - !! rowlabel is a LENBUDROWLABEL character text entry that is written to the - !! right of the table. It can be used for adding package names to budget + !! rowlabel is a LENBUDROWLABEL character text entry that is written to the + !! right of the table. It can be used for adding package names to budget !! entries. !! !< - subroutine add_single_entry(this, rin, rout, delt, text, & + subroutine add_single_entry(this, rin, rout, delt, text, & isupress_accumulate, rowlabel) ! -- dummy - class(BudgetType) :: this !< BudgetType object - real(DP), intent(in) :: rin !< inflow rate - real(DP), intent(in) :: rout !< outflow rate - real(DP), intent(in) :: delt !< time step length - character(len=LENBUDTXT), intent(in) :: text !< name of the entry - integer(I4B), optional, intent(in) :: isupress_accumulate !< accumulate flag - character(len=*), optional, intent(in) :: rowlabel !< row label + class(BudgetType) :: this !< BudgetType object + real(DP), intent(in) :: rin !< inflow rate + real(DP), intent(in) :: rout !< outflow rate + real(DP), intent(in) :: delt !< time step length + character(len=LENBUDTXT), intent(in) :: text !< name of the entry + integer(I4B), optional, intent(in) :: isupress_accumulate !< accumulate flag + character(len=*), optional, intent(in) :: rowlabel !< row label ! -- local character(len=LINELENGTH) :: errmsg character(len=*), parameter :: fmtbuderr = & - "('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" + &"('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" integer(I4B) :: iscv integer(I4B) :: maxsize ! iscv = 0 - if(present(isupress_accumulate)) then + if (present(isupress_accumulate)) then iscv = isupress_accumulate - endif + end if ! ! -- ensure budget arrays are large enough maxsize = this%msum @@ -416,33 +417,33 @@ subroutine add_single_entry(this, rin, rout, delt, text, & ! ! -- If budget has been written at least once, then make sure that the present ! text entry matches the last text entry - if(this%written_once) then - if(trim(adjustl(this%vbnm(this%msum))) /= trim(adjustl(text))) then - write(errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & - trim(adjustl(text)) + if (this%written_once) then + if (trim(adjustl(this%vbnm(this%msum))) /= trim(adjustl(text))) then + write (errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & + trim(adjustl(text)) call store_error(errmsg, terminate=.TRUE.) - endif - endif + end if + end if ! - if(iscv == 0) then - this%vbvl(1, this%msum)=this%vbvl(1,this%msum) + rin * delt - this%vbvl(2, this%msum)=this%vbvl(2,this%msum) + rout * delt - endif + if (iscv == 0) then + this%vbvl(1, this%msum) = this%vbvl(1, this%msum) + rin * delt + this%vbvl(2, this%msum) = this%vbvl(2, this%msum) + rout * delt + end if ! this%vbvl(3, this%msum) = rin this%vbvl(4, this%msum) = rout this%vbnm(this%msum) = adjustr(text) - if(present(rowlabel)) then + if (present(rowlabel)) then this%rowlabel(this%msum) = adjustl(rowlabel) this%labeled = .true. - endif + end if this%msum = this%msum + 1 ! ! -- Return return end subroutine add_single_entry - !> @ brief Add multiple rows of information + !> @ brief Add multiple rows of information !! !! Add information corresponding to one multiple rows in the budget table !! budterm is an array with inflow in column 1 and outflow in column 2 @@ -451,31 +452,31 @@ end subroutine add_single_entry !! row in budterm !! isupress_accumulate is an optional flag. If specified as 1, then !! the volume is NOT added to the accumulators on vbvl(1, :) and vbvl(2, :). - !! rowlabel is a LENBUDROWLABEL character text entry that is written to the - !! right of the table. It can be used for adding package names to budget + !! rowlabel is a LENBUDROWLABEL character text entry that is written to the + !! right of the table. It can be used for adding package names to budget !! entries. For multiple entries, the same rowlabel is used for each entry. !! !< - subroutine add_multi_entry(this, budterm, delt, budtxt, & + subroutine add_multi_entry(this, budterm, delt, budtxt, & isupress_accumulate, rowlabel) ! -- dummy - class(BudgetType) :: this !< BudgetType object - real(DP), dimension(:, :), intent(in) :: budterm !< array of budget terms - real(DP), intent(in) :: delt !< time step length - character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt !< name of the entries - integer(I4B), optional, intent(in) :: isupress_accumulate !< suppress accumulate - character(len=*), optional, intent(in) :: rowlabel !< row label + class(BudgetType) :: this !< BudgetType object + real(DP), dimension(:, :), intent(in) :: budterm !< array of budget terms + real(DP), intent(in) :: delt !< time step length + character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt !< name of the entries + integer(I4B), optional, intent(in) :: isupress_accumulate !< suppress accumulate + character(len=*), optional, intent(in) :: rowlabel !< row label ! -- local character(len=LINELENGTH) :: errmsg character(len=*), parameter :: fmtbuderr = & - "('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" + &"('Error in MODFLOW 6.', 'Entries do not match: ', (a), (a) )" integer(I4B) :: iscv, i integer(I4B) :: nbudterms, maxsize ! iscv = 0 - if(present(isupress_accumulate)) then + if (present(isupress_accumulate)) then iscv = isupress_accumulate - endif + end if ! ! -- ensure budget arrays are large enough nbudterms = size(budtxt) @@ -489,35 +490,35 @@ subroutine add_multi_entry(this, budterm, delt, budtxt, & ! ! -- If budget has been written at least once, then make sure that the present ! text entry matches the last text entry - if(this%written_once) then - if(trim(adjustl(this%vbnm(this%msum))) /= & - trim(adjustl(budtxt(i)))) then - write(errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & - trim(adjustl(budtxt(i))) - call store_error(errmsg) - endif - endif + if (this%written_once) then + if (trim(adjustl(this%vbnm(this%msum))) /= & + trim(adjustl(budtxt(i)))) then + write (errmsg, fmtbuderr) trim(adjustl(this%vbnm(this%msum))), & + trim(adjustl(budtxt(i))) + call store_error(errmsg) + end if + end if ! - if(iscv == 0) then - this%vbvl(1, this%msum)=this%vbvl(1,this%msum) + budterm(1, i) * delt - this%vbvl(2, this%msum)=this%vbvl(2,this%msum) + budterm(2, i) * delt - endif + if (iscv == 0) then + this%vbvl(1, this%msum) = this%vbvl(1, this%msum) + budterm(1, i) * delt + this%vbvl(2, this%msum) = this%vbvl(2, this%msum) + budterm(2, i) * delt + end if ! this%vbvl(3, this%msum) = budterm(1, i) this%vbvl(4, this%msum) = budterm(2, i) this%vbnm(this%msum) = adjustr(budtxt(i)) - if(present(rowlabel)) then + if (present(rowlabel)) then this%rowlabel(this%msum) = adjustl(rowlabel) this%labeled = .true. - endif + end if this%msum = this%msum + 1 ! - enddo + end do ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error('Could not add multi-entry', terminate=.TRUE.) - endif + end if ! ! -- Return return @@ -531,20 +532,20 @@ end subroutine add_multi_entry subroutine allocate_scalars(this, name_model) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - character(len=*), intent(in) :: name_model !< name of the model - ! - allocate(this%msum) - allocate(this%maxsize) - allocate(this%budperc) - allocate(this%written_once) - allocate(this%labeled) - allocate(this%bdtype) - allocate(this%bddim) - allocate(this%labeltitle) - allocate(this%bdzone) - allocate(this%ibudcsv) - allocate(this%icsvheader) + class(BudgetType) :: this !< BudgetType object + character(len=*), intent(in) :: name_model !< name of the model + ! + allocate (this%msum) + allocate (this%maxsize) + allocate (this%budperc) + allocate (this%written_once) + allocate (this%labeled) + allocate (this%bdtype) + allocate (this%bddim) + allocate (this%labeltitle) + allocate (this%bdzone) + allocate (this%ibudcsv) + allocate (this%icsvheader) ! ! -- Initialize values this%msum = 0 @@ -569,26 +570,26 @@ end subroutine allocate_scalars subroutine allocate_arrays(this) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! ! -- If redefining, then need to deallocate/reallocate - if(associated(this%vbvl)) then - deallocate(this%vbvl) - nullify(this%vbvl) - endif - if(associated(this%vbnm)) then - deallocate(this%vbnm) - nullify(this%vbnm) - endif - if(associated(this%rowlabel)) then - deallocate(this%rowlabel) - nullify(this%rowlabel) - endif + if (associated(this%vbvl)) then + deallocate (this%vbvl) + nullify (this%vbvl) + end if + if (associated(this%vbnm)) then + deallocate (this%vbnm) + nullify (this%vbnm) + end if + if (associated(this%rowlabel)) then + deallocate (this%rowlabel) + nullify (this%rowlabel) + end if ! ! -- Allocate - allocate(this%vbvl(4, this%maxsize)) - allocate(this%vbnm(this%maxsize)) - allocate(this%rowlabel(this%maxsize)) + allocate (this%vbvl(4, this%maxsize)) + allocate (this%vbnm(this%maxsize)) + allocate (this%rowlabel(this%maxsize)) ! ! -- Initialize values this%vbvl(:, :) = DZERO @@ -597,7 +598,7 @@ subroutine allocate_arrays(this) ! return end subroutine allocate_arrays - + !> @ brief Resize the budget object !! !! If the size wasn't allocated to be large enough, then the budget object @@ -607,8 +608,8 @@ end subroutine allocate_arrays subroutine resize(this, maxsize) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: maxsize !< maximum size + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: maxsize !< maximum size ! -- local real(DP), dimension(:, :), allocatable :: vbvl character(len=LENBUDTXT), dimension(:), allocatable :: vbnm @@ -617,9 +618,9 @@ subroutine resize(this, maxsize) ! ! -- allocate and copy into local storage maxsizeold = this%maxsize - allocate(vbvl(4, maxsizeold)) - allocate(vbnm(maxsizeold)) - allocate(rowlabel(maxsizeold)) + allocate (vbvl(4, maxsizeold)) + allocate (vbnm(maxsizeold)) + allocate (rowlabel(maxsizeold)) vbvl(:, :) = this%vbvl(:, :) vbnm(:) = this%vbnm(:) rowlabel(:) = this%rowlabel(:) @@ -634,14 +635,14 @@ subroutine resize(this, maxsize) this%rowlabel(1:maxsizeold) = rowlabel(1:maxsizeold) ! ! - deallocate local copies - deallocate(vbvl) - deallocate(vbnm) - deallocate(rowlabel) + deallocate (vbvl) + deallocate (vbnm) + deallocate (rowlabel) ! ! -- return return end subroutine resize - + !> @ brief Rate accumulator subroutine !! !! Routing for tallying inflows and outflows of an array @@ -650,9 +651,9 @@ end subroutine resize subroutine rate_accumulator(flow, rin, rout) ! -- modules ! -- dummy - real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flows - real(DP), intent(out) :: rin !< calculated sum of inflows - real(DP), intent(out) :: rout !< calculated sum of outflows + real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flows + real(DP), intent(out) :: rin !< calculated sum of inflows + real(DP), intent(out) :: rout !< calculated sum of outflows integer(I4B) :: n ! rin = DZERO @@ -666,7 +667,7 @@ subroutine rate_accumulator(flow, rin, rout) end do return end subroutine rate_accumulator - + !> @ brief Set unit number for csv output file !! !! This routine can be used to activate csv output @@ -676,12 +677,12 @@ end subroutine rate_accumulator subroutine set_ibudcsv(this, ibudcsv) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - integer(I4B), intent(in) :: ibudcsv !< unit number for csv budget output + class(BudgetType) :: this !< BudgetType object + integer(I4B), intent(in) :: ibudcsv !< unit number for csv budget output this%ibudcsv = ibudcsv return end subroutine set_ibudcsv - + !> @ brief Write csv output !! !! This routine will write a row of output to the @@ -692,8 +693,8 @@ end subroutine set_ibudcsv subroutine writecsv(this, totim) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object - real(DP), intent(in) :: totim !< time corresponding to this data + class(BudgetType) :: this !< BudgetType object + real(DP), intent(in) :: totim !< time corresponding to this data ! -- local integer(I4B) :: i real(DP) :: totrin @@ -727,19 +728,20 @@ subroutine writecsv(this, totim) end if ! ! -- write data - write(this%ibudcsv, '(*(G0,:,","))') totim, & - (this%vbvl(3, i), i=1,this%msum-1), & - (this%vbvl(4, i), i=1,this%msum-1), & - totrin, totrout, pdiffr + write (this%ibudcsv, '(*(G0,:,","))') & + totim, & + (this%vbvl(3, i), i=1, this%msum - 1), & + (this%vbvl(4, i), i=1, this%msum - 1), & + totrin, totrout, pdiffr ! ! -- flush the file - flush(this%ibudcsv) + flush (this%ibudcsv) end if ! ! -- return return end subroutine writecsv - + !> @ brief Write csv header !! !! This routine will write the csv header based on the @@ -749,21 +751,21 @@ end subroutine writecsv subroutine write_csv_header(this) ! -- modules ! -- dummy - class(BudgetType) :: this !< BudgetType object + class(BudgetType) :: this !< BudgetType object ! -- local integer(I4B) :: l character(len=LINELENGTH) :: txt, txtl - write(this%ibudcsv, '(a)', advance='NO') 'time,' + write (this%ibudcsv, '(a)', advance='NO') 'time,' ! ! -- first write IN do l = 1, this%msum - 1 txt = this%vbnm(l) txtl = '' if (this%labeled) then - txtl = '(' // trim(adjustl(this%rowlabel(l))) // ')' + txtl = '('//trim(adjustl(this%rowlabel(l)))//')' end if - txt = trim(adjustl(txt)) // trim(adjustl(txtl)) // '_IN,' - write(this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) + txt = trim(adjustl(txt))//trim(adjustl(txtl))//'_IN,' + write (this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) end do ! ! -- then write OUT @@ -771,12 +773,12 @@ subroutine write_csv_header(this) txt = this%vbnm(l) txtl = '' if (this%labeled) then - txtl = '(' // trim(adjustl(this%rowlabel(l))) // ')' + txtl = '('//trim(adjustl(this%rowlabel(l)))//')' end if - txt = trim(adjustl(txt)) // trim(adjustl(txtl)) // '_OUT,' - write(this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) + txt = trim(adjustl(txt))//trim(adjustl(txtl))//'_OUT,' + write (this%ibudcsv, '(a)', advance='NO') trim(adjustl(txt)) end do - write(this%ibudcsv, '(a)') 'TOTAL_IN,TOTAL_OUT,PERCENT_DIFFERENCE' + write (this%ibudcsv, '(a)') 'TOTAL_IN,TOTAL_OUT,PERCENT_DIFFERENCE' ! ! -- return return diff --git a/src/Utilities/BudgetFileReader.f90 b/src/Utilities/BudgetFileReader.f90 index be959e66efa..413ded4faa9 100644 --- a/src/Utilities/BudgetFileReader.f90 +++ b/src/Utilities/BudgetFileReader.f90 @@ -5,12 +5,12 @@ module BudgetFileReaderModule use ConstantsModule, only: LINELENGTH implicit none - + private public :: BudgetFileReaderType - + type :: BudgetFileReaderType - + logical :: hasimeth1flowja = .false. integer(I4B) :: inunit integer(I4B) :: nbudterms @@ -45,17 +45,17 @@ module BudgetFileReaderModule character(len=16) :: dstmodelname character(len=16) :: dstpackagename character(len=16), dimension(:), allocatable :: dstpackagenamearray - + contains - + procedure :: initialize procedure :: read_record procedure :: finalize - + end type BudgetFileReaderType - - contains - + +contains + subroutine initialize(this, iu, iout, ncrbud) ! ****************************************************************************** ! initialize @@ -82,8 +82,8 @@ subroutine initialize(this, iu, iout, ncrbud) ! ! -- Determine number of budget terms within a time step if (iout > 0) & - write(iout, '(a)') & - 'Reading budget file to determine number of terms per time step.' + write (iout, '(a)') & + 'Reading budget file to determine number of terms per time step.' ! ! -- Read through the first set of data for time step 1 and stress period 1 do @@ -96,13 +96,13 @@ subroutine initialize(this, iu, iout, ncrbud) end do kstp_last = this%kstp kper_last = this%kper - allocate(this%budtxtarray(this%nbudterms)) - allocate(this%imetharray(this%nbudterms)) - allocate(this%dstpackagenamearray(this%nbudterms)) - allocate(this%nauxarray(this%nbudterms)) - allocate(this%auxtxtarray(maxaux, this%nbudterms)) + allocate (this%budtxtarray(this%nbudterms)) + allocate (this%imetharray(this%nbudterms)) + allocate (this%dstpackagenamearray(this%nbudterms)) + allocate (this%nauxarray(this%nbudterms)) + allocate (this%auxtxtarray(maxaux, this%nbudterms)) this%auxtxtarray(:, :) = '' - rewind(this%inunit) + rewind (this%inunit) ! ! -- Now read through again and store budget text names do ibudterm = 1, this%nbudterms @@ -116,18 +116,18 @@ subroutine initialize(this, iu, iout, ncrbud) this%auxtxtarray(1:this%naux, ibudterm) = this%auxtxt(:) end if if (this%srcmodelname == this%dstmodelname) then - if(allocated(this%nodesrc)) ncrbud = max(ncrbud, maxval(this%nodesrc)) - endif - enddo - rewind(this%inunit) + if (allocated(this%nodesrc)) ncrbud = max(ncrbud, maxval(this%nodesrc)) + end if + end do + rewind (this%inunit) if (iout > 0) & - write(iout, '(a, i0, a)') 'Detected ', this%nbudterms, & + write (iout, '(a, i0, a)') 'Detected ', this%nbudterms, & ' unique flow terms in budget file.' ! ! -- return return end subroutine initialize - + subroutine read_record(this, success, iout_opt) ! ****************************************************************************** ! read_record @@ -150,7 +150,7 @@ subroutine read_record(this, success, iout_opt) iout = iout_opt else iout = 0 - endif + end if ! this%kstp = 0 this%kper = 0 @@ -163,83 +163,83 @@ subroutine read_record(this, success, iout_opt) this%srcpackagename = '' this%dstmodelname = '' this%dstpackagename = '' - + success = .true. this%kstpnext = 0 this%kpernext = 0 - read(this%inunit, iostat=iostat) this%kstp, this%kper, this%budtxt, & + read (this%inunit, iostat=iostat) this%kstp, this%kper, this%budtxt, & this%nval, this%idum1, this%idum2 if (iostat /= 0) then success = .false. if (iostat < 0) this%endoffile = .true. return - endif - read(this%inunit) this%imeth, this%delt, this%pertim, this%totim - if(this%imeth == 1) then + end if + read (this%inunit) this%imeth, this%delt, this%pertim, this%totim + if (this%imeth == 1) then if (trim(adjustl(this%budtxt)) == 'FLOW-JA-FACE') then - if(allocated(this%flowja)) deallocate(this%flowja) - allocate(this%flowja(this%nval)) - read(this%inunit) this%flowja + if (allocated(this%flowja)) deallocate (this%flowja) + allocate (this%flowja(this%nval)) + read (this%inunit) this%flowja this%hasimeth1flowja = .true. else this%nval = this%nval * this%idum1 * abs(this%idum2) - if(allocated(this%flow)) deallocate(this%flow) - allocate(this%flow(this%nval)) - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - allocate(this%nodesrc(this%nval)) - read(this%inunit) this%flow + if (allocated(this%flow)) deallocate (this%flow) + allocate (this%flow(this%nval)) + if (allocated(this%nodesrc)) deallocate (this%nodesrc) + allocate (this%nodesrc(this%nval)) + read (this%inunit) this%flow do i = 1, this%nval this%nodesrc(i) = i - enddo - endif + end do + end if elseif (this%imeth == 6) then ! -- method code 6 - read(this%inunit) this%srcmodelname - read(this%inunit) this%srcpackagename - read(this%inunit) this%dstmodelname - read(this%inunit) this%dstpackagename - read(this%inunit) this%ndat + read (this%inunit) this%srcmodelname + read (this%inunit) this%srcpackagename + read (this%inunit) this%dstmodelname + read (this%inunit) this%dstpackagename + read (this%inunit) this%ndat this%naux = this%ndat - 1 - if(allocated(this%auxtxt)) deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) - read(this%inunit) this%auxtxt - read(this%inunit) this%nlist - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - allocate(this%nodesrc(this%nlist)) - if(allocated(this%nodedst)) deallocate(this%nodedst) - allocate(this%nodedst(this%nlist)) - if(allocated(this%flow)) deallocate(this%flow) - allocate(this%flow(this%nlist)) - if(allocated(this%auxvar)) deallocate(this%auxvar) - allocate(this%auxvar(this%naux, this%nlist)) - read(this%inunit) (this%nodesrc(n), this%nodedst(n), this%flow(n), & - (this%auxvar(i, n), i = 1, this%naux), n = 1, this%nlist) + if (allocated(this%auxtxt)) deallocate (this%auxtxt) + allocate (this%auxtxt(this%naux)) + read (this%inunit) this%auxtxt + read (this%inunit) this%nlist + if (allocated(this%nodesrc)) deallocate (this%nodesrc) + allocate (this%nodesrc(this%nlist)) + if (allocated(this%nodedst)) deallocate (this%nodedst) + allocate (this%nodedst(this%nlist)) + if (allocated(this%flow)) deallocate (this%flow) + allocate (this%flow(this%nlist)) + if (allocated(this%auxvar)) deallocate (this%auxvar) + allocate (this%auxvar(this%naux, this%nlist)) + read (this%inunit) (this%nodesrc(n), this%nodedst(n), this%flow(n), & + (this%auxvar(i, n), i=1, this%naux), n=1, this%nlist) else - write(errmsg, '(a, a)') 'ERROR READING: ', trim(this%budtxt) + write (errmsg, '(a, a)') 'ERROR READING: ', trim(this%budtxt) call store_error(errmsg) - write(errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', this%imeth + write (errmsg, '(a, i0)') 'INVALID METHOD CODE DETECTED: ', this%imeth call store_error(errmsg) call store_error_unit(this%inunit) - endif + end if if (iout > 0) then - write(iout, '(1pg15.6, a, 1x, a)') this%totim, this%budtxt, & + write (iout, '(1pg15.6, a, 1x, a)') this%totim, this%budtxt, & this%dstpackagename - endif + end if ! ! -- look ahead to next kstp and kper, then backup if read successfully if (.not. this%endoffile) then - read(this%inunit, iostat=iostat) this%kstpnext, this%kpernext + read (this%inunit, iostat=iostat) this%kstpnext, this%kpernext if (iostat == 0) then call fseek_stream(this%inunit, -2 * I4B, 1, iostat) else if (iostat < 0) then this%endoffile = .true. end if - endif + end if ! ! -- return return end subroutine read_record - + subroutine finalize(this) ! ****************************************************************************** ! budgetdata_finalize @@ -249,16 +249,16 @@ subroutine finalize(this) ! ------------------------------------------------------------------------------ class(BudgetFileReaderType) :: this ! ------------------------------------------------------------------------------ - close(this%inunit) - if(allocated(this%auxtxt)) deallocate(this%auxtxt) - if(allocated(this%flowja)) deallocate(this%flowja) - if(allocated(this%nodesrc)) deallocate(this%nodesrc) - if(allocated(this%nodedst)) deallocate(this%nodedst) - if(allocated(this%flow)) deallocate(this%flow) - if(allocated(this%auxvar)) deallocate(this%auxvar) + close (this%inunit) + if (allocated(this%auxtxt)) deallocate (this%auxtxt) + if (allocated(this%flowja)) deallocate (this%flowja) + if (allocated(this%nodesrc)) deallocate (this%nodesrc) + if (allocated(this%nodedst)) deallocate (this%nodedst) + if (allocated(this%flow)) deallocate (this%flow) + if (allocated(this%auxvar)) deallocate (this%auxvar) ! ! -- return return end subroutine finalize - + end module BudgetFileReaderModule diff --git a/src/Utilities/BudgetObject.f90 b/src/Utilities/BudgetObject.f90 index eefd3e243a0..35836bf50b6 100644 --- a/src/Utilities/BudgetObject.f90 +++ b/src/Utilities/BudgetObject.f90 @@ -1,25 +1,25 @@ -! Comprehensive budget object that stores all of the -! intercell flows, and the inflows and the outflows for +! Comprehensive budget object that stores all of the +! intercell flows, and the inflows and the outflows for ! an advanced package. module BudgetObjectModule - + use KindModule, only: I4B, DP - use ConstantsModule, only: LENBUDTXT, LINELENGTH, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + use ConstantsModule, only: LENBUDTXT, LINELENGTH, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & DZERO, DHALF, DHUNDRED - use BudgetModule, only : BudgetType, budget_cr + use BudgetModule, only: BudgetType, budget_cr use BudgetTermModule, only: BudgetTermType use TableModule, only: TableType, table_cr use BaseDisModule, only: DisBaseType use BudgetFileReaderModule, only: BudgetFileReaderType - + implicit none - + public :: BudgetObjectType public :: budgetobject_cr public :: budgetobject_cr_bfr - + type :: BudgetObjectType ! ! -- name, number of control volumes, and number of budget terms @@ -47,20 +47,20 @@ module BudgetObjectModule ! -- budget table object, for writing the typical MODFLOW budget type(BudgetType), pointer :: budtable => null() ! - ! -- flow table object, for writing the flow budget for + ! -- flow table object, for writing the flow budget for ! each control volume logical, pointer :: add_cellids => null() integer(I4B), pointer :: icellid => null() integer(I4B), pointer :: nflowterms => null() integer(I4B), dimension(:), pointer :: istart => null() integer(I4B), dimension(:), pointer :: iflowterms => null() - type(TableType), pointer :: flowtab => null() + type(TableType), pointer :: flowtab => null() ! ! -- budget file reader, for reading flows from a binary file type(BudgetFileReaderType), pointer :: bfr => null() - + contains - + procedure :: budgetobject_df procedure :: flowtable_df procedure :: accumulate_terms @@ -72,10 +72,10 @@ module BudgetObjectModule procedure :: bfr_init procedure :: bfr_advance procedure :: fill_from_bfr - + end type BudgetObjectType - - contains + +contains subroutine budgetobject_cr(this, name) ! ****************************************************************************** @@ -91,7 +91,7 @@ subroutine budgetobject_cr(this, name) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- initialize variables this%name = name @@ -142,31 +142,31 @@ subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto, & this%nsto = nsto ! ! -- allocate space for budterm - allocate(this%budterm(nbudterm)) + allocate (this%budterm(nbudterm)) ! ! -- Set the budget type to name bdtype = this%name ! ! -- Set the budget dimension - if(present(bddim_opt)) then + if (present(bddim_opt)) then bddim = bddim_opt else bddim = 'L**3' - endif + end if ! ! -- Set the budget zone - if(present(bdzone_opt)) then + if (present(bdzone_opt)) then bdzone = bdzone_opt else bdzone = 'ENTIRE MODEL' - endif + end if ! ! -- Set the label title - if(present(labeltitle_opt)) then + if (present(labeltitle_opt)) then labeltitle = labeltitle_opt else labeltitle = 'PACKAGE NAME' - endif + end if ! ! -- setup the budget table object call this%budtable%budget_df(nbudterm, bdtype, bddim, labeltitle, bdzone) @@ -179,7 +179,7 @@ subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto, & ! -- Return return end subroutine budgetobject_df - + subroutine flowtable_df(this, iout, cellids) ! ****************************************************************************** ! flowtable_df -- Define the new flow table object @@ -215,9 +215,9 @@ subroutine flowtable_df(this, iout, cellids) end if ! ! -- allocate scalars - allocate(this%add_cellids) - allocate(this%icellid) - allocate(this%nflowterms) + allocate (this%add_cellids) + allocate (this%icellid) + allocate (this%nflowterms) ! ! -- initialize scalars this%add_cellids = add_cellids @@ -250,11 +250,11 @@ subroutine flowtable_df(this, iout, cellids) end do ! ! -- allocate arrays - allocate(this%istart(this%nflowterms)) - allocate(this%iflowterms(this%nflowterms)) + allocate (this%istart(this%nflowterms)) + allocate (this%iflowterms(this%nflowterms)) ! ! -- set up flow tableobj - title = trim(this%name) // ' PACKAGE - SUMMARY OF FLOWS FOR ' // & + title = trim(this%name)//' PACKAGE - SUMMARY OF FLOWS FOR '// & 'EACH CONTROL VOLUME' call table_cr(this%flowtab, this%name, title) call this%flowtab%table_df(this%ncv, maxcol, iout, transient=.TRUE.) @@ -298,7 +298,7 @@ subroutine flowtable_df(this, iout, cellids) ! -- Return return end subroutine flowtable_df - + subroutine accumulate_terms(this) ! ****************************************************************************** ! accumulate_terms -- add up accumulators and submit to budget table @@ -311,7 +311,7 @@ subroutine accumulate_terms(this) ! -- dummy class(BudgetObjectType) :: this ! -- dummy - character(len=LENBUDTXT) :: flowtype + character(len=LENBUDTXT) :: flowtype integer(I4B) :: i real(DP) :: ratin, ratout ! ------------------------------------------------------------------------------ @@ -404,9 +404,9 @@ subroutine write_flowtable(this, dis, kstp, kper, cellidstr) cellid = cellidstr(icv) else ! - ! -- Determine the cellid for this entry. The cellid, such as + ! -- Determine the cellid for this entry. The cellid, such as ! (1, 10, 10), is assumed to be in the id2 column of this budterm. - j = this%icellid + j = this%icellid idx = this%iflowterms(j) i = this%istart(j) id2 = this%budterm(idx)%get_id2(i) @@ -427,7 +427,7 @@ subroutine write_flowtable(this, dis, kstp, kper, cellidstr) qinflow = DZERO qoutflow = DZERO ! - ! -- determine the index, flowtype and length of + ! -- determine the index, flowtype and length of ! the flowterm idx = this%iflowterms(j) flowtype = this%budterm(idx)%get_flowtype() @@ -438,7 +438,7 @@ subroutine write_flowtable(this, dis, kstp, kper, cellidstr) colterm: do i = this%istart(j), nlist id1 = this%budterm(idx)%get_id1(i) if (this%budterm(idx)%ordered_id1) then - if(id1 > icv) then + if (id1 > icv) then this%istart(j) = i exit colterm end if @@ -497,11 +497,11 @@ subroutine write_budtable(this, kstp, kper, iout, ibudfl, totim) ! -- modules ! -- dummy class(BudgetObjectType) :: this - integer(I4B),intent(in) :: kstp - integer(I4B),intent(in) :: kper - integer(I4B),intent(in) :: iout - integer(I4B),intent(in) :: ibudfl - real(DP),intent(in) :: totim + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: ibudfl + real(DP), intent(in) :: totim ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -514,7 +514,7 @@ subroutine write_budtable(this, kstp, kper, iout, ibudfl, totim) ! -- return return end subroutine write_budtable - + subroutine save_flows(this, dis, ibinun, kstp, kper, delt, & pertim, totim, iout) ! ****************************************************************************** @@ -547,7 +547,7 @@ subroutine save_flows(this, dis, ibinun, kstp, kper, delt, & ! -- return return end subroutine save_flows - + subroutine read_flows(this, dis, ibinun) ! ****************************************************************************** ! read_flows -- Read froms from a binary file into this BudgetObjectType @@ -579,7 +579,7 @@ subroutine read_flows(this, dis, ibinun) ! -- return return end subroutine read_flows - + subroutine budgetobject_da(this) ! ****************************************************************************** ! budgetobject_da -- deallocate @@ -601,27 +601,27 @@ subroutine budgetobject_da(this) ! ! -- destroy the flow table if (associated(this%flowtab)) then - deallocate(this%add_cellids) - deallocate(this%icellid) - deallocate(this%nflowterms) - deallocate(this%istart) - deallocate(this%iflowterms) + deallocate (this%add_cellids) + deallocate (this%icellid) + deallocate (this%nflowterms) + deallocate (this%istart) + deallocate (this%iflowterms) call this%flowtab%table_da() - deallocate(this%flowtab) - nullify(this%flowtab) + deallocate (this%flowtab) + nullify (this%flowtab) end if ! ! -- destroy the budget object table if (associated(this%budtable)) then call this%budtable%budget_da() - deallocate(this%budtable) - nullify(this%budtable) + deallocate (this%budtable) + nullify (this%budtable) end if ! ! -- Return return end subroutine budgetobject_da - + subroutine budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2) ! ****************************************************************************** ! budgetobject_cr_bfr -- Create a new budget object from a binary flow file @@ -681,7 +681,7 @@ subroutine budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2) ! -- Return return end subroutine budgetobject_cr_bfr - + subroutine bfr_init(this, ibinun, ncv, nbudterm, iout) ! ****************************************************************************** ! bfr_init -- initialize the budget file reader @@ -700,14 +700,14 @@ subroutine bfr_init(this, ibinun, ncv, nbudterm, iout) ! ------------------------------------------------------------------------------ ! ! -- initialize budget file reader - allocate(this%bfr) + allocate (this%bfr) call this%bfr%initialize(ibinun, iout, ncv) nbudterm = this%bfr%nbudterms ! ! -- Return return end subroutine bfr_init - + subroutine bfr_advance(this, dis, iout) ! ****************************************************************************** ! bfr_advance -- copy the information from the binary file into budterms @@ -723,10 +723,10 @@ subroutine bfr_advance(this, dis, iout) integer(I4B), intent(in) :: iout ! -- dummy logical :: readnext - character(len=*), parameter :: fmtkstpkper = & - "(1x,/1x, a, ' READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" + character(len=*), parameter :: fmtkstpkper = & + &"(1x,/1x, a, ' READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" character(len=*), parameter :: fmtbudkstpkper = & - "(1x,/1x, a, ' SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & + "(1x,/1x, a, ' SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & &i0, ' TO BUDGET FILE TERMS FROM KSTP ', i0, ' AND KPER ', i0)" ! ------------------------------------------------------------------------------ ! @@ -743,28 +743,28 @@ subroutine bfr_advance(this, dis, iout) else if (this%bfr%kpernext == kper + 1 .and. this%bfr%kstpnext == 1) & readnext = .false. - endif - endif + end if + end if ! ! -- Read the next record if (readnext) then ! ! -- Write the current time step and stress period if (iout > 0) & - write(iout, fmtkstpkper) this%name, kstp, kper + write (iout, fmtkstpkper) this%name, kstp, kper ! ! -- read flows from the binary file and copy them into this%budterm(:) call this%fill_from_bfr(dis, iout) else if (iout > 0) & - write(iout, fmtbudkstpkper) trim(this%name), kstp, kper, & - this%bfr%kstp, this%bfr%kper - endif + write (iout, fmtbudkstpkper) trim(this%name), kstp, kper, & + this%bfr%kstp, this%bfr%kper + end if ! ! -- Return return end subroutine bfr_advance - + subroutine fill_from_bfr(this, dis, iout) ! ****************************************************************************** ! fill_from_bfr -- copy the information from the binary file into budterms @@ -791,5 +791,5 @@ subroutine fill_from_bfr(this, dis, iout) ! -- Return return end subroutine fill_from_bfr - -end module BudgetObjectModule \ No newline at end of file + +end module BudgetObjectModule diff --git a/src/Utilities/BudgetTerm.f90 b/src/Utilities/BudgetTerm.f90 index 79ca70697fd..e3aeb13a67a 100644 --- a/src/Utilities/BudgetTerm.f90 +++ b/src/Utilities/BudgetTerm.f90 @@ -1,6 +1,6 @@ ! A budget term is the information needed to describe flow. -! The budget object contains an array of budget terms. -! For an advanced package. The budget object describes all of +! The budget object contains an array of budget terms. +! For an advanced package. The budget object describes all of ! the flows. module BudgetTermModule @@ -12,29 +12,29 @@ module BudgetTermModule implicit none public :: BudgetTermType - + type :: BudgetTermType - - character(len=LENBUDTXT) :: flowtype ! type of flow (WEL, DRN, ...) - character(len=LENBUDTXT) :: text1id1 ! model - character(len=LENBUDTXT) :: text2id1 ! to model - character(len=LENBUDTXT) :: text1id2 ! package/model - character(len=LENBUDTXT) :: text2id2 ! to package/model - character(len=LENBUDTXT), dimension(:), pointer :: auxtxt => null() ! name of auxiliary variables - integer(I4B) :: maxlist ! allocated size of arrays - integer(I4B) :: naux ! number of auxiliary variables - integer(I4B) :: nlist ! size of arrays for this period - logical :: olconv1 = .false. ! convert id1 to user node upon output - logical :: olconv2 = .false. ! convert id2 to user node upon output - logical :: ordered_id1 ! the id1 array is ordered sequentially - integer(I4B), dimension(:), pointer :: id1 => null() ! first id (maxlist) - integer(I4B), dimension(:), pointer :: id2 => null() ! second id (maxlist) - real(DP), dimension(:), pointer :: flow => null() ! point this to simvals or simtomvr (maxlist) - real(DP), dimension(:, :), pointer :: auxvar => null() ! auxiliary variables (naux, maxlist) - integer(I4B) :: icounter ! counter variable - + + character(len=LENBUDTXT) :: flowtype ! type of flow (WEL, DRN, ...) + character(len=LENBUDTXT) :: text1id1 ! model + character(len=LENBUDTXT) :: text2id1 ! to model + character(len=LENBUDTXT) :: text1id2 ! package/model + character(len=LENBUDTXT) :: text2id2 ! to package/model + character(len=LENBUDTXT), dimension(:), pointer :: auxtxt => null() ! name of auxiliary variables + integer(I4B) :: maxlist ! allocated size of arrays + integer(I4B) :: naux ! number of auxiliary variables + integer(I4B) :: nlist ! size of arrays for this period + logical :: olconv1 = .false. ! convert id1 to user node upon output + logical :: olconv2 = .false. ! convert id2 to user node upon output + logical :: ordered_id1 ! the id1 array is ordered sequentially + integer(I4B), dimension(:), pointer :: id1 => null() ! first id (maxlist) + integer(I4B), dimension(:), pointer :: id2 => null() ! second id (maxlist) + real(DP), dimension(:), pointer :: flow => null() ! point this to simvals or simtomvr (maxlist) + real(DP), dimension(:, :), pointer :: auxvar => null() ! auxiliary variables (naux, maxlist) + integer(I4B) :: icounter ! counter variable + contains - + procedure :: initialize procedure :: allocate_arrays procedure :: reset @@ -49,11 +49,11 @@ module BudgetTermModule procedure :: read_flows procedure :: fill_from_bfr procedure :: deallocate_arrays - + end type BudgetTermType - contains - +contains + subroutine initialize(this, flowtype, text1id1, text2id1, & text1id2, text2id2, maxlist, olconv1, olconv2, & naux, auxtxt, ordered_id1) @@ -94,7 +94,7 @@ subroutine initialize(this, flowtype, text1id1, text2id1, & this%ordered_id1 = .true. if (present(ordered_id1)) this%ordered_id1 = ordered_id1 end subroutine initialize - + subroutine allocate_arrays(this) ! ****************************************************************************** ! allocate_arrays -- allocate budget term arrays @@ -106,13 +106,13 @@ subroutine allocate_arrays(this) ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) - allocate(this%auxtxt(this%naux)) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) + allocate (this%auxtxt(this%naux)) end subroutine allocate_arrays - + subroutine deallocate_arrays(this) ! ****************************************************************************** ! deallocate_arrays -- deallocate budget term arrays @@ -124,13 +124,13 @@ subroutine deallocate_arrays(this) ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - deallocate(this%auxtxt) + deallocate (this%id1) + deallocate (this%id2) + deallocate (this%flow) + deallocate (this%auxvar) + deallocate (this%auxtxt) end subroutine deallocate_arrays - + subroutine reset(this, nlist) ! ****************************************************************************** ! reset -- reset the budget term and counter so terms can be updated @@ -146,10 +146,10 @@ subroutine reset(this, nlist) this%nlist = nlist this%icounter = 1 end subroutine reset - + subroutine update_term(this, id1, id2, flow, auxvar) ! ****************************************************************************** -! update_term -- replace the terms in position this%icounter +! update_term -- replace the terms in position this%icounter ! for id1, id2, flow, and aux ! ****************************************************************************** ! @@ -169,7 +169,7 @@ subroutine update_term(this, id1, id2, flow, auxvar) if (present(auxvar)) this%auxvar(:, this%icounter) = auxvar(1:this%naux) this%icounter = this%icounter + 1 end subroutine update_term - + subroutine accumulate_flow(this, ratin, ratout) ! ****************************************************************************** ! accumulate_flow -- calculate ratin and ratout for all the flow terms @@ -197,7 +197,7 @@ subroutine accumulate_flow(this, ratin, ratout) end if end do end subroutine accumulate_flow - + subroutine save_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim, & iout) ! ****************************************************************************** @@ -254,7 +254,7 @@ subroutine save_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim, & olconv2=this%olconv2) end do end subroutine save_flows - + function get_nlist(this) result(nlist) ! ****************************************************************************** ! get_nlist -- get the number of entries for the stress period @@ -264,7 +264,7 @@ function get_nlist(this) result(nlist) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - integer(I4B) :: nlist + integer(I4B) :: nlist ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ @@ -273,7 +273,7 @@ function get_nlist(this) result(nlist) ! -- return return end function get_nlist - + function get_flowtype(this) result(flowtype) ! ****************************************************************************** ! get_flowtype -- get the flowtype for the budget term @@ -283,7 +283,7 @@ function get_flowtype(this) result(flowtype) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - character(len=LENBUDTXT) :: flowtype + character(len=LENBUDTXT) :: flowtype ! -- dummy class(BudgetTermType) :: this ! ------------------------------------------------------------------------------ @@ -292,7 +292,7 @@ function get_flowtype(this) result(flowtype) ! -- return return end function get_flowtype - + function get_id1(this, icount) result(id1) ! ****************************************************************************** ! get_id1 -- get id1(icount) for the budget term @@ -302,7 +302,7 @@ function get_id1(this, icount) result(id1) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - integer(I4B) :: id1 + integer(I4B) :: id1 ! -- dummy class(BudgetTermType) :: this integer(I4B), intent(in) :: icount @@ -312,7 +312,7 @@ function get_id1(this, icount) result(id1) ! -- return return end function get_id1 - + function get_id2(this, icount) result(id2) ! ****************************************************************************** ! get_id2 -- get id2(icount) for the budget term @@ -322,7 +322,7 @@ function get_id2(this, icount) result(id2) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - integer(I4B) :: id2 + integer(I4B) :: id2 ! -- dummy class(BudgetTermType) :: this integer(I4B), intent(in) :: icount @@ -332,7 +332,7 @@ function get_id2(this, icount) result(id2) ! -- return return end function get_id2 - + function get_flow(this, icount) result(flow) ! ****************************************************************************** ! get_flow -- get flow(icount) for the budget term @@ -342,7 +342,7 @@ function get_flow(this, icount) result(flow) ! ------------------------------------------------------------------------------ ! -- modules ! -- return - real(DP) :: flow + real(DP) :: flow ! -- dummy class(BudgetTermType) :: this integer(I4B), intent(in) :: icount @@ -352,7 +352,7 @@ function get_flow(this, icount) result(flow) ! -- return return end function get_flow - + subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) ! ****************************************************************************** ! read_flows -- read flows from a binary file @@ -377,48 +377,48 @@ subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) integer(I4B) :: n2 real(DP) :: q ! ------------------------------------------------------------------------------ - read(ibinun) kstp, kper, this%flowtype, this%nlist, idum1, idum2 - read(ibinun) imeth, delt, pertim, totim - read(ibinun) this%text1id1 - read(ibinun) this%text2id1 - read(ibinun) this%text1id2 - read(ibinun) this%text2id2 - read(ibinun) this%naux + read (ibinun) kstp, kper, this%flowtype, this%nlist, idum1, idum2 + read (ibinun) imeth, delt, pertim, totim + read (ibinun) this%text1id1 + read (ibinun) this%text2id1 + read (ibinun) this%text1id2 + read (ibinun) this%text2id2 + read (ibinun) this%naux this%naux = this%naux - 1 if (.not. associated(this%auxtxt)) then - allocate(this%auxtxt(this%naux)) + allocate (this%auxtxt(this%naux)) else if (size(this%auxtxt) /= this%naux) then - deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) + deallocate (this%auxtxt) + allocate (this%auxtxt(this%naux)) end if end if - if (this%naux > 0) read(ibinun) (this%auxtxt(j), j = 1, this%naux) - read(ibinun) this%nlist + if (this%naux > 0) read (ibinun) (this%auxtxt(j), j=1, this%naux) + read (ibinun) this%nlist if (.not. associated(this%id1)) then this%maxlist = this%nlist - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) else if (this%nlist > this%maxlist) then this%maxlist = this%nlist - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + deallocate (this%id1) + deallocate (this%id2) + deallocate (this%flow) + deallocate (this%auxvar) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) end if end if do i = 1, this%nlist - read(ibinun) n1 - read(ibinun) n2 - read(ibinun) q - read(ibinun) (this%auxvar(j, i), j = 1, this%naux) + read (ibinun) n1 + read (ibinun) n2 + read (ibinun) q + read (ibinun) (this%auxvar(j, i), j=1, this%naux) if (this%olconv1) n1 = dis%get_nodenumber(n1, 0) if (this%olconv2) n2 = dis%get_nodenumber(n2, 0) this%id1(i) = n1 @@ -426,7 +426,7 @@ subroutine read_flows(this, dis, ibinun, kstp, kper, delt, pertim, totim) this%flow(i) = q end do end subroutine read_flows - + subroutine fill_from_bfr(this, bfr, dis) ! ****************************************************************************** ! fill_from_bfr -- copy the flow from the binary file reader into this budterm @@ -453,32 +453,32 @@ subroutine fill_from_bfr(this, bfr, dis) this%text2id2 = bfr%dstpackagename this%naux = bfr%naux if (.not. associated(this%auxtxt)) then - allocate(this%auxtxt(this%naux)) + allocate (this%auxtxt(this%naux)) else if (size(this%auxtxt) /= this%naux) then - deallocate(this%auxtxt) - allocate(this%auxtxt(this%naux)) + deallocate (this%auxtxt) + allocate (this%auxtxt(this%naux)) end if end if if (this%naux > 0) this%auxtxt(:) = bfr%auxtxt(:) this%nlist = bfr%nlist if (.not. associated(this%id1)) then this%maxlist = this%nlist - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) else if (this%nlist > this%maxlist) then this%maxlist = this%nlist - deallocate(this%id1) - deallocate(this%id2) - deallocate(this%flow) - deallocate(this%auxvar) - allocate(this%id1(this%maxlist)) - allocate(this%id2(this%maxlist)) - allocate(this%flow(this%maxlist)) - allocate(this%auxvar(this%naux, this%maxlist)) + deallocate (this%id1) + deallocate (this%id2) + deallocate (this%flow) + deallocate (this%auxvar) + allocate (this%id1(this%maxlist)) + allocate (this%id2(this%maxlist)) + allocate (this%flow(this%maxlist)) + allocate (this%auxvar(this%naux, this%maxlist)) end if end if do i = 1, this%nlist @@ -493,5 +493,5 @@ subroutine fill_from_bfr(this, bfr, dis) this%flow(i) = q end do end subroutine fill_from_bfr - -end module BudgetTermModule \ No newline at end of file + +end module BudgetTermModule diff --git a/src/Utilities/Constants.f90 b/src/Utilities/Constants.f90 index 0e64becc32e..b23a28e129c 100644 --- a/src/Utilities/Constants.f90 +++ b/src/Utilities/Constants.f90 @@ -10,167 +10,172 @@ module ConstantsModule use KindModule public ! -- constants - integer(I4B), parameter :: IUSERFORMATSTRIP = -99 !< default user format strip - integer(I4B), parameter :: IUSERFORMATWRAP = 99 !< default user format wrap - integer(I4B), parameter :: LENBIGLINE = 5000 !< maximum length of a big line - integer(I4B), parameter :: LENHUGELINE = 50000 !< maximum length of a huge line - integer(I4B), parameter :: LENVARNAME = 16 !< maximum length of a variable name - integer(I4B), parameter :: LENCOMPONENTNAME = 16 !< maximum length of a component name - integer(I4B), parameter :: LENSOLUTIONNAME = LENCOMPONENTNAME !< maximum length of the solution name - integer(I4B), parameter :: LENMODELNAME = LENCOMPONENTNAME !< maximum length of the model name - integer(I4B), parameter :: LENPACKAGENAME = LENCOMPONENTNAME !< maximum length of the package name - integer(I4B), parameter :: LENEXCHANGENAME = LENCOMPONENTNAME !< maximum length of the exchange name - integer(I4B), parameter :: LENBUDROWLABEL = 2 * LENPACKAGENAME + 1 !< maximum length of the rowlabel string used in the budget table - integer(I4B), parameter :: LENMEMSEPARATOR = 1 !< maximum length of the memory path separator used, currently a '/' - integer(I4B), parameter :: LENMEMPATH = 2*LENCOMPONENTNAME + LENMEMSEPARATOR !< maximum length of the memory path - integer(I4B), parameter :: LENMEMADDRESS = LENMEMPATH + LENMEMSEPARATOR + LENVARNAME !< maximum length of the full memory address, including variable name - integer(I4B), parameter :: LENAUXNAME = 16 !< maximum length of a aux variable - integer(I4B), parameter :: LENBOUNDNAME = 40 !< maximum length of a bound name - integer(I4B), parameter :: LENBUDTXT = 16 !< maximum length of a budget component names - integer(I4B), parameter :: LENPACKAGETYPE = 7 !< maximum length of a package type (DIS6, SFR6, CSUB6, etc.) - integer(I4B), parameter :: LENFTYPE = 5 !< maximum length of a package type (DIS, WEL, OC, etc.) - integer(I4B), parameter :: LENOBSNAME = 40 !< maximum length of a observation name - integer(I4B), parameter :: LENOBSTYPE = 30 !< maximum length of a observation type (CONTINUOUS) - integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME !< maximum length of a time series name - integer(I4B), parameter :: LENTIMESERIESTEXT = 16 !< maximum length of a time series text - integer(I4B), parameter :: LENDATETIME = 30 !< maximum length of a date time string - integer(I4B), parameter :: LINELENGTH = 300 !< maximum length of a standard line - integer(I4B), parameter :: LENLISTLABEL = 500 !< maximum length of a llist label - integer(I4B), parameter :: MAXCHARLEN = max(1000, LENBIGLINE) !< maximum length of char string - integer(I4B), parameter :: MAXOBSTYPES = 100 !< maximum number of observation types - integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 !< named bound flag - integer(I4B), parameter :: LENPAKLOC = 34 !< maximum length of a package location - integer(I4B), parameter :: IZERO = 0 !< integer constant zero + integer(I4B), parameter :: IUSERFORMATSTRIP = -99 !< default user format strip + integer(I4B), parameter :: IUSERFORMATWRAP = 99 !< default user format wrap + integer(I4B), parameter :: LENBIGLINE = 5000 !< maximum length of a big line + integer(I4B), parameter :: LENHUGELINE = 50000 !< maximum length of a huge line + integer(I4B), parameter :: LENVARNAME = 16 !< maximum length of a variable name + integer(I4B), parameter :: LENCOMPONENTNAME = 16 !< maximum length of a component name + integer(I4B), parameter :: LENSOLUTIONNAME = LENCOMPONENTNAME !< maximum length of the solution name + integer(I4B), parameter :: LENMODELNAME = LENCOMPONENTNAME !< maximum length of the model name + integer(I4B), parameter :: LENPACKAGENAME = LENCOMPONENTNAME !< maximum length of the package name + integer(I4B), parameter :: LENEXCHANGENAME = LENCOMPONENTNAME !< maximum length of the exchange name + integer(I4B), parameter :: LENBUDROWLABEL = 2 * LENPACKAGENAME + 1 !< maximum length of the rowlabel string used in the budget table + integer(I4B), parameter :: LENMEMSEPARATOR = 1 !< maximum length of the memory path separator used, currently a '/' + integer(I4B), parameter :: LENMEMPATH = & + 2 * LENCOMPONENTNAME + & + LENMEMSEPARATOR !< maximum length of the memory path + integer(I4B), parameter :: LENMEMADDRESS = & + LENMEMPATH + & + LENMEMSEPARATOR + & + LENVARNAME !< maximum length of the full memory address, including variable name + integer(I4B), parameter :: LENAUXNAME = 16 !< maximum length of a aux variable + integer(I4B), parameter :: LENBOUNDNAME = 40 !< maximum length of a bound name + integer(I4B), parameter :: LENBUDTXT = 16 !< maximum length of a budget component names + integer(I4B), parameter :: LENPACKAGETYPE = 7 !< maximum length of a package type (DIS6, SFR6, CSUB6, etc.) + integer(I4B), parameter :: LENFTYPE = 5 !< maximum length of a package type (DIS, WEL, OC, etc.) + integer(I4B), parameter :: LENOBSNAME = 40 !< maximum length of a observation name + integer(I4B), parameter :: LENOBSTYPE = 30 !< maximum length of a observation type (CONTINUOUS) + integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME !< maximum length of a time series name + integer(I4B), parameter :: LENTIMESERIESTEXT = 16 !< maximum length of a time series text + integer(I4B), parameter :: LENDATETIME = 30 !< maximum length of a date time string + integer(I4B), parameter :: LINELENGTH = 300 !< maximum length of a standard line + integer(I4B), parameter :: LENLISTLABEL = 500 !< maximum length of a llist label + integer(I4B), parameter :: MAXCHARLEN = max(1000, LENBIGLINE) !< maximum length of char string + integer(I4B), parameter :: MAXOBSTYPES = 100 !< maximum number of observation types + integer(I4B), parameter :: NAMEDBOUNDFLAG = -9 !< named bound flag + integer(I4B), parameter :: LENPAKLOC = 34 !< maximum length of a package location + integer(I4B), parameter :: IZERO = 0 !< integer constant zero ! ! -- file constants - integer(I4B), parameter :: IUOC = 999 !< open/close file unit number - integer(I4B), parameter :: IUSTART = 1000 !< starting file unit number - integer(I4B), parameter :: IULAST = 10000 !< maximum file unit number (this allows for 9000 open files) + integer(I4B), parameter :: IUOC = 999 !< open/close file unit number + integer(I4B), parameter :: IUSTART = 1000 !< starting file unit number + integer(I4B), parameter :: IULAST = 10000 !< maximum file unit number (this allows for 9000 open files) ! ! -- memory manager constants - integer(I4B), public, parameter :: MAXMEMRANK = 3 !< maximum memory manager length (up to 3-dimensional arrays) - integer(I4B), public, parameter :: LENMEMTYPE = 50 !< maximum length of a memory manager type + integer(I4B), public, parameter :: MAXMEMRANK = 3 !< maximum memory manager length (up to 3-dimensional arrays) + integer(I4B), public, parameter :: LENMEMTYPE = 50 !< maximum length of a memory manager type ! ! -- real constants - real(DP), parameter :: DZERO = 0.0_DP !< real constant zero - real(DP), parameter :: DQUARTER = 0.25_DP !< real constant 1/3 - real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP !< real constant 1/3 - real(DP), parameter :: DHALF = 0.5_DP !< real constant 1/2 - real(DP), parameter :: DP6 = 0.6_DP !< real constant 3/5 - real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP !< real constant 2/3 - real(DP), parameter :: DP7 = 0.7_DP !< real constant 7/10 - real(DP), parameter :: DP9 = 0.9_DP !< real constant 9/10 - real(DP), parameter :: DP99 = 0.99_DP !< real constant 99/100 - real(DP), parameter :: DP999 = 0.999_DP !< real constant 999/1000 - - real(DP), parameter :: DONE = 1.0_DP !< real constant 1 - real(DP), parameter :: D1P1 = 1.1_DP !< real constant 1.1 - real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP !< real constant 5/3 - real(DP), parameter :: DTWO = 2.0_DP !< real constant 2 - real(DP), parameter :: DTHREE = 3.0_DP !< real constant 3 - real(DP), parameter :: DFOUR = 4.0_DP !< real constant 4 - real(DP), parameter :: DSIX = 6.0_DP !< real constant 6 - real(DP), parameter :: DEIGHT = 8.0_DP !< real constant 8 - real(DP), parameter :: DTEN = 1.0e1_DP !< real constant 10 - real(DP), parameter :: DHUNDRED = 1.0e2_DP !< real constant 100 - - real(DP), parameter :: DEP3 = 1.0e3_DP !< real constant 1000 - real(DP), parameter :: DEP6 = 1.0e6_DP !< real constant 1000000 - real(DP), parameter :: DEP9 = 1.0e9_DP !< real constant 1e9 - real(DP), parameter :: DEP20 = 1.0e20_DP !< real constant 1e20 - - real(DP), parameter :: DHNOFLO = 1.e30_DP !< real no flow constant - real(DP), parameter :: DHDRY = -1.e30_DP !< real dry cell constant - real(DP), parameter :: DNODATA = 3.0e30_DP !< real no data constant - - real(DP), parameter :: DEM1 = 1.0e-1_DP !< real constant 1e-1 - real(DP), parameter :: D5EM2 = 5.0e-2_DP !< real constant 5e-2 - real(DP), parameter :: DEM2 = 1.0e-2_DP !< real constant 1e-2 - real(DP), parameter :: DEM3 = 1.0e-3_DP !< real constant 1e-3 - real(DP), parameter :: DEM4 = 1.0e-4_DP !< real constant 1e-4 - real(DP), parameter :: DEM5 = 1.0e-5_DP !< real constant 1e-5 - real(DP), parameter :: DEM6 = 1.0e-6_DP !< real constant 1e-6 - real(DP), parameter :: DEM7 = 1.0e-7_DP !< real constant 1e-7 - real(DP), parameter :: DEM8 = 1.0e-8_DP !< real constant 1e-8 - real(DP), parameter :: DEM9 = 1.0e-9_DP !< real constant 1e-9 - real(DP), parameter :: DEM10 = 1.0e-10_DP !< real constant 1e-10 - real(DP), parameter :: DEM12 = 1.0e-12_DP !< real constant 1e-12 - real(DP), parameter :: DEM14 = 1.0e-14_DP !< real constant 1e-14 - real(DP), parameter :: DEM15 = 1.0e-15_DP !< real constant 1e-15 - real(DP), parameter :: DEM20 = 1.0e-20_DP !< real constant 1e-20 - real(DP), parameter :: DEM30 = 1.0e-30_DP !< real constant 1e-30 - - real(DP), parameter :: DPREC = EPSILON(1.0_DP) !< real constant machine precision - real(DP), parameter :: DSAME = DHUNDRED * DPREC !< real constant for values that - !! are consider the same based on machine precision - - real(DP), parameter :: DLNLOW = 0.995_DP !< real constant low ratio used to calculate log mean of K - real(DP), parameter :: DLNHIGH = 1.005_DP !< real constant high ratio used to calculate log mean of K - - real(DP), parameter :: DPI = DFOUR * ATAN(DONE) !< real constant \f$\pi\f$ - real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE) !< real constant \f$2 \pi\f$ - real(DP), parameter :: DPIO180 = datan(DONE)/4.5d1 !< real constant \f$\pi/180\f$ - - real(DP), parameter :: DGRAVITY = 9.80665_DP !< real constant gravitational acceleration (m/(s s)) - real(DP), parameter :: DCD = 0.61_DP !< real constant weir coefficient in SI units - - character(len=10), dimension(3, 3), parameter :: cidxnames = reshape ( & - [ ' NODE', ' ', ' ', & - ' LAYER', ' CELL2D', ' ', & - ' LAYER', ' ROW', ' COL'], [3,3]) !< cellid labels for DIS, DISV, and DISU discretizations - - + real(DP), parameter :: DZERO = 0.0_DP !< real constant zero + real(DP), parameter :: DQUARTER = 0.25_DP !< real constant 1/3 + real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP !< real constant 1/3 + real(DP), parameter :: DHALF = 0.5_DP !< real constant 1/2 + real(DP), parameter :: DP6 = 0.6_DP !< real constant 3/5 + real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP !< real constant 2/3 + real(DP), parameter :: DP7 = 0.7_DP !< real constant 7/10 + real(DP), parameter :: DP9 = 0.9_DP !< real constant 9/10 + real(DP), parameter :: DP99 = 0.99_DP !< real constant 99/100 + real(DP), parameter :: DP999 = 0.999_DP !< real constant 999/1000 + + real(DP), parameter :: DONE = 1.0_DP !< real constant 1 + real(DP), parameter :: D1P1 = 1.1_DP !< real constant 1.1 + real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP !< real constant 5/3 + real(DP), parameter :: DTWO = 2.0_DP !< real constant 2 + real(DP), parameter :: DTHREE = 3.0_DP !< real constant 3 + real(DP), parameter :: DFOUR = 4.0_DP !< real constant 4 + real(DP), parameter :: DSIX = 6.0_DP !< real constant 6 + real(DP), parameter :: DEIGHT = 8.0_DP !< real constant 8 + real(DP), parameter :: DTEN = 1.0e1_DP !< real constant 10 + real(DP), parameter :: DHUNDRED = 1.0e2_DP !< real constant 100 + + real(DP), parameter :: DEP3 = 1.0e3_DP !< real constant 1000 + real(DP), parameter :: DEP6 = 1.0e6_DP !< real constant 1000000 + real(DP), parameter :: DEP9 = 1.0e9_DP !< real constant 1e9 + real(DP), parameter :: DEP20 = 1.0e20_DP !< real constant 1e20 + + real(DP), parameter :: DHNOFLO = 1.e30_DP !< real no flow constant + real(DP), parameter :: DHDRY = -1.e30_DP !< real dry cell constant + real(DP), parameter :: DNODATA = 3.0e30_DP !< real no data constant + + real(DP), parameter :: DEM1 = 1.0e-1_DP !< real constant 1e-1 + real(DP), parameter :: D5EM2 = 5.0e-2_DP !< real constant 5e-2 + real(DP), parameter :: DEM2 = 1.0e-2_DP !< real constant 1e-2 + real(DP), parameter :: DEM3 = 1.0e-3_DP !< real constant 1e-3 + real(DP), parameter :: DEM4 = 1.0e-4_DP !< real constant 1e-4 + real(DP), parameter :: DEM5 = 1.0e-5_DP !< real constant 1e-5 + real(DP), parameter :: DEM6 = 1.0e-6_DP !< real constant 1e-6 + real(DP), parameter :: DEM7 = 1.0e-7_DP !< real constant 1e-7 + real(DP), parameter :: DEM8 = 1.0e-8_DP !< real constant 1e-8 + real(DP), parameter :: DEM9 = 1.0e-9_DP !< real constant 1e-9 + real(DP), parameter :: DEM10 = 1.0e-10_DP !< real constant 1e-10 + real(DP), parameter :: DEM12 = 1.0e-12_DP !< real constant 1e-12 + real(DP), parameter :: DEM14 = 1.0e-14_DP !< real constant 1e-14 + real(DP), parameter :: DEM15 = 1.0e-15_DP !< real constant 1e-15 + real(DP), parameter :: DEM20 = 1.0e-20_DP !< real constant 1e-20 + real(DP), parameter :: DEM30 = 1.0e-30_DP !< real constant 1e-30 + + real(DP), parameter :: DPREC = EPSILON(1.0_DP) !< real constant machine precision + real(DP), parameter :: DSAME = DHUNDRED * DPREC !< real constant for values that are considered + !! the same based on machine precision + + real(DP), parameter :: DLNLOW = 0.995_DP !< real constant low ratio used to calculate log mean of K + real(DP), parameter :: DLNHIGH = 1.005_DP !< real constant high ratio used to calculate log mean of K + + real(DP), parameter :: DPI = DFOUR * ATAN(DONE) !< real constant \f$\pi\f$ + real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE) !< real constant \f$2 \pi\f$ + real(DP), parameter :: DPIO180 = datan(DONE) / 4.5d1 !< real constant \f$\pi/180\f$ + + real(DP), parameter :: DGRAVITY = 9.80665_DP !< real constant gravitational acceleration (m/(s s)) + real(DP), parameter :: DCD = 0.61_DP !< real constant weir coefficient in SI units + + character(len=10), dimension(3, 3), parameter :: & + cidxnames = reshape( & + [' NODE', ' ', ' ', & + ' LAYER', ' CELL2D', ' ', & + ' LAYER', ' ROW', ' COL'], [3, 3]) !< cellid labels for DIS, DISV, and DISU discretizations + ! -- enumerator used with TimeSeriesType ENUM, BIND(C) - ENUMERATOR :: UNDEFINED=0 !< 0 - ENUMERATOR :: STEPWISE=1 !< 1 - ENUMERATOR :: LINEAR=2 !< 2 - ENUMERATOR :: LINEAREND=3 !< 3 - END ENUM + ENUMERATOR :: UNDEFINED = 0 !< 0 + ENUMERATOR :: STEPWISE = 1 !< 1 + ENUMERATOR :: LINEAR = 2 !< 2 + ENUMERATOR :: LINEAREND = 3 !< 3 + END ENUM ! -- enumerator used with table objects ENUM, BIND(C) - ENUMERATOR :: TABLEFT=0 !< 0 - ENUMERATOR :: TABCENTER=1 !< 1 - ENUMERATOR :: TABRIGHT=2 !< 2 + ENUMERATOR :: TABLEFT = 0 !< 0 + ENUMERATOR :: TABCENTER = 1 !< 1 + ENUMERATOR :: TABRIGHT = 2 !< 2 END ENUM ! -- enumerator used to define table column data type ENUM, BIND(C) - ENUMERATOR :: TABSTRING=0 !< 0 - ENUMERATOR :: TABUCSTRING=1 !< 1 - ENUMERATOR :: TABINTEGER=2 !< 2 - ENUMERATOR :: TABREAL=3 !< 3 + ENUMERATOR :: TABSTRING = 0 !< 0 + ENUMERATOR :: TABUCSTRING = 1 !< 1 + ENUMERATOR :: TABINTEGER = 2 !< 2 + ENUMERATOR :: TABREAL = 3 !< 3 END ENUM ! -- enumerator used to define output option ENUM, BIND(C) - ENUMERATOR :: VSUMMARY=0 !< 0 - ENUMERATOR :: VALL=1 !< 1 - ENUMERATOR :: VDEBUG=2 !< 2 + ENUMERATOR :: VSUMMARY = 0 !< 0 + ENUMERATOR :: VALL = 1 !< 1 + ENUMERATOR :: VDEBUG = 2 !< 2 END ENUM ! -- enumerator that defines the operating system ENUM, BIND(C) - ENUMERATOR :: OSUNDEF=0 !< 0 - ENUMERATOR :: OSLINUX=1 !< 1 - ENUMERATOR :: OSMAC=2 !< 2 - ENUMERATOR :: OSWIN=3 !< 3 + ENUMERATOR :: OSUNDEF = 0 !< 0 + ENUMERATOR :: OSLINUX = 1 !< 1 + ENUMERATOR :: OSMAC = 2 !< 2 + ENUMERATOR :: OSWIN = 3 !< 3 END ENUM ! -- enumerator that defines the simulation mode ENUM, BIND(C) - ENUMERATOR :: MVALIDATE=0 !< 0 - ENUMERATOR :: MNORMAL=1 !< 1 - ENUMERATOR :: MRUN=2 !< 2 + ENUMERATOR :: MVALIDATE = 0 !< 0 + ENUMERATOR :: MNORMAL = 1 !< 1 + ENUMERATOR :: MRUN = 2 !< 2 END ENUM ! -- enumerator that defines the compiler ENUM, BIND(C) - ENUMERATOR :: CUNKNOWN=0 !< 0 - ENUMERATOR :: CGFORTRAN=1 !< 1 - ENUMERATOR :: CINTEL=3 !< 2 - ENUMERATOR :: CCRAYFTN=3 !< 3 + ENUMERATOR :: CUNKNOWN = 0 !< 0 + ENUMERATOR :: CGFORTRAN = 1 !< 1 + ENUMERATOR :: CINTEL = 3 !< 2 + ENUMERATOR :: CCRAYFTN = 3 !< 3 END ENUM end module ConstantsModule diff --git a/src/Utilities/HashTable.f90 b/src/Utilities/HashTable.f90 index 5e37abf94e5..51f90b04efd 100644 --- a/src/Utilities/HashTable.f90 +++ b/src/Utilities/HashTable.f90 @@ -1,5 +1,5 @@ ! HashTableType implements a hash table for storing integers, -! for use as an index for an array that could contain +! for use as an index for an array that could contain ! any data type. This HashTableModule was designed using the ! dictionary implementation by Arjen Markus of the Flibs ! collection of Fortran utilities. This hash table works @@ -7,37 +7,37 @@ ! strings and each string will be assigned a unique number ! between 1 and n, allowing an efficient way to store a ! unique integer index with a character string. - + module HashTableModule use KindModule, only: DP, I4B - + implicit none private public HashTableType public hash_table_cr public hash_table_da - - integer, parameter, private :: HASH_SIZE = 4993 + + integer, parameter, private :: HASH_SIZE = 4993 integer, parameter, private :: MULTIPLIER = 31 type :: ListDataType character(len=:), allocatable :: key integer(I4B) :: index end type ListDataType - + type :: ListType type(ListDataType) :: listdata type(ListType), pointer :: next => null() contains procedure :: add => listtype_add end type ListType - + type :: HashListType type(ListType), pointer :: list => null() end type HashListType - + type :: HashTableType private type(HashListType), dimension(:), pointer :: table => null() @@ -46,9 +46,9 @@ module HashTableModule procedure :: get_elem procedure :: get_index end type HashTableType - - contains - + +contains + subroutine hash_table_cr(ht) ! ****************************************************************************** ! hash_table_cr -- public subroutine to create the hash table object @@ -63,18 +63,18 @@ subroutine hash_table_cr(ht) ! ------------------------------------------------------------------------------ ! ! -- allocate - allocate(ht) - allocate(ht%table(HASH_SIZE)) + allocate (ht) + allocate (ht%table(HASH_SIZE)) ! ! -- nullify each list do i = 1, HASH_SIZE ht%table(i)%list => null() - enddo + end do ! ! -- return return end subroutine hash_table_cr - + subroutine hash_table_da(ht) ! ****************************************************************************** ! hash_table_da -- public subroutine to deallocate the hash table object @@ -90,19 +90,19 @@ subroutine hash_table_da(ht) ! ! -- deallocate the list for each hash do i = 1, size(ht%table) - if ( associated( ht%table(i)%list)) then + if (associated(ht%table(i)%list)) then call listtype_da(ht%table(i)%list) - endif - enddo + end if + end do ! ! -- deallocate the table and the hash table - deallocate(ht%table) - deallocate(ht) + deallocate (ht%table) + deallocate (ht) ! ! -- return return end subroutine hash_table_da - + subroutine add_entry(this, key, index) ! ****************************************************************************** ! add_entry -- hash table method to add a key/index entry @@ -157,16 +157,16 @@ function get_elem(this, key) result(elem) elem => this%table(ihash)%list do while (associated(elem)) if (elem%listdata%key == key) then - exit + exit else elem => elem%next end if - enddo + end do ! ! -- return return - end function get_elem - + end function get_elem + function get_index(this, key) result(index) ! ****************************************************************************** ! get_index -- get the integer index that corresponds to this hash. @@ -188,12 +188,12 @@ function get_index(this, key) result(index) index = elem%listdata%index else index = 0 - endif + end if ! ! -- return return end function get_index - + subroutine listtype_cr(list, key, index) ! ****************************************************************************** ! listtype_cr -- subroutine to create a list @@ -206,7 +206,7 @@ subroutine listtype_cr(list, key, index) character(len=*), intent(in) :: key integer(I4B), intent(in) :: index ! ------------------------------------------------------------------------------ - allocate(list) + allocate (list) list%next => null() list%listdata%key = key list%listdata%index = index @@ -229,7 +229,7 @@ subroutine listtype_add(this, key, index) ! -- local type(ListType), pointer :: next ! ------------------------------------------------------------------------------ - allocate(next) + allocate (next) next%listdata%key = key next%listdata%index = index next%next => this%next @@ -249,15 +249,15 @@ subroutine listtype_da(list) ! -- dummy type(ListType), pointer, intent(in) :: list ! -- local - type(ListType), pointer :: current - type(ListType), pointer :: elem + type(ListType), pointer :: current + type(ListType), pointer :: elem ! ------------------------------------------------------------------------------ elem => list - do while ( associated(elem) ) + do while (associated(elem)) current => elem elem => current%next - deallocate(current) - enddo + deallocate (current) + end do ! ! -- return return @@ -277,9 +277,9 @@ function hashfunc(key) result(ihash) integer(I4B) :: i ! ------------------------------------------------------------------------------ ihash = 0 - do i = 1,len(key) - ihash = modulo( MULTIPLIER * ihash + ichar(key(i:i)), HASH_SIZE) - enddo + do i = 1, len(key) + ihash = modulo(MULTIPLIER * ihash + ichar(key(i:i)), HASH_SIZE) + end do ihash = 1 + modulo(ihash - 1, HASH_SIZE) ! ! -- return diff --git a/src/Utilities/HeadFileReader.f90 b/src/Utilities/HeadFileReader.f90 index 6795dc60a6d..2e2253e2c1c 100644 --- a/src/Utilities/HeadFileReader.f90 +++ b/src/Utilities/HeadFileReader.f90 @@ -4,12 +4,12 @@ module HeadFileReaderModule use ConstantsModule, only: LINELENGTH implicit none - + private public :: HeadFileReaderType - + type :: HeadFileReaderType - + integer(I4B) :: inunit character(len=16) :: text integer(I4B) :: nlay @@ -22,17 +22,17 @@ module HeadFileReaderModule real(DP) :: pertim real(DP) :: totim real(DP), dimension(:), allocatable :: head - + contains - + procedure :: initialize procedure :: read_record procedure :: finalize - + end type HeadFileReaderType - - contains - + +contains + subroutine initialize(this, iu, iout) ! ****************************************************************************** ! initialize @@ -56,27 +56,27 @@ subroutine initialize(this, iu, iout) call this%read_record(success) kstp_last = this%kstp kper_last = this%kper - rewind(this%inunit) + rewind (this%inunit) ! ! -- Determine number of records within a time step if (iout > 0) & - write(iout, '(a)') & - 'Reading binary file to determine number of records per time step.' + write (iout, '(a)') & + 'Reading binary file to determine number of records per time step.' do call this%read_record(success, iout) if (.not. success) exit if (kstp_last /= this%kstp .or. kper_last /= this%kper) exit this%nlay = this%nlay + 1 - enddo - rewind(this%inunit) + end do + rewind (this%inunit) if (iout > 0) & - write(iout, '(a, i0, a)') 'Detected ', this%nlay, & + write (iout, '(a, i0, a)') 'Detected ', this%nlay, & ' unique records in binary file.' ! ! -- return return end subroutine initialize - + subroutine read_record(this, success, iout_opt) ! ****************************************************************************** ! read_record @@ -99,48 +99,48 @@ subroutine read_record(this, success, iout_opt) iout = iout_opt else iout = 0 - endif + end if ! this%kstp = 0 this%kper = 0 success = .true. this%kstpnext = 0 this%kpernext = 0 - read(this%inunit, iostat=iostat) this%kstp, this%kper, this%pertim, & + read (this%inunit, iostat=iostat) this%kstp, this%kper, this%pertim, & this%totim, this%text, ncol, nrow, ilay if (iostat /= 0) then success = .false. if (iostat < 0) this%endoffile = .true. return - endif + end if ! ! -- allocate head to proper size if (.not. allocated(this%head)) then - allocate(this%head(ncol*nrow)) + allocate (this%head(ncol * nrow)) else - if (size(this%head) /= ncol*nrow) then - deallocate(this%head) - allocate(this%head(ncol*nrow)) - endif - endif + if (size(this%head) /= ncol * nrow) then + deallocate (this%head) + allocate (this%head(ncol * nrow)) + end if + end if ! ! -- read the head array - read(this%inunit) this%head + read (this%inunit) this%head ! ! -- look ahead to next kstp and kper, then backup if read successfully if (.not. this%endoffile) then - read(this%inunit, iostat=iostat) this%kstpnext, this%kpernext + read (this%inunit, iostat=iostat) this%kstpnext, this%kpernext if (iostat == 0) then call fseek_stream(this%inunit, -2 * I4B, 1, iostat) else if (iostat < 0) then this%endoffile = .true. - endif - endif + end if + end if ! ! -- return return end subroutine read_record - + subroutine finalize(this) ! ****************************************************************************** ! budgetdata_finalize @@ -150,11 +150,11 @@ subroutine finalize(this) ! ------------------------------------------------------------------------------ class(HeadFileReaderType) :: this ! ------------------------------------------------------------------------------ - close(this%inunit) - if(allocated(this%head)) deallocate(this%head) + close (this%inunit) + if (allocated(this%head)) deallocate (this%head) ! ! -- return return end subroutine finalize - + end module HeadFileReaderModule diff --git a/src/Utilities/Iunit.f90 b/src/Utilities/Iunit.f90 index 41f968a1311..0f109a0fe47 100644 --- a/src/Utilities/Iunit.f90 +++ b/src/Utilities/Iunit.f90 @@ -2,7 +2,7 @@ ! -- assigned to a single package type, as shown below. ! -- row(i) cunit(i) iunit(i)%nval iunit(i)%iunit iunit(i)%ipos ! -- 1 BCF6 1 (1000) (1) -! -- 2 WEL 3 (1001,1003,1005) (2,5,7) +! -- 2 WEL 3 (1001,1003,1005) (2,5,7) ! -- 3 GHB 1 (1002) (4) ! -- 4 EVT 2 (1004,1006) (6,10) ! -- 5 RIV 0 () () @@ -19,8 +19,8 @@ module IunitModule type :: IunitRowType integer(I4B) :: nval = 0 - integer(I4B), allocatable, dimension(:) :: iunit ! unit numbers for this row - integer(I4B), allocatable, dimension(:) :: ipos ! position in the input files character array + integer(I4B), allocatable, dimension(:) :: iunit ! unit numbers for this row + integer(I4B), allocatable, dimension(:) :: ipos ! position in the input files character array end type IunitRowType type :: IunitType @@ -33,7 +33,7 @@ module IunitModule procedure :: getunitnumber end type IunitType - contains +contains subroutine init(this, niunit, cunit) ! ****************************************************************************** @@ -51,12 +51,12 @@ subroutine init(this, niunit, cunit) integer(I4B) :: i ! ------------------------------------------------------------------------------ ! - allocate(this%cunit(niunit)) - allocate(this%iunit(niunit)) + allocate (this%cunit(niunit)) + allocate (this%iunit(niunit)) this%niunit = niunit - do i=1,niunit - this%cunit(i)=cunit(i) - enddo + do i = 1, niunit + this%cunit(i) = cunit(i) + end do ! ! -- Return return @@ -86,41 +86,41 @@ subroutine addfile(this, ftyp, iunit, ipos, namefilename) ! -- Find the row containing ftyp irow = 0 do i = 1, this%niunit - if(this%cunit(i) == ftyp) then + if (this%cunit(i) == ftyp) then irow = i exit - endif - enddo - if(irow == 0) then - write(errmsg, '(a,a)') 'Package type not supported: ', ftyp + end if + end do + if (irow == 0) then + write (errmsg, '(a,a)') 'Package type not supported: ', ftyp call store_error(errmsg) call store_error_filename(namefilename, terminate=.TRUE.) - endif + end if ! ! -- Store the iunit number for this ftyp - if(this%iunit(irow)%nval == 0) then - allocate(this%iunit(irow)%iunit(1)) - allocate(this%iunit(irow)%ipos(1)) - this%iunit(irow)%nval=1 + if (this%iunit(irow)%nval == 0) then + allocate (this%iunit(irow)%iunit(1)) + allocate (this%iunit(irow)%ipos(1)) + this%iunit(irow)%nval = 1 else ! ! -- increase size of iunit - allocate(itemp(this%iunit(irow)%nval)) + allocate (itemp(this%iunit(irow)%nval)) itemp(:) = this%iunit(irow)%iunit(:) - deallocate(this%iunit(irow)%iunit) + deallocate (this%iunit(irow)%iunit) this%iunit(irow)%nval = this%iunit(irow)%nval + 1 - allocate(this%iunit(irow)%iunit(this%iunit(irow)%nval)) + allocate (this%iunit(irow)%iunit(this%iunit(irow)%nval)) this%iunit(irow)%iunit(1:this%iunit(irow)%nval - 1) = itemp(:) ! ! -- increase size of ipos itemp(:) = this%iunit(irow)%ipos(:) - deallocate(this%iunit(irow)%ipos) - allocate(this%iunit(irow)%ipos(this%iunit(irow)%nval)) + deallocate (this%iunit(irow)%ipos) + allocate (this%iunit(irow)%ipos(this%iunit(irow)%nval)) this%iunit(irow)%ipos(1:this%iunit(irow)%nval - 1) = itemp(:) ! ! -- cleanup temp - deallocate(itemp) - endif + deallocate (itemp) + end if this%iunit(irow)%iunit(this%iunit(irow)%nval) = iunit this%iunit(irow)%ipos(this%iunit(irow)%nval) = ipos ! @@ -146,26 +146,26 @@ subroutine getunitnumber(this, ftyp, iunit, iremove) ! -- Find the row irow = 0 do i = 1, this%niunit - if(this%cunit(i) == ftyp) then + if (this%cunit(i) == ftyp) then irow = i exit - endif - enddo + end if + end do ! ! -- Find the unit number. iunit = 0 - if(irow > 0) then + if (irow > 0) then nval = this%iunit(irow)%nval - if(nval > 0) then + if (nval > 0) then iunit = this%iunit(irow)%iunit(nval) - if(iremove > 0) then + if (iremove > 0) then this%iunit(irow)%iunit(nval) = 0 this%iunit(irow)%nval = nval - 1 - endif + end if else iunit = 0 - endif - endif + end if + end if end subroutine getunitnumber end module IunitModule diff --git a/src/Utilities/List.f90 b/src/Utilities/List.f90 index 6b4dc6d5999..dbd807b22ec 100644 --- a/src/Utilities/List.f90 +++ b/src/Utilities/List.f90 @@ -24,13 +24,13 @@ module ListModule procedure, public :: DeallocateBackward procedure, public :: GetNextItem procedure, public :: GetPreviousItem - generic, public :: GetItem => get_item_by_index, get_current_item + generic, public :: GetItem => get_item_by_index, get_current_item procedure, public :: InsertAfter procedure, public :: InsertBefore procedure, public :: Next procedure, public :: Previous procedure, public :: Reset - generic, public :: RemoveNode => remove_node_by_index, remove_this_node + generic, public :: RemoveNode => remove_node_by_index, remove_this_node ! -- Private procedures procedure, private :: get_current_item procedure, private :: get_item_by_index @@ -46,21 +46,21 @@ module ListModule type(ListNodeType), pointer, public :: nextNode => null() type(ListNodeType), pointer, public :: prevNode => null() ! -- Private members - class(*), pointer, private :: Value => null() + class(*), pointer, private :: Value => null() contains ! -- Public procedure - procedure, public :: GetItem + procedure, public :: GetItem ! -- Private procedures procedure, private :: DeallocValue end type ListNodeType - + interface function isEqualIface(obj1, obj2) result(isEqual) class(*), pointer :: obj1, obj2 logical :: isEqual end function end interface - + contains ! -- Public type-bound procedures for ListType @@ -72,16 +72,16 @@ subroutine Add(this, objptr) class(*), pointer, intent(inout) :: objptr ! if (.not. associated(this%firstNode)) then - allocate(this%firstNode) + allocate (this%firstNode) this%firstNode%Value => objptr this%firstNode%prevNode => null() this%lastNode => this%firstNode else - allocate(this%lastNode%nextNode) + allocate (this%lastNode%nextNode) this%lastNode%nextNode%prevNode => this%lastNode this%lastNode%nextNode%value => objptr this%lastNode => this%lastNode%nextNode - endif + end if this%nodeCount = this%nodeCount + 1 return end subroutine Add @@ -106,14 +106,14 @@ subroutine Clear(this, destroy) destroyLocal = .false. if (present(destroy)) then destroyLocal = destroy - endif + end if ! if (.not. associated(this%firstNode)) return ! -- The last node will be deallocated in the loop below. ! Just nullify the pointer to the last node to avoid ! having a dangling pointer. Also nullify currentNode. - nullify(this%lastNode) - nullify(this%currentNode) + nullify (this%lastNode) + nullify (this%currentNode) ! current => this%firstNode do while (associated(current)) @@ -122,12 +122,12 @@ subroutine Clear(this, destroy) ! -- Deallocate the object stored in the current node call current%DeallocValue(destroyLocal) ! -- Deallocate the current node - deallocate(current) + deallocate (current) this%firstNode => next this%nodeCount = this%nodeCount - 1 ! -- Advance to the next node current => next - enddo + end do ! call this%Reset() ! @@ -160,7 +160,7 @@ function ContainsObject(this, obj, isEqual) result(hasObj) logical :: hasObj ! local type(ListNodeType), pointer :: current => null() - + hasObj = .false. current => this%firstNode do while (associated(current)) @@ -168,21 +168,21 @@ function ContainsObject(this, obj, isEqual) result(hasObj) hasObj = .true. return end if - + ! -- Advance to the next node current => current%nextNode - enddo - + end do + ! this means there is no match return - end function - + end function + function arePointersEqual(obj1, obj2) result(areIdentical) class(*), pointer :: obj1, obj2 logical :: areIdentical - areIdentical = associated(obj1, obj2) + areIdentical = associated(obj1, obj2) end function arePointersEqual - + subroutine DeallocateBackward(this, fromNode) ! ************************************************************************** ! DeallocateBackward @@ -205,18 +205,18 @@ subroutine DeallocateBackward(this, fromNode) this%firstNode => fromNode%nextNode else this%firstNode => null() - endif + end if ! -- deallocate fromNode and all previous nodes current => fromNode do while (associated(current)) prev => current%prevNode call current%DeallocValue(.true.) - deallocate(current) + deallocate (current) this%nodeCount = this%nodeCount - 1 current => prev - enddo + end do fromNode => null() - endif + end if ! return end subroutine DeallocateBackward @@ -263,7 +263,7 @@ subroutine InsertAfter(this, objptr, indx) precedingNode => this%get_node_by_index(indx) if (associated(precedingNode%nextNode)) then followingNode => precedingNode%nextNode - allocate(newNode) + allocate (newNode) newNode%Value => objptr newNode%nextNode => followingNode newNode%prevNode => precedingNode @@ -271,11 +271,11 @@ subroutine InsertAfter(this, objptr, indx) followingNode%prevNode => newNode this%nodeCount = this%nodeCount + 1 else - write(line,'(a)') 'Programming error in ListType%insert_after' + write (line, '(a)') 'Programming error in ListType%insert_after' call sim_message(line) call stop_with_error(1) - endif - endif + end if + end if ! return end subroutine InsertAfter @@ -292,10 +292,10 @@ subroutine InsertBefore(this, objptr, targetNode) ! if (.not. associated(targetNode)) then stop 'Programming error, likely in call to ListType%InsertBefore' - endif + end if ! ! Allocate a new list node and point its Value member to the object - allocate(newNode) + allocate (newNode) newNode%Value => objptr ! ! Do the insertion @@ -308,7 +308,7 @@ subroutine InsertBefore(this, objptr, targetNode) ! Insert before first node this%firstNode => newNode newNode%prevNode => null() - endif + end if targetNode%prevNode => newNode this%nodeCount = this%nodeCount + 1 ! @@ -326,7 +326,7 @@ subroutine Next(this) else this%currentNode => null() this%currentNodeIndex = 0 - endif + end if else if (associated(this%currentNode%nextNode)) then this%currentNode => this%currentNode%nextNode @@ -334,8 +334,8 @@ subroutine Next(this) else this%currentNode => null() this%currentNodeIndex = 0 - endif - endif + end if + end if return end subroutine Next @@ -348,7 +348,7 @@ subroutine Previous(this) else this%currentNode => this%currentNode%prevNode this%currentNodeIndex = this%currentNodeIndex - 1 - endif + end if return end subroutine Previous @@ -365,8 +365,8 @@ subroutine remove_node_by_index(this, i, destroyValue) implicit none ! -- dummy class(ListType), intent(inout) :: this - integer(I4B), intent(in) :: i - logical, intent(in) :: destroyValue + integer(I4B), intent(in) :: i + logical, intent(in) :: destroyValue ! -- local type(ListNodeType), pointer :: node ! @@ -374,7 +374,7 @@ subroutine remove_node_by_index(this, i, destroyValue) node => this%get_node_by_index(i) if (associated(node)) then call this%remove_this_node(node, destroyValue) - endif + end if ! return end subroutine remove_node_by_index @@ -382,9 +382,9 @@ end subroutine remove_node_by_index subroutine remove_this_node(this, node, destroyValue) implicit none ! -- dummy - class(ListType), intent(inout) :: this + class(ListType), intent(inout) :: this type(ListNodeType), pointer, intent(inout) :: node - logical, intent(in) :: destroyValue + logical, intent(in) :: destroyValue ! -- local ! logical :: first, last @@ -398,32 +398,32 @@ subroutine remove_this_node(this, node, destroyValue) else node%prevNode%nextNode => null() this%lastNode => node%prevNode - endif + end if else first = .true. - endif + end if if (associated(node%nextNode)) then if (associated(node%prevNode)) then node%prevNode%nextNode => node%nextNode else node%nextNode%prevNode => null() this%firstNode => node%nextNode - endif + end if else last = .true. - endif + end if if (destroyValue) then call node%DeallocValue(destroyValue) - endif - deallocate(node) + end if + deallocate (node) this%nodeCount = this%nodeCount - 1 if (first .and. last) then this%firstNode => null() this%lastNode => null() this%currentNode => null() - endif + end if call this%Reset() - endif + end if ! return end subroutine remove_this_node @@ -439,7 +439,7 @@ function get_current_item(this) result(resultobj) resultobj => null() if (associated(this%currentNode)) then resultobj => this%currentNode%Value - endif + end if return end function get_current_item @@ -466,13 +466,13 @@ function get_item_by_index(this, indx) result(resultobj) ! -- Ensure that this%currentNode is associated if (.not. associated(this%currentNode)) then this%currentNodeIndex = 0 - endif + end if if (this%currentNodeIndex == 0) then if (associated(this%firstNode)) then this%currentNode => this%firstNode this%currentNodeIndex = 1 - endif - endif + end if + end if ! ! -- Check indx position relative to current node index i = 0 @@ -483,28 +483,28 @@ function get_item_by_index(this, indx) result(resultobj) this%currentNode => this%firstNode this%currentNodeIndex = 1 i = 1 - endif + end if else i = this%currentNodeIndex - endif + end if if (i == 0) return ! ! -- If current node is requested node, ! assign pointer and return - if (i==indx) then + if (i == indx) then resultobj => this%currentNode%Value return - endif + end if ! ! -- Iterate from current node to requested node do while (associated(this%currentNode%nextNode)) this%currentNode => this%currentNode%nextNode this%currentNodeIndex = this%currentNodeIndex + 1 - if (this%currentNodeIndex==indx) then + if (this%currentNodeIndex == indx) then resultobj => this%currentNode%Value return - endif - enddo + end if + end do return end function get_item_by_index @@ -533,8 +533,8 @@ function get_node_by_index(this, indx) result(resultnode) if (associated(this%firstNode)) then this%currentNode => this%firstNode this%currentNodeIndex = 1 - endif - endif + end if + end if ! ! -- Check indx position relative to current node index i = 0 @@ -545,28 +545,28 @@ function get_node_by_index(this, indx) result(resultnode) this%currentNode => this%firstNode this%currentNodeIndex = 1 i = 1 - endif + end if else i = this%currentNodeIndex - endif + end if if (i == 0) return ! ! -- If current node is requested node, ! assign pointer and return - if (i==indx) then + if (i == indx) then resultnode => this%currentNode return - endif + end if ! ! -- Iterate from current node to requested node do while (associated(this%currentNode%nextNode)) this%currentNode => this%currentNode%nextNode this%currentNodeIndex = this%currentNodeIndex + 1 - if (this%currentNodeIndex==indx) then + if (this%currentNodeIndex == indx) then resultnode => this%currentNode return - endif - enddo + end if + end do return end function get_node_by_index @@ -602,11 +602,11 @@ subroutine DeallocValue(this, destroy) if (associated(this%Value)) then if (present(destroy)) then if (destroy) then - deallocate(this%Value) - endif - endif - nullify(this%Value) - endif + deallocate (this%Value) + end if + end if + nullify (this%Value) + end if return end subroutine DeallocValue diff --git a/src/Utilities/ListReader.f90 b/src/Utilities/ListReader.f90 index 8e97e0746ac..d40943f2e31 100644 --- a/src/Utilities/ListReader.f90 +++ b/src/Utilities/ListReader.f90 @@ -4,54 +4,54 @@ module ListReaderModule use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & LENAUXNAME, LENLISTLABEL, DONE - use SimModule, only: store_error_unit + use SimModule, only: store_error_unit implicit none private public ListReaderType - + type :: ListReaderType - integer(I4B) :: in = 0 ! unit number of file containing control record - integer(I4B) :: inlist = 0 ! unit number of file from which list will be read - integer(I4B) :: iout = 0 ! unit number to output messages - integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read - integer(I4B) :: ierr = 0 ! error flag - integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined - integer(I4B) :: ibinary = 0 ! flag indicating to read binary list - integer(I4B) :: istart = 0 ! string starting location - integer(I4B) :: istop = 0 ! string ending location - integer(I4B) :: lloc = 0 ! entry number in line - integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file - integer(I4B) :: ndim = 0 ! number of dimensions in model - integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist - integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar - character(len=LENLISTLABEL) :: label = '' ! label for printing list - character(len=:), allocatable, private :: line ! current line - integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist - real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar - character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: boundname => null() ! pointer to boundname - integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar - integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar + integer(I4B) :: in = 0 ! unit number of file containing control record + integer(I4B) :: inlist = 0 ! unit number of file from which list will be read + integer(I4B) :: iout = 0 ! unit number to output messages + integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read + integer(I4B) :: ierr = 0 ! error flag + integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined + integer(I4B) :: ibinary = 0 ! flag indicating to read binary list + integer(I4B) :: istart = 0 ! string starting location + integer(I4B) :: istop = 0 ! string ending location + integer(I4B) :: lloc = 0 ! entry number in line + integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file + integer(I4B) :: ndim = 0 ! number of dimensions in model + integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist + integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar + character(len=LENLISTLABEL) :: label = '' ! label for printing list + character(len=:), allocatable, private :: line ! current line + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist + real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar + character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: boundname => null() ! pointer to boundname + integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar + integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar contains - procedure :: read_list - procedure :: write_list + procedure :: read_list + procedure :: write_list procedure, private :: read_control_record procedure, private :: read_data procedure, private :: set_openclose procedure, private :: read_ascii procedure, private :: read_binary end type ListReaderType - - contains - - subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & + +contains + + subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & rlist, auxvar, auxname, boundname, label) ! ****************************************************************************** ! init -- Initialize the reader @@ -72,7 +72,8 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & real(DP), dimension(:, :), intent(inout), contiguous, pointer :: rlist real(DP), dimension(:, :), intent(inout), contiguous, pointer :: auxvar character(len=LENAUXNAME), dimension(:), intent(inout), target :: auxname - character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, intent(inout) :: boundname + character(len=LENBOUNDNAME), & + dimension(:), pointer, contiguous, intent(inout) :: boundname character(len=LENLISTLABEL), intent(in) :: label ! -- local ! ------------------------------------------------------------------------------ @@ -94,12 +95,12 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & this%boundname => boundname ! ! -- Allocate arrays for storing text and text locations - if(.not. allocated(this%idxtxtrow)) allocate(this%idxtxtrow(0)) - if(.not. allocated(this%idxtxtcol)) allocate(this%idxtxtcol(0)) - if(.not. allocated(this%idxtxtauxrow)) allocate(this%idxtxtauxrow(0)) - if(.not. allocated(this%idxtxtauxcol)) allocate(this%idxtxtauxcol(0)) - if(.not. allocated(this%txtrlist)) allocate(this%txtrlist(0)) - if(.not. allocated(this%txtauxvar)) allocate(this%txtauxvar(0)) + if (.not. allocated(this%idxtxtrow)) allocate (this%idxtxtrow(0)) + if (.not. allocated(this%idxtxtcol)) allocate (this%idxtxtcol(0)) + if (.not. allocated(this%idxtxtauxrow)) allocate (this%idxtxtauxrow(0)) + if (.not. allocated(this%idxtxtauxcol)) allocate (this%idxtxtauxcol(0)) + if (.not. allocated(this%txtrlist)) allocate (this%txtrlist(0)) + if (.not. allocated(this%txtauxvar)) allocate (this%txtauxvar(0)) ! ! -- Read control record call this%read_control_record() @@ -113,7 +114,7 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & ! -- return return end subroutine read_list - + subroutine read_control_record(this) ! ****************************************************************************** ! read_control_record -- Check for a control record, and parse if found @@ -130,7 +131,7 @@ subroutine read_control_record(this) real(DP) :: r ! -- formats character(len=*), parameter :: fmtlsf = & - "(1X,'LIST SCALING FACTOR=',1PG12.5)" + "(1X,'LIST SCALING FACTOR=',1PG12.5)" ! ------------------------------------------------------------------------------ ! ! -- Set default values, which may be changed by control record @@ -141,19 +142,19 @@ subroutine read_control_record(this) ! -- Read to the first non-commented line call u9rdcom(this%in, this%iout, this%line, this%ierr) this%lloc = 1 - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%in) ! ! -- Parse record - select case(this%line(this%istart:this%istop)) - case('OPEN/CLOSE') + select case (this%line(this%istart:this%istop)) + case ('OPEN/CLOSE') call this%set_openclose() end select ! ! -- return return end subroutine read_control_record - + subroutine set_openclose(this) ! ****************************************************************************** ! set_openclose -- set up for open/close file @@ -179,54 +180,54 @@ subroutine set_openclose(this) character(len=LINELENGTH) :: errmsg ! -- formats character(len=*), parameter :: fmtocne = & - "('Specified OPEN/CLOSE file ',(A),' does not exist')" + &"('Specified OPEN/CLOSE file ',(A),' does not exist')" character(len=*), parameter :: fmtobf = & - "(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" + &"(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" character(len=*), parameter :: fmtobfnlist = & - "(1X, 'TO READ ', I0, ' RECORDS.')" + &"(1X, 'TO READ ', I0, ' RECORDS.')" character(len=*), parameter :: fmtofnlist = & - "(1x,'TO READ ', I0, ' RECORDS.')" + &"(1x,'TO READ ', I0, ' RECORDS.')" character(len=*), parameter :: fmtof = & - "(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" + &"(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" ! ------------------------------------------------------------------------------ ! ! -- get filename - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & this%iout, this%in) fname = this%line(this%istart:this%istop) ! ! -- check to see if file OPEN/CLOSE file exists - inquire(file=fname, exist=exists) + inquire (file=fname, exist=exists) if (.not. exists) then - write(errmsg, fmtocne) this%line(this%istart:this%istop) + write (errmsg, fmtocne) this%line(this%istart:this%istop) call store_error(errmsg) call store_error('Specified OPEN/CLOSE file does not exist') call store_error_unit(this%in) - endif + end if ! ! -- Check for (BINARY) keyword - call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%in) - if(this%line(this%istart:this%istop) == '(BINARY)') this%ibinary = 1 + if (this%line(this%istart:this%istop) == '(BINARY)') this%ibinary = 1 ! ! -- Open the file depending on ibinary flag this%inlist = nunopn - if(this%ibinary == 1) then + if (this%ibinary == 1) then itmp = this%iout - if(this%iout > 0) then + if (this%iout > 0) then itmp = 0 - write(this%iout, fmtobf) this%inlist, trim(adjustl(fname)) - if(this%nlist > 0) write(this%iout, fmtobfnlist) this%nlist - endif - call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE', fmtarg_opt=form, & + write (this%iout, fmtobf) this%inlist, trim(adjustl(fname)) + if (this%nlist > 0) write (this%iout, fmtobfnlist) this%nlist + end if + call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE', fmtarg_opt=form, & accarg_opt=access) else itmp = this%iout - if(this%iout > 0) then + if (this%iout > 0) then itmp = 0 - write(this%iout, fmtof) this%inlist, trim(adjustl(fname)) - if(this%nlist > 0) write(this%iout, fmtofnlist) this%nlist - endif + write (this%iout, fmtof) this%inlist, trim(adjustl(fname)) + if (this%nlist > 0) write (this%iout, fmtofnlist) this%nlist + end if call openfile(this%inlist, itmp, fname, 'OPEN/CLOSE') end if ! @@ -236,13 +237,13 @@ subroutine set_openclose(this) ! ! -- Read the first line from inlist to be consistent with how the list is ! read when it is included in the package input file - if(this%ibinary /= 1) call u9rdcom(this%inlist, this%iout, this%line, & - this%ierr) + if (this%ibinary /= 1) call u9rdcom(this%inlist, this%iout, this%line, & + this%ierr) ! ! -- return return end subroutine set_openclose - + subroutine read_data(this) ! ****************************************************************************** ! read_data -- read the data @@ -258,20 +259,20 @@ subroutine read_data(this) ! ------------------------------------------------------------------------------ ! ! -- Read the list - if(this%ibinary == 1) then + if (this%ibinary == 1) then call this%read_binary() else call this%read_ascii() - endif + end if ! ! -- if open/close, then close file - if(this%iclose == 1) then - close(this%inlist) - endif + if (this%iclose == 1) then + close (this%inlist) + end if ! -- return return end subroutine read_data - + subroutine read_binary(this) ! ****************************************************************************** ! read_binary -- read the data from a binary file @@ -292,14 +293,14 @@ subroutine read_binary(this) integer(I4B), dimension(:), allocatable :: cellid ! -- formats character(len=*), parameter :: fmtmxlsterronly = & - "('ERROR READING LIST FROM FILE: '," // & - "a,' ON UNIT: ',I0," // & - "' THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & - "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & - " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" + "('ERROR READING LIST FROM FILE: ',& + &a,' ON UNIT: ',I0,& + &' THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER & + &OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST.& + & NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" character(len=*), parameter :: fmtlsterronly = & - "('ERROR READING LIST FROM FILE: '," // & - "1x,a,1x,' ON UNIT: ',I0)" + "('ERROR READING LIST FROM FILE: ',& + &1x,a,1x,' ON UNIT: ',I0)" ! ------------------------------------------------------------------------------ ! ! -- determine array sizes @@ -308,74 +309,74 @@ subroutine read_binary(this) naux = size(this%auxvar, 1) ! ! -- Allocate arrays - allocate(cellid(this%ndim)) + allocate (cellid(this%ndim)) ! ii = 1 readloop: do ! ! -- read layer, row, col, or cell number - read(this%inlist, iostat=this%ierr) cellid + read (this%inlist, iostat=this%ierr) cellid ! -- If not end of record, then store nodenumber, else ! calculate lstend and nlist, and exit readloop - select case(this%ierr) - case(0) + select case (this%ierr) + case (0) ! ! -- Check range - if(ii > mxlist) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtmxlsterronly) fname, this%inlist, ii, mxlist + if (ii > mxlist) then + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtmxlsterronly) fname, this%inlist, ii, mxlist call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- Store node number and read the remainder of the record - if(this%ndim == 1) then + if (this%ndim == 1) then nod = cellid(1) - elseif(this%ndim == 2) then - nod = get_node(cellid(1), 1, cellid(2), & + elseif (this%ndim == 2) then + nod = get_node(cellid(1), 1, cellid(2), & this%mshape(1), 1, this%mshape(2)) else - nod = get_node(cellid(1), cellid(2), cellid(3), & + nod = get_node(cellid(1), cellid(2), cellid(3), & this%mshape(1), this%mshape(2), this%mshape(3)) - endif + end if this%nodelist(ii) = nod - read(this%inlist, iostat=this%ierr) (this%rlist(jj,ii),jj=1,ldim), & - (this%auxvar(ii,jj),jj=1,naux) - if(this%ierr /= 0) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist + read (this%inlist, iostat=this%ierr) (this%rlist(jj, ii), jj=1, ldim), & + (this%auxvar(ii, jj), jj=1, naux) + if (this%ierr /= 0) then + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist call store_error(errmsg, terminate=.TRUE.) - endif + end if ! - case(:-1) + case (:-1) ! ! -- End of record was encountered this%nlist = ii - 1 exit readloop ! - case(1:) + case (1:) ! ! -- Error - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtlsterronly) trim(adjustl(fname)), this%inlist call store_error(errmsg, terminate=.TRUE.) ! end select ! ! -- If nlist is known, then exit when nlist values have been read - if(this%nlist > 0) then - if(ii == this%nlist) exit readloop - endif + if (this%nlist > 0) then + if (ii == this%nlist) exit readloop + end if ! ! -- increment ii ii = ii + 1 ! - enddo readloop + end do readloop ! ! -- return return end subroutine read_binary - + subroutine read_ascii(this) ! ****************************************************************************** ! read_ascii -- read the data from an ascii file @@ -390,7 +391,7 @@ subroutine read_ascii(this) use ArrayHandlersModule, only: ExpandArray ! -- dummy class(ListReaderType) :: this - ! -- local + ! -- local integer(I4B) :: mxlist, ldim, naux integer(I4B) :: ii, jj, idum, nod, istat, increment real(DP) :: r @@ -400,8 +401,8 @@ subroutine read_ascii(this) ! -- formats character(len=*), parameter :: fmtmxlsterronly = & "('***ERROR READING LIST. & - &THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER " // & - "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST." // & + &THE NUMBER OF RECORDS ENCOUNTERED EXCEEDS THE MAXIMUM NUMBER "// & + "OF RECORDS. TRY INCREASING MAXBOUND FOR THIS LIST."// & " NUMBER OF RECORDS: ',I0,' MAXBOUND: ',I0)" ! ------------------------------------------------------------------------------ ! @@ -413,116 +414,116 @@ subroutine read_ascii(this) this%ntxtauxvar = 0 ! ! -- Allocate arrays - allocate(cellid(this%ndim)) + allocate (cellid(this%ndim)) ! ii = 1 readloop: do ! ! -- First line was already read, so don't read again - if(ii /= 1) call u9rdcom(this%inlist, 0, this%line, this%ierr) + if (ii /= 1) call u9rdcom(this%inlist, 0, this%line, this%ierr) ! ! -- If this is an unknown-length list, then check for END. ! If found, then backspace, set nlist, and exit readloop. - if(this%nlist < 0) then + if (this%nlist < 0) then this%lloc = 1 call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%inlist) - if(this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then + if (this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then ! If ierr < 0, backspace was already performed in u9rdcom, so only ! need to backspace if END was found. if (this%ierr == 0) then - backspace(this%inlist) - endif + backspace (this%inlist) + end if this%nlist = ii - 1 exit readloop - endif - endif + end if + end if ! ! -- Check range - if(ii > mxlist) then - inquire(unit=this%inlist, name=fname) - write(errmsg, fmtmxlsterronly) ii, mxlist + if (ii > mxlist) then + inquire (unit=this%inlist, name=fname) + write (errmsg, fmtmxlsterronly) ii, mxlist call store_error(errmsg) - errmsg = 'Error occurred reading line: ' // trim(this%line) + errmsg = 'Error occurred reading line: '//trim(this%line) call store_error(errmsg) call store_error_unit(this%inlist) - endif + end if ! ! -- Read layer, row, column or cell number and assign to nodelist this%lloc = 1 - if(this%ndim == 3) then + if (this%ndim == 3) then ! ! -- Grid is structured; read layer, row, column - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(1), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(2), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(3), r, this%iout, this%inlist) ! ! -- Check for illegal grid location - if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then - write(errmsg, *) ' Layer number in list is outside of the grid', & - cellid(1) - call store_error(errmsg) + if (cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then + write (errmsg, *) ' Layer number in list is outside of the grid', & + cellid(1) + call store_error(errmsg) end if - if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then - write(errmsg, *) ' Row number in list is outside of the grid', & - cellid(2) - call store_error(errmsg) + if (cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then + write (errmsg, *) ' Row number in list is outside of the grid', & + cellid(2) + call store_error(errmsg) end if - if(cellid(3) < 1 .or. cellid(3) > this%mshape(3)) then - write(errmsg, *) ' Column number in list is outside of the grid', & - cellid(3) - call store_error(errmsg) + if (cellid(3) < 1 .or. cellid(3) > this%mshape(3)) then + write (errmsg, *) ' Column number in list is outside of the grid', & + cellid(3) + call store_error(errmsg) end if ! ! -- Calculate nodenumber and put in nodelist - nod = get_node(cellid(1), cellid(2), cellid(3), & + nod = get_node(cellid(1), cellid(2), cellid(3), & this%mshape(1), this%mshape(2), this%mshape(3)) - elseif(this%ndim == 2) then + elseif (this%ndim == 2) then ! ! -- Grid is disv - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(1), r, this%iout, this%inlist) - call urword(this%line, this%lloc, this%istart, this%istop, 2, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, & cellid(2), r, this%iout, this%inlist) ! ! -- Check for illegal grid location - if(cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then - write(errmsg, *) ' Layer number in list is outside of the grid', & - cellid(1) - call store_error(errmsg) + if (cellid(1) < 1 .or. cellid(1) > this%mshape(1)) then + write (errmsg, *) ' Layer number in list is outside of the grid', & + cellid(1) + call store_error(errmsg) end if - if(cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then - write(errmsg, *) ' Cell2d number in list is outside of the grid', & - cellid(2) - call store_error(errmsg) + if (cellid(2) < 1 .or. cellid(2) > this%mshape(2)) then + write (errmsg, *) ' Cell2d number in list is outside of the grid', & + cellid(2) + call store_error(errmsg) end if ! ! -- Calculate nodenumber and put in nodelist - nod = get_node(cellid(1), 1, cellid(2), & + nod = get_node(cellid(1), 1, cellid(2), & this%mshape(1), 1, this%mshape(2)) else ! ! -- Grid is unstructured; read layer and celld2d number - call urword(this%line, this%lloc, this%istart, this%istop, 2, nod, r, & + call urword(this%line, this%lloc, this%istart, this%istop, 2, nod, r, & this%iout, this%inlist) - if(nod < 1 .or. nod > this%mshape(1)) then - write(errmsg, *) ' Node number in list is outside of the grid', nod - call store_error(errmsg) + if (nod < 1 .or. nod > this%mshape(1)) then + write (errmsg, *) ' Node number in list is outside of the grid', nod + call store_error(errmsg) end if ! - endif + end if ! ! -- Assign nod to nodelist this%nodelist(ii) = nod ! ! -- Read rlist do jj = 1, ldim - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & r, this%iout, this%inlist) - read(this%line(this%istart:this%istop), *, iostat=istat) r + read (this%line(this%istart:this%istop), *, iostat=istat) r ! ! -- If a double precision value, then store in rlist, otherwise store ! the text name and location @@ -531,25 +532,25 @@ subroutine read_ascii(this) else this%rlist(jj, ii) = DZERO this%ntxtrlist = this%ntxtrlist + 1 - if(this%ntxtrlist > size(this%txtrlist)) then + if (this%ntxtrlist > size(this%txtrlist)) then increment = int(size(this%txtrlist) * 0.2) increment = max(100, increment) call ExpandArray(this%txtrlist, increment) call ExpandArray(this%idxtxtrow, increment) call ExpandArray(this%idxtxtcol, increment) - endif + end if this%txtrlist(this%ntxtrlist) = this%line(this%istart:this%istop) this%idxtxtrow(this%ntxtrlist) = ii this%idxtxtcol(this%ntxtrlist) = jj - endif + end if ! - enddo + end do ! ! -- Read auxvar do jj = 1, naux - call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & + call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, & r, this%iout, this%inlist) - read(this%line(this%istart:this%istop), *, iostat=istat) r + read (this%line(this%istart:this%istop), *, iostat=istat) r ! ! -- If a double precision value, then store in auxvar, otherwise store ! the text name and location @@ -558,46 +559,46 @@ subroutine read_ascii(this) else this%auxvar(jj, ii) = DZERO this%ntxtauxvar = this%ntxtauxvar + 1 - if(this%ntxtauxvar > size(this%txtauxvar)) then + if (this%ntxtauxvar > size(this%txtauxvar)) then increment = int(size(this%txtauxvar) * 0.2) increment = max(100, increment) call ExpandArray(this%txtauxvar, increment) call ExpandArray(this%idxtxtauxrow, increment) call ExpandArray(this%idxtxtauxcol, increment) - endif + end if this%txtauxvar(this%ntxtauxvar) = this%line(this%istart:this%istop) this%idxtxtauxrow(this%ntxtauxvar) = ii this%idxtxtauxcol(this%ntxtauxvar) = jj - endif + end if ! - enddo + end do ! ! -- Read the boundary names (only supported for ascii input) if (this%inamedbound > 0) then call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%inlist) this%boundname(ii) = this%line(this%istart:this%istop) - endif + end if ! ! -- If nlist is known, then exit when nlist values have been read - if(this%nlist > 0) then - if(ii == this%nlist) exit readloop - endif + if (this%nlist > 0) then + if (ii == this%nlist) exit readloop + end if ! ! -- increment ii row counter ii = ii + 1 ! - enddo readloop + end do readloop ! ! -- Stop if errors were detected - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error_unit(this%inlist) - endif + end if ! ! -- return return end subroutine read_ascii - + subroutine write_list(this) ! ****************************************************************************** ! write_list -- Write input data to a list @@ -606,7 +607,7 @@ subroutine write_list(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & + use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & TABLEFT, TABCENTER use InputOutputModule, only: ulstlb, get_ijk use TableModule, only: TableType, table_cr @@ -638,51 +639,51 @@ subroutine write_list(this) ! contains the column headers (except for boundname and auxnames) ipos = index(this%label, 'NO.') if (ipos /= 0) then - write(cpos,'(i10)') ipos + 3 - fmtlstbn = '(a' // trim(adjustl(cpos)) + write (cpos, '(i10)') ipos + 3 + fmtlstbn = '(a'//trim(adjustl(cpos)) else fmtlstbn = '(a7' end if ! -- sequence number, layer, row, and column. - if(size(this%mshape) == 3) then + if (size(this%mshape) == 3) then ntabcols = 4 - fmtlstbn = trim(fmtlstbn) // ',a7,a7,a7' - ! - ! -- sequence number, layer, and cell2d. - else if(size(this%mshape) == 2) then + fmtlstbn = trim(fmtlstbn)//',a7,a7,a7' + ! + ! -- sequence number, layer, and cell2d. + else if (size(this%mshape) == 2) then ntabcols = 3 - fmtlstbn = trim(fmtlstbn) // ',a7,a7' - ! - ! -- sequence number and node. + fmtlstbn = trim(fmtlstbn)//',a7,a7' + ! + ! -- sequence number and node. else ntabcols = 2 - fmtlstbn = trim(fmtlstbn) // ',a7' + fmtlstbn = trim(fmtlstbn)//',a7' end if ! ! -- Add fields for non-optional real values ntabcols = ntabcols + ldim do i = 1, ldim - fmtlstbn = trim(fmtlstbn) // ',a16' + fmtlstbn = trim(fmtlstbn)//',a16' end do ! ! -- Add field for boundary name if (this%inamedbound == 1) then ntabcols = ntabcols + 1 - fmtlstbn = trim(fmtlstbn) // ',a16' + fmtlstbn = trim(fmtlstbn)//',a16' end if ! ! -- Add fields for auxiliary variables ntabcols = ntabcols + naux do i = 1, naux - fmtlstbn = trim(fmtlstbn) // ',a16' + fmtlstbn = trim(fmtlstbn)//',a16' end do - fmtlstbn = trim(fmtlstbn) // ')' + fmtlstbn = trim(fmtlstbn)//')' ! ! -- allocate words - allocate(words(ntabcols)) + allocate (words(ntabcols)) ! ! -- parse this%label into words - read(this%label, fmtlstbn) (words(i), i=1, ntabcols) + read (this%label, fmtlstbn) (words(i), i=1, ntabcols) ! ! -- initialize the input table object call table_cr(inputtab, ' ', ' ') @@ -723,7 +724,7 @@ subroutine write_list(this) ! -- discretization if (size(this%mshape) == 3) then nod = this%nodelist(ii) - call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & + call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & i, j, k) call inputtab%add_term(k) call inputtab%add_term(i) @@ -740,7 +741,7 @@ subroutine write_list(this) ! ! -- non-optional variables do jj = 1, ldim - call inputtab%add_term(this%rlist(jj,ii)) + call inputtab%add_term(this%rlist(jj, ii)) end do ! ! -- boundname @@ -750,18 +751,18 @@ subroutine write_list(this) ! ! -- aux variables do jj = 1, naux - call inputtab%add_term(this%auxvar(jj,ii)) + call inputtab%add_term(this%auxvar(jj, ii)) end do - end do + end do ! ! -- deallocate the local variables call inputtab%table_da() - deallocate(inputtab) - nullify(inputtab) - deallocate(words) + deallocate (inputtab) + nullify (inputtab) + deallocate (words) ! ! -- return return end subroutine write_list - + end module ListReaderModule diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 6e403377845..5bafd6b0ff1 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -1,44 +1,46 @@ module MemoryTypeModule - + use KindModule, only: DP, LGP, I4B - use ConstantsModule, only: LENMEMPATH, LENMEMADDRESS, LENTIMESERIESNAME, & - LENVARNAME, MAXMEMRANK, LENMEMTYPE, & - TABSTRING, TABINTEGER, & + use ConstantsModule, only: LENMEMPATH, LENMEMADDRESS, LENTIMESERIESNAME, & + LENVARNAME, MAXMEMRANK, LENMEMTYPE, & + TABSTRING, TABINTEGER, & TABCENTER, TABLEFT, TABRIGHT use TableModule, only: TableType use MemoryHelperModule, only: create_mem_address - + implicit none private public :: MemoryType - + type MemoryType - character(len=LENVARNAME) :: name !< name of the array - character(len=LENVARNAME) :: mastername = 'none' !< name of the master array - character(len=LENMEMPATH) :: path !< path to memory object - character(len=LENMEMPATH) :: masterPath = 'none' !< path to master memory object - character(len=LENMEMTYPE) :: memtype !< type (INTEGER or DOUBLE) - integer(I4B) :: id !< id, not used - integer(I4B) :: nrealloc = 0 !< number of times reallocated - integer(I4B) :: isize !< size of the array - integer(I4B) :: set_handler_idx = 0 !< index of side effect handler for external access - logical(LGP) :: master = .true. !< master copy, others point to this one - logical(LGP), pointer :: logicalsclr => null() !< pointer to the logical - integer(I4B), pointer :: intsclr => null() !< pointer to the integer - real(DP), pointer :: dblsclr => null() !< pointer to the double - integer(I4B), dimension(:), pointer, contiguous :: aint1d => null() !< pointer to 1d integer array - integer(I4B), dimension(:, :), pointer, contiguous :: aint2d => null() !< pointer to 2d integer array - integer(I4B), dimension(:, :, :), pointer, contiguous :: aint3d => null() !< pointer to 3d integer array - real(DP), dimension(:), pointer, contiguous :: adbl1d => null() !< pointer to 1d double array - real(DP), dimension(:, :), pointer, contiguous :: adbl2d => null() !< pointer to 2d double array - real(DP), dimension(:, :, :), pointer, contiguous :: adbl3d => null() !< pointer to 3d double array + character(len=LENVARNAME) :: name !< name of the array + character(len=LENVARNAME) :: mastername = 'none' !< name of the master array + character(len=LENMEMPATH) :: path !< path to memory object + character(len=LENMEMPATH) :: masterPath = 'none' !< path to master memory object + character(len=LENMEMTYPE) :: memtype !< type (INTEGER or DOUBLE) + integer(I4B) :: id !< id, not used + integer(I4B) :: nrealloc = 0 !< number of times reallocated + integer(I4B) :: isize !< size of the array + integer(I4B) :: set_handler_idx = 0 !< index of side effect handler for external access + logical(LGP) :: master = .true. !< master copy, others point to this one + character(len=:), pointer :: strsclr => null() !< pointer to the character string + logical(LGP), pointer :: logicalsclr => null() !< pointer to the logical + integer(I4B), pointer :: intsclr => null() !< pointer to the integer + real(DP), pointer :: dblsclr => null() !< pointer to the double + character(len=:), dimension(:), pointer, contiguous :: astr1d => null() !< pointer to the 1d character string array + integer(I4B), dimension(:), pointer, contiguous :: aint1d => null() !< pointer to 1d integer array + integer(I4B), dimension(:, :), pointer, contiguous :: aint2d => null() !< pointer to 2d integer array + integer(I4B), dimension(:, :, :), pointer, contiguous :: aint3d => null() !< pointer to 3d integer array + real(DP), dimension(:), pointer, contiguous :: adbl1d => null() !< pointer to 1d double array + real(DP), dimension(:, :), pointer, contiguous :: adbl2d => null() !< pointer to 2d double array + real(DP), dimension(:, :, :), pointer, contiguous :: adbl3d => null() !< pointer to 3d double array contains procedure :: table_entry procedure :: mt_associated end type - - contains - + +contains + subroutine table_entry(this, memtab) ! -- dummy class(MemoryType) :: this @@ -54,7 +56,7 @@ subroutine table_entry(this, memtab) if (ipos < 1) then ipos = 16 else - ipos = min(16,ipos-1) + ipos = min(16, ipos - 1) end if cmem = this%memtype(1:ipos) ! @@ -79,15 +81,17 @@ function mt_associated(this) result(al) class(MemoryType) :: this logical :: al al = .false. - if(associated(this%logicalsclr)) al = .true. - if(associated(this%intsclr)) al = .true. - if(associated(this%dblsclr)) al = .true. - if(associated(this%aint1d)) al = .true. - if(associated(this%aint2d)) al = .true. - if(associated(this%aint3d)) al = .true. - if(associated(this%adbl1d)) al = .true. - if(associated(this%adbl2d)) al = .true. - if(associated(this%adbl3d)) al = .true. + if (associated(this%strsclr)) al = .true. + if (associated(this%logicalsclr)) al = .true. + if (associated(this%intsclr)) al = .true. + if (associated(this%dblsclr)) al = .true. + if (associated(this%astr1d)) al = .true. + if (associated(this%aint1d)) al = .true. + if (associated(this%aint2d)) al = .true. + if (associated(this%aint3d)) al = .true. + if (associated(this%adbl1d)) al = .true. + if (associated(this%adbl2d)) al = .true. + if (associated(this%adbl3d)) al = .true. end function mt_associated - -end module MemoryTypeModule \ No newline at end of file + +end module MemoryTypeModule diff --git a/src/Utilities/Memory/MemoryHelper.f90 b/src/Utilities/Memory/MemoryHelper.f90 index a06d20c2255..e14541398c6 100644 --- a/src/Utilities/Memory/MemoryHelper.f90 +++ b/src/Utilities/Memory/MemoryHelper.f90 @@ -1,6 +1,7 @@ module MemoryHelperModule use KindModule, only: I4B, LGP - use ConstantsModule, only: LENMEMPATH, LENMEMSEPARATOR, LENMEMADDRESS, LENVARNAME, LENCOMPONENTNAME + use ConstantsModule, only: LENMEMPATH, LENMEMSEPARATOR, LENMEMADDRESS, & + LENVARNAME, LENCOMPONENTNAME use SimModule, only: store_error use SimVariablesModule, only: errmsg @@ -13,24 +14,24 @@ module MemoryHelperModule !> @brief returns the path to the memory object !! !! Returns the path to the location in the memory manager where - !! the variables for this (sub)component are stored, the 'memoryPath' + !! the variables for this (sub)component are stored, the 'memoryPath' !! !! NB: no need to trim the input parameters !< function create_mem_path(component, subcomponent) result(memory_path) - character(len=*), intent(in) :: component !< name of the solution, model, or exchange - character(len=*), intent(in), optional :: subcomponent !< name of the package (optional) - character(len=LENMEMPATH) :: memory_path !< the memory path - + character(len=*), intent(in) :: component !< name of the solution, model, or exchange + character(len=*), intent(in), optional :: subcomponent !< name of the package (optional) + character(len=LENMEMPATH) :: memory_path !< the memory path + call mem_check_length(component, LENCOMPONENTNAME, "solution/model/exchange") - call mem_check_length(subcomponent, LENCOMPONENTNAME, "package") - + call mem_check_length(subcomponent, LENCOMPONENTNAME, "package") + if (present(subcomponent)) then - memory_path = trim(component) // memPathSeparator // trim(subcomponent) + memory_path = trim(component)//memPathSeparator//trim(subcomponent) else memory_path = trim(component) end if - + end function create_mem_path !> @brief returns the address string of the memory object @@ -40,24 +41,24 @@ end function create_mem_path !! NB: no need to trim the input parameters !< function create_mem_address(mem_path, var_name) result(mem_address) - character(len=*), intent(in) :: mem_path !< path to the memory object - character(len=*), intent(in) :: var_name !< name of the stored variable + character(len=*), intent(in) :: mem_path !< path to the memory object + character(len=*), intent(in) :: var_name !< name of the stored variable character(len=LENMEMADDRESS) :: mem_address !< full address string to the memory object call mem_check_length(mem_path, LENMEMPATH, "memory path") call mem_check_length(var_name, LENVARNAME, "variable") - mem_address = trim(mem_path) // memPathSeparator // trim(var_name) + mem_address = trim(mem_path)//memPathSeparator//trim(var_name) - end function create_mem_address + end function create_mem_address !> @brief Split a memory address string into memory path and variable name !< subroutine split_mem_address(mem_address, mem_path, var_name, success) - character(len=*), intent(in) :: mem_address !< the full memory address string - character(len=LENMEMPATH), intent(out) :: mem_path !< the memory path - character(len=LENVARNAME), intent(out) :: var_name !< the variable name - logical(LGP), intent(out) :: success !< true when successful + character(len=*), intent(in) :: mem_address !< the full memory address string + character(len=LENMEMPATH), intent(out) :: mem_path !< the memory path + character(len=LENVARNAME), intent(out) :: var_name !< the variable name + logical(LGP), intent(out) :: success !< true when successful ! local integer(I4B) :: idx @@ -65,48 +66,47 @@ subroutine split_mem_address(mem_address, mem_path, var_name, success) ! if no separator, or it's at the end of the string, ! the memory address is not valid: - if(idx < 1 .or. idx == len(mem_address)) then + if (idx < 1 .or. idx == len(mem_address)) then success = .false. mem_path = '' var_name = '' else success = .true. - mem_path = mem_address(:idx-1) - var_name = mem_address(idx+1:) + mem_path = mem_address(:idx - 1) + var_name = mem_address(idx + 1:) end if - + end subroutine split_mem_address !> @brief Split the memory path into component(s) !! - !! NB: when there is no subcomponent in the path, the + !! NB: when there is no subcomponent in the path, the !! value for @par subcomponent is set to an empty string. !< - subroutine split_mem_path(mem_path, component, subcomponent) - character(len=*), intent(in) :: mem_path !< path to the memory object - character(len=LENCOMPONENTNAME), intent(out) :: component !< name of the component (solution, model, exchange) - character(len=LENCOMPONENTNAME), intent(out) :: subcomponent !< name of the subcomponent (package) - + subroutine split_mem_path(mem_path, component, subcomponent) + character(len=*), intent(in) :: mem_path !< path to the memory object + character(len=LENCOMPONENTNAME), intent(out) :: component !< name of the component (solution, model, exchange) + character(len=LENCOMPONENTNAME), intent(out) :: subcomponent !< name of the subcomponent (package) + ! local integer(I4B) :: idx idx = index(mem_path, memPathSeparator, back=.true.) ! if the separator is found at the end of the string, ! the path is invalid: - if(idx == len(mem_path)) then - write(errmsg, '(*(G0))') & + if (idx == len(mem_path)) then + write (errmsg, '(*(G0))') & 'Fatal error in Memory Manager, cannot split invalid memory path: ', & - mem_path + mem_path ! -- store error and stop program execution call store_error(errmsg, terminate=.TRUE.) end if - if (idx > 0) then ! when found: - component = mem_path(:idx-1) - subcomponent = mem_path(idx+1:) + component = mem_path(:idx - 1) + subcomponent = mem_path(idx + 1:) else ! when not found, there apparently is no subcomponent: component = mem_path @@ -119,7 +119,7 @@ end subroutine split_mem_path !! !! The string will be trimmed before the measurement. !! - !! @warning{if the length exceeds the maximum, a message is recorded + !! @warning{if the length exceeds the maximum, a message is recorded !! and the program will be stopped} !! !! The description should describe the part of the address that is checked @@ -127,13 +127,13 @@ end subroutine split_mem_path !! itself !< subroutine mem_check_length(name, max_length, description) - character(len=*), intent(in) :: name !< string to be checked - integer(I4B), intent(in) :: max_length !< maximum length + character(len=*), intent(in) :: name !< string to be checked + integer(I4B), intent(in) :: max_length !< maximum length character(len=*), intent(in) :: description !< a descriptive string - - if(len(trim(name)) > max_length) then - write(errmsg, '(*(G0))') & - 'Fatal error in Memory Manager, length of ', description, ' must be ', & + + if (len(trim(name)) > max_length) then + write (errmsg, '(*(G0))') & + 'Fatal error in Memory Manager, length of ', description, ' must be ', & max_length, ' characters or less: ', name, '(len=', len(trim(name)), ')' ! -- store error and stop program execution @@ -141,4 +141,4 @@ subroutine mem_check_length(name, max_length, description) end if end subroutine mem_check_length -end module MemoryHelperModule \ No newline at end of file +end module MemoryHelperModule diff --git a/src/Utilities/Memory/MemoryList.f90 b/src/Utilities/Memory/MemoryList.f90 index 15210b6135f..94e5045398a 100644 --- a/src/Utilities/Memory/MemoryList.f90 +++ b/src/Utilities/Memory/MemoryList.f90 @@ -4,7 +4,7 @@ module MemoryListModule use ListModule, only: ListType private public :: MemoryListType - + type :: MemoryListType type(ListType), private :: list contains @@ -13,9 +13,9 @@ module MemoryListModule procedure :: count procedure :: clear end type MemoryListType - - contains - + +contains + subroutine add(this, mt) class(MemoryListType) :: this type(MemoryType), pointer :: mt @@ -23,7 +23,7 @@ subroutine add(this, mt) obj => mt call this%list%add(obj) end subroutine add - + function get(this, ipos) result(res) class(MemoryListType) :: this integer(I4B), intent(in) :: ipos @@ -36,7 +36,7 @@ function get(this, ipos) result(res) end select return end function get - + function count(this) result(nval) class(MemoryListType) :: this integer(I4B) :: nval @@ -48,5 +48,5 @@ subroutine clear(this) class(MemoryListType) :: this call this%list%Clear() end subroutine clear - -end module MemoryListModule \ No newline at end of file + +end module MemoryListModule diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index dce1bdddc99..6cb62978bac 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1,20 +1,20 @@ module MemoryManagerModule - use KindModule, only: DP, LGP, I4B, I8B - use ConstantsModule, only: DZERO, DONE, & - DEM3, DEM6, DEM9, DEP3, DEP6, DEP9, & - LENMEMPATH, LENMEMSEPARATOR, LENVARNAME, & - LENCOMPONENTNAME, LINELENGTH, LENMEMTYPE, & - LENMEMADDRESS, TABSTRING, TABUCSTRING, & - TABINTEGER, TABREAL, TABCENTER, TABLEFT, & - TABRIGHT - use SimVariablesModule, only: errmsg - use SimModule, only: store_error, count_errors - use MemoryTypeModule, only: MemoryType - use MemoryListModule, only: MemoryListType - use MemoryHelperModule, only: mem_check_length, split_mem_path - use TableModule, only: TableType, table_cr - + use KindModule, only: DP, LGP, I4B, I8B + use ConstantsModule, only: DZERO, DONE, & + DEM3, DEM6, DEM9, DEP3, DEP6, DEP9, & + LENMEMPATH, LENMEMSEPARATOR, LENVARNAME, & + LENCOMPONENTNAME, LINELENGTH, LENMEMTYPE, & + LENMEMADDRESS, TABSTRING, TABUCSTRING, & + TABINTEGER, TABREAL, TABCENTER, TABLEFT, & + TABRIGHT + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, count_errors + use MemoryTypeModule, only: MemoryType + use MemoryListModule, only: MemoryListType + use MemoryHelperModule, only: mem_check_length, split_mem_path + use TableModule, only: TableType, table_cr + implicit none private public :: mem_allocate @@ -28,7 +28,7 @@ module MemoryManagerModule public :: mem_da public :: mem_set_print_option public :: get_from_memorylist - + public :: get_mem_type public :: get_mem_rank public :: get_mem_elem_size @@ -37,7 +37,7 @@ module MemoryManagerModule public :: copy_dbl1d public :: memorylist - + type(MemoryListType) :: memorylist type(TableType), pointer :: memtab => null() integer(I8B) :: nvalues_alogical = 0 @@ -47,65 +47,65 @@ module MemoryManagerModule integer(I4B) :: iprmem = 0 interface mem_allocate - module procedure allocate_logical, & - allocate_str, allocate_str1d, & - allocate_int, allocate_int1d, allocate_int2d, & - allocate_int3d, & - allocate_dbl, allocate_dbl1d, allocate_dbl2d, & - allocate_dbl3d + module procedure allocate_logical, & + allocate_str, allocate_str1d, & + allocate_int, allocate_int1d, allocate_int2d, & + allocate_int3d, & + allocate_dbl, allocate_dbl1d, allocate_dbl2d, & + allocate_dbl3d end interface mem_allocate - + interface mem_checkin - module procedure checkin_int1d, & - checkin_dbl1d + module procedure checkin_int1d, & + checkin_dbl1d end interface mem_checkin - + interface mem_reallocate - module procedure reallocate_int1d, reallocate_int2d, reallocate_dbl1d, & - reallocate_dbl2d, reallocate_str1d + module procedure reallocate_int1d, reallocate_int2d, reallocate_dbl1d, & + reallocate_dbl2d, reallocate_str1d end interface mem_reallocate - + interface mem_setptr - module procedure setptr_logical, & - setptr_int, setptr_int1d, setptr_int2d, setptr_int3d, & - setptr_dbl, setptr_dbl1d, setptr_dbl2d, setptr_dbl3d + module procedure setptr_logical, & + setptr_int, setptr_int1d, setptr_int2d, setptr_int3d, & + setptr_dbl, setptr_dbl1d, setptr_dbl2d, setptr_dbl3d end interface mem_setptr - + interface mem_copyptr - module procedure copyptr_int1d, copyptr_int2d, & - copyptr_dbl1d, copyptr_dbl2d + module procedure copyptr_int1d, copyptr_int2d, & + copyptr_dbl1d, copyptr_dbl2d end interface mem_copyptr interface mem_reassignptr - module procedure reassignptr_int, & - reassignptr_int1d, reassignptr_int2d, & - reassignptr_dbl1d, reassignptr_dbl2d + module procedure reassignptr_int, & + reassignptr_int1d, reassignptr_int2d, & + reassignptr_dbl1d, reassignptr_dbl2d end interface mem_reassignptr interface mem_deallocate - module procedure deallocate_logical, & - deallocate_str, deallocate_str1d, & - deallocate_int, deallocate_int1d, deallocate_int2d, & - deallocate_int3d, & - deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & - deallocate_dbl3d + module procedure deallocate_logical, & + deallocate_str, deallocate_str1d, & + deallocate_int, deallocate_int1d, deallocate_int2d, & + deallocate_int3d, & + deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & + deallocate_dbl3d end interface mem_deallocate - contains - +contains + !> @ brief Get the variable memory type !! !! Returns any of 'LOGICAL', 'INTEGER', 'DOUBLE', 'STRING'. !! returns 'UNKNOWN' when the variable is not found. !< subroutine get_mem_type(name, mem_path, var_type) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - character(len=LENMEMTYPE), intent(out) :: var_type !< memory type + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + character(len=LENMEMTYPE), intent(out) :: var_type !< memory type ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found - ! -- code + ! -- code mt => null() var_type = 'UNKNOWN' call get_from_memorylist(name, mem_path, mt, found) @@ -116,19 +116,19 @@ subroutine get_mem_type(name, mem_path, var_type) ! -- return return end subroutine get_mem_type - + !> @ brief Get the variable rank !! !! Returns rank = -1 when not found. !< subroutine get_mem_rank(name, mem_path, rank) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< mem_path - integer(I4B), intent(out) :: rank !< rank + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< mem_path + integer(I4B), intent(out) :: rank !< rank ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found - ! -- code + ! -- code ! ! -- initialize rank to a value to communicate failure rank = -1 @@ -138,29 +138,29 @@ subroutine get_mem_rank(name, mem_path, rank) ! ! -- set rank if (found) then - if(associated(mt%logicalsclr)) rank = 0 - if(associated(mt%intsclr)) rank = 0 - if(associated(mt%dblsclr)) rank = 0 - if(associated(mt%aint1d)) rank = 1 - if(associated(mt%aint2d)) rank = 2 - if(associated(mt%aint3d)) rank = 3 - if(associated(mt%adbl1d)) rank = 1 - if(associated(mt%adbl2d)) rank = 2 - if(associated(mt%adbl3d)) rank = 3 - end if + if (associated(mt%logicalsclr)) rank = 0 + if (associated(mt%intsclr)) rank = 0 + if (associated(mt%dblsclr)) rank = 0 + if (associated(mt%aint1d)) rank = 1 + if (associated(mt%aint2d)) rank = 2 + if (associated(mt%aint3d)) rank = 3 + if (associated(mt%adbl1d)) rank = 1 + if (associated(mt%adbl2d)) rank = 2 + if (associated(mt%adbl3d)) rank = 3 + end if ! ! -- return return - end subroutine get_mem_rank - + end subroutine get_mem_rank + !> @ brief Get the memory size of a single element of the stored variable !! !! Memory size in bytes, returns size = -1 when not found. !< subroutine get_mem_elem_size(name, mem_path, size) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), intent(out) :: size !< size of the variable in bytes + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(out) :: size !< size of the variable in bytes ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found @@ -173,8 +173,8 @@ subroutine get_mem_elem_size(name, mem_path, size) call get_from_memorylist(name, mem_path, mt, found) ! ! -- set memory size - if (found) then - select case(mt%memtype(1:index(mt%memtype,' '))) + if (found) then + select case (mt%memtype(1:index(mt%memtype, ' '))) case ('STRING') size = 1 case ('LOGICAL') @@ -183,22 +183,22 @@ subroutine get_mem_elem_size(name, mem_path, size) size = 4 case ('DOUBLE') size = 8 - end select + end select end if ! ! -- return return end subroutine get_mem_elem_size - + !> @ brief Get the variable memory shape !! !! Returns an integer array with the shape (Fortran ordering), !! and set shape(1) = -1 when not found. !< subroutine get_mem_shape(name, mem_path, mem_shape) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), dimension(:), intent(out) :: mem_shape !< shape of the variable + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), dimension(:), intent(out) :: mem_shape !< shape of the variable ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found @@ -209,16 +209,16 @@ subroutine get_mem_shape(name, mem_path, mem_shape) ! ! -- set shape if (found) then - if(associated(mt%logicalsclr)) mem_shape = shape(mt%logicalsclr) - if(associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr) - if(associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr) - if(associated(mt%aint1d)) mem_shape = shape(mt%aint1d) - if(associated(mt%aint2d)) mem_shape = shape(mt%aint2d) - if(associated(mt%aint3d)) mem_shape = shape(mt%aint3d) - if(associated(mt%adbl1d)) mem_shape = shape(mt%adbl1d) - if(associated(mt%adbl2d)) mem_shape = shape(mt%adbl2d) - if(associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d) - ! -- to communicate failure + if (associated(mt%logicalsclr)) mem_shape = shape(mt%logicalsclr) + if (associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr) + if (associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr) + if (associated(mt%aint1d)) mem_shape = shape(mt%aint1d) + if (associated(mt%aint2d)) mem_shape = shape(mt%aint2d) + if (associated(mt%aint3d)) mem_shape = shape(mt%aint3d) + if (associated(mt%adbl1d)) mem_shape = shape(mt%adbl1d) + if (associated(mt%adbl2d)) mem_shape = shape(mt%adbl2d) + if (associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d) + ! -- to communicate failure else mem_shape(1) = -1 end if @@ -226,19 +226,19 @@ subroutine get_mem_shape(name, mem_path, mem_shape) ! -- return return end subroutine get_mem_shape - + !> @ brief Get the number of elements for this variable !! !! Returns with isize = -1 when not found. !< subroutine get_isize(name, mem_path, isize) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), intent(out) :: isize !< number of elements (flattened) + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(out) :: isize !< number of elements (flattened) ! -- local type(MemoryType), pointer :: mt => null() logical(LGP) :: found - ! -- code + ! -- code ! ! -- initialize isize to a value to communicate failure isize = -1 @@ -254,19 +254,19 @@ subroutine get_isize(name, mem_path, isize) ! -- return return end subroutine get_isize - + !> @ brief Get a memory type entry from the memory list !! !! Default value for @par check is .true. which means that this !! routine will kill the program when the memory entry cannot be found. !< subroutine get_from_memorylist(name, mem_path, mt, found, check) - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - type(MemoryType), pointer, intent(inout) :: mt !< memory type entry - logical(LGP),intent(out) :: found !< set to .true. when found - logical(LGP), intent(in), optional :: check !< to suppress aborting the program when not found, - !! set check = .false. + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + type(MemoryType), pointer, intent(inout) :: mt !< memory type entry + logical(LGP), intent(out) :: found !< set to .true. when found + logical(LGP), intent(in), optional :: check !< to suppress aborting the program when not found, + !! set check = .false. ! -- local integer(I4B) :: ipos logical(LGP) check_opt @@ -279,7 +279,7 @@ subroutine get_from_memorylist(name, mem_path, mt, found, check) ! -- iterate over the memory list do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(mt%name == name .and. mt%path == mem_path) then + if (mt%name == name .and. mt%path == mem_path) then found = .true. exit end if @@ -290,9 +290,9 @@ subroutine get_from_memorylist(name, mem_path, mt, found, check) end if if (check_opt) then if (.not. found) then - errmsg = "Programming error in memory manager. Variable '" // & - trim(name) // "' in '" // trim(mem_path) // "' cannot be " // & - "assigned because it does not exist in memory manager." + errmsg = "Programming error in memory manager. Variable '"// & + trim(name)//"' in '"//trim(mem_path)//"' cannot be "// & + "assigned because it does not exist in memory manager." call store_error(errmsg, terminate=.TRUE.) end if end if @@ -300,39 +300,39 @@ subroutine get_from_memorylist(name, mem_path, mt, found, check) ! -- return return end subroutine get_from_memorylist - + !> @brief Issue allocation error message and stop program execution !< subroutine allocate_error(varname, mem_path, istat, isize) - character(len=*), intent(in) :: varname !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored - integer(I4B), intent(in) :: istat !< status code - integer(I4B), intent(in) :: isize !< size of allocation + character(len=*), intent(in) :: varname !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), intent(in) :: istat !< status code + integer(I4B), intent(in) :: isize !< size of allocation ! -- local - character(len=20) :: csize - character(len=20) :: cstat + character(len=20) :: csize + character(len=20) :: cstat ! -- code ! ! -- initialize character variables - write(csize, '(i0)') isize - write(cstat, '(i0)') istat + write (csize, '(i0)') isize + write (cstat, '(i0)') istat ! ! -- create error message - errmsg = "Error trying to allocate memory. Path '" // trim(mem_path) // & - "' variable name '" // trim(varname) // "' size '" // trim(csize) // & - "'. Error message is '" // trim(adjustl(errmsg)) // & - "'. Status code is " // trim(cstat) // '.' + errmsg = "Error trying to allocate memory. Path '"//trim(mem_path)// & + "' variable name '"//trim(varname)//"' size '"//trim(csize)// & + "'. Error message is '"//trim(adjustl(errmsg))// & + "'. Status code is "//trim(cstat)//'.' ! ! -- store error and stop program execution call store_error(errmsg, terminate=.TRUE.) - end subroutine allocate_error + end subroutine allocate_error !> @brief Allocate a logical scalar !< subroutine allocate_logical(sclr, name, mem_path) - logical(LGP), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + logical(LGP), pointer, intent(inout) :: sclr !< variable for allocation + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local integer(I4B) :: istat type(MemoryType), pointer :: mt @@ -342,8 +342,8 @@ subroutine allocate_logical(sclr, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate the logical scalar - allocate(sclr, stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (sclr, stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if ! @@ -351,14 +351,14 @@ subroutine allocate_logical(sclr, name, mem_path) nvalues_alogical = nvalues_alogical + 1 ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%logicalsclr => sclr mt%isize = 1 mt%name = name mt%path = mem_path - write(mt%memtype, "(a)") 'LOGICAL' + write (mt%memtype, "(a)") 'LOGICAL' ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -370,10 +370,10 @@ end subroutine allocate_logical !> @brief Allocate a character string !< subroutine allocate_str(sclr, ilen, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length + integer(I4B), intent(in) :: ilen !< string length character(len=ilen), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local integer(I4B) :: istat type(MemoryType), pointer :: mt @@ -382,7 +382,7 @@ subroutine allocate_str(sclr, ilen, name, mem_path) ! ! -- make sure ilen is greater than 0 if (ilen < 1) then - errmsg = 'Programming error in allocate_str. ILEN must be greater than 0.' + errmsg = 'Programming error in allocate_str. ILEN must be greater than 0.' call store_error(errmsg, terminate=.TRUE.) end if ! @@ -390,7 +390,7 @@ subroutine allocate_str(sclr, ilen, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate string - allocate(character(len=ilen) :: sclr, stat=istat, errmsg=errmsg) + allocate (character(len=ilen) :: sclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if @@ -402,13 +402,14 @@ subroutine allocate_str(sclr, ilen, name, mem_path) nvalues_astr = nvalues_astr + ilen ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type + mt%strsclr => sclr mt%isize = ilen mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen + write (mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen ! ! -- add defined length string to the memory manager list call memorylist%add(mt) @@ -416,15 +417,16 @@ subroutine allocate_str(sclr, ilen, name, mem_path) ! -- return return end subroutine allocate_str - - !> @brief Allocate a 1-dimensional defined length string array + + !> @brief Allocate a 1-dimensional defined length string array !< - subroutine allocate_str1d(astr, ilen, nrow, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length - character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< variable for allocation - integer(I4B), intent(in) :: nrow !< number of strings in array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path) + integer(I4B), intent(in) :: ilen !< string length + character(len=ilen), dimension(:), & + pointer, contiguous, intent(inout) :: astr1d !< variable for allocation + integer(I4B), intent(in) :: nrow !< number of strings in array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local variables type(MemoryType), pointer :: mt character(len=ilen) :: string @@ -438,8 +440,8 @@ subroutine allocate_str1d(astr, ilen, nrow, name, mem_path) ! ! -- make sure ilen is greater than 0 if (ilen < 1) then - errmsg = 'Programming error in allocate_str1d. ' // & - 'ILEN must be greater than 0.' + errmsg = 'Programming error in allocate_str1d. '// & + 'ILEN must be greater than 0.' call store_error(errmsg, terminate=.TRUE.) end if ! @@ -450,7 +452,7 @@ subroutine allocate_str1d(astr, ilen, nrow, name, mem_path) isize = ilen * nrow ! ! -- allocate defined length string array - allocate(character(len=ilen) :: astr(nrow), stat=istat, errmsg=errmsg) + allocate (character(len=ilen) :: astr1d(nrow), stat=istat, errmsg=errmsg) ! ! -- check for error condition if (istat /= 0) then @@ -459,20 +461,21 @@ subroutine allocate_str1d(astr, ilen, nrow, name, mem_path) ! ! -- fill deferred length string with empty string do n = 1, nrow - astr(n) = string + astr1d(n) = string end do ! ! -- update counter nvalues_astr = nvalues_astr + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type + mt%astr1d => astr1d mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow ! ! -- add deferred length character array to the memory manager list call memorylist%add(mt) @@ -484,9 +487,9 @@ end subroutine allocate_str1d !> @brief Allocate a integer scalar !< subroutine allocate_int(sclr, name, mem_path) - integer(I4B), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where the variable is stored + integer(I4B), pointer, intent(inout) :: sclr !< variable for allocation + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where the variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -496,7 +499,7 @@ subroutine allocate_int(sclr, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate integer scalar - allocate(sclr, stat=istat, errmsg=errmsg) + allocate (sclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if @@ -505,14 +508,14 @@ subroutine allocate_int(sclr, name, mem_path) nvalues_aint = nvalues_aint + 1 ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%intsclr => sclr mt%isize = 1 mt%name = name mt%path = mem_path - write(mt%memtype, "(a)") 'INTEGER' + write (mt%memtype, "(a)") 'INTEGER' ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -520,14 +523,14 @@ subroutine allocate_int(sclr, name, mem_path) ! -- return return end subroutine allocate_int - + !> @brief Allocate a 1-dimensional integer array !< subroutine allocate_int1d(aint, nrow, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< variable for allocation - integer(I4B), intent(in) :: nrow !< integer array number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< variable for allocation + integer(I4B), intent(in) :: nrow !< integer array number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! --local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -541,7 +544,7 @@ subroutine allocate_int1d(aint, nrow, name, mem_path) isize = nrow ! ! -- allocate integer array - allocate(aint(nrow), stat=istat, errmsg=errmsg) + allocate (aint(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -550,14 +553,14 @@ subroutine allocate_int1d(aint, nrow, name, mem_path) nvalues_aint = nvalues_aint + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint1d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -565,15 +568,15 @@ subroutine allocate_int1d(aint, nrow, name, mem_path) ! -- return return end subroutine allocate_int1d - + !> @brief Allocate a 2-dimensional integer array !< subroutine allocate_int2d(aint, ncol, nrow, name, mem_path) - integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -587,7 +590,7 @@ subroutine allocate_int2d(aint, ncol, nrow, name, mem_path) isize = ncol * nrow ! ! -- allocate the integer array - allocate(aint(ncol, nrow), stat=istat, errmsg=errmsg) + allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -596,30 +599,30 @@ subroutine allocate_int2d(aint, ncol, nrow, name, mem_path) nvalues_aint = nvalues_aint + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint2d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! ! -- add memory type to the memory list call memorylist%add(mt) ! ! -- return end subroutine allocate_int2d - + !> @brief Allocate a 3-dimensional integer array !< subroutine allocate_int3d(aint, ncol, nrow, nlay, name, mem_path) - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - integer(I4B), intent(in) :: nlay !< number of layers - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + integer(I4B), intent(in) :: nlay !< number of layers + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -633,24 +636,24 @@ subroutine allocate_int3d(aint, ncol, nrow, nlay, name, mem_path) isize = ncol * nrow * nlay ! ! -- allocate integer array - allocate(aint(ncol, nrow, nlay), stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (aint(ncol, nrow, nlay), stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if ! - ! -- update counter + ! -- update counter nvalues_aint = nvalues_aint + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint3d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & - nrow, nlay + write (mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, & + nrow, nlay ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -662,9 +665,9 @@ end subroutine allocate_int3d !> @brief Allocate a real scalar !< subroutine allocate_dbl(sclr, name, mem_path) - real(DP), pointer, intent(inout) :: sclr !< variable for allocation - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), pointer, intent(inout) :: sclr !< variable for allocation + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -674,7 +677,7 @@ subroutine allocate_dbl(sclr, name, mem_path) call mem_check_length(name, LENVARNAME, "variable") ! ! -- allocate real scalar - allocate(sclr, stat=istat, errmsg=errmsg) + allocate (sclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, 1) end if @@ -683,14 +686,14 @@ subroutine allocate_dbl(sclr, name, mem_path) nvalues_aint = nvalues_aint + 1 ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%dblsclr => sclr mt%isize = 1 mt%name = name mt%path = mem_path - write(mt%memtype, "(a)") 'DOUBLE' + write (mt%memtype, "(a)") 'DOUBLE' ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -698,14 +701,14 @@ subroutine allocate_dbl(sclr, name, mem_path) ! -- return return end subroutine allocate_dbl - + !> @brief Allocate a 1-dimensional real array !< subroutine allocate_dbl1d(adbl, nrow, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< variable for allocation - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< variable for allocation + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -719,7 +722,7 @@ subroutine allocate_dbl1d(adbl, nrow, name, mem_path) isize = nrow ! ! -- allocate the real array - allocate(adbl(nrow), stat=istat, errmsg=errmsg) + allocate (adbl(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -728,14 +731,14 @@ subroutine allocate_dbl1d(adbl, nrow, name, mem_path) nvalues_adbl = nvalues_adbl + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl1d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -743,15 +746,15 @@ subroutine allocate_dbl1d(adbl, nrow, name, mem_path) ! -- return return end subroutine allocate_dbl1d - + !> @brief Allocate a 2-dimensional real array !< subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -765,7 +768,7 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) isize = ncol * nrow ! ! -- allocate the real array - allocate(adbl(ncol, nrow), stat=istat, errmsg=errmsg) + allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -774,14 +777,14 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) nvalues_adbl = nvalues_adbl + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl2d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -789,16 +792,16 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path) ! -- return return end subroutine allocate_dbl2d - + !> @brief Allocate a 3-dimensional real array !< subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) - real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - integer(I4B), intent(in) :: nlay !< number of layers - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + integer(I4B), intent(in) :: nlay !< number of layers + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -812,7 +815,7 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) isize = ncol * nrow * nlay ! ! -- allocate the real array - allocate(adbl(ncol, nrow, nlay), stat=istat, errmsg=errmsg) + allocate (adbl(ncol, nrow, nlay), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -821,15 +824,15 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) nvalues_adbl = nvalues_adbl + isize ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl3d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & - nrow, nlay + write (mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, & + nrow, nlay ! ! -- add memory type to the memory list call memorylist%add(mt) @@ -837,15 +840,15 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path) ! -- return return end subroutine allocate_dbl3d - + !> @brief Check in an existing 1d integer array with a new address (name + path) !< subroutine checkin_int1d(aint, name, mem_path, name2, mem_path2) integer(I4B), dimension(:), pointer, contiguous, intent(in) :: aint !< the existing array - character(len=*), intent(in) :: name !< new variable name - character(len=*), intent(in) :: mem_path !< new path where variable is stored - character(len=*), intent(in) :: name2 !< existing variable name - character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored + character(len=*), intent(in) :: name !< new variable name + character(len=*), intent(in) :: mem_path !< new path where variable is stored + character(len=*), intent(in) :: name2 !< existing variable name + character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored ! --local type(MemoryType), pointer :: mt integer(I4B) :: isize @@ -858,14 +861,14 @@ subroutine checkin_int1d(aint, name, mem_path, name2, mem_path2) isize = size(aint) ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%aint1d => aint mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize ! ! -- set master information mt%master = .false. @@ -882,11 +885,11 @@ end subroutine checkin_int1d !> @brief Check in an existing 1d double precision array with a new address (name + path) !< subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the existing array - character(len=*), intent(in) :: name !< new variable name - character(len=*), intent(in) :: mem_path !< new path where variable is stored - character(len=*), intent(in) :: name2 !< existing variable name - character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the existing array + character(len=*), intent(in) :: name !< new variable name + character(len=*), intent(in) :: mem_path !< new path where variable is stored + character(len=*), intent(in) :: name2 !< existing variable name + character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: isize @@ -899,14 +902,14 @@ subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2) isize = size(adbl) ! ! -- allocate memory type - allocate(mt) + allocate (mt) ! ! -- set memory type mt%adbl1d => adbl mt%isize = isize mt%name = name mt%path = mem_path - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! ! -- set master information mt%master = .false. @@ -919,15 +922,15 @@ subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2) ! -- return return end subroutine checkin_dbl1d - + !> @brief Reallocate a 1-dimensional defined length string array !< subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length - integer(I4B), intent(in) :: nrow !< number of rows + integer(I4B), intent(in) :: ilen !< string length + integer(I4B), intent(in) :: nrow !< number of rows character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reallocated string array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -954,7 +957,7 @@ subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) isize = ilen * nrow ! ! -- allocate astrtemp - allocate(astrtemp(nrow), stat=istat, errmsg=errmsg) + allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if @@ -970,46 +973,46 @@ subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(astr) + deallocate (astr) ! ! -- allocate astr1d - allocate(astr(nrow), stat=istat, errmsg=errmsg) + allocate (astr(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if ! ! -- fill the reallocate character array do n = 1, nrow - astr(n) = astrtemp(n) + astr(n) = astrtemp(n) end do ! ! -- deallocate temporary storage - deallocate(astrtemp) + deallocate (astrtemp) ! ! -- reset memory manager values mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_astr = nvalues_astr + isize - isize_old - write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow else - errmsg = "Programming error, varible '" // trim(name) // "' from '" // & - trim(mem_path) // "' is not defined in the memory manager. Use " // & - "mem_allocate instead." + errmsg = "Programming error, varible '"//trim(name)//"' from '"// & + trim(mem_path)//"' is not defined in the memory manager. Use "// & + "mem_allocate instead." call store_error(errmsg, terminate=.TRUE.) end if ! ! -- return return end subroutine reallocate_str1d - + !> @brief Reallocate a 1-dimensional integer array !< subroutine reallocate_int1d(aint, nrow, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1027,16 +1030,16 @@ subroutine reallocate_int1d(aint, nrow, name, mem_path) isize = nrow isizeold = size(mt%aint1d) ifill = min(isizeold, isize) - allocate(aint(nrow), stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (aint(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ifill aint(i) = mt%aint1d(i) - enddo + end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%aint1d) + deallocate (mt%aint1d) mt%aint1d => aint mt%isize = isize mt%nrealloc = mt%nrealloc + 1 @@ -1046,15 +1049,15 @@ subroutine reallocate_int1d(aint, nrow, name, mem_path) ! -- return return end subroutine reallocate_int1d - + !> @brief Reallocate a 2-dimensional integer array !< subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reallocated 2d integer array - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1073,36 +1076,36 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) ishape = shape(mt%aint2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate(aint(ncol, nrow), stat=istat, errmsg=errmsg) + allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ishape(2) do j = 1, ishape(1) aint(j, i) = mt%aint2d(j, i) - enddo - enddo + end do + end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%aint2d) + deallocate (mt%aint2d) mt%aint2d => aint mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_aint = nvalues_aint + isize - isizeold - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! ! -- return return end subroutine reallocate_int2d - + !> @brief Reallocate a 1-dimensional real array !< subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -1120,35 +1123,35 @@ subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) isize = nrow isizeold = size(mt%adbl1d) ifill = min(isizeold, isize) - allocate(adbl(nrow), stat=istat, errmsg=errmsg) + allocate (adbl(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ifill adbl(i) = mt%adbl1d(i) - enddo + end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%adbl1d) + deallocate (mt%adbl1d) mt%adbl1d => adbl mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize ! ! -- return return end subroutine reallocate_dbl1d - + !> @brief Reallocate a 2-dimensional real array !< subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reallocated 2d real array - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1167,8 +1170,8 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) ishape = shape(mt%adbl2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate(adbl(ncol, nrow), stat=istat, errmsg=errmsg) - if(istat /= 0) then + allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if do i = 1, ishape(2) @@ -1178,165 +1181,165 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) end do ! ! -- deallocate mt pointer, repoint, recalculate isize - deallocate(mt%adbl2d) + deallocate (mt%adbl2d) mt%adbl2d => adbl mt%isize = isize mt%nrealloc = mt%nrealloc + 1 mt%master = .true. nvalues_adbl = nvalues_adbl + isize - isizeold - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! ! -- return return end subroutine reallocate_dbl2d - + !> @brief Set pointer to a logical scalar !< subroutine setptr_logical(sclr, name, mem_path) - logical(LGP), pointer, intent(inout) :: sclr !< pointer to logical scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), pointer, intent(inout) :: sclr !< pointer to logical scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) sclr => mt%logicalsclr ! ! -- return return end subroutine setptr_logical - + !> @brief Set pointer to integer scalar !< subroutine setptr_int(sclr, name, mem_path) - integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) sclr => mt%intsclr ! ! -- return return end subroutine setptr_int - + !> @brief Set pointer to 1d integer array !< subroutine setptr_int1d(aint, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => mt%aint1d ! ! -- return return end subroutine setptr_int1d - + !> @brief Set pointer to 2d integer array !< subroutine setptr_int2d(aint, name, mem_path) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => mt%aint2d ! ! -- return return end subroutine setptr_int2d - + !> @brief Set pointer to 3d integer array !< subroutine setptr_int3d(aint, name, mem_path) integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< pointer to 3d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => mt%aint3d ! ! -- return return end subroutine setptr_int3d - + !> @brief Set pointer to a real scalar !< subroutine setptr_dbl(sclr, name, mem_path) - real(DP), pointer, intent(inout) :: sclr !< pointer to a real scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), pointer, intent(inout) :: sclr !< pointer to a real scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) sclr => mt%dblsclr ! ! -- return return end subroutine setptr_dbl - + !> @brief Set pointer to a 1d real array !< subroutine setptr_dbl1d(adbl, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => mt%adbl1d ! ! -- return return end subroutine setptr_dbl1d - + !> @brief Set pointer to a 2d real array !< subroutine setptr_dbl2d(adbl, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => mt%adbl2d ! ! -- return return end subroutine setptr_dbl2d - - !> @brief Set pointer to a 3d real array + + !> @brief Set pointer to a 3d real array !< subroutine setptr_dbl3d(adbl, name, mem_path) real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 3d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => mt%adbl3d ! ! -- return @@ -1346,25 +1349,25 @@ end subroutine setptr_dbl3d !> @brief Make a copy of a 1-dimensional integer array !< subroutine copyptr_int1d(aint, name, mem_path, mem_path_copy) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< returned copy of 1d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< returned copy of 1d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found integer(I4B) :: n ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => null() ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_int1d(aint, size(mt%aint1d), mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(aint(size(mt%aint1d))) + allocate (aint(size(mt%aint1d))) end if do n = 1, size(mt%aint1d) aint(n) = mt%aint1d(n) @@ -1377,12 +1380,12 @@ end subroutine copyptr_int1d !> @brief Make a copy of a 2-dimensional integer array !< subroutine copyptr_int2d(aint, name, mem_path, mem_path_copy) - integer(I4B), dimension(:,:), pointer, contiguous, intent(inout) :: aint !< returned copy of 2d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< returned copy of 2d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1391,20 +1394,20 @@ subroutine copyptr_int2d(aint, name, mem_path, mem_path_copy) integer(I4B) :: ncol integer(I4B) :: nrow ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) aint => null() ncol = size(mt%aint2d, dim=1) nrow = size(mt%aint2d, dim=2) ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_int2d(aint, ncol, nrow, mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(aint(ncol,nrow)) + allocate (aint(ncol, nrow)) end if do i = 1, nrow do j = 1, ncol - aint(j,i) = mt%aint2d(j,i) + aint(j, i) = mt%aint2d(j, i) end do end do ! @@ -1415,25 +1418,25 @@ end subroutine copyptr_int2d !> @brief Make a copy of a 1-dimensional real array !< subroutine copyptr_dbl1d(adbl, name, mem_path, mem_path_copy) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 1d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 1d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found integer(I4B) :: n ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => null() ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_dbl1d(adbl, size(mt%adbl1d), mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(adbl(size(mt%adbl1d))) + allocate (adbl(size(mt%adbl1d))) end if do n = 1, size(mt%adbl1d) adbl(n) = mt%adbl1d(n) @@ -1446,12 +1449,12 @@ end subroutine copyptr_dbl1d !> @brief Make a copy of a 2-dimensional real array !< subroutine copyptr_dbl2d(adbl, name, mem_path, mem_path_copy) - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 2d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, - !! if passed then the copy is added to the - !! memory manager + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< returned copy of 2d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy wil be stored, + !! if passed then the copy is added to the + !! memory manager ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1460,33 +1463,33 @@ subroutine copyptr_dbl2d(adbl, name, mem_path, mem_path_copy) integer(I4B) :: ncol integer(I4B) :: nrow ! -- code - call get_from_memorylist(name, mem_path, mt, found) + call get_from_memorylist(name, mem_path, mt, found) adbl => null() ncol = size(mt%adbl2d, dim=1) nrow = size(mt%adbl2d, dim=2) ! -- check the copy into the memory manager if (present(mem_path_copy)) then call allocate_dbl2d(adbl, ncol, nrow, mt%name, mem_path_copy) - ! -- create a local copy + ! -- create a local copy else - allocate(adbl(ncol,nrow)) + allocate (adbl(ncol, nrow)) end if do i = 1, nrow do j = 1, ncol - adbl(j,i) = mt%adbl2d(j,i) + adbl(j, i) = mt%adbl2d(j, i) end do end do ! ! -- return return end subroutine copyptr_dbl2d - + !> @brief Copy values from a 1-dimensional real array in the memory !< manager to a passed 1-dimensional real array subroutine copy_dbl1d(adbl, name, mem_path) real(DP), dimension(:), intent(inout) :: adbl !< target array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1500,15 +1503,15 @@ subroutine copy_dbl1d(adbl, name, mem_path) ! -- return return end subroutine copy_dbl1d - - !> @brief Set the pointer for an integer scalar to + + !> @brief Set the pointer for an integer scalar to !< a target array already stored in the memory manager subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target) - integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1518,12 +1521,12 @@ subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (associated(sclr)) then nvalues_aint = nvalues_aint - 1 - deallocate(sclr) + deallocate (sclr) end if sclr => mt2%intsclr mt%intsclr => sclr - mt%isize = 1 - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize + mt%isize = 1 + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize ! ! -- set master information mt%master = .false. @@ -1534,14 +1537,14 @@ subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_int - !> @brief Set the pointer for a 1-dimensional integer array to + !> @brief Set the pointer for a 1-dimensional integer array to !< a target array already stored in the memory manager subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1551,12 +1554,12 @@ subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(aint) > 0) then nvalues_aint = nvalues_aint - size(aint) - deallocate(aint) + deallocate (aint) end if aint => mt2%aint1d mt%aint1d => aint - mt%isize = size(aint) - write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize + mt%isize = size(aint) + write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize ! ! -- set master information mt%master = .false. @@ -1567,14 +1570,14 @@ subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_int1d - !> @brief Set the pointer for a 2-dimensional integer array to + !> @brief Set the pointer for a 2-dimensional integer array to !< a target array already stored in the memory manager subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target) - integer(I4B), dimension(:,:), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1586,14 +1589,14 @@ subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(aint) > 0) then nvalues_aint = nvalues_aint - size(aint) - deallocate(aint) + deallocate (aint) end if aint => mt2%aint2d mt%aint2d => aint mt%isize = size(aint) ncol = size(aint, dim=1) nrow = size(aint, dim=2) - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow ! ! -- set master information mt%master = .false. @@ -1604,14 +1607,14 @@ subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_int2d - !> @brief Set the pointer for a 1-dimensional real array to + !> @brief Set the pointer for a 1-dimensional real array to !< a target array already stored in the memory manager subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1621,12 +1624,12 @@ subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(adbl) > 0) then nvalues_adbl = nvalues_adbl - size(adbl) - deallocate(adbl) + deallocate (adbl) end if adbl => mt2%adbl1d mt%adbl1d => adbl - mt%isize = size(adbl) - write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize + mt%isize = size(adbl) + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize ! ! -- set master information mt%master = .false. @@ -1637,14 +1640,14 @@ subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target) return end subroutine reassignptr_dbl1d - !> @brief Set the pointer for a 2-dimensional real array to + !> @brief Set the pointer for a 2-dimensional real array to !< a target array already stored in the memory manager subroutine reassignptr_dbl2d(adbl, name, mem_path, name_target, mem_path_target) - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - character(len=*), intent(in) :: name_target !< name of target variable - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), intent(in) :: name_target !< name of target variable + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! -- local type(MemoryType), pointer :: mt type(MemoryType), pointer :: mt2 @@ -1656,14 +1659,14 @@ subroutine reassignptr_dbl2d(adbl, name, mem_path, name_target, mem_path_target) call get_from_memorylist(name_target, mem_path_target, mt2, found) if (size(adbl) > 0) then nvalues_adbl = nvalues_adbl - size(adbl) - deallocate(adbl) + deallocate (adbl) end if adbl => mt2%adbl2d mt%adbl2d => adbl mt%isize = size(adbl) ncol = size(adbl, dim=1) nrow = size(adbl, dim=2) - write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow ! ! -- set master information mt%master = .false. @@ -1677,47 +1680,78 @@ end subroutine reassignptr_dbl2d !> @brief Deallocate a variable-length character string !< subroutine deallocate_str(sclr, name, mem_path) - character(len=*), pointer, intent(inout) :: sclr !< pointer to string - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + character(len=*), pointer, intent(inout) :: sclr !< pointer to string + character(len=*), intent(in), optional :: name !< variable name + character(len=*), intent(in), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found + integer(I4B) :: ipos ! -- code - if (associated(sclr)) then - call get_from_memorylist(name, mem_path, mt, found, check=.FALSE.) - if (.not. found) then - call store_error('Programming error in deallocate_str.', terminate=.TRUE.) + if (present(name) .and. present(mem_path)) then + call get_from_memorylist(name, mem_path, mt, found) + nullify (mt%strsclr) + else + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if (associated(mt%strsclr, sclr)) then + nullify (mt%strsclr) + found = .true. + exit + end if + end do + end if + if (.not. found) then + call store_error('Programming error in deallocate_str.', terminate=.TRUE.) + else + if (mt%master) then + deallocate (sclr) else - deallocate(sclr) + nullify (sclr) end if end if ! ! -- return return end subroutine deallocate_str - + !> @brief Deallocate an array of variable-length character strings !! !! @todo confirm this description versus the previous doc !< - subroutine deallocate_str1d(astr, name, mem_path) - character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr !< array of strings - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored + subroutine deallocate_str1d(astr1d, name, mem_path) + character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d !< array of strings + character(len=*), optional, intent(in) :: name !< variable name + character(len=*), optional, intent(in) :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found + integer(I4B) :: ipos ! -- code - if (associated(astr)) then - call get_from_memorylist(name, mem_path, mt, found, check=.FALSE.) - if (.not. found) then - errmsg = "Programming error in deallocate_str1d. Variable '" // & - trim(name) // "' in '" // trim(mem_path) // "' is not " // & - "present in the memory manager but is associated." - call store_error(errmsg, terminate=.TRUE.) + ! + ! -- process optional variables + if (present(name) .and. present(mem_path)) then + call get_from_memorylist(name, mem_path, mt, found) + nullify (mt%astr1d) + else + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + if (associated(mt%astr1d, astr1d)) then + nullify (mt%astr1d) + found = .true. + exit + end if + end do + end if + if (.not. found .and. size(astr1d) > 0) then + call store_error('programming error in deallocate_str1d', terminate=.TRUE.) + else + if (mt%master) then + deallocate (astr1d) else - deallocate(astr) + nullify (astr1d) end if end if ! @@ -1728,7 +1762,7 @@ end subroutine deallocate_str1d !> @brief Deallocate a logical scalar !< subroutine deallocate_logical(sclr) - logical(LGP), pointer, intent(inout) :: sclr !< logical scalar to deallocate + logical(LGP), pointer, intent(inout) :: sclr !< logical scalar to deallocate ! -- local class(MemoryType), pointer :: mt logical(LGP) :: found @@ -1737,30 +1771,31 @@ subroutine deallocate_logical(sclr) found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%logicalsclr, sclr)) then - nullify(mt%logicalsclr) + if (associated(mt%logicalsclr, sclr)) then + nullify (mt%logicalsclr) found = .true. exit end if end do if (.not. found) then - call store_error('programming error in deallocate_logical', terminate=.TRUE.) + call store_error('programming error in deallocate_logical', & + terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else - nullify(sclr) + nullify (sclr) end if end if ! ! -- return return end subroutine deallocate_logical - + !> @brief Deallocate a integer scalar !< subroutine deallocate_int(sclr) - integer(I4B), pointer, intent(inout) :: sclr !< integer variable to deallocate + integer(I4B), pointer, intent(inout) :: sclr !< integer variable to deallocate ! -- local class(MemoryType), pointer :: mt logical(LGP) :: found @@ -1769,8 +1804,8 @@ subroutine deallocate_int(sclr) found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%intsclr, sclr)) then - nullify(mt%intsclr) + if (associated(mt%intsclr, sclr)) then + nullify (mt%intsclr) found = .true. exit end if @@ -1779,20 +1814,20 @@ subroutine deallocate_int(sclr) call store_error('Programming error in deallocate_int.', terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else - nullify(sclr) + nullify (sclr) end if end if ! ! -- return return end subroutine deallocate_int - + !> @brief Deallocate a real scalar !< subroutine deallocate_dbl(sclr) - real(DP), pointer, intent(inout) :: sclr !< real variable to deallocate + real(DP), pointer, intent(inout) :: sclr !< real variable to deallocate ! -- local class(MemoryType), pointer :: mt logical(LGP) :: found @@ -1801,8 +1836,8 @@ subroutine deallocate_dbl(sclr) found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%dblsclr, sclr)) then - nullify(mt%dblsclr) + if (associated(mt%dblsclr, sclr)) then + nullify (mt%dblsclr) found = .true. exit end if @@ -1811,7 +1846,7 @@ subroutine deallocate_dbl(sclr) call store_error('Programming error in deallocate_dbl.', terminate=.TRUE.) else if (mt%master) then - deallocate(sclr) + deallocate (sclr) else nullify (sclr) end if @@ -1820,13 +1855,13 @@ subroutine deallocate_dbl(sclr) ! -- return return end subroutine deallocate_dbl - + !> @brief Deallocate a 1-dimensional integer array !< subroutine deallocate_int1d(aint, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< 1d integer array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< 1d integer array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1836,38 +1871,38 @@ subroutine deallocate_int1d(aint, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%aint1d) + nullify (mt%aint1d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) if (associated(mt%aint1d, aint)) then - nullify(mt%aint1d) + nullify (mt%aint1d) found = .true. exit end if end do end if - if (.not. found .and. size(aint) > 0 ) then + if (.not. found .and. size(aint) > 0) then call store_error('programming error in deallocate_int1d', terminate=.TRUE.) else if (mt%master) then - deallocate(aint) + deallocate (aint) else - nullify(aint) + nullify (aint) end if end if ! ! -- return return end subroutine deallocate_int1d - + !> @brief Deallocate a 2-dimensional integer array !< subroutine deallocate_int2d(aint, name, mem_path) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< 2d integer array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1877,38 +1912,38 @@ subroutine deallocate_int2d(aint, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%aint2d) + nullify (mt%aint2d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint2d, aint)) then - nullify(mt%aint2d) + if (associated(mt%aint2d, aint)) then + nullify (mt%aint2d) found = .true. exit end if end do end if - if (.not. found .and. size(aint) > 0 ) then + if (.not. found .and. size(aint) > 0) then call store_error('programming error in deallocate_int2d', terminate=.TRUE.) else if (mt%master) then - deallocate(aint) + deallocate (aint) else - nullify(aint) + nullify (aint) end if end if ! ! -- return return end subroutine deallocate_int2d - + !> @brief Deallocate a 3-dimensional integer array !< subroutine deallocate_int3d(aint, name, mem_path) - integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< 3d integer array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< 3d integer array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1918,38 +1953,38 @@ subroutine deallocate_int3d(aint, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%aint3d) + nullify (mt%aint3d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%aint3d, aint)) then - nullify(mt%aint3d) + if (associated(mt%aint3d, aint)) then + nullify (mt%aint3d) found = .true. exit end if end do end if - if (.not. found .and. size(aint) > 0 ) then + if (.not. found .and. size(aint) > 0) then call store_error('programming error in deallocate_int3d', terminate=.TRUE.) else if (mt%master) then - deallocate(aint) + deallocate (aint) else - nullify(aint) + nullify (aint) end if end if ! ! -- return return end subroutine deallocate_int3d - + !> @brief Deallocate a 1-dimensional real array !< subroutine deallocate_dbl1d(adbl, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< 1d real array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< 1d real array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -1959,38 +1994,38 @@ subroutine deallocate_dbl1d(adbl, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%adbl1d) + nullify (mt%adbl1d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl1d, adbl)) then - nullify(mt%adbl1d) + if (associated(mt%adbl1d, adbl)) then + nullify (mt%adbl1d) found = .true. exit end if end do end if - if (.not. found .and. size(adbl) > 0 ) then + if (.not. found .and. size(adbl) > 0) then call store_error('programming error in deallocate_dbl1d', terminate=.TRUE.) else if (mt%master) then - deallocate(adbl) + deallocate (adbl) else - nullify(adbl) + nullify (adbl) end if end if ! ! -- return return end subroutine deallocate_dbl1d - + !> @brief Deallocate a 2-dimensional real array !< subroutine deallocate_dbl2d(adbl, name, mem_path) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< 2d real array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -2000,38 +2035,38 @@ subroutine deallocate_dbl2d(adbl, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%adbl2d) + nullify (mt%adbl2d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl2d, adbl)) then - nullify(mt%adbl2d) + if (associated(mt%adbl2d, adbl)) then + nullify (mt%adbl2d) found = .true. exit end if end do end if - if (.not. found .and. size(adbl) > 0 ) then + if (.not. found .and. size(adbl) > 0) then call store_error('programming error in deallocate_dbl2d', terminate=.TRUE.) else if (mt%master) then - deallocate(adbl) + deallocate (adbl) else - nullify(adbl) + nullify (adbl) end if end if ! ! -- return return end subroutine deallocate_dbl2d - + !> @brief Deallocate a 3-dimensional real array !< subroutine deallocate_dbl3d(adbl, name, mem_path) - real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< 3d real array to deallocate - character(len=*), optional :: name !< variable name - character(len=*), optional :: mem_path !< path where variable is stored + real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< 3d real array to deallocate + character(len=*), optional :: name !< variable name + character(len=*), optional :: mem_path !< path where variable is stored ! -- local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -2041,25 +2076,25 @@ subroutine deallocate_dbl3d(adbl, name, mem_path) ! -- process optional variables if (present(name) .and. present(mem_path)) then call get_from_memorylist(name, mem_path, mt, found) - nullify(mt%adbl3d) + nullify (mt%adbl3d) else found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - if(associated(mt%adbl3d, adbl)) then - nullify(mt%adbl3d) + if (associated(mt%adbl3d, adbl)) then + nullify (mt%adbl3d) found = .true. exit end if end do end if - if (.not. found .and. size(adbl) > 0 ) then + if (.not. found .and. size(adbl) > 0) then call store_error('programming error in deallocate_dbl3d', terminate=.TRUE.) else if (mt%master) then - deallocate(adbl) + deallocate (adbl) else - nullify(adbl) + nullify (adbl) end if end if ! @@ -2070,37 +2105,37 @@ end subroutine deallocate_dbl3d !> @brief Set the memory print option !< subroutine mem_set_print_option(iout, keyword, error_msg) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - character(len=*), intent(in) :: keyword !< memory print option - character(len=*), intent(inout) :: error_msg !< returned error message if keyword is not valid option + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + character(len=*), intent(in) :: keyword !< memory print option + character(len=*), intent(inout) :: error_msg !< returned error message if keyword is not valid option ! -- local ! -- format ! -- code select case (keyword) - case ('NONE') - iprmem = 0 - write(iout, '(4x, a)') & - 'LIMITED MEMORY INFORMATION WILL BE WRITTEN.' - case ('SUMMARY') - iprmem = 1 - write(iout, '(4x, a)') & - 'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' - case ('ALL') - iprmem = 2 - write(iout, '(4x, a)') & - 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' - case default - error_msg = "Unknown memory print option '" // trim(keyword) // "." + case ('NONE') + iprmem = 0 + write (iout, '(4x, a)') & + 'LIMITED MEMORY INFORMATION WILL BE WRITTEN.' + case ('SUMMARY') + iprmem = 1 + write (iout, '(4x, a)') & + 'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' + case ('ALL') + iprmem = 2 + write (iout, '(4x, a)') & + 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' + case default + error_msg = "Unknown memory print option '"//trim(keyword)//"." end select return end subroutine mem_set_print_option - + !> @brief Create a table if memory_print_option is 'SUMMARY' !< subroutine mem_summary_table(iout, nrows, cunits) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - integer(I4B), intent(in) :: nrows !< number of table rows - character(len=*), intent(in) :: cunits !< memory units (bytes, kilobytes, megabytes, or gigabytes) + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + integer(I4B), intent(in) :: nrows !< number of table rows + character(len=*), intent(in) :: cunits !< memory units (bytes, kilobytes, megabytes, or gigabytes) ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -2110,8 +2145,8 @@ subroutine mem_summary_table(iout, nrows, cunits) nterms = 6 ! ! -- set up table title - title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER, ' // & - 'IN ' // trim(cunits) + title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER, '// & + 'IN '//trim(cunits) ! ! -- set up stage tableobj call table_cr(memtab, 'MEM SUM', title) @@ -2143,13 +2178,13 @@ subroutine mem_summary_table(iout, nrows, cunits) ! ! -- return return - end subroutine mem_summary_table - - !> @brief Create a table if memory_print_option is 'ALL' + end subroutine mem_summary_table + + !> @brief Create a table if memory_print_option is 'ALL' !< subroutine mem_detailed_table(iout, nrows) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - integer(I4B), intent(in) :: nrows !< number of table rows + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + integer(I4B), intent(in) :: nrows !< number of table rows ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -2187,17 +2222,17 @@ subroutine mem_detailed_table(iout, nrows) ! ! -- return return - end subroutine mem_detailed_table - + end subroutine mem_detailed_table + !> @brief Write a row for the memory_print_option 'SUMMARY' table !< subroutine mem_summary_line(component, rchars, rlog, rint, rreal, bytes) character(len=*), intent(in) :: component !< character defining the program component (e.g. solution) - real(DP), intent(in) :: rchars !< allocated size of characters (in common units) - real(DP), intent(in) :: rlog !< allocated size of logical (in common units) - real(DP), intent(in) :: rint !< allocated size of integer variables (in common units) - real(DP), intent(in) :: rreal !< allocated size of real variables (in common units) - real(DP), intent(in) :: bytes !< total allocated memory in memory manager (in common units) + real(DP), intent(in) :: rchars !< allocated size of characters (in common units) + real(DP), intent(in) :: rlog !< allocated size of logical (in common units) + real(DP), intent(in) :: rint !< allocated size of integer variables (in common units) + real(DP), intent(in) :: rreal !< allocated size of real variables (in common units) + real(DP), intent(in) :: bytes !< total allocated memory in memory manager (in common units) ! -- formats ! -- code ! @@ -2211,14 +2246,14 @@ subroutine mem_summary_line(component, rchars, rlog, rint, rreal, bytes) ! ! -- return return - end subroutine mem_summary_line + end subroutine mem_summary_line !> @brief Determine appropriate memory unit and conversion factor !< subroutine mem_units(bytes, fact, cunits) ! -- dummy - real(DP), intent(in) :: bytes !< total nr. of bytes - real(DP), intent(inout) :: fact !< conversion factor + real(DP), intent(in) :: bytes !< total nr. of bytes + real(DP), intent(inout) :: fact !< conversion factor character(len=*), intent(inout) :: cunits !< string with memory unit ! -- local ! -- formats @@ -2238,20 +2273,20 @@ subroutine mem_units(bytes, fact, cunits) else if (bytes < DEP9) then fact = DEM6 cunits = 'MEGABYTES' - else + else fact = DEM9 cunits = 'GIGABYTES' end if ! ! -- return return - end subroutine mem_units - - !> @brief Create and fill a table with the total allocated memory + end subroutine mem_units + + !> @brief Create and fill a table with the total allocated memory !< in the memory manager subroutine mem_summary_total(iout, bytes) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst - real(DP), intent(in) :: bytes !< total number of bytes allocated in the memory manager + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + real(DP), intent(in) :: bytes !< total number of bytes allocated in the memory manager ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -2271,7 +2306,7 @@ subroutine mem_summary_total(iout, bytes) nrows = 5 ! ! -- set up table title - title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE, IN ' // trim(cunits) + title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE, IN '//trim(cunits) ! ! -- set up stage tableobj call table_cr(memtab, 'MEM TOT', title) @@ -2318,8 +2353,8 @@ subroutine mem_summary_total(iout, bytes) ! ! -- return return - end subroutine mem_summary_total - + end subroutine mem_summary_total + !> @brief Generic function to clean a memory manager table !< subroutine mem_cleanup_table() @@ -2327,21 +2362,21 @@ subroutine mem_cleanup_table() ! -- formats ! -- code call memtab%table_da() - deallocate(memtab) - nullify(memtab) + deallocate (memtab) + nullify (memtab) ! ! -- return return - end subroutine mem_cleanup_table - - !> @brief Write memory manager memory usage based on the + end subroutine mem_cleanup_table + + !> @brief Write memory manager memory usage based on the !! user-specified memory_print_option !! !! The total memory usage by data types (int, real, etc.) !! is written for every simulation. !< subroutine mem_write_usage(iout) - integer(I4B), intent(in) :: iout !< unit number for mfsim.lst + integer(I4B), intent(in) :: iout !< unit number for mfsim.lst ! -- local class(MemoryType), pointer :: mt character(len=LENMEMPATH), allocatable, dimension(:) :: cunique @@ -2364,9 +2399,9 @@ subroutine mem_write_usage(iout) ! -- code ! ! -- Calculate simulation memory allocation - simbytes = (nvalues_astr + & - nvalues_alogical * LGP + & - nvalues_aint * I4B + & + simbytes = (nvalues_astr + & + nvalues_alogical * LGP + & + nvalues_aint * I4B + & nvalues_adbl * DP) simbytes = real(simbytes, DP) ! @@ -2432,7 +2467,7 @@ subroutine mem_write_usage(iout) ! -- return return end subroutine mem_write_usage - + !> @brief Deallocate memory in the memory manager !< subroutine mem_da() @@ -2451,8 +2486,8 @@ subroutine mem_da() ! ! -- check if memory has been deallocated if (mt%mt_associated() .and. mt%isize > 0) then - error_msg = trim(adjustl(mt%path)) // ' ' // & - trim(adjustl(mt%name)) // ' not deallocated' + error_msg = trim(adjustl(mt%path))//' '// & + trim(adjustl(mt%name))//' not deallocated' call store_error(trim(error_msg)) end if ! @@ -2460,15 +2495,15 @@ subroutine mem_da() ucname = mt%name call UPCASE(ucname) if (mt%name /= ucname) then - error_msg = trim(adjustl(mt%path)) // ' ' // & - trim(adjustl(mt%name)) // ' not upper case' + error_msg = trim(adjustl(mt%path))//' '// & + trim(adjustl(mt%name))//' not upper case' call store_error(trim(error_msg)) end if end if ! ! -- deallocate instance of memory type - deallocate(mt) - enddo + deallocate (mt) + end do call memorylist%clear() if (count_errors() > 0) then call store_error('Could not clear memory list.', terminate=.TRUE.) @@ -2477,7 +2512,7 @@ subroutine mem_da() ! -- return return end subroutine mem_da - + !> @brief Create a array with unique first components from all memory paths. !! Only the first component of the memory path is evaluated. !< @@ -2485,7 +2520,7 @@ subroutine mem_unique_origins(cunique) ! -- modules use ArrayHandlersModule, only: ExpandArray, ifind ! -- dummy - character(len=LENMEMPATH), allocatable, dimension(:), intent(inout) :: cunique !< array with unique first components + character(len=LENMEMPATH), allocatable, dimension(:), intent(inout) :: cunique !< array with unique first components ! -- local class(MemoryType), pointer :: mt character(len=LENCOMPONENTNAME) :: component @@ -2495,14 +2530,14 @@ subroutine mem_unique_origins(cunique) ! -- code ! ! -- initialize cunique - allocate(cunique(0)) + allocate (cunique(0)) ! ! -- find unique origins do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) call split_mem_path(mt%path, component, subcomponent) ipa = ifind(cunique, component) - if(ipa < 1) then + if (ipa < 1) then call ExpandArray(cunique, 1) cunique(size(cunique)) = component end if @@ -2511,5 +2546,5 @@ subroutine mem_unique_origins(cunique) ! -- return return end subroutine mem_unique_origins - + end module MemoryManagerModule diff --git a/src/Utilities/Memory/MemorySetHandler.f90 b/src/Utilities/Memory/MemorySetHandler.f90 index c1756ec79c8..a9af706373b 100644 --- a/src/Utilities/Memory/MemorySetHandler.f90 +++ b/src/Utilities/Memory/MemorySetHandler.f90 @@ -1,6 +1,6 @@ -module MemorySetHandlerModule - use KindModule, only: I4B, LGP - use ListModule, only: ListType +module MemorySetHandlerModule + use KindModule, only: I4B, LGP + use ListModule, only: ListType use MemoryTypeModule, only: MemoryType use MemoryManagerModule, only: get_from_memorylist use ConstantsModule, only: LENMEMPATH, LENVARNAME @@ -27,20 +27,20 @@ subroutine set_handler_iface(owner, status) end subroutine end interface - contains +contains !> @brief Register the event handler and context for this variable !! !! The event handler and its ctx are called whenever the trigger - !! is given by calling @p on_set_memory(). This allows to handle - !! side effects, e.g. when a variable is from outside a class + !! is given by calling @p on_set_memory(). This allows to handle + !! side effects, e.g. when a variable is from outside a class !! (the context) such as happens with the BMI. !< subroutine mem_register_handler(var_name, mem_path, handler, ctx) - character(len=*), intent(in) :: var_name !< the variable name - character(len=*), intent(in) :: mem_path !< the memory path - procedure(set_handler_iface), pointer :: handler !< called after memory is set - class(*), pointer :: ctx !< the context with which the handler should be called + character(len=*), intent(in) :: var_name !< the variable name + character(len=*), intent(in) :: mem_path !< the memory path + procedure(set_handler_iface), pointer :: handler !< called after memory is set + class(*), pointer :: ctx !< the context with which the handler should be called ! local integer(I4B) :: handler_idx class(EventHandlerDataType), pointer :: handler_data => null() @@ -49,7 +49,7 @@ subroutine mem_register_handler(var_name, mem_path, handler, ctx) logical(LGP) :: found ! first store the handler data - allocate(handler_data) + allocate (handler_data) handler_data%handler => handler handler_data%handlerContext => ctx @@ -74,9 +74,9 @@ subroutine mem_register_handler(var_name, mem_path, handler, ctx) !! because the data in memory is no longer consistent... !< subroutine on_memory_set(var_name, mem_path, status) - character(len=*), intent(in) :: var_name !< the variable name - character(len=*), intent(in) :: mem_path !< the memory path - integer(I4B), intent(out) :: status !< status: 0 for success, -1 when failed + character(len=*), intent(in) :: var_name !< the variable name + character(len=*), intent(in) :: mem_path !< the memory path + integer(I4B), intent(out) :: status !< status: 0 for success, -1 when failed ! local type(MemoryType), pointer :: mt logical(LGP) :: found @@ -92,15 +92,15 @@ subroutine on_memory_set(var_name, mem_path, status) status = 0 return end if - + handler_data_genptr => handler_list%GetItem(mt%set_handler_idx) - select type(handler_data_genptr) + select type (handler_data_genptr) class is (EventHandlerDataType) evt_handler_data => handler_data_genptr end select - + ! call the function call evt_handler_data%handler(evt_handler_data%handlerContext, status) end subroutine -end module \ No newline at end of file +end module diff --git a/src/Utilities/Message.f90 b/src/Utilities/Message.f90 index 8298b3b6fdf..c4f40740dcb 100644 --- a/src/Utilities/Message.f90 +++ b/src/Utilities/Message.f90 @@ -1,36 +1,36 @@ !> @brief This module contains message methods !! -!! This module contains generic message methods that are used to +!! This module contains generic message methods that are used to !! create warning and error messages and notes. This module also has methods -!! for counting messages. The module does not have any dependencies on +!! for counting messages. The module does not have any dependencies on !! models, exchanges, or solutions in a simulation. !! !< module MessageModule - + use KindModule, only: LGP, I4B, DP - use ConstantsModule, only: LINELENGTH, MAXCHARLEN, DONE, & + use ConstantsModule, only: LINELENGTH, MAXCHARLEN, DONE, & VSUMMARY - use GenericUtilitiesModule, only: sim_message, write_message - use SimVariablesModule, only: istdout - use ArrayHandlersModule, only: ExpandArray - + use GenericUtilitiesModule, only: sim_message, write_message + use SimVariablesModule, only: istdout + use ArrayHandlersModule, only: ExpandArray + implicit none - + public :: MessageType - + type :: MessageType - character(len=LINELENGTH) :: title !< title of the message - character(len=LINELENGTH) :: name !< message name - integer(I4B) :: nmessage = 0 !< number of messages stored - integer(I4B) :: max_message = 1000 !< default maximum number of messages that can be stored - integer(I4B) :: max_exceeded = 0 !< flag indicating if the maximum number of messages has exceed the maximum number - integer(I4B) :: inc_message = 100 !< amount to increment message array by when calling ExpandArray - character(len=MAXCHARLEN), allocatable, dimension(:) :: message !< message array - - contains - + character(len=LINELENGTH) :: title !< title of the message + character(len=LINELENGTH) :: name !< message name + integer(I4B) :: nmessage = 0 !< number of messages stored + integer(I4B) :: max_message = 1000 !< default maximum number of messages that can be stored + integer(I4B) :: max_exceeded = 0 !< flag indicating if the maximum number of messages has exceed the maximum number + integer(I4B) :: inc_message = 100 !< amount to increment message array by when calling ExpandArray + character(len=MAXCHARLEN), allocatable, dimension(:) :: message !< message array + + contains + procedure :: init_message procedure :: count_message procedure :: set_max_message @@ -39,225 +39,224 @@ module MessageModule procedure :: deallocate_message end type MessageType - - contains - !> @brief Always initialize the message object +contains + + !> @brief Always initialize the message object !! - !! Subroutine that initializes the message object. Allocation of message + !! Subroutine that initializes the message object. Allocation of message !! array occurs on-the-fly. !! - !< - subroutine init_message(this) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - ! - ! -- initialize message variables - this%nmessage = 0 - this%max_message = 1000 - this%max_exceeded = 0 - this%inc_message = 100 - ! - ! -- return - return - end subroutine init_message - - !> @brief Return number of messages + !< + subroutine init_message(this) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + ! + ! -- initialize message variables + this%nmessage = 0 + this%max_message = 1000 + this%max_exceeded = 0 + this%inc_message = 100 + ! + ! -- return + return + end subroutine init_message + + !> @brief Return number of messages !! !! Function to return the number of messages that have been stored. !! !! @return ncount number of messages stored !! - !< - function count_message(this) result(nmessage) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - ! -- return variable - integer(I4B) :: nmessage - ! - ! -- set nmessage - if (allocated(this%message)) then - nmessage = this%nmessage - else - nmessage = 0 - end if - ! - ! -- return - return - end function count_message - - !> @brief Set the maximum number of messages stored + !< + function count_message(this) result(nmessage) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + ! -- return variable + integer(I4B) :: nmessage + ! + ! -- set nmessage + if (allocated(this%message)) then + nmessage = this%nmessage + else + nmessage = 0 + end if + ! + ! -- return + return + end function count_message + + !> @brief Set the maximum number of messages stored !! !! Subroutine to set the maximum number of messages that will be stored !! in a simulation. !! - !< - subroutine set_max_message(this, imax) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - integer(I4B), intent(in) :: imax !< maximum number of messages that will be stored - ! - ! -- set max_message - this%max_message = imax - ! - ! -- return - return - end subroutine set_max_message - - !> @brief Store message + !< + subroutine set_max_message(this, imax) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + integer(I4B), intent(in) :: imax !< maximum number of messages that will be stored + ! + ! -- set max_message + this%max_message = imax + ! + ! -- return + return + end subroutine set_max_message + + !> @brief Store message !! !! Subroutine to store a message for printing at the end of !! the simulation. !! - !< - subroutine store_message(this, msg, substring) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - character(len=*), intent(in) :: msg !< message - character(len=*), intent(in), optional :: substring !< optional string that can be used - !! to prevent storing duplicate messages - ! -- local variables - logical(LGP) :: inc_array - logical(LGP) :: increment_message - integer(I4B) :: i - integer(I4B) :: idx - ! - ! -- determine if messages should be expanded - inc_array = .TRUE. - if (allocated(this%message)) then - i = this%nmessage - if (i < size(this%message)) then - inc_array = .FALSE. - end if - end if - ! - ! -- resize message - if (inc_array) then - call ExpandArray(this%message, increment=this%inc_message) - this%inc_message = int(this%inc_message * 1.1) - end if - ! - ! -- Determine if the substring exists in the passed message. - ! If substring is in passed message, do not add the duplicate - ! passed message. - increment_message = .TRUE. - if (present(substring)) then - do i = 1, this%nmessage - idx = index(this%message(i), substring) - if (idx > 0) then - increment_message = .FALSE. - exit - end if - end do + !< + subroutine store_message(this, msg, substring) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + character(len=*), intent(in) :: msg !< message + character(len=*), intent(in), optional :: substring !< optional string that can be used + !! to prevent storing duplicate messages + ! -- local variables + logical(LGP) :: inc_array + logical(LGP) :: increment_message + integer(I4B) :: i + integer(I4B) :: idx + ! + ! -- determine if messages should be expanded + inc_array = .TRUE. + if (allocated(this%message)) then + i = this%nmessage + if (i < size(this%message)) then + inc_array = .FALSE. end if - ! - ! -- store this message and calculate nmessage - if (increment_message) then - i = this%nmessage + 1 - if (i <= this%max_message) then - this%nmessage = i - this%message(i) = msg - else - this%max_exceeded = this%max_exceeded + 1 + end if + ! + ! -- resize message + if (inc_array) then + call ExpandArray(this%message, increment=this%inc_message) + this%inc_message = int(this%inc_message * 1.1) + end if + ! + ! -- Determine if the substring exists in the passed message. + ! If substring is in passed message, do not add the duplicate + ! passed message. + increment_message = .TRUE. + if (present(substring)) then + do i = 1, this%nmessage + idx = index(this%message(i), substring) + if (idx > 0) then + increment_message = .FALSE. + exit end if + end do + end if + ! + ! -- store this message and calculate nmessage + if (increment_message) then + i = this%nmessage + 1 + if (i <= this%max_message) then + this%nmessage = i + this%message(i) = msg + else + this%max_exceeded = this%max_exceeded + 1 end if - ! - ! -- return - return - end subroutine store_message - - !> @brief Print messages + end if + ! + ! -- return + return + end subroutine store_message + + !> @brief Print messages !! !! Subroutine to print stored messages. !! - !< - subroutine print_message(this, title, name, iunit, level) - ! -- dummy variables - class(MessageType) :: this !< MessageType object - character(len=*), intent(in) :: title !< message title - character(len=*), intent(in) :: name !< message name - integer(I4B), intent(in), optional :: iunit !< optional file unit to save messages to - integer(I4B), intent(in), optional :: level !< optional level of messages to print - ! -- local - character(len=LINELENGTH) :: errmsg - character(len=LINELENGTH) :: cerr - integer(I4B) :: iu - integer(I4B) :: ilevel - integer(I4B) :: i - integer(I4B) :: isize - integer(I4B) :: iwidth - ! -- formats - character(len=*), parameter :: stdfmt = "(/,A,/)" - ! - ! -- process optional variables - if (present(iunit)) then - iu = iunit - else - iu = 0 - end if - if (present(level)) then - ilevel = level - else - ilevel = VSUMMARY - end if - ! - ! -- write the title and all message entries - if (allocated(this%message)) then - isize = this%nmessage - if (isize > 0) then - ! - ! -- calculate the maximum width of the prepended string - ! for the counter - write(cerr, '(i0)') isize - iwidth = len_trim(cerr) + 1 - ! - ! -- write title for message + !< + subroutine print_message(this, title, name, iunit, level) + ! -- dummy variables + class(MessageType) :: this !< MessageType object + character(len=*), intent(in) :: title !< message title + character(len=*), intent(in) :: name !< message name + integer(I4B), intent(in), optional :: iunit !< optional file unit to save messages to + integer(I4B), intent(in), optional :: level !< optional level of messages to print + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: cerr + integer(I4B) :: iu + integer(I4B) :: ilevel + integer(I4B) :: i + integer(I4B) :: isize + integer(I4B) :: iwidth + ! -- formats + character(len=*), parameter :: stdfmt = "(/,A,/)" + ! + ! -- process optional variables + if (present(iunit)) then + iu = iunit + else + iu = 0 + end if + if (present(level)) then + ilevel = level + else + ilevel = VSUMMARY + end if + ! + ! -- write the title and all message entries + if (allocated(this%message)) then + isize = this%nmessage + if (isize > 0) then + ! + ! -- calculate the maximum width of the prepended string + ! for the counter + write (cerr, '(i0)') isize + iwidth = len_trim(cerr) + 1 + ! + ! -- write title for message + if (iu > 0) then + call sim_message(title, iunit=iu, fmt=stdfmt, level=ilevel) + end if + call sim_message(title, fmt=stdfmt, level=ilevel) + ! + ! -- write each message + do i = 1, isize + call write_message(this%message(i), icount=i, iwidth=iwidth, & + level=ilevel) if (iu > 0) then - call sim_message(title, iunit=iu, fmt=stdfmt, level=ilevel) - end if - call sim_message(title, fmt=stdfmt, level=ilevel) - ! - ! -- write each message - do i = 1, isize call write_message(this%message(i), icount=i, iwidth=iwidth, & - level=ilevel) - if (iu > 0) then - call write_message(this%message(i), icount=i, iwidth=iwidth, & - iunit=iu, level=ilevel) - end if - end do - ! - ! -- write the number of additional messages - if (this%max_exceeded > 0) then - write(errmsg, '(i0,3(1x,a))') & - this%max_exceeded, 'additional', trim(name), & - 'detected but not printed.' - call sim_message(trim(errmsg), fmt='(/,1x,a)', level=ilevel) - if (iu > 0) then - call sim_message(trim(errmsg), iunit=iu, fmt='(/,1x,a)', & - level=ilevel) - end if + iunit=iu, level=ilevel) + end if + end do + ! + ! -- write the number of additional messages + if (this%max_exceeded > 0) then + write (errmsg, '(i0,3(1x,a))') & + this%max_exceeded, 'additional', trim(name), & + 'detected but not printed.' + call sim_message(trim(errmsg), fmt='(/,1x,a)', level=ilevel) + if (iu > 0) then + call sim_message(trim(errmsg), iunit=iu, fmt='(/,1x,a)', & + level=ilevel) end if end if end if - ! - ! -- return - return - end subroutine print_message + end if + ! + ! -- return + return + end subroutine print_message - !> @ brief Deallocate message !! - !! Subroutine that deallocate the array of strings if it was allocated + !! Subroutine that deallocate the array of strings if it was allocated !! !< subroutine deallocate_message(this) ! -- dummy variables - class(MessageType) :: this !< MessageType object + class(MessageType) :: this !< MessageType object ! ! -- deallocate the message if (allocated(this%message)) then - deallocate(this%message) + deallocate (this%message) end if ! ! -- return diff --git a/src/Utilities/NameFile.f90 b/src/Utilities/NameFile.f90 index 6b6131b0401..115a8550c26 100644 --- a/src/Utilities/NameFile.f90 +++ b/src/Utilities/NameFile.f90 @@ -1,11 +1,11 @@ module NameFileModule use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, openfile, getunit - use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use InputOutputModule, only: ParseLine, openfile, getunit + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use ArrayHandlersModule, only: ExpandArray, remove_character - use IunitModule, only: IunitType - use BlockParserModule, only: BlockParserType + use IunitModule, only: IunitType + use BlockParserModule, only: BlockParserType implicit none private public :: NameFileType @@ -18,17 +18,17 @@ module NameFileModule type(IunitType) :: iunit_obj type(BlockParserType) :: parser contains - procedure :: init => namefile_init - procedure :: add_cunit => namefile_add_cunit - procedure :: openlistfile => namefile_openlistfile - procedure :: openfiles => namefile_openfiles - procedure :: get_unitnumber => namefile_get_unitnumber - procedure :: get_nval_for_row => namefile_get_nval_for_row + procedure :: init => namefile_init + procedure :: add_cunit => namefile_add_cunit + procedure :: openlistfile => namefile_openlistfile + procedure :: openfiles => namefile_openfiles + procedure :: get_unitnumber => namefile_get_unitnumber + procedure :: get_nval_for_row => namefile_get_nval_for_row procedure :: get_unitnumber_rowcol => namefile_get_unitnumber_rowcol - procedure :: get_pakname => namefile_get_pakname + procedure :: get_pakname => namefile_get_pakname end type NameFileType - contains +contains subroutine namefile_init(this, filename, iout) ! ****************************************************************************** @@ -49,9 +49,9 @@ subroutine namefile_init(this, filename, iout) integer(I4B) :: i, ierr, inunit, n logical :: isFound, endOfBlock ! -- formats - character(len=*), parameter :: fmtfname = & - "(1x, 'NON-COMMENTED ENTRIES FOUND IN ', /, & - &4X, 'BLOCK: ', a, /, & + character(len=*), parameter :: fmtfname = & + "(1x, 'NON-COMMENTED ENTRIES FOUND IN ', /, & + &4X, 'BLOCK: ', a, /, & &4X, 'FILE: ', a)" character(len=*), parameter :: fmtbeg = "(/, 1x, A)" character(len=*), parameter :: fmtline = "(2x, a)" @@ -60,8 +60,8 @@ subroutine namefile_init(this, filename, iout) ! ! -- Store filename and initialize variables this%filename = filename - allocate(this%opts(0)) - allocate(this%input_files(0)) + allocate (this%opts(0)) + allocate (this%input_files(0)) ! ! -- Open the name file and initialize the block parser inunit = getunit() @@ -70,8 +70,8 @@ subroutine namefile_init(this, filename, iout) ! ! -- Read and set the options call this%parser%GetBlock('OPTIONS', isFound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - if(isFound) then + supportOpenClose=.true., blockRequired=.false.) + if (isFound) then ! ! -- Populate this%opts n = 0 @@ -82,26 +82,26 @@ subroutine namefile_init(this, filename, iout) call ExpandArray(this%opts) n = n + 1 this%opts(n) = adjustl(line) - enddo getopts + end do getopts ! - if(iout > 0) then - write(iout, fmtfname) 'OPTIONS', trim(adjustl(filename)) - write(iout, fmtbeg) 'BEGIN OPTIONS' + if (iout > 0) then + write (iout, fmtfname) 'OPTIONS', trim(adjustl(filename)) + write (iout, fmtbeg) 'BEGIN OPTIONS' do i = 1, n - write(iout, fmtline) trim(adjustl(this%opts(i))) - enddo - write(iout, fmtend) 'END OPTIONS' - endif + write (iout, fmtline) trim(adjustl(this%opts(i))) + end do + write (iout, fmtend) 'END OPTIONS' + end if else - if(iout > 0) then - write(iout, '(/, A, /)') 'NO VALID OPTIONS BLOCK DETECTED' - endif - endif + if (iout > 0) then + write (iout, '(/, A, /)') 'NO VALID OPTIONS BLOCK DETECTED' + end if + end if ! ! -- Read and set the input_files call this%parser%GetBlock('PACKAGES', isFound, ierr, & - supportOpenClose=.true.) - if(isFound) then + supportOpenClose=.true.) + if (isFound) then ! ! -- Populate this%input_files n = 0 @@ -112,24 +112,24 @@ subroutine namefile_init(this, filename, iout) call ExpandArray(this%input_files) n = n + 1 this%input_files(n) = adjustl(line) - enddo getpaks + end do getpaks ! ! -- Write to list file - if(iout > 0) then - write(iout, fmtfname) 'PACKAGES', trim(adjustl(filename)) - write(iout, fmtbeg) 'BEGIN PACKAGES' + if (iout > 0) then + write (iout, fmtfname) 'PACKAGES', trim(adjustl(filename)) + write (iout, fmtbeg) 'BEGIN PACKAGES' do i = 1, n - write(iout, fmtline) trim(adjustl(this%input_files(i))) - enddo - write(iout, fmtend) 'END PACKAGES' - endif + write (iout, fmtline) trim(adjustl(this%input_files(i))) + end do + write (iout, fmtend) 'END PACKAGES' + end if else ! ! -- Package block not found. Terminate with error. - write(errmsg, '(a, a)') 'Error reading PACKAGES from file: ', & - trim(adjustl(filename)) + write (errmsg, '(a, a)') 'Error reading PACKAGES from file: ', & + trim(adjustl(filename)) call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- return return @@ -182,13 +182,13 @@ subroutine namefile_openlistfile(this, iout) findloop: do i = 1, size(this%opts) call ParseLine(this%opts(i), nwords, words) call upcase(words(1)) - if(words(1) == 'LIST') then + if (words(1) == 'LIST') then fname = words(2) ipos = i found = .true. exit findloop - endif - enddo findloop + end if + end do findloop ! ! -- remove list file from options list if (ipos > 0) then @@ -206,13 +206,13 @@ subroutine namefile_openlistfile(this, iout) if (this%filename(i:i) == '.') then istart = i exit - endif - enddo + end if + end do if (istart == 0) istart = istop + 1 fname = this%filename(1:istart) istop = istart + 3 fname(istart:istop) = '.lst' - endif + end if ! ! -- Open the list file iout = getunit() @@ -248,7 +248,7 @@ subroutine namefile_openfiles(this, iout) ! -- Parse the line and set defaults call ParseLine(this%input_files(i), nwords, words) call upcase(words(1)) - ftype = words(1)(1:20) + ftype = words(1) (1:20) accarg = 'SEQUENTIAL' fmtarg = 'FORMATTED' filstat = 'OLD' @@ -258,9 +258,9 @@ subroutine namefile_openfiles(this, iout) call this%iunit_obj%addfile(ftype, inunit, i, this%filename) ! ! -- Open the file - call openfile(inunit, iout, trim(adjustl(words(2))), & + call openfile(inunit, iout, trim(adjustl(words(2))), & ftype, fmtarg, accarg, filstat) - enddo + end do ! ! -- return return @@ -307,8 +307,8 @@ function namefile_get_nval_for_row(this, irow) result(nval) return end function namefile_get_nval_for_row - function namefile_get_unitnumber_rowcol(this, irow, jcol) & - result(iu) + function namefile_get_unitnumber_rowcol(this, irow, jcol) & + result(iu) ! ****************************************************************************** ! namefile_get_unitnumber_rowcol -- Get the unit number for entries in ! cunit(irow) and columns (icol). For example, return the unit number for @@ -358,23 +358,22 @@ subroutine namefile_get_pakname(this, irow, jcol, pakname) pakname = '' if (nwords > 2) then ilen = len(trim(adjustl(words(3)))) - if(ilen > LENPACKAGENAME) then - write(errmsg, "(a, i0, a)") & - 'ERROR. PACKAGENAME MUST NOT BE GREATER THAN ', & - LENPACKAGENAME, ' CHARACTERS.' + if (ilen > LENPACKAGENAME) then + write (errmsg, "(a, i0, a)") & + 'ERROR. PACKAGENAME MUST NOT BE GREATER THAN ', & + LENPACKAGENAME, ' CHARACTERS.' call store_error(errmsg) call store_error(trim(this%input_files(ipos))) - write(errmsg, '(a, a)') 'Error in PACKAGES block in file: ', & - trim(adjustl(this%filename)) + write (errmsg, '(a, a)') 'Error in PACKAGES block in file: ', & + trim(adjustl(this%filename)) call store_error(errmsg, terminate=.TRUE.) - endif + end if pakname = trim(adjustl(words(3))) call upcase(pakname) - endif + end if ! ! -- return return end subroutine namefile_get_pakname - end module NameFileModule diff --git a/src/Utilities/Observation/Obs3.f90 b/src/Utilities/Observation/Obs3.f90 index e0e883801c2..54c4cc8e4a2 100644 --- a/src/Utilities/Observation/Obs3.f90 +++ b/src/Utilities/Observation/Obs3.f90 @@ -126,34 +126,34 @@ !------------------------------------------------------------------------------- module ObsModule - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B use ArrayHandlersModule, only: ExpandArray - use BaseDisModule, only: DisBaseType - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LENBIGLINE, LENFTYPE, LENOBSNAME, & - LENOBSTYPE, LENPACKAGENAME, LENBOUNDNAME, & - LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & - MAXOBSTYPES, LENHUGELINE, DNODATA, & - TABLEFT - use TableModule, only: TableType, table_cr - use InputOutputModule, only: UPCASE, openfile, GetUnit, GetFileFromPath - use ListModule, only: ListType - use ObsContainerModule, only: ObsContainerType - use ObserveModule, only: ConstructObservation, ObsDataType, & - ObserveType, GetObsFromList, & - AddObsToList + use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LENBIGLINE, LENFTYPE, LENOBSNAME, & + LENOBSTYPE, LENPACKAGENAME, LENBOUNDNAME, & + LINELENGTH, NAMEDBOUNDFLAG, MAXCHARLEN, & + MAXOBSTYPES, LENHUGELINE, DNODATA, & + TABLEFT + use TableModule, only: TableType, table_cr + use InputOutputModule, only: UPCASE, openfile, GetUnit, GetFileFromPath + use ListModule, only: ListType + use ObsContainerModule, only: ObsContainerType + use ObserveModule, only: ConstructObservation, ObsDataType, & + ObserveType, GetObsFromList, & + AddObsToList use ObsOutputListModule, only: ObsOutputListType - use ObsOutputModule, only: ObsOutputType - use ObsUtilityModule, only: write_fmtd_cont, write_unfmtd_cont - use OpenSpecModule, only: ACCESS, FORM - use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, store_error_unit - use TdisModule, only: totim + use ObsOutputModule, only: ObsOutputType + use ObsUtilityModule, only: write_fmtd_cont, write_unfmtd_cont + use OpenSpecModule, only: ACCESS, FORM + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error, store_error_unit + use TdisModule, only: totim implicit none private - public :: ObsType, DefaultObsIdProcessor, obs_cr + public :: ObsType, DefaultObsIdProcessor, obs_cr type :: ObsType ! -- Public members @@ -161,17 +161,17 @@ module ObsModule integer(I4B), public :: npakobs = 0 integer(I4B), pointer, public :: inUnitObs => null() character(len=LINELENGTH), pointer, public :: inputFilename => null() - character(len=2*LENPACKAGENAME+4), public :: pkgName = '' + character(len=2*LENPACKAGENAME + 4), public :: pkgName = '' character(len=LENFTYPE), public :: filtyp = '' logical, pointer, public :: active => null() type(ObsContainerType), dimension(:), pointer, public :: pakobs => null() type(ObsDataType), dimension(:), pointer, public :: obsData => null() ! -- Private members - integer(I4B), private :: iprecision = 2 ! 2=double; 1=single + integer(I4B), private :: iprecision = 2 ! 2=double; 1=single integer(I4B), private :: idigits = 0 character(len=LINELENGTH), private :: outputFilename = '' character(len=LINELENGTH), private :: blockTypeFound = '' - character(len=20), private:: obsfmtcont = '' + character(len=20), private :: obsfmtcont = '' logical, private :: echo = .false. logical, private :: more type(ListType), private :: obsList @@ -183,15 +183,15 @@ module ObsModule type(TableType), pointer :: obstab => null() contains ! -- Public procedures - procedure, public :: obs_df - procedure, public :: obs_ar - procedure, public :: obs_ad - procedure, public :: obs_bd_clear - procedure, public :: obs_ot - procedure, public :: obs_da - procedure, public :: SaveOneSimval - procedure, public :: StoreObsType - procedure, public :: allocate_scalars + procedure, public :: obs_df + procedure, public :: obs_ar + procedure, public :: obs_ad + procedure, public :: obs_bd_clear + procedure, public :: obs_ot + procedure, public :: obs_da + procedure, public :: SaveOneSimval + procedure, public :: StoreObsType + procedure, public :: allocate_scalars ! -- Private procedures procedure, private :: build_headers procedure, private :: define_fmts @@ -223,11 +223,11 @@ subroutine obs_cr(obs, inobs) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ObsType), pointer, intent(out) :: obs + type(ObsType), pointer, intent(out) :: obs integer(I4B), pointer, intent(in) :: inobs ! ------------------------------------------------------------------------------ ! - allocate(obs) + allocate (obs) call obs%allocate_scalars() obs%inUnitObs => inobs ! @@ -261,7 +261,7 @@ subroutine DefaultObsIdProcessor(obsrv, dis, inunitobs, iout) ! -- Initialize variables strng = obsrv%IDstring icol = 1 - flag_string = .true. ! Allow strng to contain a boundary name + flag_string = .true. ! Allow strng to contain a boundary name ! n = dis%noder_from_string(icol, istart, istop, inunitobs, & iout, strng, flag_string) @@ -280,7 +280,7 @@ subroutine DefaultObsIdProcessor(obsrv, dis, inunitobs, iout) errmsg = 'Error reading data from ID string' call store_error(errmsg) call store_error_unit(inunitobs) - endif + end if ! return end subroutine DefaultObsIdProcessor @@ -299,7 +299,7 @@ subroutine obs_df(this, iout, pkgname, filtyp, dis) integer(I4B), intent(in) :: iout character(len=*), intent(in) :: pkgname character(len=*), intent(in) :: filtyp - class(DisBaseType), pointer :: dis + class(DisBaseType), pointer :: dis ! ------------------------------------------------------------------------------ ! this%iout = iout @@ -329,7 +329,7 @@ subroutine obs_ar(this) call this%obs_ar1(this%pkgName) if (this%active) then call this%obs_ar2(this%dis) - endif + end if ! return end subroutine obs_ar @@ -350,10 +350,10 @@ subroutine obs_ad(this) ! ------------------------------------------------------------------------------ ! n = this%get_num() - do i=1,n + do i = 1, n obsrv => this%get_obs(i) call obsrv%ResetCurrent() - enddo + end do ! return end subroutine obs_ad @@ -396,7 +396,7 @@ subroutine obs_ot(this) if (this%npakobs > 0) then call this%write_continuous_simvals() call this%obsOutputList%WriteOutputLines() - endif + end if ! return end subroutine obs_ot @@ -415,15 +415,15 @@ subroutine obs_da(this) class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! - deallocate(this%active) - deallocate(this%inputFilename) - deallocate(this%obsData) + deallocate (this%active) + deallocate (this%inputFilename) + deallocate (this%obsData) ! ! -- obs table object if (associated(this%obstab)) then call this%obstab%table_da() - deallocate(this%obstab) - nullify(this%obstab) + deallocate (this%obstab) + nullify (this%obstab) end if ! ! -- deallocate pakobs components and pakobs @@ -431,21 +431,21 @@ subroutine obs_da(this) do i = 1, this%npakobs obsrv => this%pakobs(i)%obsrv call obsrv%da() - deallocate(obsrv) - nullify(this%pakobs(i)%obsrv) + deallocate (obsrv) + nullify (this%pakobs(i)%obsrv) end do - deallocate(this%pakobs) + deallocate (this%pakobs) end if ! ! -- deallocate obsOutputList call this%obsOutputList%DeallocObsOutputList() - deallocate(this%obsOutputList) + deallocate (this%obsOutputList) ! ! -- deallocate obslist call this%obslist%Clear() ! ! -- nullify - nullify(this%inUnitObs) + nullify (this%inUnitObs) ! return end subroutine obs_da @@ -460,9 +460,9 @@ subroutine SaveOneSimval(this, obsrv, simval) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(ObsType) :: this + class(ObsType) :: this class(ObserveType), intent(inout) :: obsrv - real(DP), intent(in) :: simval + real(DP), intent(in) :: simval ! -- local character(len=LENOBSTYPE) :: obsTypeID type(ObsDataType), pointer :: obsDatum => null() @@ -480,7 +480,7 @@ subroutine SaveOneSimval(this, obsrv, simval) obsrv%CurrentTimeStepEndValue = obsrv%CurrentTimeStepEndValue + simval else obsrv%CurrentTimeStepEndValue = simval - endif + end if ! return end subroutine SaveOneSimval @@ -497,37 +497,37 @@ subroutine StoreObsType(this, obsrvType, cumulative, indx) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - character(len=*), intent(in) :: obsrvType + character(len=*), intent(in) :: obsrvType ! cumulative: Accumulate simulated values for multiple boundaries - logical, intent(in) :: cumulative - integer(I4B), intent(out) :: indx + logical, intent(in) :: cumulative + integer(I4B), intent(out) :: indx ! -- local integer(I4B) :: i - character(len=LENOBSTYPE) :: obsTypeUpper + character(len=LENOBSTYPE) :: obsTypeUpper character(len=100) :: msg ! ------------------------------------------------------------------------------ ! ! -- Ensure that obsrvType is not blank - if (obsrvType=='') then + if (obsrvType == '') then msg = 'Programmer error: Invalid argument in store_obs_type.' call store_error(msg, terminate=.TRUE.) - endif + end if ! ! -- Find first unused element indx = -1 - do i=1,MAXOBSTYPES + do i = 1, MAXOBSTYPES if (this%obsData(i)%ObsTypeID /= '') cycle indx = i exit - enddo + end do ! ! -- Ensure that array size is not exceeded if (indx == -1) then msg = 'Size of obsData array is insufficient; ' & - // 'need to increase MAXOBSTYPES.' + //'need to increase MAXOBSTYPES.' call store_error(msg) call store_error_unit(this%inUnitObs) - endif + end if ! ! -- Convert character argument to upper case obsTypeUpper = obsrvType @@ -553,10 +553,10 @@ subroutine allocate_scalars(this) class(ObsType) :: this ! ------------------------------------------------------------------------------ ! - allocate(this%active) - allocate(this%inputFilename) - allocate(this%obsOutputList) - allocate(this%obsData(MAXOBSTYPES)) + allocate (this%active) + allocate (this%inputFilename) + allocate (this%obsOutputList) + allocate (this%obsData(MAXOBSTYPES)) ! ! -- Initialize this%active = .false. @@ -578,21 +578,21 @@ subroutine obs_ar1(this, pkgname) class(ObsType), intent(inout) :: this character(len=*), intent(in) :: pkgname ! -- formats - 10 format(/,'The observation utility is active for "',a,'"') +10 format(/, 'The observation utility is active for "', a, '"') ! ------------------------------------------------------------------------------ ! if (this%inUnitObs > 0) then this%active = .true. ! ! -- Indicate that OBS is active - write(this%iout,10)trim(pkgname) + write (this%iout, 10) trim(pkgname) ! ! -- Read Options block call this%read_obs_options() ! ! -- define output formats call this%define_fmts() - endif + end if ! return end subroutine obs_ar1 @@ -608,11 +608,11 @@ subroutine obs_ar2(this, dis) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - class(DisBaseType) :: dis + class(DisBaseType) :: dis ! -- local integer(I4B) :: i - type(ObsDataType), pointer :: obsDat => null() - character(len=LENOBSTYPE) :: obsTypeID + type(ObsDataType), pointer :: obsDat => null() + character(len=LENOBSTYPE) :: obsTypeID class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! @@ -620,19 +620,19 @@ subroutine obs_ar2(this, dis) ! -- allocate and populate observations array call this%get_obs_array(this%npakobs, this%pakobs) ! - do i=1,this%npakobs + do i = 1, this%npakobs obsrv => this%pakobs(i)%obsrv ! -- Call IDstring processor procedure provided by package obsTypeID = obsrv%ObsTypeId obsDat => this%get_obs_datum(obsTypeID) if (associated(obsDat%ProcessIdPtr)) then call obsDat%ProcessIdPtr(obsrv, dis, & - this%inUnitObs, this%iout) + this%inUnitObs, this%iout) else call DefaultObsIdProcessor(obsrv, dis, & - this%inUnitObs, this%iout) - endif - enddo + this%inUnitObs, this%iout) + end if + end do ! if (count_errors() > 0) then call store_error_unit(this%inunitobs) @@ -662,9 +662,9 @@ subroutine read_obs_options(this) logical :: continueread, found, endOfBlock ! -- formats 10 format('No options block found in OBS input. Defaults will be used.') -40 format('Text output number of digits of precision set to: ',i2) +40 format('Text output number of digits of precision set to: ', i2) 50 format('Text output number of digits set to internal representation (G0).') -60 format(/,'Processing observation options:',/) +60 format(/, 'Processing observation options:',/) ! ------------------------------------------------------------------------------ ! localprecision = 0 @@ -673,7 +673,7 @@ subroutine read_obs_options(this) ! ! -- Find and store file name iin = this%inUnitObs - inquire(unit=iin, name=fname) + inquire (unit=iin, name=fname) this%inputFilename = fname ! ! -- Read Options block @@ -682,22 +682,22 @@ subroutine read_obs_options(this) ! ! -- get BEGIN line of OPTIONS block call this%parser%GetBlock('OPTIONS', found, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) if (ierr /= 0) then ! end of file - errmsg = 'End-of-file encountered while searching for' // & - ' OPTIONS in OBS ' // & - 'input file "' // trim(this%inputFilename) // '"' + errmsg = 'End-of-file encountered while searching for'// & + ' OPTIONS in OBS '// & + 'input file "'//trim(this%inputFilename)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() elseif (.not. found) then this%blockTypeFound = '' - if (this%iout>0) write(this%iout,10) - endif + if (this%iout > 0) write (this%iout, 10) + end if ! ! -- parse OPTIONS entries if (found) then - write(this%iout,60) + write (this%iout, 60) readblockoptions: do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -720,33 +720,33 @@ subroutine read_obs_options(this) ! ! -- Set localdigits to valid value: 0, or 2 to 16 if (localdigits == 0) then - write(this%iout, 50) + write (this%iout, 50) else if (localdigits < 1) then - errmsg = 'Error in OBS input: Invalid value for DIGITS option' - call store_error(errmsg) - exit readblockoptions + errmsg = 'Error in OBS input: Invalid value for DIGITS option' + call store_error(errmsg) + exit readblockoptions else if (localdigits < 2) localdigits = 2 if (localdigits > 16) localdigits = 16 - write(this%iout, 40) localdigits + write (this%iout, 40) localdigits end if case ('PRINT_INPUT') this%echo = .true. - write(this%iout,'(a)')'The PRINT_INPUT option has been specified.' + write (this%iout, '(a)') 'The PRINT_INPUT option has been specified.' case default - errmsg = 'Error in OBS input: Unrecognized option: ' // & - trim(keyword) + errmsg = 'Error in OBS input: Unrecognized option: '// & + trim(keyword) call store_error(errmsg) exit readblockoptions end select - enddo readblockoptions - endif + end do readblockoptions + end if ! - if (count_errors()>0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! - write(this%iout,'(1x)') + write (this%iout, '(1x)') ! ! -- Assign type variables if (localprecision > 0) this%iprecision = localprecision @@ -766,13 +766,13 @@ subroutine define_fmts(this) ! -- dummy class(ObsType) :: this ! formats -50 format('(g',i2.2,'.',i2.2,')') +50 format('(g', i2.2, '.', i2.2, ')') ! ------------------------------------------------------------------------------ ! if (this%idigits == 0) then this%obsfmtcont = '(G0)' else - write(this%obsfmtcont,50) this%idigits+7, this%idigits + write (this%obsfmtcont, 50) this%idigits + 7, this%idigits end if return end subroutine define_fmts @@ -838,9 +838,9 @@ subroutine build_headers(this) integer(I4B) :: iu integer(I4B) :: num integer(int32) :: nobs - character(len=4) :: clenobsname - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() + character(len=4) :: clenobsname + type(ObserveType), pointer :: obsrv => null() + type(ObsOutputType), pointer :: obsOutput => null() ! ------------------------------------------------------------------------------ ! ! -- Cycle through ObsOutputList to write headers @@ -854,40 +854,40 @@ subroutine build_headers(this) ! ! -- write header information to the formatted file if (obsOutput%FormattedOutput) then - write(iu, '(a)', advance='NO') 'time' + write (iu, '(a)', advance='NO') 'time' else ! -- write header to unformatted file ! First 11 bytes are obs type and precision - if (this%iprecision==1) then + if (this%iprecision == 1) then ! -- single precision output - write(iu) 'cont single' - else if (this%iprecision==2) then + write (iu) 'cont single' + else if (this%iprecision == 2) then ! -- double precision output - write(iu) 'cont double' + write (iu) 'cont double' end if ! -- write LENOBSNAME to bytes 12-15 - write(clenobsname,'(i4)') LENOBSNAME - write(iu) clenobsname + write (clenobsname, '(i4)') LENOBSNAME + write (iu) clenobsname ! -- write blanks to complete 100-byte header do ii = 16, 100 - write(iu) ' ' + write (iu) ' ' end do ! -- write NOBS - write(iu) nobs + write (iu) nobs end if ! ! -- write observation name obsfile: do ii = 1, nobs obsrv => this%get_obs(idx) if (obsOutput%FormattedOutput) then - write(iu, '(a,a)', advance='NO') ',', trim(obsrv%Name) + write (iu, '(a,a)', advance='NO') ',', trim(obsrv%Name) ! ! -- terminate the line on the last observation in file if (ii == nobs) then - write(iu, '(a)', advance='YES') '' + write (iu, '(a)', advance='YES') '' end if else - write(iu) obsrv%Name + write (iu) obsrv%Name end if idx = idx + 1 end do obsfile @@ -907,19 +907,19 @@ subroutine get_obs_array(this, nObs, obsArray) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - integer(I4B), intent(out) :: nObs + integer(I4B), intent(out) :: nObs type(ObsContainerType), dimension(:), pointer, intent(inout) :: obsArray ! -- local ! ------------------------------------------------------------------------------ ! nObs = this%get_num() - if (associated(obsArray)) deallocate(obsArray) - allocate(obsArray(nObs)) + if (associated(obsArray)) deallocate (obsArray) + allocate (obsArray(nObs)) ! ! Get observations if (nObs > 0) then call this%populate_obs_array(nObs, obsArray) - endif + end if ! return end subroutine get_obs_array @@ -941,18 +941,18 @@ function get_obs_datum(this, obsTypeID) result(obsDatum) ! ------------------------------------------------------------------------------ ! obsDatum => null() - do i=1,MAXOBSTYPES + do i = 1, MAXOBSTYPES if (this%obsData(i)%ObsTypeID == obsTypeID) then obsDatum => this%obsData(I) exit - endif - enddo + end if + end do ! if (.not. associated(obsDatum)) then - errmsg = 'Observation type not found: ' // trim(obsTypeID) + errmsg = 'Observation type not found: '//trim(obsTypeID) call store_error(errmsg) call store_error_unit(this%inUnitObs) - endif + end if ! return end function get_obs_datum @@ -967,7 +967,7 @@ subroutine populate_obs_array(this, nObs, obsArray) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType), intent(inout) :: this - integer(I4B), intent(in) :: nObs + integer(I4B), intent(in) :: nObs type(ObsContainerType), dimension(nObs), intent(inout) :: obsArray ! ------------------------------------------------------------------------------ ! @@ -976,10 +976,10 @@ subroutine populate_obs_array(this, nObs, obsArray) type(ObserveType), pointer :: obsrv => null() ! n = this%get_num() - do i=1,n + do i = 1, n obsrv => this%get_obs(i) obsArray(i)%obsrv => obsrv - enddo + end do ! return end subroutine populate_obs_array @@ -994,7 +994,7 @@ function get_obs(this, indx) result(obsrv) ! ------------------------------------------------------------------------------ ! -- dummy class(ObsType) :: this - integer(I4B), intent(in) :: indx + integer(I4B), intent(in) :: indx class(ObserveType), pointer :: obsrv ! -- local ! ------------------------------------------------------------------------------ @@ -1024,8 +1024,8 @@ subroutine read_obs_blocks(this, fname) character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag character(len=20) :: accarg, bin, fmtarg - type(ObserveType), pointer :: obsrv => null() - type(ObsOutputType), pointer :: obsOutput => null() + type(ObserveType), pointer :: obsrv => null() + type(ObsOutputType), pointer :: obsOutput => null() integer(I4B) :: ntabrows integer(I4B) :: ntabcols ! -- formats @@ -1035,7 +1035,7 @@ subroutine read_obs_blocks(this, fname) numspec = -1 errmsg = '' ! - inquire(unit=this%parser%iuactive, name=pnamein) + inquire (unit=this%parser%iuactive, name=pnamein) call GetFileFromPath(pnamein, fnamein) ! if (this%echo) then @@ -1046,18 +1046,18 @@ subroutine read_obs_blocks(this, fname) ntabcols = 5 ! ! -- initialize table and define columns - title = 'OBSERVATIONS READ FROM FILE "' // trim(fnamein) // '"' + title = 'OBSERVATIONS READ FROM FILE "'//trim(fnamein)//'"' call table_cr(this%obstab, fnamein, title) - call this%obstab%table_df(ntabrows, ntabcols, this%iout, & + call this%obstab%table_df(ntabrows, ntabcols, this%iout, & finalize=.FALSE.) tag = 'NAME' call this%obstab%initialize_column(tag, LENOBSNAME, alignment=TABLEFT) tag = 'TYPE' - call this%obstab%initialize_column(tag, LENOBSTYPE+12, alignment=TABLEFT) + call this%obstab%initialize_column(tag, LENOBSTYPE + 12, alignment=TABLEFT) tag = 'TIME' call this%obstab%initialize_column(tag, 12, alignment=TABLEFT) tag = 'LOCATION DATA' - call this%obstab%initialize_column(tag, LENBOUNDNAME+2, alignment=TABLEFT) + call this%obstab%initialize_column(tag, LENBOUNDNAME + 2, alignment=TABLEFT) tag = 'OUTPUT FILENAME' call this%obstab%initialize_column(tag, 80, alignment=TABLEFT) end if @@ -1075,8 +1075,8 @@ subroutine read_obs_blocks(this, fname) ! Get keyword, which should be FILEOUT call this%parser%GetStringCaps(word) if (word /= 'FILEOUT') then - call store_error('CONTINUOUS keyword must be followed by ' // & - '"FILEOUT" then by filename.') + call store_error('CONTINUOUS keyword must be followed by '// & + '"FILEOUT" then by filename.') cycle end if ! @@ -1084,13 +1084,13 @@ subroutine read_obs_blocks(this, fname) call this%parser%GetString(fname) ! Fname is the output file name defined in the BEGIN line of the block. if (fname == '') then - message = 'Error reading OBS input file, likely due to bad' // & + message = 'Error reading OBS input file, likely due to bad'// & ' block or missing file name.' call store_error(message) cycle else if (this%obsOutputList%ContainsFile(fname)) then - errmsg = 'OBS outfile "' // trim(fname) // & - '" is provided more than once.' + errmsg = 'OBS outfile "'//trim(fname)// & + '" is provided more than once.' call store_error(errmsg) cycle end if @@ -1105,16 +1105,16 @@ subroutine read_obs_blocks(this, fname) fmtarg = 'FORMATTED' accarg = 'SEQUENTIAL' fmtd = .true. - endif + end if ! ! -- open the output file numspec = 0 - call openfile(numspec, 0, fname, 'OBS OUTPUT', fmtarg, & + call openfile(numspec, 0, fname, 'OBS OUTPUT', fmtarg, & accarg, 'REPLACE') ! ! -- add output file to list of output files and assign its ! FormattedOutput member appropriately - call this%obsOutputList%Add(fname,numspec) + call this%obsOutputList%Add(fname, numspec) indexobsout = this%obsOutputList%Count() obsOutput => this%obsOutputList%Get(indexobsout) obsOutput%FormattedOutput = fmtd @@ -1144,8 +1144,8 @@ subroutine read_obs_blocks(this, fname) end if end do readblockcontinuous case default - errmsg = 'Error: Observation block type not recognized: ' // & - trim(btagfound) + errmsg = 'Error: Observation block type not recognized: '// & + trim(btagfound) call store_error(errmsg) end select end do readblocks @@ -1175,9 +1175,9 @@ subroutine write_continuous_simvals(this) ! -- dummy class(ObsType), intent(inout) :: this ! -- local - integer(I4B) :: i, iprec, numobs - character(len=20) :: fmtc - real(DP) :: simval + integer(I4B) :: i, iprec, numobs + character(len=20) :: fmtc + real(DP) :: simval class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! @@ -1186,7 +1186,7 @@ subroutine write_continuous_simvals(this) fmtc = this%obsfmtcont ! -- iterate through all observations numobs = this%obsList%Count() - do i=1,numobs + do i = 1, numobs obsrv => this%get_obs(i) ! -- continuous observation simval = obsrv%CurrentTimeStepEndValue @@ -1194,11 +1194,11 @@ subroutine write_continuous_simvals(this) call write_fmtd_cont(fmtc, obsrv, this%obsOutputList, simval) else call write_unfmtd_cont(obsrv, iprec, this%obsOutputList, simval) - endif + end if end do ! ! -- flush file - flush(obsrv%UnitNumber) + flush (obsrv%UnitNumber) ! ! --return return diff --git a/src/Utilities/Observation/ObsContainer.f90 b/src/Utilities/Observation/ObsContainer.f90 index ee36ab30d66..b59dac00617 100644 --- a/src/Utilities/Observation/ObsContainer.f90 +++ b/src/Utilities/Observation/ObsContainer.f90 @@ -16,7 +16,7 @@ module ObsContainerModule type :: ObsContainerType ! -- Public members - class(ObserveType), pointer, public :: obsrv => null() + class(ObserveType), pointer, public :: obsrv => null() end type ObsContainerType end module ObsContainerModule diff --git a/src/Utilities/Observation/ObsOutput.f90 b/src/Utilities/Observation/ObsOutput.f90 index 2109e61c449..a467031acbe 100644 --- a/src/Utilities/Observation/ObsOutput.f90 +++ b/src/Utilities/Observation/ObsOutput.f90 @@ -64,9 +64,9 @@ subroutine WriteLineout(this) implicit none ! -- dummy class(ObsOutputType), intent(inout) :: this - ! -- write a line return to end of observation output line + ! -- write a line return to end of observation output line ! for this totim - write(this%nunit,'(a)', advance='YES') '' + write (this%nunit, '(a)', advance='YES') '' ! return end subroutine WriteLineout @@ -115,7 +115,7 @@ subroutine ConstructObsOutput(newObsOutput, fname, nunit) character(len=*), intent(in) :: fname integer(I4B), intent(in) :: nunit ! - allocate(newObsOutput) + allocate (newObsOutput) newObsOutput%filename = fname newObsOutput%nunit = nunit return @@ -124,7 +124,7 @@ end subroutine ConstructObsOutput subroutine AddObsOutputToList(list, obsOutput) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(ObsOutputType), pointer, intent(inout) :: obsOutput ! -- local class(*), pointer :: obj @@ -135,12 +135,12 @@ subroutine AddObsOutputToList(list, obsOutput) return end subroutine AddObsOutputToList - function GetObsOutputFromList(list, idx) result (res) + function GetObsOutputFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(ObsOutputType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + type(ObsOutputType), pointer :: res ! -- local class(*), pointer :: obj ! diff --git a/src/Utilities/Observation/ObsOutputList.f90 b/src/Utilities/Observation/ObsOutputList.f90 index 6a9f01b0598..55de0b7665f 100644 --- a/src/Utilities/Observation/ObsOutputList.f90 +++ b/src/Utilities/Observation/ObsOutputList.f90 @@ -10,7 +10,7 @@ module ObsOutputListModule use KindModule, only: DP, I4B use InputOutputModule, only: same_word use ListModule, only: ListType - use ObsOutputModule, only: ObsOutputType, ConstructObsOutput, & + use ObsOutputModule, only: ObsOutputType, ConstructObsOutput, & AddObsOutputToList, GetObsOutputFromList implicit none @@ -51,10 +51,10 @@ subroutine ClearOutputLines(this) type(ObsOutputType), pointer :: obsOutput => null() ! num = this%Count() - do i=1,num + do i = 1, num obsOutput => this%Get(i) call obsOutput%ClearLineout() - enddo + end do ! return end subroutine ClearOutputLines @@ -76,7 +76,7 @@ function Count(this) return end function Count - logical function ContainsFile(this,fname) + logical function ContainsFile(this, fname) ! ************************************************************************** ! ContainsFile -- return true if filename fname is included in list of ! ObsOutputType objects @@ -87,24 +87,24 @@ logical function ContainsFile(this,fname) implicit none ! -- dummy class(ObsOutputListType), intent(inout) :: this - character(len=*), intent(in) :: fname + character(len=*), intent(in) :: fname ! -- local type(ObsOutputType), pointer :: obsOutput => null() integer(I4B) :: i, n ! ContainsFile = .false. n = this%Count() - loop1: do i=1,n + loop1: do i = 1, n obsOutput => this%Get(i) - if (same_word(obsOutput%filename,fname)) then + if (same_word(obsOutput%filename, fname)) then ContainsFile = .true. exit loop1 - endif - enddo loop1 + end if + end do loop1 return end function ContainsFile - subroutine Add(this,fname,nunit) + subroutine Add(this, fname, nunit) ! ************************************************************************** ! Add -- construct a new ObsOutputType object with arguments assigned to ! its members, and add the new object to the list @@ -115,8 +115,8 @@ subroutine Add(this,fname,nunit) implicit none ! -- dummy class(ObsOutputListType), intent(inout) :: this - character(len=*), intent(in) :: fname - integer(I4B), intent(in) :: nunit + character(len=*), intent(in) :: fname + integer(I4B), intent(in) :: nunit ! -- local type(ObsOutputType), pointer :: obsOutput => null() ! @@ -143,12 +143,12 @@ subroutine WriteOutputLines(this) integer(I4B) :: i, num ! num = this%Count() - do i=1,num + do i = 1, num obsOutput => this%Get(i) if (obsOutput%FormattedOutput) then call obsOutput%WriteLineout() - endif - enddo + end if + end do ! return end subroutine WriteOutputLines @@ -196,10 +196,10 @@ subroutine DeallocObsOutputList(this) type(ObsOutputType), pointer :: obsoutput => null() ! n = this%Count() - do i=1,n + do i = 1, n obsoutput => GetObsOutputFromList(this%ObsOutputs, i) !call obsoutput%DeallocObsOutput() - enddo + end do ! call this%ObsOutputs%Clear(.true.) ! diff --git a/src/Utilities/Observation/ObsUtility.f90 b/src/Utilities/Observation/ObsUtility.f90 index b8e90576b6b..1b04c70a9c4 100644 --- a/src/Utilities/Observation/ObsUtility.f90 +++ b/src/Utilities/Observation/ObsUtility.f90 @@ -6,11 +6,11 @@ module ObsUtilityModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENOBSNAME, LENBIGLINE - use ObserveModule, only: ObserveType + use ConstantsModule, only: LENOBSNAME, LENBIGLINE + use ObserveModule, only: ObserveType use ObsOutputListModule, only: ObsOutputListType - use ObsOutputModule, only: ObsOutputType - use TdisModule, only: totim + use ObsOutputModule, only: ObsOutputType + use TdisModule, only: totim implicit none @@ -32,16 +32,16 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) ! -------------------------------------------------------------------------- implicit none ! -- dummy - character(len=*), intent(in) :: fmtc - type(ObserveType), intent(inout) :: obsrv + character(len=*), intent(in) :: fmtc + type(ObserveType), intent(inout) :: obsrv type(ObsOutputListType), pointer, intent(inout) :: obsOutputList - real(DP), intent(in) :: value + real(DP), intent(in) :: value ! -- local - integer(I4B) :: indx - integer(I4B) :: nunit - character(len=50) :: cval + integer(I4B) :: indx + integer(I4B) :: nunit + character(len=50) :: cval character(len=LENOBSNAME), pointer :: linout => null() - type(ObsOutputType), pointer :: ObsOutput => null() + type(ObsOutputType), pointer :: ObsOutput => null() !--------------------------------------------------------------------------- ! -- format for totim 10 format(G20.13) @@ -52,13 +52,13 @@ subroutine write_fmtd_cont(fmtc, obsrv, obsOutputList, value) ObsOutput => obsOutputList%Get(indx) linout => obsOutput%lineout if (linout == '') then - write(linout,10) totim - write(cval,10) totim - write(nunit, '(a)', advance='NO') trim(adjustl(cval)) - endif + write (linout, 10) totim + write (cval, 10) totim + write (nunit, '(a)', advance='NO') trim(adjustl(cval)) + end if ! -- append value to output line - write(cval,fmtc)value - write(nunit, '(a,a)', advance='NO') ',', trim(adjustl(cval)) + write (cval, fmtc) value + write (nunit, '(a,a)', advance='NO') ',', trim(adjustl(cval)) ! ! -- return return @@ -86,11 +86,11 @@ subroutine write_unfmtd_cont(obsrv, iprec, obsOutputList, value) type(ObsOutputListType), pointer, intent(inout) :: obsOutputList real(DP), intent(in) :: value ! -- local - integer(I4B) :: indx, nunit + integer(I4B) :: indx, nunit character(len=LENOBSNAME), pointer :: linout => null() - real(real32) :: totimsngl, valsngl - real(real64) :: totimdbl, valdbl - type(ObsOutputType), pointer :: obsOutput => null() + real(real32) :: totimsngl, valsngl + real(real64) :: totimdbl, valdbl + type(ObsOutputType), pointer :: obsOutput => null() !--------------------------------------------------------------------------- ! -- formats 10 format(G20.13) @@ -101,23 +101,23 @@ subroutine write_unfmtd_cont(obsrv, iprec, obsOutputList, value) obsOutput => obsOutputList%Get(indx) linout => obsOutput%lineout if (linout == '') then - write(linout,10)totim + write (linout, 10) totim if (iprec == 1) then totimsngl = real(totim, real32) - write(nunit)totimsngl + write (nunit) totimsngl elseif (iprec == 2) then totimdbl = totim - write(nunit)totimdbl - endif - endif + write (nunit) totimdbl + end if + end if ! -- write value to unformatted output if (iprec == 1) then valsngl = real(value, real32) - write(nunit)valsngl + write (nunit) valsngl elseif (iprec == 2) then valdbl = value - write(nunit)valdbl - endif + write (nunit) valdbl + end if ! ! -- return return diff --git a/src/Utilities/Observation/Observe.f90 b/src/Utilities/Observation/Observe.f90 index e8f0a732653..cd34726e074 100644 --- a/src/Utilities/Observation/Observe.f90 +++ b/src/Utilities/Observation/Observe.f90 @@ -11,18 +11,18 @@ !----------------------------------------------------------------------- module ObserveModule - use KindModule, only: DP, I4B - use BaseDisModule, only: DisBaseType - use ConstantsModule, only: LENBOUNDNAME, LENOBSNAME, LENOBSTYPE, & - MAXOBSTYPES, DNODATA, DZERO - use TableModule, only: TableType - use InputOutputModule, only: urword - use ListModule, only: ListType - use SimModule, only: store_warning, store_error, & - store_error_unit - use TdisModule, only: totim, totalsimtime + use KindModule, only: DP, I4B + use BaseDisModule, only: DisBaseType + use ConstantsModule, only: LENBOUNDNAME, LENOBSNAME, LENOBSTYPE, & + MAXOBSTYPES, DNODATA, DZERO + use TableModule, only: TableType + use InputOutputModule, only: urword + use ListModule, only: ListType + use SimModule, only: store_warning, store_error, & + store_error_unit + use TdisModule, only: totim, totalsimtime use ArrayHandlersModule, only: ExpandArrayWrapper - + implicit none private @@ -68,11 +68,11 @@ module ObserveModule type(ObsDataType), pointer, private :: obsDatum => null() contains ! -- Public procedures - procedure, public :: ResetCurrent - procedure, public :: WriteTo - procedure, public :: AddObsIndex - procedure, public :: ResetObsIndex - procedure, public :: da + procedure, public :: ResetCurrent + procedure, public :: WriteTo + procedure, public :: AddObsIndex + procedure, public :: ResetObsIndex + procedure, public :: da end type ObserveType type :: ObsDataType @@ -96,10 +96,10 @@ subroutine ProcessIdSub(obsrv, dis, inunitobs, iout) import :: ObserveType import :: DisBaseType ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout end subroutine ProcessIdSub end interface @@ -143,21 +143,21 @@ subroutine WriteTo(this, obstab, btagfound, fnamein) if (len_trim(btagfound) > 12) then tag = btagfound(1:12) else - write(tag, '(a12)') btagfound + write (tag, '(a12)') btagfound end if ! ! -- write fnamein to fnameout if (len_trim(fnamein) > 80) then fnameout = fnamein(1:80) else - write(fnameout, '(a80)') fnamein + write (fnameout, '(a80)') fnamein end if ! ! -- write data to observation table call obstab%add_term(this%Name) - call obstab%add_term(tag // trim(this%ObsTypeId)) + call obstab%add_term(tag//trim(this%ObsTypeId)) call obstab%add_term('ALL TIMES') - call obstab%add_term('"' // trim(this%IDstring) // '"') + call obstab%add_term('"'//trim(this%IDstring)//'"') call obstab%add_term(fnameout) ! ! -- return @@ -179,11 +179,11 @@ subroutine ResetObsIndex(this) ! ! -- Deallocate observation index array, if necessary if (allocated(this%indxbnds)) then - deallocate(this%indxbnds) + deallocate (this%indxbnds) end if ! ! -- Allocate observation index array to size 0 - allocate(this%indxbnds(0)) + allocate (this%indxbnds(0)) ! ! -- return return @@ -192,7 +192,7 @@ end subroutine ResetObsIndex subroutine AddObsIndex(this, indx) ! ************************************************************************** ! AddObsIndex -- Add the observation index to the observation index array -! (indbnds). The observation index count (indxbnds_count) +! (indbnds). The observation index count (indxbnds_count) ! is also incremented by one and the observation index array ! is expanded, if necessary. ! ************************************************************************** @@ -226,7 +226,7 @@ subroutine da(this) ! -- dummy class(ObserveType), intent(inout) :: this if (allocated(this%indxbnds)) then - deallocate(this%indxbnds) + deallocate (this%indxbnds) end if ! ! -- return @@ -245,13 +245,13 @@ subroutine ConstructObservation(newObservation, defLine, numunit, & ! SPECIFICATIONS: ! -------------------------------------------------------------------------- ! -- dummy variables - type(ObserveType), pointer :: newObservation - character(len=*), intent(in) :: defLine - integer(I4B), intent(in) :: numunit ! Output unit number - logical, intent(in) :: formatted ! Formatted output? - integer(I4B), intent(in) :: indx ! Index in ObsOutput array + type(ObserveType), pointer :: newObservation + character(len=*), intent(in) :: defLine + integer(I4B), intent(in) :: numunit ! Output unit number + logical, intent(in) :: formatted ! Formatted output? + integer(I4B), intent(in) :: indx ! Index in ObsOutput array type(ObsDataType), dimension(:), pointer, intent(in) :: obsData - integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: inunit ! -- local real(DP) :: r integer(I4B) :: i, icol, iout, istart, istop, n @@ -262,8 +262,8 @@ subroutine ConstructObservation(newObservation, defLine, numunit, & icol = 1 ! ! -- Allocate an ObserveType object. - allocate(newObservation) - allocate(newObservation%indxbnds(0)) + allocate (newObservation) + allocate (newObservation%indxbnds(0)) ! ! -- Set indxbnds_count to 0 newObservation%indxbnds_count = 0 @@ -272,22 +272,22 @@ subroutine ConstructObservation(newObservation, defLine, numunit, & ! contents of defLine. ! ! -- Get observation name and store it - call urword(defLine,icol,istart,istop,1,n,r,iout,inunit) + call urword(defLine, icol, istart, istop, 1, n, r, iout, inunit) newObservation%Name = defLine(istart:istop) ! ! -- Get observation type, convert it to uppercase, and store it. - call urword(defLine,icol,istart,istop,1,n,r,iout,inunit) + call urword(defLine, icol, istart, istop, 1, n, r, iout, inunit) newObservation%ObsTypeId = defLine(istart:istop) ! ! -- Look up package ID for this observation type and store it - do i=1,MAXOBSTYPES + do i = 1, MAXOBSTYPES if (obsData(i)%ObsTypeID == newObservation%ObsTypeId) then newObservation%obsDatum => obsData(i) exit elseif (obsData(i)%ObsTypeID == '') then exit - endif - enddo + end if + end do ! ! -- Remaining text is ID [and ID2]; store the remainder of the string istart = istop + 1 @@ -321,7 +321,7 @@ end function CastAsObserveType subroutine AddObsToList(list, obs) ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(ObserveType), pointer, intent(inout) :: obs ! -- local class(*), pointer :: obj @@ -332,11 +332,11 @@ subroutine AddObsToList(list, obs) return end subroutine AddObsToList - function GetObsFromList(list, idx) result (res) + function GetObsFromList(list, idx) result(res) ! -- dummy type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(ObserveType), pointer :: res + integer(I4B), intent(in) :: idx + type(ObserveType), pointer :: res ! -- local class(*), pointer :: obj ! diff --git a/src/Utilities/OpenSpec.f90 b/src/Utilities/OpenSpec.f90 index 224b6680cc2..2be8d7bf0d7 100644 --- a/src/Utilities/OpenSpec.f90 +++ b/src/Utilities/OpenSpec.f90 @@ -4,7 +4,7 @@ module OpenSpecModule ! specifiers is not included in ANSI FORTRAN 77. The included ! specifiers are ACCESS, FORM and ACTION. ! - CHARACTER(len=20) :: ACCESS,FORM,ACTION(2) + CHARACTER(len=20) :: ACCESS, FORM, ACTION(2) ! ! ! Specifiers for OPEN statements for unformatted files, which are @@ -15,14 +15,14 @@ module OpenSpecModule ! ! Standard Fortran -- Use unless there is a reason to do otherwise. ! DATA ACCESS/'SEQUENTIAL'/ - DATA ACCESS/'STREAM'/ + DATA ACCESS/'STREAM'/ ! ! ! FORM specifier -- ! ! Standard Fortran, which results in vendor dependent (non-portable) ! files. Use unless there is a reason to do otherwise. - DATA FORM/'UNFORMATTED'/ + DATA FORM/'UNFORMATTED'/ ! ! Non-standard Fortran that causes code compiled by Compaq (Digital) ! Fortran on personal computers to use unstructured non-formatted @@ -41,7 +41,7 @@ module OpenSpecModule ! ! Standard Fortran 90 and 95 -- Use unless there is a reason to do ! otherwise. - DATA (ACTION(IACT),IACT=1,2)/'READ','READWRITE'/ + DATA(ACTION(IACT), IACT=1, 2)/'READ', 'READWRITE'/ ! ! Non-standard Fortran that causes code compiled by the Lahey LF90 ! compiler to create files that can be shared. For use when parallel @@ -49,4 +49,4 @@ module OpenSpecModule ! while the program is running. ! DATA (ACTION(I),I=1,2)/'READ,DENYWRITE','READWRITE,DENYNONE'/ ! -end module OpenSpecModule \ No newline at end of file +end module OpenSpecModule diff --git a/src/Utilities/OutputControl/OutputControl.f90 b/src/Utilities/OutputControl/OutputControl.f90 index d6591f6fb7f..23a97e25748 100644 --- a/src/Utilities/OutputControl/OutputControl.f90 +++ b/src/Utilities/OutputControl/OutputControl.f90 @@ -7,13 +7,13 @@ !< module OutputControlModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENMEMPATH - use SimVariablesModule, only: errmsg + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENMEMPATH + use SimVariablesModule, only: errmsg use OutputControlDataModule, only: OutputControlDataType, ocd_cr - use BlockParserModule, only: BlockParserType + use BlockParserModule, only: BlockParserType use InputOutputModule, only: GetUnit, openfile - + implicit none private public OutputControlType, oc_cr @@ -22,16 +22,17 @@ module OutputControlModule !! !! Generalized output control package !< - type OutputControlType - character(len=LENMEMPATH) :: memoryPath !< path to data stored in the memory manager - character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model - integer(I4B), pointer :: inunit => null() !< unit number for input file - integer(I4B), pointer :: iout => null() !< unit number for output file - integer(I4B), pointer :: ibudcsv => null() !< unit number for budget csv output file - integer(I4B), pointer :: iperoc => null() !< stress period number for next output control - integer(I4B), pointer :: iocrep => null() !< output control repeat flag (period 0 step 0) - type(OutputControlDataType), dimension(:), pointer, contiguous :: ocdobj => null() !< output control objects - type(BlockParserType) :: parser + type OutputControlType + character(len=LENMEMPATH) :: memoryPath !< path to data stored in the memory manager + character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model + integer(I4B), pointer :: inunit => null() !< unit number for input file + integer(I4B), pointer :: iout => null() !< unit number for output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for budget csv output file + integer(I4B), pointer :: iperoc => null() !< stress period number for next output control + integer(I4B), pointer :: iocrep => null() !< output control repeat flag (period 0 step 0) + type(OutputControlDataType), dimension(:), & + pointer, contiguous :: ocdobj => null() !< output control objects + type(BlockParserType) :: parser contains procedure :: oc_df procedure :: oc_rp @@ -45,7 +46,7 @@ module OutputControlModule procedure :: set_print_flag end type OutputControlType - contains +contains !> @ brief Create OutputControlType !! @@ -55,13 +56,13 @@ module OutputControlModule !< subroutine oc_cr(ocobj, name_model, inunit, iout) ! -- dummy - type(OutputControlType), pointer :: ocobj !< OutputControlType object - character(len=*), intent(in) :: name_model !< name of the model - integer(I4B), intent(in) :: inunit !< unit number for input - integer(I4B), intent(in) :: iout !< unit number for output + type(OutputControlType), pointer :: ocobj !< OutputControlType object + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< unit number for input + integer(I4B), intent(in) :: iout !< unit number for output ! ! -- Create the object - allocate(ocobj) + allocate (ocobj) ! ! -- Allocate scalars call ocobj%allocate_scalars(name_model) @@ -84,7 +85,7 @@ end subroutine oc_cr !< subroutine oc_df(this) ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! ! -- Return return @@ -97,11 +98,11 @@ end subroutine oc_df !< subroutine oc_rp(this) ! -- modules - use TdisModule, only: kper, nper - use ConstantsModule, only: LINELENGTH + use TdisModule, only: kper, nper + use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! -- local integer(I4B) :: ierr, ival, ipos logical :: isfound, found, endOfBlock @@ -110,19 +111,19 @@ subroutine oc_rp(this) character(len=LINELENGTH) :: printsave class(OutputControlDataType), pointer :: ocdobjptr ! -- formats - character(len=*), parameter :: fmtboc = & - "(1X,/1X,'BEGIN READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" - character(len=*), parameter :: fmteoc = & - "(/,1X,'END READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" - character(len=*), parameter :: fmterr = & - "(' ERROR READING OUTPUT CONTROL PERIOD BLOCK: ')" - character(len=*), parameter :: fmtroc = & - "(1X,/1X,'OUTPUT CONTROL FOR STRESS PERIOD ',I0, & - &' IS REPEATED USING SETTINGS FROM A PREVIOUS STRESS PERIOD.')" - character(len=*), parameter :: fmtpererr = & - "(1x,'CURRENT STRESS PERIOD GREATER THAN PERIOD IN OUTPUT CONTROL.')" - character(len=*), parameter :: fmtpererr2 = & - "(1x,'CURRENT STRESS PERIOD: ',I0,' SPECIFIED STRESS PERIOD: ',I0)" + character(len=*), parameter :: fmtboc = & + &"(1X,/1X,'BEGIN READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" + character(len=*), parameter :: fmteoc = & + &"(/,1X,'END READING OUTPUT CONTROL FOR STRESS PERIOD ',I0)" + character(len=*), parameter :: fmterr = & + &"(' ERROR READING OUTPUT CONTROL PERIOD BLOCK: ')" + character(len=*), parameter :: fmtroc = & + "(1X,/1X,'OUTPUT CONTROL FOR STRESS PERIOD ',I0, & + &' IS REPEATED USING SETTINGS FROM A PREVIOUS STRESS PERIOD.')" + character(len=*), parameter :: fmtpererr = & + &"(1x,'CURRENT STRESS PERIOD GREATER THAN PERIOD IN OUTPUT CONTROL.')" + character(len=*), parameter :: fmtpererr2 = & + &"(1x,'CURRENT STRESS PERIOD: ',I0,' SPECIFIED STRESS PERIOD: ',I0)" ! ! -- Read next block header if kper greater than last one read if (this%iperoc < kper) then @@ -134,38 +135,38 @@ subroutine oc_rp(this) ! -- If end of file, set iperoc past kper, else parse line if (ierr < 0) then this%iperoc = nper + 1 - write(this%iout, '(/,1x,a)') 'END OF FILE DETECTED IN OUTPUT CONTROL.' - write(this%iout, '(1x,a)') 'CURRENT OUTPUT CONTROL SETTINGS WILL BE ' - write(this%iout, '(1x,a)') 'REPEATED UNTIL THE END OF THE SIMULATION.' + write (this%iout, '(/,1x,a)') 'END OF FILE DETECTED IN OUTPUT CONTROL.' + write (this%iout, '(1x,a)') 'CURRENT OUTPUT CONTROL SETTINGS WILL BE ' + write (this%iout, '(1x,a)') 'REPEATED UNTIL THE END OF THE SIMULATION.' else ! ! -- Read period number ival = this%parser%GetInteger() ! ! -- Check to see if this is a valid kper - if(ival <= 0 .or. ival > nper) then - write(ermsg, '(a,i0)') 'PERIOD NOT VALID IN OUTPUT CONTROL: ', ival + if (ival <= 0 .or. ival > nper) then + write (ermsg, '(a,i0)') 'PERIOD NOT VALID IN OUTPUT CONTROL: ', ival call store_error(ermsg) - write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) + write (ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) call store_error(ermsg) - endif + end if ! ! -- Check to see if specified is less than kper - if(ival < kper) then - write(ermsg, fmtpererr) + if (ival < kper) then + write (ermsg, fmtpererr) call store_error(ermsg) - write(ermsg, fmtpererr2) kper, ival + write (ermsg, fmtpererr2) kper, ival call store_error(ermsg) - write(ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) + write (ermsg, '(a, a)') 'LINE: ', trim(adjustl(line)) call store_error(ermsg) - endif + end if ! ! -- Stop or set iperoc and continue - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if this%iperoc = ival - endif + end if end if ! ! -- Read the stress period block @@ -175,10 +176,10 @@ subroutine oc_rp(this) do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) call ocdobjptr%psmobj%init() - enddo + end do ! ! -- Output control time step matches simulation time step. - write(this%iout,fmtboc) this%iperoc + write (this%iout, fmtboc) this%iperoc ! ! -- loop to read records recordloop: do @@ -199,33 +200,33 @@ subroutine oc_rp(this) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(keyword2 == trim(ocdobjptr%cname)) then + if (keyword2 == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo + end if + end do if (.not. found) then call this%parser%GetCurrentLine(line) - write(ermsg, fmterr) + write (ermsg, fmterr) call store_error(ermsg) call store_error('UNRECOGNIZED KEYWORD: '//keyword2) call store_error(trim(line)) call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetRemainingLine(line) - call ocdobjptr%psmobj%rp(trim(printsave)//' '//line, & + call ocdobjptr%psmobj%rp(trim(printsave)//' '//line, & this%iout) call ocdobjptr%ocd_rp_check(this%parser%iuactive) ! ! -- End of recordloop - enddo recordloop - write(this%iout,fmteoc) this%iperoc + end do recordloop + write (this%iout, fmteoc) this%iperoc else ! ! -- Write message that output control settings are from a previous ! stress period. - write(this%iout, fmtroc) kper - endif + write (this%iout, fmtroc) kper + end if ! ! -- return return @@ -241,11 +242,11 @@ subroutine oc_ot(this, ipflg) ! -- modules use TdisModule, only: kstp, endofperiod ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - integer(I4B), intent(inout) :: ipflg !< flag indicating if data was printed + class(OutputControlType) :: this !< OutputControlType object + integer(I4B), intent(inout) :: ipflg !< flag indicating if data was printed ! -- local integer(I4B) :: ipos - type(OutputControlDataType), pointer :: ocdobjptr + type(OutputControlDataType), pointer :: ocdobjptr ! ! -- Clear printout flag(ipflg). This flag indicates that an array was ! printed to the listing file. @@ -254,7 +255,7 @@ subroutine oc_ot(this, ipflg) do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) call ocdobjptr%ocd_ot(ipflg, kstp, endofperiod, this%iout) - enddo + end do ! ! -- Return return @@ -269,16 +270,16 @@ subroutine oc_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! -- local integer(I4B) :: i ! do i = 1, size(this%ocdobj) call this%ocdobj(i)%ocd_da() - enddo - deallocate(this%ocdobj) + end do + deallocate (this%ocdobj) ! - deallocate(this%name_model) + deallocate (this%name_model) call mem_deallocate(this%inunit) call mem_deallocate(this%iout) call mem_deallocate(this%ibudcsv) @@ -299,12 +300,12 @@ subroutine allocate_scalars(this, name_model) use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: name_model !< name of model + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: name_model !< name of model ! this%memoryPath = create_mem_path(name_model, 'OC') ! - allocate(this%name_model) + allocate (this%name_model) call mem_allocate(this%inunit, 'INUNIT', this%memoryPath) call mem_allocate(this%iout, 'IOUT', this%memoryPath) call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath) @@ -332,7 +333,7 @@ subroutine read_options(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, store_error_unit ! -- dummy - class(OutputControlType) :: this !< OutputControlType object + class(OutputControlType) :: this !< OutputControlType object ! -- local character(len=LINELENGTH) :: keyword character(len=LINELENGTH) :: keyword2 @@ -341,15 +342,15 @@ subroutine read_options(this) integer(I4B) :: ierr integer(I4B) :: ipos logical :: isfound, found, endOfBlock - type(OutputControlDataType), pointer :: ocdobjptr + type(OutputControlDataType), pointer :: ocdobjptr ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(/,1x,a,/)') 'PROCESSING OC OPTIONS' + write (this%iout, '(/,1x,a,/)') 'PROCESSING OC OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -359,34 +360,35 @@ subroutine read_options(this) call this%parser%GetStringCaps(keyword2) if (keyword2 /= 'FILEOUT') then errmsg = "BUDGETCSV must be followed by FILEOUT and then budget & - &csv file name. Found '" // trim(keyword2) // "'." + &csv file name. Found '"//trim(keyword2)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end if call this%parser%GetString(fname) this%ibudcsv = GetUnit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', filstat_opt='REPLACE') + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') found = .true. end if - + if (.not. found) then do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(keyword == trim(ocdobjptr%cname)) then + if (keyword == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo + end if + end do if (.not. found) then - errmsg = "UNKNOWN OC OPTION '" // trim(keyword) // "'." + errmsg = "UNKNOWN OC OPTION '"//trim(keyword)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetRemainingLine(line) call ocdobjptr%set_option(line, this%parser%iuactive, this%iout) end if end do - write(this%iout,'(1x,a)') 'END OF OC OPTIONS' + write (this%iout, '(1x,a)') 'END OF OC OPTIONS' end if ! ! -- return @@ -402,8 +404,8 @@ logical function oc_save(this, cname) ! -- modules use TdisModule, only: kstp, endofperiod ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name ! -- local integer(I4B) :: ipos logical :: found @@ -413,14 +415,14 @@ logical function oc_save(this, cname) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then + if (cname == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo - if(found) then + end if + end do + if (found) then oc_save = ocdobjptr%psmobj%kstp_to_save(kstp, endofperiod) - endif + end if ! ! -- Return return @@ -435,8 +437,8 @@ logical function oc_print(this, cname) ! -- modules use TdisModule, only: kstp, endofperiod ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name ! -- local integer(I4B) :: ipos logical :: found @@ -446,14 +448,14 @@ logical function oc_print(this, cname) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then + if (cname == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo - if(found) then + end if + end do + if (found) then oc_print = ocdobjptr%psmobj%kstp_to_print(kstp, endofperiod) - endif + end if ! ! -- Return return @@ -469,8 +471,8 @@ function oc_save_unit(this, cname) ! -- return integer(I4B) :: oc_save_unit ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name ! -- local integer(I4B) :: ipos logical :: found @@ -480,14 +482,14 @@ function oc_save_unit(this, cname) found = .false. do ipos = 1, size(this%ocdobj) ocdobjptr => this%ocdobj(ipos) - if(cname == trim(ocdobjptr%cname)) then + if (cname == trim(ocdobjptr%cname)) then found = .true. exit - endif - enddo - if(found) then + end if + end do + if (found) then oc_save_unit = ocdobjptr%idataun - endif + end if ! ! -- Return return @@ -504,25 +506,25 @@ function set_print_flag(this, cname, icnvg, endofperiod) result(iprint_flag) ! -- return integer(I4B) :: iprint_flag ! -- dummy - class(OutputControlType) :: this !< OutputControlType object - character(len=*), intent(in) :: cname !< character string for data name - integer(I4B), intent(in) :: icnvg !< convergence flag - logical, intent(in) :: endofperiod !< end of period logical flag + class(OutputControlType) :: this !< OutputControlType object + character(len=*), intent(in) :: cname !< character string for data name + integer(I4B), intent(in) :: icnvg !< convergence flag + logical, intent(in) :: endofperiod !< end of period logical flag ! -- local ! ! -- default is to not print iprint_flag = 0 ! ! -- if the output control file indicates that cname should be printed - if(this%oc_print(cname)) iprint_flag = 1 + if (this%oc_print(cname)) iprint_flag = 1 ! ! -- if it is not a CONTINUE run, then set to print if not converged if (isimcontinue == 0) then - if(icnvg == 0) iprint_flag = 1 + if (icnvg == 0) iprint_flag = 1 end if ! ! -- if it's the end of the period, then set flag to print - if(endofperiod) iprint_flag = 1 + if (endofperiod) iprint_flag = 1 ! ! -- Return return diff --git a/src/Utilities/OutputControl/OutputControlData.f90 b/src/Utilities/OutputControl/OutputControlData.f90 index 5837980bdbf..adbbeee0ce1 100644 --- a/src/Utilities/OutputControl/OutputControlData.f90 +++ b/src/Utilities/OutputControl/OutputControlData.f90 @@ -7,34 +7,34 @@ !! !< module OutputControlDataModule - - use BaseDisModule, only: DisBaseType - use InputOutputModule, only: print_format - use KindModule, only: DP, I4B, LGP + + use BaseDisModule, only: DisBaseType + use InputOutputModule, only: print_format + use KindModule, only: DP, I4B, LGP use PrintSaveManagerModule, only: PrintSaveManagerType - + implicit none private public OutputControlDataType, ocd_cr - + !> @ brief OutputControlDataType !! !! Object for storing information and determining whether or !! not model data should be printed to a list file or saved to disk. !< type OutputControlDataType - character(len=16), pointer :: cname => null() !< name of variable, such as HEAD - character(len=60), pointer :: cdatafmp => null() !< fortran format for printing - integer(I4B), pointer :: idataun => null() !< fortran unit number for binary output - character(len=1), pointer :: editdesc => null() !< fortran format type (I, G, F, S, E) - integer(I4B), pointer :: nvaluesp => null() !< number of values per line for printing - integer(I4B), pointer :: nwidthp => null() !< width of the number for printing - real(DP), pointer :: dnodata => null() !< no data value - integer(I4B), pointer :: inodata => null() !< integer no data value - real(DP), dimension(:), pointer, contiguous :: dblvec => null() !< pointer to double precision data array - integer(I4B), dimension(:), pointer, contiguous :: intvec => null() !< pointer to integer data array - class(DisBaseType), pointer :: dis => null() !< pointer to discretization package - type(PrintSaveManagerType), pointer :: psmobj => null() !< print/save manager object + character(len=16), pointer :: cname => null() !< name of variable, such as HEAD + character(len=60), pointer :: cdatafmp => null() !< fortran format for printing + integer(I4B), pointer :: idataun => null() !< fortran unit number for binary output + character(len=1), pointer :: editdesc => null() !< fortran format type (I, G, F, S, E) + integer(I4B), pointer :: nvaluesp => null() !< number of values per line for printing + integer(I4B), pointer :: nwidthp => null() !< width of the number for printing + real(DP), pointer :: dnodata => null() !< no data value + integer(I4B), pointer :: inodata => null() !< integer no data value + real(DP), dimension(:), pointer, contiguous :: dblvec => null() !< pointer to double precision data array + integer(I4B), dimension(:), pointer, contiguous :: intvec => null() !< pointer to integer data array + class(DisBaseType), pointer :: dis => null() !< pointer to discretization package + type(PrintSaveManagerType), pointer :: psmobj => null() !< print/save manager object contains procedure :: allocate_scalars procedure :: init_int @@ -44,9 +44,9 @@ module OutputControlDataModule procedure :: ocd_ot procedure :: ocd_da end type OutputControlDataType - - contains - + +contains + !> @ brief Create OutputControlDataType !! !! Create by allocating a new OutputControlDataType object @@ -54,10 +54,10 @@ module OutputControlDataModule !< subroutine ocd_cr(ocdobj) ! -- dummy - type(OutputControlDataType), pointer :: ocdobj !< OutputControlDataType object + type(OutputControlDataType), pointer :: ocdobj !< OutputControlDataType object ! ! -- Create the object - allocate(ocdobj) + allocate (ocdobj) ! ! -- Allocate scalars call ocdobj%allocate_scalars() @@ -65,7 +65,7 @@ subroutine ocd_cr(ocdobj) ! -- Return return end subroutine ocd_cr - + !> @ brief Check OutputControlDataType object !! !! Perform a consistency check @@ -76,28 +76,28 @@ subroutine ocd_rp_check(this, inunit) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - integer(I4B), intent(in) :: inunit !< Unit number for input + class(OutputControlDataType) :: this !< OutputControlDataType object + integer(I4B), intent(in) :: inunit !< Unit number for input ! -- locals character(len=LINELENGTH) :: errmsg ! -- formats - character(len=*), parameter :: fmtocsaveerr = & - "(1X,'REQUESTING TO SAVE ',A,' BUT ',A,' SAVE FILE NOT SPECIFIED. ', & + character(len=*), parameter :: fmtocsaveerr = & + "(1X,'REQUESTING TO SAVE ',A,' BUT ',A,' SAVE FILE NOT SPECIFIED. ', & &A,' SAVE FILE MUST BE SPECIFIED IN OUTPUT CONTROL OPTIONS.')" ! ! -- Check to make sure save file was specified - if(this%psmobj%save_detected) then - if(this%idataun == 0) then - write(errmsg, fmtocsaveerr) trim(adjustl(this%cname)), & - trim(adjustl(this%cname)), & - trim(adjustl(this%cname)) + if (this%psmobj%save_detected) then + if (this%idataun == 0) then + write (errmsg, fmtocsaveerr) trim(adjustl(this%cname)), & + trim(adjustl(this%cname)), & + trim(adjustl(this%cname)) call store_error(errmsg) - endif - endif + end if + end if ! - if(count_errors() > 0) then + if (count_errors() > 0) then call store_error_unit(inunit) - endif + end if ! ! -- return return @@ -111,13 +111,13 @@ end subroutine ocd_rp_check !< subroutine ocd_ot(this, ipflg, kstp, endofperiod, iout, iprint_opt, isav_opt) ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - integer(I4B), intent(inout) :: ipflg !< Flag indicating if something was printed - integer(I4B), intent(in) :: kstp !< Current time step - logical(LGP), intent(in) :: endofperiod !< End of period logical flag - integer(I4B), intent(in) :: iout !< Unit number for output - integer(I4B), optional, intent(in) :: iprint_opt !< Optional print flag override - integer(I4B), optional, intent(in) :: isav_opt !< Optional save flag override + class(OutputControlDataType) :: this !< OutputControlDataType object + integer(I4B), intent(inout) :: ipflg !< Flag indicating if something was printed + integer(I4B), intent(in) :: kstp !< Current time step + logical(LGP), intent(in) :: endofperiod !< End of period logical flag + integer(I4B), intent(in) :: iout !< Unit number for output + integer(I4B), optional, intent(in) :: iprint_opt !< Optional print flag override + integer(I4B), optional, intent(in) :: isav_opt !< Optional save flag override ! -- local integer(I4B) :: iprint integer(I4B) :: idataun @@ -133,39 +133,39 @@ subroutine ocd_ot(this, ipflg, kstp, endofperiod, iout, iprint_opt, isav_opt) if (iprint_opt /= 0) then iprint = 1 ipflg = 1 - endif + end if else - if(this%psmobj%kstp_to_print(kstp, endofperiod)) then + if (this%psmobj%kstp_to_print(kstp, endofperiod)) then iprint = 1 ipflg = 1 - endif - endif + end if + end if ! ! -- determine whether or not to save the array to a file if (present(isav_opt)) then if (isav_opt /= 0) then idataun = this%idataun - endif + end if else - if(this%psmobj%kstp_to_save(kstp, endofperiod)) idataun = this%idataun - endif + if (this%psmobj%kstp_to_save(kstp, endofperiod)) idataun = this%idataun + end if ! ! -- Record double precision array - if(associated(this%dblvec)) & - call this%dis%record_array(this%dblvec, iout, iprint, idataun, & - this%cname, this%cdatafmp, this%nvaluesp, & - this%nwidthp, this%editdesc, this%dnodata) + if (associated(this%dblvec)) & + call this%dis%record_array(this%dblvec, iout, iprint, idataun, & + this%cname, this%cdatafmp, this%nvaluesp, & + this%nwidthp, this%editdesc, this%dnodata) ! ! -- Record integer array (not supported yet) - !if(associated(this%intvec)) & - !call this%dis%record_array(this%intvec, iout, iprint, idataun, & - ! this%cname, this%cdatafmp, this%nvaluesp, & + !if(associated(this%intvec)) & + !call this%dis%record_array(this%intvec, iout, iprint, idataun, & + ! this%cname, this%cdatafmp, this%nvaluesp, & ! this%nwidthp, this%editdesc, this%inodata) ! ! -- Return return end subroutine ocd_ot - + !> @ brief Deallocate OutputControlDataType !! !! Deallocate members of this type @@ -177,37 +177,37 @@ subroutine ocd_da(this) ! -- dummy class(OutputControlDataType) :: this ! - ! -- deallocate - deallocate(this%cname) - deallocate(this%cdatafmp) - deallocate(this%idataun) - deallocate(this%editdesc) - deallocate(this%nvaluesp) - deallocate(this%nwidthp) - deallocate(this%dnodata) - deallocate(this%inodata) - deallocate(this%psmobj) + ! -- deallocate + deallocate (this%cname) + deallocate (this%cdatafmp) + deallocate (this%idataun) + deallocate (this%editdesc) + deallocate (this%nvaluesp) + deallocate (this%nwidthp) + deallocate (this%dnodata) + deallocate (this%inodata) + deallocate (this%psmobj) ! ! -- return return - end subroutine ocd_da - + end subroutine ocd_da + !> @ brief Initialize this OutputControlDataType as double precision data !! !! Initialize this object as a double precision data type !! !< - subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & + subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & dnodata) ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - character(len=*), intent(in) :: cname !< Name of variable - real(DP), dimension(:), pointer, contiguous, intent(in) :: dblvec !< Data array that will be managed by this object - class(DisBaseType), pointer, intent(in) :: dis !< Discretization package - character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager - character(len=*), intent(in) :: cdeffmp !< String for print format - integer(I4B), intent(in) :: iout !< Unit number for output - real(DP), intent(in) :: dnodata !< No data value + class(OutputControlDataType) :: this !< OutputControlDataType object + character(len=*), intent(in) :: cname !< Name of variable + real(DP), dimension(:), pointer, contiguous, intent(in) :: dblvec !< Data array that will be managed by this object + class(DisBaseType), pointer, intent(in) :: dis !< Discretization package + character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager + character(len=*), intent(in) :: cdeffmp !< String for print format + integer(I4B), intent(in) :: iout !< Unit number for output + real(DP), intent(in) :: dnodata !< No data value ! this%cname = cname this%dblvec => dblvec @@ -215,29 +215,29 @@ subroutine init_dbl(this, cname, dblvec, dis, cdefpsm, cdeffmp, iout, & this%dnodata = dnodata call this%psmobj%init() if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) - call print_format(cdeffmp, this%cdatafmp, & + call print_format(cdeffmp, this%cdatafmp, & this%editdesc, this%nvaluesp, this%nwidthp, 0) ! ! -- return return end subroutine init_dbl - + !> @ brief Initialize this OutputControlDataType as integer data !! !! Initialize this object as an integer data type !! !< - subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & + subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & inodata) ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - character(len=*), intent(in) :: cname !< Name of variable - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: intvec !< Data array that will be managed by this object - class(DisBaseType), pointer, intent(in) :: dis !< Discretization package - character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager - character(len=*), intent(in) :: cdeffmp !< String for print format - integer(I4B), intent(in) :: iout !< Unit number for output - integer(I4B), intent(in) :: inodata !< No data value + class(OutputControlDataType) :: this !< OutputControlDataType object + character(len=*), intent(in) :: cname !< Name of variable + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: intvec !< Data array that will be managed by this object + class(DisBaseType), pointer, intent(in) :: dis !< Discretization package + character(len=*), intent(in) :: cdefpsm !< String for defining the print/save manager + character(len=*), intent(in) :: cdeffmp !< String for print format + integer(I4B), intent(in) :: iout !< Unit number for output + integer(I4B), intent(in) :: inodata !< No data value ! this%cname = cname this%intvec => intvec @@ -246,13 +246,13 @@ subroutine init_int(this, cname, intvec, dis, cdefpsm, cdeffmp, iout, & this%editdesc = 'I' call this%psmobj%init() if (cdefpsm /= '') call this%psmobj%rp(cdefpsm, iout) - call print_format(cdeffmp, this%cdatafmp, this%editdesc, this%nvaluesp, & + call print_format(cdeffmp, this%cdatafmp, this%editdesc, this%nvaluesp, & this%nwidthp, 0) ! ! -- return return - end subroutine init_int - + end subroutine init_int + !> @ brief Allocate OutputControlDataType members !! !! Allocate and initialize member variables @@ -262,17 +262,17 @@ subroutine allocate_scalars(this) ! -- modules use ConstantsModule, only: DZERO ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object + class(OutputControlDataType) :: this !< OutputControlDataType object ! - allocate(this%cname) - allocate(this%cdatafmp) - allocate(this%idataun) - allocate(this%editdesc) - allocate(this%nvaluesp) - allocate(this%nwidthp) - allocate(this%dnodata) - allocate(this%inodata) - allocate(this%psmobj) + allocate (this%cname) + allocate (this%cdatafmp) + allocate (this%idataun) + allocate (this%editdesc) + allocate (this%nvaluesp) + allocate (this%nwidthp) + allocate (this%dnodata) + allocate (this%inodata) + allocate (this%psmobj) ! this%cname = '' this%cdatafmp = '' @@ -285,8 +285,8 @@ subroutine allocate_scalars(this) ! ! -- return return - end subroutine allocate_scalars - + end subroutine allocate_scalars + !> @ brief Set options for this object based on an input string !! !! Set FILEOUT and PRINT_FORMAT options for this object. @@ -294,47 +294,47 @@ end subroutine allocate_scalars !< subroutine set_option(this, linein, inunit, iout) ! -- modules - use ConstantsModule, only: MNORMAL + use ConstantsModule, only: MNORMAL use OpenSpecModule, only: access, form use InputOutputModule, only: urword, getunit, openfile use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(OutputControlDataType) :: this !< OutputControlDataType object - character(len=*), intent(in) :: linein !< Character string with options - integer(I4B), intent(in) :: inunit !< Unit number for input - integer(I4B), intent(in) :: iout !< Unit number for output + class(OutputControlDataType) :: this !< OutputControlDataType object + character(len=*), intent(in) :: linein !< Character string with options + integer(I4B), intent(in) :: inunit !< Unit number for input + integer(I4B), intent(in) :: iout !< Unit number for output ! -- local character(len=len(linein)) :: line integer(I4B) :: lloc, istart, istop, ival real(DP) :: rval ! -- format - character(len=*),parameter :: fmtocsave = & - "(4X,A,' INFORMATION WILL BE WRITTEN TO:', & - &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" + character(len=*), parameter :: fmtocsave = & + "(4X,A,' INFORMATION WILL BE WRITTEN TO:', & + &/,6X,'UNIT NUMBER: ', I0,/,6X, 'FILE NAME: ', A)" ! line(:) = linein(:) lloc = 1 call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('FILEOUT') + select case (line(istart:istop)) + case ('FILEOUT') call urword(line, lloc, istart, istop, 0, ival, rval, 0, 0) this%idataun = getunit() - write(iout, fmtocsave) trim(adjustl(this%cname)), this%idataun, & - line(istart:istop) - call openfile(this%idataun, iout, line(istart:istop), 'DATA(BINARY)', & + write (iout, fmtocsave) trim(adjustl(this%cname)), this%idataun, & + line(istart:istop) + call openfile(this%idataun, iout, line(istart:istop), 'DATA(BINARY)', & form, access, 'REPLACE', MNORMAL) - case('PRINT_FORMAT') + case ('PRINT_FORMAT') call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - call print_format(line(istart:), this%cdatafmp, this%editdesc, & + call print_format(line(istart:), this%cdatafmp, this%editdesc, & this%nvaluesp, this%nwidthp, inunit) case default - call store_error('Looking for FILEOUT or PRINT_FORMAT. Found:') - call store_error(trim(adjustl(line))) - call store_error_unit(inunit) + call store_error('Looking for FILEOUT or PRINT_FORMAT. Found:') + call store_error(trim(adjustl(line))) + call store_error_unit(inunit) end select ! ! -- return return - end subroutine set_option - + end subroutine set_option + end module OutputControlDataModule diff --git a/src/Utilities/OutputControl/PrintSaveManager.f90 b/src/Utilities/OutputControl/PrintSaveManager.f90 index 064a3585766..2aa1fcc811f 100644 --- a/src/Utilities/OutputControl/PrintSaveManager.f90 +++ b/src/Utilities/OutputControl/PrintSaveManager.f90 @@ -28,17 +28,17 @@ !! !< module PrintSaveManagerModule - + use KindModule, only: DP, I4B, LGP use ArrayHandlersModule, only: expandarray use SimVariablesModule, only: errmsg - use SimModule, only: store_error - use InputOutputModule, only: urword - + use SimModule, only: store_error + use InputOutputModule, only: urword + implicit none private public :: PrintSaveManagerType - + !> @ brief PrintSaveManagerType !! !! Object for storing information and determining whether or @@ -47,25 +47,25 @@ module PrintSaveManagerModule type :: PrintSaveManagerType integer(I4B), allocatable, dimension(:) :: kstp_list_print integer(I4B), allocatable, dimension(:) :: kstp_list_save - integer(I4B) :: ifreq_print - integer(I4B) :: ifreq_save - logical :: print_first - logical :: save_first - logical :: print_last - logical :: save_last - logical :: print_all - logical :: save_all - logical :: save_detected - logical :: print_detected + integer(I4B) :: ifreq_print + integer(I4B) :: ifreq_save + logical :: print_first + logical :: save_first + logical :: print_last + logical :: save_last + logical :: print_all + logical :: save_all + logical :: save_detected + logical :: print_detected contains procedure :: init procedure :: rp procedure :: kstp_to_print procedure :: kstp_to_save end type PrintSaveManagerType - - contains - + +contains + !> @ brief Initialize PrintSaveManager !! !! Initializes variables of a PrintSaveManagerType @@ -73,13 +73,13 @@ module PrintSaveManagerModule !< subroutine init(this) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object to initialize + class(PrintSaveManagerType) :: this !< psm object to initialize ! ! -- Initialize members to their defaults - if(allocated(this%kstp_list_print)) deallocate(this%kstp_list_print) - if(allocated(this%kstp_list_save)) deallocate(this%kstp_list_save) - allocate(this%kstp_list_print(0)) - allocate(this%kstp_list_save(0)) + if (allocated(this%kstp_list_print)) deallocate (this%kstp_list_print) + if (allocated(this%kstp_list_save)) deallocate (this%kstp_list_save) + allocate (this%kstp_list_print(0)) + allocate (this%kstp_list_save(0)) this%ifreq_print = 0 this%ifreq_save = 0 this%save_first = .false. @@ -94,18 +94,18 @@ subroutine init(this) ! -- return return end subroutine init - + !> @ brief Read and prepare for PrintSaveManager !! - !! Parse information in the line and assign settings for the + !! Parse information in the line and assign settings for the !! PrintSaveManagerType. !! !< subroutine rp(this, linein, iout) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object - character(len=*), intent(in) :: linein !< character line of information - integer(I4B), intent(in) :: iout !< unit number of output file + class(PrintSaveManagerType) :: this !< psm object + character(len=*), intent(in) :: linein !< character line of information + integer(I4B), intent(in) :: iout !< unit number of output file ! -- local character(len=len(linein)) :: line logical lp, ls @@ -114,9 +114,9 @@ subroutine rp(this, linein, iout) real(DP) :: rval ! -- formats character(len=*), parameter :: fmt_steps = & - "(6x,'THE FOLLOWING STEPS WILL BE ',A,': ',50(I0,' '))" + &"(6x,'THE FOLLOWING STEPS WILL BE ',A,': ',50(I0,' '))" character(len=*), parameter :: fmt_freq = & - "(6x,'THE FOLLOWING FREQUENCY WILL BE ',A,': ',I0)" + &"(6x,'THE FOLLOWING FREQUENCY WILL BE ',A,': ',I0)" ! ! -- Set the values based on line ! -- Get keyword to use in assignment @@ -127,15 +127,15 @@ subroutine rp(this, linein, iout) ! -- set dimension for print or save lp = .false. ls = .false. - select case(line(istart:istop)) - case('PRINT') + select case (line(istart:istop)) + case ('PRINT') lp = .true. - case('SAVE') + case ('SAVE') ls = .true. case default - write(errmsg, '(2a)') & - 'Looking for PRINT or SAVE. Found:', trim(adjustl(line)) - call store_error(errmsg, terminate=.TRUE.) + write (errmsg, '(2a)') & + 'Looking for PRINT or SAVE. Found:', trim(adjustl(line)) + call store_error(errmsg, terminate=.TRUE.) end select ! ! -- set member variables @@ -144,64 +144,64 @@ subroutine rp(this, linein, iout) ! ! -- set the steps to print or save call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('ALL') - if(lp) then + select case (line(istart:istop)) + case ('ALL') + if (lp) then this%print_all = .true. - if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE PRINTED' - endif - if(ls) then + if (iout > 0) write (iout, "(6x,a)") 'ALL TIME STEPS WILL BE PRINTED' + end if + if (ls) then this%save_all = .true. - if(iout > 0) write(iout,"(6x,a)") 'ALL TIME STEPS WILL BE SAVED' - endif - case('STEPS') + if (iout > 0) write (iout, "(6x,a)") 'ALL TIME STEPS WILL BE SAVED' + end if + case ('STEPS') listsearch: do call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) - if(ival > 0) then - if(lp) then + if (ival > 0) then + if (lp) then n = size(this%kstp_list_print) call expandarray(this%kstp_list_print) this%kstp_list_print(n + 1) = ival - endif - if(ls) then + end if + if (ls) then n = size(this%kstp_list_save) call expandarray(this%kstp_list_save) this%kstp_list_save(n + 1) = ival - endif + end if cycle listsearch - endif + end if exit listsearch - enddo listsearch - if(iout > 0) then - if(lp) write(iout, fmt_steps) 'PRINTED', this%kstp_list_print - if(ls) write(iout, fmt_steps) 'SAVED', this%kstp_list_save - endif - case('FREQUENCY') + end do listsearch + if (iout > 0) then + if (lp) write (iout, fmt_steps) 'PRINTED', this%kstp_list_print + if (ls) write (iout, fmt_steps) 'SAVED', this%kstp_list_save + end if + case ('FREQUENCY') call urword(line, lloc, istart, istop, 2, ival, rval, -1, 0) - if(lp) this%ifreq_print = ival - if(ls) this%ifreq_save = ival - if(iout > 0) then - if(lp) write(iout, fmt_freq) 'PRINTED', this%ifreq_print - if(ls) write(iout, fmt_freq) 'SAVED', this%ifreq_save - endif - case('FIRST') - if(lp) then + if (lp) this%ifreq_print = ival + if (ls) this%ifreq_save = ival + if (iout > 0) then + if (lp) write (iout, fmt_freq) 'PRINTED', this%ifreq_print + if (ls) write (iout, fmt_freq) 'SAVED', this%ifreq_save + end if + case ('FIRST') + if (lp) then this%print_first = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE PRINTED' - endif - if(ls) then + if (iout > 0) write (iout, "(6x,a)") 'THE FIRST TIME STEP WILL BE PRINTED' + end if + if (ls) then this%save_first = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE FIRST TIME STEP WILL BE SAVED' - endif - case('LAST') - if(lp) then + if (iout > 0) write (iout, "(6x,a)") 'THE FIRST TIME STEP WILL BE SAVED' + end if + case ('LAST') + if (lp) then this%print_last = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE PRINTED' - endif - if(ls) then + if (iout > 0) write (iout, "(6x,a)") 'THE LAST TIME STEP WILL BE PRINTED' + end if + if (ls) then this%save_last = .true. - if(iout > 0) write(iout,"(6x,a)") 'THE LAST TIME STEP WILL BE SAVED' - endif + if (iout > 0) write (iout, "(6x,a)") 'THE LAST TIME STEP WILL BE SAVED' + end if case default write (errmsg, '(2a)') & 'Looking for ALL, STEPS, FIRST, LAST, OR FREQUENCY. Found: ', & @@ -212,73 +212,73 @@ subroutine rp(this, linein, iout) ! -- return return end subroutine rp - + !> @ brief Determine if it is time to print the data !! - !! Determine if data should be printed based on kstp and endofperiod + !! Determine if data should be printed based on kstp and endofperiod !! !< logical function kstp_to_print(this, kstp, endofperiod) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object - integer(I4B), intent(in) :: kstp !< current time step - logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period + class(PrintSaveManagerType) :: this !< psm object + integer(I4B), intent(in) :: kstp !< current time step + logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period ! -- local integer(I4B) :: i, n ! kstp_to_print = .false. - if(this%print_all) kstp_to_print = .true. - if(kstp == 1 .and. this%print_first) kstp_to_print = .true. - if(endofperiod .and. this%print_last) kstp_to_print = .true. - if(this%ifreq_print > 0) then - if(mod(kstp, this%ifreq_print) == 0) kstp_to_print = .true. - endif + if (this%print_all) kstp_to_print = .true. + if (kstp == 1 .and. this%print_first) kstp_to_print = .true. + if (endofperiod .and. this%print_last) kstp_to_print = .true. + if (this%ifreq_print > 0) then + if (mod(kstp, this%ifreq_print) == 0) kstp_to_print = .true. + end if n = size(this%kstp_list_print) - if(n > 0) then + if (n > 0) then do i = 1, n - if(kstp == this%kstp_list_print(i)) then + if (kstp == this%kstp_list_print(i)) then kstp_to_print = .true. exit - endif - enddo - endif + end if + end do + end if ! ! -- Return return end function kstp_to_print - + !> @ brief Determine if it is time to save the data !! - !! Determine if data should be saved based on kstp and endofperiod + !! Determine if data should be saved based on kstp and endofperiod !! !< logical function kstp_to_save(this, kstp, endofperiod) ! -- dummy - class(PrintSaveManagerType) :: this !< psm object - integer(I4B), intent(in) :: kstp !< current time step - logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period + class(PrintSaveManagerType) :: this !< psm object + integer(I4B), intent(in) :: kstp !< current time step + logical(LGP), intent(in) :: endofperiod !< flag indicating end of stress period ! -- local integer(I4B) :: i, n ! kstp_to_save = .false. - if(this%save_all) kstp_to_save = .true. - if(kstp == 1 .and. this%save_first) kstp_to_save = .true. - if(endofperiod .and. this%save_last) kstp_to_save = .true. - if(this%ifreq_save > 0) then - if(mod(kstp, this%ifreq_save) == 0) kstp_to_save = .true. - endif + if (this%save_all) kstp_to_save = .true. + if (kstp == 1 .and. this%save_first) kstp_to_save = .true. + if (endofperiod .and. this%save_last) kstp_to_save = .true. + if (this%ifreq_save > 0) then + if (mod(kstp, this%ifreq_save) == 0) kstp_to_save = .true. + end if n = size(this%kstp_list_save) - if(n > 0) then + if (n > 0) then do i = 1, n - if(kstp == this%kstp_list_save(i)) then + if (kstp == this%kstp_list_save(i)) then kstp_to_save = .true. exit - endif - enddo - endif + end if + end do + end if ! ! -- Return return end function kstp_to_save - -end module PrintSaveManagerModule \ No newline at end of file + +end module PrintSaveManagerModule diff --git a/src/Utilities/PackageBudget.f90 b/src/Utilities/PackageBudget.f90 index e1c37a63a57..93f1f5b2c6b 100644 --- a/src/Utilities/PackageBudget.f90 +++ b/src/Utilities/PackageBudget.f90 @@ -1,44 +1,44 @@ -!> @brief This module contains the PackageBudgetModule Module +!> @brief This module contains the PackageBudgetModule Module !! !! The PackageBudgetType object defined here provides flows to the GWT !! model. The PackageBudgetType can be filled with flows from a budget -!! object that was written from a previous GWF simulation, or its +!! object that was written from a previous GWF simulation, or its !! individual members can be pointed to flows that are being calculated !! by a GWF model that is running as part of this simulation. !< module PackageBudgetModule - + use KindModule use ConstantsModule, only: LENPACKAGENAME, LENAUXNAME, LENMEMPATH - use MemoryManagerModule, only: mem_allocate, mem_reassignptr, & + use MemoryManagerModule, only: mem_allocate, mem_reassignptr, & mem_reallocate, mem_deallocate implicit none - + private public :: PackageBudgetType - - !> @brief Derived type for storing flows + + !> @brief Derived type for storing flows !! !! This derived type stores flows and provides them through the FMI - !! package to other parts of GWT. + !! package to other parts of GWT. !! !< type :: PackageBudgetType - - character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored - character(len=LENPACKAGENAME), pointer :: name => null() !< name of the package - character(len=LENPACKAGENAME), pointer :: budtxt => null() !< type of flow (CHD, RCH, RCHA, ...) - character(len=LENAUXNAME), dimension(:), pointer, & - contiguous :: auxname => null() !< vector of auxname - integer(I4B), pointer :: naux => null() !< number of auxiliary variables - integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< vector of reduced node numbers - real(DP), dimension(:), pointer, contiguous :: flow => null() !< calculated flow - real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !< auxiliary variable array - + + character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored + character(len=LENPACKAGENAME), pointer :: name => null() !< name of the package + character(len=LENPACKAGENAME), pointer :: budtxt => null() !< type of flow (CHD, RCH, RCHA, ...) + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: auxname => null() !< vector of auxname + integer(I4B), pointer :: naux => null() !< number of auxiliary variables + integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< vector of reduced node numbers + real(DP), dimension(:), pointer, contiguous :: flow => null() !< calculated flow + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< auxiliary variable array + contains - + procedure :: initialize procedure :: set_name procedure :: set_auxname @@ -46,19 +46,19 @@ module PackageBudgetModule procedure :: copy_values procedure :: get_flow procedure :: da - - end type PackageBudgetType - - contains - + + end type PackageBudgetType + +contains + !> @ brief Initialize a PackageBudgetType object !! - !! Establish the memory path and allocate and initialize member variables. + !! Establish the memory path and allocate and initialize member variables. !! !< subroutine initialize(this, mempath) - class(PackageBudgetType) :: this !< PackageBudgetType object - character(len=*), intent(in) :: mempath !< memory path in memory manager + class(PackageBudgetType) :: this !< PackageBudgetType object + character(len=*), intent(in) :: mempath !< memory path in memory manager this%memoryPath = mempath ! ! -- allocate member variables in memory manager @@ -78,50 +78,51 @@ subroutine initialize(this, mempath) this%nbound = 0 return end subroutine initialize - + !> @ brief Set names for this PackageBudgetType object !! - !! Set the name of the package and the name of the of budget text + !! Set the name of the package and the name of the of budget text !! !< subroutine set_name(this, name, budtxt) - class(PackageBudgetType) :: this !< PackageBudgetType object - character(len=LENPACKAGENAME) :: name !< name of the package (WEL-1, DRN-4, etc.) - character(len=LENPACKAGENAME) :: budtxt !< name of budget term (CHD, RCH, EVT, DRN-TO-MVR, etc.) + class(PackageBudgetType) :: this !< PackageBudgetType object + character(len=LENPACKAGENAME) :: name !< name of the package (WEL-1, DRN-4, etc.) + character(len=LENPACKAGENAME) :: budtxt !< name of budget term (CHD, RCH, EVT, DRN-TO-MVR, etc.) this%name = name this%budtxt = budtxt return end subroutine set_name - + !> @ brief Set aux names for this PackageBudgetType object !! - !! Set the number of auxiliary variables and the names of the + !! Set the number of auxiliary variables and the names of the !! auxiliary variables !! !< subroutine set_auxname(this, naux, auxname) - class(PackageBudgetType) :: this !< PackageBudgetType object - integer(I4B), intent(in) :: naux !< number of auxiliary variables + class(PackageBudgetType) :: this !< PackageBudgetType object + integer(I4B), intent(in) :: naux !< number of auxiliary variables character(len=LENAUXNAME), contiguous, & - dimension(:), intent(in) :: auxname !< array of names for auxiliary variables + dimension(:), intent(in) :: auxname !< array of names for auxiliary variables this%naux = naux - call mem_reallocate(this%auxname, LENAUXNAME, naux, 'AUXNAME', this%memoryPath) + call mem_reallocate(this%auxname, LENAUXNAME, naux, 'AUXNAME', & + this%memoryPath) this%auxname(:) = auxname(:) return end subroutine set_auxname - + !> @ brief Point members of this class to data stored in GWF packages !! - !! The routine is called when a GWF model is being run concurrently with + !! The routine is called when a GWF model is being run concurrently with !! a GWT model. In this situation, the member variables NBOUND, NODELIST, !! FLOW, and AUXVAR are pointed into member variables of the individual !! GWF Package members stored in BndType. !! !< subroutine set_pointers(this, flowvarname, mem_path_target) - class(PackageBudgetType) :: this !< PackageBudgetType object - character(len=*), intent(in) :: flowvarname !< name of variable storing flow (SIMVALS, SIMTOMVR) - character(len=*), intent(in) :: mem_path_target !< path where target variable is stored + class(PackageBudgetType) :: this !< PackageBudgetType object + character(len=*), intent(in) :: flowvarname !< name of variable storing flow (SIMVALS, SIMTOMVR) + character(len=*), intent(in) :: mem_path_target !< path where target variable is stored ! ! -- Reassign pointers to variables in the flow model call mem_reassignptr(this%nbound, 'NBOUND', this%memoryPath, & @@ -132,7 +133,7 @@ subroutine set_pointers(this, flowvarname, mem_path_target) flowvarname, mem_path_target) call mem_reassignptr(this%auxvar, 'AUXVAR', this%memoryPath, & 'AUXVAR', mem_path_target) - return + return end subroutine set_pointers !> @ brief Copy data read from a budget file into this object @@ -144,11 +145,11 @@ end subroutine set_pointers !! !< subroutine copy_values(this, nbound, nodelist, flow, auxvar) - class(PackageBudgetType) :: this !< PackageBudgetType object - integer(I4B), intent(in) :: nbound !< number of entries - integer(I4B), dimension(:), contiguous, intent(in) :: nodelist !< array of GWT node numbers - real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flow rates - real(DP), dimension(:,:), contiguous, intent(in) :: auxvar !< array of auxiliary variables + class(PackageBudgetType) :: this !< PackageBudgetType object + integer(I4B), intent(in) :: nbound !< number of entries + integer(I4B), dimension(:), contiguous, intent(in) :: nodelist !< array of GWT node numbers + real(DP), dimension(:), contiguous, intent(in) :: flow !< array of flow rates + real(DP), dimension(:, :), contiguous, intent(in) :: auxvar !< array of auxiliary variables integer(I4B) :: i ! ! -- Assign variables @@ -159,8 +160,9 @@ subroutine copy_values(this, nbound, nodelist, flow, auxvar) if (size(this%nodelist) < nbound) then call mem_reallocate(this%nodelist, nbound, 'NODELIST', this%memoryPath) call mem_reallocate(this%flow, nbound, 'FLOW', this%memoryPath) - call mem_reallocate(this%auxvar, this%naux, nbound, 'AUXVAR', this%memoryPath) - endif + call mem_reallocate(this%auxvar, this%naux, nbound, 'AUXVAR', & + this%memoryPath) + end if ! ! -- Copy values into member variables do i = 1, nbound @@ -169,20 +171,20 @@ subroutine copy_values(this, nbound, nodelist, flow, auxvar) this%auxvar(:, i) = auxvar(:, i) end do end subroutine copy_values - + !> @ brief Get flow rate for specified entry !! !! Return the flow rate for the specified entry !! !< function get_flow(this, i) result(flow) - class(PackageBudgetType) :: this !< PackageBudgetType object - integer(I4B), intent(in) :: i !< entry number + class(PackageBudgetType) :: this !< PackageBudgetType object + integer(I4B), intent(in) :: i !< entry number real(DP) :: flow flow = this%flow(i) return end function get_flow - + !> @ brief Deallocate !! !! Free any memory associated with this object @@ -200,5 +202,5 @@ subroutine da(this) call mem_deallocate(this%auxvar, 'AUXVAR', this%memoryPath) return end subroutine da - -end module PackageBudgetModule \ No newline at end of file + +end module PackageBudgetModule diff --git a/src/Utilities/Sim.f90 b/src/Utilities/Sim.f90 index 7ee1ec9458a..50fdfe1340a 100644 --- a/src/Utilities/Sim.f90 +++ b/src/Utilities/Sim.f90 @@ -2,25 +2,25 @@ !! !! This module contains simulation methods for storing warning and error !! messages and notes. This module also has methods for counting warnings, -!! errors, and notes in addition to stopping the simulation. The module does -!! not have any dependencies on models, exchanges, or solutions in a +!! errors, and notes in addition to stopping the simulation. The module does +!! not have any dependencies on models, exchanges, or solutions in a !! simulation. !! !< module SimModule - - use KindModule, only: DP, I4B - use DefinedMacros, only: get_os - use ConstantsModule, only: MAXCHARLEN, LINELENGTH, & - DONE, & - IUSTART, IULAST, & - VSUMMARY, VALL, VDEBUG, & - OSWIN, OSUNDEF - use SimVariablesModule, only: istdout, iout, isim_level, ireturnerr, & - iforcestop, iunext, & - warnmsg + + use KindModule, only: DP, I4B + use DefinedMacros, only: get_os + use ConstantsModule, only: MAXCHARLEN, LINELENGTH, & + DONE, & + IUSTART, IULAST, & + VSUMMARY, VALL, VDEBUG, & + OSWIN, OSUNDEF + use SimVariablesModule, only: istdout, iout, isim_level, ireturnerr, & + iforcestop, iunext, & + warnmsg use GenericUtilitiesModule, only: sim_message, stop_with_error - use MessageModule, only: MessageType + use MessageModule, only: MessageType implicit none @@ -40,567 +40,567 @@ module SimModule public :: store_error_unit public :: store_error_filename public :: MaxErrors - + type(MessageType) :: sim_errors type(MessageType) :: sim_uniterrors type(MessageType) :: sim_warnings type(MessageType) :: sim_notes - contains +contains - !> @brief Return number of errors + !> @brief Return number of errors !! !! Function to return the number of errors messages that have been stored. !! !! @return ncount number of error messages stored !! - !< - function count_errors() result(ncount) - ! -- return variable - integer(I4B) :: ncount - ! - ! -- set ncount - ncount = sim_errors%count_message() - ! - ! -- return - return - end function count_errors + !< + function count_errors() result(ncount) + ! -- return variable + integer(I4B) :: ncount + ! + ! -- set ncount + ncount = sim_errors%count_message() + ! + ! -- return + return + end function count_errors - !> @brief Return number of warnings + !> @brief Return number of warnings !! !! Function to return the number of warning messages that have been stored. !! !! @return ncount number of warning messages stored !! - !< - function count_warnings() result(ncount) - ! -- return variable - integer(I4B) :: ncount - ! - ! -- set ncount - ncount = sim_warnings%count_message() - ! - ! -- return - return - end function count_warnings + !< + function count_warnings() result(ncount) + ! -- return variable + integer(I4B) :: ncount + ! + ! -- set ncount + ncount = sim_warnings%count_message() + ! + ! -- return + return + end function count_warnings - !> @brief Return number of notes + !> @brief Return number of notes !! !! Function to return the number of notes that have been stored. !! !! @return ncount number of notes stored !! - !< - function count_notes() result(ncount) - ! -- return variable - integer(I4B) :: ncount - ! - ! -- set ncount - ncount = sim_notes%count_message() - ! - ! -- return - return - end function count_notes + !< + function count_notes() result(ncount) + ! -- return variable + integer(I4B) :: ncount + ! + ! -- set ncount + ncount = sim_notes%count_message() + ! + ! -- return + return + end function count_notes - !> @brief Set the maximum number of errors stored + !> @brief Set the maximum number of errors stored !! !! Subroutine to set the maximum number of error messages that will be stored !! in a simulation. !! - !< - subroutine MaxErrors(imax) - ! -- dummy variables - integer(I4B), intent(in) :: imax !< maximum number of error messages that will be stored - ! - ! -- set the maximum number of error messages that will be saved - call sim_errors%set_max_message(imax) - ! - ! -- return - return - end subroutine MaxErrors + !< + subroutine MaxErrors(imax) + ! -- dummy variables + integer(I4B), intent(in) :: imax !< maximum number of error messages that will be stored + ! + ! -- set the maximum number of error messages that will be saved + call sim_errors%set_max_message(imax) + ! + ! -- return + return + end subroutine MaxErrors - !> @brief Store error message + !> @brief Store error message !! !! Subroutine to store a error message for printing at the end of !! the simulation. !! - !< - subroutine store_error(msg, terminate) - ! -- dummy variable - character(len=*), intent(in) :: msg !< error message - logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated - ! -- local variables - logical :: lterminate - ! - ! -- process optional variables - if (present(terminate)) then - lterminate = terminate - else - lterminate = .FALSE. - end if - ! - ! -- store error - call sim_errors%store_message(msg) - ! - ! -- terminate the simulation - if (lterminate) then - call ustop() - end if - ! - ! -- return - return - end subroutine store_error + !< + subroutine store_error(msg, terminate) + ! -- dummy variable + character(len=*), intent(in) :: msg !< error message + logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated + ! -- local variables + logical :: lterminate + ! + ! -- process optional variables + if (present(terminate)) then + lterminate = terminate + else + lterminate = .FALSE. + end if + ! + ! -- store error + call sim_errors%store_message(msg) + ! + ! -- terminate the simulation + if (lterminate) then + call ustop() + end if + ! + ! -- return + return + end subroutine store_error - !> @brief Get the file name + !> @brief Get the file name !! !! Subroutine to get the file name from the unit number for a open file. - !! If the INQUIRE function returns the full path (for example, the INTEL - !! compiler) then the returned file name (fname) is limited to the filename + !! If the INQUIRE function returns the full path (for example, the INTEL + !! compiler) then the returned file name (fname) is limited to the filename !! without the path. !! - !< - subroutine get_filename(iunit, fname) - ! -- dummy variables - integer(I4B), intent(in) :: iunit !< open file unit number - character(len=*), intent(inout) :: fname !< file name attached to the open file unit number - ! -- local variables - integer(I4B) :: ipos - integer(I4B) :: ios - integer(I4B) :: ilen - ! - ! -- get file name from unit number - inquire(unit=iunit, name=fname) - ! - ! -- determine the operating system - ios = get_os() - ! - ! -- extract filename from full path, if present - ! forward slash on linux, unix, and osx - if (ios /= OSWIN) then - ipos = index(fname, '/', back=.TRUE.) - end if - ! - ! -- check for backslash on windows or undefined os and - ! forward slashes were not found - if (ios == OSWIN .or. ios == OSUNDEF) then - if (ipos < 1) then - ipos = index(fname, '\', back=.TRUE.) - end if - end if - ! - ! -- exclude the path from the file name - if (ipos > 0) then - ilen = len_trim(fname) - write(fname, '(a)') fname(ipos+1:ilen) // ' ' + !< + subroutine get_filename(iunit, fname) + ! -- dummy variables + integer(I4B), intent(in) :: iunit !< open file unit number + character(len=*), intent(inout) :: fname !< file name attached to the open file unit number + ! -- local variables + integer(I4B) :: ipos + integer(I4B) :: ios + integer(I4B) :: ilen + ! + ! -- get file name from unit number + inquire (unit=iunit, name=fname) + ! + ! -- determine the operating system + ios = get_os() + ! + ! -- extract filename from full path, if present + ! forward slash on linux, unix, and osx + if (ios /= OSWIN) then + ipos = index(fname, '/', back=.TRUE.) + end if + ! + ! -- check for backslash on windows or undefined os and + ! forward slashes were not found + if (ios == OSWIN .or. ios == OSUNDEF) then + if (ipos < 1) then + ipos = index(fname, '\', back=.TRUE.) end if - ! - ! -- return - return - end subroutine get_filename + end if + ! + ! -- exclude the path from the file name + if (ipos > 0) then + ilen = len_trim(fname) + write (fname, '(a)') fname(ipos + 1:ilen)//' ' + end if + ! + ! -- return + return + end subroutine get_filename - !> @brief Store the file unit number + !> @brief Store the file unit number !! !! Subroutine to convert the unit number for a open file to a file name !! and indicate that there is an error reading from the file. By default, !! the simulation is terminated when this subroutine is called. !! - !< - subroutine store_error_unit(iunit, terminate) - ! -- dummy variables - integer(I4B), intent(in) :: iunit !< open file unit number - logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated - ! -- local variables - logical :: lterminate - character(len=LINELENGTH) :: fname - character(len=LINELENGTH) :: errmsg - ! - ! -- process optional variables - if (present(terminate)) then - lterminate = terminate - else - lterminate = .TRUE. - end if - ! - ! -- store error unit - inquire(unit=iunit, name=fname) - write(errmsg,'(3a)') & - "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(fname)), "'" - call sim_uniterrors%store_message(errmsg) - ! - ! -- terminate the simulation - if (lterminate) then - call ustop() - end if - ! - ! -- return - return - end subroutine store_error_unit + !< + subroutine store_error_unit(iunit, terminate) + ! -- dummy variables + integer(I4B), intent(in) :: iunit !< open file unit number + logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated + ! -- local variables + logical :: lterminate + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: errmsg + ! + ! -- process optional variables + if (present(terminate)) then + lterminate = terminate + else + lterminate = .TRUE. + end if + ! + ! -- store error unit + inquire (unit=iunit, name=fname) + write (errmsg, '(3a)') & + "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(fname)), "'" + call sim_uniterrors%store_message(errmsg) + ! + ! -- terminate the simulation + if (lterminate) then + call ustop() + end if + ! + ! -- return + return + end subroutine store_error_unit - !> @brief Store the erroring file name + !> @brief Store the erroring file name !! !! Subroutine to store the file name issuing an error. By default, !! the simulation is terminated when this subroutine is called !! - !< - subroutine store_error_filename(filename, terminate) - ! -- dummy variables - character(len=*), intent(in) :: filename !< erroring file name - logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated - ! -- local variables - logical :: lterminate - character(len=LINELENGTH) :: errmsg - ! - ! -- process optional variables - if (present(terminate)) then - lterminate = terminate - else - lterminate = .TRUE. - end if - ! - ! -- store error unit - write(errmsg,'(3a)') & - "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(filename)), "'" - call sim_uniterrors%store_message(errmsg) - ! - ! -- terminate the simulation - if (lterminate) then - call ustop() - end if - ! - ! -- return - return - end subroutine store_error_filename + !< + subroutine store_error_filename(filename, terminate) + ! -- dummy variables + character(len=*), intent(in) :: filename !< erroring file name + logical, optional, intent(in) :: terminate !< boolean indicating if the simulation should be terminated + ! -- local variables + logical :: lterminate + character(len=LINELENGTH) :: errmsg + ! + ! -- process optional variables + if (present(terminate)) then + lterminate = terminate + else + lterminate = .TRUE. + end if + ! + ! -- store error unit + write (errmsg, '(3a)') & + "ERROR OCCURRED WHILE READING FILE '", trim(adjustl(filename)), "'" + call sim_uniterrors%store_message(errmsg) + ! + ! -- terminate the simulation + if (lterminate) then + call ustop() + end if + ! + ! -- return + return + end subroutine store_error_filename - !> @brief Store warning message + !> @brief Store warning message !! !! Subroutine to store a warning message for printing at the end of !! the simulation. !! - !< - subroutine store_warning(msg, substring) - ! -- dummy variables - character(len=*), intent(in) :: msg !< warning message - character(len=*), intent(in), optional :: substring !< optional string that can be used - !! to prevent storing duplicate messages - ! - ! -- store warning - if (present(substring)) then - call sim_warnings%store_message(msg, substring) - else - call sim_warnings%store_message(msg) - end if - ! - ! -- return - return - end subroutine store_warning + !< + subroutine store_warning(msg, substring) + ! -- dummy variables + character(len=*), intent(in) :: msg !< warning message + character(len=*), intent(in), optional :: substring !< optional string that can be used + !! to prevent storing duplicate messages + ! + ! -- store warning + if (present(substring)) then + call sim_warnings%store_message(msg, substring) + else + call sim_warnings%store_message(msg) + end if + ! + ! -- return + return + end subroutine store_warning - !> @brief Store deprecation warning message + !> @brief Store deprecation warning message !! - !! Subroutine to store a warning message for deprecated variables + !! Subroutine to store a warning message for deprecated variables !! and printing at the end of simulation. !! - !< - subroutine deprecation_warning(cblock, cvar, cver, endmsg, iunit) - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy variables - character(len=*), intent(in) :: cblock !< block name - character(len=*), intent(in) :: cvar !< variable name - character(len=*), intent(in) :: cver !< version when variable was deprecated - character(len=*), intent(in), optional :: endmsg !< optional user defined message to append - !! at the end of the deprecation warning - integer(I4B), intent(in), optional :: iunit !< optional input file unit number with - !! the deprecated variable - ! -- local variables - character(len=MAXCHARLEN) :: message - character(len=LINELENGTH) :: fname - ! - ! -- build message - write(message,'(a)') & - trim(cblock) // " BLOCK VARIABLE '" // trim(cvar) // "'" - if (present(iunit)) then - call get_filename(iunit, fname) - write(message,'(a,1x,3a)') & - trim(message), "IN FILE '", trim(fname), "'" - end if - write(message,'(a)') & - trim(message) // ' WAS DEPRECATED IN VERSION ' // trim(cver) // '.' - if (present(endmsg)) then - write(message,'(a,1x,2a)') trim(message), trim(endmsg), '.' - end if - ! - ! -- store warning - call sim_warnings%store_message(message) - ! - ! -- return - return - end subroutine deprecation_warning + !< + subroutine deprecation_warning(cblock, cvar, cver, endmsg, iunit) + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy variables + character(len=*), intent(in) :: cblock !< block name + character(len=*), intent(in) :: cvar !< variable name + character(len=*), intent(in) :: cver !< version when variable was deprecated + character(len=*), intent(in), optional :: endmsg !< optional user defined message to append + !! at the end of the deprecation warning + integer(I4B), intent(in), optional :: iunit !< optional input file unit number with + !! the deprecated variable + ! -- local variables + character(len=MAXCHARLEN) :: message + character(len=LINELENGTH) :: fname + ! + ! -- build message + write (message, '(a)') & + trim(cblock)//" BLOCK VARIABLE '"//trim(cvar)//"'" + if (present(iunit)) then + call get_filename(iunit, fname) + write (message, '(a,1x,3a)') & + trim(message), "IN FILE '", trim(fname), "'" + end if + write (message, '(a)') & + trim(message)//' WAS DEPRECATED IN VERSION '//trim(cver)//'.' + if (present(endmsg)) then + write (message, '(a,1x,2a)') trim(message), trim(endmsg), '.' + end if + ! + ! -- store warning + call sim_warnings%store_message(message) + ! + ! -- return + return + end subroutine deprecation_warning - !> @brief Store note + !> @brief Store note !! !! Subroutine to store a note for printing at the end of the simulation. !! - !< - subroutine store_note(note) - ! -- modules - use ArrayHandlersModule, only: ExpandArray - ! -- dummy variables - character(len=*), intent(in) :: note !< note - ! - ! -- store note - call sim_notes%store_message(note) - ! - ! -- return - return - end subroutine store_note + !< + subroutine store_note(note) + ! -- modules + use ArrayHandlersModule, only: ExpandArray + ! -- dummy variables + character(len=*), intent(in) :: note !< note + ! + ! -- store note + call sim_notes%store_message(note) + ! + ! -- return + return + end subroutine store_note - !> @brief Stop the simulation. + !> @brief Stop the simulation. !! - !! Subroutine to stop the simulations with option to print message + !! Subroutine to stop the simulations with option to print message !! before stopping with the active error code. !! - !< - subroutine ustop(stopmess, ioutlocal) - ! -- dummy variables - character, optional, intent(in) :: stopmess*(*) !< optional message to print before - !! stopping the simulation - integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to - !! final message to - ! - ! -- print the final message - call print_final_message(stopmess, ioutlocal) - ! - ! -- return appropriate error codes when terminating the program - call stop_with_error(ireturnerr) - - end subroutine ustop + !< + subroutine ustop(stopmess, ioutlocal) + ! -- dummy variables + character, optional, intent(in) :: stopmess * (*) !< optional message to print before + !! stopping the simulation + integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to + !! final message to + ! + ! -- print the final message + call print_final_message(stopmess, ioutlocal) + ! + ! -- return appropriate error codes when terminating the program + call stop_with_error(ireturnerr) - !> @brief Print the final messages + end subroutine ustop + + !> @brief Print the final messages !! - !! Subroutine to print the notes, warnings, errors and the final message (if passed). + !! Subroutine to print the notes, warnings, errors and the final message (if passed). !! The subroutine also closes all open files. !! - !< - subroutine print_final_message(stopmess, ioutlocal) - ! -- dummy variables - character, optional, intent(in) :: stopmess*(*) !< optional message to print before - !! stopping the simulation - integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to - !! final message to - ! -- local variables - character(len=*), parameter :: fmt = '(1x,a)' - character(len=*), parameter :: msg = 'Stopping due to error(s)' - ! - ! -- print the accumulated messages - call sim_notes%print_message('NOTES:', 'note(s)', & - iunit=iout, level=VALL) - call sim_warnings%print_message('WARNING REPORT:', 'warning(s)', & - iunit=iout, level=VALL) - call sim_errors%print_message('ERROR REPORT:', 'error(s)', iunit=iout) - call sim_uniterrors%print_message('UNIT ERROR REPORT:', & - 'file unit error(s)', iunit=iout) - ! - ! -- write a stop message, if one is passed - if (present(stopmess)) then - if (stopmess.ne.' ') then - call sim_message(stopmess, fmt=fmt, iunit=iout) - call sim_message(stopmess, fmt=fmt) - if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal /= iout) then - write(ioutlocal,fmt) trim(stopmess) - close (ioutlocal) - endif - endif - endif - endif - ! - ! -- determine if an error condition has occurred - if (sim_errors%count_message() > 0) then - ireturnerr = 2 + !< + subroutine print_final_message(stopmess, ioutlocal) + ! -- dummy variables + character, optional, intent(in) :: stopmess * (*) !< optional message to print before + !! stopping the simulation + integer(I4B), optional, intent(in) :: ioutlocal !< optional output file to + !! final message to + ! -- local variables + character(len=*), parameter :: fmt = '(1x,a)' + character(len=*), parameter :: msg = 'Stopping due to error(s)' + ! + ! -- print the accumulated messages + call sim_notes%print_message('NOTES:', 'note(s)', & + iunit=iout, level=VALL) + call sim_warnings%print_message('WARNING REPORT:', 'warning(s)', & + iunit=iout, level=VALL) + call sim_errors%print_message('ERROR REPORT:', 'error(s)', iunit=iout) + call sim_uniterrors%print_message('UNIT ERROR REPORT:', & + 'file unit error(s)', iunit=iout) + ! + ! -- write a stop message, if one is passed + if (present(stopmess)) then + if (stopmess .ne. ' ') then + call sim_message(stopmess, fmt=fmt, iunit=iout) + call sim_message(stopmess, fmt=fmt) if (present(ioutlocal)) then - if (ioutlocal > 0 .and. ioutlocal /= iout) write(ioutlocal,fmt) msg - endif - endif - ! - ! -- close all open files - call sim_closefiles() - ! - ! -- return - return - end subroutine print_final_message + if (ioutlocal > 0 .and. ioutlocal /= iout) then + write (ioutlocal, fmt) trim(stopmess) + close (ioutlocal) + end if + end if + end if + end if + ! + ! -- determine if an error condition has occurred + if (sim_errors%count_message() > 0) then + ireturnerr = 2 + if (present(ioutlocal)) then + if (ioutlocal > 0 .and. ioutlocal /= iout) write (ioutlocal, fmt) msg + end if + end if + ! + ! -- close all open files + call sim_closefiles() + ! + ! -- return + return + end subroutine print_final_message - !> @brief Reset the simulation convergence flag + !> @brief Reset the simulation convergence flag !! !! Subroutine to reset the simulation convergence flag. !! - !< - subroutine converge_reset() - ! -- modules - use SimVariablesModule, only: isimcnvg - ! - ! -- reset simulation convergence flag - isimcnvg = 1 - ! - ! -- return - return - end subroutine converge_reset + !< + subroutine converge_reset() + ! -- modules + use SimVariablesModule, only: isimcnvg + ! + ! -- reset simulation convergence flag + isimcnvg = 1 + ! + ! -- return + return + end subroutine converge_reset - !> @brief Simulation convergence check + !> @brief Simulation convergence check !! !! Subroutine to check simulation convergence. If the continue option is !! set the simulation convergence flag is set to True if the simulation !! did not actually converge for a time step and the non-convergence counter !! is incremented. !! - !< - subroutine converge_check(hasConverged) - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue - ! -- dummy variables - logical, intent(inout) :: hasConverged !< boolean indicting if the - !! simulation is considered converged - ! -- format - character(len=*), parameter :: fmtfail = & - "(1x, 'Simulation convergence failure.', & - &' Simulation will terminate after output and deallocation.')" - ! - ! -- Initialize hasConverged to True - hasConverged = .true. - ! - ! -- Count number of failures - if(isimcnvg == 0) then - numnoconverge = numnoconverge + 1 + !< + subroutine converge_check(hasConverged) + ! -- modules + use SimVariablesModule, only: isimcnvg, numnoconverge, isimcontinue + ! -- dummy variables + logical, intent(inout) :: hasConverged !< boolean indicting if the + !! simulation is considered converged + ! -- format + character(len=*), parameter :: fmtfail = & + "(1x, 'Simulation convergence failure.', & + &' Simulation will terminate after output and deallocation.')" + ! + ! -- Initialize hasConverged to True + hasConverged = .true. + ! + ! -- Count number of failures + if (isimcnvg == 0) then + numnoconverge = numnoconverge + 1 + end if + ! + ! -- Continue if 'CONTINUE' specified in simulation control file + if (isimcontinue == 1) then + if (isimcnvg == 0) then + isimcnvg = 1 end if - ! - ! -- Continue if 'CONTINUE' specified in simulation control file - if(isimcontinue == 1) then - if(isimcnvg == 0) then - isimcnvg = 1 - endif - endif - ! - ! -- save simulation failure message - if(isimcnvg == 0) then - call sim_message('', fmt=fmtfail, iunit=iout) - hasConverged = .false. - endif - ! - ! -- return - return - end subroutine converge_check + end if + ! + ! -- save simulation failure message + if (isimcnvg == 0) then + call sim_message('', fmt=fmtfail, iunit=iout) + hasConverged = .false. + end if + ! + ! -- return + return + end subroutine converge_check - !> @brief Print the header and initializes messaging - !! - !! Subroutine that prints the initial message and initializes the notes, - !! warning messages, unit errors, and error messages. - !! - !< - subroutine initial_message() - ! -- modules - use VersionModule, only: write_listfile_header - ! - ! -- initialize message lists - call sim_errors%init_message() - call sim_uniterrors%init_message() - call sim_warnings%init_message() - call sim_notes%init_message() - ! - ! -- Write banner to screen (unit stdout) - call write_listfile_header(istdout, write_kind_info=.false., & - write_sys_command=.false.) - ! - end subroutine initial_message + !> @brief Print the header and initializes messaging + !! + !! Subroutine that prints the initial message and initializes the notes, + !! warning messages, unit errors, and error messages. + !! + !< + subroutine initial_message() + ! -- modules + use VersionModule, only: write_listfile_header + ! + ! -- initialize message lists + call sim_errors%init_message() + call sim_uniterrors%init_message() + call sim_warnings%init_message() + call sim_notes%init_message() + ! + ! -- Write banner to screen (unit stdout) + call write_listfile_header(istdout, write_kind_info=.false., & + write_sys_command=.false.) + ! + end subroutine initial_message - !> @brief Create final message - !! - !! Subroutine that creates the appropriate final message and - !! terminates the program with an error message, if necessary. - !! - !< - subroutine final_message() - ! -- modules - use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr, & - isimcontinue - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" - ! - ! -- Write message if nonconvergence occured in at least one timestep - if(numnoconverge > 0) then - write(warnmsg, fmtnocnvg) numnoconverge - if (isimcontinue == 0) then - call sim_errors%store_message(warnmsg) - else - call sim_warnings%store_message(warnmsg) - end if - endif - ! - ! -- write final message - if(isimcnvg == 0) then - call print_final_message('Premature termination of simulation.', iout) + !> @brief Create final message + !! + !! Subroutine that creates the appropriate final message and + !! terminates the program with an error message, if necessary. + !! + !< + subroutine final_message() + ! -- modules + use SimVariablesModule, only: isimcnvg, numnoconverge, ireturnerr, & + isimcontinue + ! -- formats + character(len=*), parameter :: fmtnocnvg = & + &"(1x, 'Simulation convergence failure occurred ', i0, ' time(s).')" + ! + ! -- Write message if nonconvergence occured in at least one timestep + if (numnoconverge > 0) then + write (warnmsg, fmtnocnvg) numnoconverge + if (isimcontinue == 0) then + call sim_errors%store_message(warnmsg) else - call print_final_message('Normal termination of simulation.', iout) - endif - ! - ! -- If the simulation did not converge and the continue - ! option was not set, then set the return code to 1. The - ! purpose of setting the returncode this way is that the - ! program will terminate without a stop code if the simulation - ! reached the end and the continue flag was set, even if the - ! the simulation did not converge. - if (isimcnvg == 0 .and. isimcontinue == 0) then - ireturnerr = 1 + call sim_warnings%store_message(warnmsg) end if - ! - ! -- destroy messages - call sim_errors%deallocate_message() - call sim_uniterrors%deallocate_message() - call sim_warnings%deallocate_message() - call sim_notes%deallocate_message() - ! - ! -- return or halt - if (iforcestop == 1) then - call stop_with_error(ireturnerr) + end if + ! + ! -- write final message + if (isimcnvg == 0) then + call print_final_message('Premature termination of simulation.', iout) + else + call print_final_message('Normal termination of simulation.', iout) + end if + ! + ! -- If the simulation did not converge and the continue + ! option was not set, then set the return code to 1. The + ! purpose of setting the returncode this way is that the + ! program will terminate without a stop code if the simulation + ! reached the end and the continue flag was set, even if the + ! the simulation did not converge. + if (isimcnvg == 0 .and. isimcontinue == 0) then + ireturnerr = 1 + end if + ! + ! -- destroy messages + call sim_errors%deallocate_message() + call sim_uniterrors%deallocate_message() + call sim_warnings%deallocate_message() + call sim_notes%deallocate_message() + ! + ! -- return or halt + if (iforcestop == 1) then + call stop_with_error(ireturnerr) + end if + + end subroutine final_message + + !> @brief Close all open files + !! + !! Subroutine that closes all open files at the end of the simulation. + !! + !< + subroutine sim_closefiles() + ! -- modules + ! -- dummy + ! -- local variables + integer(I4B) :: i + logical :: opened + character(len=7) :: output_file + ! + ! -- close all open file units + do i = iustart, iunext - 1 + ! + ! -- determine if file unit i is open + inquire (unit=i, opened=opened) + ! + ! -- skip file units that are no longer open + if (.not. opened) then + cycle end if - - end subroutine final_message - - !> @brief Close all open files - !! - !! Subroutine that closes all open files at the end of the simulation. - !! - !< - subroutine sim_closefiles() - ! -- modules - ! -- dummy - ! -- local variables - integer(I4B) :: i - logical :: opened - character(len=7) :: output_file ! - ! -- close all open file units - do i = iustart, iunext - 1 - ! - ! -- determine if file unit i is open - inquire(unit=i, opened=opened) - ! - ! -- skip file units that are no longer open - if(.not. opened) then - cycle - end if - ! - ! -- flush the file if it can be written to - inquire(unit=i, write=output_file) - if (trim(adjustl(output_file)) == 'YES') then - flush(i) - end if - ! - ! -- close file unit i - close(i) - end do + ! -- flush the file if it can be written to + inquire (unit=i, write=output_file) + if (trim(adjustl(output_file)) == 'YES') then + flush (i) + end if ! - ! -- return - return - end subroutine sim_closefiles - + ! -- close file unit i + close (i) + end do + ! + ! -- return + return + end subroutine sim_closefiles + end module SimModule diff --git a/src/Utilities/SimVariables.f90 b/src/Utilities/SimVariables.f90 index 82b4f55a8bc..a86853f27c5 100644 --- a/src/Utilities/SimVariables.f90 +++ b/src/Utilities/SimVariables.f90 @@ -11,22 +11,22 @@ module SimVariablesModule use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, MAXCHARLEN, IUSTART, VALL, MNORMAL public - character(len=LINELENGTH) :: simfile = 'mfsim.nam' !< simulation name file - character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' !< simulation listing file name - character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' !< name of standard out file if screen output is piped to a file - character(len=MAXCHARLEN) :: errmsg !< error message string - character(len=MAXCHARLEN) :: warnmsg !< warning message string - integer(I4B) :: istdout = output_unit !< unit number for stdout - integer(I4B) :: isim_level = VALL !< simulation output level - integer(I4B) :: isim_mode = MNORMAL !< simulation mode - integer(I4B) :: iout !< file unit number for simulation output - integer(I4B) :: isimcnvg !< simulation convergence flag (1) if all objects have converged, (0) otherwise - integer(I4B) :: isimcontinue = 0 !< simulation continue flag (1) to continue if isimcnvg = 0, (0) to terminate - integer(I4B) :: isimcheck = 1 !< simulation input check flag (1) to check input, (0) to ignore checks - integer(I4B) :: numnoconverge = 0 !< number of times the simulation did not converge - integer(I4B) :: ireturnerr = 0 !< return code for program (0) successful, (1) non-convergence, (2) error - integer(I4B) :: iforcestop = 1 !< forced stop flag (1) forces a call to ustop(..) when the simulation has ended, (0) doesn't - integer(I4B) :: iunext = IUSTART !< next file unit number to assign - integer(I4B) :: lastStepFailed = 0 !< flag indicating if the last step failed (1) if last step failed; (0) otherwise (set in converge_check) - integer(I4B) :: iFailedStepRetry = 0 !< current retry for this time step + character(len=LINELENGTH) :: simfile = 'mfsim.nam' !< simulation name file + character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' !< simulation listing file name + character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' !< name of standard out file if screen output is piped to a file + character(len=MAXCHARLEN) :: errmsg !< error message string + character(len=MAXCHARLEN) :: warnmsg !< warning message string + integer(I4B) :: istdout = output_unit !< unit number for stdout + integer(I4B) :: isim_level = VALL !< simulation output level + integer(I4B) :: isim_mode = MNORMAL !< simulation mode + integer(I4B) :: iout !< file unit number for simulation output + integer(I4B) :: isimcnvg !< simulation convergence flag (1) if all objects have converged, (0) otherwise + integer(I4B) :: isimcontinue = 0 !< simulation continue flag (1) to continue if isimcnvg = 0, (0) to terminate + integer(I4B) :: isimcheck = 1 !< simulation input check flag (1) to check input, (0) to ignore checks + integer(I4B) :: numnoconverge = 0 !< number of times the simulation did not converge + integer(I4B) :: ireturnerr = 0 !< return code for program (0) successful, (1) non-convergence, (2) error + integer(I4B) :: iforcestop = 1 !< forced stop flag (1) forces a call to ustop(..) when the simulation has ended, (0) doesn't + integer(I4B) :: iunext = IUSTART !< next file unit number to assign + integer(I4B) :: lastStepFailed = 0 !< flag indicating if the last step failed (1) if last step failed; (0) otherwise (set in converge_check) + integer(I4B) :: iFailedStepRetry = 0 !< current retry for this time step end module SimVariablesModule diff --git a/src/Utilities/SmoothingFunctions.f90 b/src/Utilities/SmoothingFunctions.f90 index 12ae5ad60f4..c821e14c67d 100644 --- a/src/Utilities/SmoothingFunctions.f90 +++ b/src/Utilities/SmoothingFunctions.f90 @@ -1,17 +1,17 @@ module SmoothingModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, & - & DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM8, DEM14 + use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR, & + DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM8, DEM14 implicit none - - contains - - subroutine sSCurve(x,range,dydx,y) + +contains + + subroutine sSCurve(x, range, dydx, y) ! ****************************************************************************** ! COMPUTES THE S CURVE FOR SMOOTH DERIVATIVES BETWEEN X=0 AND X=1 ! FROM mfusg smooth SUBROUTINE in gwf2wel7u1.f ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(in) :: x @@ -25,28 +25,28 @@ subroutine sSCurve(x,range,dydx,y) ! code ! s = range - if ( s < DPREC ) s = DPREC + if (s < DPREC) s = DPREC xs = x / s if (xs < DZERO) xs = DZERO if (xs <= DZERO) then y = DZERO dydx = DZERO - elseif(xs < DONE)then + elseif (xs < DONE) then y = -DTWO * xs**DTHREE + DTHREE * xs**DTWO dydx = -DSIX * xs**DTWO + DSIX * xs else y = DONE dydx = DZERO - endif + end if return end subroutine sSCurve - - subroutine sCubicLinear(x,range,dydx,y) + + subroutine sCubicLinear(x, range, dydx, y) ! ****************************************************************************** ! COMPUTES THE S CURVE WHERE DY/DX = 0 at X=0; AND DY/DX = 1 AT X=1. ! Smooths from zero to a slope of 1. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(in) :: x @@ -60,27 +60,27 @@ subroutine sCubicLinear(x,range,dydx,y) ! code ! s = range - if ( s < DPREC ) s = DPREC + if (s < DPREC) s = DPREC xs = x / s if (xs < DZERO) xs = DZERO if (xs <= DZERO) then y = DZERO dydx = DZERO - elseif(xs < DONE)then + elseif (xs < DONE) then y = -DONE * xs**DTHREE + DTWO * xs**DTWO dydx = -DTHREE * xs**DTWO + DFOUR * xs else y = DONE dydx = DZERO - endif + end if return end subroutine sCubicLinear - subroutine sCubic(x,range,dydx,y) + subroutine sCubic(x, range, dydx, y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; cubic function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(inout) :: x @@ -95,31 +95,31 @@ subroutine sCubic(x,range,dydx,y) ! dydx = DZERO y = DZERO - if ( range < DPREC ) range = DPREC - if ( x < DPREC ) x = DPREC + if (range < DPREC) range = DPREC + if (x < DPREC) x = DPREC s = range - aa = -DSIX/(s**DTHREE) - bb = -DSIX/(s**DTWO) + aa = -DSIX / (s**DTHREE) + bb = -DSIX / (s**DTWO) cof1 = x**DTWO - cof2 = -(DTWO*x)/(s**DTHREE) - cof3 = DTHREE/(s**DTWO) + cof2 = -(DTWO * x) / (s**DTHREE) + cof3 = DTHREE / (s**DTWO) y = cof1 * (cof2 + cof3) - dydx = (aa*x**DTWO - bb*x) - if ( x <= DZERO ) then + dydx = (aa * x**DTWO - bb * x) + if (x <= DZERO) then y = DZERO dydx = DZERO - else if ( (x - s) > -DPREC ) then + else if ((x - s) > -DPREC) then y = DONE dydx = DZERO end if return end subroutine sCubic - - subroutine sLinear(x,range,dydx,y) + + subroutine sLinear(x, range, dydx, y) ! ****************************************************************************** ! Linear smoothing function returns value between 0-1 ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(inout) :: x @@ -133,23 +133,23 @@ subroutine sLinear(x,range,dydx,y) ! dydx = DZERO y = DZERO - if ( range < DPREC ) range = DPREC - if ( x < DPREC ) x = DPREC + if (range < DPREC) range = DPREC + if (x < DPREC) x = DPREC s = range - y = DONE - (s - x)/s - dydx = DONE/s - if ( y > DONE ) then + y = DONE - (s - x) / s + dydx = DONE / s + if (y > DONE) then y = DONE dydx = DZERO end if return end subroutine sLinear - - subroutine sQuadratic(x,range,dydx,y) + + subroutine sQuadratic(x, range, dydx, y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; quadratic function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(inout) :: x @@ -163,12 +163,12 @@ subroutine sQuadratic(x,range,dydx,y) ! dydx = DZERO y = DZERO - if ( range < DPREC ) range = DPREC - if ( x < DPREC ) x = DPREC + if (range < DPREC) range = DPREC + if (x < DPREC) x = DPREC s = range y = (x**DTWO) / (s**DTWO) - dydx = DTWO*x/(s**DTWO) - if ( y > DONE ) then + dydx = DTWO * x / (s**DTWO) + if (y > DONE) then y = DONE dydx = DZERO end if @@ -179,7 +179,7 @@ subroutine sChSmooth(d, smooth, dwdh) ! ****************************************************************************** ! Function to smooth channel variables during channel drying ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ real(DP), intent(in) :: d @@ -196,38 +196,38 @@ subroutine sChSmooth(d, smooth, dwdh) real(DP) :: y ! ------------------------------------------------------------------------------ ! code -! +! smooth = DZERO s = DEM5 x = d diff = x - s - if ( diff > DZERO ) then + if (diff > DZERO) then smooth = DONE dwdh = DZERO else aa = -DONE / (s**DTWO) ad = -DTWO / (s**DTWO) b = DTWO / s - y = aa * x**DTWO + b*x - dwdh = (ad*x + b) - if ( x <= DZERO ) then + y = aa * x**DTWO + b * x + dwdh = (ad * x + b) + if (x <= DZERO) then y = DZERO dwdh = DZERO - else if ( diff > -DEM14 ) then + else if (diff > -DEM14) then y = DONE dwdh = DZERO end if smooth = y end if return -end subroutine sChSmooth - + end subroutine sChSmooth + function sLinearSaturation(top, bot, x) result(y) ! ****************************************************************************** ! Linear smoothing function returns value between 0-1; ! Linear saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -252,13 +252,12 @@ function sLinearSaturation(top, bot, x) result(y) return end function sLinearSaturation - function sCubicSaturation(top, bot, x, eps) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Quadratic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -292,24 +291,23 @@ function sCubicSaturation(top, bot, x, eps) result(y) y = DZERO else if (w < s) then y = -cof1 * (w**DTHREE) + cof2 * (w**DTWO) - else if (w < (b-s)) then + else if (w < (b - s)) then y = w / b else if (w < b) then y = DONE + cof1 * ((b - w)**DTHREE) - cof2 * ((b - w)**DTWO) else y = DONE end if - + return end function sCubicSaturation - function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Quadratic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -349,14 +347,14 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) else br = (x - bot) / b end if - av = DONE / (DONE - teps) + av = DONE / (DONE - teps) bri = DONE - br if (br < tbmin) then br = tbmin end if if (br < teps) then - y = av * DHALF * (br*br) / teps - elseif (br < (DONE-teps)) then + y = av * DHALF * (br * br) / teps + elseif (br < (DONE - teps)) then y = av * br + DHALF * (DONE - av) elseif (br < DONE) then y = DONE - ((av * DHALF * (bri * bri)) / teps) @@ -370,16 +368,16 @@ function sQuadraticSaturation(top, bot, x, eps, bmin) result(y) y = DONE end if end if - + return end function sQuadraticSaturation - + function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! van Genuchten saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -412,14 +410,13 @@ function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y) return end function svanGenuchtenSaturation - - + function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) ! ****************************************************************************** ! Derivative of nonlinear smoothing function returns value between 0-1; ! Derivative of the quadratic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -458,14 +455,14 @@ function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) else br = (x - bot) / b end if - av = DONE / (DONE - teps) + av = DONE / (DONE - teps) bri = DONE - br if (br < tbmin) then br = tbmin end if if (br < teps) then y = av * br / teps - elseif (br < (DONE-teps)) then + elseif (br < (DONE - teps)) then y = av elseif (br < DONE) then y = av * bri / teps @@ -473,18 +470,16 @@ function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y) y = DZERO end if y = y / b - + return end function sQuadraticSaturationDerivative - - function sQSaturation(top, bot, x, c1, c2) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Cubic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -531,7 +526,7 @@ function sQSaturation(top, bot, x, c1, c2) result(y) ! -- calculate fraction if (s < DZERO) then y = DZERO - else if(s < DONE) then + else if (s < DONE) then y = cof1 * w**DTHREE + cof2 * w**DTWO else y = DONE @@ -540,13 +535,13 @@ function sQSaturation(top, bot, x, c1, c2) result(y) ! -- return return end function sQSaturation - + function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns value between 0-1; ! Cubic saturation function ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -569,7 +564,7 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! ! -- process optional variables if (present(c1)) then - cof1 = c1 + cof1 = c1 else cof1 = -DTWO end if @@ -586,7 +581,7 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) b = top - bot s = w / b ! - ! -- multiply cof1 and cof2 by 3 and 2, respectively, and then + ! -- multiply cof1 and cof2 by 3 and 2, respectively, and then ! divide by range to the power 3 and 2, respectively cof1 = cof1 * DTHREE / b**DTHREE cof2 = cof2 * DTWO / b**DTWO @@ -594,7 +589,7 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! -- calculate derivative of fraction with respect to x if (s < DZERO) then y = DZERO - else if(s < DONE) then + else if (s < DONE) then y = cof1 * w**DTWO + cof2 * w else y = DZERO @@ -603,14 +598,14 @@ function sQSaturationDerivative(top, bot, x, c1, c2) result(y) ! -- return return end function sQSaturationDerivative - + function sSlope(x, xi, yi, sm, sp, ta) result(y) ! ****************************************************************************** ! Nonlinear smoothing function returns a smoothed value of y that has the value ! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for ! x-values greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -654,15 +649,15 @@ function sSlope(x, xi, yi, sm, sp, ta) result(y) ! ! -- return return - end function sSlope - + end function sSlope + function sSlopeDerivative(x, xi, sm, sp, ta) result(y) ! ****************************************************************************** -! Derivative of nonlinear smoothing function that has the value yi at xi and -! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values +! Derivative of nonlinear smoothing function that has the value yi at xi and +! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values ! greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -697,20 +692,20 @@ function sSlopeDerivative(x, xi, sm, sp, ta) result(y) rho = dx / mu ! ! -- calculate derivative from individual contributions - y = DHALF * (sm + sp) - DHALF * rho * (sm - sp) + y = DHALF * (sm + sp) - DHALF * rho * (sm - sp) ! ! -- return return - end function sSlopeDerivative - + end function sSlopeDerivative + function sQuadratic0sp(x, xi, tomega) result(y) ! ****************************************************************************** -! Nonlinear smoothing function returns a smoothed value of y that uses a +! Nonlinear smoothing function returns a smoothed value of y that uses a ! quadratic to smooth x over range of xi - epsilon to xi + epsilon. ! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. ! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -749,16 +744,16 @@ function sQuadratic0sp(x, xi, tomega) result(y) ! ! -- return return - end function sQuadratic0sp - + end function sQuadratic0sp + function sQuadratic0spDerivative(x, xi, tomega) result(y) ! ****************************************************************************** -! Derivative of nonlinear smoothing function returns a smoothed value of y +! Derivative of nonlinear smoothing function returns a smoothed value of y ! that uses a quadratic to smooth x over range of xi - epsilon to xi + epsilon. ! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0. ! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -797,15 +792,15 @@ function sQuadratic0spDerivative(x, xi, tomega) result(y) ! ! -- return return - end function sQuadratic0spDerivative - + end function sQuadratic0spDerivative + function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y) ! ****************************************************************************** ! Quadratic smoothing function returns a smoothed value of y that has the value ! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for ! x-values greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -852,16 +847,15 @@ function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y) ! ! -- return return - end function sQuadraticSlope - - + end function sQuadraticSlope + function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y) ! ****************************************************************************** -! Derivative of quadratic smoothing function returns a smoothed value of y -! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and +! Derivative of quadratic smoothing function returns a smoothed value of y +! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and ! yi + (sp * dx) for x-values greater than xi, where dx = x - xi. ! ****************************************************************************** -! +! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- return @@ -904,6 +898,6 @@ function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y) ! ! -- return return - end function sQuadraticSlopeDerivative - + end function sQuadraticSlopeDerivative + end module SmoothingModule diff --git a/src/Utilities/Sparse.f90 b/src/Utilities/Sparse.f90 index e942aed7af2..af01ef34d9a 100644 --- a/src/Utilities/Sparse.f90 +++ b/src/Utilities/Sparse.f90 @@ -3,275 +3,278 @@ module SparseModule !of a matrix. Module uses FORTRAN 2003 extensions to manage !the data structures in an object oriented fashion. - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B + implicit none + + type rowtype + integer(I4B) :: nnz ! number of nonzero entries in the row + integer(I4B), allocatable, dimension(:) :: icolarray ! array of column numbers + end type rowtype + + type, public :: sparsematrix + integer(I4B) :: nrow ! number of rows in the matrix + integer(I4B) :: ncol ! number of columns in the matrix + integer(I4B) :: nnz ! number of nonzero matrix entries + type(rowtype), allocatable, dimension(:) :: row ! one rowtype for each matrix row + contains + generic :: init => initialize, initializefixed + procedure :: addconnection + procedure :: filliaja + procedure :: sort + procedure :: destroy + + procedure, private :: initializefixed + procedure, private :: initialize + end type sparsematrix + +contains + + subroutine destroy(this) + class(sparsematrix), intent(inout) :: this + deallocate (this%row) + end subroutine destroy + + subroutine initialize(this, nrow, ncol, rowmaxnnz) + !initial the sparse matrix. This subroutine + !acts a method for a sparse matrix by initializing + !the row data. It presently requires one maximum + !value for all rows, however, this can be changed + !to a vector of maximum values with one value for + !each row. + ! -- dummy + class(sparsematrix), intent(inout) :: this + integer(I4B), intent(in) :: nrow, ncol + integer(I4B), intent(in), dimension(nrow) :: rowmaxnnz + ! -- local + integer(I4B) :: i + ! -- code + this%nrow = nrow + this%ncol = ncol + this%nnz = 0 + allocate (this%row(nrow)) + do i = 1, nrow + allocate (this%row(i)%icolarray(rowmaxnnz(i))) + this%row(i)%icolarray = 0 + this%row(i)%nnz = 0 + end do + ! + ! -- return + return + end subroutine initialize + + ! overload + subroutine initializefixed(this, nrow, ncol, maxnnz) implicit none - - type rowtype - integer(I4B) :: nnz ! number of nonzero entries in the row - integer(I4B), allocatable, dimension(:) :: icolarray ! array of column numbers - end type rowtype + class(sparsematrix), intent(inout) :: this + integer(I4B), intent(in) :: nrow, ncol + integer(I4B), intent(in) :: maxnnz + ! local + integer(I4B), dimension(:), allocatable :: rowmaxnnz + integer(I4B) :: i - type, public :: sparsematrix - integer(I4B) :: nrow ! number of rows in the matrix - integer(I4B) :: ncol ! number of columns in the matrix - integer(I4B) :: nnz ! number of nonzero matrix entries - type(rowtype), allocatable, dimension(:) :: row ! one rowtype for each matrix row - contains - generic :: init => initialize, initializefixed - procedure :: addconnection - procedure :: filliaja - procedure :: sort - procedure :: destroy + allocate (rowmaxnnz(nrow)) - procedure, private :: initializefixed - procedure, private :: initialize - end type sparsematrix - - contains + do i = 1, nrow + rowmaxnnz(i) = maxnnz + end do - subroutine destroy(this) - class(sparsematrix), intent(inout) :: this - deallocate(this%row) - end subroutine destroy + call this%initialize(nrow, ncol, rowmaxnnz) + deallocate (rowmaxnnz) - subroutine initialize(this,nrow,ncol,rowmaxnnz) - !initial the sparse matrix. This subroutine - !acts a method for a sparse matrix by initializing - !the row data. It presently requires one maximum - !value for all rows, however, this can be changed - !to a vector of maximum values with one value for - !each row. - ! -- dummy - class(sparsematrix), intent(inout) :: this - integer(I4B),intent(in) :: nrow,ncol - integer(I4B),intent(in),dimension(nrow) :: rowmaxnnz - ! -- local - integer(I4B) :: i - ! -- code - this%nrow = nrow - this%ncol = ncol - this%nnz = 0 - allocate(this%row(nrow)) - do i = 1, nrow - allocate(this%row(i)%icolarray(rowmaxnnz(i))) - this%row(i)%icolarray=0 - this%row(i)%nnz=0 - end do - ! - ! -- return - return - end subroutine initialize + end subroutine initializefixed - ! overload - subroutine initializefixed(this,nrow,ncol,maxnnz) - implicit none - class(sparsematrix), intent(inout) :: this - integer(I4B),intent(in) :: nrow,ncol - integer(I4B),intent(in) :: maxnnz - ! local - integer(I4B), dimension(nrow) :: rowmaxnnz - integer(I4B) :: i - - do i=1,nrow - rowmaxnnz(i) = maxnnz - enddo - - call this%initialize(nrow, ncol, rowmaxnnz) - - end subroutine initializefixed - - subroutine filliaja(this, ia, ja, ierror, sort) - !allocate and fill the ia and ja arrays using information - !from the sparsematrix. - !ierror is returned as: - ! 0 if no error - ! 1 if ia is not the correct size - ! 2 if ja is not the correct size - ! 3 if both ia and ja are not correct size - ! -- dummy - class(sparsematrix), intent(inout) :: this - integer(I4B),dimension(:),intent(inout) :: ia, ja - integer(I4B),intent(inout) :: ierror - logical, intent(in), optional :: sort - ! -- local - logical :: sortja - integer(I4B) :: i,j,ipos - ! -- code - ! - ! -- process optional dummy variables - if (present(sort)) then - sortja = sort - else - sortja = .FALSE. - end if - ! - ! -- initialize error variable - ierror = 0 - ! - ! -- check for error conditions - if (ubound(ia,dim=1) /= this%nrow+1) then - ierror = 1 - end if - if (ubound(ja,dim=1) /= this%nnz) then - ierror = ierror + 2 - end if - if (ierror/=0) then - return - end if - ! - ! -- sort this - if (sortja) then - call this%sort() - end if - ! - ! -- fill ia and ja - ipos = 1 - ia(1) = ipos - do i = 1, this%nrow - do j = 1, this%row(i)%nnz - ja(ipos) = this%row(i)%icolarray(j) - ipos = ipos + 1 - end do - ia(i+1) = ipos - end do - ! - ! -- return + subroutine filliaja(this, ia, ja, ierror, sort) + !allocate and fill the ia and ja arrays using information + !from the sparsematrix. + !ierror is returned as: + ! 0 if no error + ! 1 if ia is not the correct size + ! 2 if ja is not the correct size + ! 3 if both ia and ja are not correct size + ! -- dummy + class(sparsematrix), intent(inout) :: this + integer(I4B), dimension(:), intent(inout) :: ia, ja + integer(I4B), intent(inout) :: ierror + logical, intent(in), optional :: sort + ! -- local + logical :: sortja + integer(I4B) :: i, j, ipos + ! -- code + ! + ! -- process optional dummy variables + if (present(sort)) then + sortja = sort + else + sortja = .FALSE. + end if + ! + ! -- initialize error variable + ierror = 0 + ! + ! -- check for error conditions + if (ubound(ia, dim=1) /= this%nrow + 1) then + ierror = 1 + end if + if (ubound(ja, dim=1) /= this%nnz) then + ierror = ierror + 2 + end if + if (ierror /= 0) then return - end subroutine filliaja + end if + ! + ! -- sort this + if (sortja) then + call this%sort() + end if + ! + ! -- fill ia and ja + ipos = 1 + ia(1) = ipos + do i = 1, this%nrow + do j = 1, this%row(i)%nnz + ja(ipos) = this%row(i)%icolarray(j) + ipos = ipos + 1 + end do + ia(i + 1) = ipos + end do + ! + ! -- return + return + end subroutine filliaja - subroutine addconnection(this, i, j, inodup, iaddop) - !add a connection to the sparsematrix. if inodup - !(for no duplicates) is 1, then j is added only - !if it is unique. - ! -- dummy - class(sparsematrix), intent(inout) :: this - integer(I4B),intent(in) :: i, j, inodup - integer(I4B),optional,intent(inout) :: iaddop - ! -- local - integer(I4B) :: iadded - ! -- code - call insert(j, this%row(i), inodup, iadded) - this%nnz = this%nnz+iadded - if (present(iaddop)) iaddop = iadded - ! - ! -- return - return - end subroutine addconnection + subroutine addconnection(this, i, j, inodup, iaddop) + !add a connection to the sparsematrix. if inodup + !(for no duplicates) is 1, then j is added only + !if it is unique. + ! -- dummy + class(sparsematrix), intent(inout) :: this + integer(I4B), intent(in) :: i, j, inodup + integer(I4B), optional, intent(inout) :: iaddop + ! -- local + integer(I4B) :: iadded + ! -- code + call insert(j, this%row(i), inodup, iadded) + this%nnz = this%nnz + iadded + if (present(iaddop)) iaddop = iadded + ! + ! -- return + return + end subroutine addconnection - subroutine insert(j, thisrow, inodup, iadded) - !insert j into thisrow (for row i) - !inodup=1 means do not include duplicate connections - !iadded is 1 if a new entry was added (meaning that nnz for the row was increased) - !iadded is 0 if duplicate and not added. Used to track total number of connections - ! -- dummy - integer(I4B), intent(in) :: j, inodup - type(rowtype), intent(inout) :: thisrow - integer(I4B), allocatable,dimension(:) :: iwk - integer(I4B), intent(inout) :: iadded - ! -- local - integer(I4B) :: jj, maxnnz - ! -- code - iadded = 0 - maxnnz = ubound(thisrow%icolarray,dim=1) - if (thisrow%icolarray(1) == 0) then - thisrow%icolarray(1) = j - thisrow%nnz = thisrow%nnz + 1 - iadded = 1 - return - end if - if (thisrow%nnz == maxnnz) then - ! -- increase size of the row - allocate(iwk(thisrow%nnz)) - iwk = thisrow%icolarray - deallocate(thisrow%icolarray) - ! -- Specify how to increase the size of the icolarray. Adding 1 - ! will be most memory conservative, but may be a little slower - ! due to frequent allocate/deallocate. Another option would be - ! to double the size: maxnnz=maxnnz*2 - maxnnz = maxnnz + 1 - allocate(thisrow%icolarray(maxnnz)) - thisrow%icolarray(1:thisrow%nnz) = iwk(1:thisrow%nnz) - thisrow%icolarray(thisrow%nnz+1:maxnnz) = 0 - end if - if (inodup == 1) then - do jj = 1, thisrow%nnz - if (thisrow%icolarray(jj)==j) then - return - end if - end do - end if - ! - ! -- add the connection to end + subroutine insert(j, thisrow, inodup, iadded) + !insert j into thisrow (for row i) + !inodup=1 means do not include duplicate connections + !iadded is 1 if a new entry was added (meaning that nnz for the row was increased) + !iadded is 0 if duplicate and not added. Used to track total number of connections + ! -- dummy + integer(I4B), intent(in) :: j, inodup + type(rowtype), intent(inout) :: thisrow + integer(I4B), allocatable, dimension(:) :: iwk + integer(I4B), intent(inout) :: iadded + ! -- local + integer(I4B) :: jj, maxnnz + ! -- code + iadded = 0 + maxnnz = ubound(thisrow%icolarray, dim=1) + if (thisrow%icolarray(1) == 0) then + thisrow%icolarray(1) = j thisrow%nnz = thisrow%nnz + 1 - thisrow%icolarray(thisrow%nnz) = j iadded = 1 - ! - ! -- return return - end subroutine insert - - subroutine sort(this) - !sort the icolarray for each row, but do not include - !the diagonal position in the sort so that it stays in front - ! -- dummy - class(sparsematrix), intent(inout) :: this - ! -- local - integer(I4B) :: i, nval - ! -- code - do i = 1, this%nrow - nval = this%row(i)%nnz - call sortintarray(nval-1, & - this%row(i)%icolarray(2:nval)) + end if + if (thisrow%nnz == maxnnz) then + ! -- increase size of the row + allocate (iwk(thisrow%nnz)) + iwk = thisrow%icolarray + deallocate (thisrow%icolarray) + ! -- Specify how to increase the size of the icolarray. Adding 1 + ! will be most memory conservative, but may be a little slower + ! due to frequent allocate/deallocate. Another option would be + ! to double the size: maxnnz=maxnnz*2 + maxnnz = maxnnz + 1 + allocate (thisrow%icolarray(maxnnz)) + thisrow%icolarray(1:thisrow%nnz) = iwk(1:thisrow%nnz) + thisrow%icolarray(thisrow%nnz + 1:maxnnz) = 0 + end if + if (inodup == 1) then + do jj = 1, thisrow%nnz + if (thisrow%icolarray(jj) == j) then + return + end if end do - ! - ! -- return - return - end subroutine sort + end if + ! + ! -- add the connection to end + thisrow%nnz = thisrow%nnz + 1 + thisrow%icolarray(thisrow%nnz) = j + iadded = 1 + ! + ! -- return + return + end subroutine insert + + subroutine sort(this) + !sort the icolarray for each row, but do not include + !the diagonal position in the sort so that it stays in front + ! -- dummy + class(sparsematrix), intent(inout) :: this + ! -- local + integer(I4B) :: i, nval + ! -- code + do i = 1, this%nrow + nval = this%row(i)%nnz + call sortintarray(nval - 1, & + this%row(i)%icolarray(2:nval)) + end do + ! + ! -- return + return + end subroutine sort - subroutine sortintarray(nval,iarray) - !simple subroutine for sorting an array - !in place. It is not the fastest sort function - !but should suffice for relatively short nodelists. - ! -- dummy - integer(I4B),intent(in) :: nval - integer(I4B),intent(inout),dimension(nval) :: iarray - ! -- local - integer(I4B) :: i, j, itemp - ! -- code - do i = 1, nval-1 - do j = i+1, nval - if (iarray(i) > iarray(j)) then - itemp = iarray(j) - iarray(j) = iarray(i) - iarray(i) = itemp - end if - end do + subroutine sortintarray(nval, iarray) + !simple subroutine for sorting an array + !in place. It is not the fastest sort function + !but should suffice for relatively short nodelists. + ! -- dummy + integer(I4B), intent(in) :: nval + integer(I4B), intent(inout), dimension(nval) :: iarray + ! -- local + integer(I4B) :: i, j, itemp + ! -- code + do i = 1, nval - 1 + do j = i + 1, nval + if (iarray(i) > iarray(j)) then + itemp = iarray(j) + iarray(j) = iarray(i) + iarray(i) = itemp + end if end do - ! - ! -- return - return - end subroutine sortintarray + end do + ! + ! -- return + return + end subroutine sortintarray - subroutine csr_diagsum(ia, flowja) - !Add up the off diagonal terms and put the sum in the - !diagonal position - ! -- dummy - integer(I4B), dimension(:), contiguous :: ia - real(DP), dimension(:), contiguous :: flowja - ! -- local - integer(I4B) :: nodes - integer(I4B) :: n - integer(I4B) :: iposdiag - integer(I4B) :: ipos - ! -- code - nodes = size(ia) - 1 - do n = 1, nodes - iposdiag = ia(n) - do ipos = ia(n) + 1, ia(n + 1) - 1 - flowja(iposdiag) = flowja(iposdiag) + flowja(ipos) - end do + subroutine csr_diagsum(ia, flowja) + !Add up the off diagonal terms and put the sum in the + !diagonal position + ! -- dummy + integer(I4B), dimension(:), contiguous :: ia + real(DP), dimension(:), contiguous :: flowja + ! -- local + integer(I4B) :: nodes + integer(I4B) :: n + integer(I4B) :: iposdiag + integer(I4B) :: ipos + ! -- code + nodes = size(ia) - 1 + do n = 1, nodes + iposdiag = ia(n) + do ipos = ia(n) + 1, ia(n + 1) - 1 + flowja(iposdiag) = flowja(iposdiag) + flowja(ipos) end do - return - end subroutine csr_diagsum + end do + return + end subroutine csr_diagsum -end module SparseModule \ No newline at end of file +end module SparseModule diff --git a/src/Utilities/StringList.f90 b/src/Utilities/StringList.f90 index 1ee9cbdffe8..4fd67c2e923 100644 --- a/src/Utilities/StringList.f90 +++ b/src/Utilities/StringList.f90 @@ -1,5 +1,5 @@ module StringListModule - + use KindModule, only: DP, I4B use ListModule, only: ListType @@ -12,17 +12,17 @@ module StringListModule contains - subroutine ConstructCharacterContainer (newCharCont, text) + subroutine ConstructCharacterContainer(newCharCont, text) implicit none type(CharacterContainerType), pointer, intent(out) :: newCharCont character(len=*), intent(in) :: text ! - allocate(newCharCont) + allocate (newCharCont) newCharCont%charstring = text return end subroutine ConstructCharacterContainer - function CastAsCharacterContainerType(obj) result (res) + function CastAsCharacterContainerType(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj type(CharacterContainerType), pointer :: res @@ -51,12 +51,12 @@ subroutine AddStringToList(list, string) if (associated(newCharacterContainer)) then obj => newCharacterContainer call list%Add(obj) - endif + end if ! return end subroutine AddStringToList - - function GetStringFromList(list, indx) result (string) + + function GetStringFromList(list, indx) result(string) implicit none ! -- dummy type(ListType), intent(inout) :: list @@ -71,7 +71,7 @@ function GetStringFromList(list, indx) result (string) charcont => CastAsCharacterContainerType(obj) if (associated(charcont)) then string = charcont%charstring - endif + end if ! return end function GetStringFromList diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 7d46f215712..b7e119621eb 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -1,22 +1,22 @@ -! Comprehensive table object that stores all of the -! intercell flows, and the inflows and the outflows for +! Comprehensive table object that stores all of the +! intercell flows, and the inflows and the outflows for ! an advanced package. module TableModule - + use KindModule, only: I4B, I8B, DP - use ConstantsModule, only: LINELENGTH, LENBUDTXT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + use ConstantsModule, only: LINELENGTH, LENBUDTXT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & TABCENTER use TableTermModule, only: TableTermType use InputOutputModule, only: UWWORD, parseline use SimModule, only: store_error use SimVariablesModule, only: errmsg - + implicit none - + public :: TableType public :: table_cr - + type :: TableType ! ! -- name, number of control volumes, and number of table terms @@ -45,18 +45,18 @@ module TableModule ! ! -- table table object, for writing the typical MODFLOW table type(TableType), pointer :: table => null() - + character(len=LINELENGTH), pointer :: linesep => null() character(len=LINELENGTH), pointer :: dataline => null() character(len=LINELENGTH), dimension(:), pointer :: header => null() - - contains - + + contains + procedure :: table_df procedure :: table_da procedure :: initialize_column procedure :: line_to_columns - procedure :: finalize_table + procedure :: finalize_table procedure :: set_maxbound procedure :: set_kstpkper procedure :: set_title @@ -65,20 +65,20 @@ module TableModule procedure :: print_separator procedure, private :: allocate_strings - procedure, private :: set_header - procedure, private :: write_header - procedure, private :: write_line + procedure, private :: set_header + procedure, private :: write_header + procedure, private :: write_line procedure, private :: finalize procedure, private :: add_error procedure, private :: reset - - generic, public :: add_term => add_integer, add_long_integer, & - add_real, add_string - procedure, private :: add_integer, add_long_integer, add_real, add_string + + generic, public :: add_term => add_integer, add_long_integer, & + add_real, add_string + procedure, private :: add_integer, add_long_integer, add_real, add_string end type TableType - - contains + +contains subroutine table_cr(this, name, title) ! ****************************************************************************** @@ -98,12 +98,12 @@ subroutine table_cr(this, name, title) ! -- check if table already associated and reset if necessary if (associated(this)) then call this%table_da() - deallocate(this) - nullify(this) + deallocate (this) + nullify (this) end if ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- initialize variables this%name = name @@ -113,7 +113,7 @@ subroutine table_cr(this, name, title) return end subroutine table_cr - subroutine table_df(this, maxbound, ntableterm, iout, transient, & + subroutine table_df(this, maxbound, ntableterm, iout, transient, & lineseparator, separator, finalize) ! ****************************************************************************** ! table_df -- Define the new table object @@ -134,29 +134,29 @@ subroutine table_df(this, maxbound, ntableterm, iout, transient, & ! ------------------------------------------------------------------------------ ! ! -- allocate scalars - allocate(this%sep) - allocate(this%write_csv) - allocate(this%first_entry) - allocate(this%transient) - allocate(this%add_linesep) - allocate(this%allow_finalization) - allocate(this%iout) - allocate(this%maxbound) - allocate(this%nheaderlines) - allocate(this%nlinewidth) - allocate(this%ntableterm) - allocate(this%ientry) - allocate(this%iloc) - allocate(this%icount) + allocate (this%sep) + allocate (this%write_csv) + allocate (this%first_entry) + allocate (this%transient) + allocate (this%add_linesep) + allocate (this%allow_finalization) + allocate (this%iout) + allocate (this%maxbound) + allocate (this%nheaderlines) + allocate (this%nlinewidth) + allocate (this%ntableterm) + allocate (this%ientry) + allocate (this%iloc) + allocate (this%icount) ! ! -- allocate space for tableterm - allocate(this%tableterm(ntableterm)) + allocate (this%tableterm(ntableterm)) ! ! -- initialize values based on optional dummy variables if (present(transient)) then this%transient = transient - allocate(this%kstp) - allocate(this%kper) + allocate (this%kstp) + allocate (this%kper) else this%transient = .FALSE. end if @@ -193,7 +193,7 @@ subroutine table_df(this, maxbound, ntableterm, iout, transient, & ! -- return return end subroutine table_df - + subroutine initialize_column(this, text, width, alignment) ! ****************************************************************************** ! initialize_column -- Initialize data for a column @@ -225,16 +225,16 @@ subroutine initialize_column(this, text, width, alignment) ! ! -- check that ientry is in bounds if (this%ientry > this%ntableterm) then - write(errmsg,'(a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & - 'Trying to add column "', trim(adjustl(text)), '" (', & - this%ientry, ') in the', trim(adjustl(this%name)), 'table ("', & - trim(adjustl(this%title)), '") that only has', this%ntableterm, & + write (errmsg, '(a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & + 'Trying to add column "', trim(adjustl(text)), '" (', & + this%ientry, ') in the', trim(adjustl(this%name)), 'table ("', & + trim(adjustl(this%title)), '") that only has', this%ntableterm, & 'columns.' call store_error(errmsg, terminate=.TRUE.) end if ! ! -- initialize table term - call this%tableterm(idx)%initialize(text, width, alignment=ialign) + call this%tableterm(idx)%initialize(text, width, alignment=ialign) ! ! -- create header when all terms have been specified if (this%ientry == this%ntableterm) then @@ -247,7 +247,7 @@ subroutine initialize_column(this, text, width, alignment) ! -- return return end subroutine initialize_column - + subroutine set_header(this) ! ****************************************************************************** ! set_header -- Set the table object header @@ -306,19 +306,19 @@ subroutine set_header(this) alignment = this%tableterm(j)%get_alignment() call this%tableterm(j)%get_header(n, cval) if (this%write_csv) then - if ( j == 1) then - write(this%header(nn), '(a)') trim(adjustl(cval)) + if (j == 1) then + write (this%header(nn), '(a)') trim(adjustl(cval)) else - write(this%header(nn), '(a,",",G0)') & + write (this%header(nn), '(a,",",G0)') & trim(this%header(nn)), trim(adjustl(cval)) end if else if (j == this%ntableterm) then - call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & - cval(1:width), ival, rval, ALIGNMENT=alignment) + call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & + cval(1:width), ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & - cval(1:width), ival, rval, ALIGNMENT=alignment, & + call UWWORD(this%header(nn), iloc, width, TABUCSTRING, & + cval(1:width), ival, rval, ALIGNMENT=alignment, & SEP=this%sep) end if end if @@ -328,7 +328,7 @@ subroutine set_header(this) ! -- return return end subroutine set_header - + subroutine allocate_strings(this, width, nlines) ! ****************************************************************************** ! allocate_strings -- Allocate allocatable character arrays @@ -359,9 +359,9 @@ subroutine allocate_strings(this, width, nlines) this%nlinewidth = width ! ! -- allocate deferred length strings - allocate(this%header(this%nheaderlines)) - allocate(this%linesep) - allocate(this%dataline) + allocate (this%header(this%nheaderlines)) + allocate (this%linesep) + allocate (this%dataline) ! ! -- initialize lines this%linesep = linesep(1:width) @@ -374,12 +374,12 @@ subroutine allocate_strings(this, width, nlines) ! linesep if (this%add_linesep) then this%header(1) = linesep(1:width) - this%header(nlines+2) = linesep(1:width) + this%header(nlines + 2) = linesep(1:width) end if ! ! -- return return - end subroutine allocate_strings + end subroutine allocate_strings subroutine write_header(this) ! ****************************************************************************** @@ -405,16 +405,16 @@ subroutine write_header(this) ! -- write title title = this%title if (this%transient) then - write(title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', this%kper - write(title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', this%kstp + write (title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', this%kper + write (title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', this%kstp end if if (len_trim(title) > 0) then - write(this%iout, '(/,1x,a)') trim(adjustl(title)) + write (this%iout, '(/,1x,a)') trim(adjustl(title)) end if ! ! -- write header do n = 1, this%nheaderlines - write(this%iout, '(1x,a)') this%header(n)(1:width) + write (this%iout, '(1x,a)') this%header(n) (1:width) end do end if ! @@ -426,7 +426,7 @@ subroutine write_header(this) ! -- return return end subroutine write_header - + subroutine write_line(this) ! ****************************************************************************** ! write_line -- Write the data line @@ -445,7 +445,7 @@ subroutine write_line(this) width = this%nlinewidth ! ! -- write the dataline - write(this%iout, '(1x,a)') this%dataline(1:width) + write (this%iout, '(1x,a)') this%dataline(1:width) ! ! -- update column and line counters this%ientry = 0 @@ -455,11 +455,11 @@ subroutine write_line(this) ! -- return return end subroutine write_line - + subroutine finalize(this) ! ****************************************************************************** ! finalize -- Private method that test for last line. If last line the -! public finalize_table method is called +! public finalize_table method is called ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -478,7 +478,7 @@ subroutine finalize(this) ! -- return return end subroutine finalize - + subroutine finalize_table(this) ! ****************************************************************************** ! finalize -- Public method to finalize the table @@ -496,14 +496,14 @@ subroutine finalize_table(this) call this%print_separator(iextralines=1) ! ! -- flush file - flush(this%iout) + flush (this%iout) ! ! -- reinitialize variables call this%reset() ! ! -- return return - end subroutine finalize_table + end subroutine finalize_table subroutine table_da(this) ! ****************************************************************************** @@ -525,37 +525,37 @@ subroutine table_da(this) end do ! ! -- deallocate space for tableterm - deallocate(this%tableterm) + deallocate (this%tableterm) ! ! -- deallocate character scalars and arrays - deallocate(this%linesep) - deallocate(this%dataline) - deallocate(this%header) + deallocate (this%linesep) + deallocate (this%dataline) + deallocate (this%header) ! ! -- deallocate scalars if (this%transient) then - deallocate(this%kstp) - deallocate(this%kper) + deallocate (this%kstp) + deallocate (this%kper) end if - deallocate(this%sep) - deallocate(this%write_csv) - deallocate(this%first_entry) - deallocate(this%transient) - deallocate(this%add_linesep) - deallocate(this%allow_finalization) - deallocate(this%iout) - deallocate(this%maxbound) - deallocate(this%nheaderlines) - deallocate(this%nlinewidth) - deallocate(this%ntableterm) - deallocate(this%ientry) - deallocate(this%iloc) - deallocate(this%icount) + deallocate (this%sep) + deallocate (this%write_csv) + deallocate (this%first_entry) + deallocate (this%transient) + deallocate (this%add_linesep) + deallocate (this%allow_finalization) + deallocate (this%iout) + deallocate (this%maxbound) + deallocate (this%nheaderlines) + deallocate (this%nlinewidth) + deallocate (this%ntableterm) + deallocate (this%ientry) + deallocate (this%iloc) + deallocate (this%icount) ! ! -- Return return end subroutine table_da - + subroutine line_to_columns(this, line) ! ****************************************************************************** ! line_to_columns -- convert a line to the correct number of columns @@ -599,12 +599,12 @@ subroutine line_to_columns(this, line) end do ! ! -- clean up local allocatable array - deallocate(words) + deallocate (words) ! ! -- Return return - end subroutine line_to_columns - + end subroutine line_to_columns + subroutine add_error(this) ! ****************************************************************************** ! add_error -- evaluate if error condition occurs when adding data to dataline @@ -620,9 +620,9 @@ subroutine add_error(this) ! ! -- check that ientry is within bounds if (this%ientry > this%ntableterm) then - write(errmsg,'(a,1x,i0,5(1x,a),1x,i0,1x,a)') & - 'Trying to add data to column ', this%ientry, 'in the', & - trim(adjustl(this%name)), 'table (', trim(adjustl(this%title)), & + write (errmsg, '(a,1x,i0,5(1x,a),1x,i0,1x,a)') & + 'Trying to add data to column ', this%ientry, 'in the', & + trim(adjustl(this%name)), 'table (', trim(adjustl(this%title)), & ') that only has', this%ntableterm, 'columns.' call store_error(errmsg, terminate=.TRUE.) end if @@ -630,7 +630,7 @@ subroutine add_error(this) ! -- Return return end subroutine add_error - + subroutine add_integer(this, ival) ! ****************************************************************************** ! add_integer -- add integer value to the dataline @@ -674,16 +674,16 @@ subroutine add_integer(this, ival) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(G0)') ival + write (this%dataline, '(G0)') ival else - write(this%dataline, '(a,",",G0)') trim(this%dataline), ival + write (this%dataline, '(a,",",G0)') trim(this%dataline), ival end if else if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & + call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & cval, ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & + call UWWORD(this%dataline, this%iloc, width, TABINTEGER, & cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -701,7 +701,7 @@ subroutine add_integer(this, ival) ! -- Return return end subroutine add_integer - + subroutine add_long_integer(this, long_ival) ! ****************************************************************************** ! add_long_integer -- add long integer value to the dataline @@ -746,17 +746,17 @@ subroutine add_long_integer(this, long_ival) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(G0)') long_ival + write (this%dataline, '(G0)') long_ival else - write(this%dataline, '(a,",",G0)') trim(this%dataline), long_ival + write (this%dataline, '(a,",",G0)') trim(this%dataline), long_ival end if else - write(cval, '(i0)') long_ival + write (cval, '(i0)') long_ival if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & trim(cval), ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & trim(cval), ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -818,16 +818,16 @@ subroutine add_real(this, rval) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(G0)') rval + write (this%dataline, '(G0)') rval else - write(this%dataline, '(a,",",G0)') trim(this%dataline), rval + write (this%dataline, '(a,",",G0)') trim(this%dataline), rval end if else if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABREAL, & + call UWWORD(this%dataline, this%iloc, width, TABREAL, & cval, ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABREAL, & + call UWWORD(this%dataline, this%iloc, width, TABREAL, & cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -845,7 +845,7 @@ subroutine add_real(this, rval) ! -- Return return end subroutine add_real - + subroutine add_string(this, cval) ! ****************************************************************************** ! add_string -- add string value to the dataline @@ -889,17 +889,17 @@ subroutine add_string(this, cval) ! -- add data to line if (this%write_csv) then if (j == 1) then - write(this%dataline, '(a)') trim(adjustl(cval)) + write (this%dataline, '(a)') trim(adjustl(cval)) else - write(this%dataline, '(a,",",a)') & + write (this%dataline, '(a,",",a)') & trim(this%dataline), trim(adjustl(cval)) end if else if (j == this%ntableterm) then - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & cval, ival, rval, ALIGNMENT=alignment) else - call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & cval, ival, rval, ALIGNMENT=alignment, SEP=this%sep) end if end if @@ -917,7 +917,7 @@ subroutine add_string(this, cval) ! -- Return return end subroutine add_string - + subroutine set_maxbound(this, maxbound) ! ****************************************************************************** ! set_maxbound -- reset maxbound @@ -940,8 +940,8 @@ subroutine set_maxbound(this, maxbound) ! ! -- return return - end subroutine set_maxbound - + end subroutine set_maxbound + subroutine set_kstpkper(this, kstp, kper) ! ****************************************************************************** ! set_kstpkper -- reset kstp and kper @@ -963,8 +963,8 @@ subroutine set_kstpkper(this, kstp, kper) ! ! -- return return - end subroutine set_kstpkper - + end subroutine set_kstpkper + subroutine set_title(this, title) ! ****************************************************************************** ! set_maxbound -- reset maxbound @@ -985,7 +985,7 @@ subroutine set_title(this, title) ! -- return return end subroutine set_title - + subroutine set_iout(this, iout) ! ****************************************************************************** ! set_iout -- reset iout @@ -1005,8 +1005,8 @@ subroutine set_iout(this, iout) ! ! -- return return - end subroutine set_iout - + end subroutine set_iout + subroutine print_list_entry(this, i, nodestr, q, bname) ! ****************************************************************************** ! print_list_entry -- write flow term table values @@ -1034,8 +1034,8 @@ subroutine print_list_entry(this, i, nodestr, q, bname) ! ! -- return return - end subroutine print_list_entry - + end subroutine print_list_entry + subroutine print_separator(this, iextralines) ! ****************************************************************************** ! print_separator -- print a line separator to the table @@ -1065,16 +1065,16 @@ subroutine print_separator(this, iextralines) ! ! -- print line separator if (this%add_linesep) then - write(this%iout, '(1x,a)') this%linesep(1:width) + write (this%iout, '(1x,a)') this%linesep(1:width) do i = 1, iextra - write(this%iout, '(/)') + write (this%iout, '(/)') end do end if ! ! -- return return end subroutine print_separator - + subroutine reset(this) ! ****************************************************************************** ! reset -- Private method to reset table counters @@ -1095,6 +1095,6 @@ subroutine reset(this) ! ! -- return return - end subroutine reset + end subroutine reset end module TableModule diff --git a/src/Utilities/TableTerm.f90 b/src/Utilities/TableTerm.f90 index f00d1cc7cd1..f7e5e3c9cc8 100644 --- a/src/Utilities/TableTerm.f90 +++ b/src/Utilities/TableTerm.f90 @@ -1,31 +1,30 @@ ! A table term is the information needed to describe flow. -! The table object contains an array of table terms. -! For an advanced package. The table object describes all of +! The table object contains an array of table terms. +! For an advanced package. The table object describes all of ! the flows. module TableTermModule use KindModule, only: I4B, DP - use ConstantsModule, only: LINELENGTH, LENBUDTXT, DZERO, & - TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL + use ConstantsModule, only: LINELENGTH, LENBUDTXT, DZERO, & + TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL use InputOutputModule, only: UPCASE, parseline implicit none public :: TableTermType - - + type :: TableTermType character(len=LINELENGTH), pointer :: tag => null() integer(I4B), pointer :: width => null() integer(I4B), pointer :: alignment => null() integer(I4B), pointer :: nheader_lines => null() - + character(len=LINELENGTH), dimension(:), pointer :: initial_lines => null() character(len=LINELENGTH), dimension(:), pointer :: header_lines => null() - + contains - + procedure :: initialize procedure, private :: allocate_scalars procedure :: get_width @@ -34,12 +33,11 @@ module TableTermModule procedure :: set_header procedure :: get_header procedure :: da - - + end type TableTermType - contains - +contains + subroutine initialize(this, tag, width, alignment) ! ****************************************************************************** ! initialize -- initialize the table term @@ -66,16 +64,16 @@ subroutine initialize(this, tag, width, alignment) ! ! -- allocate scalars call this%allocate_scalars() - + ! -- process dummy variables this%tag = tag - + if (present(alignment)) then this%alignment = alignment else this%alignment = TABCENTER end if - + this%width = width ! ! -- parse tag into words @@ -86,16 +84,16 @@ subroutine initialize(this, tag, width, alignment) do i = 1, nwords ilen = len(trim(words(i))) if (ilen > width) then - words(i)(width:width) = '.' + words(i) (width:width) = '.' do j = width + 1, ilen - words(i)(j:j) = ' ' + words(i) (j:j) = ' ' end do end if end do ! ! -- combine words that fit into width i = 0 - do + do i = i + 1 if (i > nwords) then exit @@ -104,7 +102,7 @@ subroutine initialize(this, tag, width, alignment) tstring = string do j = i + 1, nwords if (len(trim(adjustl(string))) > 0) then - tstring = trim(adjustl(tstring)) // ' ' // trim(adjustl(words(j))) + tstring = trim(adjustl(tstring))//' '//trim(adjustl(words(j))) else tstring = trim(adjustl(words(j))) end if @@ -130,22 +128,22 @@ subroutine initialize(this, tag, width, alignment) end do ! ! allocate initial_lines and fill with words - allocate(this%initial_lines(this%nheader_lines)) - do i = 1, this%nheader_lines - this%initial_lines(i) = words(i)(1:width) + allocate (this%initial_lines(this%nheader_lines)) + do i = 1, this%nheader_lines + this%initial_lines(i) = words(i) (1:width) end do ! ! -- deallocate words - deallocate(words) + deallocate (words) ! ! -- return return end subroutine initialize - + function get_width(this) ! ****************************************************************************** -! get_width -- get column width +! get_width -- get column width ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -162,10 +160,10 @@ function get_width(this) ! -- return return end function get_width - + function get_alignment(this) ! ****************************************************************************** -! get_width -- get column width +! get_width -- get column width ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -181,8 +179,8 @@ function get_alignment(this) ! ! -- return return - end function get_alignment - + end function get_alignment + function get_header_lines(this) ! ****************************************************************************** ! get_header_lines -- get the number of lines in initial_lines @@ -202,7 +200,7 @@ function get_header_lines(this) ! -- return return end function get_header_lines - + subroutine allocate_scalars(this) ! ****************************************************************************** ! allocate_scalars -- allocate table term scalars @@ -216,10 +214,10 @@ subroutine allocate_scalars(this) ! ------------------------------------------------------------------------------ ! ! -- allocate scalars - allocate(this%tag) - allocate(this%alignment) - allocate(this%width) - allocate(this%nheader_lines) + allocate (this%tag) + allocate (this%alignment) + allocate (this%width) + allocate (this%nheader_lines) ! ! -- initialize scalars this%nheader_lines = 0 @@ -227,7 +225,7 @@ subroutine allocate_scalars(this) ! -- return return end subroutine allocate_scalars - + subroutine da(this) ! ****************************************************************************** ! da -- deallocate table terms @@ -242,16 +240,16 @@ subroutine da(this) !integer(I4B) :: n ! ------------------------------------------------------------------------------ ! - ! -- deallocate scalars - deallocate(this%tag) - deallocate(this%alignment) - deallocate(this%width) - deallocate(this%nheader_lines) - deallocate(this%header_lines) + ! -- deallocate scalars + deallocate (this%tag) + deallocate (this%alignment) + deallocate (this%width) + deallocate (this%nheader_lines) + deallocate (this%header_lines) ! ! -- return end subroutine da - + subroutine set_header(this, nlines) ! ****************************************************************************** ! set_header -- set final header lines for table term @@ -274,8 +272,8 @@ subroutine set_header(this, nlines) ! -- initialize variables string = ' ' ! - ! allocate header_lines - allocate(this%header_lines(nlines)) + ! allocate header_lines + allocate (this%header_lines(nlines)) ! ! -- initialize header lines do i = 1, nlines @@ -286,20 +284,20 @@ subroutine set_header(this, nlines) ! bottom to top idiff = nlines - this%nheader_lines i0 = 1 - idiff - do i = this%nheader_lines, 1, -1 + do i = this%nheader_lines, 1, -1 j = i + idiff this%header_lines(j) = this%initial_lines(i) end do ! ! -- deallocate temporary header lines - deallocate(this%initial_lines) + deallocate (this%initial_lines) ! ! -- reinitialize nheader_lines this%nheader_lines = nlines ! ! -- return end subroutine set_header - + subroutine get_header(this, iline, cval) ! ****************************************************************************** ! get_header -- get header entry for table term iline @@ -317,9 +315,9 @@ subroutine get_header(this, iline, cval) ! ------------------------------------------------------------------------------ ! ! -- set return value - cval = this%header_lines(iline)(1:this%width) + cval = this%header_lines(iline) (1:this%width) ! ! -- return - end subroutine get_header - -end module TableTermModule \ No newline at end of file + end subroutine get_header + +end module TableTermModule diff --git a/src/Utilities/TimeSeries/TimeArray.f90 b/src/Utilities/TimeSeries/TimeArray.f90 index 15da0224f6e..49b7ee99e4c 100644 --- a/src/Utilities/TimeSeries/TimeArray.f90 +++ b/src/Utilities/TimeSeries/TimeArray.f90 @@ -1,10 +1,10 @@ module TimeArrayModule - use BaseDisModule, only: DisBaseType - use KindModule, only: DP, I4B - use ListModule, only: ListType + use BaseDisModule, only: DisBaseType + use KindModule, only: DP, I4B + use ListModule, only: ListType use SimVariablesModule, only: errmsg - use SimModule, only: store_error + use SimModule, only: store_error implicit none private @@ -37,7 +37,7 @@ subroutine ConstructTimeArray(newTa, dis) ! ------------------------------------------------------------------------------ ! -- dummy type(TimeArrayType), pointer, intent(out) :: newTa - class(DisBaseType), pointer, intent(in) :: dis + class(DisBaseType), pointer, intent(in) :: dis ! -- local integer(I4B) :: isize ! ------------------------------------------------------------------------------ @@ -48,9 +48,9 @@ subroutine ConstructTimeArray(newTa, dis) else errmsg = 'Time array series is not supported for discretization type' call store_error(errmsg, terminate=.TRUE.) - endif - allocate(newTa) - allocate(newTa%taArray(isize)) + end if + allocate (newTa) + allocate (newTa%taArray(isize)) return end subroutine ConstructTimeArray @@ -84,7 +84,7 @@ subroutine AddTimeArrayToList(list, timearray) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeArrayType), pointer, intent(inout) :: timearray ! -- local class(*), pointer :: obj @@ -96,7 +96,7 @@ subroutine AddTimeArrayToList(list, timearray) return end subroutine AddTimeArrayToList - function GetTimeArrayFromList(list, indx) result (res) + function GetTimeArrayFromList(list, indx) result(res) ! ****************************************************************************** ! GetTimeArrayFromList -- get ta from list ! ****************************************************************************** @@ -105,8 +105,8 @@ function GetTimeArrayFromList(list, indx) result (res) ! ------------------------------------------------------------------------------ ! -- dummy type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: indx - type(TimeArrayType), pointer :: res + integer(I4B), intent(in) :: indx + type(TimeArrayType), pointer :: res ! -- local class(*), pointer :: obj ! ------------------------------------------------------------------------------ @@ -128,7 +128,7 @@ subroutine ta_da(this) class(TimeArrayType) :: this ! ------------------------------------------------------------------------------ ! - deallocate(this%taArray) + deallocate (this%taArray) this%taArray => null() ! return diff --git a/src/Utilities/TimeSeries/TimeArraySeries.f90 b/src/Utilities/TimeSeries/TimeArraySeries.f90 index 2aa13b54f4a..34119ffa65a 100644 --- a/src/Utilities/TimeSeries/TimeArraySeries.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeries.f90 @@ -1,25 +1,25 @@ module TimeArraySeriesModule use ArrayReadersModule, only: ReadArray - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & - LENTIMESERIESNAME, DZERO, DONE - use GenericUtilitiesModule, only: is_same - use InputOutputModule, only: GetUnit, openfile - use KindModule, only: DP, I4B - use ListModule, only: ListType, ListNodeType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & + LENTIMESERIESNAME, DZERO, DONE + use GenericUtilitiesModule, only: is_same + use InputOutputModule, only: GetUnit, openfile + use KindModule, only: DP, I4B + use ListModule, only: ListType, ListNodeType use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, store_error_unit - use TimeArrayModule, only: TimeArrayType, ConstructTimeArray, & - AddTimeArrayToList, CastAsTimeArrayType, & - GetTimeArrayFromList - use BaseDisModule, only: DisBaseType + use SimModule, only: count_errors, store_error, store_error_unit + use TimeArrayModule, only: TimeArrayType, ConstructTimeArray, & + AddTimeArrayToList, CastAsTimeArrayType, & + GetTimeArrayFromList + use BaseDisModule, only: DisBaseType use, intrinsic :: iso_fortran_env, only: IOSTAT_END implicit none private - public :: TimeArraySeriesType, ConstructTimeArraySeries, & - CastAsTimeArraySeriesType, GetTimeArraySeriesFromList + public :: TimeArraySeriesType, ConstructTimeArraySeries, & + CastAsTimeArraySeriesType, GetTimeArraySeriesFromList type TimeArraySeriesType ! -- Public members @@ -67,18 +67,18 @@ subroutine ConstructTimeArraySeries(newTas, filename) logical :: lex ! ------------------------------------------------------------------------------ ! formats - 10 format('Error: Time-array-series file "',a,'" does not exist.') +10 format('Error: Time-array-series file "', a, '" does not exist.') ! ! -- Allocate a new object of type TimeArraySeriesType - allocate(newTas) - allocate(newTas%list) + allocate (newTas) + allocate (newTas%list) ! ! -- Ensure that input file exists - inquire(file=filename,exist=lex) + inquire (file=filename, exist=lex) if (.not. lex) then - write(errmsg,10)trim(filename) + write (errmsg, 10) trim(filename) call store_error(errmsg, terminate=.TRUE.) - endif + end if newTas%datafile = filename ! return @@ -99,7 +99,7 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) class(DisBaseType), pointer, intent(inout) :: dis integer(I4B), intent(in) :: iout character(len=*), intent(inout) :: tasname - logical, optional, intent(in) :: autoDeallocate + logical, optional, intent(in) :: autoDeallocate ! -- local integer(I4B) :: istatus integer(I4B) :: ierr @@ -111,7 +111,7 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) ! -- initialize some variables if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate this%dataFile = fname - allocate(this%list) + allocate (this%list) ! ! -- assign members this%dis => dis @@ -131,13 +131,13 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) ! ! -- get BEGIN line of ATTRIBUTES block call this%parser%GetBlock('ATTRIBUTES', found, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (.not. found) then - errmsg = 'Error: Attributes block not found in file: ' // & - trim(fname) + errmsg = 'Error: Attributes block not found in file: '// & + trim(fname) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- parse ATTRIBUTES entries do @@ -161,64 +161,64 @@ subroutine tas_init(this, fname, dis, iout, tasname, autoDeallocate) case ('LINEAR') this%iMethod = LINEAR case default - errmsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' + errmsg = 'Unknown interpolation method: "'//trim(keyvalue)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() end select case ('AUTODEALLOCATE') this%autoDeallocate = (keyvalue == 'TRUE') case ('SFAC') - read(keyvalue,*,iostat=istatus)this%sfac + read (keyvalue, *, iostat=istatus) this%sfac if (istatus /= 0) then - errmsg = 'Error reading numeric SFAC value from "' // trim(keyvalue) & - // '"' + errmsg = 'Error reading numeric SFAC value from "'//trim(keyvalue) & + //'"' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if case default - errmsg = 'Unknown option found in ATTRIBUTES block: "' // & - trim(keyword) // '"' + errmsg = 'Unknown option found in ATTRIBUTES block: "'// & + trim(keyword)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() end select - enddo + end do ! ! -- ensure that NAME and METHOD have been specified if (this%Name == '') then - errmsg = 'Name not specified for time array series in file: ' // & + errmsg = 'Name not specified for time array series in file: '// & trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if if (this%iMethod == UNDEFINED) then - errmsg = 'Interpolation method not specified for time' // & - ' array series in file: ' // trim(this%dataFile) + errmsg = 'Interpolation method not specified for time'// & + ' array series in file: '//trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- handle any errors encountered so far - if (count_errors()>0) then - errmsg = 'Error(s) encountered initializing time array series from file: ' // & - trim(this%dataFile) + if (count_errors() > 0) then + errmsg = 'Error(s) encountered initializing time array series from file: ' & + //trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- try to read first time array into linked list if (.not. this%read_next_array()) then - errmsg = 'Error encountered reading time-array data from file: ' // & + errmsg = 'Error encountered reading time-array data from file: '// & trim(this%dataFile) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! return end subroutine tas_init subroutine GetAverageValues(this, nvals, values, time0, time1) ! ****************************************************************************** -! GetAverageValues -- populate an array time-weighted average value for a +! GetAverageValues -- populate an array time-weighted average value for a ! specified time span. ! ****************************************************************************** ! @@ -226,10 +226,10 @@ subroutine GetAverageValues(this, nvals, values, time0, time1) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals + integer(I4B), intent(in) :: nvals real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 ! -- local integer(I4B) :: i real(DP) :: timediff @@ -238,13 +238,13 @@ subroutine GetAverageValues(this, nvals, values, time0, time1) timediff = time1 - time0 if (timediff > 0) then call this%get_integrated_values(nvals, values, time0, time1) - do i=1,nvals + do i = 1, nvals values(i) = values(i) / timediff - enddo + end do else ! -- time0 and time1 are the same, so skip the integration step. call this%get_values_at_time(nvals, values, time0) - endif + end if ! return end subroutine GetAverageValues @@ -278,7 +278,7 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeArraySeriesType), intent(inout) :: this - real(DP), intent(in) :: time + real(DP), intent(in) :: time type(TimeArrayType), pointer, intent(inout) :: taEarlier type(TimeArrayType), pointer, intent(inout) :: taLater ! -- local @@ -295,7 +295,7 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) ! if (associated(this%list%firstNode)) then currNode => this%list%firstNode - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -308,15 +308,15 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) currNode => currNode%nextNode else exit - endif + end if else ! -- read another array if (.not. this%read_next_array()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -333,8 +333,8 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) time0 = ta0%taTime else exit - endif - enddo + end if + end do ! ! -- find later record node1 => currNode @@ -352,11 +352,11 @@ subroutine get_surrounding_records(this, time, taEarlier, taLater) if (.not. this%read_next_array()) then ! -- end of file reached, so exit loop exit - endif - endif - enddo + end if + end if + end do ! - endif + end if ! if (time0 <= time) taEarlier => ta0 if (time1 >= time) taLater => ta1 @@ -376,7 +376,7 @@ logical function read_next_array(this) ! -- local integer(I4B) :: i, ierr, istart, istat, istop, lloc, nrow, ncol, nodesperlayer logical :: lopen, isFound - type(TimeArrayType), pointer :: ta => null() + type(TimeArrayType), pointer :: ta => null() ! ------------------------------------------------------------------------------ ! istart = 1 @@ -386,38 +386,39 @@ logical function read_next_array(this) ! Get dimensions for supported discretization type if (this%dis%supports_layers()) then nodesperlayer = this%dis%get_ncpl() - if(size(this%dis%mshape) == 3) then + if (size(this%dis%mshape) == 3) then nrow = this%dis%mshape(2) ncol = this%dis%mshape(3) else nrow = 1 ncol = this%dis%mshape(2) - endif + end if else - errmsg = 'Time array series is not supported for selected discretization type.' + errmsg = 'Time array series is not supported for selected & + &discretization type.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! read_next_array = .false. - inquire(unit=this%inunit,opened=lopen) + inquire (unit=this%inunit, opened=lopen) if (lopen) then call ConstructTimeArray(ta, this%dis) ! -- read a time and an array from the input file ! -- Get a TIME block and read the time call this%parser%GetBlock('TIME', isFound, ierr, & - supportOpenClose=.false.) + supportOpenClose=.false.) if (isFound) then ta%taTime = this%parser%GetDouble() ! -- Read the array call ReadArray(this%parser%iuactive, ta%taArray, this%Name, & - this%dis%ndim, ncol, nrow, 1, nodesperlayer, & - this%iout, 0, 0) + this%dis%ndim, ncol, nrow, 1, nodesperlayer, & + this%iout, 0, 0) ! ! -- multiply values by sfac do i = 1, nodesperlayer ta%taArray(i) = ta%taArray(i) * this%sfac - enddo + end do ! ! -- append the new time array to the list call AddTimeArrayToList(this%list, ta) @@ -425,8 +426,8 @@ logical function read_next_array(this) ! ! -- make sure block is closed call this%parser%terminateblock() - endif - endif + end if + end if return ! Normal return ! return @@ -434,7 +435,7 @@ end function read_next_array subroutine get_values_at_time(this, nvals, values, time) ! ****************************************************************************** -! get_values_at_time -- Return an array of values for a specified time, same +! get_values_at_time -- Return an array of values for a specified time, same ! units as time-series values. ! ****************************************************************************** ! @@ -448,44 +449,44 @@ subroutine get_values_at_time(this, nvals, values, time) ! -- local integer(I4B) :: i, ierr real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & - valdiff + valdiff type(TimeArrayType), pointer :: taEarlier => null() type(TimeArrayType), pointer :: taLater => null() ! formats - 10 format('Error getting array at time ',g10.3, & - ' for time-array series "',a,'"') +10 format('Error getting array at time ', g10.3, & + ' for time-array series "', a, '"') ! ------------------------------------------------------------------------------ ! ierr = 0 - call this%get_surrounding_records(time,taEarlier,taLater) + call this%get_surrounding_records(time, taEarlier, taLater) if (associated(taEarlier)) then if (associated(taLater)) then ! -- values are available for both earlier and later times if (this%iMethod == STEPWISE) then ! -- Just populate values from elements of earlier time array - values = taEarlier%taArray + values = taEarlier%taArray elseif (this%iMethod == LINEAR) then ! -- perform linear interpolation time0 = taEarlier%taTime time1 = taLater%tatime timediff = time1 - time0 timediffi = time - time0 - if (timediff>0) then - ratio = timediffi/timediff + if (timediff > 0) then + ratio = timediffi / timediff else ! -- should not happen if TS does not contain duplicate times ratio = 0.5d0 - endif + end if ! -- Iterate through all elements and perform interpolation. - do i=1,nvals + do i = 1, nvals val0 = taEarlier%taArray(i) val1 = taLater%taArray(i) valdiff = val1 - val0 - values(i) = val0 + (ratio*valdiff) - enddo + values(i) = val0 + (ratio * valdiff) + end do else ierr = 1 - endif + end if else if (is_same(taEarlier%taTime, time)) then values = taEarlier%taArray @@ -493,12 +494,12 @@ subroutine get_values_at_time(this, nvals, values, time) ! -- Only earlier time is available, and it is not time of interest; ! however, if method is STEPWISE, use value for earlier time. if (this%iMethod == STEPWISE) then - values = taEarlier%taArray + values = taEarlier%taArray else ierr = 1 - endif - endif - endif + end if + end if + end if else if (associated(taLater)) then if (is_same(taLater%taTime, time)) then @@ -506,26 +507,26 @@ subroutine get_values_at_time(this, nvals, values, time) else ! -- only later time is available, and it is not time of interest ierr = 1 - endif + end if else ! -- Neither earlier nor later time is available. ! This should never happen! ierr = 1 - endif - endif + end if + end if ! if (ierr > 0) then - write(errmsg,10)time,trim(this%Name) + write (errmsg, 10) time, trim(this%Name) call store_error(errmsg) call store_error_unit(this%inunit) - endif + end if ! return end subroutine get_values_at_time subroutine get_integrated_values(this, nvals, values, time0, time1) ! ****************************************************************************** -! get_integrated_values -- Populates an array with integrated values for a +! get_integrated_values -- Populates an array with integrated values for a ! specified time span. Units: (ts-value-unit)*time ! ****************************************************************************** ! @@ -533,14 +534,14 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeArraySeriesType), intent(inout) :: this - integer(I4B), intent(in) :: nvals + integer(I4B), intent(in) :: nvals real(DP), dimension(nvals), intent(inout) :: values - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 ! -- local integer(I4B) :: i real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, & - t01, t1, timediff, value, value0, value1, valuediff + t01, t1, timediff, value, value0, value1, valuediff logical :: ldone type(ListNodeType), pointer :: precNode => null() type(ListNodeType), pointer :: currNode => null(), nextNode => null() @@ -548,8 +549,8 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) class(*), pointer :: currObj => null(), nextObj => null() ! -- formats 10 format('Error encountered while performing integration', & - ' for time-array series "',a,'" for time interval: ', & - g12.5,' to ',g12.5) + ' for time-array series "', a, '" for time interval: ', & + g12.5, ' to ', g12.5) ! ------------------------------------------------------------------------------ ! values = DZERO @@ -567,11 +568,11 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) if (.not. associated(currNode%nextNode)) then ! -- try to read the next array if (.not. this%read_next_array()) then - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call store_error_unit(this%inunit) - endif - endif + end if + end if if (associated(currNode%nextNode)) then nextNode => currNode%nextNode nextObj => nextNode%GetItem() @@ -583,26 +584,26 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) t0 = currTime else t0 = time0 - endif + end if if (nextTime <= time1) then t1 = nextTime else t1 = time1 - endif + end if ! -- For each element, find area of rectangle ! or trapezoid delimited by t0 and t1. t01 = t1 - t0 select case (this%iMethod) case (STEPWISE) - do i=1,nvals + do i = 1, nvals ! -- compute area of a rectangle value0 = currRecord%taArray(i) area = value0 * t01 ! -- add area to integrated value values(i) = values(i) + area - enddo + end do case (LINEAR) - do i=1,nvals + do i = 1, nvals ! -- compute area of a trapezoid timediff = nextTime - currTime ratio0 = (t0 - currTime) / timediff @@ -613,17 +614,17 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) area = 0.5d0 * t01 * (value0 + value1) ! -- add area to integrated value values(i) = values(i) + area - enddo + end do end select else - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call store_error('(Probable programming error)', terminate=.TRUE.) - endif + end if else ! Current node time = time1 so should be done ldone = .true. - endif + end if ! ! -- Are we done yet? if (t1 >= time1) then @@ -632,50 +633,50 @@ subroutine get_integrated_values(this, nvals, values, time0, time1) if (.not. associated(currNode%nextNode)) then ! -- try to read the next array if (.not. this%read_next_array()) then - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - endif + end if + end if if (associated(currNode%nextNode)) then currNode => currNode%nextNode else - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg) call store_error('(Probable programming error)', terminate=.TRUE.) - endif - endif - enddo - endif + end if + end if + end do + end if ! if (this%autoDeallocate) then if (associated(precNode)) then - if (associated(precNode%prevNode))then + if (associated(precNode%prevNode)) then call this%DeallocateBackward(precNode%prevNode) - endif - endif - endif + end if + end if + end if ! return end subroutine get_integrated_values subroutine DeallocateBackward(this, fromNode) ! ****************************************************************************** -! DeallocateBackward -- Deallocate fromNode and all previous nodes in list; +! DeallocateBackward -- Deallocate fromNode and all previous nodes in list; ! reassign firstNode. ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this + class(TimeArraySeriesType), intent(inout) :: this type(ListNodeType), pointer, intent(inout) :: fromNode ! ! -- local - type(ListNodeType), pointer :: current => null() - type(ListNodeType), pointer :: prev => null() + type(ListNodeType), pointer :: current => null() + type(ListNodeType), pointer :: prev => null() type(TimeArrayType), pointer :: ta => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! if (associated(fromNode)) then @@ -684,7 +685,7 @@ subroutine DeallocateBackward(this, fromNode) this%list%firstNode => fromNode%nextNode else this%list%firstNode => null() - endif + end if ! -- deallocate fromNode and all previous nodes current => fromNode do while (associated(current)) @@ -696,41 +697,42 @@ subroutine DeallocateBackward(this, fromNode) call ta%da() call this%list%RemoveNode(current, .true.) current => prev - enddo + end do fromNode => null() - endif + end if ! return end subroutine DeallocateBackward subroutine get_latest_preceding_node(this, time, tslNode) ! ****************************************************************************** -! get_latest_preceding_node -- Return pointer to ListNodeType object for the +! get_latest_preceding_node -- Return pointer to ListNodeType object for the ! node representing the latest preceding time in the time series ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeArraySeriesType), intent(inout) :: this - real(DP), intent(in) :: time + class(TimeArraySeriesType), intent(inout) :: this + real(DP), intent(in) :: time type(ListNodeType), pointer, intent(inout) :: tslNode ! -- local real(DP) :: time0 - type(ListNodeType), pointer :: currNode => null() - type(ListNodeType), pointer :: node0 => null() + type(ListNodeType), pointer :: currNode => null() + type(ListNodeType), pointer :: node0 => null() type(TimeArrayType), pointer :: ta => null() type(TimeArrayType), pointer :: ta0 => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tslNode => null() if (associated(this%list%firstNode)) then currNode => this%list%firstNode else - call store_error('probable programming error in get_latest_preceding_node', & + call store_error('probable programming error in & + &get_latest_preceding_node', & terminate=.TRUE.) - endif + end if ! continue ! -- If the next node is earlier than time of interest, advance along @@ -740,19 +742,19 @@ subroutine get_latest_preceding_node(this, time, tslNode) if (associated(currNode%nextNode)) then obj => currNode%nextNode%GetItem() ta => CastAsTimeArrayType(obj) - if (ta%taTime < time .or. is_same(ta%taTime, time)) then + if (ta%taTime < time .or. is_same(ta%taTime, time)) then currNode => currNode%nextNode else exit - endif + end if else ! -- read another record if (.not. this%read_next_array()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -769,9 +771,9 @@ subroutine get_latest_preceding_node(this, time, tslNode) time0 = ta0%taTime else exit - endif - enddo - endif + end if + end do + end if ! if (time0 <= time) tslNode => node0 ! @@ -794,30 +796,30 @@ subroutine tas_da(this) ! ! -- Deallocate contents of each time array in list n = this%list%Count() - do i=1,n + do i = 1, n ta => GetTimeArrayFromList(this%list, i) call ta%da() - enddo + end do ! ! -- Deallocate the list of time arrays call this%list%Clear(.true.) - deallocate(this%list) + deallocate (this%list) ! return end subroutine tas_da ! -- Procedures not type-bound - function CastAsTimeArraySeriesType(obj) result (res) + function CastAsTimeArraySeriesType(obj) result(res) ! ****************************************************************************** -! CastAsTimeArraySeriesType -- Cast an unlimited polymorphic object as +! CastAsTimeArraySeriesType -- Cast an unlimited polymorphic object as ! class(TimeArraySeriesType) ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(*), pointer, intent(inout) :: obj + class(*), pointer, intent(inout) :: obj type(TimeArraySeriesType), pointer :: res ! ------------------------------------------------------------------------------ ! @@ -832,7 +834,7 @@ function CastAsTimeArraySeriesType(obj) result (res) return end function CastAsTimeArraySeriesType - function GetTimeArraySeriesFromList(list, indx) result (res) + function GetTimeArraySeriesFromList(list, indx) result(res) ! ****************************************************************************** ! GetTimeArraySeriesFromList -- get time array from list ! ****************************************************************************** @@ -840,8 +842,8 @@ function GetTimeArraySeriesFromList(list, indx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer, intent(in) :: indx + type(ListType), intent(inout) :: list + integer, intent(in) :: indx type(TimeArraySeriesType), pointer :: res ! -- local class(*), pointer :: obj diff --git a/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 b/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 index add7e0852bf..4e1bb7d7a01 100644 --- a/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeriesLink.f90 @@ -1,9 +1,9 @@ module TimeArraySeriesLinkModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENPACKAGENAME, LENTIMESERIESTEXT - use InputOutputModule, only: UPCASE - use ListModule, only: ListType + use ConstantsModule, only: LENPACKAGENAME, LENTIMESERIESTEXT + use InputOutputModule, only: UPCASE + use ListModule, only: ListType use TimeArraySeriesModule, only: TimeArraySeriesType implicit none @@ -53,7 +53,7 @@ subroutine tasl_da(this) end subroutine tasl_da subroutine ConstructTimeArraySeriesLink(newTasLink, timeArraySeries, & - pkgName, bndArray, iprpak, text) + pkgName, bndArray, iprpak, text) ! ****************************************************************************** ! ConstructTimeArraySeriesLink -- construct ! ****************************************************************************** @@ -61,17 +61,17 @@ subroutine ConstructTimeArraySeriesLink(newTasLink, timeArraySeries, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(TimeArraySeriesLinkType), pointer, intent(out) :: newTasLink - type(TimeArraySeriesType), pointer, intent(in) :: timeArraySeries - character(len=*), intent(in) :: pkgName - real(DP), dimension(:), pointer, intent(in) :: bndArray - integer(I4B), intent(in) :: iprpak - character(len=*), intent(in) :: text + type(TimeArraySeriesLinkType), pointer, intent(out) :: newTasLink + type(TimeArraySeriesType), pointer, intent(in) :: timeArraySeries + character(len=*), intent(in) :: pkgName + real(DP), dimension(:), pointer, intent(in) :: bndArray + integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: text ! -- local character(len=LENPACKAGENAME) :: pkgNameTemp ! ------------------------------------------------------------------------------ ! - allocate(newTasLink) + allocate (newTasLink) ! Store package name as all caps pkgNameTemp = pkgName call UPCASE(pkgNameTemp) @@ -86,7 +86,7 @@ end subroutine ConstructTimeArraySeriesLink function CastAsTimeArraySeriesLinkType(obj) result(res) ! ****************************************************************************** -! CastAsTimeArraySeriesLinkType -- Cast an unlimited polymorphic object as +! CastAsTimeArraySeriesLinkType -- Cast an unlimited polymorphic object as ! TimeArraySeriesLinkType ! ****************************************************************************** ! @@ -115,7 +115,7 @@ subroutine AddTimeArraySeriesLinkToList(list, tasLink) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeArraySeriesLinkType), pointer, intent(inout) :: tasLink ! -- local class(*), pointer :: obj @@ -127,7 +127,7 @@ subroutine AddTimeArraySeriesLinkToList(list, tasLink) return end subroutine AddTimeArraySeriesLinkToList - function GetTimeArraySeriesLinkFromList(list, idx) result (res) + function GetTimeArraySeriesLinkFromList(list, idx) result(res) ! ****************************************************************************** ! GetTimeArraySeriesLinkFromList -- get from list ! ****************************************************************************** @@ -135,9 +135,9 @@ function GetTimeArraySeriesLinkFromList(list, idx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - type(TimeArraySeriesLinkType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + type(TimeArraySeriesLinkType), pointer :: res ! -- local class(*), pointer :: obj ! ------------------------------------------------------------------------------ diff --git a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 index ebd11739f1c..46040ca4cde 100644 --- a/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeArraySeriesManager.f90 @@ -1,18 +1,18 @@ module TimeArraySeriesManagerModule - use KindModule, only: DP, I4B - use SimVariablesModule, only: errmsg - use ConstantsModule, only: DZERO, LENTIMESERIESNAME, LINELENGTH, & - LENHUGELINE - use ListModule, only: ListType - use SimModule, only: store_error, store_error_unit - use TdisModule, only: delt, totimc, kper, kstp + use KindModule, only: DP, I4B + use SimVariablesModule, only: errmsg + use ConstantsModule, only: DZERO, LENTIMESERIESNAME, LINELENGTH, & + LENHUGELINE + use ListModule, only: ListType + use SimModule, only: store_error, store_error_unit + use TdisModule, only: delt, totimc, kper, kstp use TimeArraySeriesLinkModule, only: TimeArraySeriesLinkType, & ConstructTimeArraySeriesLink, & GetTimeArraySeriesLinkFromList, & AddTimeArraySeriesLinkToList - use TimeArraySeriesModule, only: TimeArraySeriesType - use BaseDisModule, only: DisBaseType + use TimeArraySeriesModule, only: TimeArraySeriesType + use BaseDisModule, only: DisBaseType implicit none @@ -21,13 +21,13 @@ module TimeArraySeriesManagerModule type TimeArraySeriesManagerType ! -- Public members - integer(I4B), public :: iout = 0 ! output unit num - class(DisBaseType), pointer, public :: dis => null() ! pointer to dis + integer(I4B), public :: iout = 0 ! output unit num + class(DisBaseType), pointer, public :: dis => null() ! pointer to dis ! -- Private members - type(ListType), pointer, private :: boundTasLinks => null() ! list of TAS links - character(len=LINELENGTH), allocatable, dimension(:) :: tasfiles ! list of TA file names - type(TimeArraySeriesType), dimension(:), pointer, contiguous :: taslist ! array of TA pointers - character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: tasnames ! array of TA names + type(ListType), pointer, private :: boundTasLinks => null() ! list of TAS links + character(len=LINELENGTH), allocatable, dimension(:) :: tasfiles ! list of TA file names + type(TimeArraySeriesType), dimension(:), pointer, contiguous :: taslist ! array of TA pointers + character(len=LENTIMESERIESNAME), allocatable, dimension(:) :: tasnames ! array of TA names contains ! -- Public procedures procedure, public :: tasmanager_df @@ -64,12 +64,12 @@ subroutine tasmanager_cr(this, dis, iout) ! this%iout = iout this%dis => dis - allocate(this%boundTasLinks) - allocate(this%tasfiles(0)) + allocate (this%boundTasLinks) + allocate (this%tasfiles(0)) ! return end subroutine tasmanager_cr - + subroutine tasmanager_df(this) ! ****************************************************************************** ! tasmanager_df -- define @@ -88,19 +88,19 @@ subroutine tasmanager_df(this) ! -- determine how many tasfiles. This is the number of time array series ! so allocate arrays to store them nfiles = size(this%tasfiles) - allocate(this%taslist(nfiles)) - allocate(this%tasnames(nfiles)) + allocate (this%taslist(nfiles)) + allocate (this%tasnames(nfiles)) ! ! -- Setup a time array series for each file specified do i = 1, nfiles tasptr => this%taslist(i) - call tasptr%tas_init(this%tasfiles(i), this%dis, & - this%iout, this%tasnames(i)) - enddo + call tasptr%tas_init(this%tasfiles(i), this%dis, & + this%iout, this%tasnames(i)) + end do ! return end subroutine tasmanager_df - + subroutine tasmgr_ad(this) ! ****************************************************************************** ! tasmgr_ad -- time step (or subtime step) advance. @@ -117,10 +117,11 @@ subroutine tasmgr_ad(this) integer(I4B) :: i, j, nlinks, nvals, isize1, isize2, inunit real(DP) :: begintime, endtime ! formats - character(len=*),parameter :: fmt5 = & - "(/,'Time-array-series controlled arrays in stress period ', & + character(len=*), parameter :: fmt5 = & + "(/,'Time-array-series controlled arrays in stress period ', & &i0, ', time step ', i0, ':')" -10 format('"',a, '" package: ',a,' array obtained from time-array series "',a,'"') +10 format('"', a, '" package: ', a, ' array obtained from time-array series "', & + a, '"') ! ------------------------------------------------------------------------------ ! ! -- Initialize time variables @@ -134,9 +135,9 @@ subroutine tasmgr_ad(this) nlinks = this%boundTasLinks%Count() do i = 1, nlinks tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) - if (tasLink%Iprpak == 1 .and. i==1) then - write(this%iout, fmt5) kper, kstp - endif + if (tasLink%Iprpak == 1 .and. i == 1) then + write (this%iout, fmt5) kper, kstp + end if if (tasLink%UseDefaultProc) then timearrayseries => tasLink%timeArraySeries nvals = size(tasLink%BndArray) @@ -148,20 +149,20 @@ subroutine tasmgr_ad(this) ! -- If conversion from flux to flow is required, multiply by cell area if (tasLink%ConvertFlux) then call this%tasmgr_convert_flux(tasLink) - endif + end if ! ! -- If PRINT_INPUT is specified, write information ! regarding source of time-array series data if (tasLink%Iprpak == 1) then - write(this%iout,10) trim(tasLink%PackageName), & - trim(tasLink%Text), & - trim(tasLink%timeArraySeries%Name) - endif - endif + write (this%iout, 10) trim(tasLink%PackageName), & + trim(tasLink%Text), & + trim(tasLink%timeArraySeries%Name) + end if + end if if (i == nlinks) then - write(this%iout, '()') - endif - enddo + write (this%iout, '()') + end if + end do ! ! -- Now that all array values have been substituted, can now multiply ! an array by a multiplier array @@ -174,19 +175,19 @@ subroutine tasmgr_ad(this) if (isize1 == isize2 .and. isize1 == nvals) then do j = 1, nvals tasLink%BndArray(j) = tasLink%BndArray(j) * tasLink%RMultArray(j) - enddo + end do else - errmsg = 'Size mismatch between boundary and multiplier arrays' // & - ' using time-array series: ' // & + errmsg = 'Size mismatch between boundary and multiplier arrays'// & + ' using time-array series: '// & trim(tasLink%TimeArraySeries%Name) call store_error(errmsg) inunit = tasLink%TimeArraySeries%GetInunit() call store_error_unit(inunit) - endif - endif - endif - enddo - endif + end if + end if + end if + end do + end if ! return end subroutine tasmgr_ad @@ -208,10 +209,10 @@ subroutine tasmgr_da(this) ! -- Deallocate contents of each TimeArraySeriesType object in list ! of time-array series links. n = this%boundTasLinks%Count() - do i=1,n + do i = 1, n tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, i) call tasLink%da() - enddo + end do ! ! -- Go through and deallocate individual time array series do i = 1, size(this%taslist) @@ -220,12 +221,12 @@ subroutine tasmgr_da(this) ! ! -- Deallocate the list of time-array series links. call this%boundTasLinks%Clear(.true.) - deallocate(this%boundTasLinks) - deallocate(this%tasfiles) + deallocate (this%boundTasLinks) + deallocate (this%tasfiles) ! ! -- Deallocate the time array series - deallocate(this%taslist) - deallocate(this%tasnames) + deallocate (this%taslist) + deallocate (this%tasnames) ! ! -- nullify pointers this%dis => null() @@ -282,9 +283,9 @@ subroutine Reset(this, pkgName) if (associated(taslink)) then do j = 1, size(taslink%BndArray) taslink%BndArray(j) = DZERO - enddo - endif - enddo + end do + end if + end do ! ! -- Delete all existing time array links if (associated(this%boundTasLinks)) then @@ -295,14 +296,14 @@ subroutine Reset(this, pkgName) if (associated(taslink)) then call taslink%da() call this%boundTasLinks%RemoveNode(i, .true.) - endif - enddo - endif + end if + end do + end if ! return end subroutine Reset - subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & + subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & tasName, text, convertFlux, nodelist, inunit) ! ****************************************************************************** ! MakeTasLink -- Make link from TAS to package array @@ -324,7 +325,7 @@ subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & integer(I4B) :: i, nfiles, iloc character(LINELENGTH) :: ermsg type(TimeArraySeriesLinkType), pointer :: newTasLink - type(TimeArraySeriesType), pointer :: tasptr => null() + type(TimeArraySeriesType), pointer :: tasptr => null() ! ------------------------------------------------------------------------------ ! ! -- Find the time array series @@ -334,13 +335,13 @@ subroutine MakeTasLink(this, pkgName, bndArray, iprpak, & if (this%tasnames(i) == tasname) then iloc = i exit - endif + end if end do if (iloc == 0) then - ermsg = 'Error: Time-array series "' // trim(tasName) // '" not found.' + ermsg = 'Error: Time-array series "'//trim(tasName)//'" not found.' call store_error(ermsg) call store_error_unit(inunit) - endif + end if tasptr => this%taslist(iloc) ! ! -- Construct a time-array series link @@ -375,7 +376,7 @@ function GetLink(this, indx) result(tasLink) ! if (associated(this%boundTasLinks)) then tasLink => GetTimeArraySeriesLinkFromList(this%boundTasLinks, indx) - endif + end if ! return end function GetLink @@ -397,7 +398,7 @@ function CountLinks(this) CountLinks = this%boundTasLinks%Count() else CountLinks = 0 - endif + end if ! return end function CountLinks @@ -421,13 +422,13 @@ subroutine tasmgr_convert_flux(this, tasLink) ! ------------------------------------------------------------------------------ ! n = size(tasLink%BndArray) - do i=1,n + do i = 1, n noder = tasLink%nodelist(i) if (noder > 0) then area = this%dis%get_area(noder) tasLink%BndArray(i) = tasLink%BndArray(i) * area - endif - enddo + end if + end do ! return end subroutine tasmgr_convert_flux @@ -440,7 +441,7 @@ subroutine tasmgr_add_link(this, tasLink) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeArraySeriesManagerType) :: this + class(TimeArraySeriesManagerType) :: this type(TimeArraySeriesLinkType), pointer :: tasLink ! -- local ! ------------------------------------------------------------------------------ diff --git a/src/Utilities/TimeSeries/TimeSeries.f90 b/src/Utilities/TimeSeries/TimeSeries.f90 index b6c687a84c6..f867607334b 100644 --- a/src/Utilities/TimeSeries/TimeSeries.f90 +++ b/src/Utilities/TimeSeries/TimeSeries.f90 @@ -1,16 +1,16 @@ module TimeSeriesModule use KindModule, only: DP, I4B - use BlockParserModule, only: BlockParserType - use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & - LINEAREND, LENTIMESERIESNAME, LENHUGELINE, & - DZERO, DONE, DNODATA - use GenericUtilitiesModule, only: is_same - use InputOutputModule, only: GetUnit, openfile, ParseLine, upcase - use ListModule, only: ListType, ListNodeType + use BlockParserModule, only: BlockParserType + use ConstantsModule, only: LINELENGTH, UNDEFINED, STEPWISE, LINEAR, & + LINEAREND, LENTIMESERIESNAME, LENHUGELINE, & + DZERO, DONE, DNODATA + use GenericUtilitiesModule, only: is_same + use InputOutputModule, only: GetUnit, openfile, ParseLine, upcase + use ListModule, only: ListType, ListNodeType use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, & - store_error_unit + use SimModule, only: count_errors, store_error, & + store_error_unit use TimeSeriesRecordModule, only: TimeSeriesRecordType, & ConstructTimeSeriesRecord, & CastAsTimeSeriesRecordType, & @@ -63,7 +63,8 @@ module TimeSeriesModule integer(I4B), public :: nTimeSeries = 0 logical, public :: finishedReading = .false. character(len=LINELENGTH), public :: datafile = '' - type(TimeSeriesType), dimension(:), pointer, contiguous, public :: timeSeries => null() + type(TimeSeriesType), dimension(:), & + pointer, contiguous, public :: timeSeries => null() type(BlockParserType), pointer, public :: parser contains ! -- Public procedures @@ -95,14 +96,14 @@ subroutine ConstructTimeSeriesFile(newTimeSeriesFile) type(TimeSeriesFileType), pointer, intent(inout) :: newTimeSeriesFile ! ------------------------------------------------------------------------------ ! - allocate(newTimeSeriesFile) - allocate(newTimeSeriesFile%parser) + allocate (newTimeSeriesFile) + allocate (newTimeSeriesFile%parser) return end subroutine ConstructTimeSeriesFile function CastAsTimeSeriesFileType(obj) result(res) ! ****************************************************************************** -! CastAsTimeSeriesFileType -- Cast an unlimited polymorphic object as +! CastAsTimeSeriesFileType -- Cast an unlimited polymorphic object as ! class(TimeSeriesFileType) ! ****************************************************************************** ! @@ -126,7 +127,7 @@ end function CastAsTimeSeriesFileType function CastAsTimeSeriesFileClass(obj) result(res) ! ****************************************************************************** -! CastAsTimeSeriesFileClass -- Cast an unlimited polymorphic object as +! CastAsTimeSeriesFileClass -- Cast an unlimited polymorphic object as ! class(TimeSeriesFileType) ! ****************************************************************************** ! @@ -156,7 +157,7 @@ subroutine AddTimeSeriesFileToList(list, tsfile) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list class(TimeSeriesFileType), pointer, intent(inout) :: tsfile ! -- local class(*), pointer :: obj => null() @@ -168,7 +169,7 @@ subroutine AddTimeSeriesFileToList(list, tsfile) return end subroutine AddTimeSeriesFileToList - function GetTimeSeriesFileFromList(list, idx) result (res) + function GetTimeSeriesFileFromList(list, idx) result(res) ! ****************************************************************************** ! GetTimeSeriesFileFromList -- get from list ! ****************************************************************************** @@ -176,8 +177,8 @@ function GetTimeSeriesFileFromList(list, idx) result (res) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx type(TimeSeriesFileType), pointer :: res ! -- local class(*), pointer :: obj => null() @@ -188,12 +189,12 @@ function GetTimeSeriesFileFromList(list, idx) result (res) ! if (.not. associated(res)) then res => CastAsTimeSeriesFileClass(obj) - endif + end if ! return end function GetTimeSeriesFileFromList - function SameTimeSeries(ts1, ts2) result (same) + function SameTimeSeries(ts1, ts2) result(same) ! ****************************************************************************** ! SameTimeSeries -- Compare two time series; if they are identical, return true. ! ****************************************************************************** @@ -217,12 +218,12 @@ function SameTimeSeries(ts1, ts2) result (same) call ts1%Reset() call ts2%Reset() ! - do i=1,n1 + do i = 1, n1 tsr1 => ts1%GetNextTimeSeriesRecord() tsr2 => ts2%GetNextTimeSeriesRecord() if (tsr1%tsrTime /= tsr2%tsrTime) return if (tsr1%tsrValue /= tsr2%tsrValue) return - enddo + end do ! same = .true. ! @@ -247,24 +248,24 @@ function GetValue(this, time0, time1, extendToEndOfSimulation) real(DP) :: GetValue ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 logical, intent(in), optional :: extendToEndOfSimulation ! logical :: extend ! ------------------------------------------------------------------------------ ! - if(present(extendToEndOfSimulation)) then + if (present(extendToEndOfSimulation)) then extend = extendToEndOfSimulation else extend = .false. - endif + end if ! select case (this%iMethod) case (STEPWISE, LINEAR) GetValue = this%get_average_value(time0, time1, extend) case (LINEAREND) - GetValue = this%get_value_at_time(time1, extend) + GetValue = this%get_value_at_time(time1, extend) end select ! return @@ -280,9 +281,9 @@ subroutine initialize_time_series(this, tsfile, name, autoDeallocate) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesType), intent(inout) :: this - class(TimeSeriesFileType), target :: tsfile - character(len=*), intent(in) :: name - logical, intent(in), optional :: autoDeallocate + class(TimeSeriesFileType), target :: tsfile + character(len=*), intent(in) :: name + logical, intent(in), optional :: autoDeallocate ! -- local character(len=LENTIMESERIESNAME) :: tsNameTemp ! ------------------------------------------------------------------------------ @@ -299,13 +300,13 @@ subroutine initialize_time_series(this, tsfile, name, autoDeallocate) if (present(autoDeallocate)) this%autoDeallocate = autoDeallocate ! ! -- allocate the list - allocate(this%list) + allocate (this%list) ! ! -- ensure that NAME has been specified if (this%Name == '') then errmsg = 'Name not specified for time series.' call store_error(errmsg, terminate=.TRUE.) - endif + end if ! return end subroutine initialize_time_series @@ -319,7 +320,7 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time + real(DP), intent(in) :: time type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecEarlier type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecLater ! -- local @@ -329,7 +330,7 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) type(ListNodeType), pointer :: tsNode1 => null() type(TimeSeriesRecordType), pointer :: tsr => null(), tsrec0 => null() type(TimeSeriesRecordType), pointer :: tsrec1 => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tsrecEarlier => null() @@ -337,7 +338,7 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) ! if (associated(this%list%firstNode)) then currNode => this%list%firstNode - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -350,15 +351,15 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) currNode => currNode%nextNode else exit - endif + end if else ! -- read another record if (.not. this%read_next_record()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -375,8 +376,8 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) time0 = tsrec0%tsrTime else exit - endif - enddo + end if + end do ! ! -- find later record tsNode1 => currNode @@ -394,11 +395,11 @@ subroutine get_surrounding_records(this, time, tsrecEarlier, tsrecLater) if (.not. this%read_next_record()) then ! -- end of file reached, so exit loop exit - endif - endif - enddo + end if + end if + end do ! - endif + end if ! if (time0 < time .or. is_same(time0, time)) tsrecEarlier => tsrec0 if (time1 > time .or. is_same(time1, time)) tsrecLater => tsrec1 @@ -416,8 +417,8 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time type(ListNodeType), pointer, intent(inout) :: nodeEarlier type(ListNodeType), pointer, intent(inout) :: nodeLater ! -- local @@ -429,17 +430,17 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) type(TimeSeriesRecordType), pointer :: tsrec1 => null() type(TimeSeriesRecordType), pointer :: tsrecEarlier type(TimeSeriesRecordType), pointer :: tsrecLater - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tsrecEarlier => null() tsrecLater => null() nodeEarlier => null() - nodeLater => null() + nodeLater => null() ! if (associated(this%list%firstNode)) then currNode => this%list%firstNode - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -452,14 +453,14 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) currNode => currNode%nextNode else exit - endif + end if else exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -476,8 +477,8 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) time0 = tsrec0%tsrTime else exit - endif - enddo + end if + end do ! ! -- find later record tsNode1 => currNode @@ -492,19 +493,19 @@ subroutine get_surrounding_nodes(this, time, nodeEarlier, nodeLater) time1 = tsrec1%tsrTime else exit - endif - enddo + end if + end do ! - endif + end if ! if (time0 < time .or. is_same(time0, time)) then tsrecEarlier => tsrec0 nodeEarlier => tsNode0 - endif + end if if (time1 > time .or. is_same(time1, time)) then tsrecLater => tsrec1 nodeLater => tsNode1 - endif + end if ! return end subroutine get_surrounding_nodes @@ -526,12 +527,12 @@ logical function read_next_record(this) if (this%tsfile%finishedReading) then read_next_record = .false. return - endif + end if ! read_next_record = this%tsfile%read_tsfile_line() if (.not. read_next_record) then this%tsfile%finishedReading = .true. - endif + end if return ! end function read_next_record @@ -548,25 +549,25 @@ function get_value_at_time(this, time, extendToEndOfSimulation) real(DP) :: get_value_at_time ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time ! time of interest + real(DP), intent(in) :: time ! time of interest logical, intent(in) :: extendToEndOfSimulation ! -- local integer(I4B) :: ierr real(DP) :: ratio, time0, time1, timediff, timediffi, val0, val1, & - valdiff + valdiff type(TimeSeriesRecordType), pointer :: tsrEarlier => null() type(TimeSeriesRecordType), pointer :: tsrLater => null() ! -- formats - 10 format('Error getting value at time ',g10.3,' for time series "',a,'"') +10 format('Error getting value at time ', g10.3, ' for time series "', a, '"') ! ------------------------------------------------------------------------------ ! ierr = 0 - call this%get_surrounding_records(time,tsrEarlier,tsrLater) + call this%get_surrounding_records(time, tsrEarlier, tsrLater) if (associated(tsrEarlier)) then if (associated(tsrLater)) then ! -- values are available for both earlier and later times if (this%iMethod == STEPWISE) then - get_value_at_time = tsrEarlier%tsrValue + get_value_at_time = tsrEarlier%tsrValue elseif (this%iMethod == LINEAR .or. this%iMethod == LINEAREND) then ! -- For get_value_at_time, result is the same for either ! linear method. @@ -575,19 +576,19 @@ function get_value_at_time(this, time, extendToEndOfSimulation) time1 = tsrLater%tsrtime timediff = time1 - time0 timediffi = time - time0 - if (timediff>0) then - ratio = timediffi/timediff + if (timediff > 0) then + ratio = timediffi / timediff else ! -- should not happen if TS does not contain duplicate times ratio = 0.5d0 - endif + end if val0 = tsrEarlier%tsrValue val1 = tsrLater%tsrValue valdiff = val1 - val0 - get_value_at_time = val0 + (ratio*valdiff) + get_value_at_time = val0 + (ratio * valdiff) else ierr = 1 - endif + end if else if (extendToEndOfSimulation .or. is_same(tsrEarlier%tsrTime, time)) then get_value_at_time = tsrEarlier%tsrValue @@ -595,12 +596,12 @@ function get_value_at_time(this, time, extendToEndOfSimulation) ! -- Only earlier time is available, and it is not time of interest; ! however, if method is STEPWISE, use value for earlier time. if (this%iMethod == STEPWISE) then - get_value_at_time = tsrEarlier%tsrValue + get_value_at_time = tsrEarlier%tsrValue else ierr = 1 - endif - endif - endif + end if + end if + end if else if (associated(tsrLater)) then if (is_same(tsrLater%tsrTime, time)) then @@ -608,18 +609,18 @@ function get_value_at_time(this, time, extendToEndOfSimulation) else ! -- only later time is available, and it is not time of interest ierr = 1 - endif + end if else ! -- Neither earlier nor later time is available. ! This should never happen! ierr = 1 - endif - endif + end if + end if ! if (ierr > 0) then - write(errmsg,10) time, trim(this%Name) + write (errmsg, 10) time, trim(this%Name) call store_error(errmsg, terminate=.TRUE.) - endif + end if ! return end function get_value_at_time @@ -637,12 +638,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) real(DP) :: get_integrated_value ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 logical, intent(in) :: extendToEndOfSimulation ! -- local real(DP) :: area, currTime, nextTime, ratio0, ratio1, t0, t01, t1, & - timediff, value, value0, value1, valuediff, currVal, nextVal + timediff, value, value0, value1, valuediff, currVal, nextVal logical :: ldone, lprocess type(ListNodeType), pointer :: tslNodePreceding => null() type(ListNodeType), pointer :: currNode => null(), nextNode => null() @@ -650,8 +651,8 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) type(TimeSeriesRecordType), pointer :: nextRecord => null() class(*), pointer :: currObj => null(), nextObj => null() ! -- formats - 10 format('Error encountered while performing integration', & - ' for time series "',a,'" for time interval: ',g12.5,' to ',g12.5) +10 format('Error encountered while performing integration', & + ' for time series "', a, '" for time interval: ', g12.5, ' to ', g12.5) ! ------------------------------------------------------------------------------ ! value = DZERO @@ -671,12 +672,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) if (.not. associated(currNode%nextNode)) then ! -- try to read the next record if (.not. this%read_next_record()) then - if(.not. extendToEndOfSimulation) then - write(errmsg,10)trim(this%Name),time0,time1 + if (.not. extendToEndOfSimulation) then + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg, terminate=.TRUE.) - endif - endif - endif + end if + end if + end if ! currVal = currRecord%tsrValue lprocess = .false. @@ -692,7 +693,7 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) nextTime = time1 nextVal = currVal lprocess = .true. - endif + end if ! if (lprocess) then ! -- determine lower and upper limits of time span of interest @@ -701,12 +702,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) t0 = currTime else t0 = time0 - endif + end if if (nextTime < time1 .or. is_same(nextTime, time1)) then t1 = nextTime else t1 = time1 - endif + end if ! -- find area of rectangle or trapezoid delimited by t0 and t1 t01 = t1 - t0 select case (this%iMethod) @@ -727,12 +728,12 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) elseif (this%iMethod == LINEAREND) then area = DZERO value = value1 - endif + end if end select ! -- add area to integrated value value = value + area - endif - endif + end if + end if ! ! -- Are we done yet? if (t1 > time1) then @@ -744,24 +745,24 @@ function get_integrated_value(this, time0, time1, extendToEndOfSimulation) if (.not. associated(currNode%nextNode)) then ! -- Not done and no more data, so try to read the next record if (.not. this%read_next_record()) then - write(errmsg,10)trim(this%Name),time0,time1 + write (errmsg, 10) trim(this%Name), time0, time1 call store_error(errmsg, terminate=.TRUE.) - endif + end if elseif (associated(currNode%nextNode)) then currNode => currNode%nextNode - endif - endif - enddo - endif + end if + end if + end do + end if ! get_integrated_value = value if (this%autoDeallocate) then if (associated(tslNodePreceding)) then - if (associated(tslNodePreceding%prevNode))then + if (associated(tslNodePreceding%prevNode)) then call this%list%DeallocateBackward(tslNodePreceding%prevNode) - endif - endif - endif + end if + end if + end if return end function get_integrated_value @@ -778,8 +779,8 @@ function get_average_value(this, time0, time1, extendToEndOfSimulation) real(DP) :: get_average_value ! -- dummy class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time0 - real(DP), intent(in) :: time1 + real(DP), intent(in) :: time0 + real(DP), intent(in) :: time1 logical, intent(in) :: extendToEndOfSimulation ! -- local real(DP) :: timediff, value, valueIntegrated @@ -787,16 +788,17 @@ function get_average_value(this, time0, time1, extendToEndOfSimulation) ! timediff = time1 - time0 if (timediff > 0) then - valueIntegrated = this%get_integrated_value(time0, time1, extendToEndOfSimulation) + valueIntegrated = this%get_integrated_value(time0, time1, & + extendToEndOfSimulation) if (this%iMethod == LINEAREND) then value = valueIntegrated else value = valueIntegrated / timediff - endif + end if else ! -- time0 and time1 are the same value = this%get_value_at_time(time0, extendToEndOfSimulation) - endif + end if get_average_value = value ! return @@ -812,8 +814,8 @@ subroutine get_latest_preceding_node(this, time, tslNode) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesType), intent(inout) :: this - real(DP), intent(in) :: time + class(TimeSeriesType), intent(inout) :: this + real(DP), intent(in) :: time type(ListNodeType), pointer, intent(inout) :: tslNode ! -- local real(DP) :: time0 @@ -821,16 +823,17 @@ subroutine get_latest_preceding_node(this, time, tslNode) type(ListNodeType), pointer :: tsNode0 => null() type(TimeSeriesRecordType), pointer :: tsr => null() type(TimeSeriesRecordType), pointer :: tsrec0 => null() - class(*), pointer :: obj => null() + class(*), pointer :: obj => null() ! ------------------------------------------------------------------------------ ! tslNode => null() if (associated(this%list%firstNode)) then currNode => this%list%firstNode else - call store_error('probable programming error in get_latest_preceding_node', & + call store_error('probable programming error in & + &get_latest_preceding_node', & terminate=.TRUE.) - endif + end if ! ! -- If the next node is earlier than time of interest, advance along ! linked list until the next node is later than time of interest. @@ -843,15 +846,15 @@ subroutine get_latest_preceding_node(this, time, tslNode) currNode => currNode%nextNode else exit - endif + end if else ! -- read another record if (.not. this%read_next_record()) exit - endif + end if else exit - endif - enddo + end if + end do ! if (associated(currNode)) then ! @@ -868,9 +871,9 @@ subroutine get_latest_preceding_node(this, time, tslNode) time0 = tsrec0%tsrTime else exit - endif - enddo - endif + end if + end do + end if ! if (time0 < time .or. is_same(time0, time)) tslNode => tsNode0 ! @@ -890,8 +893,8 @@ subroutine ts_da(this) ! if (associated(this%list)) then call this%list%Clear(.true.) - deallocate(this%list) - endif + deallocate (this%list) + end if ! return end subroutine ts_da @@ -916,7 +919,7 @@ subroutine AddTimeSeriesRecord(this, tsr) return end subroutine AddTimeSeriesRecord - function GetCurrentTimeSeriesRecord(this) result (res) + function GetCurrentTimeSeriesRecord(this) result(res) ! ****************************************************************************** ! GetCurrentTimeSeriesRecord -- get current ts record ! ****************************************************************************** @@ -936,12 +939,12 @@ function GetCurrentTimeSeriesRecord(this) result (res) obj => this%list%GetItem() if (associated(obj)) then res => CastAsTimeSeriesRecordType(obj) - endif + end if ! return end function GetCurrentTimeSeriesRecord - function GetPreviousTimeSeriesRecord(this) result (res) + function GetPreviousTimeSeriesRecord(this) result(res) ! ****************************************************************************** ! GetPreviousTimeSeriesRecord -- get previous ts record ! ****************************************************************************** @@ -961,12 +964,12 @@ function GetPreviousTimeSeriesRecord(this) result (res) obj => this%list%GetPreviousItem() if (associated(obj)) then res => CastAsTimeSeriesRecordType(obj) - endif + end if ! return end function GetPreviousTimeSeriesRecord - function GetNextTimeSeriesRecord(this) result (res) + function GetNextTimeSeriesRecord(this) result(res) ! ****************************************************************************** ! GetNextTimeSeriesRecord -- get next ts record ! ****************************************************************************** @@ -986,12 +989,12 @@ function GetNextTimeSeriesRecord(this) result (res) obj => this%list%GetNextItem() if (associated(obj)) then res => CastAsTimeSeriesRecordType(obj) - endif + end if ! return end function GetNextTimeSeriesRecord - function GetTimeSeriesRecord(this, time, epsi) result (res) + function GetTimeSeriesRecord(this, time, epsi) result(res) ! ****************************************************************************** ! GetTimeSeriesRecord -- get ts record ! ****************************************************************************** @@ -1016,12 +1019,12 @@ function GetTimeSeriesRecord(this, time, epsi) result (res) if (is_same(tsr%tsrTime, time)) then res => tsr exit - endif + end if if (tsr%tsrTime > time) exit else exit - endif - enddo + end if + end do ! return end function GetTimeSeriesRecord @@ -1050,7 +1053,7 @@ subroutine InsertTsr(this, tsr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesType), intent(inout) :: this + class(TimeSeriesType), intent(inout) :: this type(TimeSeriesRecordType), pointer, intent(inout) :: tsr ! -- local double precision :: badtime, time, time0, time1 @@ -1070,16 +1073,16 @@ subroutine InsertTsr(this, tsr) tsrEarlier => CastAsTimeSeriesRecordType(obj) if (associated(tsrEarlier)) then time0 = tsrEarlier%tsrTime - endif - endif + end if + end if ! if (associated(nodeLater)) then obj => nodeLater%GetItem() tsrLater => CastAsTimeSeriesRecordType(obj) if (associated(tsrLater)) then time1 = tsrLater%tsrTime - endif - endif + end if + end if ! if (time0 > badtime) then ! Time0 is valid @@ -1093,17 +1096,17 @@ subroutine InsertTsr(this, tsr) ! No need to insert a time series record, but if existing record ! for time of interest has NODATA as tsrValue, replace tsrValue if (time == time0 .and. tsrEarlier%tsrValue == DNODATA .and. & - tsr%tsrValue /= DNODATA) then + tsr%tsrValue /= DNODATA) then tsrEarlier%tsrValue = tsr%tsrValue elseif (time == time1 .and. tsrLater%tsrValue == DNODATA .and. & tsr%tsrValue /= DNODATA) then tsrLater%tsrValue = tsr%tsrValue - endif - endif + end if + end if else ! Time0 is valid and time1 is invalid. Just add tsr to the list. call this%AddTimeSeriesRecord(tsr) - endif + end if else ! Time0 is invalid, so time1 must be for first node in list if (time1 > badtime) then @@ -1117,18 +1120,18 @@ subroutine InsertTsr(this, tsr) ! for time of interest has NODATA as tsrValue, replace tsrValue if (tsrLater%tsrValue == DNODATA .and. tsr%tsrValue /= DNODATA) then tsrLater%tsrValue = tsr%tsrValue - endif - endif + end if + end if else ! Both time0 and time1 are invalid. Just add tsr to the list. call this%AddTimeSeriesRecord(tsr) - endif - endif + end if + end if ! return end subroutine InsertTsr - function FindLatestTime(this, readToEnd) result (endtime) + function FindLatestTime(this, readToEnd) result(endtime) ! ****************************************************************************** ! FindLatestTime -- find latest time ! ****************************************************************************** @@ -1149,9 +1152,9 @@ function FindLatestTime(this, readToEnd) result (endtime) if (present(readToEnd)) then if (readToEnd) then do while (this%read_next_record()) - enddo - endif - endif + end do + end if + end if ! nrecords = this%list%Count() obj => this%list%GetItem(nrecords) @@ -1170,7 +1173,7 @@ subroutine Clear(this, destroy) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesType), intent(inout) :: this - logical, optional, intent(in) :: destroy + logical, optional, intent(in) :: destroy ! ------------------------------------------------------------------------------ ! call this%list%Clear(destroy) @@ -1197,11 +1200,11 @@ function Count(this) Count = size(this%timeSeries) else Count = 0 - endif + end if return end function Count - function GetTimeSeries(this, indx) result (res) + function GetTimeSeries(this, indx) result(res) ! ****************************************************************************** ! GetTimeSeries -- get ts ! ****************************************************************************** @@ -1218,13 +1221,13 @@ function GetTimeSeries(this, indx) result (res) res => null() if (indx > 0 .and. indx <= this%nTimeSeries) then res => this%timeSeries(indx) - endif + end if return end function GetTimeSeries subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ****************************************************************************** -! Initializetsfile -- Open time-series tsfile file and read options and first +! Initializetsfile -- Open time-series tsfile file and read options and first ! record, which may contain data to define multiple time series. ! ****************************************************************************** ! @@ -1232,9 +1235,9 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ------------------------------------------------------------------------------ ! -- dummy class(TimeSeriesFileType), target, intent(inout) :: this - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: autoDeallocate + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: autoDeallocate ! -- local integer(I4B) :: iMethod, istatus, j, nwords integer(I4B) :: ierr, inunit @@ -1257,7 +1260,7 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! -- Open the time-series tsfile input file this%inunit = GetUnit() inunit = this%inunit - call openfile(inunit,0,filename,'TS6') + call openfile(inunit, 0, filename, 'TS6') ! ! -- Initialize block parser call this%parser%Initialize(this%inunit, this%iout) @@ -1268,20 +1271,20 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ! -- get BEGIN line of ATTRIBUTES block call this%parser%GetBlock('ATTRIBUTES', found, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (ierr /= 0) then ! end of file - errmsg = 'End-of-file encountered while searching for' // & - ' ATTRIBUTES in time-series ' // & - 'input file "' // trim(this%datafile) // '"' + errmsg = 'End-of-file encountered while searching for'// & + ' ATTRIBUTES in time-series '// & + 'input file "'//trim(this%datafile)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() elseif (.not. found) then - errmsg = 'ATTRIBUTES block not found in time-series ' // & - 'tsfile input file "' // trim(this%datafile) // '"' + errmsg = 'ATTRIBUTES block not found in time-series '// & + 'tsfile input file "'//trim(this%datafile)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- parse ATTRIBUTES entries do @@ -1293,12 +1296,13 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) call this%parser%GetStringCaps(keyword) ! ! support either NAME or NAMES as equivalent keywords - if (keyword=='NAMES') keyword = 'NAME' + if (keyword == 'NAMES') keyword = 'NAME' ! - if (keyword /= 'NAME' .and. keyword /= 'METHODS' .and. keyword /= 'SFACS') then + if (keyword /= 'NAME' .and. keyword /= 'METHODS' .and. & + keyword /= 'SFACS') then ! -- get the word following the keyword (the key value) call this%parser%GetStringCaps(keyvalue) - endif + end if ! select case (keyword) case ('NAME') @@ -1308,18 +1312,18 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) this%nTimeSeries = nwords ! -- Allocate the timeSeries array and initialize each ! time series. - allocate(this%timeSeries(this%nTimeSeries)) - do j=1,this%nTimeSeries + allocate (this%timeSeries(this%nTimeSeries)) + do j = 1, this%nTimeSeries call this%timeSeries(j)%initialize_time_series(this, words(j), & - autoDeallocateLocal) - enddo + autoDeallocateLocal) + end do case ('METHOD') if (this%nTimeSeries == 0) then errmsg = 'Error: NAME attribute not provided before METHOD in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if select case (keyvalue) case ('STEPWISE') iMethod = STEPWISE @@ -1328,28 +1332,28 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) case ('LINEAREND') iMethod = LINEAREND case default - errmsg = 'Unknown interpolation method: "' // trim(keyvalue) // '"' + errmsg = 'Unknown interpolation method: "'//trim(keyvalue)//'"' call store_error(errmsg) end select - do j=1,this%nTimeSeries + do j = 1, this%nTimeSeries this%timeSeries(j)%iMethod = iMethod - enddo + end do case ('METHODS') if (this%nTimeSeries == 0) then errmsg = 'Error: NAME attribute not provided before METHODS in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetRemainingLine(line) call ParseLine(line, nwords, words, this%parser%iuactive) if (nwords < this%nTimeSeries) then - errmsg = 'METHODS attribute does not list a method for' // & - ' all time series.' + errmsg = 'METHODS attribute does not list a method for'// & + ' all time series.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - do j=1,this%nTimeSeries + end if + do j = 1, this%nTimeSeries call upcase(words(j)) select case (words(j)) case ('STEPWISE') @@ -1359,48 +1363,48 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) case ('LINEAREND') iMethod = LINEAREND case default - errmsg = 'Unknown interpolation method: "' // trim(words(j)) // '"' + errmsg = 'Unknown interpolation method: "'//trim(words(j))//'"' call store_error(errmsg) end select this%timeSeries(j)%iMethod = iMethod - enddo + end do case ('SFAC') if (this%nTimeSeries == 0) then errmsg = 'NAME attribute not provided before SFAC in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - read(keyvalue,*,iostat=istatus)sfaclocal + end if + read (keyvalue, *, iostat=istatus) sfaclocal if (istatus /= 0) then - errmsg = 'Error reading numeric value from: "' // trim(keyvalue) // '"' + errmsg = 'Error reading numeric value from: "'//trim(keyvalue)//'"' call store_error(errmsg) - endif - do j=1,this%nTimeSeries + end if + do j = 1, this%nTimeSeries this%timeSeries(j)%sfac = sfaclocal - enddo + end do case ('SFACS') if (this%nTimeSeries == 0) then errmsg = 'NAME attribute not provided before SFACS in file: ' & - // trim(filename) + //trim(filename) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif - do j=1,this%nTimeSeries + end if + do j = 1, this%nTimeSeries sfaclocal = this%parser%GetDouble() this%timeSeries(j)%sfac = sfaclocal - enddo + end do case ('AUTODEALLOCATE') - do j=1,this%nTimeSeries + do j = 1, this%nTimeSeries this%timeSeries(j)%autoDeallocate = (keyvalue == 'TRUE') - enddo + end do case default - errmsg = 'Unknown option found in ATTRIBUTES block: "' // & - trim(keyword) // '"' + errmsg = 'Unknown option found in ATTRIBUTES block: "'// & + trim(keyword)//'"' call store_error(errmsg) call this%parser%StoreErrorUnit() end select - enddo + end do ! ! -- Get TIMESERIES block call this%parser%GetBlock('TIMESERIES', found, ierr, & @@ -1408,17 +1412,17 @@ subroutine Initializetsfile(this, filename, iout, autoDeallocate) ! ! -- Read the first line of time-series data if (.not. this%read_tsfile_line()) then - errmsg = 'Error: No time-series data contained in file: ' // & - trim(this%datafile) + errmsg = 'Error: No time-series data contained in file: '// & + trim(this%datafile) call store_error(errmsg) - endif + end if ! ! -- Clean up and return - if (allocated(words)) deallocate(words) + if (allocated(words)) deallocate (words) ! if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! return end subroutine Initializetsfile @@ -1448,20 +1452,20 @@ logical function read_tsfile_line(this) ! -- Check if we've reached the end of the TIMESERIES block if (endOfBlock) then return - endif + end if ! ! -- Get the time tsrTime = this%parser%GetDouble() ! ! -- Construct a new record and append a new node to each time series - tsloop: do i=1,this%nTimeSeries + tsloop: do i = 1, this%nTimeSeries tsrValue = this%parser%GetDouble() if (tsrValue == DNODATA) cycle tsloop ! -- multiply value by sfac tsrValue = tsrValue * this%timeSeries(i)%sfac call ConstructTimeSeriesRecord(tsRecord, tsrTime, tsrValue) call AddTimeSeriesRecordToList(this%timeSeries(i)%list, tsRecord) - enddo tsloop + end do tsloop read_tsfile_line = .true. ! return @@ -1482,16 +1486,16 @@ subroutine tsf_da(this) ! ------------------------------------------------------------------------------ ! n = this%Count() - do i=1,n + do i = 1, n ts => this%GetTimeSeries(i) if (associated(ts)) then call ts%da() ! deallocate(ts) - endif - enddo + end if + end do ! - deallocate(this%timeSeries) - deallocate(this%parser) + deallocate (this%timeSeries) + deallocate (this%parser) ! return end subroutine tsf_da diff --git a/src/Utilities/TimeSeries/TimeSeriesFileList.f90 b/src/Utilities/TimeSeries/TimeSeriesFileList.f90 index 06bcfd1e8ef..f0dbd3a8f42 100644 --- a/src/Utilities/TimeSeries/TimeSeriesFileList.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesFileList.f90 @@ -1,8 +1,8 @@ module TimeSeriesFileListModule use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH - use ListModule, only: ListType + use ConstantsModule, only: LINELENGTH + use ListModule, only: ListType use TimeSeriesModule, only: TimeSeriesFileType, & ConstructTimeSeriesFile, & GetTimeSeriesFileFromList, & @@ -19,13 +19,13 @@ module TimeSeriesFileListModule type(ListType), public :: tsfileList contains ! -- Public procedures - procedure, public :: Add - procedure, public :: Counttsfiles - procedure, public :: CountTimeSeries - procedure, public :: Gettsfile - procedure, public :: Clear - procedure, public :: da => tsfl_da - procedure, public :: add_time_series_tsfile + procedure, public :: Add + procedure, public :: Counttsfiles + procedure, public :: CountTimeSeries + procedure, public :: Gettsfile + procedure, public :: Clear + procedure, public :: da => tsfl_da + procedure, public :: add_time_series_tsfile end type TimeSeriesFileListType contains @@ -87,17 +87,17 @@ function CountTimeSeries(this) ! numtsfiles = this%Counttsfiles() CountTimeSeries = 0 - do i=1,numtsfiles + do i = 1, numtsfiles tsfile => this%Gettsfile(i) if (associated(tsfile)) then CountTimeSeries = CountTimeSeries + tsfile%Count() - endif - enddo + end if + end do ! return end function CountTimeSeries - function Gettsfile(this, indx) result (res) + function Gettsfile(this, indx) result(res) implicit none ! -- dummy class(TimeSeriesFileListType) :: this @@ -115,7 +115,7 @@ end function Gettsfile subroutine add_time_series_tsfile(this, tsfile) implicit none ! -- dummy - class(TimeSeriesFileListType), intent(inout) :: this + class(TimeSeriesFileListType), intent(inout) :: this class(TimeSeriesFileType), pointer, intent(inout) :: tsfile ! -- local ! @@ -132,10 +132,10 @@ subroutine tsfl_da(this) type(TimeSeriesFileType), pointer :: tsf => null() ! n = this%Counttsfiles() - do i=1,n + do i = 1, n tsf => this%Gettsfile(i) call tsf%da() - enddo + end do ! call this%tsfileList%Clear(.true.) ! diff --git a/src/Utilities/TimeSeries/TimeSeriesLink.f90 b/src/Utilities/TimeSeries/TimeSeriesLink.f90 index f755903306f..6379be6daf6 100644 --- a/src/Utilities/TimeSeries/TimeSeriesLink.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesLink.f90 @@ -1,23 +1,23 @@ module TimeSeriesLinkModule use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENBOUNDNAME, LENPACKAGENAME, & - LENTIMESERIESTEXT + use ConstantsModule, only: DZERO, LENBOUNDNAME, LENPACKAGENAME, & + LENTIMESERIESTEXT use InputOutputModule, only: UPCASE - use ListModule, only: ListType - use TimeSeriesModule, only: TimeSeriesType + use ListModule, only: ListType + use TimeSeriesModule, only: TimeSeriesType implicit none private - public :: TimeSeriesLinkType, ConstructTimeSeriesLink, & + public :: TimeSeriesLinkType, ConstructTimeSeriesLink, & GetTimeSeriesLinkFromList, AddTimeSeriesLinkToList private :: CastAsTimeSeriesLinkType type :: TimeSeriesLinkType ! -- Public members - integer(I4B), public :: IRow = 0 ! row index (2nd dim) in bound or auxval array - integer(I4B), public :: JCol = 0 ! column index (1st dim) in bound or auxval array + integer(I4B), public :: IRow = 0 ! row index (2nd dim) in bound or auxval array + integer(I4B), public :: JCol = 0 ! column index (1st dim) in bound or auxval array integer(I4B), public :: Iprpak = 1 ! BndElement can point to an element in either the bound or auxval ! array of BndType, or any other double precision variable or array @@ -53,7 +53,7 @@ subroutine ConstructTimeSeriesLink(newTsLink, timeSeries, pkgName, & ! -- local character(len=LENPACKAGENAME) :: pkgNameTemp ! - allocate(newTsLink) + allocate (newTsLink) ! ! Store package name as all caps pkgNameTemp = pkgName @@ -68,7 +68,7 @@ subroutine ConstructTimeSeriesLink(newTsLink, timeSeries, pkgName, & ! if (present(text)) then newTsLink%Text = text - endif + end if ! return end subroutine ConstructTimeSeriesLink @@ -110,7 +110,7 @@ end function GetTimeSeriesLinkFromList subroutine AddTimeSeriesLinkToList(list, tslink) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeSeriesLinkType), pointer, intent(inout) :: tslink ! -- local class(*), pointer :: obj diff --git a/src/Utilities/TimeSeries/TimeSeriesManager.f90 b/src/Utilities/TimeSeries/TimeSeriesManager.f90 index 065831a4bf3..157564a863f 100644 --- a/src/Utilities/TimeSeries/TimeSeriesManager.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesManager.f90 @@ -1,43 +1,43 @@ module TimeSeriesManagerModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENPACKAGENAME, MAXCHARLEN, & - LINELENGTH, LENTIMESERIESNAME - use HashTableModule, only: HashTableType, hash_table_cr, & - hash_table_da - use InputOutputModule, only: same_word, UPCASE - use ListModule, only: ListType - use SimModule, only: store_error, store_error_unit - use TdisModule, only: delt, kper, kstp, totim, totimc, & - totimsav - use TimeSeriesFileListModule, only: TimeSeriesFileListType - use TimeSeriesLinkModule, only: TimeSeriesLinkType, & - ConstructTimeSeriesLink, & - GetTimeSeriesLinkFromList, & - AddTimeSeriesLinkToList - use TimeSeriesModule, only: TimeSeriesContainerType, & - TimeSeriesFileType, & - TimeSeriesType + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENPACKAGENAME, MAXCHARLEN, & + LINELENGTH, LENTIMESERIESNAME + use HashTableModule, only: HashTableType, hash_table_cr, & + hash_table_da + use InputOutputModule, only: same_word, UPCASE + use ListModule, only: ListType + use SimModule, only: store_error, store_error_unit + use TdisModule, only: delt, kper, kstp, totim, totimc, & + totimsav + use TimeSeriesFileListModule, only: TimeSeriesFileListType + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + ConstructTimeSeriesLink, & + GetTimeSeriesLinkFromList, & + AddTimeSeriesLinkToList + use TimeSeriesModule, only: TimeSeriesContainerType, & + TimeSeriesFileType, & + TimeSeriesType implicit none private - public :: TimeSeriesManagerType, read_value_or_time_series, & - read_value_or_time_series_adv, & + public :: TimeSeriesManagerType, read_value_or_time_series, & + read_value_or_time_series_adv, & var_timeseries, tsmanager_cr type TimeSeriesManagerType - integer(I4B), public :: iout = 0 ! output unit number - type(TimeSeriesFileListType), pointer, public :: tsfileList => null() ! list of ts files objs - type(ListType), pointer, public :: boundTsLinks => null() ! links to bound and aux - integer(I4B) :: numtsfiles = 0 ! number of ts files - character(len=MAXCHARLEN), allocatable, dimension(:) :: tsfiles ! list of ts files - logical, private :: removeTsLinksOnCompletion = .false. ! flag indicating whether time series links should be removed in ad() once simulation time passes the end of the time series - logical, private :: extendTsToEndOfSimulation = .false. ! flag indicating whether time series should be extended to provide their final value for all times after the series end time - type(ListType), pointer, private :: auxvarTsLinks => null() ! list of aux links - type(HashTableType), pointer, private :: BndTsHashTable => null() ! hash of ts to tsobj - type(TimeSeriesContainerType), allocatable, dimension(:), & - private :: TsContainers + integer(I4B), public :: iout = 0 ! output unit number + type(TimeSeriesFileListType), pointer, public :: tsfileList => null() ! list of ts files objs + type(ListType), pointer, public :: boundTsLinks => null() ! links to bound and aux + integer(I4B) :: numtsfiles = 0 ! number of ts files + character(len=MAXCHARLEN), allocatable, dimension(:) :: tsfiles ! list of ts files + logical, private :: removeTsLinksOnCompletion = .false. ! flag indicating whether time series links should be removed in ad() once simulation time passes the end of the time series + logical, private :: extendTsToEndOfSimulation = .false. ! flag indicating whether time series should be extended to provide their final value for all times after the series end time + type(ListType), pointer, private :: auxvarTsLinks => null() ! list of aux links + type(HashTableType), pointer, private :: BndTsHashTable => null() ! hash of ts to tsobj + type(TimeSeriesContainerType), allocatable, dimension(:), & + private :: TsContainers contains ! -- Public procedures procedure, public :: tsmanager_df @@ -53,9 +53,10 @@ module TimeSeriesManagerModule procedure, private :: make_link end type TimeSeriesManagerType - contains - - subroutine tsmanager_cr(this, iout, removeTsLinksOnCompletion, extendTsToEndOfSimulation) +contains + + subroutine tsmanager_cr(this, iout, removeTsLinksOnCompletion, & + extendTsToEndOfSimulation) ! ****************************************************************************** ! tsmanager_cr -- create the tsmanager ! ****************************************************************************** @@ -70,20 +71,20 @@ subroutine tsmanager_cr(this, iout, removeTsLinksOnCompletion, extendTsToEndOfSi ! ------------------------------------------------------------------------------ ! this%iout = iout - if(present(removeTsLinksOnCompletion)) then + if (present(removeTsLinksOnCompletion)) then this%removeTsLinksOnCompletion = removeTsLinksOnCompletion - endif - if(present(extendTsToEndOfSimulation)) then + end if + if (present(extendTsToEndOfSimulation)) then this%extendTsToEndOfSimulation = extendTsToEndOfSimulation - endif - allocate(this%boundTsLinks) - allocate(this%auxvarTsLinks) - allocate(this%tsfileList) - allocate(this%tsfiles(1000)) + end if + allocate (this%boundTsLinks) + allocate (this%auxvarTsLinks) + allocate (this%tsfileList) + allocate (this%tsfiles(1000)) ! return end subroutine tsmanager_cr - + subroutine tsmanager_df(this) ! ****************************************************************************** ! tsmanager_df -- define @@ -98,12 +99,12 @@ subroutine tsmanager_df(this) ! if (this%numtsfiles > 0) then call this%HashBndTimeSeries() - endif + end if ! ! -- return return end subroutine tsmanager_df - + subroutine add_tsfile(this, fname, inunit) ! ****************************************************************************** ! add_tsfile -- add a time series file to this manager @@ -128,29 +129,29 @@ subroutine add_tsfile(this, fname, inunit) if (this%numtsfiles > 0) then do i = 1, this%numtsfiles if (this%tsfiles(i) == fname) then - call store_error('Found duplicate time-series file name: ' // trim(fname)) + call store_error('Found duplicate time-series file name: '//trim(fname)) call store_error_unit(inunit) - endif - enddo - endif + end if + end do + end if ! ! -- Save fname this%numtsfiles = this%numtsfiles + 1 isize = size(this%tsfiles) if (this%numtsfiles > isize) then call ExpandArray(this%tsfiles, 1000) - endif + end if this%tsfiles(this%numtsfiles) = fname ! - ! -- + ! -- call this%tsfileList%Add(fname, this%iout, tsfile) ! return end subroutine add_tsfile - + subroutine tsmgr_ad(this) ! ****************************************************************************** -! tsmgr_ad -- time step (or subtime step) advance. Call this each time step or +! tsmgr_ad -- time step (or subtime step) advance. Call this each time step or ! subtime step. ! ****************************************************************************** ! @@ -163,15 +164,19 @@ subroutine tsmgr_ad(this) type(TimeSeriesType), pointer :: timeseries => null() integer(I4B) :: i, nlinks, nauxlinks real(DP) :: begintime, endtime, tsendtime - character(len=LENPACKAGENAME+2) :: pkgID + character(len=LENPACKAGENAME + 2) :: pkgID ! formats - character(len=*),parameter :: fmt5 = & - &"(/,'Time-series controlled values in stress period: ', i0, & - &', time step ', i0, ':')" - 10 format(a,' package: Boundary ',i0,', entry ',i0, ' value from time series "',a,'" = ',g12.5) - 15 format(a,' package: Boundary ',i0,', entry ',i0,' value from time series "',a,'" = ',g12.5,' (',a,')') - 20 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5) - 25 format(a,' package: Boundary ',i0,', ',a,' value from time series "',a,'" = ',g12.5,' (',a,')') + character(len=*), parameter :: fmt5 = & + "(/,'Time-series controlled values in stress period: ', i0, & + &', time step ', i0, ':')" +10 format(a, ' package: Boundary ', i0, ', entry ', i0, & + ' value from time series "', a, '" = ', g12.5) +15 format(a, ' package: Boundary ', i0, ', entry ', i0, & + ' value from time series "', a, '" = ', g12.5, ' (', a, ')') +20 format(a, ' package: Boundary ', i0, ', ', a, & + ' value from time series "', a, '" = ', g12.5) +25 format(a, ' package: Boundary ', i0, ', ', a, & + ' value from time series "', a, '" = ', g12.5, ' (', a, ')') ! ------------------------------------------------------------------------------ ! ! -- Initialize time variables @@ -187,7 +192,7 @@ subroutine tsmgr_ad(this) ! appropriate time series. Need to do auxvartslinks ! first because they may be a multiplier column i = 1 - do while(i <= nauxlinks) + do while (i <= nauxlinks) tsLink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) timeseries => tsLink%timeSeries ! @@ -198,50 +203,51 @@ subroutine tsmgr_ad(this) call this%auxvarTsLinks%RemoveNode(i, .TRUE.) nauxlinks = this%auxvartslinks%Count() cycle - endif - endif + end if + end if ! if (i == 1) then if (tsLink%Iprpak == 1) then - write(this%iout, fmt5) kper, kstp - endif - endif - tsLink%BndElement = timeseries%GetValue(begintime, endtime, this%extendTsToEndOfSimulation) + write (this%iout, fmt5) kper, kstp + end if + end if + tsLink%BndElement = timeseries%GetValue(begintime, endtime, & + this%extendTsToEndOfSimulation) ! ! -- Write time series values to output file if (tsLink%Iprpak == 1) then - pkgID = '"' // trim(tsLink%PackageName) // '"' + pkgID = '"'//trim(tsLink%PackageName)//'"' if (tsLink%Text == '') then if (tsLink%BndName == '') then - write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 10) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif + write (this%iout, 15) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if else if (tsLink%BndName == '') then - write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 20) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - endif - endif + write (this%iout, 25) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if + end if + end if ! i = i + 1 - enddo + end do ! ! -- Iterate through boundtslinks and replace specified ! elements of bound with average value obtained from ! appropriate time series. (For list-type packages) i = 1 - do while(i <= nlinks) + do while (i <= nlinks) tsLink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) timeseries => tsLink%timeSeries ! @@ -252,68 +258,69 @@ subroutine tsmgr_ad(this) call this%boundTsLinks%RemoveNode(i, .TRUE.) nlinks = this%boundTsLinks%Count() cycle - endif - endif + end if + end if ! if (i == 1 .and. nauxlinks == 0) then if (tsLink%Iprpak == 1) then - write(this%iout, fmt5) kper, kstp - endif - endif + write (this%iout, fmt5) kper, kstp + end if + end if ! this part needs to be different for MAW because MAW does not use ! bound array for well rate (although rate is stored in ! this%bound(4,ibnd)), it uses this%mawwells(n)%rate%value if (tsLink%UseDefaultProc) then timeseries => tsLink%timeSeries - tsLink%BndElement = timeseries%GetValue(begintime, endtime, this%extendTsToEndOfSimulation) + tsLink%BndElement = timeseries%GetValue(begintime, endtime, & + this%extendTsToEndOfSimulation) ! - ! -- If multiplier is active and it applies to this element, + ! -- If multiplier is active and it applies to this element, ! do the multiplication. This must be done after the auxlinks ! have been calculated in case iauxmultcol is being used. if (associated(tsLink%RMultiplier)) then tsLink%BndElement = tsLink%BndElement * tsLink%RMultiplier - endif + end if ! ! -- Write time series values to output files if (tsLink%Iprpak == 1) then - pkgID = '"' // trim(tsLink%PackageName) // '"' + pkgID = '"'//trim(tsLink%PackageName)//'"' if (tsLink%Text == '') then if (tsLink%BndName == '') then - write(this%iout,10)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 10) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,15)trim(pkgID), tsLink%IRow, tsLink%JCol, & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif + write (this%iout, 15) trim(pkgID), tsLink%IRow, tsLink%JCol, & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if else if (tsLink%BndName == '') then - write(this%iout,20)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement + write (this%iout, 20) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement else - write(this%iout,25)trim(pkgID), tsLink%IRow, trim(tsLink%Text), & - trim(tsLink%timeSeries%Name), & - tsLink%BndElement, trim(tsLink%BndName) - endif - endif - endif + write (this%iout, 25) trim(pkgID), tsLink%IRow, trim(tsLink%Text), & + trim(tsLink%timeSeries%Name), & + tsLink%BndElement, trim(tsLink%BndName) + end if + end if + end if ! ! -- If conversion from flux to flow is required, multiply by cell area if (tsLink%ConvertFlux) then tsLink%BndElement = tsLink%BndElement * tsLink%CellArea - endif - endif + end if + end if ! i = i + 1 - enddo + end do ! ! -- Finish with ending line if (nlinks + nauxlinks > 0) then if (tsLink%Iprpak == 1) then - write(this%iout,'()') - endif + write (this%iout, '()') + end if end if ! return @@ -333,22 +340,22 @@ subroutine tsmgr_da(this) ! ! -- Deallocate time-series links in boundTsLinks call this%boundTsLinks%Clear(.true.) - deallocate(this%boundTsLinks) + deallocate (this%boundTsLinks) ! ! -- Deallocate time-series links in auxvarTsLinks call this%auxvarTsLinks%Clear(.true.) - deallocate(this%auxvarTsLinks) + deallocate (this%auxvarTsLinks) ! ! -- Deallocate tsfileList call this%tsfileList%da() - deallocate(this%tsfileList) + deallocate (this%tsfileList) ! ! -- Deallocate the hash table if (associated(this%BndTsHashTable)) then call hash_table_da(this%BndTsHashTable) end if ! - deallocate(this%tsfiles) + deallocate (this%tsfiles) ! return end subroutine tsmgr_da @@ -365,7 +372,7 @@ subroutine Reset(this, pkgName) class(TimeSeriesManagerType) :: this character(len=*), intent(in) :: pkgName ! -- local - integer(I4B) :: i, nlinks + integer(I4B) :: i, nlinks type(TimeSeriesLinkType), pointer :: tslink ! ------------------------------------------------------------------------------ ! Zero out values for time-series controlled stresses. @@ -376,34 +383,34 @@ subroutine Reset(this, pkgName) ! ! Reassign all linked elements to zero nlinks = this%boundTsLinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) if (associated(tslink)) then if (tslink%PackageName == pkgName) then tslink%BndElement = DZERO - endif - endif - enddo + end if + end if + end do ! ! Remove links belonging to calling package nlinks = this%boundTsLinks%Count() - do i=nlinks,1,-1 + do i = nlinks, 1, -1 tslink => GetTimeSeriesLinkFromList(this%boundTsLinks, i) if (associated(tslink)) then if (tslink%PackageName == pkgName) then call this%boundTsLinks%RemoveNode(i, .true.) - endif - endif - enddo + end if + end if + end do nlinks = this%auxvarTsLinks%Count() - do i=nlinks,1,-1 - tslink => GetTimeSeriesLinkFromList(this%auxvarTsLinks,i) + do i = nlinks, 1, -1 + tslink => GetTimeSeriesLinkFromList(this%auxvarTsLinks, i) if (associated(tslink)) then if (tslink%PackageName == pkgName) then call this%auxvarTsLinks%RemoveNode(i, .true.) - endif - endif - enddo + end if + end if + end do ! return end subroutine Reset @@ -411,22 +418,22 @@ end subroutine Reset subroutine make_link(this, timeSeries, pkgName, auxOrBnd, bndElem, & irow, jcol, iprpak, tsLink, text, bndName) ! ****************************************************************************** -! make_link -- +! make_link -- ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesManagerType), intent(inout) :: this - type(TimeSeriesType), pointer, intent(inout) :: timeSeries - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - real(DP), pointer, intent(inout) :: bndElem - integer(I4B), intent(in) :: irow, jcol - integer(I4B), intent(in) :: iprpak + class(TimeSeriesManagerType), intent(inout) :: this + type(TimeSeriesType), pointer, intent(inout) :: timeSeries + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + real(DP), pointer, intent(inout) :: bndElem + integer(I4B), intent(in) :: irow, jcol + integer(I4B), intent(in) :: iprpak type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink - character(len=*), intent(in) :: text - character(len=*), intent(in) :: bndName + character(len=*), intent(in) :: text + character(len=*), intent(in) :: bndName ! -- local ! ------------------------------------------------------------------------------ ! @@ -440,17 +447,17 @@ subroutine make_link(this, timeSeries, pkgName, auxOrBnd, bndElem, & call AddTimeSeriesLinkToList(this%auxvarTsLinks, tsLink) else call store_error('programmer error in make_link', terminate=.TRUE.) - endif + end if tsLink%Text = text tsLink%BndName = bndName - endif + end if ! return end subroutine make_link function GetLink(this, auxOrBnd, indx) result(tsLink) ! ****************************************************************************** -! GetLink -- +! GetLink -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -458,7 +465,7 @@ function GetLink(this, auxOrBnd, indx) result(tsLink) ! -- dummy class(TimeSeriesManagerType) :: this character(len=3), intent(in) :: auxOrBnd - integer(I4B), intent(in) :: indx + integer(I4B), intent(in) :: indx type(TimeSeriesLinkType), pointer :: tsLink ! -- local type(ListType), pointer :: list @@ -476,14 +483,14 @@ function GetLink(this, auxOrBnd, indx) result(tsLink) ! if (associated(list)) then tsLink => GetTimeSeriesLinkFromList(list, indx) - endif + end if ! return end function GetLink function CountLinks(this, auxOrBnd) ! ****************************************************************************** -! CountLinks -- +! CountLinks -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -500,21 +507,21 @@ function CountLinks(this, auxOrBnd) CountLinks = this%boundTsLinks%Count() elseif (auxOrBnd == 'AUX') then CountLinks = this%auxvarTsLinks%count() - endif + end if ! return end function CountLinks - function get_time_series(this, name) result (res) + function get_time_series(this, name) result(res) ! ****************************************************************************** -! get_time_series -- +! get_time_series -- ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(TimeSeriesManagerType) :: this - character(len=*), intent(in) :: name + class(TimeSeriesManagerType) :: this + character(len=*), intent(in) :: name ! -- result type(TimeSeriesType), pointer :: res ! -- local @@ -527,14 +534,14 @@ function get_time_series(this, name) result (res) indx = this%BndTsHashTable%get_index(name) if (indx > 0) then res => this%TsContainers(indx)%timeSeries - endif + end if ! return end function get_time_series subroutine HashBndTimeSeries(this) ! ****************************************************************************** -! HashBndTimeSeries -- +! HashBndTimeSeries -- ! Store all boundary (stress) time series links in ! TsContainers and construct hash table BndTsHashTable. ! ****************************************************************************** @@ -542,7 +549,7 @@ subroutine HashBndTimeSeries(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class (TimeSeriesManagerType), intent(inout) :: this + class(TimeSeriesManagerType), intent(inout) :: this ! -- local integer(I4B) :: i, j, k, numtsfiles, numts character(len=LENTIMESERIESNAME) :: name @@ -554,7 +561,7 @@ subroutine HashBndTimeSeries(this) ! ! Allocate the TsContainers array to accommodate all time-series links. numts = this%tsfileList%CountTimeSeries() - allocate(this%TsContainers(numts)) + allocate (this%TsContainers(numts)) ! ! Store a pointer to each time series in the TsContainers array ! and put its key (time-series name) and index in the hash table. @@ -563,51 +570,51 @@ subroutine HashBndTimeSeries(this) do i = 1, numtsfiles tsfile => this%tsfileList%Gettsfile(i) numts = tsfile%Count() - do j=1,numts + do j = 1, numts k = k + 1 this%TsContainers(k)%timeSeries => tsfile%GetTimeSeries(j) if (associated(this%TsContainers(k)%timeSeries)) then name = this%TsContainers(k)%timeSeries%Name call this%BndTsHashTable%add_entry(name, k) - endif - enddo - enddo + end if + end do + end do ! return end subroutine HashBndTimeSeries ! -- Non-type-bound procedures - subroutine read_value_or_time_series(textInput, ii, jj, bndElem, & - pkgName, auxOrBnd, tsManager, iprpak, tsLink) + subroutine read_value_or_time_series(textInput, ii, jj, bndElem, pkgName, & + auxOrBnd, tsManager, iprpak, tsLink) ! ****************************************************************************** -! read_value_or_time_series -- +! read_value_or_time_series -- ! Call this subroutine if the time-series link is available or needed. ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - character(len=*), intent(in) :: textInput - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - real(DP), pointer, intent(inout) :: bndElem - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: textInput + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + real(DP), pointer, intent(inout) :: bndElem + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + type(TimeSeriesManagerType), intent(inout) :: tsManager + integer(I4B), intent(in) :: iprpak type(TimeSeriesLinkType), pointer, intent(inout) :: tsLink ! -- local - type(TimeSeriesType), pointer :: timeseries => null() + type(TimeSeriesType), pointer :: timeseries => null() type(TimeSeriesLinkType), pointer :: tslTemp => null() - integer(I4B) :: i, istat, nlinks - real(DP) :: r + integer(I4B) :: i, istat, nlinks + real(DP) :: r character(len=LINELENGTH) :: errmsg character(len=LENTIMESERIESNAME) :: tsNameTemp logical :: found ! ------------------------------------------------------------------------------ ! - read (textInput,*,iostat=istat) r + read (textInput, *, iostat=istat) r if (istat == 0) then bndElem = r else @@ -621,53 +628,54 @@ subroutine read_value_or_time_series(textInput, ii, jj, bndElem, & if (associated(timeseries)) then ! -- Assign value from time series to current ! array element - r = timeseries%GetValue(totimsav, totim, tsManager%extendTsToEndOfSimulation) + r = timeseries%GetValue(totimsav, totim, & + tsManager%extendTsToEndOfSimulation) bndElem = r ! Look to see if this array element already has a time series ! linked to it. If not, make a link to it. nlinks = tsManager%CountLinks(auxOrBnd) found = .false. - searchlinks: do i=1,nlinks + searchlinks: do i = 1, nlinks tslTemp => tsManager%GetLink(auxOrBnd, i) if (tslTemp%PackageName == pkgName) then - ! -- Check ii, jj against iRow, jCol stored in link - if (tslTemp%IRow==ii .and. tslTemp%JCol==jj) then - ! -- This array element is already linked to a time series. - tsLink => tslTemp - found = .true. - exit searchlinks - endif - endif - enddo searchlinks + ! -- Check ii, jj against iRow, jCol stored in link + if (tslTemp%IRow == ii .and. tslTemp%JCol == jj) then + ! -- This array element is already linked to a time series. + tsLink => tslTemp + found = .true. + exit searchlinks + end if + end if + end do searchlinks if (.not. found) then ! -- Link was not found. Make one and add it to the list. - call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & + call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & ii, jj, iprpak, tsLink, '', '') - endif + end if else - errmsg = 'Error in list input. Expected numeric value or ' // & - "time-series name, but found '" // trim(textInput) // "'." + errmsg = 'Error in list input. Expected numeric value or '// & + "time-series name, but found '"//trim(textInput)//"'." call store_error(errmsg) - endif - endif + end if + end if end subroutine read_value_or_time_series - subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & + subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & auxOrBnd, tsManager, iprpak, varName) ! ****************************************************************************** -! read_value_or_time_series_adv -- Call this subroutine from advanced +! read_value_or_time_series_adv -- Call this subroutine from advanced ! packages to define timeseries link for a variable (varName). ! ! -- Arguments are as follows: ! textInput : string that is either a float or a string name -! ii : column number -! jj : row number -! bndElem : pointer to a position in an array in package pkgName +! ii : column number +! jj : row number +! bndElem : pointer to a position in an array in package pkgName ! pkgName : package name ! auxOrBnd : 'AUX' or 'BND' keyword ! tsManager : timeseries manager object for package ! iprpak : integer flag indicating if interpolated timeseries values -! should be printed to package iout during TsManager%ad() +! should be printed to package iout during TsManager%ad() ! varName : variable name ! ! ****************************************************************************** @@ -675,22 +683,22 @@ subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - character(len=*), intent(in) :: textInput - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - real(DP), pointer, intent(inout) :: bndElem - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd + character(len=*), intent(in) :: textInput + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + real(DP), pointer, intent(inout) :: bndElem + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: iprpak - character(len=*), intent(in) :: varName + integer(I4B), intent(in) :: iprpak + character(len=*), intent(in) :: varName ! -- local integer(I4B) :: istat real(DP) :: v character(len=LINELENGTH) :: errmsg character(len=LENTIMESERIESNAME) :: tsNameTemp logical :: found - type(TimeSeriesType), pointer :: timeseries => null() + type(TimeSeriesType), pointer :: timeseries => null() type(TimeSeriesLinkType), pointer :: tsLink => null() ! ------------------------------------------------------------------------------ ! @@ -704,10 +712,10 @@ subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & bndElem = v ! ! -- remove existing link if it exists for this boundary element - found = remove_existing_link(tsManager, ii, jj, pkgName, & + found = remove_existing_link(tsManager, ii, jj, pkgName, & auxOrBnd, varName) - ! - ! -- timeseries + ! + ! -- timeseries else ! ! -- attempt to read numeric value from textInput failed. @@ -724,37 +732,38 @@ subroutine read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, & if (associated(timeseries)) then ! ! -- Assign average value from time series to current array element - v = timeseries%GetValue(totimsav, totim, tsManager%extendTsToEndOfSimulation) + v = timeseries%GetValue(totimsav, totim, & + tsManager%extendTsToEndOfSimulation) bndElem = v ! ! -- remove existing link if it exists for this boundary element - found = remove_existing_link(tsManager, ii, jj, & + found = remove_existing_link(tsManager, ii, jj, & pkgName, auxOrBnd, varName) ! ! -- Add link to the list. - call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & + call tsManager%make_link(timeseries, pkgName, auxOrBnd, bndElem, & ii, jj, iprpak, tsLink, varName, '') - ! - ! -- not a valid timeseries name + ! + ! -- not a valid timeseries name else - errmsg = 'Error in list input. Expected numeric value or ' // & - "time-series name, but found '" // trim(textInput) // "'." + errmsg = 'Error in list input. Expected numeric value or '// & + "time-series name, but found '"//trim(textInput)//"'." call store_error(errmsg) end if end if return end subroutine read_value_or_time_series_adv -! +! ! -- private subroutines - function remove_existing_link(tsManager, ii, jj, & + function remove_existing_link(tsManager, ii, jj, & pkgName, auxOrBnd, varName) result(found) ! ****************************************************************************** ! remove_existing_link -- remove an existing timeseries link if it is defined. ! ! -- Arguments are as follows: ! tsManager : timeseries manager object for package -! ii : column number -! jj : row number +! ii : column number +! jj : row number ! pkgName : package name ! auxOrBnd : 'AUX' or 'BND' keyword ! varName : variable name @@ -767,11 +776,11 @@ function remove_existing_link(tsManager, ii, jj, & logical :: found ! -- dummy type(TimeSeriesManagerType), intent(inout) :: tsManager - integer(I4B), intent(in) :: ii - integer(I4B), intent(in) :: jj - character(len=*), intent(in) :: pkgName - character(len=3), intent(in) :: auxOrBnd - character(len=*), intent(in) :: varName + integer(I4B), intent(in) :: ii + integer(I4B), intent(in) :: jj + character(len=*), intent(in) :: pkgName + character(len=3), intent(in) :: auxOrBnd + character(len=*), intent(in) :: varName ! -- local integer(I4B) :: i integer(I4B) :: nlinks @@ -786,12 +795,12 @@ function remove_existing_link(tsManager, ii, jj, & csearchlinks: do i = 1, nlinks tslTemp => tsManager%GetLink(auxOrBnd, i) ! - ! -- Check ii against iRow, jj against jCol, and varName + ! -- Check ii against iRow, jj against jCol, and varName ! against Text member of link if (tslTemp%PackageName == pkgName) then ! ! -- This array element is already linked to a time series. - if (tslTemp%IRow == ii .and. tslTemp%JCol == jj .and. & + if (tslTemp%IRow == ii .and. tslTemp%JCol == jj .and. & same_word(tslTemp%Text, varName)) then found = .TRUE. removeLink = i diff --git a/src/Utilities/TimeSeries/TimeSeriesRecord.f90 b/src/Utilities/TimeSeries/TimeSeriesRecord.f90 index b161f70d267..8bfb1bc735c 100644 --- a/src/Utilities/TimeSeries/TimeSeriesRecord.f90 +++ b/src/Utilities/TimeSeries/TimeSeriesRecord.f90 @@ -1,5 +1,5 @@ module TimeSeriesRecordModule - + use KindModule, only: DP, I4B use ListModule, only: ListType @@ -21,7 +21,7 @@ subroutine ConstructTimeSeriesRecord(newTsRecord, time, value) type(TimeSeriesRecordType), pointer, intent(out) :: newTsRecord real(DP), intent(in) :: time, value ! - allocate(newTsRecord) + allocate (newTsRecord) newTsRecord%tsrTime = time newTsRecord%tsrValue = value return @@ -46,7 +46,7 @@ end function CastAsTimeSeriesRecordType subroutine AddTimeSeriesRecordToList(list, tsrecord) implicit none ! -- dummy - type(ListType), intent(inout) :: list + type(ListType), intent(inout) :: list type(TimeSeriesRecordType), pointer, intent(inout) :: tsrecord ! -- local class(*), pointer :: obj => null() diff --git a/src/Utilities/Timer.f90 b/src/Utilities/Timer.f90 index 01b73632c8d..14358101ac4 100644 --- a/src/Utilities/Timer.f90 +++ b/src/Utilities/Timer.f90 @@ -1,5 +1,5 @@ module TimerModule - + use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, DZERO use GenericUtilitiesModule, only: sim_message @@ -9,9 +9,9 @@ module TimerModule public :: elapsed_time public :: code_timer integer(I4B), dimension(8) :: ibdt - - contains - + +contains + subroutine start_time() ! ****************************************************************************** ! Start simulation timer @@ -24,20 +24,20 @@ subroutine start_time() character(len=LINELENGTH) :: line integer(I4B) :: i ! -- format - character(len=*), parameter :: fmtdt = & - "(1X,'Run start date and time (yyyy/mm/dd hh:mm:ss): ', & + character(len=*), parameter :: fmtdt = & + "(1X,'Run start date and time (yyyy/mm/dd hh:mm:ss): ', & &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" ! ------------------------------------------------------------------------------ - ! + ! ! -- Get current date and time, assign to IBDT, and write to screen call date_and_time(values=ibdt) - write(line, fmtdt) (ibdt(i), i = 1, 3), (ibdt(i), i = 5, 7) + write (line, fmtdt) (ibdt(i), i=1, 3), (ibdt(i), i=5, 7) call sim_message(line, skipafter=1) ! ! -- return return end subroutine start_time - + SUBROUTINE elapsed_time(iout, iprtim) ! ****************************************************************************** ! Get end time and calculate elapsed time @@ -56,111 +56,111 @@ SUBROUTINE elapsed_time(iout, iprtim) integer(I4B) :: ndays, leap, ibd, ied, mb, me, nm, mc, m integer(I4B) :: nhours, nmins, nsecs, msecs, nrsecs real(DP) :: elsec, rsecs - DATA IDPM/31,28,31,30,31,30,31,31,30,31,30,31/ ! Days per month - DATA NSPD/86400/ ! Seconds per day + DATA IDPM/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ ! Days per month + DATA NSPD/86400/ ! Seconds per day ! -- format - character(len=*), parameter :: fmtdt = & - "(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & + character(len=*), parameter :: fmtdt = & + "(1X,'Run end date and time (yyyy/mm/dd hh:mm:ss): ', & &I4,'/',I2.2,'/',I2.2,1X,I2,':',I2.2,':',I2.2)" ! ------------------------------------------------------------------------------ ! ! Get current date and time, assign to IEDT, and write. - CALL DATE_AND_TIME(VALUES=IEDT) - ! - ! -- write elapsed time to stdout - write(line,fmtdt) (IEDT(I),I=1,3),(IEDT(I),I=5,7) - call sim_message(line, skipbefore=1) - ! - ! -- write elapsted time to iout - IF(IPRTIM.GT.0) THEN - call sim_message(line, iunit=iout, skipbefore=1) - END IF + CALL DATE_AND_TIME(VALUES=IEDT) + ! + ! -- write elapsed time to stdout + write (line, fmtdt) (IEDT(I), I=1, 3), (IEDT(I), I=5, 7) + call sim_message(line, skipbefore=1) + ! + ! -- write elapsted time to iout + IF (IPRTIM .GT. 0) THEN + call sim_message(line, iunit=iout, skipbefore=1) + END IF ! ! Calculate elapsed time in days and seconds - NDAYS=0 - LEAP=0 - IF (MOD(IEDT(1),4).EQ.0) LEAP = 1 - IBD = IBDT(3) ! BEGIN DAY - IED = IEDT(3) ! END DAY + NDAYS = 0 + LEAP = 0 + IF (MOD(IEDT(1), 4) .EQ. 0) LEAP = 1 + IBD = IBDT(3) ! BEGIN DAY + IED = IEDT(3) ! END DAY ! FIND DAYS - IF (IBDT(2).NE.IEDT(2)) THEN + IF (IBDT(2) .NE. IEDT(2)) THEN ! MONTHS DIFFER - MB = IBDT(2) ! BEGIN MONTH - ME = IEDT(2) ! END MONTH - NM = ME-MB+1 ! NUMBER OF MONTHS TO LOOK AT - IF (MB.GT.ME) NM = NM+12 - MC=MB-1 - DO M=1,NM - MC=MC+1 ! MC IS CURRENT MONTH - IF (MC.EQ.13) MC = 1 - IF (MC.EQ.MB) THEN - NDAYS = NDAYS+IDPM(MC)-IBD - IF (MC.EQ.2) NDAYS = NDAYS + LEAP - ELSEIF (MC.EQ.ME) THEN - NDAYS = NDAYS+IED - ELSE - NDAYS = NDAYS+IDPM(MC) - IF (MC.EQ.2) NDAYS = NDAYS + LEAP - ENDIF - ENDDO - ELSEIF (IBD.LT.IED) THEN + MB = IBDT(2) ! BEGIN MONTH + ME = IEDT(2) ! END MONTH + NM = ME - MB + 1 ! NUMBER OF MONTHS TO LOOK AT + IF (MB .GT. ME) NM = NM + 12 + MC = MB - 1 + DO M = 1, NM + MC = MC + 1 ! MC IS CURRENT MONTH + IF (MC .EQ. 13) MC = 1 + IF (MC .EQ. MB) THEN + NDAYS = NDAYS + IDPM(MC) - IBD + IF (MC .EQ. 2) NDAYS = NDAYS + LEAP + ELSEIF (MC .EQ. ME) THEN + NDAYS = NDAYS + IED + ELSE + NDAYS = NDAYS + IDPM(MC) + IF (MC .EQ. 2) NDAYS = NDAYS + LEAP + END IF + END DO + ELSEIF (IBD .LT. IED) THEN ! START AND END IN SAME MONTH, ONLY ACCOUNT FOR DAYS - NDAYS = IED-IBD - ENDIF - ELSEC=NDAYS*NSPD + NDAYS = IED - IBD + END IF + ELSEC = NDAYS * NSPD ! ! ADD OR SUBTRACT SECONDS - ELSEC = ELSEC+(IEDT(5)-IBDT(5))*3600.0 - ELSEC = ELSEC+(IEDT(6)-IBDT(6))*60.0 - ELSEC = ELSEC+(IEDT(7)-IBDT(7)) - ELSEC = ELSEC+(IEDT(8)-IBDT(8))*0.001 + ELSEC = ELSEC + (IEDT(5) - IBDT(5)) * 3600.0 + ELSEC = ELSEC + (IEDT(6) - IBDT(6)) * 60.0 + ELSEC = ELSEC + (IEDT(7) - IBDT(7)) + ELSEC = ELSEC + (IEDT(8) - IBDT(8)) * 0.001 ! ! CONVERT SECONDS TO DAYS, HOURS, MINUTES, AND SECONDS - NDAYS = INT(ELSEC/NSPD) - RSECS = MOD(ELSEC, 86400.0_DP) - NHOURS = INT(RSECS/3600.0) - RSECS = MOD(RSECS,3600.0_DP) - NMINS = INT(RSECS/60.0) - RSECS = MOD(RSECS,60.0_DP) - NSECS = INT(RSECS) - RSECS = MOD(RSECS,1.0_DP) - MSECS = NINT(RSECS*1000.0) - NRSECS = NSECS - IF (RSECS.GE.0.5) NRSECS=NRSECS+1 + NDAYS = INT(ELSEC / NSPD) + RSECS = MOD(ELSEC, 86400.0_DP) + NHOURS = INT(RSECS / 3600.0) + RSECS = MOD(RSECS, 3600.0_DP) + NMINS = INT(RSECS / 60.0) + RSECS = MOD(RSECS, 60.0_DP) + NSECS = INT(RSECS) + RSECS = MOD(RSECS, 1.0_DP) + MSECS = NINT(RSECS * 1000.0) + NRSECS = NSECS + IF (RSECS .GE. 0.5) NRSECS = NRSECS + 1 ! ! Write elapsed time to screen - IF (NDAYS.GT.0) THEN - WRITE(line, 1010) NDAYS,NHOURS,NMINS,NRSECS - 1010 FORMAT(1X,'Elapsed run time: ',I3,' Days, ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds') - ELSEIF (NHOURS.GT.0) THEN - WRITE(line, 1020) NHOURS,NMINS,NRSECS - 1020 FORMAT(1X,'Elapsed run time: ',I2,' Hours, ',I2, & - ' Minutes, ',I2,' Seconds') - ELSEIF (NMINS.GT.0) THEN - WRITE(line, 1030) NMINS,NSECS,MSECS - 1030 FORMAT(1X,'Elapsed run time: ',I2,' Minutes, ', & - I2,'.',I3.3,' Seconds') - ELSE - WRITE(line, 1040) NSECS,MSECS - 1040 FORMAT(1X,'Elapsed run time: ',I2,'.',I3.3,' Seconds') - ENDIF - call sim_message(line, skipafter=1) + IF (NDAYS .GT. 0) THEN + WRITE (line, 1010) NDAYS, NHOURS, NMINS, NRSECS +1010 FORMAT(1X, 'Elapsed run time: ', I3, ' Days, ', I2, ' Hours, ', I2, & + ' Minutes, ', I2, ' Seconds') + ELSEIF (NHOURS .GT. 0) THEN + WRITE (line, 1020) NHOURS, NMINS, NRSECS +1020 FORMAT(1X, 'Elapsed run time: ', I2, ' Hours, ', I2, & + ' Minutes, ', I2, ' Seconds') + ELSEIF (NMINS .GT. 0) THEN + WRITE (line, 1030) NMINS, NSECS, MSECS +1030 FORMAT(1X, 'Elapsed run time: ', I2, ' Minutes, ', & + I2, '.', I3.3, ' Seconds') + ELSE + WRITE (line, 1040) NSECS, MSECS +1040 FORMAT(1X, 'Elapsed run time: ', I2, '.', I3.3, ' Seconds') + END IF + call sim_message(line, skipafter=1) ! ! Write times to file if requested - IF(IPRTIM.GT.0) THEN - IF (NDAYS.GT.0) THEN - WRITE(IOUT,1010) NDAYS,NHOURS,NMINS,NRSECS - ELSEIF (NHOURS.GT.0) THEN - WRITE(IOUT,1020) NHOURS,NMINS,NRSECS - ELSEIF (NMINS.GT.0) THEN - WRITE(IOUT,1030) NMINS,NSECS,MSECS - ELSE - WRITE(IOUT,1040) NSECS,MSECS - ENDIF - ENDIF + IF (IPRTIM .GT. 0) THEN + IF (NDAYS .GT. 0) THEN + WRITE (IOUT, 1010) NDAYS, NHOURS, NMINS, NRSECS + ELSEIF (NHOURS .GT. 0) THEN + WRITE (IOUT, 1020) NHOURS, NMINS, NRSECS + ELSEIF (NMINS .GT. 0) THEN + WRITE (IOUT, 1030) NMINS, NSECS, MSECS + ELSE + WRITE (IOUT, 1040) NSECS, MSECS + END IF + END IF ! - RETURN + RETURN END SUBROUTINE elapsed_time ! @@ -190,5 +190,5 @@ SUBROUTINE code_timer(it, t1, ts) ! -- RETURN RETURN END SUBROUTINE code_timer - + end module TimerModule diff --git a/src/Utilities/VectorInt.f90 b/src/Utilities/VectorInt.f90 index 91fbc060880..405cf5f87a0 100644 --- a/src/Utilities/VectorInt.f90 +++ b/src/Utilities/VectorInt.f90 @@ -4,44 +4,44 @@ module VectorIntModule use ArrayHandlersModule, only: ExpandArray implicit none private - public :: VectorInt - + public :: VectorInt + integer(I4B), parameter :: defaultInitialCapacity = 4 - + ! This is a dynamic vector type for integers type :: VectorInt integer(I4B), private, allocatable :: values(:) ! the internal array for storage - integer(I4B) :: size ! the number of elements (technically this stuff should be unsigned) - integer(I4B) :: capacity ! the reserved storage + integer(I4B) :: size ! the number of elements (technically this stuff should be unsigned) + integer(I4B) :: capacity ! the reserved storage contains - procedure, pass(this) :: init ! allocate memory, init size and capacity - procedure, pass(this) :: push_back ! adds an element at the end of the vector - procedure, pass(this) :: at ! random access, unsafe, no bounds checking - procedure, pass(this) :: at_safe ! random access with bounds checking - procedure, pass(this) :: clear ! empties the vector, leaves memory unchanged - procedure, pass(this) :: shrink_to_fit ! reduces the allocated memory to fit the actual vector size - procedure, pass(this) :: destroy ! deletes the memory + procedure, pass(this) :: init ! allocate memory, init size and capacity + procedure, pass(this) :: push_back ! adds an element at the end of the vector + procedure, pass(this) :: at ! random access, unsafe, no bounds checking + procedure, pass(this) :: at_safe ! random access with bounds checking + procedure, pass(this) :: clear ! empties the vector, leaves memory unchanged + procedure, pass(this) :: shrink_to_fit ! reduces the allocated memory to fit the actual vector size + procedure, pass(this) :: destroy ! deletes the memory ! private procedure, private, pass(this) :: expand end type VectorInt contains ! module routines - + subroutine init(this, capacity) class(VectorInt), intent(inout) :: this integer(I4B), intent(in), optional :: capacity ! the initial capacity, when given - + if (present(capacity)) then this%capacity = capacity else this%capacity = defaultInitialCapacity - end if - - allocate(this%values(this%capacity)) + end if + + allocate (this%values(this%capacity)) this%size = 0 - + end subroutine init - + subroutine push_back(this, newValue) class(VectorInt), intent(inout) :: this integer(I4B) :: newValue @@ -49,95 +49,96 @@ subroutine push_back(this, newValue) if (this%size + 1 > this%capacity) then call this%expand() end if - + this%size = this%size + 1 this%values(this%size) = newValue - + end subroutine push_back - + function at(this, idx) result(value) class(VectorInt), intent(inout) :: this - integer(I4B), intent(in) :: idx - integer(I4B) :: value - + integer(I4B), intent(in) :: idx + integer(I4B) :: value + value = this%values(idx) - + end function at - + function at_safe(this, idx) result(value) class(VectorInt), intent(inout) :: this - integer(I4B), intent(in) :: idx - integer(I4B) :: value - + integer(I4B), intent(in) :: idx + integer(I4B) :: value + if (idx > this%size) then - write(*,*) 'VectorInt exception: access out of bounds, index ', idx, ' exceeds actual size (', this%size, ')' + write (*, *) 'VectorInt exception: access out of bounds, index ', idx, & + ' exceeds actual size (', this%size, ')' call ustop() end if value = this%at(idx) - + end function at_safe - + subroutine clear(this) class(VectorInt), intent(inout) :: this - + ! really, this is all there is to it... this%size = 0 - + end subroutine clear - + subroutine shrink_to_fit(this) class(VectorInt), intent(inout) :: this ! local integer(I4B), allocatable :: tempValues(:) integer(I4B) :: i, newSize - + if (this%size == this%capacity) then - return + return end if - + ! store temp newSize = this%size - allocate(tempValues(newSize)) + allocate (tempValues(newSize)) do i = 1, newSize - tempValues(i) = this%values(i) + tempValues(i) = this%values(i) end do - + ! reinit call this%destroy() call this%init(newSize) - + ! copy back do i = 1, newSize - call this%push_back(tempValues(i)) + call this%push_back(tempValues(i)) end do - + end subroutine shrink_to_fit - + subroutine destroy(this) class(VectorInt), intent(inout) :: this - + if (allocated(this%values)) then - deallocate(this%values) + deallocate (this%values) this%size = 0 this%capacity = 0 else - write(*,*) 'VectorInt exception: cannot delete an unallocated array' + write (*, *) 'VectorInt exception: cannot delete an unallocated array' call ustop() end if - + end subroutine destroy - + ! expand the array with the given strategy, at ! least by 1 subroutine expand(this) class(VectorInt), intent(inout) :: this integer(I4B) :: increment - + ! expansion strategy - increment = this%capacity/2 + 1 + increment = this%capacity / 2 + 1 call ExpandArray(this%values, increment) this%capacity = this%capacity + increment - + end subroutine expand - + end module VectorIntModule diff --git a/src/Utilities/comarg.f90 b/src/Utilities/comarg.f90 index 9eae7118541..f9d328dee06 100644 --- a/src/Utilities/comarg.f90 +++ b/src/Utilities/comarg.f90 @@ -1,14 +1,14 @@ module CommandArguments use KindModule - use ConstantsModule, only: LINELENGTH, LENBIGLINE, LENHUGELINE, & - VSUMMARY, VALL, VDEBUG, & + use ConstantsModule, only: LINELENGTH, LENBIGLINE, LENHUGELINE, & + VSUMMARY, VALL, VDEBUG, & MVALIDATE - use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE, & - FMTDISCLAIMER, FMTLICENSE + use VersionModule, only: VERSION, MFVNAM, IDEVELOPMODE, & + FMTDISCLAIMER, FMTLICENSE use CompilerVersion - use SimVariablesModule, only: istdout, isim_level, & - simfile, simlstfile, simstdout, & - isim_mode + use SimVariablesModule, only: istdout, isim_level, & + simfile, simlstfile, simstdout, & + isim_mode use GenericUtilitiesModule, only: sim_message, write_message use SimModule, only: store_error, ustop use InputOutputModule, only: upcase, getunit @@ -18,8 +18,8 @@ module CommandArguments private public :: GetCommandLineArguments ! - contains - +contains + !> @brief Get command line arguments !! !! Subroutine to get and write information on command line arguments. @@ -56,7 +56,7 @@ subroutine GetCommandLineArguments() call get_command_argument(0, cexe) cexe = adjustl(cexe) ! - ! -- find the program basename, not including the path (this should be + ! -- find the program basename, not including the path (this should be ! mf6.exe, mf6d.exe, etc.) ipos = index(cexe, '/', back=.TRUE.) if (ipos == 0) then @@ -71,8 +71,8 @@ subroutine GetCommandLineArguments() ! ! -- write header call get_compile_date(cdate) - write(header, '(a,4(1x,a),a)') & - trim(adjustl(cexe)), '- MODFLOW', & + write (header, '(a,4(1x,a),a)') & + trim(adjustl(cexe)), '- MODFLOW', & trim(adjustl(VERSION)), '(compiled', trim(adjustl(cdate)), ')' ! ! -- set ctyp @@ -88,12 +88,12 @@ subroutine GetCommandLineArguments() do iarg = 1, icountcmd call get_command_argument(iarg, uctag) call upcase(uctag) - if (trim(adjustl(uctag)) == '-S' .or. & - trim(adjustl(uctag)) == '--SILENT') then + if (trim(adjustl(uctag)) == '-S' .or. & + trim(adjustl(uctag)) == '--SILENT') then ! ! -- get file unit and open mfsim.stdout istdout = getunit() - open(unit=istdout, file=trim(adjustl(simstdout))) + open (unit=istdout, file=trim(adjustl(simstdout))) ! ! -- exit loop exit @@ -127,9 +127,9 @@ subroutine GetCommandLineArguments() if (ipos > 0) then ipos = index(tag, '=') ilen = len_trim(tag) - clevel = tag(ipos+1:ilen) + clevel = tag(ipos + 1:ilen) call upcase(clevel) - uctag = tag(1:ipos-1) + uctag = tag(1:ipos - 1) call upcase(uctag) end if ! @@ -139,110 +139,110 @@ subroutine GetCommandLineArguments() if (ipos > 0) then ipos = index(tag, '=') ilen = len_trim(tag) - cmode = tag(ipos+1:ilen) + cmode = tag(ipos + 1:ilen) call upcase(cmode) - uctag = tag(1:ipos-1) + uctag = tag(1:ipos - 1) call upcase(uctag) end if ! ! -- evaluate the command line argument (uctag) - select case(trim(adjustl(uctag))) - case('-H', '-?', '--HELP') - lstop = .TRUE. + select case (trim(adjustl(uctag))) + case ('-H', '-?', '--HELP') + lstop = .TRUE. + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + case ('-V', '--VERSION') + lstop = .TRUE. + write (line, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp + call write_message(line, skipbefore=1, skipafter=1) + case ('-DEV', '--DEVELOP') + lstop = .TRUE. + write (line, '(2a,g0)') & + trim(adjustl(cexe)), ': develop version ', ltyp + call write_message(line, skipbefore=1, skipafter=1) + case ('-C', '--COMPILER') + lstop = .TRUE. + call get_compiler(compiler) + write (line, '(2a,1x,a)') & + trim(adjustl(cexe)), ':', trim(adjustl(compiler)) + call write_message(line, skipbefore=1, skipafter=1) + case ('-S', '--SILENT') + write (line, '(2a,1x,a)') & + trim(adjustl(cexe)), ':', 'all screen output sent to mfsim.stdout' + call write_message(line, skipbefore=1, skipafter=1) + case ('-D', '--DISCLAIMER') + lstop = .TRUE. + call sim_message('', fmt=FMTDISCLAIMER) + case ('-LIC', '--LICENSE') + lstop = .TRUE. + call sim_message('', fmt=FMTLICENSE) + case ('-CO', '--COMPILER-OPT') + lstop = .TRUE. + call get_compile_options(coptions) + call write_message(coptions, skipbefore=1, skipafter=1) + case ('-L', '--LEVEL') + if (len_trim(clevel) < 1) then + iarg = iarg + 1 + call get_command_argument(iarg, clevel) + call upcase(clevel) + end if + select case (trim(adjustl(clevel))) + case ('SUMMARY') + isim_level = VSUMMARY + case ('DEBUG') + isim_level = VDEBUG + case default call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - case('-V', '--VERSION') - lstop = .TRUE. - write(line, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(VERSION)), ctyp - call write_message(line, skipbefore=1, skipafter=1) - case('-DEV', '--DEVELOP') - lstop = .TRUE. - write(line, '(2a,g0)') & - trim(adjustl(cexe)), ': develop version ', ltyp - call write_message(line, skipbefore=1, skipafter=1) - case('-C', '--COMPILER') - lstop = .TRUE. - call get_compiler(compiler) - write(line, '(2a,1x,a)') & - trim(adjustl(cexe)), ':', trim(adjustl(compiler)) - call write_message(line, skipbefore=1, skipafter=1) - case('-S', '--SILENT') - write(line, '(2a,1x,a)') & - trim(adjustl(cexe)), ':', 'all screen output sent to mfsim.stdout' - call write_message(line, skipbefore=1, skipafter=1) - case('-D', '--DISCLAIMER') - lstop = .TRUE. - call sim_message('', fmt=FMTDISCLAIMER) - case('-LIC', '--LICENSE') - lstop = .TRUE. - call sim_message('', fmt=FMTLICENSE) - case('-CO', '--COMPILER-OPT') - lstop = .TRUE. - call get_compile_options(coptions) - call write_message(coptions, skipbefore=1, skipafter=1) - case('-L', '--LEVEL') - if (len_trim(clevel) < 1) then - iarg = iarg + 1 - call get_command_argument(iarg, clevel) - call upcase(clevel) - end if - select case(trim(adjustl(clevel))) - case('SUMMARY') - isim_level = VSUMMARY - case('DEBUG') - isim_level = VDEBUG - case default - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal STDOUT level option -', & - trim(adjustl(clevel)) - call store_error(errmsg) - end select - ! - ! -- write message to stdout - write(line, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', 'stdout output level', & + write (errmsg, '(2a,1x,a)') & + trim(adjustl(cexe)), ': illegal STDOUT level option -', & trim(adjustl(clevel)) - call write_message(line, skipbefore=1, skipafter=1) - case('-M', '--MODE') - if (len_trim(cmode) < 1) then - iarg = iarg + 1 - call get_command_argument(iarg, cmode) - call upcase(cmode) - end if - select case(trim(adjustl(cmode))) - case('VALIDATE') - isim_mode = MVALIDATE - case default - call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - errmsg = trim(adjustl(cexe)) // ': illegal MODFLOW 6 ' // & - 'simulation mode option - ' // trim(adjustl(cmode)) - call store_error(errmsg, terminate=.TRUE.) - end select - ! - ! -- write message to stdout - line = trim(adjustl(cexe)) // ': MODFLOW 6 simulation mode ' // & - trim(adjustl(cmode)) // '. Model input will be checked for all ' // & - 'stress periods but the matrix equations will not be ' // & - 'assembled or solved.' - call write_message(line, skipbefore=1, skipafter=1) + call store_error(errmsg) + end select + ! + ! -- write message to stdout + write (line, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', 'stdout output level', & + trim(adjustl(clevel)) + call write_message(line, skipbefore=1, skipafter=1) + case ('-M', '--MODE') + if (len_trim(cmode) < 1) then + iarg = iarg + 1 + call get_command_argument(iarg, cmode) + call upcase(cmode) + end if + select case (trim(adjustl(cmode))) + case ('VALIDATE') + isim_mode = MVALIDATE case default - lstop = .TRUE. call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) - write(errmsg, '(2a,1x,a)') & - trim(adjustl(cexe)), ': illegal option -', trim(adjustl(tag)) + errmsg = trim(adjustl(cexe))//': illegal MODFLOW 6 '// & + 'simulation mode option - '//trim(adjustl(cmode)) call store_error(errmsg, terminate=.TRUE.) + end select + ! + ! -- write message to stdout + line = trim(adjustl(cexe))//': MODFLOW 6 simulation mode '// & + trim(adjustl(cmode))//'. Model input will be checked for all '// & + 'stress periods but the matrix equations will not be '// & + 'assembled or solved.' + call write_message(line, skipbefore=1, skipafter=1) + case default + lstop = .TRUE. + call write_usage(trim(adjustl(header)), trim(adjustl(cexe))) + write (errmsg, '(2a,1x,a)') & + trim(adjustl(cexe)), ': illegal option -', trim(adjustl(tag)) + call store_error(errmsg, terminate=.TRUE.) end select end do ! ! -- check if simfile exists, only if the model should be run if (.not. lstop) then - inquire(file=trim(adjustl(simfile)), exist=lexist) + inquire (file=trim(adjustl(simfile)), exist=lexist) if (.NOT. lexist) then lstop = .TRUE. - write(errmsg, '(2a,2(1x,a))') & - trim(adjustl(cexe)), ':', trim(adjustl(simfile)), & - 'is not present in working directory.' + write (errmsg, '(2a,2(1x,a))') & + trim(adjustl(cexe)), ':', trim(adjustl(simfile)), & + 'is not present in working directory.' call store_error(errmsg, terminate=.TRUE.) end if end if @@ -260,7 +260,7 @@ subroutine GetCommandLineArguments() ! -- return return end subroutine GetCommandLineArguments - + !> @brief Write command line argument usage !! !! Subroutine to write usage information for command line arguments. @@ -268,48 +268,48 @@ end subroutine GetCommandLineArguments !< subroutine write_usage(header, cexe) ! -- dummy variables - character(len=*), intent(in) :: header !< header for usage - character(len=*), intent(in) :: cexe !< executable name + character(len=*), intent(in) :: header !< header for usage + character(len=*), intent(in) :: cexe !< executable name ! -- local variables character(len=LINELENGTH) :: line ! -- format - character(len=*), parameter :: OPTIONSFMT = & - "(/, & - &'Options GNU long option Meaning ',/, & - &' -h, -? --help Show this message',/, & - &' -v --version Display program version information.',/, & - &' -dev --develop Display program develop option mode.',/, & - &' -d --disclaimer Display program disclaimer.',/, & - &' -lic --license Display program license information.',/, & - &' -c --compiler Display compiler information.',/, & - &' -co --compiler-opt Display compiler options.',/, & - &' -s --silent All STDOUT to mfsim.stdout.',/, & - &' -l --level STDOUT output to screen based on .',/, & - &' =summary Limited output to STDOUT.',/, & - &' =debug Enhanced output to STDOUT.',/, & + character(len=*), parameter :: OPTIONSFMT = & + "(/,& + &'Options GNU long option Meaning ',/,& + &' -h, -? --help Show this message',/,& + &' -v --version Display program version information.',/,& + &' -dev --develop Display program develop option mode.',/,& + &' -d --disclaimer Display program disclaimer.',/,& + &' -lic --license Display program license information.',/,& + &' -c --compiler Display compiler information.',/,& + &' -co --compiler-opt Display compiler options.',/,& + &' -s --silent All STDOUT to mfsim.stdout.',/,"// & + "' -l --level STDOUT output to screen based on .',/,& + &' =summary Limited output to STDOUT.',/,& + &' =debug Enhanced output to STDOUT.',/,& &' -m --mode MODFLOW 6 simulation mode based on .',/,& - &' =validate Check model input for',/, & - &' errors but do not ',/, & - &' assemble or solve matrix ',/, & - &' equations or write ',/, & - &' solution output.',/, & - &' ',/, & - &'Bug reporting and contributions are welcome from the community. ',/, & - &'Questions can be asked on the issues page[1]. Before creating a new',/, & - &'issue, please take a moment to search and make sure a similar issue',/, & - &'does not already exist. If one does exist, you can comment (most',/, & - &'simply even with just :+1:) to show your support for that issue.',/, & - &' ',/, & + &' =validate Check model input for',/,& + &' errors but do not ',/,& + &' assemble or solve matrix ',/,& + &' equations or write ',/,& + &' solution output.',/,"// & + "' ',/,& + &'Bug reporting and contributions are welcome from the community. ',/,& + &'Questions can be asked on the issues page[1]. Before creating a new',/,& + &'issue, please take a moment to search and make sure a similar issue',/,& + &'does not already exist. If one does exist, you can comment (most',/,& + &'simply even with just :+1:) to show your support for that issue.',/,& + &' ',/,& &'[1] https://github.com/MODFLOW-USGS/modflow6/issues',/)" ! ! -- write command line usage information to the screen call sim_message(header) - write(line, '(a,1x,a,15x,a,2(1x,a),2a)') & - 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & + write (line, '(a,1x,a,15x,a,2(1x,a),2a)') & + 'usage:', cexe, 'run MODFLOW', trim(adjustl(MFVNAM)), & 'using "', trim(adjustl(simfile)), '"' call sim_message(line) - write(line, '(a,1x,a,1x,a,5x,a)') & - ' or:', cexe, '[options]', & + write (line, '(a,1x,a,1x,a,5x,a)') & + ' or:', cexe, '[options]', & 'retrieve program information' call sim_message(line) call sim_message('', fmt=OPTIONSFMT) @@ -317,5 +317,5 @@ subroutine write_usage(header, cexe) ! -- return return end subroutine write_usage - -end module CommandArguments \ No newline at end of file + +end module CommandArguments diff --git a/src/Utilities/compilerversion.F90 b/src/Utilities/compilerversion.F90 index 4f701dad114..5acfe4026a5 100644 --- a/src/Utilities/compilerversion.F90 +++ b/src/Utilities/compilerversion.F90 @@ -7,10 +7,10 @@ module CompilerVersion implicit none private ! -- compiler version - character(len=10) :: ccompiler !< compiler string - character(len=10) :: cversion !< compiler version string - character(len=20) :: cdate !< compilation date - integer(I4B) :: icompiler = CUNKNOWN !< compiler enum + character(len=10) :: ccompiler !< compiler string + character(len=10) :: cversion !< compiler version string + character(len=20) :: cdate !< compilation date + integer(I4B) :: icompiler = CUNKNOWN !< compiler enum public :: get_compiler, get_compile_date, get_compile_options contains @@ -34,7 +34,7 @@ subroutine get_compiler(txt) #endif #ifdef _CRAYFTN icompiler = CCRAYFTN - cdate = __DATE__ // ' ' // __TIME__ + cdate = __DATE__//' '//__TIME__ #endif ! ! -- set compiler strings @@ -60,7 +60,7 @@ end subroutine get_compiler !< subroutine get_compile_date(txt) ! -- dummy variables - character(len=20), intent(inout) :: txt !< compilation date + character(len=20), intent(inout) :: txt !< compilation date ! -- set variables #ifdef __GFORTRAN__ cdate = __DATE__//' '//__TIME__ @@ -69,7 +69,7 @@ subroutine get_compile_date(txt) cdate = __DATE__//' '//__TIME__ #endif #ifdef _CRAYFTN - cdate = __DATE__ // ' ' // __TIME__ + cdate = __DATE__//' '//__TIME__ #endif ! ! -- write compilation date string @@ -86,7 +86,7 @@ end subroutine get_compile_date !< subroutine get_compile_options(txt) ! -- dummy variables - character(len=LENBIGLINE), intent(inout) :: txt !< compilation options + character(len=LENBIGLINE), intent(inout) :: txt !< compilation options ! -- set variables ! ! -- set txt string diff --git a/src/Utilities/genericutils.f90 b/src/Utilities/genericutils.f90 index 188fc721614..549e3476d17 100644 --- a/src/Utilities/genericutils.f90 +++ b/src/Utilities/genericutils.f90 @@ -1,6 +1,6 @@ !> @brief This module contains generic utilties !! -!! This module contains generic utilities that have +!! This module contains generic utilities that have !! limited dependencies. !! !< @@ -11,33 +11,33 @@ module GenericUtilitiesModule LINELENGTH, LENHUGELINE, VSUMMARY use SimVariablesModule, only: istdout, isim_level ! - implicit none - + implicit none + private - + public :: sim_message public :: write_message public :: write_centered public :: is_same public :: stop_with_error - contains +contains !> @brief Write simulation message !! !! Subroutine to print message to user specified iunit or STDOUT based on level. !! !< - subroutine sim_message(message, iunit, fmt, level, & + subroutine sim_message(message, iunit, fmt, level, & skipbefore, skipafter, advance) ! -- dummy variables - character(len=*), intent(in) :: message !< message to write to iunit - integer(I4B), intent(in), optional :: iunit !< optional file unit to write the message to (default=stdout) - character(len=*), intent(in), optional :: fmt !< optional format to write the message (default='(a)') - integer(I4B), intent(in), optional :: level !< optional level for the message (default=summary) - integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) - integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) - logical(LGP), intent(in), optional :: advance !< optional boolean indicating if advancing output (default is .TRUE.) + character(len=*), intent(in) :: message !< message to write to iunit + integer(I4B), intent(in), optional :: iunit !< optional file unit to write the message to (default=stdout) + character(len=*), intent(in), optional :: fmt !< optional format to write the message (default='(a)') + integer(I4B), intent(in), optional :: level !< optional level for the message (default=summary) + integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) + integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) + logical(LGP), intent(in), optional :: advance !< optional boolean indicating if advancing output (default is .TRUE.) ! -- local variables character(len=3) :: cadvance integer(I4B) :: i @@ -84,7 +84,7 @@ subroutine sim_message(message, iunit, fmt, level, & ! -- write empty line before message if (present(skipbefore)) then do i = 1, skipbefore - write(iu, *) + write (iu, *) end do end if ! @@ -92,16 +92,16 @@ subroutine sim_message(message, iunit, fmt, level, & ! or equal the isim_level for the simulation if (ilevel <= isim_level) then if (ilen > 0) then - write(iu, trim(simfmt), advance=cadvance) message(1:ilen) + write (iu, trim(simfmt), advance=cadvance) message(1:ilen) else - write(iu, trim(simfmt), advance=cadvance) + write (iu, trim(simfmt), advance=cadvance) end if end if ! ! -- write empty line after message if (present(skipafter)) then do i = 1, skipafter - write(iu, *) + write (iu, *) end do end if ! @@ -111,7 +111,7 @@ end subroutine sim_message !> @brief Write messages !! - !! Subroutine that formats and writes a single message that + !! Subroutine that formats and writes a single message that !! may exceeed 78 characters in length. Messages longer than !! 78 characters are written across multiple lines. When a !! counter is passed in subsequent lines are indented. @@ -120,32 +120,32 @@ end subroutine sim_message subroutine write_message(message, icount, iwidth, iunit, level, & skipbefore, skipafter) ! -- dummy variables - character (len=*), intent(in) :: message !< message to be written - integer(I4B), intent(in), optional :: icount !< counter to prepended to the message - integer(I4B), intent(in), optional :: iwidth !< maximum width of the prepended counter - integer(I4B), intent(in), optional :: iunit !< the unit number to which the message is written - integer(I4B), intent(in), optional :: level !< level of message (VSUMMARY, VALL, VDEBUG) - integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) - integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) + character(len=*), intent(in) :: message !< message to be written + integer(I4B), intent(in), optional :: icount !< counter to prepended to the message + integer(I4B), intent(in), optional :: iwidth !< maximum width of the prepended counter + integer(I4B), intent(in), optional :: iunit !< the unit number to which the message is written + integer(I4B), intent(in), optional :: level !< level of message (VSUMMARY, VALL, VDEBUG) + integer(I4B), intent(in), optional :: skipbefore !< optional number of empty lines before message (default=0) + integer(I4B), intent(in), optional :: skipafter !< optional number of empty lines after message (default=0) ! -- local variables - integer(I4B), parameter :: len_line=78 + integer(I4B), parameter :: len_line = 78 character(len=LENHUGELINE) :: amessage - character(len=len_line) :: line - character(len=16) :: cfmt - character(len=10) :: counter - character(len=5) :: fmt_first - character(len=20) :: fmt_cont - logical(LGP) :: include_counter - integer(I4B) :: isb - integer(I4B) :: isa - integer(I4B) :: jend - integer(I4B) :: len_str1 - integer(I4B) :: len_str2 - integer(I4B) :: len_message - integer(I4B) :: junit - integer(I4B) :: ilevel - integer(I4B) :: i - integer(I4B) :: j + character(len=len_line) :: line + character(len=16) :: cfmt + character(len=10) :: counter + character(len=5) :: fmt_first + character(len=20) :: fmt_cont + logical(LGP) :: include_counter + integer(I4B) :: isb + integer(I4B) :: isa + integer(I4B) :: jend + integer(I4B) :: len_str1 + integer(I4B) :: len_str2 + integer(I4B) :: len_message + integer(I4B) :: junit + integer(I4B) :: ilevel + integer(I4B) :: i + integer(I4B) :: j ! ! -- return if no message is passed if (len_trim(message) < 1) then @@ -162,10 +162,10 @@ subroutine write_message(message, icount, iwidth, iunit, level, & include_counter = .FALSE. junit = istdout j = 0 - ! + ! ! -- process optional dummy variables ! -- set the unit number - if(present(iunit))then + if (present(iunit)) then if (iunit > 0) then junit = iunit end if @@ -193,18 +193,18 @@ subroutine write_message(message, icount, iwidth, iunit, level, & end if ! ! -- create the counter to prepend to the start of the message, - ! formats, and variables used to create strings + ! formats, and variables used to create strings if (present(iwidth) .and. present(icount)) then include_counter = .TRUE. ! -- write counter - write(cfmt, '(A,I0,A)') '(1x,i', iwidth, ',".",1x)' - write(counter, cfmt) icount + write (cfmt, '(A,I0,A)') '(1x,i', iwidth, ',".",1x)' + write (counter, cfmt) icount ! -- calculate the length of the first and second string on a line len_str1 = len(trim(counter)) + 1 len_str2 = len_line - len_str1 ! -- write format for the continuation lines - write(fmt_cont, '(a,i0,a)') & - '(',len(trim(counter)) + 1, 'x,a)' + write (fmt_cont, '(a,i0,a)') & + '(', len(trim(counter)) + 1, 'x,a)' end if ! ! -- calculate the length of the message @@ -214,19 +214,19 @@ subroutine write_message(message, icount, iwidth, iunit, level, & 5 continue jend = j + len_str2 if (jend >= len_message) go to 100 - do i = jend, j+1, -1 - if (amessage(i:i).eq.' ') then + do i = jend, j + 1, -1 + if (amessage(i:i) .eq. ' ') then if (j == 0) then if (include_counter) then - line = counter(1:len_str1)//amessage(j+1:i) + line = counter(1:len_str1)//amessage(j + 1:i) else - line = amessage(j+1:i) + line = amessage(j + 1:i) end if call sim_message(line, iunit=junit, & fmt=fmt_first, level=ilevel, & skipbefore=isb) else - line = adjustl(amessage(j+1:i)) + line = adjustl(amessage(j + 1:i)) call sim_message(line, iunit=junit, & fmt=fmt_cont, level=ilevel) end if @@ -236,15 +236,15 @@ subroutine write_message(message, icount, iwidth, iunit, level, & end do if (j == 0) then if (include_counter) then - line = counter(1:len_str1)//amessage(j+1:jend) + line = counter(1:len_str1)//amessage(j + 1:jend) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) end if call sim_message(line, iunit=junit, & fmt=fmt_first, level=ilevel, & skipbefore=isb) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) call sim_message(line, iunit=junit, & fmt=fmt_cont, level=ilevel) end if @@ -256,15 +256,15 @@ subroutine write_message(message, icount, iwidth, iunit, level, & jend = len_message if (j == 0) then if (include_counter) then - line = counter(1:len_str1)//amessage(j+1:jend) + line = counter(1:len_str1)//amessage(j + 1:jend) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) end if call sim_message(line, iunit=junit, & fmt=fmt_first, level=ilevel, & skipbefore=isb, skipafter=isa) else - line = amessage(j+1:jend) + line = amessage(j + 1:jend) call sim_message(line, iunit=junit, fmt=fmt_cont, & level=ilevel, & skipafter=isa) @@ -276,15 +276,15 @@ end subroutine write_message !> @brief Write centered text !! - !! Subroutine to write text to unit iunit centered in width defined by linelen. + !! Subroutine to write text to unit iunit centered in width defined by linelen. !! Left-pad with blanks as needed. !! !< subroutine write_centered(text, linelen, iunit) ! -- dummy variables - character(len=*), intent(in) :: text !< message to write to iunit - integer(I4B), intent(in) :: linelen !< length of line to center text in - integer(I4B), intent(in), optional :: iunit !< optional file unit to write text (default=stdout) + character(len=*), intent(in) :: text !< message to write to iunit + integer(I4B), intent(in) :: linelen !< length of line to center text in + integer(I4B), intent(in), optional :: iunit !< optional file unit to write text (default=stdout) ! -- local variables character(len=linelen) :: line character(len=linelen) :: blank @@ -314,17 +314,17 @@ subroutine write_centered(text, linelen, iunit) 5 continue jend = j + linelen if (jend >= len_message) go to 100 - do i = jend, j+1, -1 - if (text(i:i).eq.' ') then - line = text(j+1:i) - ipad = ((linelen - len_trim(line)) / 2) + do i = jend, j + 1, -1 + if (text(i:i) .eq. ' ') then + line = text(j + 1:i) + ipad = ((linelen - len_trim(line)) / 2) call sim_message(blank(1:ipad)//line, iunit=iu) j = i go to 5 end if end do - line = text(j+1:jend) - ipad = ((linelen - len_trim(line)) / 2) + line = text(j + 1:jend) + ipad = ((linelen - len_trim(line)) / 2) call sim_message(blank(1:ipad)//line, iunit=iu) j = jend go to 5 @@ -332,28 +332,28 @@ subroutine write_centered(text, linelen, iunit) ! -- last piece of amessage to write to a line 100 continue jend = len_message - line = text(j+1:jend) - ipad = ((linelen - len_trim(line)) / 2) + line = text(j + 1:jend) + ipad = ((linelen - len_trim(line)) / 2) call sim_message(blank(1:ipad)//line, iunit=iu) end if ! ! -- return return end subroutine write_centered - + !> @brief Function to determine if two reals are the same !! - !! Function to evaluate if the difference between a and b are less than eps + !! Function to evaluate if the difference between a and b are less than eps !! (i.e. a and b are the same). !! !< function is_same(a, b, eps) result(lvalue) ! -- return variable - logical(LGP) :: lvalue !< boolean indicating if a and b are the same + logical(LGP) :: lvalue !< boolean indicating if a and b are the same ! -- dummy variables - real(DP), intent(in) :: a !< first number to evaluate - real(DP), intent(in) :: b !< second number to evaluate - real(DP), intent(in), optional :: eps !< optional maximum difference between a abd b (default=DSAME) + real(DP), intent(in) :: a !< first number to evaluate + real(DP), intent(in) :: b !< second number to evaluate + real(DP), intent(in), optional :: eps !< optional maximum difference between a abd b (default=DSAME) ! -- local variables real(DP) :: epsloc real(DP) :: denom @@ -364,7 +364,7 @@ function is_same(a, b, eps) result(lvalue) epsloc = eps else epsloc = DSAME - endif + end if lvalue = .FALSE. if (a == b) then lvalue = .TRUE. @@ -377,7 +377,7 @@ function is_same(a, b, eps) result(lvalue) denom = DPREC end if end if - rdiff = abs( (a - b) / denom ) + rdiff = abs((a - b) / denom) if (rdiff <= epsloc) then lvalue = .TRUE. end if @@ -394,7 +394,7 @@ end function is_same !< subroutine stop_with_error(ierr) ! -- dummy variables - integer(I4B), intent(in), optional :: ierr !< optional error code to return (default=0) + integer(I4B), intent(in), optional :: ierr !< optional error code to return (default=0) ! -- local variables integer(I4B) :: ireturn_err ! @@ -404,10 +404,10 @@ subroutine stop_with_error(ierr) else ireturn_err = 0 end if - + ! -- return the correct return code call exit(ireturn_err) - - end subroutine stop_with_error - end module GenericUtilitiesModule \ No newline at end of file + end subroutine stop_with_error + +end module GenericUtilitiesModule diff --git a/src/Utilities/kind.f90 b/src/Utilities/kind.f90 index e258a239389..60b355d0aa2 100644 --- a/src/Utilities/kind.f90 +++ b/src/Utilities/kind.f90 @@ -6,57 +6,58 @@ !! !< module KindModule - use, intrinsic:: iso_fortran_env, only: I4B => int32, & - I8B => int64, & - LGP => int32, & - DP => real64 - + use, intrinsic :: iso_fortran_env, only: I4B => int32, & + &I8B => int64, & + &LGP => int32, & + &DP => real64 + implicit none - public:: I4B, I8B, LGP, DP, write_kindinfo + public :: I4B, I8B, LGP, DP, write_kindinfo + +contains - contains - - !> @brief Write variable data types + !> @brief Write variable data types !! !! This subroutine writes the precision of logical, integer, long integer, !! and real data types used in MODFLOW 6. !! - !< - subroutine write_kindinfo(iout) - ! -- dummy variables - integer(I4B), intent(in) :: iout !< file unit to output kind variables - ! -- local variables - integer(LGP) :: ldum = 0 - integer(I4B) :: idum = 0 - integer(I8B) :: long_idum = 0 - integer(DP) :: irdum = 0 ! for bit size of real variables - real(DP) :: rdum = 0._DP - ! - ! -- write kind information - write(iout, '(/a)') 'Real Variables' - write(iout, '(2x,a,i0)') 'KIND: ', DP - write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', tiny(rdum) - write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) - write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum) - - write(iout, '(/a)') 'Integer Variables' - write(iout, '(2x,a,i0)') 'KIND: ', I4B - write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum) - - write(iout, '(/a)') 'Long Integer Variables' - write(iout, '(2x,a,i0)') 'KIND: ', I8B - write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum) - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum) - - write(iout, '(/a)') 'Logical Variables' - write(iout, '(2x,a,i0)') 'KIND: ', LGP - write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum) - ! - ! -- Return - return - end subroutine write_kindinfo - + !< + subroutine write_kindinfo(iout) + ! -- dummy variables + integer(I4B), intent(in) :: iout !< file unit to output kind variables + ! -- local variables + integer(LGP) :: ldum = 0 + integer(I4B) :: idum = 0 + integer(I8B) :: long_idum = 0 + integer(DP) :: irdum = 0 ! for bit size of real variables + real(DP) :: rdum = 0._DP + ! + ! -- write kind information + write (iout, '(/a)') 'Real Variables' + write (iout, '(2x,a,i0)') 'KIND: ', DP + write (iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', & + tiny(rdum) + write (iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) + write (iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum) + + write (iout, '(/a)') 'Integer Variables' + write (iout, '(2x,a,i0)') 'KIND: ', I4B + write (iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum) + + write (iout, '(/a)') 'Long Integer Variables' + write (iout, '(2x,a,i0)') 'KIND: ', I8B + write (iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum) + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum) + + write (iout, '(/a)') 'Logical Variables' + write (iout, '(2x,a,i0)') 'KIND: ', LGP + write (iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum) + ! + ! -- Return + return + end subroutine write_kindinfo + end module KindModule diff --git a/src/Utilities/sort.f90 b/src/Utilities/sort.f90 index 7fdc63e7292..4cc637a3511 100644 --- a/src/Utilities/sort.f90 +++ b/src/Utilities/sort.f90 @@ -11,514 +11,511 @@ module SortModule interface qsort module procedure qsort_int1d, qsort_dbl1d end interface - + interface unique_values module procedure unique_values_int1d, unique_values_dbl1d end interface - - contains - subroutine qsort_int1d(indx, v, reverse) +contains + subroutine qsort_int1d(indx, v, reverse) ! ************************************************************************** ! qsort -- quick sort that also includes an index number ! ************************************************************************** ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - ! -- dummy arguments - integer(I4B), dimension(:), intent(inout) :: indx - integer(I4B), dimension(:), intent(inout) :: v - logical, intent(in), optional :: reverse - ! -- local variables - logical :: lrev - integer(I4B), parameter :: nn=15 - integer(I4B), parameter :: nstack=50 - integer(I4B) :: nsize - integer(I4B) :: k - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jstack - integer(I4B) :: ileft - integer(I4B) :: iright - integer(I4B), dimension(nstack) :: istack - integer(I4B) :: iidx - integer(I4B) :: ia - integer(I4B) :: a - ! -- functions - ! -- code - ! - ! -- process optional dummy variables - if (present(reverse)) then - lrev = reverse + ! -- dummy arguments + integer(I4B), dimension(:), intent(inout) :: indx + integer(I4B), dimension(:), intent(inout) :: v + logical, intent(in), optional :: reverse + ! -- local variables + logical :: lrev + integer(I4B), parameter :: nn = 15 + integer(I4B), parameter :: nstack = 50 + integer(I4B) :: nsize + integer(I4B) :: k + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jstack + integer(I4B) :: ileft + integer(I4B) :: iright + integer(I4B), dimension(nstack) :: istack + integer(I4B) :: iidx + integer(I4B) :: ia + integer(I4B) :: a + ! -- functions + ! -- code + ! + ! -- process optional dummy variables + if (present(reverse)) then + lrev = reverse + else + lrev = .FALSE. + end if + ! + ! -- initialize variables + nsize = size(v) + jstack = 0 + ileft = 1 + iright = nsize + ! + ! -- perform quicksort + do + if (iright - ileft < nn) then + do j = (ileft + 1), iright + a = v(j) + iidx = indx(j) + do i = (j - 1), ileft, -1 + if (v(i) <= a) exit + v(i + 1) = v(i) + indx(i + 1) = indx(i) + end do + v(i + 1) = a + indx(i + 1) = iidx + end do + if (jstack == 0) return + iright = istack(jstack) + ileft = istack(jstack - 1) + jstack = jstack - 2 else - lrev = .FALSE. - endif - ! - ! -- initialize variables - nsize = size(v) - jstack = 0 - ileft = 1 - iright = nsize - ! - ! -- perform quicksort - do - if (iright - ileft < nn) then - do j = (ileft + 1), iright - a = v(j) - iidx = indx(j) - do i = (j - 1), ileft, -1 - if (v(i) <= a) exit - v(i+ 1) = v(i) - indx(i+ 1) = indx(i) - end do - v(i + 1) = a - indx(i + 1) = iidx + k = (ileft + iright) / 2 + call iswap(v(k), v(ileft + 1)) + call iswap(indx(k), indx(ileft + 1)) + if (v(ileft) > v(iright)) then + call iswap(v(ileft), v(iright)) + call iswap(indx(ileft), indx(iright)) + end if + if (v(ileft + 1) > v(iright)) then + call iswap(v(ileft + 1), v(iright)) + call iswap(indx(ileft + 1), indx(iright)) + end if + if (v(ileft) > v(ileft + 1)) then + call iswap(v(ileft), v(ileft + 1)) + call iswap(indx(ileft), indx(ileft + 1)) + end if + i = ileft + 1 + j = iright + a = v(ileft + 1) + ia = indx(ileft + 1) + do + do + i = i + 1 + if (v(i) >= a) then + exit + end if end do - if (jstack == 0) return - iright = istack(jstack) - ileft = istack(jstack - 1) - jstack = jstack - 2 - else - k = (ileft + iright)/2 - call iswap(v(k), v(ileft + 1)) - call iswap(indx(k), indx(ileft + 1)) - if (v(ileft) > v(iright)) then - call iswap(v(ileft), v(iright)) - call iswap(indx(ileft), indx(iright)) - end if - if (v(ileft + 1) > v(iright)) then - call iswap(v(ileft + 1), v(iright)) - call iswap(indx(ileft + 1), indx(iright)) - end if - if (v(ileft) > v(ileft + 1)) then - call iswap(v(ileft), v(ileft + 1)) - call iswap(indx(ileft), indx(ileft + 1)) - end if - i = ileft + 1 - j = iright - a = v(ileft + 1) - ia = indx(ileft + 1) do - do - i = i + 1 - if (v(i) >= a) then - exit - end if - end do - do - j = j - 1 - if (v(j) <= a) then - exit - end if - end do - if (j < i) then + j = j - 1 + if (v(j) <= a) then exit end if - call iswap(v(i), v(j)) - call iswap(indx(i), indx(j)) end do - v(ileft + 1) = v(j) - indx(ileft + 1) = indx(j) - v(j) = a - indx(j) = ia - jstack = jstack + 2 - if (jstack > nstack) then - write(errmsg,'(4x,a,3(1x,a))') & - 'JSTACK > NSTACK IN SortModule::qsort' - call store_error(errmsg, terminate=.TRUE.) - end if - if ((iright - i + 1) >= (j - 1)) then - istack(jstack) = iright - istack(jstack - 1) = i - iright = j - 1 - else - istack(jstack) = j - 1 - istack(jstack - 1) = ileft - ileft = i + if (j < i) then + exit end if - end if - end do - ! - ! -- reverse order of the heap index - if (lrev) then - j = nsize - do i = 1, nsize / 2 call iswap(v(i), v(j)) call iswap(indx(i), indx(j)) - j = j - 1 end do + v(ileft + 1) = v(j) + indx(ileft + 1) = indx(j) + v(j) = a + indx(j) = ia + jstack = jstack + 2 + if (jstack > nstack) then + write (errmsg, '(4x,a,3(1x,a))') & + 'JSTACK > NSTACK IN SortModule::qsort' + call store_error(errmsg, terminate=.TRUE.) + end if + if ((iright - i + 1) >= (j - 1)) then + istack(jstack) = iright + istack(jstack - 1) = i + iright = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = ileft + ileft = i + end if end if - ! - ! -- return - return - end subroutine qsort_int1d + end do + ! + ! -- reverse order of the heap index + if (lrev) then + j = nsize + do i = 1, nsize / 2 + call iswap(v(i), v(j)) + call iswap(indx(i), indx(j)) + j = j - 1 + end do + end if + ! + ! -- return + return + end subroutine qsort_int1d - subroutine qsort_dbl1d(indx, v, reverse) + subroutine qsort_dbl1d(indx, v, reverse) ! ************************************************************************** ! qsort -- quick sort that also includes an index number ! ************************************************************************** ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - ! -- dummy arguments - integer(I4B), dimension(:), intent(inout) :: indx - real(DP), dimension(:), intent(inout) :: v - logical, intent(in), optional :: reverse - ! -- local variables - logical :: lrev - integer(I4B), parameter :: nn=15 - integer(I4B), parameter :: nstack=50 - integer(I4B) :: nsize - integer(I4B) :: k - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: jstack - integer(I4B) :: ileft - integer(I4B) :: iright - integer(I4B), dimension(nstack) :: istack - integer(I4B) :: iidx - integer(I4B) :: ia - real(DP) :: a - ! -- functions - ! -- code - ! - ! -- process optional dummy variables - if (present(reverse)) then - lrev = reverse + ! -- dummy arguments + integer(I4B), dimension(:), intent(inout) :: indx + real(DP), dimension(:), intent(inout) :: v + logical, intent(in), optional :: reverse + ! -- local variables + logical :: lrev + integer(I4B), parameter :: nn = 15 + integer(I4B), parameter :: nstack = 50 + integer(I4B) :: nsize + integer(I4B) :: k + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: jstack + integer(I4B) :: ileft + integer(I4B) :: iright + integer(I4B), dimension(nstack) :: istack + integer(I4B) :: iidx + integer(I4B) :: ia + real(DP) :: a + ! -- functions + ! -- code + ! + ! -- process optional dummy variables + if (present(reverse)) then + lrev = reverse + else + lrev = .FALSE. + end if + ! + ! -- initialize variables + nsize = size(v) + jstack = 0 + ileft = 1 + iright = nsize + ! + ! -- perform quicksort + do + if (iright - ileft < nn) then + do j = (ileft + 1), iright + a = v(j) + iidx = indx(j) + do i = (j - 1), ileft, -1 + if (v(i) <= a) exit + v(i + 1) = v(i) + indx(i + 1) = indx(i) + end do + v(i + 1) = a + indx(i + 1) = iidx + end do + if (jstack == 0) return + iright = istack(jstack) + ileft = istack(jstack - 1) + jstack = jstack - 2 else - lrev = .FALSE. - endif - ! - ! -- initialize variables - nsize = size(v) - jstack = 0 - ileft = 1 - iright = nsize - ! - ! -- perform quicksort - do - if (iright - ileft < nn) then - do j = (ileft + 1), iright - a = v(j) - iidx = indx(j) - do i = (j - 1), ileft, -1 - if (v(i) <= a) exit - v(i+ 1) = v(i) - indx(i+ 1) = indx(i) - end do - v(i + 1) = a - indx(i + 1) = iidx + k = (ileft + iright) / 2 + call rswap(v(k), v(ileft + 1)) + call iswap(indx(k), indx(ileft + 1)) + if (v(ileft) > v(iright)) then + call rswap(v(ileft), v(iright)) + call iswap(indx(ileft), indx(iright)) + end if + if (v(ileft + 1) > v(iright)) then + call rswap(v(ileft + 1), v(iright)) + call iswap(indx(ileft + 1), indx(iright)) + end if + if (v(ileft) > v(ileft + 1)) then + call rswap(v(ileft), v(ileft + 1)) + call iswap(indx(ileft), indx(ileft + 1)) + end if + i = ileft + 1 + j = iright + a = v(ileft + 1) + ia = indx(ileft + 1) + do + do + i = i + 1 + if (v(i) >= a) then + exit + end if end do - if (jstack == 0) return - iright = istack(jstack) - ileft = istack(jstack - 1) - jstack = jstack - 2 - else - k = (ileft + iright)/2 - call rswap(v(k), v(ileft + 1)) - call iswap(indx(k), indx(ileft + 1)) - if (v(ileft) > v(iright)) then - call rswap(v(ileft), v(iright)) - call iswap(indx(ileft), indx(iright)) - end if - if (v(ileft + 1) > v(iright)) then - call rswap(v(ileft + 1), v(iright)) - call iswap(indx(ileft + 1), indx(iright)) - end if - if (v(ileft) > v(ileft + 1)) then - call rswap(v(ileft), v(ileft + 1)) - call iswap(indx(ileft), indx(ileft + 1)) - end if - i = ileft + 1 - j = iright - a = v(ileft + 1) - ia = indx(ileft + 1) do - do - i = i + 1 - if (v(i) >= a) then - exit - end if - end do - do - j = j - 1 - if (v(j) <= a) then - exit - end if - end do - if (j < i) then + j = j - 1 + if (v(j) <= a) then exit end if - call rswap(v(i), v(j)) - call iswap(indx(i), indx(j)) end do - v(ileft + 1) = v(j) - indx(ileft + 1) = indx(j) - v(j) = a - indx(j) = ia - jstack = jstack + 2 - if (jstack > nstack) then - write(errmsg,'(4x,a,3(1x,a))') & - 'JSTACK > NSTACK IN SortModule::qsort' - call store_error(errmsg, terminate=.TRUE.) - end if - if ((iright - i + 1) >= (j - 1)) then - istack(jstack) = iright - istack(jstack - 1) = i - iright = j - 1 - else - istack(jstack) = j - 1 - istack(jstack - 1) = ileft - ileft = i + if (j < i) then + exit end if - end if - end do - ! - ! -- reverse order of the heap index - if (lrev) then - j = nsize - do i = 1, nsize / 2 call rswap(v(i), v(j)) call iswap(indx(i), indx(j)) - j = j - 1 end do + v(ileft + 1) = v(j) + indx(ileft + 1) = indx(j) + v(j) = a + indx(j) = ia + jstack = jstack + 2 + if (jstack > nstack) then + write (errmsg, '(4x,a,3(1x,a))') & + 'JSTACK > NSTACK IN SortModule::qsort' + call store_error(errmsg, terminate=.TRUE.) + end if + if ((iright - i + 1) >= (j - 1)) then + istack(jstack) = iright + istack(jstack - 1) = i + iright = j - 1 + else + istack(jstack) = j - 1 + istack(jstack - 1) = ileft + ileft = i + end if end if - ! - ! -- return - return - end subroutine qsort_dbl1d - - subroutine unique_values_int1d(a, b) - ! - dummy arguments - integer(I4B), dimension(:), allocatable, intent(in) :: a - integer(I4B), dimension(:), allocatable, intent(inout) :: b - ! -- local variables - integer(I4B) :: count - integer(I4B) :: n - integer(I4B), dimension(:), allocatable :: indxarr - integer(I4B), dimension(:), allocatable :: tarr - ! -- functions - ! -- code - ! - ! -- allocate tarr and create idxarr - allocate(tarr(size(a))) - allocate(indxarr(size(a))) - ! - ! -- fill tarr with a and create index - do n = 1, size(a) - tarr(n) = a(n) - indxarr(n) = n + end do + ! + ! -- reverse order of the heap index + if (lrev) then + j = nsize + do i = 1, nsize / 2 + call rswap(v(i), v(j)) + call iswap(indx(i), indx(j)) + j = j - 1 end do - ! - ! -- sort a in increasing order - call qsort(indxarr, tarr, reverse=.TRUE.) - ! - ! -- determine the number of unique values - count = 1 - do n = 2, size(tarr) - if (tarr(n) > tarr(n-1)) count = count + 1 - end do - ! - ! -- allocate b for unique values - if (allocated(b)) then - deallocate(b) + end if + ! + ! -- return + return + end subroutine qsort_dbl1d + + subroutine unique_values_int1d(a, b) + ! - dummy arguments + integer(I4B), dimension(:), allocatable, intent(in) :: a + integer(I4B), dimension(:), allocatable, intent(inout) :: b + ! -- local variables + integer(I4B) :: count + integer(I4B) :: n + integer(I4B), dimension(:), allocatable :: indxarr + integer(I4B), dimension(:), allocatable :: tarr + ! -- functions + ! -- code + ! + ! -- allocate tarr and create idxarr + allocate (tarr(size(a))) + allocate (indxarr(size(a))) + ! + ! -- fill tarr with a and create index + do n = 1, size(a) + tarr(n) = a(n) + indxarr(n) = n + end do + ! + ! -- sort a in increasing order + call qsort(indxarr, tarr, reverse=.TRUE.) + ! + ! -- determine the number of unique values + count = 1 + do n = 2, size(tarr) + if (tarr(n) > tarr(n - 1)) count = count + 1 + end do + ! + ! -- allocate b for unique values + if (allocated(b)) then + deallocate (b) + end if + allocate (b(count)) + ! + ! -- fill b with unique values + b(1) = tarr(1) + count = 1 + do n = 2, size(a) + if (tarr(n) > b(count)) then + count = count + 1 + b(count) = tarr(n) end if - allocate(b(count)) - ! - ! -- fill b with unique values - b(1) = tarr(1) - count = 1 - do n = 2, size(a) - if (tarr(n) > b(count)) then - count = count + 1 - b(count) = tarr(n) - end if - end do - ! - ! -- allocate tarr and create idxarr - deallocate(tarr) - deallocate(indxarr) - ! - ! -- return - return - end subroutine unique_values_int1d - - subroutine unique_values_dbl1d(a, b) - ! - dummy arguments - real(DP), dimension(:), allocatable, intent(in) :: a - real(DP), dimension(:), allocatable, intent(inout) :: b - ! -- local variables - integer(I4B) :: count - integer(I4B) :: n - integer(I4B), dimension(:), allocatable :: indxarr - real(DP), dimension(:), allocatable :: tarr - ! -- functions - ! -- code - ! - ! -- allocate tarr and create idxarr - allocate(tarr(size(a))) - allocate(indxarr(size(a))) - ! - ! -- fill tarr with a and create index - do n = 1, size(a) - tarr(n) = a(n) - indxarr(n) = n - end do - ! - ! -- sort a in increasing order - call qsort(indxarr, tarr, reverse=.TRUE.) - ! - ! -- determine the number of unique values - count = 1 - do n = 2, size(tarr) - if (tarr(n) > tarr(n-1)) count = count + 1 - end do - ! - ! -- allocate b for unique values - if (allocated(b)) then - deallocate(b) + end do + ! + ! -- allocate tarr and create idxarr + deallocate (tarr) + deallocate (indxarr) + ! + ! -- return + return + end subroutine unique_values_int1d + + subroutine unique_values_dbl1d(a, b) + ! - dummy arguments + real(DP), dimension(:), allocatable, intent(in) :: a + real(DP), dimension(:), allocatable, intent(inout) :: b + ! -- local variables + integer(I4B) :: count + integer(I4B) :: n + integer(I4B), dimension(:), allocatable :: indxarr + real(DP), dimension(:), allocatable :: tarr + ! -- functions + ! -- code + ! + ! -- allocate tarr and create idxarr + allocate (tarr(size(a))) + allocate (indxarr(size(a))) + ! + ! -- fill tarr with a and create index + do n = 1, size(a) + tarr(n) = a(n) + indxarr(n) = n + end do + ! + ! -- sort a in increasing order + call qsort(indxarr, tarr, reverse=.TRUE.) + ! + ! -- determine the number of unique values + count = 1 + do n = 2, size(tarr) + if (tarr(n) > tarr(n - 1)) count = count + 1 + end do + ! + ! -- allocate b for unique values + if (allocated(b)) then + deallocate (b) + end if + allocate (b(count)) + ! + ! -- fill b with unique values + b(1) = tarr(1) + count = 1 + do n = 2, size(a) + if (tarr(n) > b(count)) then + count = count + 1 + b(count) = tarr(n) end if - allocate(b(count)) - ! - ! -- fill b with unique values - b(1) = tarr(1) - count = 1 - do n = 2, size(a) - if (tarr(n) > b(count)) then - count = count + 1 - b(count) = tarr(n) - end if - end do - ! - ! -- allocate tarr and create idxarr - deallocate(tarr) - deallocate(indxarr) - ! - ! -- return - return - end subroutine unique_values_dbl1d - - subroutine selectn(indx, v, reverse) + end do + ! + ! -- allocate tarr and create idxarr + deallocate (tarr) + deallocate (indxarr) + ! + ! -- return + return + end subroutine unique_values_dbl1d + + subroutine selectn(indx, v, reverse) ! ************************************************************************** ! selectn -- heap selection ! ************************************************************************** ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - ! -- dummy arguments - integer(I4B), dimension(:), intent(inout) :: indx - real(DP), dimension(:), intent(inout) :: v - logical, intent(in), optional :: reverse - ! -- local variables - logical :: lrev - integer(I4B) :: nsizei - integer(I4B) :: nsizev - integer(I4B) :: i - integer(I4B) :: j - integer(I4B) :: k - integer(I4B) :: n - !integer(I4B) :: iidx - real(DP), dimension(:), allocatable :: vv - ! -- functions - ! -- code - ! - ! -- process optional dummy variables - if (present(reverse)) then - lrev = reverse - else - lrev = .FALSE. - endif - ! - ! -- initialize heap - nsizev = size(v) - nsizei = min(nsizev, size(indx)) - allocate(vv(nsizei)) - ! - ! -- initialize heap index (indx) and heap (vv) - do n = 1, nsizei - vv(n) = v(n) - indx(n) = n - end do - ! - ! -- initial sort - call qsort(indx, vv) - ! - ! -- evaluate the remaining elements in v - do i = nsizei+1, nsizev - ! - ! -- put the current value on the heap - if (v(i) > vv(1)) then - vv(1) = v(i) - indx(1) = i - j = 1 - do - k = 2 * j - if (k > nsizei) then - exit - end if - if (k /= nsizei) then - if (vv(k) > vv(k+1)) then - k = k + 1 - end if - end if - if (vv(j) <= vv(k)) then - exit + ! -- dummy arguments + integer(I4B), dimension(:), intent(inout) :: indx + real(DP), dimension(:), intent(inout) :: v + logical, intent(in), optional :: reverse + ! -- local variables + logical :: lrev + integer(I4B) :: nsizei + integer(I4B) :: nsizev + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: k + integer(I4B) :: n + !integer(I4B) :: iidx + real(DP), dimension(:), allocatable :: vv + ! -- functions + ! -- code + ! + ! -- process optional dummy variables + if (present(reverse)) then + lrev = reverse + else + lrev = .FALSE. + end if + ! + ! -- initialize heap + nsizev = size(v) + nsizei = min(nsizev, size(indx)) + allocate (vv(nsizei)) + ! + ! -- initialize heap index (indx) and heap (vv) + do n = 1, nsizei + vv(n) = v(n) + indx(n) = n + end do + ! + ! -- initial sort + call qsort(indx, vv) + ! + ! -- evaluate the remaining elements in v + do i = nsizei + 1, nsizev + ! + ! -- put the current value on the heap + if (v(i) > vv(1)) then + vv(1) = v(i) + indx(1) = i + j = 1 + do + k = 2 * j + if (k > nsizei) then + exit + end if + if (k /= nsizei) then + if (vv(k) > vv(k + 1)) then + k = k + 1 end if - call rswap(vv(k), vv(j)) - call iswap(indx(k), indx(j)) - j = k - end do - end if - end do - ! - ! -- final sort - call qsort(indx, vv) - ! - ! -- reverse order of the heap index - if (lrev) then - j = nsizei - do i = 1, nsizei / 2 - call iswap(indx(i), indx(j)) - j = j - 1 + end if + if (vv(j) <= vv(k)) then + exit + end if + call rswap(vv(k), vv(j)) + call iswap(indx(k), indx(j)) + j = k end do end if - ! - ! -- return - return - end subroutine selectn + end do + ! + ! -- final sort + call qsort(indx, vv) + ! + ! -- reverse order of the heap index + if (lrev) then + j = nsizei + do i = 1, nsizei / 2 + call iswap(indx(i), indx(j)) + j = j - 1 + end do + end if + ! + ! -- return + return + end subroutine selectn - subroutine rswap(a, b) - ! -- dummy arguments - real(DP), intent(inout) :: a - real(DP), intent(inout) :: b - ! -- local variables - real(DP) :: d - ! -- functions - ! -- code - d = a - a = b - b = d - ! - ! -- return - return - end subroutine rswap + subroutine rswap(a, b) + ! -- dummy arguments + real(DP), intent(inout) :: a + real(DP), intent(inout) :: b + ! -- local variables + real(DP) :: d + ! -- functions + ! -- code + d = a + a = b + b = d + ! + ! -- return + return + end subroutine rswap + + subroutine iswap(ia, ib) + ! -- dummy arguments + integer(I4B), intent(inout) :: ia + integer(I4B), intent(inout) :: ib + ! -- local variables + integer(I4B) :: id + ! -- functions + ! -- code + id = ia + ia = ib + ib = id + ! + ! -- return + return + end subroutine iswap - subroutine iswap(ia, ib) - ! -- dummy arguments - integer(I4B), intent(inout) :: ia - integer(I4B), intent(inout) :: ib - ! -- local variables - integer(I4B) :: id - ! -- functions - ! -- code - id = ia - ia = ib - ib = id - ! - ! -- return - return - end subroutine iswap - - - end module SortModule diff --git a/src/Utilities/version.f90 b/src/Utilities/version.f90 index d1c1aff4763..95fd8e01ec5 100644 --- a/src/Utilities/version.f90 +++ b/src/Utilities/version.f90 @@ -13,139 +13,141 @@ module VersionModule use CompilerVersion, only: get_compiler, get_compile_options implicit none public - ! -- modflow 6 version + ! -- modflow 6 version integer(I4B), parameter :: IDEVELOPMODE = 1 - character(len=40), parameter :: VERSION = '6.4.0 release candidate 03/04/2022' - character(len=10), parameter :: MFVNAM = ' 6' - character(len=*), parameter :: MFTITLE = & - 'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL' - character(len=*), parameter :: FMTTITLE = & - "(/,34X,'MODFLOW',A,/, & - &16X,'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL', & - &/,23X,'Version ',A/)" - ! -- license for MODFLOW and libraries - character(len=*), parameter :: FMTLICENSE = & - "(/, & - &'As a work of the United States Government, this USGS product is ',/, & - &'in the public domain within the United States. You can copy, ',/, & - &'modify, distribute, and perform the work, even for commercial ',/, & - &'purposes, all without asking permission. Additionally, USGS ',/, & - &'waives copyright and related rights in the work worldwide ',/, & - &'through CC0 1.0 Universal Public Domain Dedication ',/, & - &'(https://creativecommons.org/publicdomain/zero/1.0/).',//, & - &'The following GNU Lesser General Public License (LGPL) libraries',/, & - &'are used in this USGS product:',//, & - &' SPARSKIT version 2.0',/, & - &' ilut, luson, and qsplit ',/, & - &' (https://www-users.cse.umn.edu/~saad/software/SPARSKIT/)',//, & - &' RCM - Reverse Cuthill McKee Ordering',/, & - &' (https://people.math.sc.edu/Burkardt/f_src/rcm/rcm.html)',//, & - &' BLAS - Basic Linear Algebra Subprograms Level 1',/, & - &' (https://people.math.sc.edu/Burkardt/f_src/blas1_d/', & - &'blas1_d.html)',//, & - &' SPARSEKIT - Sparse Matrix Utility Package',/, & - &' amux, dperm, dvperm, rperm, and cperm',/, & - &' (https://people.sc.fsu.edu/~jburkardt/f77_src/sparsekit/', & - &'sparsekit.html)',//, & - &'The following BSD-3 License libraries are used in this USGS product:',//, & - &' Modern Fortran DAG Library',/, & - &' Copyright (c) 2018, Jacob Williams',/, & - &' All rights reserved.',/, & - &' (https://github.com/jacobwilliams/daglib)',/ & - &)" - ! -- disclaimer must be appropriate for version (release or release candidate) - character(len=*), parameter :: FMTDISCLAIMER = & - "(/, & - &'This software is preliminary or provisional and is subject to ',/, & - &'revision. It is being provided to meet the need for timely best ',/, & - &'science. The software has not received final approval by the U.S. ',/, & - &'Geological Survey (USGS). No warranty, expressed or implied, is made ',/, & - &'by the USGS or the U.S. Government as to the functionality of the ',/, & - &'software and related material nor shall the fact of release ',/, & - &'constitute any such warranty. The software is provided on the ',/, & + character(len=*), parameter :: VERSIONNUMBER = '6.4.0' + character(len=*), parameter :: VERSIONTAG = ' release candidate 03/04/2022' + character(len=40), parameter :: VERSION = VERSIONNUMBER//VERSIONTAG + character(len=10), parameter :: MFVNAM = ' 6' + character(len=*), parameter :: MFTITLE = & + &'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL' + character(len=*), parameter :: FMTTITLE = & + "(/,34X,'MODFLOW',A,/,& + &16X,'U.S. GEOLOGICAL SURVEY MODULAR HYDROLOGIC MODEL',& + &/,23X,'Version ',A/)" + ! -- license for MODFLOW and libraries + character(len=*), parameter :: FMTLICENSE = & + "(/,& + &'As a work of the United States Government, this USGS product is ',/,& + &'in the public domain within the United States. You can copy, ',/,& + &'modify, distribute, and perform the work, even for commercial ',/,& + &'purposes, all without asking permission. Additionally, USGS ',/,& + &'waives copyright and related rights in the work worldwide ',/,& + &'through CC0 1.0 Universal Public Domain Dedication ',/,& + &'(https://creativecommons.org/publicdomain/zero/1.0/).',//,& + &'The following GNU Lesser General Public License (LGPL) libraries',/,& + &'are used in this USGS product:',//,"// & + "' SPARSKIT version 2.0',/,& + &' ilut, luson, and qsplit ',/,& + &' (https://www-users.cse.umn.edu/~saad/software/SPARSKIT/)',//,& + &' RCM - Reverse Cuthill McKee Ordering',/,& + &' (https://people.math.sc.edu/Burkardt/f_src/rcm/rcm.html)',//,& + &' BLAS - Basic Linear Algebra Subprograms Level 1',/,& + &' (https://people.math.sc.edu/Burkardt/f_src/blas1_d/',& + &'blas1_d.html)',//,"// & + "' SPARSEKIT - Sparse Matrix Utility Package',/,& + &' amux, dperm, dvperm, rperm, and cperm',/,& + &' (https://people.sc.fsu.edu/~jburkardt/f77_src/sparsekit/',& + &'sparsekit.html)',//,& + &'The following BSD-3 License libraries are used in this USGS product:',//,& + &' Modern Fortran DAG Library',/,& + &' Copyright (c) 2018, Jacob Williams',/,& + &' All rights reserved.',/,& + &' (https://github.com/jacobwilliams/daglib)',/& + &)" + ! -- disclaimer must be appropriate for version (release or release candidate) + character(len=*), parameter :: FMTDISCLAIMER = & + "(/,& + &'This software is preliminary or provisional and is subject to ',/,& + &'revision. It is being provided to meet the need for timely best ',/,& + &'science. The software has not received final approval by the U.S. ',/,& + &'Geological Survey (USGS). No warranty, expressed or implied, is made ',/,& + &'by the USGS or the U.S. Government as to the functionality of the ',/,& + &'software and related material nor shall the fact of release ',/,& + &'constitute any such warranty. The software is provided on the ',/,& &'condition that neither the USGS nor the U.S. Government shall be held ',/,& - &'liable for any damages resulting from the authorized or unauthorized ',/, & + &'liable for any damages resulting from the authorized or unauthorized ',/,& &'use of the software.',/)" - contains +contains - !> @ brief Write program header + !> @ brief Write program header !! !! Write header for program to the program listing file. !! - !< - subroutine write_listfile_header(iout, cmodel_type, write_sys_command, & - write_kind_info) - ! -- dummy variables - integer(I4B), intent(in) :: iout !< program listing file - character(len=*), intent(in), optional :: cmodel_type !< optional model type string - logical(LGP), intent(in), optional :: write_sys_command !< boolean indicating if the system command should be written - logical(LGP), intent(in), optional :: write_kind_info !< boolean indicating in program data types should be written - ! -- local variables - character(len=LENBIGLINE) :: syscmd - character(len=LENBIGLINE) :: compiler - character(len=LENBIGLINE) :: compiler_options - integer(I4B) :: iheader_width = 80 - logical(LGP) :: wki - logical(LGP) :: wsc - ! - ! -- Write title to list file - call write_centered('MODFLOW'//MFVNAM, iheader_width, iunit=iout) - call write_centered(MFTITLE, iheader_width, iunit=iout) - ! - ! -- Write model type to list file - if (present(cmodel_type)) then - call write_centered(cmodel_type, iheader_width, iunit=iout) - end if - ! - ! -- Write version - call write_centered('VERSION '//VERSION, iheader_width, iunit=iout) - ! - ! -- Write if develop mode - if (IDEVELOPMODE == 1) then - call write_centered('***DEVELOP MODE***', iheader_width, iunit=iout) - end if - ! - ! -- Write compiler version - call get_compiler(compiler) - call write_centered(' ', iheader_width, iunit=iout) - call write_centered(trim(adjustl(compiler)), iheader_width, iunit=iout) - ! - ! -- Write disclaimer - write(iout, FMTDISCLAIMER) - ! - ! -- Write license information - if (iout /= istdout) then - write(iout, FMTLICENSE) - end if - ! - ! -- write compiler options - if (iout /= istdout) then - call get_compile_options(compiler_options) - call write_message(compiler_options, iunit=iout) - end if - ! - ! -- Write the system command used to initiate simulation - wsc = .true. - if (present(write_sys_command)) wsc = write_sys_command - if (wsc) then - call GET_COMMAND(syscmd) - write(iout, '(/,a,/,a)') 'System command used to initiate simulation:', & - trim(syscmd) - end if - ! - ! -- Write precision of real variables - wki = .true. - if (present(write_kind_info)) wki = write_kind_info - if (wki) then - write(iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' - call write_kindinfo(iout) - end if - write(iout, *) - ! - ! -- return - return - end subroutine write_listfile_header + !< + subroutine write_listfile_header(iout, cmodel_type, write_sys_command, & + write_kind_info) + ! -- dummy variables + integer(I4B), intent(in) :: iout !< program listing file + character(len=*), intent(in), optional :: cmodel_type !< optional model type string + logical(LGP), intent(in), optional :: write_sys_command !< boolean indicating if the system command should be written + logical(LGP), intent(in), optional :: write_kind_info !< boolean indicating in program data types should be written + ! -- local variables + character(len=LENBIGLINE) :: syscmd + character(len=LENBIGLINE) :: compiler + character(len=LENBIGLINE) :: compiler_options + integer(I4B) :: iheader_width = 80 + logical(LGP) :: wki + logical(LGP) :: wsc + ! + ! -- Write title to list file + call write_centered('MODFLOW'//MFVNAM, iheader_width, iunit=iout) + call write_centered(MFTITLE, iheader_width, iunit=iout) + ! + ! -- Write model type to list file + if (present(cmodel_type)) then + call write_centered(cmodel_type, iheader_width, iunit=iout) + end if + ! + ! -- Write version + call write_centered('VERSION '//VERSION, iheader_width, iunit=iout) + ! + ! -- Write if develop mode + if (IDEVELOPMODE == 1) then + call write_centered('***DEVELOP MODE***', iheader_width, iunit=iout) + end if + ! + ! -- Write compiler version + call get_compiler(compiler) + call write_centered(' ', iheader_width, iunit=iout) + call write_centered(trim(adjustl(compiler)), iheader_width, iunit=iout) + ! + ! -- Write disclaimer + write (iout, FMTDISCLAIMER) + ! + ! -- Write license information + if (iout /= istdout) then + write (iout, FMTLICENSE) + end if + ! + ! -- write compiler options + if (iout /= istdout) then + call get_compile_options(compiler_options) + call write_message(compiler_options, iunit=iout) + end if + ! + ! -- Write the system command used to initiate simulation + wsc = .true. + if (present(write_sys_command)) wsc = write_sys_command + if (wsc) then + call GET_COMMAND(syscmd) + write (iout, '(/,a,/,a)') & + 'System command used to initiate simulation:', trim(syscmd) + end if + ! + ! -- Write precision of real variables + wki = .true. + if (present(write_kind_info)) wki = write_kind_info + if (wki) then + write (iout, '(/,a)') 'MODFLOW was compiled using uniform precision.' + call write_kindinfo(iout) + end if + write (iout, *) + ! + ! -- return + return + end subroutine write_listfile_header end module VersionModule From 983aa452c530d365306fed119426276e6b8dedcd Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 16:28:45 -0700 Subject: [PATCH 007/212] Updating the four files located in 'src' directory with the fprettify stuff. The SimulationCreate.f90 file had some of my local changes. --- src/SimulationCreate.f90 | 440 ++++++++-------- src/mf6.f90 | 3 +- src/mf6core.f90 | 1056 +++++++++++++++++++------------------- src/mf6lists.f90 | 10 +- 4 files changed, 758 insertions(+), 751 deletions(-) diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index 0145033aaab..7ade72dccbb 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -1,24 +1,24 @@ module SimulationCreateModule - use KindModule, only: DP, I4B, write_kindinfo - use ConstantsModule, only: LINELENGTH, LENMODELNAME, LENBIGLINE, DZERO - use SimVariablesModule, only: simfile, simlstfile, iout + use KindModule, only: DP, I4B, write_kindinfo + use ConstantsModule, only: LINELENGTH, LENMODELNAME, LENBIGLINE, DZERO + use SimVariablesModule, only: simfile, simlstfile, iout use GenericUtilitiesModule, only: sim_message, write_centered - use SimModule, only: store_error, count_errors, & - store_error_unit, MaxErrors - use VersionModule, only: write_listfile_header - use InputOutputModule, only: getunit, urword, openfile - use ArrayHandlersModule, only: expandarray, ifind - use BaseModelModule, only: BaseModelType - use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & - GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, AddSolutionGroupToList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use ListsModule, only: basesolutionlist, basemodellist, & - solutiongrouplist, baseexchangelist - use BaseModelModule, only: GetBaseModelFromList - use BlockParserModule, only: BlockParserType - use ListModule, only: ListType + use SimModule, only: store_error, count_errors, & + store_error_unit, MaxErrors + use VersionModule, only: write_listfile_header + use InputOutputModule, only: getunit, urword, openfile + use ArrayHandlersModule, only: expandarray, ifind + use BaseModelModule, only: BaseModelType + use BaseSolutionModule, only: BaseSolutionType, AddBaseSolutionToList, & + GetBaseSolutionFromList + use SolutionGroupModule, only: SolutionGroupType, AddSolutionGroupToList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use ListsModule, only: basesolutionlist, basemodellist, & + solutiongrouplist, baseexchangelist + use BaseModelModule, only: GetBaseModelFromList + use BlockParserModule, only: BlockParserType + use ListModule, only: ListType implicit none private @@ -29,7 +29,7 @@ module SimulationCreateModule character(len=LENMODELNAME), allocatable, dimension(:) :: modelname type(BlockParserType) :: parser - contains +contains !> @brief Read the simulation name file and initialize the models, exchanges !< @@ -39,7 +39,7 @@ subroutine simulation_cr() character(len=LINELENGTH) :: line ! ------------------------------------------------------------------------------ ! - ! -- initialize iout + ! -- initialize iout iout = 0 ! ! -- Open simulation list file @@ -47,8 +47,8 @@ subroutine simulation_cr() call openfile(iout, 0, simlstfile, 'LIST', filstat_opt='REPLACE') ! ! -- write simlstfile to stdout - write(line,'(2(1x,A))') 'Writing simulation list file:', & - trim(adjustl(simlstfile)) + write (line, '(2(1x,A))') 'Writing simulation list file:', & + trim(adjustl(simlstfile)) call sim_message(line) call write_listfile_header(iout) ! @@ -58,7 +58,7 @@ subroutine simulation_cr() ! -- Return return end subroutine simulation_cr - + !> @brief Deallocate simulation variables !< subroutine simulation_da() @@ -67,7 +67,7 @@ subroutine simulation_da() ! ------------------------------------------------------------------------------ ! ! -- variables - deallocate(modelname) + deallocate (modelname) ! ! -- Return return @@ -82,7 +82,7 @@ end subroutine simulation_da !< subroutine read_simulation_namefile(namfile) ! -- dummy - character(len=*),intent(in) :: namfile !< simulation name file + character(len=*), intent(in) :: namfile !< simulation name file ! -- local character(len=LINELENGTH) :: line ! ------------------------------------------------------------------------------ @@ -92,7 +92,7 @@ subroutine read_simulation_namefile(namfile) call openfile(inunit, iout, namfile, 'NAM') ! ! -- write name of namfile to stdout - write(line,'(2(1x,a))') 'Using Simulation name file:', namfile + write (line, '(2(1x,a))') 'Using Simulation name file:', namfile call sim_message(line, skipafter=1) ! ! -- Initialize block parser @@ -121,7 +121,7 @@ subroutine read_simulation_namefile(namfile) call parser%Clear() ! ! -- Go through each solution and assign exchanges accordingly - call assign_exchanges() + call assign_exchanges() ! ! -- Return return @@ -143,44 +143,44 @@ subroutine options_create() ! ! -- Process OPTIONS block call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION OPTIONS' + write (iout, '(/1x,a)') 'READING SIMULATION OPTIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('CONTINUE') - isimcontinue = 1 - write(iout, '(4x, a)') & - 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' - case ('NOCHECK') - isimcheck = 0 - write(iout, '(4x, a)') & - 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' - case ('MEMORY_PRINT_OPTION') - errmsg = '' - call parser%GetStringCaps(keyword) - call mem_set_print_option(iout, keyword, errmsg) - if (errmsg /= ' ') then - call store_error(errmsg) - call parser%StoreErrorUnit() - endif - case ('MAXERRORS') - imax = parser%GetInteger() - call MaxErrors(imax) - write(iout, '(4x, a, i0)') & - 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', imax - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION OPTION: ', & - trim(keyword) + case ('CONTINUE') + isimcontinue = 1 + write (iout, '(4x, a)') & + 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' + case ('NOCHECK') + isimcheck = 0 + write (iout, '(4x, a)') & + 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' + case ('MEMORY_PRINT_OPTION') + errmsg = '' + call parser%GetStringCaps(keyword) + call mem_set_print_option(iout, keyword, errmsg) + if (errmsg /= ' ') then call store_error(errmsg) call parser%StoreErrorUnit() + end if + case ('MAXERRORS') + imax = parser%GetInteger() + call MaxErrors(imax) + write (iout, '(4x, a, i0)') & + 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', imax + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION OPTION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION OPTIONS' + write (iout, '(1x,a)') 'END OF SIMULATION OPTIONS' end if ! ! -- return @@ -206,27 +206,27 @@ subroutine timing_create() ! ! -- Process TIMING block call parser%GetBlock('TIMING', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION TIMING' + write (iout, '(/1x,a)') 'READING SIMULATION TIMING' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('TDIS6') - found_tdis = .true. - call parser%GetString(line) - call tdis_cr(line) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION TIMING: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('TDIS6') + found_tdis = .true. + call parser%GetString(line) + call tdis_cr(line) + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION TIMING: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION TIMING' + write (iout, '(1x,a)') 'END OF SIMULATION TIMING' else call store_error('****ERROR. Did not find TIMING block in simulation'// & ' control file.') @@ -234,10 +234,10 @@ subroutine timing_create() end if ! ! -- Ensure that TDIS was found - if(.not. found_tdis) then + if (.not. found_tdis) then call store_error('****ERROR. TDIS not found in TIMING block.') call parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -247,9 +247,10 @@ end subroutine timing_create !< subroutine models_create() ! -- modules - use GwfModule, only: gwf_cr - use GwtModule, only: gwt_cr - use ConstantsModule, only: LENMODELNAME + use GwfModule, only: gwf_cr + use GwtModule, only: gwt_cr + use GweModule, only: gwe_cr + use ConstantsModule, only: LENMODELNAME ! -- dummy ! -- local integer(I4B) :: ierr @@ -262,32 +263,36 @@ subroutine models_create() ! ! -- Process MODELS block call parser%GetBlock('MODELS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION MODELS' + write (iout, '(/1x,a)') 'READING SIMULATION MODELS' im = 0 do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('GWF6') - call parser%GetString(fname) - call add_model(im, 'GWF6', mname) - call gwf_cr(fname, im, modelname(im)) - case ('GWT6') + case ('GWF6') + call parser%GetString(fname) + call add_model(im, 'GWF6', mname) + call gwf_cr(fname, im, modelname(im)) + case ('GWT6') + call parser%GetString(fname) + call add_model(im, 'GWT6', mname) + call gwt_cr(fname, im, modelname(im)) + case ('GWE6') call parser%GetString(fname) - call add_model(im, 'GWT6', mname) - call gwt_cr(fname, im, modelname(im)) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION MODEL: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + call add_model(im, 'GWE6', mname) + call gwe_cr(fname, im, modelname(im)) + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION MODEL: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION MODELS' + write (iout, '(1x,a)') 'END OF SIMULATION MODELS' else call store_error('****ERROR. Did not find MODELS block in simulation'// & ' control file.') @@ -302,9 +307,10 @@ end subroutine models_create !< subroutine exchanges_create() ! -- modules - use GwfGwfExchangeModule, only: gwfexchange_create - use GwfGwtExchangeModule, only: gwfgwt_cr - use GwtGwtExchangeModule, only: gwtexchange_create + use GwfGwfExchangeModule, only: gwfexchange_create + use GwfGwtExchangeModule, only: gwfgwt_cr + use GwtGwtExchangeModule, only: gwtexchange_create + use GwfGweExchangeModule, only: gwfgwe_cr ! -- dummy ! -- local integer(I4B) :: ierr @@ -320,9 +326,9 @@ subroutine exchanges_create() &'file. Could not find model: ', a)" ! ------------------------------------------------------------------------------ call parser%GetBlock('EXCHANGES', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) if (isfound) then - write(iout,'(/1x,a)')'READING SIMULATION EXCHANGES' + write (iout, '(/1x,a)') 'READING SIMULATION EXCHANGES' id = 0 do call parser%GetNextLine(endOfBlock) @@ -337,39 +343,41 @@ subroutine exchanges_create() ! find model index in list m1 = ifind(modelname, name1) - if(m1 < 0) then - write(errmsg, fmtmerr) trim(name1) + if (m1 < 0) then + write (errmsg, fmtmerr) trim(name1) call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if m2 = ifind(modelname, name2) - if(m2 < 0) then - write(errmsg, fmtmerr) trim(name2) + if (m2 < 0) then + write (errmsg, fmtmerr) trim(name2) call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if - write(iout, '(4x,a,a,i0,a,i0,a,i0)') trim(keyword), ' exchange ', & - id, ' will be created to connect model ', m1, ' with model ', m2 + write (iout, '(4x,a,a,i0,a,i0,a,i0)') trim(keyword), ' exchange ', & + id, ' will be created to connect model ', m1, ' with model ', m2 select case (keyword) - case ('GWF6-GWF6') - call gwfexchange_create(fname, id, m1, m2) - case ('GWF6-GWT6') - call gwfgwt_cr(fname, id, m1, m2) - case ('GWT6-GWT6') - call gwtexchange_create(fname, id, m1, m2) - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('GWF6-GWF6') + call gwfexchange_create(fname, id, m1, m2) + case ('GWF6-GWT6') + call gwfgwt_cr(fname, id, m1, m2) + case ('GWT6-GWT6') + call gwtexchange_create(fname, id, m1, m2) + case ('GWF6-GWE6') + call gwfgwe_cr(fname, id, m1, m2) + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END OF SIMULATION EXCHANGES' + write (iout, '(1x,a)') 'END OF SIMULATION EXCHANGES' else - call store_error('****ERROR. Did not find EXCHANGES block in '// & + call store_error('****ERROR. Did not find EXCHANGES block in '// & 'simulation control file.') call parser%StoreErrorUnit() end if @@ -382,17 +390,17 @@ end subroutine exchanges_create !< subroutine solution_groups_create() ! -- modules - use SolutionGroupModule, only: SolutionGroupType, & - solutiongroup_create - use BaseSolutionModule, only: BaseSolutionType - use BaseModelModule, only: BaseModelType - use BaseExchangeModule, only: BaseExchangeType - use NumericalSolutionModule, only: solution_create + use SolutionGroupModule, only: SolutionGroupType, & + solutiongroup_create + use BaseSolutionModule, only: BaseSolutionType + use BaseModelModule, only: BaseModelType + use BaseExchangeModule, only: BaseExchangeType + use NumericalSolutionModule, only: solution_create ! -- dummy ! -- local - type(SolutionGroupType), pointer :: sgp - class(BaseSolutionType), pointer :: sp - class(BaseModelType), pointer :: mp + type(SolutionGroupType), pointer :: sgp + class(BaseSolutionType), pointer :: sp + class(BaseModelType), pointer :: mp integer(I4B) :: ierr logical :: isfound, endOfBlock integer(I4B) :: isoln @@ -405,9 +413,9 @@ subroutine solution_groups_create() character(len=LINELENGTH) :: fname, mname ! -- formats character(len=*), parameter :: fmterrmxiter = & - "('ERROR. MXITER IS SET TO ', i0, ' BUT THERE IS ONLY ONE SOLUTION', & - &' IN SOLUTION GROUP ', i0, '. SET MXITER TO 1 IN SIMULATION CONTROL', & - &' FILE.')" + "('ERROR. MXITER IS SET TO ', i0, ' BUT THERE IS ONLY ONE SOLUTION', & + &' IN SOLUTION GROUP ', i0, '. SET MXITER TO 1 IN SIMULATION CONTROL', & + &' FILE.')" ! ------------------------------------------------------------------------------ ! ! -- isoln is the cumulative solution number, isgp is the cumulative @@ -419,27 +427,27 @@ subroutine solution_groups_create() sgploop: do ! call parser%GetBlock('SOLUTIONGROUP', isfound, ierr, & - supportOpenClose=.true.) - if(ierr /= 0) exit sgploop + supportOpenClose=.true.) + if (ierr /= 0) exit sgploop if (.not. isfound) exit sgploop isgp = isgp + 1 ! ! -- Get the solutiongroup id and check that it is listed consecutively. sgid = parser%GetInteger() - if(isgp /= sgid) then - write(errmsg, '(a)') 'Solution groups are not listed consecutively.' + if (isgp /= sgid) then + write (errmsg, '(a)') 'Solution groups are not listed consecutively.' call store_error(errmsg) - write(errmsg, '(a,i0,a,i0)' ) 'Found ', sgid, ' when looking for ',isgp + write (errmsg, '(a,i0,a,i0)') 'Found ', sgid, ' when looking for ', isgp call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- Create the solutiongroup and add it to the solutiongrouplist call solutiongroup_create(sgp, sgid) call AddSolutionGroupToList(solutiongrouplist, sgp) ! ! -- Begin processing the solution group - write(iout,'(/1x,a)')'READING SOLUTIONGROUP' + write (iout, '(/1x,a)') 'READING SOLUTIONGROUP' ! ! -- Initialize isgpsoln to 0. isgpsoln is the solution counter for this ! particular solution group. It goes from 1 to the number of solutions @@ -451,126 +459,126 @@ subroutine solution_groups_create() call parser%GetStringCaps(keyword) select case (keyword) ! - case ('MXITER') - sgp%mxiter = parser%GetInteger() + case ('MXITER') + sgp%mxiter = parser%GetInteger() + ! + case ('IMS6') + ! + ! -- Initialize and increment counters + isoln = isoln + 1 + isgpsoln = isgpsoln + 1 ! - case ('IMS6') + ! -- Create the solution, retrieve from the list, and add to sgp + call parser%GetString(fname) + call solution_create(fname, isoln) + sp => GetBaseSolutionFromList(basesolutionlist, isoln) + call sgp%add_solution(isoln, sp) + ! + ! -- Add all of the models that are listed on this line to + ! the current solution (sp) + do ! - ! -- Initialize and increment counters - isoln = isoln + 1 - isgpsoln = isgpsoln + 1 + ! -- Set istart and istop to encompass model name. Exit this + ! loop if there are no more models. + call parser%GetStringCaps(mname) + if (mname == '') exit ! - ! -- Create the solution, retrieve from the list, and add to sgp - call parser%GetString(fname) - call solution_create(fname, isoln) - sp => GetBaseSolutionFromList(basesolutionlist, isoln) - call sgp%add_solution(isoln, sp) + ! -- Find the model id, and then get model + mid = ifind(modelname, mname) + if (mid <= 0) then + write (errmsg, '(a,a)') 'Error. Invalid modelname: ', & + trim(mname) + call store_error(errmsg) + call parser%StoreErrorUnit() + end if + mp => GetBaseModelFromList(basemodellist, mid) + ! + ! -- Add the model to the solution + call sp%add_model(mp) + mp%idsoln = isoln ! - ! -- Add all of the models that are listed on this line to - ! the current solution (sp) - do - ! - ! -- Set istart and istop to encompass model name. Exit this - ! loop if there are no more models. - call parser%GetStringCaps(mname) - if (mname == '') exit - ! - ! -- Find the model id, and then get model - mid = ifind(modelname, mname) - if(mid <= 0) then - write(errmsg, '(a,a)') 'Error. Invalid modelname: ', & - trim(mname) - call store_error(errmsg) - call parser%StoreErrorUnit() - endif - mp => GetBaseModelFromList(basemodellist, mid) - ! - ! -- Add the model to the solution - call sp%add_model(mp) - mp%idsoln = isoln - ! - enddo + end do ! - case default - write(errmsg, '(4x,a,a)') & - '****ERROR. UNKNOWN SOLUTIONGROUP ENTRY: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case default + write (errmsg, '(4x,a,a)') & + '****ERROR. UNKNOWN SOLUTIONGROUP ENTRY: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do ! ! -- Make sure there is a solution in this solution group - if(isgpsoln == 0) then - write(errmsg, '(4x,a,i0)') & + if (isgpsoln == 0) then + write (errmsg, '(4x,a,i0)') & 'ERROR. THERE ARE NO SOLUTIONS FOR SOLUTION GROUP ', isgp call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- If there is only one solution then mxiter should be 1. - if(isgpsoln == 1 .and. sgp%mxiter > 1) then - write(errmsg, fmterrmxiter) sgp%mxiter, isgpsoln + if (isgpsoln == 1 .and. sgp%mxiter > 1) then + write (errmsg, fmterrmxiter) sgp%mxiter, isgpsoln call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- todo: more error checking? ! - write(iout,'(1x,a)')'END OF SIMULATION SOLUTIONGROUP' + write (iout, '(1x,a)') 'END OF SIMULATION SOLUTIONGROUP' ! - enddo sgploop + end do sgploop ! ! -- Check and make sure at least one solution group was found - if(solutiongrouplist%Count() == 0) then + if (solutiongrouplist%Count() == 0) then call store_error('ERROR. THERE ARE NO SOLUTION GROUPS.') call parser%StoreErrorUnit() - endif + end if ! ! -- return return end subroutine solution_groups_create - !> @brief Check for dangling models, and break with + !> @brief Check for dangling models, and break with !! error when found !< - subroutine check_model_assignment() + subroutine check_model_assignment() character(len=LINELENGTH) :: errmsg class(BaseModelType), pointer :: mp integer(I4B) :: im - + do im = 1, basemodellist%Count() mp => GetBaseModelFromList(basemodellist, im) if (mp%idsoln == 0) then - write(errmsg, '(a,a)') & + write (errmsg, '(a,a)') & '****ERROR. Model was not assigned to a solution: ', mp%name call store_error(errmsg) - endif - enddo + end if + end do if (count_errors() > 0) then call store_error_unit(inunit) - endif + end if end subroutine check_model_assignment !> @brief Assign exchanges to solutions - !! - !! This assigns NumericalExchanges to NumericalSolutions, + !! + !! This assigns NumericalExchanges to NumericalSolutions, !! based on the link between the models in the solution and - !! those exchanges. The BaseExchange%connects_model() function + !! those exchanges. The BaseExchange%connects_model() function !! should be overridden to indicate if such a link exists. !< subroutine assign_exchanges() ! -- local - class(BaseSolutionType), pointer :: sp + class(BaseSolutionType), pointer :: sp class(BaseExchangeType), pointer :: ep - class(BaseModelType), pointer :: mp + class(BaseModelType), pointer :: mp type(ListType), pointer :: models_in_solution integer(I4B) :: is, ie, im do is = 1, basesolutionlist%Count() sp => GetBaseSolutionFromList(basesolutionlist, is) - ! + ! ! -- now loop over exchanges do ie = 1, baseexchangelist%Count() ep => GetBaseExchangeFromList(baseexchangelist, ie) @@ -580,14 +588,14 @@ subroutine assign_exchanges() do im = 1, models_in_solution%Count() mp => GetBaseModelFromList(models_in_solution, im) if (ep%connects_model(mp)) then - ! + ! ! -- add to solution (and only once) call sp%add_exchange(ep) exit end if end do end do - enddo + end do end subroutine assign_exchanges !> @brief Add the model to the list of modelnames, check that the model name is valid @@ -601,35 +609,35 @@ subroutine add_model(im, mtype, mname) integer :: ilen integer :: i character(len=LINELENGTH) :: errmsg - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ im = im + 1 call expandarray(modelname) call parser%GetStringCaps(mname) ilen = len_trim(mname) if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'ERROR. INVALID MODEL NAME: ', trim(mname) + write (errmsg, '(4x,a,a)') & + 'ERROR. INVALID MODEL NAME: ', trim(mname) call store_error(errmsg) - write(errmsg, '(4x,a,i0,a,i0)') & - 'NAME LENGTH OF ', ilen, ' EXCEEDS MAXIMUM LENGTH OF ', & - LENMODELNAME + write (errmsg, '(4x,a,i0,a,i0)') & + 'NAME LENGTH OF ', ilen, ' EXCEEDS MAXIMUM LENGTH OF ', & + LENMODELNAME call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if do i = 1, ilen if (mname(i:i) == ' ') then - write(errmsg, '(4x,a,a)') & - 'ERROR. INVALID MODEL NAME: ', trim(mname) + write (errmsg, '(4x,a,a)') & + 'ERROR. INVALID MODEL NAME: ', trim(mname) call store_error(errmsg) - write(errmsg, '(4x,a)') & - 'MODEL NAME CANNOT HAVE SPACES WITHIN IT.' + write (errmsg, '(4x,a)') & + 'MODEL NAME CANNOT HAVE SPACES WITHIN IT.' call store_error(errmsg) call parser%StoreErrorUnit() - endif - enddo + end if + end do modelname(im) = mname - write(iout, '(4x,a,i0)') mtype // ' model ' // trim(mname) // & - ' will be created as model ', im + write (iout, '(4x,a,i0)') mtype//' model '//trim(mname)// & + ' will be created as model ', im ! ! -- return return diff --git a/src/mf6.f90 b/src/mf6.f90 index 2b705c96ed5..94a2818ac87 100644 --- a/src/mf6.f90 +++ b/src/mf6.f90 @@ -9,6 +9,5 @@ program mf6 ! ! -- run call Mf6Run() - + end program - \ No newline at end of file diff --git a/src/mf6core.f90 b/src/mf6core.f90 index 5343beda4f1..988c3b651bd 100644 --- a/src/mf6core.f90 +++ b/src/mf6core.f90 @@ -5,344 +5,344 @@ !! of MODFLOW 6. !! !< -module Mf6CoreModule - use KindModule, only: I4B, LGP - use ListsModule, only: basesolutionlist, solutiongrouplist, & - basemodellist, baseexchangelist, & - baseconnectionlist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use SpatialModelConnectionModule, only: SpatialModelConnectionType, & +module Mf6CoreModule + use KindModule, only: I4B, LGP + use ListsModule, only: basesolutionlist, solutiongrouplist, & + basemodellist, baseexchangelist, & + baseconnectionlist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use SpatialModelConnectionModule, only: SpatialModelConnectionType, & GetSpatialModelConnectionFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - implicit none + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList + implicit none - contains - - !> @brief Main controller +contains + + !> @brief Main controller !! !! This subroutine is the main controller for MODFLOW 6. !! - !< - subroutine Mf6Run - ! -- modules - use CommandArguments, only: GetCommandLineArguments - use TdisModule, only: totim, totalsimtime - use KindModule, only: DP - ! -- local - logical(LGP) :: hasConverged - ! - ! -- parse any command line arguments - call GetCommandLineArguments() - ! - ! initialize simulation - call Mf6Initialize() - ! - ! -- time loop - tsloop: do while (totim < totalsimtime) - - ! perform a time step - hasConverged = Mf6Update() - - ! if not converged, break - if(.not. hasConverged) exit tsloop - - enddo tsloop - ! - ! -- finalize simulation - call Mf6Finalize() - - end subroutine Mf6Run - - !> @brief Initialize a simulation + !< + subroutine Mf6Run + ! -- modules + use CommandArguments, only: GetCommandLineArguments + use TdisModule, only: totim, totalsimtime + use KindModule, only: DP + ! -- local + logical(LGP) :: hasConverged + ! + ! -- parse any command line arguments + call GetCommandLineArguments() + ! + ! initialize simulation + call Mf6Initialize() + ! + ! -- time loop + do while (totim < totalsimtime) + + ! perform a time step + hasConverged = Mf6Update() + + ! if not converged, break + if (.not. hasConverged) exit + + end do + ! + ! -- finalize simulation + call Mf6Finalize() + + end subroutine Mf6Run + + !> @brief Initialize a simulation !! !! This subroutine initializes a MODFLOW 6 simulation. The subroutine: !! - creates the simulation !! - defines !! - allocates and reads static data !! - !< - subroutine Mf6Initialize() - ! -- modules - use SimulationCreateModule, only: simulation_cr - ! - ! -- print banner and info to screen - call printInfo() - - ! -- create - call simulation_cr() - - ! -- define - call simulation_df() - - ! -- allocate and read - call simulation_ar() - - end subroutine Mf6Initialize - - !> @brief Run a time step + !< + subroutine Mf6Initialize() + ! -- modules + use SimulationCreateModule, only: simulation_cr + ! + ! -- print banner and info to screen + call printInfo() + + ! -- create + call simulation_cr() + + ! -- define + call simulation_df() + + ! -- allocate and read + call simulation_ar() + + end subroutine Mf6Initialize + + !> @brief Run a time step !! !! This function runs a single time step to completion. !! !! @return hasConverged boolean indicating if convergence was achieved for the time step !! - !< - function Mf6Update() result(hasConverged) - ! -- return variable - logical(LGP) :: hasConverged - ! - ! -- prepare timestep - call Mf6PrepareTimestep() - ! - ! -- do timestep - call Mf6DoTimestep() - ! - ! -- after timestep - hasConverged = Mf6FinalizeTimestep() - ! - end function Mf6Update - - !> @brief Finalize the simulation + !< + function Mf6Update() result(hasConverged) + ! -- return variable + logical(LGP) :: hasConverged + ! + ! -- prepare timestep + call Mf6PrepareTimestep() + ! + ! -- do timestep + call Mf6DoTimestep() + ! + ! -- after timestep + hasConverged = Mf6FinalizeTimestep() + ! + end function Mf6Update + + !> @brief Finalize the simulation !! !! This subroutine finalizes a simulation. Steps include: !! - final processing !! - deallocate memory !! - !< - subroutine Mf6Finalize() - ! -- modules - use, intrinsic :: iso_fortran_env, only: output_unit - use ListsModule, only: lists_da - use MemoryManagerModule, only: mem_write_usage, mem_da - use TimerModule, only: elapsed_time - use SimVariablesModule, only: iout - use SimulationCreateModule, only: simulation_da - use TdisModule, only: tdis_da - use SimModule, only: final_message - ! -- local variables - integer(I4B) :: im - integer(I4B) :: ic - integer(I4B) :: is - integer(I4B) :: isg - class(SolutionGroupType), pointer :: sgp => null() - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - ! - ! -- FINAL PROCESSING (FP) - ! -- Final processing for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_fp() - enddo - ! - ! -- Final processing for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_fp() - enddo - ! - ! -- Final processing for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_fp() - enddo - ! - ! -- DEALLOCATE (DA) - ! -- Deallocate tdis - call tdis_da() - ! - ! -- Deallocate for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_da() - deallocate(mp) - enddo - ! - ! -- Deallocate for each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_da() - deallocate(ep) - enddo - ! - ! -- Deallocate for each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_da() - deallocate(mc) - enddo - ! - ! -- Deallocate for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_da() - deallocate(sp) - enddo - ! - ! -- Deallocate solution group and simulation variables - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_da() - deallocate(sgp) - enddo - call simulation_da() - call lists_da() - ! - ! -- Write memory usage, elapsed time and terminate - call mem_write_usage(iout) - call mem_da() - call elapsed_time(iout, 1) - call final_message() - ! - end subroutine Mf6Finalize - - !> @brief Print info to screen + !< + subroutine Mf6Finalize() + ! -- modules + use, intrinsic :: iso_fortran_env, only: output_unit + use ListsModule, only: lists_da + use MemoryManagerModule, only: mem_write_usage, mem_da + use TimerModule, only: elapsed_time + use SimVariablesModule, only: iout + use SimulationCreateModule, only: simulation_da + use TdisModule, only: tdis_da + use SimModule, only: final_message + ! -- local variables + integer(I4B) :: im + integer(I4B) :: ic + integer(I4B) :: is + integer(I4B) :: isg + class(SolutionGroupType), pointer :: sgp => null() + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + ! + ! -- FINAL PROCESSING (FP) + ! -- Final processing for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_fp() + end do + ! + ! -- Final processing for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_fp() + end do + ! + ! -- Final processing for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_fp() + end do + ! + ! -- DEALLOCATE (DA) + ! -- Deallocate tdis + call tdis_da() + ! + ! -- Deallocate for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_da() + deallocate (mp) + end do + ! + ! -- Deallocate for each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_da() + deallocate (ep) + end do + ! + ! -- Deallocate for each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_da() + deallocate (mc) + end do + ! + ! -- Deallocate for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_da() + deallocate (sp) + end do + ! + ! -- Deallocate solution group and simulation variables + do isg = 1, solutiongrouplist%Count() + sgp => GetSolutionGroupFromList(solutiongrouplist, isg) + call sgp%sgp_da() + deallocate (sgp) + end do + call simulation_da() + call lists_da() + ! + ! -- Write memory usage, elapsed time and terminate + call mem_write_usage(iout) + call mem_da() + call elapsed_time(iout, 1) + call final_message() + ! + end subroutine Mf6Finalize + + !> @brief Print info to screen !! !! This subroutine prints the banner to the screen. !! - !< - subroutine printInfo() - use SimModule, only: initial_message - use TimerModule, only: start_time - ! - ! -- print initial message - call initial_message() - ! - ! -- get start time - call start_time() - return - end subroutine printInfo - - !> @brief Define the simulation + !< + subroutine printInfo() + use SimModule, only: initial_message + use TimerModule, only: start_time + ! + ! -- print initial message + call initial_message() + ! + ! -- get start time + call start_time() + return + end subroutine printInfo + + !> @brief Define the simulation !! !! This subroutine defined the simulation. Steps include: !! - define each model !! - define each solution !! - !< - subroutine simulation_df() - ! -- local variables - integer(I4B) :: im - integer(I4B) :: ic - integer(I4B) :: is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - - ! -- Define each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_df() - enddo - ! - ! -- Define each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_df() - enddo - ! - ! -- when needed, this is were the interface models are - ! created and added to the numerical solutions - call connections_cr() - ! - ! -- Define each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_df() - enddo - ! - ! -- Define each solution - do is = 1, basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_df() - enddo - - end subroutine simulation_df - - !> @brief Simulation allocate and read + !< + subroutine simulation_df() + ! -- local variables + integer(I4B) :: im + integer(I4B) :: ic + integer(I4B) :: is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + + ! -- Define each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_df() + end do + ! + ! -- Define each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_df() + end do + ! + ! -- when needed, this is were the interface models are + ! created and added to the numerical solutions + call connections_cr() + ! + ! -- Define each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_df() + end do + ! + ! -- Define each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_df() + end do + + end subroutine simulation_df + + !> @brief Simulation allocate and read !! - !! This subroutine allocates and read static data for the simulation. + !! This subroutine allocates and read static data for the simulation. !! Steps include: !! - allocate and read for each model !! - allocate and read for each exchange !! - allocate and read for each solution !! - !< - subroutine simulation_ar() - ! -- local variables - integer(I4B) :: im - integer(I4B) :: ic - integer(I4B) :: is - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - - ! -- Allocate and read each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_ar() - enddo - ! - ! -- Allocate and read each exchange - do ic = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ic) - call ep%exg_ar() - enddo - ! - ! -- Allocate and read all model connections - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_ar() - enddo - ! - ! -- Allocate and read each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_ar() - enddo - ! - end subroutine simulation_ar + !< + subroutine simulation_ar() + ! -- local variables + integer(I4B) :: im + integer(I4B) :: ic + integer(I4B) :: is + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + + ! -- Allocate and read each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_ar() + end do + ! + ! -- Allocate and read each exchange + do ic = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ic) + call ep%exg_ar() + end do + ! + ! -- Allocate and read all model connections + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_ar() + end do + ! + ! -- Allocate and read each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_ar() + end do + ! + end subroutine simulation_ar - !> @brief Create the model connections from the exchanges + !> @brief Create the model connections from the exchanges !! !! This will upgrade the numerical exchanges in the solution, - !! whenever the configuration requires this, to Connection + !! whenever the configuration requires this, to Connection !! objects. Currently we anticipate: !! !! GWF-GWF => GwfGwfConnection !! GWT-GWT => GwtGwtConecction - !< - subroutine connections_cr() - use ConnectionBuilderModule - use SimVariablesModule, only: iout - integer(I4B) :: isol - type(ConnectionBuilderType) :: connectionBuilder - class(BaseSolutionType), pointer :: sol => null() - - write(iout,'(/a)') 'PROCESSING MODEL CONNECTIONS' - - if (baseexchangelist%Count() == 0) then - ! if this is not a coupled simulation in any way, - ! then we will not need model connections - return - end if - - do isol = 1, basesolutionlist%Count() - sol => GetBaseSolutionFromList(basesolutionlist, isol) - call connectionBuilder%processSolution(sol) - end do + !< + subroutine connections_cr() + use ConnectionBuilderModule + use SimVariablesModule, only: iout + integer(I4B) :: isol + type(ConnectionBuilderType) :: connectionBuilder + class(BaseSolutionType), pointer :: sol => null() + + write (iout, '(/a)') 'PROCESSING MODEL CONNECTIONS' + + if (baseexchangelist%Count() == 0) then + ! if this is not a coupled simulation in any way, + ! then we will not need model connections + return + end if + + do isol = 1, basesolutionlist%Count() + sol => GetBaseSolutionFromList(basesolutionlist, isol) + call connectionBuilder%processSolution(sol) + end do - write(iout,'(a)') 'END OF MODEL CONNECTIONS' - end subroutine connections_cr - - !> @brief Read and prepare time step + write (iout, '(a)') 'END OF MODEL CONNECTIONS' + end subroutine connections_cr + + !> @brief Read and prepare time step !! - !! This subroutine reads and prepares period data for the simulation. + !! This subroutine reads and prepares period data for the simulation. !! Steps include: !! - read and prepare for each model !! - read and prepare for each exchange @@ -352,179 +352,179 @@ end subroutine connections_cr !! - calculate maximum time step for each solution !! - set time discretization timestep using smallest maximum timestep !! - !< - subroutine Mf6PrepareTimestep() - ! -- modules - use KindModule, only: I4B - use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE - use TdisModule, only: tdis_set_counters, tdis_set_timestep, & - kstp, kper - use ListsModule, only: basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SimModule, only: converge_reset - use SimVariablesModule, only: isim_mode - ! -- local variables - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - class(BaseSolutionType), pointer :: sp => null() - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: fmt - integer(I4B) :: im - integer(I4B) :: ie - integer(I4B) :: ic - integer(I4B) :: is - ! - ! -- initialize fmt - fmt = "(/,a,/)" - ! - ! -- period update - call tdis_set_counters() - ! - ! -- set base line - write(line, '(a,i0,a,i0,a)') & - 'start timestep kper="', kper, '" kstp="', kstp, '" mode="' - ! - ! -- evaluate simulation mode - select case (isim_mode) - case (MVALIDATE) - line = trim(line) // 'validate"' - case(MNORMAL) - line = trim(line) // 'normal"' - end select - - ! -- Read and prepare each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_message(line, fmt=fmt) - call mp%model_rp() - enddo - ! - ! -- Read and prepare each exchange - do ie = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ie) - call ep%exg_rp() - enddo - ! - ! -- Read and prepare each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_rp() - enddo - ! - ! -- reset simulation convergence flag - call converge_reset() - ! - ! -- time update for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_calculate_delt() - enddo - ! - ! -- time update for each exchange - do ie = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ie) - call ep%exg_calculate_delt() - enddo - ! - ! -- time update for each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_calculate_delt() - enddo - ! - ! -- time update for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_calculate_delt() - enddo - ! - ! -- set time step - call tdis_set_timestep() - - end subroutine Mf6PrepareTimestep - - !> @brief Run time step + !< + subroutine Mf6PrepareTimestep() + ! -- modules + use KindModule, only: I4B + use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE + use TdisModule, only: tdis_set_counters, tdis_set_timestep, & + kstp, kper + use ListsModule, only: basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SimModule, only: converge_reset + use SimVariablesModule, only: isim_mode + ! -- local variables + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + class(BaseSolutionType), pointer :: sp => null() + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: fmt + integer(I4B) :: im + integer(I4B) :: ie + integer(I4B) :: ic + integer(I4B) :: is + ! + ! -- initialize fmt + fmt = "(/,a,/)" + ! + ! -- period update + call tdis_set_counters() + ! + ! -- set base line + write (line, '(a,i0,a,i0,a)') & + 'start timestep kper="', kper, '" kstp="', kstp, '" mode="' + ! + ! -- evaluate simulation mode + select case (isim_mode) + case (MVALIDATE) + line = trim(line)//'validate"' + case (MNORMAL) + line = trim(line)//'normal"' + end select + + ! -- Read and prepare each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_message(line, fmt=fmt) + call mp%model_rp() + end do + ! + ! -- Read and prepare each exchange + do ie = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ie) + call ep%exg_rp() + end do + ! + ! -- Read and prepare each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_rp() + end do + ! + ! -- reset simulation convergence flag + call converge_reset() + ! + ! -- time update for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_calculate_delt() + end do + ! + ! -- time update for each exchange + do ie = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ie) + call ep%exg_calculate_delt() + end do + ! + ! -- time update for each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_calculate_delt() + end do + ! + ! -- time update for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_calculate_delt() + end do + ! + ! -- set time step + call tdis_set_timestep() + + end subroutine Mf6PrepareTimestep + + !> @brief Run time step !! - !! This subroutine runs a single time step for the simulation. + !! This subroutine runs a single time step for the simulation. !! Steps include: !! - formulate the system of equations for each model and exchange !! - solve each solution !! - !< - subroutine Mf6DoTimestep() - ! -- modules - use KindModule, only: I4B - use ListsModule, only: solutiongrouplist - use SimVariablesModule, only: iFailedStepRetry - use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList - ! -- local variables - class(SolutionGroupType), pointer :: sgp => null() - integer(I4B) :: isg - logical :: finishedTrying - - ! -- By default, the solution groups will be solved once, and - ! may fail. But if adaptive stepping is active, then - ! the solution groups may be solved over and over with - ! progressively smaller time steps to see if convergence - ! can be obtained. - iFailedStepRetry = 0 - retryloop: do - - do isg = 1, solutiongrouplist%Count() - sgp => GetSolutionGroupFromList(solutiongrouplist, isg) - call sgp%sgp_ca() - enddo - - call sim_step_retry(finishedTrying) - if (finishedTrying) exit retryloop - iFailedStepRetry = iFailedStepRetry + 1 - - end do retryloop - - end subroutine Mf6DoTimestep - - !> @brief Rerun time step + !< + subroutine Mf6DoTimestep() + ! -- modules + use KindModule, only: I4B + use ListsModule, only: solutiongrouplist + use SimVariablesModule, only: iFailedStepRetry + use SolutionGroupModule, only: SolutionGroupType, GetSolutionGroupFromList + ! -- local variables + class(SolutionGroupType), pointer :: sgp => null() + integer(I4B) :: isg + logical :: finishedTrying + + ! -- By default, the solution groups will be solved once, and + ! may fail. But if adaptive stepping is active, then + ! the solution groups may be solved over and over with + ! progressively smaller time steps to see if convergence + ! can be obtained. + iFailedStepRetry = 0 + retryloop: do + + do isg = 1, solutiongrouplist%Count() + sgp => GetSolutionGroupFromList(solutiongrouplist, isg) + call sgp%sgp_ca() + end do + + call sim_step_retry(finishedTrying) + if (finishedTrying) exit retryloop + iFailedStepRetry = iFailedStepRetry + 1 + + end do retryloop + + end subroutine Mf6DoTimestep + + !> @brief Rerun time step !! !! This subroutine reruns a single time step for the simulation when - !! the adaptive time step option is used. + !! the adaptive time step option is used. !! - !< - subroutine sim_step_retry(finishedTrying) - ! -- modules - use KindModule, only: DP - use SimVariablesModule, only: lastStepFailed - use SimModule, only: converge_reset - use TdisModule, only: kstp, kper, delt, tdis_delt_reset - use AdaptiveTimeStepModule, only: ats_reset_delt - ! -- dummy variables - logical, intent(out) :: finishedTrying !< boolean that indicates if no - ! additional reruns of the time step are required - ! - ! -- Check with ats to reset delt and keep trying - finishedTrying = .true. - call ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) - ! - if (.not. finishedTrying) then - ! - ! -- Reset delt, which requires updating pertim, totim - ! and end of period and simulation indicators - call tdis_delt_reset(delt) - ! - ! -- Reset state of the simulation convergence flag - call converge_reset() - - end if - ! - ! -- return - return - end subroutine sim_step_retry - - !> @brief Finalize time step + !< + subroutine sim_step_retry(finishedTrying) + ! -- modules + use KindModule, only: DP + use SimVariablesModule, only: lastStepFailed + use SimModule, only: converge_reset + use TdisModule, only: kstp, kper, delt, tdis_delt_reset + use AdaptiveTimeStepModule, only: ats_reset_delt + ! -- dummy variables + logical, intent(out) :: finishedTrying !< boolean that indicates if no + ! additional reruns of the time step are required + ! + ! -- Check with ats to reset delt and keep trying + finishedTrying = .true. + call ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) + ! + if (.not. finishedTrying) then + ! + ! -- Reset delt, which requires updating pertim, totim + ! and end of period and simulation indicators + call tdis_delt_reset(delt) + ! + ! -- Reset state of the simulation convergence flag + call converge_reset() + + end if + ! + ! -- return + return + end subroutine sim_step_retry + + !> @brief Finalize time step !! - !! This function finalizes a single time step for the simulation + !! This function finalizes a single time step for the simulation !! and writes output for the time step. Steps include: !! - write output for each model !! - write output for each exchange @@ -534,78 +534,78 @@ end subroutine sim_step_retry !! !! @return hasConverged boolean indicating if convergence was achieved for the time step !! - !< - function Mf6FinalizeTimestep() result(hasConverged) - ! -- modules - use KindModule, only: I4B - use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE - use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList - use SimModule, only: converge_check - use SimVariablesModule, only: isim_mode - ! -- return variable - logical(LGP) :: hasConverged - ! -- local variables - class(BaseSolutionType), pointer :: sp => null() - class(BaseModelType), pointer :: mp => null() - class(BaseExchangeType), pointer :: ep => null() - class(SpatialModelConnectionType), pointer :: mc => null() - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: fmt - integer(I4B) :: im - integer(I4B) :: ix - integer(I4B) :: ic - integer(I4B) :: is + !< + function Mf6FinalizeTimestep() result(hasConverged) + ! -- modules + use KindModule, only: I4B + use ConstantsModule, only: LINELENGTH, MNORMAL, MVALIDATE + use ListsModule, only: basesolutionlist, basemodellist, baseexchangelist + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList + use BaseSolutionModule, only: BaseSolutionType, GetBaseSolutionFromList + use SimModule, only: converge_check + use SimVariablesModule, only: isim_mode + ! -- return variable + logical(LGP) :: hasConverged + ! -- local variables + class(BaseSolutionType), pointer :: sp => null() + class(BaseModelType), pointer :: mp => null() + class(BaseExchangeType), pointer :: ep => null() + class(SpatialModelConnectionType), pointer :: mc => null() + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: fmt + integer(I4B) :: im + integer(I4B) :: ix + integer(I4B) :: ic + integer(I4B) :: is + ! + ! -- initialize format and line + fmt = "(/,a,/)" + line = 'end timestep' + ! + ! -- evaluate simulation mode + select case (isim_mode) + case (MVALIDATE) + ! + ! -- Write final message for timestep for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_message(line, fmt=fmt) + end do + case (MNORMAL) ! - ! -- initialize format and line - fmt = "(/,a,/)" - line = 'end timestep' + ! -- Write output and final message for timestep for each model + do im = 1, basemodellist%Count() + mp => GetBaseModelFromList(basemodellist, im) + call mp%model_ot() + call mp%model_message(line, fmt=fmt) + end do ! - ! -- evaluate simulation mode - select case (isim_mode) - case(MVALIDATE) - ! - ! -- Write final message for timestep for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_message(line, fmt=fmt) - end do - case(MNORMAL) - ! - ! -- Write output and final message for timestep for each model - do im = 1, basemodellist%Count() - mp => GetBaseModelFromList(basemodellist, im) - call mp%model_ot() - call mp%model_message(line, fmt=fmt) - enddo - ! - ! -- Write output for each exchange - do ix = 1, baseexchangelist%Count() - ep => GetBaseExchangeFromList(baseexchangelist, ix) - call ep%exg_ot() - enddo - ! - ! -- Write output for each connection - do ic = 1, baseconnectionlist%Count() - mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) - call mc%exg_ot() - end do - ! - ! -- Write output for each solution - do is=1,basesolutionlist%Count() - sp => GetBaseSolutionFromList(basesolutionlist, is) - call sp%sln_ot() - enddo - end select + ! -- Write output for each exchange + do ix = 1, baseexchangelist%Count() + ep => GetBaseExchangeFromList(baseexchangelist, ix) + call ep%exg_ot() + end do ! - ! -- Check if we're done - call converge_check(hasConverged) + ! -- Write output for each connection + do ic = 1, baseconnectionlist%Count() + mc => GetSpatialModelConnectionFromList(baseconnectionlist, ic) + call mc%exg_ot() + end do ! - ! -- return - return - - end function Mf6FinalizeTimestep - + ! -- Write output for each solution + do is = 1, basesolutionlist%Count() + sp => GetBaseSolutionFromList(basesolutionlist, is) + call sp%sln_ot() + end do + end select + ! + ! -- Check if we're done + call converge_check(hasConverged) + ! + ! -- return + return + + end function Mf6FinalizeTimestep + end module Mf6CoreModule diff --git a/src/mf6lists.f90 b/src/mf6lists.f90 index 2d3ee1f2a9a..904caddbdc7 100644 --- a/src/mf6lists.f90 +++ b/src/mf6lists.f90 @@ -23,12 +23,12 @@ module ListsModule ! -- list of all exchanges in simulation type(ListType) :: baseexchangelist - + ! -- list of all connections in simulation type(ListType) :: baseconnectionlist - - contains - + +contains + subroutine lists_da() ! ****************************************************************************** ! Deallocate the lists @@ -43,7 +43,7 @@ subroutine lists_da() call solutiongrouplist%Clear() call baseexchangelist%Clear() call baseconnectionlist%Clear() - + return end subroutine lists_da From 59047797047b40624b8c0e1145dcb1e6741b6d67 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 16:30:09 -0700 Subject: [PATCH 008/212] Updating the contents of the src/Timing/ directory with the fprettify stuff. I didn't have any local changes in this directory. --- src/Timing/ats.f90 | 190 +++++++++++----------- src/Timing/tdis.f90 | 388 ++++++++++++++++++++++---------------------- 2 files changed, 288 insertions(+), 290 deletions(-) diff --git a/src/Timing/ats.f90 b/src/Timing/ats.f90 index db895122e4d..1fca4d34010 100644 --- a/src/Timing/ats.f90 +++ b/src/Timing/ats.f90 @@ -3,7 +3,7 @@ ! Ensure ATS not specified for steady state period ! Add courant time step constraint and other stability controls for GWT model module AdaptiveTimeStepModule - + use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: iout, errmsg, warnmsg use SimModule, only: store_error, count_errors, store_warning @@ -22,20 +22,20 @@ module AdaptiveTimeStepModule public :: ats_cr public :: ats_da - integer(I4B), pointer :: nper => null() !< set equal to nper - integer(I4B), pointer :: maxats => null() !< number of ats entries - real(DP), public, pointer :: dtstable => null() !< delt value required for stability - integer(I4B), dimension(:), pointer, contiguous :: kperats => null() !< array of stress period numbers to apply ats (size NPER) - integer(I4B), dimension(:), pointer, contiguous :: iperats => null() !< array of stress period numbers to apply ats (size MAXATS) - real(DP), dimension(:), pointer, contiguous :: dt0 => null() !< input array of initial time step sizes - real(DP), dimension(:), pointer, contiguous :: dtmin => null() !< input array of minimum time step sizes - real(DP), dimension(:), pointer, contiguous :: dtmax => null() !< input array of maximum time step sizes - real(DP), dimension(:), pointer, contiguous :: dtadj => null() !< input array of time step factors for shortening or increasing - real(DP), dimension(:), pointer, contiguous :: dtfailadj => null() !< input array of time step factors for shortening due to nonconvergence - type(BlockParserType) :: parser !< block parser for reading input file - - contains - + integer(I4B), pointer :: nper => null() !< set equal to nper + integer(I4B), pointer :: maxats => null() !< number of ats entries + real(DP), public, pointer :: dtstable => null() !< delt value required for stability + integer(I4B), dimension(:), pointer, contiguous :: kperats => null() !< array of stress period numbers to apply ats (size NPER) + integer(I4B), dimension(:), pointer, contiguous :: iperats => null() !< array of stress period numbers to apply ats (size MAXATS) + real(DP), dimension(:), pointer, contiguous :: dt0 => null() !< input array of initial time step sizes + real(DP), dimension(:), pointer, contiguous :: dtmin => null() !< input array of minimum time step sizes + real(DP), dimension(:), pointer, contiguous :: dtmax => null() !< input array of maximum time step sizes + real(DP), dimension(:), pointer, contiguous :: dtadj => null() !< input array of time step factors for shortening or increasing + real(DP), dimension(:), pointer, contiguous :: dtfailadj => null() !< input array of time step factors for shortening due to nonconvergence + type(BlockParserType) :: parser !< block parser for reading input file + +contains + !> @ brief Determine if period is adaptive !! !! Check settings and determine if kper is an adaptive @@ -53,7 +53,7 @@ function isAdaptivePeriod(kper) result(lv) end if return end function isAdaptivePeriod - + !> @ brief Create ATS object !! !! Create a new ATS object, and read and check input. @@ -66,7 +66,7 @@ subroutine ats_cr(inunit, nper_tdis) integer(I4B), intent(in) :: nper_tdis ! -- local ! -- formats - character(len=*),parameter :: fmtheader = & + character(len=*), parameter :: fmtheader = & "(1X,/1X,'ATS -- ADAPTIVE TIME STEP PACKAGE,', / & &' VERSION 1 : 03/18/2021 - INPUT READ FROM UNIT ',I0)" ! @@ -74,7 +74,7 @@ subroutine ats_cr(inunit, nper_tdis) call ats_allocate_scalars() ! ! -- Identify package - write(iout, fmtheader) inunit + write (iout, fmtheader) inunit ! ! -- Initialize block parser call parser%initialize(inunit, iout) @@ -110,7 +110,7 @@ end subroutine ats_cr !> @ brief Allocate scalars !! - !! Allocate and initialize scalars for the ATS package. + !! Allocate and initialize scalars for the ATS package. !! !< subroutine ats_allocate_scalars() @@ -130,10 +130,10 @@ subroutine ats_allocate_scalars() ! -- return return end subroutine ats_allocate_scalars - + !> @ brief Allocate arrays !! - !! Allocate and initialize arrays for the ATS package. + !! Allocate and initialize arrays for the ATS package. !! !< subroutine ats_allocate_arrays() @@ -171,7 +171,7 @@ end subroutine ats_allocate_arrays !> @ brief Deallocate variables !! - !! Deallocate all ATS variables. + !! Deallocate all ATS variables. !! !< subroutine ats_da() @@ -197,7 +197,7 @@ end subroutine ats_da !> @ brief Read options !! - !! Read options from ATS input file. + !! Read options from ATS input file. !! !< subroutine ats_read_options() @@ -210,33 +210,33 @@ subroutine ats_read_options() ! ! -- get options block call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING ATS OPTIONS' + write (iout, '(1x,a)') 'PROCESSING ATS OPTIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN ATS OPTION: ', & - trim(keyword) + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN ATS OPTION: ', & + trim(keyword) call store_error(errmsg) call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF ATS OPTIONS' + write (iout, '(1x,a)') 'END OF ATS OPTIONS' end if ! ! -- Return return end subroutine ats_read_options - + !> @ brief Read dimensions !! - !! Read dimensions from ATS input file. + !! Read dimensions from ATS input file. !! !< subroutine ats_read_dimensions() @@ -247,33 +247,33 @@ subroutine ats_read_dimensions() logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtmaxats = & - "(1X,I0,' ADAPTIVE TIME STEP RECORDS(S) WILL FOLLOW IN PERIODDATA')" + &"(1X,I0,' ADAPTIVE TIME STEP RECORDS(S) WILL FOLLOW IN PERIODDATA')" ! ! -- get DIMENSIONS block call parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING ATS DIMENSIONS' + write (iout, '(1x,a)') 'PROCESSING ATS DIMENSIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('MAXATS') - maxats = parser%GetInteger() - write(iout, fmtmaxats) maxats - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN ATS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('MAXATS') + maxats = parser%GetInteger() + write (iout, fmtmaxats) maxats + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN ATS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF ATS DIMENSIONS' + write (iout, '(1x,a)') 'END OF ATS DIMENSIONS' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -281,10 +281,10 @@ subroutine ats_read_dimensions() ! -- Return return end subroutine ats_read_dimensions - + !> @ brief Read timing !! - !! Read timing information from ATS input file. + !! Read timing information from ATS input file. !! !< subroutine ats_read_timing() @@ -298,11 +298,11 @@ subroutine ats_read_timing() ! ! -- get PERIODDATA block call parser%GetBlock('PERIODDATA', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'READING ATS PERIODDATA' + write (iout, '(1x,a)') 'READING ATS PERIODDATA' do n = 1, maxats call parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -314,18 +314,18 @@ subroutine ats_read_timing() dtmax(n) = parser%GetDouble() dtadj(n) = parser%GetDouble() dtfailadj(n) = parser%GetDouble() - enddo + end do ! ! -- Close the block call parser%terminateblock() ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call parser%StoreErrorUnit() - endif - write(iout,'(1x,a)') 'END READING ATS PERIODDATA' + end if + write (iout, '(1x,a)') 'END READING ATS PERIODDATA' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -333,10 +333,10 @@ subroutine ats_read_timing() ! -- Return return end subroutine ats_read_timing - + !> @ brief Process input !! - !! Process ATS input by filling the kperats array. + !! Process ATS input by filling the kperats array. !! !< subroutine ats_process_input() @@ -351,10 +351,10 @@ subroutine ats_process_input() end if end do end subroutine ats_process_input - + !> @ brief Write input table !! - !! Write a table showing the ATS input read from the perioddata block. + !! Write a table showing the ATS input read from the perioddata block. !! !< subroutine ats_input_table() @@ -392,35 +392,35 @@ subroutine ats_input_table() call inputtab%add_term(dtmax(n)) call inputtab%add_term(dtadj(n)) call inputtab%add_term(dtfailadj(n)) - end do + end do ! ! -- deallocate the table call inputtab%table_da() - deallocate(inputtab) - nullify(inputtab) + deallocate (inputtab) + nullify (inputtab) return end subroutine ats_input_table - + !> @ brief Check timing !! !! Perform a check on the input data to make sure values are within - !! required ranges. + !! required ranges. !! !< subroutine ats_check_timing() integer(I4B) :: n - write(iout,'(1x,a)') 'PROCESSING ATS INPUT' + write (iout, '(1x,a)') 'PROCESSING ATS INPUT' do n = 1, maxats ! ! -- check iperats if (iperats(n) < 1) then - write(errmsg, '(a, i0, a, i0)') & + write (errmsg, '(a, i0, a, i0)') & 'IPERATS MUST BE GREATER THAN ZERO. FOUND ', iperats(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) end if if (iperats(n) > nper) then - write(warnmsg, '(a, i0, a, i0)') & + write (warnmsg, '(a, i0, a, i0)') & 'IPERATS GREATER THAN NPER. FOUND ', iperats(n), & ' FOR ATS PERIODDATA RECORD ', n call store_warning(warnmsg) @@ -428,7 +428,7 @@ subroutine ats_check_timing() ! ! -- check dt0 if (dt0(n) < DZERO) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DT0 MUST BE >= ZERO. FOUND ', dt0(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -436,7 +436,7 @@ subroutine ats_check_timing() ! ! -- check dtmin if (dtmin(n) <= DZERO) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTMIN MUST BE > ZERO. FOUND ', dtmin(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -444,7 +444,7 @@ subroutine ats_check_timing() ! ! -- check dtmax if (dtmax(n) <= DZERO) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTMAX MUST BE > ZERO. FOUND ', dtmax(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -452,7 +452,7 @@ subroutine ats_check_timing() ! ! -- check dtmin <= dtmax if (dtmin(n) > dtmax(n)) then - write(errmsg, '(a, 2g15.7, a, i0)') & + write (errmsg, '(a, 2g15.7, a, i0)') & 'DTMIN MUST BE < DTMAX. FOUND ', dtmin(n), dtmax(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -460,7 +460,7 @@ subroutine ats_check_timing() ! ! -- check dtadj if (dtadj(n) .ne. DZERO .and. dtadj(n) < DONE) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTADJ MUST BE 0 or >= 1.0. FOUND ', dtadj(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) @@ -468,25 +468,25 @@ subroutine ats_check_timing() ! ! -- check dtfailadj if (dtfailadj(n) .ne. DZERO .and. dtfailadj(n) < DONE) then - write(errmsg, '(a, g15.7, a, i0)') & + write (errmsg, '(a, g15.7, a, i0)') & 'DTFAILADJ MUST BE 0 or >= 1.0. FOUND ', dtfailadj(n), & ' FOR ATS PERIODDATA RECORD ', n call store_error(errmsg) end if - + end do ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call parser%StoreErrorUnit() - endif - write(iout,'(1x,a)') 'DONE PROCESSING ATS INPUT' + end if + write (iout, '(1x,a)') 'DONE PROCESSING ATS INPUT' end subroutine ats_check_timing - + !> @ brief Write period message !! !! Write message to mfsim.lst file with information on ATS settings - !! for this period. + !! for this period. !! !< subroutine ats_period_message(kper) @@ -494,7 +494,7 @@ subroutine ats_period_message(kper) integer(I4B), intent(in) :: kper ! -- local integer(I4B) :: n - character(len=*),parameter :: fmtspts = & + character(len=*), parameter :: fmtspts = & "(28X,'ATS IS OVERRIDING TIME STEPPING FOR THIS PERIOD',/ & &28X,'INITIAL TIME STEP SIZE (DT0) = ',G15.7,/ & &28X,'MINIMUM TIME STEP SIZE (DTMIN) = ',G15.7,/ & @@ -503,10 +503,10 @@ subroutine ats_period_message(kper) &28X,'DIVIDER FOR FAILED TIME STEP (DTFAILADJ) = ',G15.7,/ & &)" n = kperats(kper) - write(iout, fmtspts) dt0(n), dtmin(n), dtmax(n), dtadj(n), dtfailadj(n) + write (iout, fmtspts) dt0(n), dtmin(n), dtmax(n), dtadj(n), dtfailadj(n) return end subroutine ats_period_message - + !> @ brief Allow and external caller to submit preferred time step !! !! Submit a preferred time step length. Alternatively, if idir is @@ -524,9 +524,9 @@ subroutine ats_submit_delt(kstp, kper, dt, sloc, idir) integer(I4B) :: n real(DP) :: tsfact real(DP) :: dt_temp - character(len=*), parameter :: fmtdtsubmit = & + character(len=*), parameter :: fmtdtsubmit = & &"(1x, 'ATS: ', A,' submitted a preferred time step size of ', G15.7)" - + if (isAdaptivePeriod(kper)) then n = kperats(kper) tsfact = dtadj(n) @@ -546,7 +546,7 @@ subroutine ats_submit_delt(kstp, kper, dt, sloc, idir) dt_temp = dt end if if (kstp > 1 .and. dt_temp > DZERO) then - write(iout, fmtdtsubmit) trim(adjustl(sloc)), dt_temp + write (iout, fmtdtsubmit) trim(adjustl(sloc)), dt_temp end if if (dt_temp > DZERO .and. dt_temp < dtstable) then ! -- Reset dtstable to a smaller value @@ -556,7 +556,7 @@ subroutine ats_submit_delt(kstp, kper, dt, sloc, idir) end if return end subroutine ats_submit_delt - + !> @ brief Set time step !! !! Set the time step length (delt) for this time step using the ATS @@ -575,8 +575,8 @@ subroutine ats_set_delt(kstp, kper, pertim, perlencurrent, delt) integer(I4B) :: n real(DP) :: tstart ! -- formats - character(len=*), parameter :: fmtdt = & - &"(1x, 'ATS: time step set to ', G15.7, ' for step ', i0, & + character(len=*), parameter :: fmtdt = & + "(1x, 'ATS: time step set to ', G15.7, ' for step ', i0, & &' and period ', i0)" ! ! -- initialize the record position (n) for this stress period @@ -588,7 +588,7 @@ subroutine ats_set_delt(kstp, kper, pertim, perlencurrent, delt) ! -- Calculate delt ! ! -- Setup new stress period if kstp is 1 - if(kstp == 1) then + if (kstp == 1) then ! ! -- Assign first value of delt for this stress period if (dt0(n) /= DZERO) then @@ -619,11 +619,11 @@ subroutine ats_set_delt(kstp, kper, pertim, perlencurrent, delt) end if ! ! -- Write time step size information - write(iout, fmtdt) delt, kstp, kper + write (iout, fmtdt) delt, kstp, kper ! return end subroutine ats_set_delt - + !> @ brief Reset time step because failure has occurred !! !! Reset the time step using dtfailadj because the time step @@ -643,7 +643,7 @@ subroutine ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) real(DP) :: delt_temp real(DP) :: tsfact ! -- formats - character(len=*),parameter :: fmttsi = & + character(len=*), parameter :: fmttsi = & "(1X, 'Failed solution for step ', i0, ' and period ', i0, & &' will be retried using time step of ', G15.7)" if (isAdaptivePeriod(kper)) then @@ -656,15 +656,15 @@ subroutine ats_reset_delt(kstp, kper, lastStepFailed, delt, finishedTrying) if (delt_temp >= dtmin(n)) then finishedTrying = .false. delt = delt_temp - write(iout, fmttsi) kstp, kper, delt + write (iout, fmttsi) kstp, kper, delt end if end if - + end if end if return end subroutine ats_reset_delt - + !> @ brief Set end of period indicator !! !! Determine if it is the end of the stress period and set the endofperiod @@ -679,12 +679,12 @@ subroutine ats_set_endofperiod(kper, pertim, perlencurrent, endofperiod) ! -- local integer(I4B) :: n ! - ! -- End of stress period and/or simulation? + ! -- End of stress period and/or simulation? n = kperats(kper) if (abs(pertim - perlencurrent) < dtmin(n)) then endofperiod = .true. end if return end subroutine ats_set_endofperiod - -end module AdaptiveTimeStepModule \ No newline at end of file + +end module AdaptiveTimeStepModule diff --git a/src/Timing/tdis.f90 b/src/Timing/tdis.f90 index ad09a2b99cb..01c631ac8fd 100644 --- a/src/Timing/tdis.f90 +++ b/src/Timing/tdis.f90 @@ -2,7 +2,7 @@ !convert this to a derived type? May not be necessary since only !one of them is needed. - module TdisModule +module TdisModule use KindModule, only: DP, I4B, LGP use SimVariablesModule, only: iout @@ -19,30 +19,30 @@ module TdisModule public :: tdis_ot public :: tdis_da ! - integer(I4B), public, pointer :: nper => null() !< number of stress period - integer(I4B), public, pointer :: itmuni => null() !< flag indicating time units - integer(I4B), public, pointer :: kper => null() !< current stress period number - integer(I4B), public, pointer :: kstp => null() !< current time step number - integer(I4B), public, pointer :: inats => null() !< flag indicating ats active for simulation - logical(LGP), public, pointer :: readnewdata => null() !< flag indicating time to read new data - logical(LGP), public, pointer :: endofperiod => null() !< flag indicating end of stress period - logical(LGP), public, pointer :: endofsimulation => null() !< flag indicating end of simulation - real(DP), public, pointer :: delt => null() !< length of the current time step - real(DP), public, pointer :: pertim => null() !< time relative to start of stress period - real(DP), public, pointer :: totim => null() !< time relative to start of simulation - real(DP), public, pointer :: totimc => null() !< simulation time at start of time step - real(DP), public, pointer :: deltsav => null() !< saved value for delt, used for subtiming - real(DP), public, pointer :: totimsav => null() !< saved value for totim, used for subtiming - real(DP), public, pointer :: pertimsav => null() !< saved value for pertim, used for subtiming - real(DP), public, pointer :: totalsimtime => null() !< time at end of simulation - real(DP), public, dimension(:), pointer, contiguous :: perlen => null() !< length of each stress period - integer(I4B), public, dimension(:), pointer, contiguous :: nstp => null() !< number of time steps in each stress period - real(DP), public, dimension(:), pointer, contiguous :: tsmult => null() !< time step multiplier for each stress period - character(len=LENDATETIME), pointer :: datetime0 => null() !< starting date and time for the simulation + integer(I4B), public, pointer :: nper => null() !< number of stress period + integer(I4B), public, pointer :: itmuni => null() !< flag indicating time units + integer(I4B), public, pointer :: kper => null() !< current stress period number + integer(I4B), public, pointer :: kstp => null() !< current time step number + integer(I4B), public, pointer :: inats => null() !< flag indicating ats active for simulation + logical(LGP), public, pointer :: readnewdata => null() !< flag indicating time to read new data + logical(LGP), public, pointer :: endofperiod => null() !< flag indicating end of stress period + logical(LGP), public, pointer :: endofsimulation => null() !< flag indicating end of simulation + real(DP), public, pointer :: delt => null() !< length of the current time step + real(DP), public, pointer :: pertim => null() !< time relative to start of stress period + real(DP), public, pointer :: totim => null() !< time relative to start of simulation + real(DP), public, pointer :: totimc => null() !< simulation time at start of time step + real(DP), public, pointer :: deltsav => null() !< saved value for delt, used for subtiming + real(DP), public, pointer :: totimsav => null() !< saved value for totim, used for subtiming + real(DP), public, pointer :: pertimsav => null() !< saved value for pertim, used for subtiming + real(DP), public, pointer :: totalsimtime => null() !< time at end of simulation + real(DP), public, dimension(:), pointer, contiguous :: perlen => null() !< length of each stress period + integer(I4B), public, dimension(:), pointer, contiguous :: nstp => null() !< number of time steps in each stress period + real(DP), public, dimension(:), pointer, contiguous :: tsmult => null() !< time step multiplier for each stress period + character(len=LENDATETIME), pointer :: datetime0 => null() !< starting date and time for the simulation ! type(BlockParserType), private :: parser - contains +contains subroutine tdis_cr(fname) ! ****************************************************************************** @@ -60,7 +60,7 @@ subroutine tdis_cr(fname) ! -- local integer(I4B) :: inunit ! -- formats - character(len=*),parameter :: fmtheader = & + character(len=*), parameter :: fmtheader = & "(1X,/1X,'TDIS -- TEMPORAL DISCRETIZATION PACKAGE,', / & &' VERSION 1 : 11/13/2014 - INPUT READ FROM UNIT ',I4)" ! ------------------------------------------------------------------------------ @@ -69,14 +69,14 @@ subroutine tdis_cr(fname) call tdis_allocate_scalars() ! ! -- Get a unit number for tdis and open the file if it is not opened - inquire(file=fname, number=inunit) - if(inunit < 0) then + inquire (file=fname, number=inunit) + if (inunit < 0) then inunit = getunit() call openfile(inunit, iout, fname, 'TDIS') - endif + end if ! ! -- Identify package - write(iout, fmtheader) inunit + write (iout, fmtheader) inunit ! ! -- Initialize block parser call parser%Initialize(inunit, iout) @@ -113,23 +113,23 @@ subroutine tdis_set_counters() use ConstantsModule, only: DONE, DZERO, MNORMAL, MVALIDATE, DNODATA use SimVariablesModule, only: isim_mode use GenericUtilitiesModule, only: sim_message - use AdaptiveTimeStepModule, only: isAdaptivePeriod, dtstable, & + use AdaptiveTimeStepModule, only: isAdaptivePeriod, dtstable, & ats_period_message ! -- local character(len=LINELENGTH) :: line character(len=4) :: cpref character(len=10) :: cend ! -- formats - character(len=*),parameter :: fmtspts = & - "(a, 'Solving: Stress period: ',i5,4x, 'Time step: ',i5,4x, a)" - character(len=*),parameter :: fmtvspts = & - "(' Validating: Stress period: ',i5,4x,'Time step: ',i5,4x)" - character(len=*),parameter :: fmtspi = & - "('1',/28X,'STRESS PERIOD NO. ',I0,', LENGTH =',G15.7,/ & - &28X,47('-'))" - character(len=*),parameter :: fmtspits = & - "(28X,'NUMBER OF TIME STEPS = ',I0,/ & - &28X,'MULTIPLIER FOR DELT =',F10.3)" + character(len=*), parameter :: fmtspts = & + &"(a, 'Solving: Stress period: ',i5,4x, 'Time step: ',i5,4x, a)" + character(len=*), parameter :: fmtvspts = & + &"(' Validating: Stress period: ',i5,4x,'Time step: ',i5,4x)" + character(len=*), parameter :: fmtspi = & + "('1',/28X,'STRESS PERIOD NO. ',I0,', LENGTH =',G15.7,/ & + &28X,47('-'))" + character(len=*), parameter :: fmtspits = & + "(28X,'NUMBER OF TIME STEPS = ',I0,/ & + &28X,'MULTIPLIER FOR DELT =',F10.3)" ! ------------------------------------------------------------------------------ ! ! -- Initialize variables for this step @@ -148,29 +148,29 @@ subroutine tdis_set_counters() end if ! ! -- Print stress period and time step to console - select case(isim_mode) - case(MVALIDATE) - write(line, fmtvspts) kper, kstp - case(MNORMAL) - write(line, fmtspts) cpref, kper, kstp, trim(cend) + select case (isim_mode) + case (MVALIDATE) + write (line, fmtvspts) kper, kstp + case (MNORMAL) + write (line, fmtspts) cpref, kper, kstp, trim(cend) end select call sim_message(line, level=VALL) call sim_message(line, iunit=iout, skipbefore=1, skipafter=1) ! ! -- Write message if first time step if (kstp == 1) then - write(iout, fmtspi) kper, perlen(kper) + write (iout, fmtspi) kper, perlen(kper) if (isAdaptivePeriod(kper)) then call ats_period_message(kper) else - write(iout, fmtspits) nstp(kper), tsmult(kper) + write (iout, fmtspits) nstp(kper), tsmult(kper) end if end if ! ! -- return return end subroutine tdis_set_counters - + subroutine tdis_set_timestep() ! ****************************************************************************** ! tdis_set_timestep -- Set time step length @@ -186,8 +186,8 @@ subroutine tdis_set_timestep() ! -- local logical(LGP) :: adaptivePeriod ! -- format - character(len=*), parameter :: fmttsi = & - "(28X,'INITIAL TIME STEP SIZE =',G15.7)" + character(len=*), parameter :: fmttsi = & + "(28X,'INITIAL TIME STEP SIZE =',G15.7)" ! ------------------------------------------------------------------------------ ! ! -- Initialize @@ -202,7 +202,7 @@ subroutine tdis_set_timestep() else call tdis_set_delt() if (kstp == 1) then - write(iout, fmttsi) delt + write (iout, fmttsi) delt end if end if ! @@ -227,7 +227,7 @@ subroutine tdis_set_timestep() end if ! ! -- Set end of simulation indicator - if (endofperiod .and. kper==nper) then + if (endofperiod .and. kper == nper) then endofsimulation = .true. totim = totalsimtime end if @@ -240,7 +240,7 @@ subroutine tdis_delt_reset(deltnew) ! ****************************************************************************** ! tdis_delt_reset -- reset delt and update timing variables and indicators. ! This routine is called when a timestep fails to converge, and so it is -! retried using a smaller time step (deltnew). +! retried using a smaller time step (deltnew). ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -273,7 +273,7 @@ subroutine tdis_delt_reset(deltnew) end if ! ! -- Set end of simulation indicator - if (endofperiod .and. kper==nper) then + if (endofperiod .and. kper == nper) then endofsimulation = .true. totim = totalsimtime end if @@ -294,11 +294,11 @@ subroutine tdis_set_delt() ! -- local ! ------------------------------------------------------------------------------ ! - if(kstp == 1) then + if (kstp == 1) then delt = perlen(kper) / float(nstp(kper)) - if(tsmult(kper) /= DONE) & - delt = perlen(kper) * (DONE-tsmult(kper)) / & - (DONE - tsmult(kper) ** nstp(kper)) + if (tsmult(kper) /= DONE) & + delt = perlen(kper) * (DONE - tsmult(kper)) / & + (DONE - tsmult(kper)**nstp(kper)) else delt = tsmult(kper) * delt end if @@ -317,7 +317,7 @@ end subroutine tdis_set_delt ! ! -- modules ! use ConstantsModule, only: DONE, DZERO ! ! -- formats -! character(len=*),parameter :: fmttsi = & +! character(len=*),parameter :: fmttsi = & ! "(28X,'INITIAL TIME STEP SIZE =',G15.7)" !! ------------------------------------------------------------------------------ ! ! @@ -326,8 +326,8 @@ end subroutine tdis_set_delt ! ! ! ! -- Calculate the first value of delt for this stress period ! delt = perlen(kper) / float(nstp(kper)) -! if(tsmult(kper) /= DONE) & -! delt = perlen(kper) * (DONE-tsmult(kper)) / & +! if(tsmult(kper) /= DONE) & +! delt = perlen(kper) * (DONE-tsmult(kper)) / & ! (DONE - tsmult(kper) ** nstp(kper)) ! ! ! ! -- Print length of first time step @@ -360,7 +360,7 @@ end subroutine tdis_set_delt ! end if ! if (endofperiod .and. kper==nper) then ! endofsimulation = .true. -! totim = totalsimtime +! totim = totalsimtime ! end if ! ! ! ! -- return @@ -374,73 +374,73 @@ subroutine tdis_ot(iout) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - ! -- dummy - integer(I4B), intent(in) :: iout - ! -- local - real(DP) :: zero,cnv,delsec,totsec,persec,sixty,hrday,dayyr, & - delmn,delhr,totmn,tothr,totdy,totyr,permn,perhr,perdy, & - peryr,deldy,delyr + ! -- dummy + integer(I4B), intent(in) :: iout + ! -- local + real(DP) :: zero, cnv, delsec, totsec, persec, sixty, hrday, dayyr, & + delmn, delhr, totmn, tothr, totdy, totyr, permn, perhr, & + perdy, peryr, deldy, delyr ! ------------------------------------------------------------------------------ - WRITE(IOUT,199) KSTP,KPER - 199 FORMAT(1X,///9X,'TIME SUMMARY AT END OF TIME STEP',I5, & - & ' IN STRESS PERIOD ',I4) + WRITE (IOUT, 199) KSTP, KPER +199 FORMAT(1X, ///9X, 'TIME SUMMARY AT END OF TIME STEP', I5, & + & ' IN STRESS PERIOD ', I4) !C !C1------USE TIME UNIT INDICATOR TO GET FACTOR TO CONVERT TO SECONDS. - ZERO=0.d0 - CNV=ZERO - IF(ITMUNI.EQ.1) CNV=1. - IF(ITMUNI.EQ.2) CNV=60. - IF(ITMUNI.EQ.3) CNV=3600. - IF(ITMUNI.EQ.4) CNV=86400. - IF(ITMUNI.EQ.5) CNV=31557600. + ZERO = 0.d0 + CNV = ZERO + IF (ITMUNI .EQ. 1) CNV = 1. + IF (ITMUNI .EQ. 2) CNV = 60. + IF (ITMUNI .EQ. 3) CNV = 3600. + IF (ITMUNI .EQ. 4) CNV = 86400. + IF (ITMUNI .EQ. 5) CNV = 31557600. !C !C2------IF FACTOR=0 THEN TIME UNITS ARE NON-STANDARD. - IF(CNV.NE.ZERO) GO TO 100 + IF (CNV .NE. ZERO) GO TO 100 !C !C2A-----PRINT TIMES IN NON-STANDARD TIME UNITS. - WRITE(IOUT,301) DELT,PERTIM,TOTIM - 301 FORMAT(21X,' TIME STEP LENGTH =',G15.6/ & - & 21X,' STRESS PERIOD TIME =',G15.6/ & - & 21X,'TOTAL SIMULATION TIME =',G15.6) + WRITE (IOUT, 301) DELT, PERTIM, TOTIM +301 FORMAT(21X, ' TIME STEP LENGTH =', G15.6 / & + & 21X, ' STRESS PERIOD TIME =', G15.6 / & + & 21X, 'TOTAL SIMULATION TIME =', G15.6) !C !C2B-----RETURN - RETURN + RETURN !C !C3------CALCULATE LENGTH OF TIME STEP & ELAPSED TIMES IN SECONDS. - 100 DELSEC=CNV*DELT - TOTSEC=CNV*TOTIM - PERSEC=CNV*PERTIM +100 DELSEC = CNV * DELT + TOTSEC = CNV * TOTIM + PERSEC = CNV * PERTIM !C !C4------CALCULATE TIMES IN MINUTES,HOURS,DAYS AND YEARS. - SIXTY=60. - HRDAY=24. - DAYYR=365.25 - DELMN=DELSEC/SIXTY - DELHR=DELMN/SIXTY - DELDY=DELHR/HRDAY - DELYR=DELDY/DAYYR - TOTMN=TOTSEC/SIXTY - TOTHR=TOTMN/SIXTY - TOTDY=TOTHR/HRDAY - TOTYR=TOTDY/DAYYR - PERMN=PERSEC/SIXTY - PERHR=PERMN/SIXTY - PERDY=PERHR/HRDAY - PERYR=PERDY/DAYYR + SIXTY = 60. + HRDAY = 24. + DAYYR = 365.25 + DELMN = DELSEC / SIXTY + DELHR = DELMN / SIXTY + DELDY = DELHR / HRDAY + DELYR = DELDY / DAYYR + TOTMN = TOTSEC / SIXTY + TOTHR = TOTMN / SIXTY + TOTDY = TOTHR / HRDAY + TOTYR = TOTDY / DAYYR + PERMN = PERSEC / SIXTY + PERHR = PERMN / SIXTY + PERDY = PERHR / HRDAY + PERYR = PERDY / DAYYR !C !C5------PRINT TIME STEP LENGTH AND ELAPSED TIMES IN ALL TIME UNITS. - WRITE(IOUT,200) - 200 FORMAT(19X,' SECONDS MINUTES HOURS',7X, & - & 'DAYS YEARS'/20X,59('-')) - write(IOUT,201) DELSEC,DELMN,DELHR,DELDY,DELYR - 201 FORMAT(1X,' TIME STEP LENGTH',1P,5G12.5) - WRITE(IOUT,202) PERSEC,PERMN,PERHR,PERDY,PERYR - 202 FORMAT(1X,'STRESS PERIOD TIME',1P,5G12.5) - WRITE(IOUT,203) TOTSEC,TOTMN,TOTHR,TOTDY,TOTYR - 203 FORMAT(1X,' TOTAL TIME',1P,5G12.5,/) + WRITE (IOUT, 200) +200 FORMAT(19X, ' SECONDS MINUTES HOURS', 7X, & + & 'DAYS YEARS'/20X, 59('-')) + write (IOUT, 201) DELSEC, DELMN, DELHR, DELDY, DELYR +201 FORMAT(1X, ' TIME STEP LENGTH', 1P, 5G12.5) + WRITE (IOUT, 202) PERSEC, PERMN, PERHR, PERDY, PERYR +202 FORMAT(1X, 'STRESS PERIOD TIME', 1P, 5G12.5) + WRITE (IOUT, 203) TOTSEC, TOTMN, TOTHR, TOTDY, TOTYR +203 FORMAT(1X, ' TOTAL TIME', 1P, 5G12.5,/) !C !C6------RETURN - RETURN + RETURN END subroutine tdis_ot subroutine tdis_da() @@ -475,7 +475,7 @@ subroutine tdis_da() call mem_deallocate(totalsimtime) ! ! -- strings - deallocate(datetime0) + deallocate (datetime0) ! ! -- Arrays call mem_deallocate(perlen) @@ -486,7 +486,6 @@ subroutine tdis_da() return end subroutine tdis_da - subroutine tdis_read_options() ! ****************************************************************************** ! tdis_read_options -- Read the options @@ -505,9 +504,9 @@ subroutine tdis_read_options() logical :: undspec ! -- formats character(len=*), parameter :: fmtitmuni = & - "(4x,'SIMULATION TIME UNIT IS ',A)" + &"(4x,'SIMULATION TIME UNIT IS ',A)" character(len=*), parameter :: fmtdatetime0 = & - "(4x,'SIMULATION STARTING DATE AND TIME IS ',A)" + &"(4x,'SIMULATION STARTING DATE AND TIME IS ',A)" !data ! ------------------------------------------------------------------------------ ! @@ -517,11 +516,11 @@ subroutine tdis_read_options() ! ! -- get options block call parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS OPTIONS' + write (iout, '(1x,a)') 'PROCESSING TDIS OPTIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -530,60 +529,60 @@ subroutine tdis_read_options() case ('TIME_UNITS') call parser%GetStringCaps(keyword) select case (keyword) - case('UNDEFINED') + case ('UNDEFINED') itmuni = 0 - write(iout, fmtitmuni) 'UNDEFINED' + write (iout, fmtitmuni) 'UNDEFINED' undspec = .true. - case('SECONDS') + case ('SECONDS') itmuni = 1 - write(iout, fmtitmuni) 'SECONDS' - case('MINUTES') + write (iout, fmtitmuni) 'SECONDS' + case ('MINUTES') itmuni = 2 - write(iout, fmtitmuni) 'MINUTES' - case('HOURS') + write (iout, fmtitmuni) 'MINUTES' + case ('HOURS') itmuni = 3 - write(iout, fmtitmuni) 'HOURS' - case('DAYS') + write (iout, fmtitmuni) 'HOURS' + case ('DAYS') itmuni = 4 - write(iout, fmtitmuni) 'DAYS' - case('YEARS') + write (iout, fmtitmuni) 'DAYS' + case ('YEARS') itmuni = 5 - write(iout, fmtitmuni) 'YEARS' + write (iout, fmtitmuni) 'YEARS' case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TIME_UNITS: ', & - trim(keyword) + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN TIME_UNITS: ', & + trim(keyword) call store_error(errmsg) call parser%StoreErrorUnit() end select case ('START_DATE_TIME') call parser%GetString(datetime0) - write(iout, fmtdatetime0) datetime0 + write (iout, fmtdatetime0) datetime0 case ('ATS6') call parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'ATS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'ATS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' call store_error(errmsg) - endif + end if call parser%GetString(fname) inats = GetUnit() call openfile(inats, iout, fname, 'ATS') case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS OPTION: ', & - trim(keyword) + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN TDIS OPTION: ', & + trim(keyword) call store_error(errmsg) call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF TDIS OPTIONS' + write (iout, '(1x,a)') 'END OF TDIS OPTIONS' end if ! ! -- Set to itmuni to undefined if not specified - if(itmuni == 0) then - if(.not. undspec) then - write(iout, fmtitmuni) 'UNDEFINED' - endif - endif + if (itmuni == 0) then + if (.not. undspec) then + write (iout, fmtitmuni) 'UNDEFINED' + end if + end if ! ! -- Return return @@ -620,7 +619,7 @@ subroutine tdis_allocate_scalars() call mem_allocate(totalsimtime, 'TOTALSIMTIME', 'TDIS') ! ! -- strings - allocate(datetime0) + allocate (datetime0) ! ! -- Initialize variables nper = 0 @@ -645,7 +644,6 @@ subroutine tdis_allocate_scalars() return end subroutine tdis_allocate_scalars - subroutine tdis_allocate_arrays() ! ****************************************************************************** ! tdis_allocate_arrays -- Allocate tdis arrays @@ -681,35 +679,35 @@ subroutine tdis_read_dimensions() logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtnper = & - "(1X,I4,' STRESS PERIOD(S) IN SIMULATION')" + "(1X,I4,' STRESS PERIOD(S) IN SIMULATION')" !data ! ------------------------------------------------------------------------------ ! ! -- get DIMENSIONS block call parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS DIMENSIONS' + write (iout, '(1x,a)') 'PROCESSING TDIS DIMENSIONS' do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('NPER') - nper = parser%GetInteger() - write(iout, fmtnper) nper - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN TDIS DIMENSION: ', & - trim(keyword) - call store_error(errmsg) - call parser%StoreErrorUnit() + case ('NPER') + nper = parser%GetInteger() + write (iout, fmtnper) nper + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN TDIS DIMENSION: ', & + trim(keyword) + call store_error(errmsg) + call parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)') 'END OF TDIS DIMENSIONS' + write (iout, '(1x,a)') 'END OF TDIS DIMENSIONS' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -734,41 +732,41 @@ subroutine tdis_read_timing() integer(I4B) :: n logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtheader = & - "(1X,//1X,'STRESS PERIOD LENGTH TIME STEPS', & + character(len=*), parameter :: fmtheader = & + "(1X,//1X,'STRESS PERIOD LENGTH TIME STEPS', & &' MULTIPLIER FOR DELT',/1X,76('-'))" - character(len=*), parameter :: fmtrow = & - "(1X,I8,1PG21.7,I7,0PF25.3)" + character(len=*), parameter :: fmtrow = & + "(1X,I8,1PG21.7,I7,0PF25.3)" ! ------------------------------------------------------------------------------ ! ! -- get PERIODDATA block call parser%GetBlock('PERIODDATA', isfound, ierr, & - supportOpenClose=.true.) + supportOpenClose=.true.) ! ! -- parse block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING TDIS PERIODDATA' - write(iout, fmtheader) + write (iout, '(1x,a)') 'PROCESSING TDIS PERIODDATA' + write (iout, fmtheader) do n = 1, nper call parser%GetNextLine(endOfBlock) perlen(n) = parser%GetDouble() nstp(n) = parser%GetInteger() tsmult(n) = parser%GetDouble() - write(iout, fmtrow) n, perlen(n), nstp(n), tsmult(n) + write (iout, fmtrow) n, perlen(n), nstp(n), tsmult(n) totalsimtime = totalsimtime + perlen(n) - enddo + end do ! ! -- Check timing information call check_tdis_timing(nper, perlen, nstp, tsmult) call parser%terminateblock() ! ! -- Check for errors - if(count_errors() > 0) then + if (count_errors() > 0) then call parser%StoreErrorUnit() - endif - write(iout,'(1x,a)') 'END OF TDIS PERIODDATA' + end if + write (iout, '(1x,a)') 'END OF TDIS PERIODDATA' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PERIODDATA BLOCK NOT FOUND.' call store_error(errmsg) call parser%StoreErrorUnit() end if @@ -776,10 +774,10 @@ subroutine tdis_read_timing() ! -- Return return end subroutine tdis_read_timing - + subroutine check_tdis_timing(nper, perlen, nstp, tsmult) ! ****************************************************************************** -! check_tdis_timing -- Check the tdis timing information. Return back to +! check_tdis_timing -- Check the tdis timing information. Return back to ! tdis_read_timing if an error condition is found and let the ustop ! routine be called there instead so the StoreErrorUnit routine can be ! called to assign the correct file name. @@ -800,13 +798,13 @@ subroutine check_tdis_timing(nper, perlen, nstp, tsmult) real(DP) :: tstart, tend, dt character(len=LINELENGTH) :: errmsg ! -- formats - character(len=*), parameter :: fmtpwarn = & - &"(1X,/1X,'PERLEN IS ZERO FOR STRESS PERIOD ', I0, & + character(len=*), parameter :: fmtpwarn = & + "(1X,/1X,'PERLEN IS ZERO FOR STRESS PERIOD ', I0, & &'. PERLEN MUST NOT BE ZERO FOR TRANSIENT PERIODS.')" - character(len=*), parameter :: fmtsperror = & + character(len=*), parameter :: fmtsperror = & &"(A,' FOR STRESS PERIOD ', I0)" - character(len=*), parameter :: fmtdterror = & - &"('TIME STEP LENGTH OF ', G0, ' IS TOO SMALL IN PERIOD ', I0, & + character(len=*), parameter :: fmtdterror = & + "('TIME STEP LENGTH OF ', G0, ' IS TOO SMALL IN PERIOD ', I0, & &' AND TIME STEP ', I0)" ! ------------------------------------------------------------------------------ ! @@ -817,28 +815,28 @@ subroutine check_tdis_timing(nper, perlen, nstp, tsmult) do kper = 1, nper ! ! -- Error if nstp less than or equal to zero - if(nstp(kper) <= 0) then - write(errmsg, fmtsperror) 'NUMBER OF TIME STEPS LESS THAN ONE ', kper + if (nstp(kper) <= 0) then + write (errmsg, fmtsperror) 'NUMBER OF TIME STEPS LESS THAN ONE ', kper call store_error(errmsg) return end if ! ! -- Warn if perlen is zero - if(perlen(kper) == DZERO) then - write(iout, fmtpwarn) kper - return + if (perlen(kper) == DZERO) then + write (iout, fmtpwarn) kper + return end if ! ! -- Error if tsmult is less than zero - if(tsmult(kper) <= DZERO) then - write(errmsg, fmtsperror) 'TSMULT MUST BE GREATER THAN 0.0 ', kper + if (tsmult(kper) <= DZERO) then + write (errmsg, fmtsperror) 'TSMULT MUST BE GREATER THAN 0.0 ', kper call store_error(errmsg) return end if ! ! -- Error if negative period length - if(perlen(kper) < DZERO) then - write(errmsg, fmtsperror) 'PERLEN CANNOT BE LESS THAN 0.0 ', kper + if (perlen(kper) < DZERO) then + write (errmsg, fmtsperror) 'PERLEN CANNOT BE LESS THAN 0.0 ', kper call store_error(errmsg) return end if @@ -847,26 +845,26 @@ subroutine check_tdis_timing(nper, perlen, nstp, tsmult) do kstp = 1, nstp(kper) if (kstp == 1) then dt = perlen(kper) / float(nstp(kper)) - if(tsmult(kper) /= DONE) & - dt = perlen(kper) * (DONE-tsmult(kper)) / & - (DONE - tsmult(kper) ** nstp(kper)) + if (tsmult(kper) /= DONE) & + dt = perlen(kper) * (DONE - tsmult(kper)) / & + (DONE - tsmult(kper)**nstp(kper)) else dt = dt * tsmult(kper) - endif + end if tend = tstart + dt ! ! -- Error condition if tstart == tend if (tstart == tend) then - write(errmsg, fmtdterror) dt, kper, kstp + write (errmsg, fmtdterror) dt, kper, kstp call store_error(errmsg) return - endif - enddo + end if + end do ! ! -- reset tstart = tend tstart = tend ! - enddo + end do ! -- Return return end subroutine check_tdis_timing From fd3e5e1158e5733d1b486d4c7b240265af149ab9 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 16:48:30 -0700 Subject: [PATCH 009/212] Updating the contents of the src/Model/Connection directory with the fprettify stuff. 2 files that I wrote need to have fprettify applied (GweGweConnection and GweInterfaceModel) and 1 file that I modified (GwtInterfaceModel.f90) --- src/Model/Connection/CellWithNbrs.f90 | 33 +- src/Model/Connection/ConnectionBuilder.f90 | 128 +-- src/Model/Connection/CsrUtils.f90 | 26 +- src/Model/Connection/GridConnection.f90 | 663 ++++++------ src/Model/Connection/GridSorting.f90 | 126 +-- src/Model/Connection/GweGweConnection.f90 | 629 ++++++++++++ src/Model/Connection/GweInterfaceModel.f90 | 239 +++++ src/Model/Connection/GwfGwfConnection.f90 | 316 +++--- src/Model/Connection/GwfInterfaceModel.f90 | 99 +- src/Model/Connection/GwtGwtConnection.f90 | 962 +++++++++--------- src/Model/Connection/GwtInterfaceModel.f90 | 391 ++++--- .../Connection/SpatialModelConnection.f90 | 325 +++--- 12 files changed, 2419 insertions(+), 1518 deletions(-) create mode 100644 src/Model/Connection/GweGweConnection.f90 create mode 100644 src/Model/Connection/GweInterfaceModel.f90 diff --git a/src/Model/Connection/CellWithNbrs.f90 b/src/Model/Connection/CellWithNbrs.f90 index 20186bfa4c9..932a9b538e5 100644 --- a/src/Model/Connection/CellWithNbrs.f90 +++ b/src/Model/Connection/CellWithNbrs.f90 @@ -7,23 +7,24 @@ module CellWithNbrsModule integer(I4B), parameter :: defaultCapacity = 6 !> Data structure to hold a global cell identifier, - !! using a pointer to the model and its local cell + !! using a pointer to the model and its local cell !< index type, public :: GlobalCellType - integer(I4B) :: index !< the index on the model grid + integer(I4B) :: index !< the index on the model grid class(NumericalModelType), pointer :: model => null() !< the model end type - + ! a global cell with neighbors type, public :: CellWithNbrsType type(GlobalCellType) :: cell integer(I4B) :: nrOfNbrs = 0 - type(CellWithNbrsType), dimension(:), pointer, contiguous :: neighbors => null() + type(CellWithNbrsType), dimension(:), pointer, & + contiguous :: neighbors => null() contains procedure :: addNbrCell end type - contains +contains subroutine addNbrCell(this, index, modelToAdd) class(CellWithNbrsType) :: this @@ -31,35 +32,35 @@ subroutine addNbrCell(this, index, modelToAdd) class(NumericalModelType), pointer :: modelToAdd ! local integer(I4B) :: nbrCnt, currentSize, i - type(CellWithNbrsType), dimension(:), pointer, contiguous :: newNeighbors - type(CellWithNbrsType), dimension(:), pointer, contiguous :: oldNeighbors + type(CellWithNbrsType), dimension(:), pointer, contiguous :: newNeighbors + type(CellWithNbrsType), dimension(:), pointer, contiguous :: oldNeighbors if (.not. associated(this%neighbors)) then - allocate(this%neighbors(defaultCapacity)) + allocate (this%neighbors(defaultCapacity)) this%nrOfNbrs = 0 end if - + nbrCnt = this%nrOfNbrs currentSize = size(this%neighbors) if (nbrCnt + 1 > currentSize) then ! inflate oldNeighbors => this%neighbors - allocate(newNeighbors(currentSize + defaultCapacity)) - do i=1, currentSize + allocate (newNeighbors(currentSize + defaultCapacity)) + do i = 1, currentSize newNeighbors(i) = oldNeighbors(i) end do this%neighbors => newNeighbors ! clean up - deallocate(oldNeighbors) - nullify(oldNeighbors) + deallocate (oldNeighbors) + nullify (oldNeighbors) end if - + this%neighbors(nbrCnt + 1)%cell%index = index this%neighbors(nbrCnt + 1)%cell%model => modelToAdd this%nrOfNbrs = nbrCnt + 1 - + end subroutine addNbrCell -end module \ No newline at end of file +end module diff --git a/src/Model/Connection/ConnectionBuilder.f90 b/src/Model/Connection/ConnectionBuilder.f90 index 66f5e2f08ba..df0988b51a8 100644 --- a/src/Model/Connection/ConnectionBuilder.f90 +++ b/src/Model/Connection/ConnectionBuilder.f90 @@ -6,38 +6,38 @@ module ConnectionBuilderModule use BaseSolutionModule, only: BaseSolutionType use NumericalSolutionModule, only: NumericalSolutionType use BaseExchangeModule, only: BaseExchangeType, GetBaseExchangeFromList - use DisConnExchangeModule, only: DisConnExchangeType, & - GetDisConnExchangeFromList + use DisConnExchangeModule, only: DisConnExchangeType, & + GetDisConnExchangeFromList use NumericalModelModule, only: NumericalModelType use SpatialModelConnectionModule, only: SpatialModelConnectionType, & - CastAsSpatialModelConnectionClass, & - GetSpatialModelConnectionFromList, & - AddSpatialModelConnectionToList - - implicit none + CastAsSpatialModelConnectionClass, & + GetSpatialModelConnectionFromList, & + AddSpatialModelConnectionToList + + implicit none private - + type, public :: ConnectionBuilderType contains procedure, pass(this) :: processSolution procedure, private, pass(this) :: processExchanges procedure, private, pass(this) :: setConnectionsToSolution procedure, private, pass(this) :: assignExchangesToConnections - end type ConnectionBuilderType - - contains + end type ConnectionBuilderType + +contains !> @brief Process the exchanges in the solution into model connections !! !! This routine processes all exchanges in a solution and, - !! when required, creates model connections of the proper + !! when required, creates model connections of the proper !! type (GWF-GWF, GWT-GWT, ...) for a subset. It removes this !! subset of exchanges from the solution and replaces them with the !! created connections. !< subroutine processSolution(this, solution) - class(ConnectionBuilderType) :: this !< the connection builder object - class(BaseSolutionType), pointer :: solution !< the solution for which the exchanges are processed + class(ConnectionBuilderType) :: this !< the connection builder object + class(BaseSolutionType), pointer :: solution !< the solution for which the exchanges are processed ! local class(NumericalSolutionType), pointer :: numSol type(ListType) :: newConnections @@ -54,10 +54,10 @@ subroutine processSolution(this, solution) call this%processExchanges(numSol%exchangelist, newConnections) if (newConnections%Count() == 0) then return - end if + end if - write(iout,'(1x,a,i0,a,a)') 'Created ', newConnections%Count(), & - ' model connections for solution ', trim(solution%name) + write (iout, '(1x,a,i0,a,a)') 'Created ', newConnections%Count(), & + ' model connections for solution ', trim(solution%name) ! set the global exchanges from this solution to ! the model connections @@ -73,16 +73,16 @@ end subroutine processSolution !> @brief Create connections from exchanges !! - !! If the configuration demands it, this will create connections, + !! If the configuration demands it, this will create connections, !! for the exchanges (one connection per exchange) add them to !! the global list, and return them as @param newConnections !< subroutine processExchanges(this, exchanges, newConnections) use ListsModule, only: baseconnectionlist, baseexchangelist use VersionModule, only: IDEVELOPMODE - class(ConnectionBuilderType) :: this !< the connection builder object - type(ListType), pointer, intent(in) :: exchanges !< the list of exchanges to process - type(ListType), intent(inout) :: newConnections !< the newly created connections + class(ConnectionBuilderType) :: this !< the connection builder object + type(ListType), pointer, intent(in) :: exchanges !< the list of exchanges to process + type(ListType), intent(inout) :: newConnections !< the newly created connections ! local class(DisConnExchangeType), pointer :: conEx class(BaseExchangeType), pointer :: baseEx @@ -96,10 +96,11 @@ subroutine processExchanges(this, exchanges, newConnections) ! Force use of the interface model dev_always_ifmod = .false. if (IDEVELOPMODE == 1) then - call get_environment_variable('DEV_ALWAYS_USE_IFMOD', value=envvar, status=status) + call get_environment_variable('DEV_ALWAYS_USE_IFMOD', & + value=envvar, status=status) if (status == 0 .and. envvar == '1') then dev_always_ifmod = .true. - write(*,'(a,/)') "### Experimental: forcing interface model ###" + write (*, '(a,/)') "### Experimental: forcing interface model ###" end if end if @@ -109,17 +110,17 @@ subroutine processExchanges(this, exchanges, newConnections) ! if it is not DisConnExchangeType, we can skip it continue end if - + ! for now, if we have XT3D on the interface, we use a connection, - ! (this will be more generic in the future) - if (conEx%use_interface_model() .or. conEx%dev_ifmod_on & + ! (this will be more generic in the future) + if (conEx%use_interface_model() .or. conEx%dev_ifmod_on & .or. dev_always_ifmod) then ! we should not get period connections here isPeriodic = associated(conEx%model1, conEx%model2) if (isPeriodic) then - write(*,*) 'Error (which should never happen): interface model '// & - 'does not support periodic boundary condition' + write (*, *) 'Error (which should never happen): interface model '// & + 'does not support periodic boundary condition' call ustop() end if @@ -128,7 +129,7 @@ subroutine processExchanges(this, exchanges, newConnections) call AddSpatialModelConnectionToList(baseconnectionlist, modelConnection) call AddSpatialModelConnectionToList(newConnections, modelConnection) - ! and for model 2, unless periodic + ! and for model 2, unless periodic modelConnection => createModelConnection(conEx%model2, conEx) call AddSpatialModelConnectionToList(baseconnectionlist, modelConnection) call AddSpatialModelConnectionToList(newConnections, modelConnection) @@ -142,7 +143,7 @@ subroutine processExchanges(this, exchanges, newConnections) exit end if end do - + end if end do @@ -158,45 +159,45 @@ function createModelConnection(model, exchange) result(connection) use GwfGwfConnectionModule, only: GwfGwfConnectionType use GwtGwtConnectionModule, only: GwtGwtConnectionType use GwfModule, only: GwfModelType - - class(NumericalModelType), pointer , intent(in) :: model !< the model for which the connection will be created + + class(NumericalModelType), pointer, intent(in) :: model !< the model for which the connection will be created class(DisConnExchangeType), pointer, intent(in) :: exchange !< the type of connection - class(SpatialModelConnectionType), pointer :: connection !< the created connection - + class(SpatialModelConnectionType), pointer :: connection !< the created connection + ! different concrete connection types: class(GwfGwfConnectionType), pointer :: flowConnection => null() class(GwtGwtConnectionType), pointer :: transportConnection => null() - + connection => null() - + ! select on type of connection to create - select case(exchange%typename) - case('GWF-GWF') - allocate(GwfGwfConnectionType :: flowConnection) - call flowConnection%construct(model, exchange) - connection => flowConnection - flowConnection => null() - case('GWT-GWT') - allocate(GwtGwtConnectionType :: transportConnection) - call transportConnection%construct(model, exchange) - connection => transportConnection - transportConnection => null() - case default - write(*,*) 'Error (which should never happen): undefined exchangetype found' - call ustop() - end select - + select case (exchange%typename) + case ('GWF-GWF') + allocate (GwfGwfConnectionType :: flowConnection) + call flowConnection%construct(model, exchange) + connection => flowConnection + flowConnection => null() + case ('GWT-GWT') + allocate (GwtGwtConnectionType :: transportConnection) + call transportConnection%construct(model, exchange) + connection => transportConnection + transportConnection => null() + case default + write (*, *) 'Error (which should never happen): '// & + 'undefined exchangetype found' + call ustop() + end select + end function createModelConnection - - + !> @brief Set connections to the solution !! - !! This adds the connections to the solution and removes + !! This adds the connections to the solution and removes !! those exchanges which are replaced by a connection !< subroutine setConnectionsToSolution(this, connections, solution) - class(ConnectionBuilderType) :: this !< the connection builder object - type(ListType), intent(inout) :: connections !< the connections created for the solution + class(ConnectionBuilderType) :: this !< the connection builder object + type(ListType), intent(inout) :: connections !< the connections created for the solution class(NumericalSolutionType), pointer, intent(in) :: solution !< the solution to which the connections are set ! local type(ListType) :: keepList @@ -211,7 +212,7 @@ subroutine setConnectionsToSolution(this, connections, solution) ! will this exchange be replaced by a connection? keepExchange = .true. do iconn = 1, connections%Count() - conn => GetSpatialModelConnectionFromList(connections,iconn) + conn => GetSpatialModelConnectionFromList(connections, iconn) exPtr2 => conn%primaryExchange if (associated(exPtr2, exPtr)) then ! if so, don't add it to the list @@ -252,9 +253,9 @@ end subroutine setConnectionsToSolution !! connected, through yet another exchange object. !< subroutine assignExchangesToConnections(this, exchanges, connections) - class(ConnectionBuilderType) :: this !< the connection builder object - type(ListType), pointer, intent(in) :: exchanges !< all exchanges in a solution - type(ListType), intent(inout) :: connections !< all connections that are created for this solution + class(ConnectionBuilderType) :: this !< the connection builder object + type(ListType), pointer, intent(in) :: exchanges !< all exchanges in a solution + type(ListType), intent(inout) :: connections !< all connections that are created for this solution ! local integer(I4B) :: iex, iconn class(DisConnExchangeType), pointer :: conEx @@ -284,8 +285,7 @@ subroutine assignExchangesToConnections(this, exchanges, connections) ! clean call keepList%Clear(destroy=.false.) - + end subroutine assignExchangesToConnections - - + end module ConnectionBuilderModule diff --git a/src/Model/Connection/CsrUtils.f90 b/src/Model/Connection/CsrUtils.f90 index 0bd0847cce5..70e72e00845 100644 --- a/src/Model/Connection/CsrUtils.f90 +++ b/src/Model/Connection/CsrUtils.f90 @@ -2,31 +2,31 @@ module CsrUtilsModule implicit none private - + public :: getCSRIndex - + contains - + !> @brief Return index for element i,j in CSR storage, !< returns -1 when not there function getCSRIndex(i, j, ia, ja) result(csrIndex) use KindModule, only: I4B - integer(I4B), intent(in) :: i !< the row index - integer(I4B), intent(in) :: j !< the column index - integer(I4B), dimension(:), intent(in) :: ia !< CSR ia array - integer(I4B), dimension(:), intent(in) :: ja !< CSR ja array - integer(I4B) :: csrIndex !< the CSR ndex of element i,j + integer(I4B), intent(in) :: i !< the row index + integer(I4B), intent(in) :: j !< the column index + integer(I4B), dimension(:), intent(in) :: ia !< CSR ia array + integer(I4B), dimension(:), intent(in) :: ja !< CSR ja array + integer(I4B) :: csrIndex !< the CSR ndex of element i,j ! local integer(I4B) :: idx - + csrIndex = -1 - do idx = ia(i), ia(i+1)-1 + do idx = ia(i), ia(i + 1) - 1 if (ja(idx) == j) then csrIndex = idx return end if end do - - end function -end module \ No newline at end of file + end function + +end module diff --git a/src/Model/Connection/GridConnection.f90 b/src/Model/Connection/GridConnection.f90 index 70a915783d0..3fbc6c0b92b 100644 --- a/src/Model/Connection/GridConnection.f90 +++ b/src/Model/Connection/GridConnection.f90 @@ -9,17 +9,17 @@ module GridConnectionModule use GwfDisuModule use DisConnExchangeModule use CellWithNbrsModule - use ConnectionsModule + use ConnectionsModule use SparseModule, only: sparsematrix implicit none private - + ! Initial nr of neighbors for sparse matrix allocation integer(I4B), parameter :: InitNrNeighbors = 7 - + !> This class is used to construct the connections object for !! the interface model's spatial discretization/grid. - !! + !! !! It works as follows: !! !! 1: construct basic instance, allocate data structures @@ -47,29 +47,27 @@ module GridConnectionModule integer(I4B) :: internalStencilDepth !< stencil size for the interior integer(I4B) :: exchangeStencilDepth !< stencil size at the interface - class(NumericalModelType), pointer :: model => null() !< the model for which this grid connection exists - - integer(I4B), pointer :: nrOfBoundaryCells => null() !< nr of boundary cells with connection to another model - type(CellWithNbrsType), dimension(:), pointer :: boundaryCells => null() !< cells on our side of the primary connections - type(CellWithNbrsType), dimension(:), pointer :: connectedCells => null() !< cells on the neighbors side of the primary connection - type(ListType) :: exchanges !< all relevant exchanges for this connection, up to - !! the required depth - - integer, dimension(:), pointer :: primConnections => null() !< table mapping the index in the boundaryCells/connectedCells - !< arrays into a connection index for e.g. access to flowja - - integer(I4B), pointer :: nrOfCells => null() !< the total number of cells in the interface - type(GlobalCellType), dimension(:), pointer :: idxToGlobal => null() !< a map from interface index to global coordinate + class(NumericalModelType), pointer :: model => null() !< the model for which this grid connection exists + + integer(I4B), pointer :: nrOfBoundaryCells => null() !< nr of boundary cells with connection to another model + type(CellWithNbrsType), dimension(:), pointer :: boundaryCells => null() !< cells on our side of the primary connections + type(CellWithNbrsType), dimension(:), pointer :: connectedCells => null() !< cells on the neighbors side of the primary connection + type(ListType) :: exchanges !< all relevant exchanges for this connection, up to the required depth + + integer, dimension(:), pointer :: primConnections => null() !< table mapping the index in the boundaryCells/connectedCells + + integer(I4B), pointer :: nrOfCells => null() !< the total number of cells in the interface + type(GlobalCellType), dimension(:), pointer :: idxToGlobal => null() !< a map from interface index to global coordinate integer(I4B), dimension(:), pointer, contiguous :: idxToGlobalIdx => null() !< a (flat) map from interface index to global index, !! stored in mem. mgr. so can be used for debugging - - integer(I4B), dimension(:), pointer :: regionalToInterfaceIdxMap => null() !< (sparse) mapping from regional index to interface ixd - type(ListType) :: regionalModels !< the models participating in the interface - integer(I4B), dimension(:), pointer :: regionalModelOffset => null() !< the new offset to compactify the range of indices - integer(I4B), pointer :: indexCount => null() !< counts the number of cells in the interface - type(ConnectionsType), pointer :: connections => null() !< sparse matrix with the connections - integer(I4B), dimension(:), pointer :: connectionMask => null() !< to mask out connections from the amat coefficient calculation - + + integer(I4B), dimension(:), pointer :: regionalToInterfaceIdxMap => null() !< (sparse) mapping from regional index to interface ixd + type(ListType) :: regionalModels !< the models participating in the interface + integer(I4B), dimension(:), pointer :: regionalModelOffset => null() !< the new offset to compactify the range of indices + integer(I4B), pointer :: indexCount => null() !< counts the number of cells in the interface + type(ConnectionsType), pointer :: connections => null() !< sparse matrix with the connections + integer(I4B), dimension(:), pointer :: connectionMask => null() !< to mask out connections from the amat coefficient calculation + contains ! public procedure, pass(this) :: construct @@ -79,13 +77,13 @@ module GridConnectionModule procedure, pass(this) :: findModelNeighbors procedure, pass(this) :: extendConnection generic :: getInterfaceIndex => getInterfaceIndexByCell, & - getInterfaceIndexByIndexModel + getInterfaceIndexByIndexModel procedure, pass(this) :: getDiscretization - + ! 'protected' procedure, pass(this) :: isPeriodic - + ! private routines procedure, private, pass(this) :: buildConnections procedure, private, pass(this) :: addNeighbors @@ -109,55 +107,56 @@ module GridConnectionModule procedure, private, pass(this) :: setMaskOnConnection procedure, private, pass(this) :: createLookupTable end type - - contains + +contains !> @brief Construct the GridConnection and allocate !! the data structures for the primary connections !< subroutine construct(this, model, nrOfPrimaries, connectionName) - class(GridConnectionType), intent(inout) :: this !> this instance - class(NumericalModelType), pointer, intent(in) :: model !> the model for which the interface is constructed - integer(I4B) :: nrOfPrimaries !> the number of primary connections between the two models - character(len=*) :: connectionName !> the name, for memory management mostly + class(GridConnectionType), intent(inout) :: this !> this instance + class(NumericalModelType), pointer, intent(in) :: model !> the model for which the interface is constructed + integer(I4B) :: nrOfPrimaries !> the number of primary connections between the two models + character(len=*) :: connectionName !> the name, for memory management mostly ! local this%model => model this%memoryPath = create_mem_path(connectionName, 'GC') call this%allocateScalars() - - allocate(this%boundaryCells(nrOfPrimaries)) - allocate(this%connectedCells(nrOfPrimaries)) - allocate(this%primConnections(nrOfPrimaries)) - allocate(this%idxToGlobal(2*nrOfPrimaries)) - + + allocate (this%boundaryCells(nrOfPrimaries)) + allocate (this%connectedCells(nrOfPrimaries)) + allocate (this%primConnections(nrOfPrimaries)) + allocate (this%idxToGlobal(2 * nrOfPrimaries)) + call this%addToRegionalModels(model) - + this%nrOfBoundaryCells = 0 this%internalStencilDepth = 1 this%exchangeStencilDepth = 1 end subroutine construct - + !> @brief Connect neighboring cells at the interface by !! storing them in the boundary cell and connected cell !! arrays !< subroutine connectCell(this, idx1, model1, idx2, model2) - class(GridConnectionType), intent(in) :: this !< this grid connection - integer(I4B) :: idx1 !< local index cell 1 - class(NumericalModelType), pointer :: model1 !< model of cell 1 - integer(I4B) :: idx2 !< local index cell 2 - class(NumericalModelType), pointer :: model2 !< model of cell 2 - - this%nrOfBoundaryCells = this%nrOfBoundaryCells + 1 + class(GridConnectionType), intent(in) :: this !< this grid connection + integer(I4B) :: idx1 !< local index cell 1 + class(NumericalModelType), pointer :: model1 !< model of cell 1 + integer(I4B) :: idx2 !< local index cell 2 + class(NumericalModelType), pointer :: model2 !< model of cell 2 + + this%nrOfBoundaryCells = this%nrOfBoundaryCells + 1 if (this%nrOfBoundaryCells > size(this%boundaryCells)) then - write(*,*) 'Error: nr of cell connections exceeds capacity in grid connection, terminating...' + write (*, *) 'Error: nr of cell connections exceeds '// & + 'capacity in grid connection, terminating...' call ustop() end if - + if (associated(model1, this%model)) then this%boundaryCells(this%nrOfBoundaryCells)%cell%index = idx1 this%boundaryCells(this%nrOfBoundaryCells)%cell%model => this%model @@ -171,39 +170,39 @@ subroutine connectCell(this, idx1, model1, idx2, model2) this%connectedCells(this%nrOfBoundaryCells)%cell%index = idx1 this%connectedCells(this%nrOfBoundaryCells)%cell%model => model1 else - write(*,*) 'Error: unable to connect cells outside the model' + write (*, *) 'Error: unable to connect cells outside the model' call ustop() end if - - end subroutine connectCell + end subroutine connectCell !> @brief Create the tree structure with all model nbrs, nbrs-of-nbrs, !< etc. for this model up to the specified depth subroutine findModelNeighbors(this, globalExchanges, depth) class(GridConnectionType), intent(inout) :: this !< this grid connection type(ListType), intent(inout) :: globalExchanges !< list with global exchanges - integer(I4B) :: depth !< the maximal number of exchanges between - !! any two models in the topology + integer(I4B) :: depth !< the maximal number of exchanges between + !! any two models in the topology call this%addModelNeighbors(this%model, globalExchanges, depth) end subroutine findModelNeighbors - !> @brief Add neighbors and nbrs-of-nbrs to the model tree - !< - recursive subroutine addModelNeighbors(this, model, globalExchanges, depth, mask) - class(GridConnectionType), intent(inout) :: this !< this grid connection + !< + recursive subroutine addModelNeighbors(this, model, & + globalExchanges, & + depth, mask) + class(GridConnectionType), intent(inout) :: this !< this grid connection class(NumericalModelType), pointer, intent(inout) :: model !< the model to add neighbors for - type(ListType), intent(inout) :: globalExchanges !< list with all exchanges - integer(I4B) :: depth !< the maximal number of exchanges between - class(NumericalModelType), pointer, optional :: mask !< don't add this one a neighbor + type(ListType), intent(inout) :: globalExchanges !< list with all exchanges + integer(I4B) :: depth !< the maximal number of exchanges between + class(NumericalModelType), pointer, optional :: mask !< don't add this one a neighbor ! local integer(I4B) :: i, n class(DisConnExchangeType), pointer :: connEx class(NumericalModelType), pointer :: neighborModel - class(NumericalModelType), pointer :: modelMask + class(NumericalModelType), pointer :: modelMask type(ListType) :: nbrModels class(*), pointer :: objPtr procedure(isEqualIface), pointer :: areEqualMethod @@ -214,7 +213,7 @@ recursive subroutine addModelNeighbors(this, model, globalExchanges, depth, mask modelMask => mask end if - ! first find all direct neighbors of the model and add them, + ! first find all direct neighbors of the model and add them, ! avoiding duplicates do i = 1, globalExchanges%Count() @@ -228,7 +227,7 @@ recursive subroutine addModelNeighbors(this, model, globalExchanges, depth, mask ! check if there is a neighbor, and it is not masked ! (to prevent back-and-forth connections) - if (associated(neighborModel) .and. .not. & + if (associated(neighborModel) .and. .not. & associated(neighborModel, modelMask)) then ! add to neighbors @@ -249,11 +248,11 @@ recursive subroutine addModelNeighbors(this, model, globalExchanges, depth, mask end if end do - + ! now recurse on the neighbors up to the specified depth depth = depth - 1 if (depth == 0) return - + do n = 1, nbrModels%Count() neighborModel => GetNumericalModelFromList(nbrModels, n) call this%addModelNeighbors(neighborModel, globalExchanges, depth, model) @@ -264,14 +263,13 @@ recursive subroutine addModelNeighbors(this, model, globalExchanges, depth, mask end subroutine addModelNeighbors - !> @brief Add a model to a list of all regional models !< subroutine addToRegionalModels(this, modelToAdd) - class(GridConnectionType), intent(inout) :: this !< this grid connection - class(NumericalModelType), pointer :: modelToAdd !< the model to add to the region + class(GridConnectionType), intent(inout) :: this !< this grid connection + class(NumericalModelType), pointer :: modelToAdd !< the model to add to the region ! local - class(*), pointer :: mPtr + class(*), pointer :: mPtr procedure(isEqualIface), pointer :: areEqualMethod mPtr => modelToAdd @@ -279,10 +277,10 @@ subroutine addToRegionalModels(this, modelToAdd) if (.not. this%regionalModels%ContainsObject(mPtr, areEqualMethod)) then call AddNumericalModelToList(this%regionalModels, modelToAdd) end if - + end subroutine addToRegionalModels - !> @brief Extend the connection topology to deal with + !> @brief Extend the connection topology to deal with !! higher levels of connectivity (neighbors-of-neighbors, etc.) !! !! The following steps are taken: @@ -291,35 +289,35 @@ end subroutine addToRegionalModels !! 3. Allocate a (sparse) mapping table for the region !! 4. Build connection object for the interface grid, and the mask !< - subroutine extendConnection(this) + subroutine extendConnection(this) class(GridConnectionType), intent(inout) :: this !< this grid connection - ! local + ! local integer(I4B) :: remoteDepth, localDepth integer(I4B) :: icell integer(I4B) :: imod, regionSize, offset class(NumericalModelType), pointer :: numModel - + ! we need (stencildepth-1) extra cells for the interior remoteDepth = this%exchangeStencilDepth - localDepth = 2*this%internalStencilDepth - 1 + localDepth = 2 * this%internalStencilDepth - 1 if (localDepth < remoteDepth) then localDepth = remoteDepth end if - - ! first add the neighbors for the interior + + ! first add the neighbors for the interior ! (possibly extending into other models) do icell = 1, this%nrOfBoundaryCells - call this%addNeighbors(this%boundaryCells(icell), localDepth, & + call this%addNeighbors(this%boundaryCells(icell), localDepth, & this%connectedCells(icell)%cell, .true.) end do ! and for the exterior do icell = 1, this%nrOfBoundaryCells - call this%addNeighbors(this%connectedCells(icell), remoteDepth, & + call this%addNeighbors(this%connectedCells(icell), remoteDepth, & this%boundaryCells(icell)%cell, .false.) end do - + ! set up mapping for the region (models participating in interface model grid) - allocate(this%regionalModelOffset(this%regionalModels%Count())) + allocate (this%regionalModelOffset(this%regionalModels%Count())) regionSize = 0 offset = 0 do imod = 1, this%regionalModels%Count() @@ -329,11 +327,11 @@ subroutine extendConnection(this) offset = offset + numModel%dis%nodes end do ! init to -1, meaning 'interface index was not assigned yet' - allocate(this%regionalToInterfaceIdxMap(regionSize)) + allocate (this%regionalToInterfaceIdxMap(regionSize)) this%regionalToInterfaceIdxMap = -1 - + call this%buildConnections() - + end subroutine extendConnection !> @brief Builds a sparse matrix holding all cell connections, @@ -343,12 +341,12 @@ subroutine buildConnections(this) ! local integer(I4B) :: icell, iconn integer(I4B), dimension(:), allocatable :: nnz - type(SparseMatrix), pointer :: sparse - integer(I4B) :: ierror + type(SparseMatrix), pointer :: sparse + integer(I4B) :: ierror type(ConnectionsType), pointer :: conn - + ! Recursively generate interface cell indices, fill map to global cells, - ! and add to region lookup table + ! and add to region lookup table this%indexCount = 0 do icell = 1, this%nrOfBoundaryCells call this%registerInterfaceCells(this%boundaryCells(icell)) @@ -363,20 +361,20 @@ subroutine buildConnections(this) ! sort interface indexes such that 'n > m' means 'n below m' call this%sortInterfaceGrid() - + ! allocate a map from interface index to global coordinates - call mem_allocate(this%idxToGlobalIdx, this%nrOfCells, & + call mem_allocate(this%idxToGlobalIdx, this%nrOfCells, & 'IDXTOGLOBALIDX', this%memoryPath) - + ! create sparse data structure, to temporarily hold connections - allocate(sparse) - allocate(nnz(this%nrOfCells)) - nnz = InitNrNeighbors+1 + allocate (sparse) + allocate (nnz(this%nrOfCells)) + nnz = InitNrNeighbors + 1 call sparse%init(this%nrOfCells, this%nrOfCells, nnz) - - ! now (recursively) add connections to sparse, start with + + ! now (recursively) add connections to sparse, start with ! the primary connections (n-m from the exchange files) - call this%makePrimaryConnections(sparse) + call this%makePrimaryConnections(sparse) ! then into own domain do icell = 1, this%nrOfBoundaryCells call this%connectNeighborCells(this%boundaryCells(icell), sparse) @@ -385,105 +383,106 @@ subroutine buildConnections(this) do icell = 1, this%nrOfBoundaryCells call this%connectNeighborCells(this%connectedCells(icell), sparse) end do - - ! create connections object - allocate(this%connections) - conn => this%connections + + ! create connections object + allocate (this%connections) + conn => this%connections call conn%allocate_scalars(this%memoryPath) conn%nodes = this%nrOfCells conn%nja = sparse%nnz - conn%njas = (conn%nja - conn%nodes) / 2 + conn%njas = (conn%nja - conn%nodes) / 2 call conn%allocate_arrays() do iconn = 1, conn%njas conn%anglex(iconn) = -999. end do ! fill connection from sparse - call sparse%filliaja(conn%ia, conn%ja, ierror) + call sparse%filliaja(conn%ia, conn%ja, ierror) if (ierror /= 0) then - write(*,*) 'Error filling ia/ja in GridConnection: terminating...' + write (*, *) 'Error filling ia/ja in GridConnection: terminating...' call ustop() - end if + end if call fillisym(conn%nodes, conn%nja, conn%ia, conn%ja, conn%isym) - call filljas(conn%nodes, conn%nja, conn%ia, conn%ja, conn%isym, conn%jas) + call filljas(conn%nodes, conn%nja, conn%ia, conn%ja, conn%isym, conn%jas) call sparse%destroy() - - ! fill connection data (ihc, cl1, cl2, etc.) using data + + ! fill connection data (ihc, cl1, cl2, etc.) using data ! from models and exchanges - call this%fillConnectionDataInternal() + call this%fillConnectionDataInternal() call this%fillConnectionDataFromExchanges() - + ! set the masks on connections call this%createConnectionMask() ! create lookup table(s) call this%createLookupTable() - - end subroutine buildConnections - + end subroutine buildConnections + !< @brief Routine for finding neighbors-of-neighbors, recursively !< recursive subroutine addNeighbors(this, cellNbrs, depth, mask, interior) use SimModule, only: ustop - class(GridConnectionType), intent(inout) :: this !< this grid connection - type(CellWithNbrsType), intent(inout) :: cellNbrs !< cell to add to - integer(I4B), intent(inout) :: depth !< current depth (typically decreases in recursion) - type(GlobalCellType), optional :: mask !< mask to excluded back-and-forth connection between cells - logical(LGP) :: interior !< when true, we are adding from the exchange back into the model + class(GridConnectionType), intent(inout) :: this !< this grid connection + type(CellWithNbrsType), intent(inout) :: cellNbrs !< cell to add to + integer(I4B), intent(inout) :: depth !< current depth (typically decreases in recursion) + type(GlobalCellType), optional :: mask !< mask to excluded back-and-forth connection between cells + logical(LGP) :: interior !< when true, we are adding from the exchange back into the model ! local - integer(I4B) :: nbrIdx, ipos, inbr - type(ConnectionsType), pointer :: conn - integer(I4B) :: newDepth - + integer(I4B) :: nbrIdx, ipos, inbr + type(ConnectionsType), pointer :: conn + integer(I4B) :: newDepth + ! if depth == 1, then we are not adding neighbors but use ! the boundary and connected cell only if (depth < 2) then return end if newDepth = depth - 1 - + conn => cellNbrs%cell%model%dis%con - + ! find neighbors local to this cell by looping through grid connections - do ipos=conn%ia(cellNbrs%cell%index) + 1, conn%ia(cellNbrs%cell%index+1) - 1 + do ipos = conn%ia(cellNbrs%cell%index) + 1, & + conn%ia(cellNbrs%cell%index + 1) - 1 nbrIdx = conn%ja(ipos) call this%addNeighborCell(cellNbrs, nbrIdx, cellNbrs%cell%model, mask) end do - + ! add remote nbr using the data from the exchanges call this%addRemoteNeighbors(cellNbrs, mask) - + ! now find nbr-of-nbr - do inbr=1, cellNbrs%nrOfNbrs + do inbr = 1, cellNbrs%nrOfNbrs ! are we leaving the model through another exchange? if (interior .and. associated(cellNbrs%cell%model, this%model)) then - if (.not. associated(cellNbrs%neighbors(inbr)%cell%model, this%model)) then + if (.not. associated(cellNbrs%neighbors(inbr)%cell%model, & + this%model)) then ! decrement by 1, because the connection we are crossing is not ! calculated by this interface newDepth = newDepth - 1 - end if + end if end if ! and add neigbors with the new depth - call this%addNeighbors(cellNbrs%neighbors(inbr), newDepth, & + call this%addNeighbors(cellNbrs%neighbors(inbr), newDepth, & cellNbrs%cell, interior) end do - + end subroutine addNeighbors - + !> @brief Add cell neighbors across models using the stored exchange !! data structures subroutine addRemoteNeighbors(this, cellNbrs, mask) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(CellWithNbrsType), intent(inout) :: cellNbrs !< cell to add to - type(GlobalCellType), optional :: mask !< a mask to exclude back-and-forth connections + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + type(CellWithNbrsType), intent(inout) :: cellNbrs !< cell to add to + type(GlobalCellType), optional :: mask !< a mask to exclude back-and-forth connections ! local integer(I4B) :: ix, iexg type(DisConnExchangeType), pointer :: connEx - - ! loop over all exchanges - do ix = 1, this%exchanges%Count() + + ! loop over all exchanges + do ix = 1, this%exchanges%Count() connEx => GetDisConnExchangeFromList(this%exchanges, ix) ! loop over n-m links in the exchange @@ -491,7 +490,7 @@ subroutine addRemoteNeighbors(this, cellNbrs, mask) do iexg = 1, connEx%nexg if (connEx%nodem1(iexg) == cellNbrs%cell%index) then ! we have a link, now add foreign neighbor - call this%addNeighborCell(cellNbrs, connEx%nodem2(iexg), & + call this%addNeighborCell(cellNbrs, connEx%nodem2(iexg), & connEx%model2, mask) end if end do @@ -501,27 +500,26 @@ subroutine addRemoteNeighbors(this, cellNbrs, mask) do iexg = 1, connEx%nexg if (connEx%nodem2(iexg) == cellNbrs%cell%index) then ! we have a link, now add foreign neighbor - call this%addNeighborCell(cellNbrs, connEx%nodem1(iexg), & + call this%addNeighborCell(cellNbrs, connEx%nodem1(iexg), & connEx%model1, mask) end if end do end if - + end do - + end subroutine addRemoteNeighbors - !> @brief Add neighboring cell to tree structure !< - subroutine addNeighborCell(this, cellNbrs, newNbrIdx, nbrModel, mask) - class(GridConnectionType), intent(in) :: this !< this grid connection instance - type(CellWithNbrsType), intent(inout) :: cellNbrs !< the root cell which to add to - integer(I4B), intent(in) :: newNbrIdx !< the neigboring cell's index - class(NumericalModelType), pointer :: nbrModel !< the model where the new neighbor lives - type(GlobalCellType), optional :: mask !< don't add connections to this cell (optional) + subroutine addNeighborCell(this, cellNbrs, newNbrIdx, nbrModel, mask) + class(GridConnectionType), intent(in) :: this !< this grid connection instance + type(CellWithNbrsType), intent(inout) :: cellNbrs !< the root cell which to add to + integer(I4B), intent(in) :: newNbrIdx !< the neigboring cell's index + class(NumericalModelType), pointer :: nbrModel !< the model where the new neighbor lives + type(GlobalCellType), optional :: mask !< don't add connections to this cell (optional) ! local - + if (present(mask)) then if (newNbrIdx == mask%index .and. associated(nbrModel, mask%model)) then return @@ -530,17 +528,17 @@ subroutine addNeighborCell(this, cellNbrs, newNbrIdx, nbrModel, mask) call cellNbrs%addNbrCell(newNbrIdx, nbrModel) end subroutine addNeighborCell - + !> @brief Recursively set interface cell indexes and !< add to the region-to-interface loopup table recursive subroutine registerInterfaceCells(this, cellWithNbrs) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(CellWithNbrsType) :: cellWithNbrs !< the cell from where to start registering neighbors + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + type(CellWithNbrsType) :: cellWithNbrs !< the cell from where to start registering neighbors ! local integer(I4B) :: offset, inbr - integer(I4B) :: regionIdx ! unique idx in the region (all connected models) - integer(I4B) :: ifaceIdx ! unique idx in the interface grid - + integer(I4B) :: regionIdx ! unique idx in the region (all connected models) + integer(I4B) :: ifaceIdx ! unique idx in the interface grid + offset = this%getRegionalModelOffset(cellWithNbrs%cell%model) regionIdx = offset + cellWithNbrs%cell%index ifaceIdx = this%getInterfaceIndex(cellWithNbrs%cell) @@ -550,20 +548,20 @@ recursive subroutine registerInterfaceCells(this, cellWithNbrs) call this%addToGlobalMap(ifaceIdx, cellWithNbrs%cell) this%regionalToInterfaceIdxMap(regionIdx) = ifaceIdx end if - + ! and also for its neighbors do inbr = 1, cellWithNbrs%nrOfNbrs call this%registerInterfaceCells(cellWithNbrs%neighbors(inbr)) end do - + end subroutine registerInterfaceCells !> @brief Add entry to lookup table, inflating when necessary !< subroutine addToGlobalMap(this, ifaceIdx, cell) class(GridConnectionType), intent(inout) :: this !< this grid connection instance - integer(I4B), intent(in) :: ifaceIdx !< unique idx in the interface grid - type(GlobalCellType), intent(in) :: cell !< the global cell + integer(I4B), intent(in) :: ifaceIdx !< unique idx in the interface grid + type(GlobalCellType), intent(in) :: cell !< the global cell ! local integer(I4B) :: i, currentSize, newSize type(GlobalCellType), dimension(:), pointer :: tempMap @@ -571,13 +569,13 @@ subroutine addToGlobalMap(this, ifaceIdx, cell) ! inflate? currentSize = size(this%idxToGlobal) if (ifaceIdx > currentSize) then - newSize = nint(1.5*currentSize) - allocate(tempMap(newSize)) + newSize = nint(1.5 * currentSize) + allocate (tempMap(newSize)) do i = 1, currentSize tempMap(i) = this%idxToGlobal(i) end do - - deallocate(this%idxToGlobal) + + deallocate (this%idxToGlobal) this%idxToGlobal => tempMap end if @@ -593,12 +591,12 @@ subroutine compressGlobalMap(this) type(GlobalCellType), dimension(:), pointer :: tempMap if (size(this%idxToGlobal) > this%nrOfCells) then - allocate(tempMap(this%nrOfCells)) + allocate (tempMap(this%nrOfCells)) tempMap(1:this%nrOfCells) = this%idxToGlobal(1:this%nrOfCells) - deallocate(this%idxToGlobal) - allocate(this%idxToGlobal(this%nrOfCells)) + deallocate (this%idxToGlobal) + allocate (this%idxToGlobal(this%nrOfCells)) this%idxToGlobal(1:this%nrOfCells) = tempMap(1:this%nrOfCells) - deallocate(tempMap) + deallocate (tempMap) end if end subroutine compressGlobalMap @@ -617,28 +615,28 @@ subroutine sortInterfaceGrid(this) integer(I4B), dimension(:), allocatable :: sortedRegionMap ! sort based on coordinates - newToOldIdx = (/ (i, i=1, size(this%idxToGlobal)) /) + newToOldIdx = (/(i, i=1, size(this%idxToGlobal))/) call quickSortGrid(newToOldIdx, size(newToOldIdx), this%idxToGlobal) - + ! and invert - allocate(oldToNewIdx(size(newToOldIdx))) - do i=1, size(oldToNewIdx) + allocate (oldToNewIdx(size(newToOldIdx))) + do i = 1, size(oldToNewIdx) oldToNewIdx(newToOldIdx(i)) = i end do ! reorder global table - allocate(sortedGlobalMap(size(this%idxToGlobal))) - do i=1, size(newToOldIdx) + allocate (sortedGlobalMap(size(this%idxToGlobal))) + do i = 1, size(newToOldIdx) sortedGlobalMap(i) = this%idxToGlobal(newToOldIdx(i)) end do - do i=1, size(newToOldIdx) + do i = 1, size(newToOldIdx) this%idxToGlobal(i) = sortedGlobalMap(i) end do - deallocate(sortedGlobalMap) + deallocate (sortedGlobalMap) - ! reorder regional lookup table - allocate(sortedRegionMap(size(this%regionalToInterfaceIdxMap))) - do i=1, size(sortedRegionMap) + ! reorder regional lookup table + allocate (sortedRegionMap(size(this%regionalToInterfaceIdxMap))) + do i = 1, size(sortedRegionMap) if (this%regionalToInterfaceIdxMap(i) /= -1) then idxOld = this%regionalToInterfaceIdxMap(i) sortedRegionMap(i) = oldToNewIdx(idxOld) @@ -646,79 +644,79 @@ subroutine sortInterfaceGrid(this) sortedRegionMap(i) = -1 end if end do - do i=1, size(sortedRegionMap) + do i = 1, size(sortedRegionMap) this%regionalToInterfaceIdxMap(i) = sortedRegionMap(i) end do - deallocate(sortedRegionMap) - + deallocate (sortedRegionMap) + end subroutine sortInterfaceGrid - + !> @brief Add primary connections to the sparse data structure !< subroutine makePrimaryConnections(this, sparse) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(SparseMatrix), pointer :: sparse !< the sparse data structure to hold the connections + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + type(SparseMatrix), pointer :: sparse !< the sparse data structure to hold the connections ! local integer(I4B) :: icell integer(I4B) :: ifaceIdx, ifaceIdxNbr - - do icell = 1, this%nrOfBoundaryCells + + do icell = 1, this%nrOfBoundaryCells ifaceIdx = this%getInterfaceIndex(this%boundaryCells(icell)%cell) ifaceIdxNbr = this%getInterfaceIndex(this%connectedCells(icell)%cell) - + ! add diagonals to sparse call sparse%addconnection(ifaceIdx, ifaceIdx, 1) call sparse%addconnection(ifaceIdxNbr, ifaceIdxNbr, 1) - + ! and cross terms call sparse%addconnection(ifaceIdx, ifaceIdxNbr, 1) call sparse%addconnection(ifaceIdxNbr, ifaceIdx, 1) end do - + end subroutine makePrimaryConnections - + !> @brief Recursively add higher order connections (from !! cells neighoring the primarily connected cells) to the !< sparse data structure recursive subroutine connectNeighborCells(this, cell, sparse) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(CellWithNbrsType) :: cell !< the cell whose connections is to be added - type(SparseMatrix), pointer :: sparse !< the sparse data structure to hold the connections + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + type(CellWithNbrsType) :: cell !< the cell whose connections is to be added + type(SparseMatrix), pointer :: sparse !< the sparse data structure to hold the connections ! local - integer(I4B) :: ifaceIdx, ifaceIdxNbr ! unique idx in the interface grid + integer(I4B) :: ifaceIdx, ifaceIdxNbr ! unique idx in the interface grid integer(I4B) :: inbr - + ifaceIdx = this%getInterfaceIndex(cell%cell) do inbr = 1, cell%nrOfNbrs ifaceIdxNbr = this%getInterfaceIndex(cell%neighbors(inbr)%cell) - + call sparse%addconnection(ifaceIdxNbr, ifaceIdxNbr, 1) call sparse%addconnection(ifaceIdx, ifaceIdxNbr, 1) call sparse%addconnection(ifaceIdxNbr, ifaceIdx, 1) - + ! recurse call this%connectNeighborCells(cell%neighbors(inbr), sparse) end do - + end subroutine connectNeighborCells - + !> @brief Fill connection data (ihc, cl1, ...) for !< connections between cells within the same model. subroutine fillConnectionDataInternal(this) use ConstantsModule, only: DPI, DTWOPI - class(GridConnectionType), intent(inout) :: this !< this grid connection instance + class(GridConnectionType), intent(inout) :: this !< this grid connection instance ! local - type(ConnectionsType), pointer :: conn, connOrig + type(ConnectionsType), pointer :: conn, connOrig integer(I4B) :: n, m, ipos, isym, iposOrig, isymOrig type(GlobalCellType), pointer :: ncell, mcell - + conn => this%connections - + do n = 1, conn%nodes - do ipos=conn%ia(n)+1, conn%ia(n+1)-1 + do ipos = conn%ia(n) + 1, conn%ia(n + 1) - 1 m = conn%ja(ipos) if (n > m) cycle - + isym = conn%jas(ipos) ncell => this%idxToGlobal(n) mcell => this%idxToGlobal(m) @@ -727,15 +725,15 @@ subroutine fillConnectionDataInternal(this) connOrig => ncell%model%dis%con iposOrig = connOrig%getjaindex(ncell%index, mcell%index) if (iposOrig == 0) then - ! periodic boundary conditions can add connections between cells in + ! periodic boundary conditions can add connections between cells in ! the same model, but they are dealt with through the exchange data if (this%isPeriodic(ncell%index, mcell%index)) cycle - + ! this should not be possible - write(*,*) 'Error: cannot find cell connection in model grid' - call ustop() + write (*, *) 'Error: cannot find cell connection in model grid' + call ustop() end if - + isymOrig = connOrig%jas(iposOrig) conn%hwva(isym) = connOrig%hwva(isymOrig) conn%ihc(isym) = connOrig%ihc(isymOrig) @@ -752,25 +750,25 @@ subroutine fillConnectionDataInternal(this) end do end do end subroutine fillConnectionDataInternal - - !> @brief Fill connection data (ihc, cl1, ...) for + + !> @brief Fill connection data (ihc, cl1, ...) for !< all exchanges subroutine fillConnectionDataFromExchanges(this) use ConstantsModule, only: DPI, DTWOPI, DPIO180 - use ArrayHandlersModule, only: ifind - class(GridConnectionType), intent(inout) :: this !< this grid connection instance + use ArrayHandlersModule, only: ifind + class(GridConnectionType), intent(inout) :: this !< this grid connection instance ! local integer(I4B) :: inx, iexg, ivalAngldegx integer(I4B) :: ipos, isym integer(I4B) :: nOffset, mOffset, nIfaceIdx, mIfaceIdx class(DisConnExchangeType), pointer :: connEx type(ConnectionsType), pointer :: conn - + conn => this%connections - + do inx = 1, this%exchanges%Count() - connEx => GetDisConnExchangeFromList(this%exchanges, inx) - + connEx => GetDisConnExchangeFromList(this%exchanges, inx) + ivalAngldegx = -1 if (connEx%naux > 0) then ivalAngldegx = ifind(connEx%auxname, 'ANGLDEGX') @@ -778,50 +776,51 @@ subroutine fillConnectionDataFromExchanges(this) conn%ianglex = 1 end if end if - + nOffset = this%getRegionalModelOffset(connEx%model1) mOffset = this%getRegionalModelOffset(connEx%model2) do iexg = 1, connEx%nexg nIfaceIdx = this%regionalToInterfaceIdxMap(noffset + connEx%nodem1(iexg)) mIfaceIdx = this%regionalToInterfaceIdxMap(moffset + connEx%nodem2(iexg)) - ! not all nodes from the exchanges are part of the interface grid + ! not all nodes from the exchanges are part of the interface grid ! (think of exchanges between neigboring models, and their neighbors) if (nIFaceIdx == -1 .or. mIFaceIdx == -1) then cycle end if - - ipos = conn%getjaindex(nIfaceIdx, mIfaceIdx) - ! (see prev. remark) sometimes the cells are in the interface grid, + + ipos = conn%getjaindex(nIfaceIdx, mIfaceIdx) + ! (see prev. remark) sometimes the cells are in the interface grid, ! but the connection isn't. This can happen for leaf nodes of the grid. if (ipos == 0) then ! no match, safely cycle cycle - end if + end if isym = conn%jas(ipos) - + ! note: cl1 equals L_nm: the length from cell n to the shared ! face with cell m (and cl2 analogously for L_mn) if (nIfaceIdx < mIfaceIdx) then conn%cl1(isym) = connEx%cl1(iexg) conn%cl2(isym) = connEx%cl2(iexg) if (ivalAngldegx > 0) then - conn%anglex(isym) = connEx%auxvar(ivalAngldegx,iexg) * DPIO180 + conn%anglex(isym) = connEx%auxvar(ivalAngldegx, iexg) * DPIO180 end if else conn%cl1(isym) = connEx%cl2(iexg) conn%cl2(isym) = connEx%cl1(iexg) if (ivalAngldegx > 0) then - conn%anglex(isym) = mod(connEx%auxvar(ivalAngldegx,iexg) + 180.0_DP, 360.0_DP) * DPIO180 + conn%anglex(isym) = mod(connEx%auxvar(ivalAngldegx, iexg) + & + 180.0_DP, 360.0_DP) * DPIO180 end if end if conn%hwva(isym) = connEx%hwva(iexg) conn%ihc(isym) = connEx%ihc(iexg) - - end do + + end do end do - - end subroutine fillConnectionDataFromExchanges - + + end subroutine fillConnectionDataFromExchanges + !> @brief Create the connection masks !! !! The level indicates the nr of connections away from @@ -834,55 +833,59 @@ subroutine createConnectionMask(this) integer(I4B) :: icell, inbr, n, ipos integer(I4B) :: level, newMask type(CellWithNbrsType), pointer :: cell, nbrCell - + ! set all masks to zero to begin with do ipos = 1, this%connections%nja - call this%connections%set_mask(ipos, 0) + call this%connections%set_mask(ipos, 0) end do - + ! remote connections remain masked ! now set mask for exchange connections (level == 1) level = 1 - do icell = 1, this%nrOfBoundaryCells - call this%setMaskOnConnection(this%boundaryCells(icell), this%connectedCells(icell), level) + do icell = 1, this%nrOfBoundaryCells + call this%setMaskOnConnection(this%boundaryCells(icell), & + this%connectedCells(icell), level) ! for cross-boundary connections, we need to apply the mask to both n-m and m-n, ! because if the upper triangular one is disabled, its transposed (lower triangular) ! counter part is skipped in the NPF calculation as well. - call this%setMaskOnConnection(this%connectedCells(icell), this%boundaryCells(icell), level) + call this%setMaskOnConnection(this%connectedCells(icell), & + this%boundaryCells(icell), level) end do - + ! now extend mask recursively into the internal domain (level > 1) do icell = 1, this%nrOfBoundaryCells - cell => this%boundaryCells(icell) + cell => this%boundaryCells(icell) do inbr = 1, cell%nrOfNbrs nbrCell => this%boundaryCells(icell)%neighbors(inbr) level = 2 ! this is incremented within the recursion - call this%maskInternalConnections(this%boundaryCells(icell), this%boundaryCells(icell)%neighbors(inbr), level) - end do + call this%maskInternalConnections(this%boundaryCells(icell), & + this%boundaryCells(icell)% & + neighbors(inbr), level) + end do end do - + ! set normalized mask: ! =1 for links with connectivity <= interior stencil depth ! =0 otherwise - do n = 1, this%connections%nodes + do n = 1, this%connections%nodes ! set diagonals to zero call this%connections%set_mask(this%connections%ia(n), 0) - + do ipos = this%connections%ia(n) + 1, this%connections%ia(n + 1) - 1 newMask = 0 if (this%connections%mask(ipos) > 0) then if (this%connections%mask(ipos) < this%internalStencilDepth + 1) then newMask = 1 end if - end if + end if ! set mask on off-diag call this%connections%set_mask(ipos, newMask) - end do + end do end do - + end subroutine createConnectionMask - !> @brief Create lookup tables for efficient access + !> @brief Create lookup tables for efficient access !< (this needs the connections object to be available) subroutine createLookupTable(this) use CsrUtilsModule, only: getCSRIndex @@ -893,58 +896,60 @@ subroutine createLookupTable(this) do i = 1, this%nrOfBoundaryCells n1 = this%getInterfaceIndexByIndexModel(this%boundaryCells(i)%cell%index, & this%boundaryCells(i)%cell%model) - n2 = this%getInterfaceIndexByIndexModel(this%connectedCells(i)%cell%index,& + n2 = this%getInterfaceIndexByIndexModel(this%connectedCells(i)%cell%index, & this%connectedCells(i)%cell%model) - + ipos = getCSRIndex(n1, n2, this%connections%ia, this%connections%ja) this%primConnections(i) = ipos - end do + end do end subroutine createLookupTable - + !> @brief Recursively mask connections, increasing the level as we go !< recursive subroutine maskInternalConnections(this, cell, nbrCell, level) class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(CellWithNbrsType), intent(inout) :: cell !< cell 1 in the connection to mask + type(CellWithNbrsType), intent(inout) :: cell !< cell 1 in the connection to mask type(CellWithNbrsType), intent(inout) :: nbrCell !< cell 2 in the connection to mask integer(I4B), intent(in) :: level ! local integer(I4B) :: inbr, newLevel - + ! only set the mask for internal connections, leaving the ! others at 0 - if (associated(cell%cell%model, this%model) .and. & + if (associated(cell%cell%model, this%model) .and. & associated(nbrCell%cell%model, this%model)) then ! this will set a mask on both diagonal, and both cross terms call this%setMaskOnConnection(cell, nbrCell, level) call this%setMaskOnConnection(nbrCell, cell, level) end if - + ! recurse on nbrs-of-nbrs newLevel = level + 1 - do inbr = 1, nbrCell%nrOfNbrs - call this%maskInternalConnections(nbrCell, nbrCell%neighbors(inbr), newLevel) + do inbr = 1, nbrCell%nrOfNbrs + call this%maskInternalConnections(nbrCell, & + nbrCell%neighbors(inbr), & + newLevel) end do - + end subroutine maskInternalConnections - + !> @brief Set a mask on the connection from a cell to its neighbor, !! (and not the transposed!) not overwriting the current level !< of a connection when it is smaller subroutine setMaskOnConnection(this, cell, nbrCell, level) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(CellWithNbrsType), intent(inout) :: cell !< cell 1 in the connection - type(CellWithNbrsType), intent(inout) :: nbrCell !< cell 2 in the connection - integer(I4B), intent(in) :: level !< the level value to set the mask to + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + type(CellWithNbrsType), intent(inout) :: cell !< cell 1 in the connection + type(CellWithNbrsType), intent(inout) :: nbrCell !< cell 2 in the connection + integer(I4B), intent(in) :: level !< the level value to set the mask to ! local integer(I4B) :: ifaceIdx, ifaceIdxNbr integer(I4B) :: iposdiag, ipos integer(I4B) :: currentLevel - + ifaceIdx = this%getInterfaceIndex(cell%cell) ifaceIdxNbr = this%getInterfaceIndex(nbrCell%cell) - + ! diagonal iposdiag = this%connections%getjaindex(ifaceIdx, ifaceIdx) currentLevel = this%connections%mask(iposdiag) @@ -957,18 +962,18 @@ subroutine setMaskOnConnection(this, cell, nbrCell, level) if (currentLevel == 0 .or. level < currentLevel) then call this%connections%set_mask(ipos, level) end if - + end subroutine setMaskOnConnection - + !> @brief Get interface index from global cell !< function getInterfaceIndexByCell(this, cell) result(ifaceIdx) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - type(GlobalCellType), intent(in) :: cell !< the global cell to get the interface index for - integer(I4B) :: ifaceIdx !< the index in the interface model + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + type(GlobalCellType), intent(in) :: cell !< the global cell to get the interface index for + integer(I4B) :: ifaceIdx !< the index in the interface model ! local integer(I4B) :: offset, regionIdx - + offset = this%getRegionalModelOffset(cell%model) regionIdx = offset + cell%index ifaceIdx = this%regionalToInterfaceIdxMap(regionIdx) @@ -977,63 +982,63 @@ end function getInterfaceIndexByCell !> @brief Get interface index from a model pointer and the local index !< function getInterfaceIndexByIndexModel(this, index, model) result(ifaceIdx) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - integer(I4B) :: index !< the local cell index - class(NumericalModelType), pointer :: model !< the cell's model - integer(I4B) :: ifaceIdx !< the index in the interface model + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + integer(I4B) :: index !< the local cell index + class(NumericalModelType), pointer :: model !< the cell's model + integer(I4B) :: ifaceIdx !< the index in the interface model ! local integer(I4B) :: offset, regionIdx - + offset = this%getRegionalModelOffset(model) regionIdx = offset + index ifaceIdx = this%regionalToInterfaceIdxMap(regionIdx) end function getInterfaceIndexByIndexModel - + !> @brief Get the offset for a regional model !< function getRegionalModelOffset(this, model) result(offset) - class(GridConnectionType), intent(inout) :: this !< this grid connection instance - class(NumericalModelType), pointer :: model !< the model to get the offset for - integer(I4B) :: offset !< the index offset in the regional domain + class(GridConnectionType), intent(inout) :: this !< this grid connection instance + class(NumericalModelType), pointer :: model !< the model to get the offset for + integer(I4B) :: offset !< the index offset in the regional domain ! local integer(I4B) :: im class(NumericalModelType), pointer :: modelInList offset = 0 do im = 1, this%regionalModels%Count() - modelInList => GetNumericalModelFromList(this%regionalModels, im) - if (associated(model, modelInList)) then - offset = this%regionalModelOffset(im) - return - end if + modelInList => GetNumericalModelFromList(this%regionalModels, im) + if (associated(model, modelInList)) then + offset = this%regionalModelOffset(im) + return + end if end do - + end function getRegionalModelOffset - + !> @brief Allocate scalar data !< subroutine allocateScalars(this) use MemoryManagerModule, only: mem_allocate class(GridConnectionType) :: this !< this grid connection instance - + call mem_allocate(this%nrOfBoundaryCells, 'NRBNDCELLS', this%memoryPath) call mem_allocate(this%indexCount, 'IDXCOUNT', this%memoryPath) call mem_allocate(this%nrOfCells, 'NRCELLS', this%memoryPath) - + end subroutine allocateScalars !> @brief Sets the discretization (DISU) after all !! preprocessing by this grid connection has been done, !< this comes after disu_cr - subroutine getDiscretization(this, disu) - use ConnectionsModule + subroutine getDiscretization(this, disu) + use ConnectionsModule use SparseModule, only: sparsematrix - class(GridConnectionType) :: this !< the grid connection - class(GwfDisuType), pointer :: disu !< the target disu object + class(GridConnectionType) :: this !< the grid connection + class(GwfDisuType), pointer :: disu !< the target disu object ! local integer(I4B) :: icell, nrOfCells, idx type(NumericalModelType), pointer :: model real(DP) :: x, y, xglo, yglo - + ! the following is similar to dis_df nrOfCells = this%nrOfCells disu%nodes = nrOfCells @@ -1041,23 +1046,23 @@ subroutine getDiscretization(this, disu) disu%nja = this%connections%nja call disu%allocate_arrays() - ! these are otherwise allocated in dis%read_dimensions + ! these are otherwise allocated in dis%read_dimensions call disu%allocate_arrays_mem() - + ! fill data do icell = 1, nrOfCells idx = this%idxToGlobal(icell)%index model => this%idxToGlobal(icell)%model - + disu%top(icell) = model%dis%top(idx) disu%bot(icell) = model%dis%bot(idx) disu%area(icell) = model%dis%area(idx) end do - + ! grid connections follow from GridConnection: disu%con => this%connections - disu%njas = disu%con%njas - + disu%njas = disu%con%njas + ! copy cell x,y do icell = 1, nrOfCells idx = this%idxToGlobal(icell)%index @@ -1067,8 +1072,8 @@ subroutine getDiscretization(this, disu) ! we are merging grids with possibly (likely) different origins, ! transform: call model%dis%transform_xy(x, y, xglo, yglo) - disu%cellxy(1,icell) = xglo - disu%cellxy(2,icell) = yglo + disu%cellxy(1, icell) = xglo + disu%cellxy(2, icell) = yglo end do ! if vertices will be needed, it will look like this: @@ -1079,44 +1084,44 @@ subroutine getDiscretization(this, disu) ! 4. get vertex data per cell, add functions to base ! 5. add vertex (x,y) to list and connectivity to sparse ! 6. generate ia/ja from sparse - + end subroutine getDiscretization - !> @brief Deallocate grid connection resources !< subroutine destroy(this) - use MemoryManagerModule, only: mem_deallocate + use MemoryManagerModule, only: mem_deallocate class(GridConnectionType) :: this !< this grid connection instance - + call mem_deallocate(this%nrOfBoundaryCells) call mem_deallocate(this%indexCount) call mem_deallocate(this%nrOfCells) ! arrays - deallocate(this%idxToGlobal) - deallocate(this%boundaryCells) - deallocate(this%connectedCells) - deallocate(this%primConnections) + deallocate (this%idxToGlobal) + deallocate (this%boundaryCells) + deallocate (this%connectedCells) + deallocate (this%primConnections) call mem_deallocate(this%idxToGlobalIdx) - + end subroutine destroy - + !> @brief Test if the connection between nodes within !< the same model is periodic function isPeriodic(this, n, m) result(periodic) class(GridConnectionType), intent(in) :: this !< this grid connection instance - integer(I4B), intent(in) :: n !< first node of the connection - integer(I4B), intent(in) :: m !< second node of the connection - logical :: periodic !< true when periodic + integer(I4B), intent(in) :: n !< first node of the connection + integer(I4B), intent(in) :: m !< second node of the connection + logical :: periodic !< true when periodic ! local integer(I4B) :: icell - - periodic = .false. + + periodic = .false. do icell = 1, this%nrOfBoundaryCells - if (.not. associated(this%boundaryCells(icell)%cell%model, this%connectedCells(icell)%cell%model)) cycle - + if (.not. associated(this%boundaryCells(icell)%cell%model, & + this%connectedCells(icell)%cell%model)) cycle + ! one way if (this%boundaryCells(icell)%cell%index == n) then if (this%connectedCells(icell)%cell%index == m) then @@ -1131,9 +1136,9 @@ function isPeriodic(this, n, m) result(periodic) return end if end if - + end do - + end function - + end module GridConnectionModule diff --git a/src/Model/Connection/GridSorting.f90 b/src/Model/Connection/GridSorting.f90 index 4c10b28bf84..732816b4e6c 100644 --- a/src/Model/Connection/GridSorting.f90 +++ b/src/Model/Connection/GridSorting.f90 @@ -1,4 +1,4 @@ -module GridSorting +module GridSorting use KindModule, only: I4B, DP, LGP use ConstantsModule, only: DHALF use CellWithNbrsModule, only: GlobalCellType @@ -11,74 +11,76 @@ module GridSorting contains ! Sort an array of integers subroutine quickSortGrid(array, arraySize, idxToGlobal) - integer, intent(inout), dimension(:) :: array - integer, intent(in) :: arraySize - type(GlobalCellType), dimension(:), pointer :: idxToGlobal + integer, intent(inout), dimension(:) :: array + integer, intent(in) :: arraySize + type(GlobalCellType), dimension(:), pointer :: idxToGlobal + ! local + integer :: QSORT_THRESHOLD = 8 + include "qsort_inline.inc" + + contains + subroutine init() + end subroutine init + + ! Compare two grid cells, this doesn't work as + ! smooth for staggered discretizations though... + function lessThan(n, m) result(isLess) + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: m + logical(LGP) :: isLess ! local - integer :: QSORT_THRESHOLD = 8 - include "qsort_inline.inc" - - contains - subroutine init() - end subroutine init + type(GlobalCellType), pointer :: gcn, gcm + real(DP) :: xnloc, ynloc, xmloc, ymloc + real(DP) :: xn, yn, zn, xm, ym, zm + + ! get coordinates + gcn => idxToGlobal(array(n)) + gcm => idxToGlobal(array(m)) + + ! convert coordinates + call gcn%model%dis%get_cellxy(gcn%index, xnloc, ynloc) + call gcn%model%dis%transform_xy(xnloc, ynloc, xn, yn) + zn = DHALF * (gcn%model%dis%top(gcn%index) + & + gcn%model%dis%bot(gcn%index)) + + call gcm%model%dis%get_cellxy(gcm%index, xmloc, ymloc) + call gcm%model%dis%transform_xy(xmloc, ymloc, xm, ym) + zm = DHALF * (gcm%model%dis%top(gcm%index) + & + gcm%model%dis%bot(gcm%index)) + + ! compare + if (.not. is_same(zn, zm, 10 * epsilon(zn))) then + isLess = zn > zm + else if (.not. is_same(yn, ym, 10 * epsilon(yn))) then + isLess = yn > ym + else if (.not. is_same(xn, xm, 10 * epsilon(xn))) then + isLess = xn < xm + else + isLess = .false. + end if - ! Compare two grid cells, this doesn't work as - ! smooth for staggered discretizations though... - function lessThan(n, m) result(isLess) - integer(I4B), intent(in) :: n - integer(I4B), intent(in) :: m - logical(LGP) :: isLess - ! local - type(GlobalCellType), pointer :: gcn, gcm - real(DP) :: xnloc, ynloc, xmloc, ymloc - real(DP) :: xn, yn, zn, xm, ym, zm - - ! get coordinates - gcn => idxToGlobal(array(n)) - gcm => idxToGlobal(array(m)) - - ! convert coordinates - call gcn%model%dis%get_cellxy(gcn%index, xnloc, ynloc) - call gcn%model%dis%transform_xy(xnloc, ynloc, xn, yn) - zn = DHALF*(gcn%model%dis%top(gcn%index) + gcn%model%dis%bot(gcn%index)) - - call gcm%model%dis%get_cellxy(gcm%index, xmloc, ymloc) - call gcm%model%dis%transform_xy(xmloc, ymloc, xm, ym) - zm = DHALF*(gcm%model%dis%top(gcm%index) + gcm%model%dis%bot(gcm%index)) - - ! compare - if (.not. is_same(zn, zm, 10*epsilon(zn))) then - isLess = zn > zm - else if (.not. is_same(yn, ym, 10*epsilon(yn))) then - isLess = yn > ym - else if (.not. is_same(xn, xm, 10*epsilon(xn))) then - isLess = xn < xm - else - isLess = .false. - end if + end function lessThan - end function lessThan + ! swap indices + subroutine swap(a, b) + integer, intent(in) :: a, b + integer :: hold - ! swap indices - subroutine swap(a,b) - integer, intent(in) :: a,b - integer :: hold + hold = array(a) + array(a) = array(b) + array(b) = hold - hold=array(a) - array(a)=array(b) - array(b)=hold + end subroutine swap - end subroutine swap - - ! circular shift-right by one - subroutine rshift(left,right) - integer, intent(in) :: left, right - integer :: hold + ! circular shift-right by one + subroutine rshift(left, right) + integer, intent(in) :: left, right + integer :: hold - hold=array(right) - array(left+1:right)=array(left:right-1) - array(left)=hold + hold = array(right) + array(left + 1:right) = array(left:right - 1) + array(left) = hold - end subroutine rshift + end subroutine rshift end subroutine quickSortGrid end module GridSorting diff --git a/src/Model/Connection/GweGweConnection.f90 b/src/Model/Connection/GweGweConnection.f90 new file mode 100644 index 00000000000..711a791b105 --- /dev/null +++ b/src/Model/Connection/GweGweConnection.f90 @@ -0,0 +1,629 @@ +module GweGweConnectionModule + use KindModule, only: I4B, DP, LGP + use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, DZERO, LENBUDTXT + use CsrUtilsModule, only: getCSRIndex + use SimModule, only: ustop + use MemoryManagerModule, only: mem_allocate, mem_deallocate + use SpatialModelConnectionModule + use NumericalModelModule + use GweModule + use DisConnExchangeModule + use GweGweExchangeModule + use GweInterfaceModelModule + use SparseModule, only: sparsematrix + use ConnectionsModule, only: ConnectionsType + use CellWithNbrsModule, only: GlobalCellType + + implicit none + private + + public :: CastAsGweGweConnection + + !> Connects a GWE model to other GWE models in space. Derives + !! from NumericalExchangeType so the solution can use it to + !! fetch the coefficients for this connection. + !< + type, public, extends(SpatialModelConnectionType) :: GweGweConnectionType + + type(GweModelType), pointer :: gweModel => null() !< the model for which this connection exists + type(GweExchangeType), pointer :: gweExchange => null() !< the primary exchange, cast to GWE-GWE + logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, + !! one of them needs to manage/own the exchange (e.g. clean up) + type(GweInterfaceModelType), pointer :: gweInterfaceModel => null() !< the interface model + integer(I4B), pointer :: iIfaceAdvScheme => null() !< the advection scheme at the interface: + !! 0 = upstream, 1 = central, 2 = TVD + integer(I4B), pointer :: iIfaceXt3d => null() !< XT3D in the interface DSP package: 0 = no, 1 = lhs, 2 = rhs + real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< intercell flows at the interface, coming from GWF interface model + integer(I4B), pointer :: exgflowSign => null() !< indicates the flow direction of exgflowja + real(DP), dimension(:), pointer, contiguous :: exgflowjaGwt => null() !< gwe-flowja at the interface (this is a subset of the GWE + !! interface model flowja's) + + real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< gwfflowja for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< gwfsat for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< gwfhead for the interface model + real(DP), dimension(:,:), pointer, contiguous :: gwfspdis => null() !< gwfspdis for the interface model + + real(DP), dimension(:), pointer, contiguous :: conc => null() !< pointer to concentration array + integer(I4B), dimension(:), pointer, contiguous :: icbound => null() !< store pointer to gwe ibound array + + integer(I4B) :: iout = 0 !< the list file for the interface model + + contains + + procedure, pass(this) :: gweGweConnection_ctor + generic, public :: construct => gweGweConnection_ctor + + procedure :: exg_ar => gwegwecon_ar + procedure :: exg_df => gwegwecon_df + procedure :: exg_ac => gwegwecon_ac + procedure :: exg_rp => gwegwecon_rp + procedure :: exg_ad => gwegwecon_ad + procedure :: exg_cf => gwegwecon_cf + procedure :: exg_fc => gwegwecon_fc + procedure :: exg_da => gwegwecon_da + procedure :: exg_cq => gwegwecon_cq + procedure :: exg_bd => gwegwecon_bd + procedure :: exg_ot => gwegwecon_ot + + ! overriding 'protected' + procedure, pass(this) :: validateConnection + + ! local stuff + procedure, pass(this), private :: allocate_scalars + procedure, pass(this), private :: allocate_arrays + procedure, pass(this), private :: syncInterfaceModel + procedure, pass(this), private :: setGridExtent + procedure, pass(this), private :: setFlowToExchange + + end type GweGweConnectionType + +contains + +!> @brief Basic construction of the connection +!< +subroutine gweGweConnection_ctor(this, model, gweEx) + use InputOutputModule, only: openfile + class(GweGweConnectionType) :: this !< the connection + class(NumericalModelType), pointer :: model !< the model owning this connection, + !! this must be a GweModelType + class(DisConnExchangeType), pointer :: gweEx !< the GWE-GWE exchange the interface model is created for + ! local + character(len=LINELENGTH) :: fname + character(len=LENCOMPONENTNAME) :: name + class(*), pointer :: objPtr + logical(LGP) :: write_ifmodel_listfile = .false. + + objPtr => model + this%gweModel => CastAsGweModel(objPtr) + objPtr => gweEx + this%gweExchange => CastAsGweExchange(objPtr) + + this%exchangeIsOwned = associated(model, gweEx%model1) + + if (this%exchangeIsOwned) then + write(name,'(a,i0)') 'GWECON1_', gweEx%id + else + write(name,'(a,i0)') 'GWECON2_', gweEx%id + end if + + ! .lst file for interface model + if (write_ifmodel_listfile) then + fname = trim(name)//'.im.lst' + call openfile(this%iout, 0, fname, 'LIST', filstat_opt='REPLACE') + write(this%iout, '(4a)') 'Creating GWE-GWE connection for model ', & + trim(this%gweModel%name), 'from exchange ', & + trim(gweEx%name) + end if + + ! first call base constructor + call this%SpatialModelConnectionType%spatialConnection_ctor(model, gweEx, name) + + call this%allocate_scalars() + this%typename = 'GWE-GWE' + this%iIfaceAdvScheme = 0 + this%iIfaceXt3d = 1 + this%exgflowSign = 1 + + allocate(this%gweInterfaceModel) + this%interfaceModel => this%gweInterfaceModel + +end subroutine gweGweConnection_ctor + +!> @brief Allocate scalar variables for this connection +!< +subroutine allocate_scalars(this) + class(GweGweConnectionType) :: this !< the connection + + call mem_allocate(this%iIfaceAdvScheme, 'IADVSCHEME', this%memoryPath) + call mem_allocate(this%iIfaceXt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%exgflowSign, 'EXGFLOWSIGN', this%memoryPath) + +end subroutine allocate_scalars + +!> @brief Allocate array variables for this connection +!< +subroutine allocate_arrays(this) + class(GweGweConnectionType) :: this !< the connection + ! local + integer(I4B) :: i + + call mem_allocate(this%gwfflowja, this%interfaceModel%nja, 'GWFFLOWJA', & + this%memoryPath) + call mem_allocate(this%gwfsat, this%neq, 'GWFSAT', this%memoryPath) + call mem_allocate(this%gwfhead, this%neq, 'GWFHEAD', this%memoryPath) + call mem_allocate(this%gwfspdis, 3, this%neq, 'GWFSPDIS', this%memoryPath) + + call mem_allocate(this%exgflowjaGwt, this%gridConnection%nrOfBoundaryCells, & + 'EXGFLOWJAGWE', this%memoryPath) + + do i = 1, size(this%gwfflowja) + this%gwfflowja = 0.0_DP + end do + + do i = 1, this%neq + this%gwfsat = 0.0_DP + end do + +end subroutine allocate_arrays + +!> @brief define the GWE-GWE connection +!< +subroutine gwegwecon_df(this) + class(GweGweConnectionType) :: this !< the connection + ! local + character(len=LENCOMPONENTNAME) :: imName + + ! determine advection scheme (the GWE-GWE exchange + ! has been read at this point) + this%iIfaceAdvScheme = this%gweExchange%iAdvScheme + + ! determine xt3d setting on interface + this%iIfaceXt3d = this%gweExchange%ixt3d + + ! determine the required size of the interface model grid + call this%setGridExtent() + + ! now set up the GridConnection + call this%spatialcon_df() + + ! we have to 'catch up' and create the interface model + ! here, then the remainder of this routine will be define + if (this%exchangeIsOwned) then + write(imName,'(a,i0)') 'GWEIM1_', this%gweExchange%id + else + write(imName,'(a,i0)') 'GWEIM2_', this%gweExchange%id + end if + call this%gweInterfaceModel%gweifmod_cr(imName, this%iout, this%gridConnection) + this%gweInterfaceModel%iAdvScheme = this%iIfaceAdvScheme + this%gweInterfaceModel%ixt3d = this%iIfaceXt3d + call this%gweInterfaceModel%model_df() + + call this%allocate_arrays() + + ! connect X, RHS, IBOUND, and flowja + call this%spatialcon_setmodelptrs() + + this%gweInterfaceModel%fmi%gwfflowja => this%gwfflowja + this%gweInterfaceModel%fmi%gwfsat => this%gwfsat + this%gweInterfaceModel%fmi%gwfhead => this%gwfhead + this%gweInterfaceModel%fmi%gwfspdis => this%gwfspdis + + ! connect pointers (used by BUY) + this%conc => this%gweInterfaceModel%x + this%icbound => this%gweInterfaceModel%ibound + + ! add connections from the interface model to solution matrix + call this%spatialcon_connect() + +end subroutine gwegwecon_df + +!> @brief Set required extent of the interface grid from +!< the configuration +subroutine setGridExtent(this) + class(GweGweConnectionType) :: this !< the connection + ! local + logical(LGP) :: hasAdv, hasDsp + + hasAdv = this%gweModel%inadv > 0 + hasDsp = this%gweModel%indsp > 0 + + if (hasAdv) then + if (this%iIfaceAdvScheme == 2) then + this%exchangeStencilDepth = 2 + if (this%gweModel%adv%iadvwt == 2) then + this%internalStencilDepth = 2 + end if + end if + end if + + if (hasDsp) then + if (this%iIfaceXt3d > 0) then + this%exchangeStencilDepth = 2 + if (this%gweModel%dsp%ixt3d > 0) then + this%internalStencilDepth = 2 + end if + end if + end if + +end subroutine setGridExtent + +!> @brief allocate and read/set the connection's data structures +!< +subroutine gwegwecon_ar(this) + class(GweGweConnectionType) :: this !< the connection + ! local + integer(I4B) :: i, idx + class(GweModelType), pointer :: gweModel + class(*), pointer :: modelPtr + + ! check if we can construct an interface model + ! NB: only makes sense after the models' allocate&read have been + ! called, which is why we do it here + call this%validateConnection() + + ! fill porosity from mst packages, needed for dsp + if (this%gweModel%inmst > 0) then + do i = 1, this%neq + modelPtr => this%gridConnection%idxToGlobal(i)%model + gweModel => CastAsGweModel(modelPtr) + idx = this%gridConnection%idxToGlobal(i)%index + this%gweInterfaceModel%porosity(i) = gweModel%mst%porosity(idx) + end do + end if + + ! allocate and read base + call this%spatialcon_ar() + + ! ... and now the interface model + call this%gweInterfaceModel%model_ar() + + ! AR the movers and obs through the exchange + if (this%exchangeIsOwned) then + !cdl implement this when MVT is ready + !cdl if (this%gweExchange%inmvt > 0) then + !cdl call this%gweExchange%mvt%mvt_ar() + !cdl end if + if (this%gweExchange%inobs > 0) then + call this%gweExchange%obs%obs_ar() + end if + end if + +end subroutine gwegwecon_ar + +!> @brief validate this connection prior to constructing +!< the interface model +subroutine validateConnection(this) + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error + class(GweGweConnectionType) :: this !< this connection + + ! base validation, the spatial/geometry part + call this%SpatialModelConnectionType%validateConnection() + + ! GWE related matters + if ((this%gweExchange%gwemodel1%inadv > 0 .and. this%gweExchange%gwemodel2%inadv == 0) .or. & + (this%gweExchange%gwemodel2%inadv > 0 .and. this%gweExchange%gwemodel1%inadv == 0)) then + write(errmsg, '(1x,a,a,a)') 'Cannot connect GWE models in exchange ', & + trim(this%gweExchange%name), ' because one model is configured with ADV & + &and the other one is not' + call store_error(errmsg) + end if + + if ((this%gweExchange%gwemodel1%indsp > 0 .and. this%gweExchange%gwemodel2%indsp == 0) .or. & + (this%gweExchange%gwemodel2%indsp > 0 .and. this%gweExchange%gwemodel1%indsp == 0)) then + write(errmsg, '(1x,a,a,a)') 'Cannot connect GWE models in exchange ', & + trim(this%gweExchange%name), ' because one model is configured with DSP & + &and the other one is not' + call store_error(errmsg) + end if + + ! abort on errors + if(count_errors() > 0) then + write(errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' + call ustop() + end if + +end subroutine validateConnection + + +!> @brief add connections to the global system for +!< this connection +subroutine gwegwecon_ac(this, sparse) + class(GweGweConnectionType) :: this !< this connection + type(sparsematrix), intent(inout) :: sparse !< sparse matrix to store the connections + ! local + integer(I4B) :: ic, iglo, jglo + type(GlobalCellType) :: boundaryCell, connectedCell + + ! connections to other models + do ic = 1, this%gridConnection%nrOfBoundaryCells + boundaryCell = this%gridConnection%boundaryCells(ic)%cell + connectedCell = this%gridConnection%connectedCells(ic)%cell + iglo = boundaryCell%index + boundaryCell%model%moffset + jglo = connectedCell%index + connectedCell%model%moffset + call sparse%addconnection(iglo, jglo, 1) + call sparse%addconnection(jglo, iglo, 1) + end do + + ! and internal connections + call this%spatialcon_ac(sparse) + +end subroutine gwegwecon_ac + +subroutine gwegwecon_rp(this) + class(GweGweConnectionType) :: this !< the connection + + ! Call exchange rp routines + if (this%exchangeIsOwned) then + call this%gweExchange%exg_rp() + end if + +end subroutine gwegwecon_rp + + +!> @brief Advance this connection + !< +subroutine gwegwecon_ad(this) + class(GweGweConnectionType) :: this !< this connection + + ! copy model data into interface model + call this%syncInterfaceModel() + + ! recalculate dispersion ellipse + if (this%gweInterfaceModel%indsp > 0) call this%gweInterfaceModel%dsp%dsp_ad() + + if (this%exchangeIsOwned) then + call this%gweExchange%exg_ad() + end if + +end subroutine gwegwecon_ad + + +subroutine gwegwecon_cf(this, kiter) + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(in) :: kiter !< the iteration counter + ! local + integer(I4B) :: i + + ! copy model data into interface model + ! (when kiter == 1, this is already done in _ad) + if (kiter > 1) call this%syncInterfaceModel() + + ! reset interface system + do i = 1, this%nja + this%amat(i) = 0.0_DP + end do + do i = 1, this%neq + this%rhs(i) = 0.0_DP + end do + + call this%gweInterfaceModel%model_cf(kiter) + +end subroutine gwegwecon_cf + + +!> @brief called during advance (*_ad), to copy the data +!! from the models into the connection's placeholder arrays +!< +subroutine syncInterfaceModel(this) + class(GweGweConnectionType) :: this !< the connection + ! local + integer(I4B) :: i, n, m, ipos, iposLoc, idx + type(ConnectionsType), pointer :: imCon !< interface model connections + type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell + type(GlobalCellType), pointer :: boundaryCell, connectedCell + class(GweModelType), pointer :: gweModel + class(*), pointer :: modelPtr + + ! for readability + imCon => this%gweInterfaceModel%dis%con + toGlobal => this%gridConnection%idxToGlobal + + ! loop over connections in interface + do n = 1, this%neq + do ipos = imCon%ia(n) + 1, imCon%ia(n+1) - 1 + m = imCon%ja(ipos) + if (associated(toGlobal(n)%model, toGlobal(m)%model)) then + ! internal connection for a model, copy from its flowja + iposLoc = getCSRIndex(toGlobal(n)%index, toGlobal(m)%index, & + toGlobal(n)%model%ia, toGlobal(n)%model%ja) + modelPtr => toGlobal(n)%model + gweModel => CastAsGweModel(modelPtr) + this%gwfflowja(ipos) = gweModel%fmi%gwfflowja(iposLoc) + end if + end do + end do + + ! the flowja for exchange cells + do i = 1, this%gridConnection%nrOfBoundaryCells + boundaryCell => this%gridConnection%boundaryCells(i)%cell + connectedCell => this%gridConnection%connectedCells(i)%cell + n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & + boundaryCell%model) + m = this%gridConnection%getInterfaceIndex(connectedCell%index, & + connectedCell%model) + ipos = getCSRIndex(n, m, imCon%ia, imCon%ja) + this%gwfflowja(ipos) = this%exgflowja(i) * this%exgflowSign + ipos = getCSRIndex(m, n, imCon%ia, imCon%ja) + this%gwfflowja(ipos) = -this%exgflowja(i) * this%exgflowSign + end do + + ! copy concentrations + do i = 1, this%gridConnection%nrOfCells + idx = this%gridConnection%idxToGlobal(i)%index + this%x(i) = this%gridConnection%idxToGlobal(i)%model%x(idx) + this%gweInterfaceModel%xold(i) = this%gridConnection%idxToGlobal(i)%model%xold(idx) + end do + + ! copy fmi + do i = 1, this%gridConnection%nrOfCells + idx = this%gridConnection%idxToGlobal(i)%index + modelPtr => this%gridConnection%idxToGlobal(i)%model + gweModel => CastAsGweModel(modelPtr) + + this%gwfsat(i) = gweModel%fmi%gwfsat(idx) + this%gwfhead(i) = gweModel%fmi%gwfhead(idx) + this%gwfspdis(1, i) = gweModel%fmi%gwfspdis(1, idx) + this%gwfspdis(2, i) = gweModel%fmi%gwfspdis(2, idx) + this%gwfspdis(3, i) = gweModel%fmi%gwfspdis(3, idx) + end do + +end subroutine syncInterfaceModel + + +subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(in) :: kiter !< the iteration counter + integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array + real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients + real(DP), dimension(:), intent(inout) ::rhssln !< global right-hand-side + integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag + ! local + integer(I4B) :: n, nglo, ipos + + call this%gweInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) + + ! map back to solution matrix + do n = 1, this%neq + ! We only need the coefficients for our own model + ! (i.e. rows in the matrix that belong to this%owner): + if (.not. associated(this%gridConnection%idxToGlobal(n)%model, this%owner)) then + cycle + end if + + nglo = this%gridConnection%idxToGlobal(n)%index + this%gridConnection%idxToGlobal(n)%model%moffset + rhssln(nglo) = rhssln(nglo) + this%rhs(n) + + do ipos = this%ia(n), this%ia(n+1) - 1 + amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + this%amat(ipos) + end do + end do + + ! FC the movers through the exchange; we can call + ! exg_fc() directly because it only handles mover terms (unlike in GwfExchange%exg_fc) + if (this%exchangeIsOwned) then + call this%gweExchange%exg_fc(kiter, iasln, amatsln, rhssln, inwtflag) + end if + +end subroutine gwegwecon_fc + +subroutine gwegwecon_cq(this, icnvg, isuppress_output, isolnid) + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id + + call this%gweInterfaceModel%model_cq(icnvg, isuppress_output) + call this%setFlowToExchange() + +end subroutine gwegwecon_cq + + !> @brief Set the flows (flowja from interface model) to the + !< simvals in the exchange, leaving the budget calcution in there + subroutine setFlowToExchange(this) + class(GweGweConnectionType) :: this !< this connection + ! local + integer(I4B) :: i + integer(I4B) :: nIface, mIface, ipos + class(GweExchangeType), pointer :: gweEx + + gweEx => this%gweExchange + if (this%exchangeIsOwned) then + do i = 1, gweEx%nexg + gweEx%simvals(i) = DZERO + + if (gweEx%gwemodel1%ibound(gweEx%nodem1(i)) /= 0 .and. & + gweEx%gwemodel2%ibound(gweEx%nodem2(i)) /= 0) then + + nIface = this%gridConnection%getInterfaceIndex(gweEx%nodem1(i), gweEx%model1) + mIface = this%gridConnection%getInterfaceIndex(gweEx%nodem2(i), gweEx%model2) + ipos = getCSRIndex(nIface, mIface, this%gweInterfaceModel%ia, this%gweInterfaceModel%ja) + gweEx%simvals(i) = this%gweInterfaceModel%flowja(ipos) + + end if + end do + end if + + end subroutine setFlowToExchange + +subroutine gwegwecon_bd(this, icnvg, isuppress_output, isolnid) + use BudgetModule, only: rate_accumulator + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id + + ! call exchange budget routine, also calls bd + ! for movers. + if (this%exchangeIsOwned) then + call this%gweExchange%exg_bd(icnvg, isuppress_output, isolnid) + end if + +end subroutine gwegwecon_bd + +subroutine gwegwecon_ot(this) + class(GweGweConnectionType) :: this !< the connection + + ! Call exg_ot() here as it handles all output processing + ! based on gweExchange%simvals(:), which was correctly + ! filled from gwegwecon + if (this%exchangeIsOwned) then + call this%gweExchange%exg_ot() + end if + +end subroutine gwegwecon_ot + +subroutine gwegwecon_da(this) + class(GweGweConnectionType) :: this !< the connection + ! local + logical(LGP) :: isOpen + + ! scalars + call mem_deallocate(this%iIfaceAdvScheme) + call mem_deallocate(this%iIfaceXt3d) + call mem_deallocate(this%exgflowSign) + + ! arrays + call mem_deallocate(this%gwfflowja) + call mem_deallocate(this%gwfsat) + call mem_deallocate(this%gwfhead) + call mem_deallocate(this%gwfspdis) + call mem_deallocate(this%exgflowjaGwt) + + ! interface model + call this%gweInterfaceModel%model_da() + deallocate(this%gweInterfaceModel) + + ! dealloc base + call this%spatialcon_da() + + inquire(this%iout, opened=isOpen) + if (isOpen) then + close(this%iout) + end if + + ! we need to deallocate the exchange we own: + if (this%exchangeIsOwned) then + call this%gweExchange%exg_da() + end if + +end subroutine gwegwecon_da + +!> @brief Cast to GweGweConnectionType +!< +function CastAsGweGweConnection(obj) result (res) + implicit none + class(*), pointer, intent(inout) :: obj !< object to be cast + class(GweGweConnectionType), pointer :: res !< the GweGweConnection + + res => null() + if (.not. associated(obj)) return + + select type (obj) + class is (GweGweConnectionType) + res => obj + end select + return +end function CastAsGweGweConnection + +end module \ No newline at end of file diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 new file mode 100644 index 00000000000..729312993e2 --- /dev/null +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -0,0 +1,239 @@ +module GweInterfaceModelModule + use KindModule, only: I4B, DP + use MemoryManagerModule, only: mem_allocate, mem_deallocate + use MemoryHelperModule, only: create_mem_path + use NumericalModelModule, only: NumericalModelType + use GweModule, only: GweModelType, CastAsGweModel + use GwfDisuModule, only: disu_cr, CastAsDisuType + use TspFmiModule, only: fmi_cr, TspFmiType + use TspAdvModule, only: adv_cr, TspAdvType + use TspAdvOptionsModule, only: TspAdvOptionsType + use GweDspModule, only: dsp_cr, GweDspType + use TspDspOptionsModule, only: TspDspOptionsType + use TspDspGridDataModule, only: TspDspGridDataType + use TspObsModule, only: tsp_obs_cr + use GridConnectionModule + + implicit none + private + + !> The GWE Interface Model is a utility to calculate the solution's + !! exchange coefficients from the interface between a GWE model and + !! its GWE neighbors. The interface model itself will not be part + !! of the solution, it is not being solved. + type, public, extends(GweModelType) :: GweInterfaceModelType + + integer(i4B), pointer :: iAdvScheme => null() !< the advection scheme: 0 = up, 1 = central, 2 = tvd + integer(i4B), pointer :: ixt3d => null() !< xt3d setting: 0 = off, 1 = lhs, 2 = rhs + + class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid + class(GweModelType), private, pointer :: owner => null() !< the real GWE model for which the exchange coefficients + !! are calculated with this interface model + + real(DP), dimension(:), pointer, contiguous :: porosity => null() !< to be filled with MST porosity + + contains + procedure, pass(this) :: gweifmod_cr + procedure :: model_df => gweifmod_df + procedure :: model_ar => gweifmod_ar + procedure :: model_da => gweifmod_da + procedure :: allocate_scalars + procedure :: setDspGridData + end type GweInterfaceModelType + +contains + +!> @brief Create the interface model, analogously to what +!< happens in gwe_cr +subroutine gweifmod_cr(this, name, iout, gridConn) + class(GweInterfaceModelType) :: this !< the GWE interface model + character(len=*), intent(in) :: name !< the interface model's name + integer(I4B), intent(in) :: iout !< the output unit + class(GridConnectionType), pointer, intent(in) :: gridConn !< the grid connection data for creating a DISU + ! local + class(*), pointer :: modelPtr + integer(I4B), target :: inobs + integer(I4B) :: adv_unit, dsp_unit + + this%memoryPath = create_mem_path(name) + call this%allocate_scalars(name) + + ! defaults + this%iAdvScheme = 0 + this%ixt3d = 0 + + this%iout = iout + this%gridConnection => gridConn + modelPtr => gridConn%model + this%owner => CastAsGweModel(modelPtr) + + inobs = 0 + adv_unit = 0 + dsp_unit = 0 + if (this%owner%inadv > 0) then + this%inadv = huge(1_I4B) + adv_unit = huge(1_I4B) + end if + if (this%owner%indsp > 0) then + this%indsp = huge(1_I4B) + dsp_unit = huge(1_I4B) + end if + + ! create dis and packages + call disu_cr(this%dis, this%name, -1, this%iout) + call fmi_cr(this%fmi, this%name, 0, this%iout) + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) + call tsp_obs_cr(this%obs, inobs) + +end subroutine gweifmod_cr + +subroutine allocate_scalars(this, modelname) + class(GweInterfaceModelType) :: this !< the GWE interface model + character(len=*), intent(in) :: modelname !< the model name + + call this%GweModelType%allocate_scalars(modelname) + + call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) + call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + +end subroutine allocate_scalars + +!> @brief Define the GWE interface model +!< +subroutine gweifmod_df(this) + class(GweInterfaceModelType) :: this !< the GWE interface model + ! local + class(*), pointer :: disPtr + type(TspAdvOptionsType) :: adv_options + type(TspDspOptionsType) :: dsp_options + integer(I4B) :: i + + this%moffset = 0 + adv_options%iAdvScheme = this%iAdvScheme + dsp_options%ixt3d = this%ixt3d + + ! define DISU + disPtr => this%dis + call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) + call this%fmi%fmi_df(this%dis, 0) + + if (this%inadv > 0) then + call this%adv%adv_df(adv_options) + end if + if (this%indsp > 0) then + call this%dsp%dsp_df(this%dis, dsp_options) + end if + + ! assign or point model members to dis members + this%neq = this%dis%nodes + this%nja = this%dis%nja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja + ! + ! allocate model arrays, now that neq and nja are assigned + call this%allocate_arrays() + call mem_allocate(this%porosity, this%neq, 'POROSITY', this%memoryPath) + + do i = 1, size(this%flowja) + this%flowja = 0.0_DP + end do + do i = 1, this%neq + this%porosity = 0.0_DP + end do + +end subroutine gweifmod_df + + +!> @brief Override allocate and read the GWE interface model and its +!! packages so that we can create stuff from memory instead of input +!< files +subroutine gweifmod_ar(this) + class(GweInterfaceModelType) :: this !< the GWE interface model + ! local + type(TspDspGridDataType) :: dspGridData + + call this%fmi%fmi_ar(this%ibound) + if (this%inadv > 0) then + call this%adv%adv_ar(this%dis, this%ibound) + end if + if (this%indsp > 0) then + this%dsp%idiffc = this%owner%dsp%idiffc + this%dsp%idisp = this%owner%dsp%idisp + call dspGridData%construct(this%neq) + call this%setDspGridData(dspGridData) + call this%dsp%dsp_ar(this%ibound, this%porosity, this%dsp%cpw, this%dsp%rhow, dspGridData) + end if + +end subroutine gweifmod_ar + + +!> @brief set dsp grid data from models +!< +subroutine setDspGridData(this, gridData) + class(GweInterfaceModelType) :: this !< the GWE interface model + type(TspDspGridDataType) :: gridData !< the dsp grid data to be set + ! local + integer(I4B) :: i, idx + class(GweModelType), pointer :: gweModel + class(*), pointer :: modelPtr + + do i = 1, this%neq + modelPtr => this%gridConnection%idxToGlobal(i)%model + gweModel => CastAsGweModel(modelPtr) + idx = this%gridConnection%idxToGlobal(i)%index + + if (this%dsp%idiffc > 0) then + gridData%diffc(i) = gweModel%dsp%diffc(idx) + end if + if (this%dsp%idisp > 0) then + gridData%alh(i) = gweModel%dsp%alh(idx) + gridData%alv(i) = gweModel%dsp%alv(idx) + gridData%ath1(i) = gweModel%dsp%ath1(idx) + gridData%ath2(i) = gweModel%dsp%ath2(idx) + gridData%atv(i) = gweModel%dsp%atv(idx) + end if + + end do + +end subroutine setDspGridData + +!> @brief Clean up resources +!< +subroutine gweifmod_da(this) + class(GweInterfaceModelType) :: this !< the GWE interface model + + ! this + call mem_deallocate(this%iAdvScheme) + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%porosity) + + ! gwe packages + call this%dis%dis_da() + call this%fmi%fmi_da() + call this%adv%adv_da() + call this%dsp%dsp_da() + + deallocate(this%dis) + deallocate(this%fmi) + deallocate(this%adv) + deallocate(this%dsp) + + ! gwe scalars + call mem_deallocate(this%inic) + call mem_deallocate(this%infmi) + call mem_deallocate(this%inadv) + call mem_deallocate(this%indsp) + call mem_deallocate(this%inssm) + call mem_deallocate(this%inmst) + call mem_deallocate(this%inmvt) + call mem_deallocate(this%inoc) + call mem_deallocate(this%inobs) + + ! base + call this%NumericalModelType%model_da() + +end subroutine gweifmod_da + + +end module GweInterfaceModelModule \ No newline at end of file diff --git a/src/Model/Connection/GwfGwfConnection.f90 b/src/Model/Connection/GwfGwfConnection.f90 index 90a0c70db6f..b79ed15375a 100644 --- a/src/Model/Connection/GwfGwfConnection.f90 +++ b/src/Model/Connection/GwfGwfConnection.f90 @@ -1,51 +1,51 @@ module GwfGwfConnectionModule use KindModule, only: I4B, DP, LGP - use ConstantsModule, only: DZERO, DONE, DEM6, LENCOMPONENTNAME, LINELENGTH + use ConstantsModule, only: DZERO, DONE, DEM6, LENCOMPONENTNAME, LINELENGTH use CsrUtilsModule, only: getCSRIndex - use SparseModule, only:sparsematrix + use SparseModule, only: sparsematrix use MemoryManagerModule, only: mem_allocate, mem_deallocate use SimModule, only: ustop - use SpatialModelConnectionModule + use SpatialModelConnectionModule use GwfInterfaceModelModule use NumericalModelModule use GwfModule, only: GwfModelType, CastAsGwfModel use DisConnExchangeModule - use GwfGwfExchangeModule, only: GwfExchangeType, GetGwfExchangeFromList, & + use GwfGwfExchangeModule, only: GwfExchangeType, GetGwfExchangeFromList, & CastAsGwfExchange use GwfNpfModule, only: GwfNpfType, hcond, vcond use GwfBuyModule, only: GwfBuyType use BaseDisModule, only: DisBaseType use ConnectionsModule, only: ConnectionsType use CellWithNbrsModule, only: GlobalCellType - + implicit none private public :: CastAsGwfGwfConnection - !> Connecting a GWF model to other models in space, implements - !! NumericalExchangeType so the solution can used this object to determine + !> Connecting a GWF model to other models in space, implements + !! NumericalExchangeType so the solution can used this object to determine !! the coefficients for the coupling between two adjacent models. !< type, public, extends(SpatialModelConnectionType) :: GwfGwfConnectionType - type(GwfModelType), pointer :: gwfModel => null() !< the model for which this connection exists - type(GwfExchangeType), pointer :: gwfExchange => null() !< the primary exchange, cast to its concrete type - logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, - !! one of them needs to manage/own the exchange (e.g. clean up) - type(GwfInterfaceModelType), pointer :: gwfInterfaceModel => null() !< the interface model - integer(I4B), pointer :: iXt3dOnExchange => null() !< run XT3D on the interface, - !! 0 = don't, 1 = matrix, 2 = rhs - integer(I4B) :: iout = 0 !< the list file for the interface model - - real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< flowja through exchange faces - - contains + type(GwfModelType), pointer :: gwfModel => null() !< the model for which this connection exists + type(GwfExchangeType), pointer :: gwfExchange => null() !< the primary exchange, cast to its concrete type + logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, + !! one of them needs to manage/own the exchange (e.g. clean up) + type(GwfInterfaceModelType), pointer :: gwfInterfaceModel => null() !< the interface model + integer(I4B), pointer :: iXt3dOnExchange => null() !< run XT3D on the interface, + !! 0 = don't, 1 = matrix, 2 = rhs + integer(I4B) :: iout = 0 !< the list file for the interface model + + real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< flowja through exchange faces + + contains procedure, pass(this) :: gwfGwfConnection_ctor generic, public :: construct => gwfGwfConnection_ctor - + ! overriding NumericalExchangeType - procedure :: exg_df => gwfgwfcon_df + procedure :: exg_df => gwfgwfcon_df procedure :: exg_ar => gwfgwfcon_ar procedure :: exg_rp => gwfgwfcon_rp procedure :: exg_ad => gwfgwfcon_ad @@ -58,7 +58,7 @@ module GwfGwfConnectionModule ! overriding 'protected' procedure, pass(this) :: validateConnection - + ! local stuff procedure, pass(this), private :: allocateScalars procedure, pass(this), private :: allocate_arrays @@ -68,20 +68,20 @@ module GwfGwfConnectionModule procedure, pass(this), private :: setFlowToExchange procedure, pass(this), private :: saveExchangeFlows procedure, pass(this), private :: setNpfEdgeProps - + end type GwfGwfConnectionType contains - + !> @brief Basic construction of the connection !< subroutine gwfGwfConnection_ctor(this, model, gwfEx) use NumericalModelModule, only: NumericalModelType use InputOutputModule, only: openfile - class(GwfGwfConnectionType) :: this !< the connection - class(NumericalModelType), pointer :: model !< the model owning this connection, - !! this must of course be a GwfModelType - class(DisConnExchangeType), pointer :: gwfEx !< the exchange the interface model is created for + class(GwfGwfConnectionType) :: this !< the connection + class(NumericalModelType), pointer :: model !< the model owning this connection, + !! this must of course be a GwfModelType + class(DisConnExchangeType), pointer :: gwfEx !< the exchange the interface model is created for ! local character(len=LINELENGTH) :: fname character(len=LENCOMPONENTNAME) :: name @@ -94,58 +94,60 @@ subroutine gwfGwfConnection_ctor(this, model, gwfEx) this%gwfExchange => CastAsGwfExchange(objPtr) this%exchangeIsOwned = associated(gwfEx%model1, model) - + if (this%exchangeIsOwned) then - write(name,'(a,i0)') 'GWFCON1_', gwfEx%id + write (name, '(a,i0)') 'GWFCON1_', gwfEx%id else - write(name,'(a,i0)') 'GWFCON2_', gwfEx%id + write (name, '(a,i0)') 'GWFCON2_', gwfEx%id end if ! .lst file for interface model if (write_ifmodel_listfile) then fname = trim(name)//'.im.lst' call openfile(this%iout, 0, fname, 'LIST', filstat_opt='REPLACE') - write(this%iout, '(4a)') 'Creating GWF-GWF connection for model ', & - trim(this%gwfModel%name), ' from exchange ', & - trim(gwfEx%name) + write (this%iout, '(4a)') 'Creating GWF-GWF connection for model ', & + trim(this%gwfModel%name), ' from exchange ', & + trim(gwfEx%name) end if - + ! first call base constructor - call this%SpatialModelConnectionType%spatialConnection_ctor(model, gwfEx, name) - + call this%SpatialModelConnectionType%spatialConnection_ctor(model, & + gwfEx, & + name) + call this%allocateScalars() - + this%typename = 'GWF-GWF' this%iXt3dOnExchange = 0 - - allocate(this%gwfInterfaceModel) + + allocate (this%gwfInterfaceModel) this%interfaceModel => this%gwfInterfaceModel - + end subroutine gwfGwfConnection_ctor - + !> @brief Define the connection - !! - !! This sets up the GridConnection (for creating the - !! interface grid), creates and defines the interface + !! + !! This sets up the GridConnection (for creating the + !! interface grid), creates and defines the interface !< model subroutine gwfgwfcon_df(this) - class(GwfGwfConnectionType) :: this !< this connection + class(GwfGwfConnectionType) :: this !< this connection ! local - character(len=LENCOMPONENTNAME) :: imName !< the interface model's name + character(len=LENCOMPONENTNAME) :: imName !< the interface model's name ! determine the required size of the interface grid call this%setGridExtent() - ! this sets up the GridConnection + ! this sets up the GridConnection call this%spatialcon_df() - + ! Now grid conn is defined, we create the interface model ! here, and the remainder of this routine is define. ! we basically follow the logic that is present in sln_df() - if(this%exchangeIsOwned) then - write(imName,'(a,i0)') 'GWFIM1_', this%gwfExchange%id + if (this%exchangeIsOwned) then + write (imName, '(a,i0)') 'GWFIM1_', this%gwfExchange%id else - write(imName,'(a,i0)') 'GWFIM2_', this%gwfExchange%id + write (imName, '(a,i0)') 'GWFIM2_', this%gwfExchange%id end if call this%gwfInterfaceModel%gwfifm_cr(imName, this%iout, this%gridConnection) @@ -160,7 +162,7 @@ subroutine gwfgwfcon_df(this) call this%spatialcon_connect() call this%allocate_arrays() - + end subroutine gwfgwfcon_df !> @brief Set the required size of the interface grid from @@ -169,7 +171,7 @@ subroutine setGridExtent(this) class(GwfGwfConnectionType) :: this !< the connection ! local - this%iXt3dOnExchange = this%gwfExchange%ixt3d + this%iXt3dOnExchange = this%gwfExchange%ixt3d if (this%iXt3dOnExchange > 0) then this%exchangeStencilDepth = 2 if (this%gwfModel%npf%ixt3d > 0) then @@ -178,7 +180,7 @@ subroutine setGridExtent(this) end if end subroutine setGridExtent - + !> @brief allocation of scalars in the connection !< subroutine allocateScalars(this) @@ -198,26 +200,26 @@ subroutine allocate_arrays(this) ! local integer(I4B) :: i - call mem_allocate(this%exgflowja, this%gridConnection%nrOfBoundaryCells, & + call mem_allocate(this%exgflowja, this%gridConnection%nrOfBoundaryCells, & 'EXGFLOWJA', this%memoryPath) do i = 1, size(this%exgflowja) this%exgflowja(i) = 0.0_DP end do end subroutine allocate_arrays - + !> @brief Allocate and read the connection !< subroutine gwfgwfcon_ar(this) - use GridConnectionModule, only: GridConnectionType + use GridConnectionModule, only: GridConnectionType class(GwfGwfConnectionType) :: this !< this connection - ! local + ! local ! check if we can construct an interface model ! NB: only makes sense after the models' allocate&read have been ! called, which is why we do it here call this%validateConnection() - + ! allocate and read base call this%spatialcon_ar() @@ -240,7 +242,7 @@ end subroutine gwfgwfcon_ar !< subroutine gwfgwfcon_rp(this) class(GwfGwfConnectionType) :: this !< this connection - + ! Call exchange rp routines if (this%exchangeIsOwned) then call this%gwfExchange%exg_rp() @@ -259,7 +261,7 @@ subroutine gwfgwfcon_ad(this) ! this triggers the BUY density calculation if (this%gwfInterfaceModel%inbuy > 0) call this%gwfInterfaceModel%buy%buy_ad() - + if (this%exchangeIsOwned) then call this%gwfExchange%exg_ad() end if @@ -271,10 +273,10 @@ end subroutine gwfgwfcon_ad !< by the connection of a GWF model with its neigbors subroutine gwfgwfcon_cf(this, kiter) class(GwfGwfConnectionType) :: this !< this connection - integer(I4B), intent(in) :: kiter !< the iteration counter + integer(I4B), intent(in) :: kiter !< the iteration counter ! local integer(I4B) :: i - + ! reset interface system do i = 1, this%nja this%amat(i) = 0.0_DP @@ -282,16 +284,16 @@ subroutine gwfgwfcon_cf(this, kiter) do i = 1, this%neq this%rhs(i) = 0.0_DP end do - + ! copy model data into interface model ! (when kiter == 1, this is already done in _ad) if (kiter > 1) call this%syncInterfaceModel() ! calculate (wetting/drying, saturation) call this%gwfInterfaceModel%model_cf(kiter) - + end subroutine gwfgwfcon_cf - + !> @brief Synchronize the interface model !! Fills interface model data from the !! contributing GWF models, at the iteration @@ -301,49 +303,52 @@ subroutine syncInterfaceModel(this) ! local integer(I4B) :: icell, idx class(NumericalModelType), pointer :: model - + ! copy head values - do icell = 1, this%gridConnection%nrOfCells + do icell = 1, this%gridConnection%nrOfCells idx = this%gridConnection%idxToGlobal(icell)%index model => this%gridConnection%idxToGlobal(icell)%model - + this%x(icell) = model%x(idx) this%gwfInterfaceModel%ibound(icell) = model%ibound(idx) this%gwfInterfaceModel%xold(icell) = model%xold(idx) end do - + end subroutine syncInterfaceModel - - !> @brief Write the calculated coefficients into the global + + !> @brief Write the calculated coefficients into the global !< system matrix and the rhs subroutine gwfgwfcon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) - class(GwfGwfConnectionType) :: this !< this connection - integer(I4B), intent(in) :: kiter !< the iteration counter - integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array - real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients - real(DP), dimension(:), intent(inout) ::rhssln !< global right-hand-side - integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag + class(GwfGwfConnectionType) :: this !< this connection + integer(I4B), intent(in) :: kiter !< the iteration counter + integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array + real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients + real(DP), dimension(:), intent(inout) :: rhssln !< global right-hand-side + integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag ! local integer(I4B) :: n, ipos, nglo - + ! fill (and add to...) coefficients for interface call this%gwfInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) - + ! map back to solution matrix do n = 1, this%neq ! we cannot check with the mask here, because cross-terms are not ! necessarily from primary connections. But, we only need the coefficients ! for our own model (i.e. fluxes into cells belonging to this%owner): - if (.not. associated(this%gridConnection%idxToGlobal(n)%model, this%owner)) then + if (.not. associated(this%gridConnection%idxToGlobal(n)%model, & + this%owner)) then ! only add connections for own model to global matrix cycle end if - - nglo = this%gridConnection%idxToGlobal(n)%index + this%gridConnection%idxToGlobal(n)%model%moffset + + nglo = this%gridConnection%idxToGlobal(n)%index + & + this%gridConnection%idxToGlobal(n)%model%moffset rhssln(nglo) = rhssln(nglo) + this%rhs(n) - - do ipos = this%ia(n), this%ia(n+1) - 1 - amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + this%amat(ipos) + + do ipos = this%ia(n), this%ia(n + 1) - 1 + amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + & + this%amat(ipos) end do end do @@ -358,7 +363,7 @@ subroutine gwfgwfcon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) end subroutine gwfgwfcon_fc !> @brief Validate this connection - !! This is called before proceeding to construct + !! This is called before proceeding to construct !! the interface model !< subroutine validateConnection(this) @@ -366,14 +371,14 @@ subroutine validateConnection(this) use SimModule, only: count_errors class(GwfGwfConnectionType) :: this !< this connection ! local - + ! base validation (geometry/spatial) call this%SpatialModelConnectionType%validateConnection() call this%validateGwfExchange() ! abort on errors - if(count_errors() > 0) then - write(errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' call ustop() end if @@ -389,7 +394,7 @@ subroutine validateGwfExchange(this) use SimVariablesModule, only: errmsg use SimModule, only: store_error use GwfNpfModule, only: GwfNpfType - class(GwfGwfConnectionType) :: this !< this connection + class(GwfGwfConnectionType) :: this !< this connection ! local class(GwfExchangeType), pointer :: gwfEx class(*), pointer :: modelPtr @@ -406,18 +411,18 @@ subroutine validateGwfExchange(this) ! GNC not allowed if (gwfEx%ingnc /= 0) then - write(errmsg, '(1x,2a)') 'Ghost node correction not supported '// & - 'with interface model for exchange', & - trim(gwfEx%name) + write (errmsg, '(1x,2a)') 'Ghost node correction not supported '// & + 'with interface model for exchange', & + trim(gwfEx%name) call store_error(errmsg) end if - if ((gwfModel1%inbuy > 0 .and. gwfModel2%inbuy == 0) .or. & + if ((gwfModel1%inbuy > 0 .and. gwfModel2%inbuy == 0) .or. & (gwfModel1%inbuy == 0 .and. gwfModel2%inbuy > 0)) then - write(errmsg, '(1x,2a)') 'Buoyancy package should be enabled/disabled '// & - 'simultaneously in models connected with the '// & - 'interface model for exchange ', & - trim(gwfEx%name) + write (errmsg, '(1x,2a)') 'Buoyancy package should be enabled/disabled '// & + 'simultaneously in models connected with the '// & + 'interface model for exchange ', & + trim(gwfEx%name) call store_error(errmsg) end if @@ -425,10 +430,10 @@ subroutine validateGwfExchange(this) if (gwfModel1%inbuy > 0 .and. gwfModel2%inbuy > 0) then ! does not work with XT3D if (this%iXt3dOnExchange > 0) then - write(errmsg, '(1x,2a)') 'Connecting models with BUY package not '// & - 'allowed with XT3D enabled on exchange ', & - trim(gwfEx%name) - call store_error(errmsg) + write (errmsg, '(1x,2a)') 'Connecting models with BUY package not '// & + 'allowed with XT3D enabled on exchange ', & + trim(gwfEx%name) + call store_error(errmsg) end if ! check compatibility of buoyancy @@ -445,12 +450,12 @@ subroutine validateGwfExchange(this) end if if (.not. compatible) then - write(errmsg, '(1x,6a)') 'Buoyancy packages in model ', & - trim(gwfEx%model1%name), ' and ', & - trim(gwfEx%model2%name), & - ' should be equivalent to construct an '// & - ' interface model for exchange ', & - trim(gwfEx%name) + write (errmsg, '(1x,6a)') 'Buoyancy packages in model ', & + trim(gwfEx%model1%name), ' and ', & + trim(gwfEx%model2%name), & + ' should be equivalent to construct an '// & + ' interface model for exchange ', & + trim(gwfEx%name) call store_error(errmsg) end if @@ -460,7 +465,7 @@ end subroutine validateGwfExchange !> @brief Deallocate all resources !< - subroutine gwfgwfcon_da(this) + subroutine gwfgwfcon_da(this) use KindModule, only: LGP class(GwfGwfConnectionType) :: this !< this connection ! local @@ -471,22 +476,22 @@ subroutine gwfgwfcon_da(this) ! arrays call mem_deallocate(this%exgflowja) - + call this%gwfInterfaceModel%model_da() - deallocate(this%gwfInterfaceModel) - + deallocate (this%gwfInterfaceModel) + call this%spatialcon_da() - inquire(this%iout, opened=isOpen) + inquire (this%iout, opened=isOpen) if (isOpen) then - close(this%iout) + close (this%iout) end if ! we need to deallocate the baseexchange we own: if (this%exchangeIsOwned) then call this%gwfExchange%exg_da() end if - + end subroutine gwfgwfcon_da !> @brief Calculate intra-cell flows @@ -494,12 +499,12 @@ end subroutine gwfgwfcon_da !! model, and then mapped back to real-world cell ids. !< subroutine gwfgwfcon_cq(this, icnvg, isuppress_output, isolnid) - class(GwfGwfConnectionType) :: this !< this connection - integer(I4B), intent(inout) :: icnvg !< convergence flag + class(GwfGwfConnectionType) :: this !< this connection + integer(I4B), intent(inout) :: icnvg !< convergence flag integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 - integer(I4B), intent(in) :: isolnid !< solution id - - call this%gwfInterfaceModel%model_cq(icnvg, isuppress_output) + integer(I4B), intent(in) :: isolnid !< solution id + + call this%gwfInterfaceModel%model_cq(icnvg, isuppress_output) call this%setFlowToExchange() @@ -509,7 +514,7 @@ subroutine gwfgwfcon_cq(this, icnvg, isuppress_output, isolnid) ! simvals? ! if needed, we add the edge properties to the model's NPF ! package for its spdis calculation: - if (this%gwfModel%npf%icalcspdis == 1) then + if (this%gwfModel%npf%icalcspdis == 1) then call this%setNpfEdgeProps() end if @@ -521,10 +526,9 @@ subroutine gwfgwfcon_cq(this, icnvg, isuppress_output, isolnid) call this%gwfExchange%gwf_gwf_add_to_flowja() end if - end subroutine gwfgwfcon_cq - !> @brief Set the flows (flowja from interface model) to the + !> @brief Set the flows (flowja from interface model) to the !< simvals in the exchange, leaving the budget calcution in there subroutine setFlowToExchange(this) class(GwfGwfConnectionType) :: this !< this connection @@ -534,16 +538,19 @@ subroutine setFlowToExchange(this) class(GwfExchangeType), pointer :: gwfEx gwfEx => this%gwfExchange - if (this%exchangeIsOwned) then + if (this%exchangeIsOwned) then do i = 1, gwfEx%nexg gwfEx%simvals(i) = DZERO - if (gwfEx%gwfmodel1%ibound(gwfEx%nodem1(i)) /= 0 .and. & + if (gwfEx%gwfmodel1%ibound(gwfEx%nodem1(i)) /= 0 .and. & gwfEx%gwfmodel2%ibound(gwfEx%nodem2(i)) /= 0) then - nIface = this%gridConnection%getInterfaceIndex(gwfEx%nodem1(i), gwfEx%model1) - mIface = this%gridConnection%getInterfaceIndex(gwfEx%nodem2(i), gwfEx%model2) - ipos = getCSRIndex(nIface, mIface, this%gwfInterfaceModel%ia, this%gwfInterfaceModel%ja) + nIface = this%gridConnection%getInterfaceIndex(gwfEx%nodem1(i), & + gwfEx%model1) + mIface = this%gridConnection%getInterfaceIndex(gwfEx%nodem2(i), & + gwfEx%model2) + ipos = getCSRIndex(nIface, mIface, this%gwfInterfaceModel%ia, & + this%gwfInterfaceModel%ja) gwfEx%simvals(i) = this%gwfInterfaceModel%flowja(ipos) end if @@ -563,11 +570,12 @@ subroutine saveExchangeFlows(this) do i = 1, this%gridConnection%nrOfBoundaryCells boundaryCell = this%gridConnection%boundaryCells(i)%cell connectedCell = this%gridConnection%connectedCells(i)%cell - n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & + n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & boundaryCell%model) - m = this%gridConnection%getInterfaceIndex(connectedCell%index, & + m = this%gridConnection%getInterfaceIndex(connectedCell%index, & connectedCell%model) - ipos = getCSRIndex(n, m, this%gwfInterfaceModel%ia, this%gwfInterfaceModel%ja) + ipos = getCSRIndex(n, m, this%gwfInterfaceModel%ia, & + this%gwfInterfaceModel%ja) this%exgflowja(i) = this%gwfInterfaceModel%flowja(ipos) end do @@ -590,9 +598,9 @@ subroutine setNpfEdgeProps(this) real(DP) :: dist real(DP) :: cl logical :: nozee - type(ConnectionsType), pointer :: imCon !< interface model connections - class(GwfNpfType), pointer :: imNpf !< interface model npf package - class(DisBaseType), pointer :: imDis !< interface model discretization + type(ConnectionsType), pointer :: imCon !< interface model connections + class(GwfNpfType), pointer :: imNpf !< interface model npf package + class(DisBaseType), pointer :: imDis !< interface model discretization type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell ! for readability @@ -617,26 +625,26 @@ subroutine setNpfEdgeProps(this) nLoc = toGlobal(n)%index - do ipos = imCon%ia(n)+1, imCon%ia(n+1) - 1 + do ipos = imCon%ia(n) + 1, imCon%ia(n + 1) - 1 if (imCon%mask(ipos) < 1) then ! skip this connection, it's masked so not determined by us cycle end if m = imCon%ja(ipos) - mLoc = toGlobal(m)%index + mLoc = toGlobal(m)%index if (.not. associated(toGlobal(m)%model, this%owner)) then ! boundary connection, set edge properties isym = imCon%jas(ipos) ihc = imCon%ihc(isym) - area = imCon%hwva(isym) + area = imCon%hwva(isym) satThick = imNpf%calcSatThickness(n, m, ihc) rrate = this%gwfInterfaceModel%flowja(ipos) - call imDis%connection_normal(n, m, ihc, nx, ny, nz, ipos) + call imDis%connection_normal(n, m, ihc, nx, ny, nz, ipos) call imDis%connection_vector(n, m, nozee, imNpf%sat(n), imNpf%sat(m), & - ihc, cx, cy, cz, conLen) + ihc, cx, cy, cz, conLen) if (ihc == 0) then ! check if n is below m @@ -650,8 +658,8 @@ subroutine setNpfEdgeProps(this) cl = imCon%cl2(isym) end if dist = conLen * cl / (imCon%cl1(isym) + imCon%cl2(isym)) - call this%gwfModel%npf%set_edge_properties(nLoc, ihc, rrate, area, & - nx, ny, dist) + call this%gwfModel%npf%set_edge_properties(nLoc, ihc, rrate, area, & + nx, ny, dist) else ! internal, need to set flowja for n-m ! TODO_MJR: should we mask the flowja calculation in the model? @@ -668,10 +676,10 @@ end subroutine setNpfEdgeProps !> @brief Calculate the budget terms for this connection, this is !! dispatched to the GWF-GWF exchange subroutine gwfgwfcon_bd(this, icnvg, isuppress_output, isolnid) - class(GwfGwfConnectionType) :: this !< this connection - integer(I4B), intent(inout) :: icnvg !< convergence flag - integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 - integer(I4B), intent(in) :: isolnid !< solution id + class(GwfGwfConnectionType) :: this !< this connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id ! local ! call exchange budget routine, also calls bd @@ -679,15 +687,15 @@ subroutine gwfgwfcon_bd(this, icnvg, isuppress_output, isolnid) if (this%exchangeIsOwned) then call this%gwfExchange%exg_bd(icnvg, isuppress_output, isolnid) end if - + end subroutine gwfgwfcon_bd !> @brief Write output for exchange (and calls !< save on the budget) subroutine gwfgwfcon_ot(this) - class(GwfGwfConnectionType) :: this !< this connection + class(GwfGwfConnectionType) :: this !< this connection ! local - + ! Call exg_ot() here as it handles all output processing ! based on gwfExchange%simvals(:), which was correctly ! filled from gwfgwfcon @@ -699,14 +707,14 @@ end subroutine gwfgwfcon_ot !> @brief Cast to GwfGwfConnectionType !< - function CastAsGwfGwfConnection(obj) result (res) + function CastAsGwfGwfConnection(obj) result(res) implicit none - class(*), pointer, intent(inout) :: obj !< object to be cast + class(*), pointer, intent(inout) :: obj !< object to be cast class(GwfGwfConnectionType), pointer :: res !< the GwfGwfConnection - + res => null() if (.not. associated(obj)) return - + select type (obj) class is (GwfGwfConnectionType) res => obj diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index 1fa930292dd..a0361c4b0f4 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -1,6 +1,6 @@ module GwfInterfaceModelModule use KindModule, only: I4B, DP - use ConstantsModule, only: DZERO + use ConstantsModule, only: DZERO use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path use NumericalModelModule, only: NumericalModelType, GetNumericalModelFromList @@ -19,65 +19,65 @@ module GwfInterfaceModelModule private !> The GWF Interface Model is a utility to calculate the solution's - !! exchange coefficients from the interface between a GWF model and - !! its GWF neighbors. The interface model itself will not be part - !! of the solution, it is not being solved. + !! exchange coefficients from the interface between a GWF model and + !! its GWF neighbors. The interface model itself will not be part + !! of the solution, it is not being solved. !! Patching (a part of the) discretizations of two GWF models in a - !! general way, e.g. DIS+DIS with refinement, requires the resulting + !! general way, e.g. DIS+DIS with refinement, requires the resulting !< discretization to be of type DISU. type, public, extends(GwfModelType) :: GwfInterfaceModelType - class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid - class(GwfModelType), private, pointer :: owner => null() !< the real GWF model for which the exchange coefficients - !! are calculated with this interface model + class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid + class(GwfModelType), private, pointer :: owner => null() !< the real GWF model for which the exchange coefficients + !! are calculated with this interface model contains procedure, pass(this) :: gwfifm_cr procedure :: model_df => gwfifm_df procedure :: model_ar => gwfifm_ar - procedure :: model_da => gwfifm_da + procedure :: model_da => gwfifm_da ! private procedure, private, pass(this) :: setNpfOptions procedure, private, pass(this) :: setNpfGridData procedure, private, pass(this) :: setBuyData end type - + contains - - !> @brief set up the interface model, analogously to what + + !> @brief set up the interface model, analogously to what !< happens in gwf_cr subroutine gwfifm_cr(this, name, iout, gridConn) - class(GwfInterfaceModelType) :: this !< the GWF interface model - character(len=*), intent(in) :: name !< the interface model's name - integer(I4B), intent(in) :: iout !< the output unit + class(GwfInterfaceModelType) :: this !< the GWF interface model + character(len=*), intent(in) :: name !< the interface model's name + integer(I4B), intent(in) :: iout !< the output unit class(GridConnectionType), pointer, intent(in) :: gridConn !< the grid connection for creating a DISU ! local class(*), pointer :: modPtr - + this%memoryPath = create_mem_path(name) call this%allocate_scalars(name) - - this%iout = iout + + this%iout = iout this%gridConnection => gridConn modPtr => this%gridConnection%model this%owner => CastAsGwfModel(modPtr) - + this%innpf = huge(1_I4B) this%inewton = this%owner%inewton this%inewtonur = this%owner%inewtonur - + if (this%owner%inbuy > 0) then this%inbuy = huge(1_I4B) end if - + ! create discretization and packages call disu_cr(this%dis, this%name, -1, this%iout) call npf_cr(this%npf, this%name, this%innpf, this%iout) call xt3d_cr(this%xt3d, this%name, this%innpf, this%iout) call buy_cr(this%buy, this%name, this%inbuy, this%iout) - + end subroutine gwfifm_cr - + !> @brief Define, mostly DISU and the NPF package !< for this interface model subroutine gwfifm_df(this) @@ -106,39 +106,38 @@ subroutine gwfifm_df(this) call this%buy%buy_df(this%dis, buyData) call buyData%destruct() end if - + this%neq = this%dis%nodes this%nja = this%dis%nja - this%ia => this%dis%con%ia - this%ja => this%dis%con%ja - + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja + call this%allocate_arrays() - + end subroutine gwfifm_df - + !> @brief allocate and read the packages !< subroutine gwfifm_ar(this) class(GwfInterfaceModelType) :: this !< the GWF interface model ! local type(GwfNpfGridDataType) :: npfGridData - + call npfGridData%construct(this%dis%nodes) call this%setNpfGridData(npfGridData) call this%npf%npf_ar(this%ic, this%ibound, this%x, npfGridData) call npfGridData%destroy() if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) - + end subroutine gwfifm_ar - !> @brief Clean up !< subroutine gwfifm_da(this) - use MemoryManagerModule, only: mem_deallocate + use MemoryManagerModule, only: mem_deallocate class(GwfInterfaceModelType) :: this !< the GWF interface model - + ! -- Internal flow packages deallocate call this%dis%dis_da() call this%npf%npf_da() @@ -146,9 +145,9 @@ subroutine gwfifm_da(this) call this%buy%buy_da() ! ! -- Internal package objects - deallocate(this%dis) - deallocate(this%npf) - deallocate(this%xt3d) + deallocate (this%dis) + deallocate (this%npf) + deallocate (this%xt3d) ! ! -- Scalars call mem_deallocate(this%inic) @@ -166,14 +165,14 @@ subroutine gwfifm_da(this) ! ! -- NumericalModelType call this%NumericalModelType%model_da() - + end subroutine - + !> @brief Copy NPF options from the model owning !! the interface to the data structure !< subroutine setNpfOptions(this, npfOptions) - class(GwfInterfaceModelType) :: this !< the GWF interface model + class(GwfInterfaceModelType) :: this !< the GWF interface model type(GwfNpfOptionsType) :: npfOptions !< the options data to be filled ! for now, assuming full homogeneity, so just take @@ -190,12 +189,12 @@ subroutine setNpfOptions(this, npfOptions) end subroutine setNpfOptions - !> @brief Loop over the interface grid and fill the structure - !! with NPF grid data, copied from the models that participate + !> @brief Loop over the interface grid and fill the structure + !! with NPF grid data, copied from the models that participate !! in this interface !< subroutine setNpfGridData(this, npfGridData) - class(GwfInterfaceModelType) :: this !< the interface model + class(GwfInterfaceModelType) :: this !< the interface model type(GwfNpfGridDataType) :: npfGridData !< grid data to be set ! local integer(I4B) :: icell, idx @@ -205,7 +204,7 @@ subroutine setNpfGridData(this, npfGridData) ! TODO_MJR: deal with inhomogeneity, for now, we assume ! that we can just take the owning model's settings... npfGridData%ik22 = this%owner%npf%ik22 - npfGridData%ik33 = this%owner%npf%ik33 + npfGridData%ik33 = this%owner%npf%ik33 npfGridData%iwetdry = this%owner%npf%iwetdry npfGridData%iangle1 = this%owner%npf%iangle1 npfGridData%iangle2 = this%owner%npf%iangle2 @@ -215,7 +214,7 @@ subroutine setNpfGridData(this, npfGridData) npfGridData%iangle2 = 1 npfGridData%iangle3 = 1 end if - + do icell = 1, this%gridConnection%nrOfCells idx = this%gridConnection%idxToGlobal(icell)%index modelPtr => this%gridConnection%idxToGlobal(icell)%model @@ -227,9 +226,9 @@ subroutine setNpfGridData(this, npfGridData) npfGridData%k33(icell) = gwfModel%npf%k33(idx) ! the K rotation angles, or default (0.0) - if (npfGridData%iangle1 == 1) then + if (npfGridData%iangle1 == 1) then if (gwfModel%npf%iangle1 == 1) then - npfGridData%angle1(icell) = gwfModel%npf%angle1(idx) + npfGridData%angle1(icell) = gwfModel%npf%angle1(idx) else npfGridData%angle1(icell) = DZERO end if @@ -262,8 +261,8 @@ subroutine setNpfGridData(this, npfGridData) end subroutine setNpfGridData - !> @brief Sets the BUY input data from the models that - !! make up this interface. We adopt everything from the + !> @brief Sets the BUY input data from the models that + !! make up this interface. We adopt everything from the !! owning model, but during validation it should be !< checked that the models are compatible. subroutine setBuyData(this, buyData) @@ -284,5 +283,5 @@ subroutine setBuyData(this, buyData) end do end subroutine setBuyData - + end module GwfInterfaceModelModule diff --git a/src/Model/Connection/GwtGwtConnection.f90 b/src/Model/Connection/GwtGwtConnection.f90 index fb9cef32314..f4374fa7d31 100644 --- a/src/Model/Connection/GwtGwtConnection.f90 +++ b/src/Model/Connection/GwtGwtConnection.f90 @@ -1,6 +1,6 @@ module GwtGwtConnectionModule use KindModule, only: I4B, DP, LGP - use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, DZERO, LENBUDTXT + use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, DZERO, LENBUDTXT use CsrUtilsModule, only: getCSRIndex use SimModule, only: ustop use MemoryManagerModule, only: mem_allocate, mem_deallocate @@ -25,28 +25,28 @@ module GwtGwtConnectionModule !< type, public, extends(SpatialModelConnectionType) :: GwtGwtConnectionType - type(GwtModelType), pointer :: gwtModel => null() !< the model for which this connection exists - type(GwtExchangeType), pointer :: gwtExchange => null() !< the primary exchange, cast to GWT-GWT - logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, - !! one of them needs to manage/own the exchange (e.g. clean up) - type(GwtInterfaceModelType), pointer :: gwtInterfaceModel => null() !< the interface model - integer(I4B), pointer :: iIfaceAdvScheme => null() !< the advection scheme at the interface: - !! 0 = upstream, 1 = central, 2 = TVD - integer(I4B), pointer :: iIfaceXt3d => null() !< XT3D in the interface DSP package: 0 = no, 1 = lhs, 2 = rhs - real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< intercell flows at the interface, coming from GWF interface model - integer(I4B), pointer :: exgflowSign => null() !< indicates the flow direction of exgflowja + type(GwtModelType), pointer :: gwtModel => null() !< the model for which this connection exists + type(GwtExchangeType), pointer :: gwtExchange => null() !< the primary exchange, cast to GWT-GWT + logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, + !! one of them needs to manage/own the exchange (e.g. clean up) + type(GwtInterfaceModelType), pointer :: gwtInterfaceModel => null() !< the interface model + integer(I4B), pointer :: iIfaceAdvScheme => null() !< the advection scheme at the interface: + !! 0 = upstream, 1 = central, 2 = TVD + integer(I4B), pointer :: iIfaceXt3d => null() !< XT3D in the interface DSP package: 0 = no, 1 = lhs, 2 = rhs + real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< intercell flows at the interface, coming from GWF interface model + integer(I4B), pointer :: exgflowSign => null() !< indicates the flow direction of exgflowja real(DP), dimension(:), pointer, contiguous :: exgflowjaGwt => null() !< gwt-flowja at the interface (this is a subset of the GWT !! interface model flowja's) - - real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< gwfflowja for the interface model - real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< gwfsat for the interface model - real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< gwfhead for the interface model - real(DP), dimension(:,:), pointer, contiguous :: gwfspdis => null() !< gwfspdis for the interface model - real(DP), dimension(:), pointer, contiguous :: conc => null() !< pointer to concentration array - integer(I4B), dimension(:), pointer, contiguous :: icbound => null() !< store pointer to gwt ibound array - - integer(I4B) :: iout = 0 !< the list file for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< gwfflowja for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< gwfsat for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< gwfhead for the interface model + real(DP), dimension(:, :), pointer, contiguous :: gwfspdis => null() !< gwfspdis for the interface model + + real(DP), dimension(:), pointer, contiguous :: conc => null() !< pointer to concentration array + integer(I4B), dimension(:), pointer, contiguous :: icbound => null() !< store pointer to gwt ibound array + + integer(I4B) :: iout = 0 !< the list file for the interface model contains @@ -81,444 +81,451 @@ module GwtGwtConnectionModule !> @brief Basic construction of the connection !< -subroutine gwtGwtConnection_ctor(this, model, gwtEx) - use InputOutputModule, only: openfile - class(GwtGwtConnectionType) :: this !< the connection - class(NumericalModelType), pointer :: model !< the model owning this connection, - !! this must be a GwtModelType - class(DisConnExchangeType), pointer :: gwtEx !< the GWT-GWT exchange the interface model is created for - ! local - character(len=LINELENGTH) :: fname - character(len=LENCOMPONENTNAME) :: name - class(*), pointer :: objPtr - logical(LGP) :: write_ifmodel_listfile = .false. - - objPtr => model - this%gwtModel => CastAsGwtModel(objPtr) - objPtr => gwtEx - this%gwtExchange => CastAsGwtExchange(objPtr) - - this%exchangeIsOwned = associated(model, gwtEx%model1) - - if (this%exchangeIsOwned) then - write(name,'(a,i0)') 'GWTCON1_', gwtEx%id - else - write(name,'(a,i0)') 'GWTCON2_', gwtEx%id - end if - - ! .lst file for interface model - if (write_ifmodel_listfile) then - fname = trim(name)//'.im.lst' - call openfile(this%iout, 0, fname, 'LIST', filstat_opt='REPLACE') - write(this%iout, '(4a)') 'Creating GWT-GWT connection for model ', & - trim(this%gwtModel%name), 'from exchange ', & - trim(gwtEx%name) - end if - - ! first call base constructor - call this%SpatialModelConnectionType%spatialConnection_ctor(model, gwtEx, name) - - call this%allocate_scalars() - this%typename = 'GWT-GWT' - this%iIfaceAdvScheme = 0 - this%iIfaceXt3d = 1 - this%exgflowSign = 1 - - allocate(this%gwtInterfaceModel) - this%interfaceModel => this%gwtInterfaceModel - -end subroutine gwtGwtConnection_ctor + subroutine gwtGwtConnection_ctor(this, model, gwtEx) + use InputOutputModule, only: openfile + class(GwtGwtConnectionType) :: this !< the connection + class(NumericalModelType), pointer :: model !< the model owning this connection, + !! this must be a GwtModelType + class(DisConnExchangeType), pointer :: gwtEx !< the GWT-GWT exchange the interface model is created for + ! local + character(len=LINELENGTH) :: fname + character(len=LENCOMPONENTNAME) :: name + class(*), pointer :: objPtr + logical(LGP) :: write_ifmodel_listfile = .false. + + objPtr => model + this%gwtModel => CastAsGwtModel(objPtr) + objPtr => gwtEx + this%gwtExchange => CastAsGwtExchange(objPtr) + + this%exchangeIsOwned = associated(model, gwtEx%model1) + + if (this%exchangeIsOwned) then + write (name, '(a,i0)') 'GWTCON1_', gwtEx%id + else + write (name, '(a,i0)') 'GWTCON2_', gwtEx%id + end if + + ! .lst file for interface model + if (write_ifmodel_listfile) then + fname = trim(name)//'.im.lst' + call openfile(this%iout, 0, fname, 'LIST', filstat_opt='REPLACE') + write (this%iout, '(4a)') 'Creating GWT-GWT connection for model ', & + trim(this%gwtModel%name), 'from exchange ', & + trim(gwtEx%name) + end if + + ! first call base constructor + call this%SpatialModelConnectionType%spatialConnection_ctor(model, & + gwtEx, & + name) + + call this%allocate_scalars() + this%typename = 'GWT-GWT' + this%iIfaceAdvScheme = 0 + this%iIfaceXt3d = 1 + this%exgflowSign = 1 + + allocate (this%gwtInterfaceModel) + this%interfaceModel => this%gwtInterfaceModel + + end subroutine gwtGwtConnection_ctor !> @brief Allocate scalar variables for this connection !< -subroutine allocate_scalars(this) - class(GwtGwtConnectionType) :: this !< the connection + subroutine allocate_scalars(this) + class(GwtGwtConnectionType) :: this !< the connection - call mem_allocate(this%iIfaceAdvScheme, 'IADVSCHEME', this%memoryPath) - call mem_allocate(this%iIfaceXt3d, 'IXT3D', this%memoryPath) - call mem_allocate(this%exgflowSign, 'EXGFLOWSIGN', this%memoryPath) + call mem_allocate(this%iIfaceAdvScheme, 'IADVSCHEME', this%memoryPath) + call mem_allocate(this%iIfaceXt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%exgflowSign, 'EXGFLOWSIGN', this%memoryPath) -end subroutine allocate_scalars + end subroutine allocate_scalars !> @brief Allocate array variables for this connection !< -subroutine allocate_arrays(this) - class(GwtGwtConnectionType) :: this !< the connection - ! local - integer(I4B) :: i + subroutine allocate_arrays(this) + class(GwtGwtConnectionType) :: this !< the connection + ! local + integer(I4B) :: i - call mem_allocate(this%gwfflowja, this%interfaceModel%nja, 'GWFFLOWJA', & - this%memoryPath) - call mem_allocate(this%gwfsat, this%neq, 'GWFSAT', this%memoryPath) - call mem_allocate(this%gwfhead, this%neq, 'GWFHEAD', this%memoryPath) - call mem_allocate(this%gwfspdis, 3, this%neq, 'GWFSPDIS', this%memoryPath) + call mem_allocate(this%gwfflowja, this%interfaceModel%nja, 'GWFFLOWJA', & + this%memoryPath) + call mem_allocate(this%gwfsat, this%neq, 'GWFSAT', this%memoryPath) + call mem_allocate(this%gwfhead, this%neq, 'GWFHEAD', this%memoryPath) + call mem_allocate(this%gwfspdis, 3, this%neq, 'GWFSPDIS', this%memoryPath) - call mem_allocate(this%exgflowjaGwt, this%gridConnection%nrOfBoundaryCells, & - 'EXGFLOWJAGWT', this%memoryPath) + call mem_allocate(this%exgflowjaGwt, this%gridConnection%nrOfBoundaryCells, & + 'EXGFLOWJAGWT', this%memoryPath) - do i = 1, size(this%gwfflowja) - this%gwfflowja = 0.0_DP - end do + do i = 1, size(this%gwfflowja) + this%gwfflowja = 0.0_DP + end do - do i = 1, this%neq - this%gwfsat = 0.0_DP - end do + do i = 1, this%neq + this%gwfsat = 0.0_DP + end do -end subroutine allocate_arrays + end subroutine allocate_arrays !> @brief define the GWT-GWT connection !< -subroutine gwtgwtcon_df(this) - class(GwtGwtConnectionType) :: this !< the connection - ! local - character(len=LENCOMPONENTNAME) :: imName - - ! determine advection scheme (the GWT-GWT exchange - ! has been read at this point) - this%iIfaceAdvScheme = this%gwtExchange%iAdvScheme - - ! determine xt3d setting on interface - this%iIfaceXt3d = this%gwtExchange%ixt3d - - ! determine the required size of the interface model grid - call this%setGridExtent() - - ! now set up the GridConnection - call this%spatialcon_df() - - ! we have to 'catch up' and create the interface model - ! here, then the remainder of this routine will be define - if (this%exchangeIsOwned) then - write(imName,'(a,i0)') 'GWTIM1_', this%gwtExchange%id - else - write(imName,'(a,i0)') 'GWTIM2_', this%gwtExchange%id - end if - call this%gwtInterfaceModel%gwtifmod_cr(imName, this%iout, this%gridConnection) - this%gwtInterfaceModel%iAdvScheme = this%iIfaceAdvScheme - this%gwtInterfaceModel%ixt3d = this%iIfaceXt3d - call this%gwtInterfaceModel%model_df() - - call this%allocate_arrays() - - ! connect X, RHS, IBOUND, and flowja - call this%spatialcon_setmodelptrs() - - this%gwtInterfaceModel%fmi%gwfflowja => this%gwfflowja - this%gwtInterfaceModel%fmi%gwfsat => this%gwfsat - this%gwtInterfaceModel%fmi%gwfhead => this%gwfhead - this%gwtInterfaceModel%fmi%gwfspdis => this%gwfspdis - - ! connect pointers (used by BUY) - this%conc => this%gwtInterfaceModel%x - this%icbound => this%gwtInterfaceModel%ibound - - ! add connections from the interface model to solution matrix - call this%spatialcon_connect() - -end subroutine gwtgwtcon_df + subroutine gwtgwtcon_df(this) + class(GwtGwtConnectionType) :: this !< the connection + ! local + character(len=LENCOMPONENTNAME) :: imName + + ! determine advection scheme (the GWT-GWT exchange + ! has been read at this point) + this%iIfaceAdvScheme = this%gwtExchange%iAdvScheme + + ! determine xt3d setting on interface + this%iIfaceXt3d = this%gwtExchange%ixt3d + + ! determine the required size of the interface model grid + call this%setGridExtent() + + ! now set up the GridConnection + call this%spatialcon_df() + + ! we have to 'catch up' and create the interface model + ! here, then the remainder of this routine will be define + if (this%exchangeIsOwned) then + write (imName, '(a,i0)') 'GWTIM1_', this%gwtExchange%id + else + write (imName, '(a,i0)') 'GWTIM2_', this%gwtExchange%id + end if + call this%gwtInterfaceModel%gwtifmod_cr(imName, & + this%iout, & + this%gridConnection) + this%gwtInterfaceModel%iAdvScheme = this%iIfaceAdvScheme + this%gwtInterfaceModel%ixt3d = this%iIfaceXt3d + call this%gwtInterfaceModel%model_df() + + call this%allocate_arrays() + + ! connect X, RHS, IBOUND, and flowja + call this%spatialcon_setmodelptrs() + + this%gwtInterfaceModel%fmi%gwfflowja => this%gwfflowja + this%gwtInterfaceModel%fmi%gwfsat => this%gwfsat + this%gwtInterfaceModel%fmi%gwfhead => this%gwfhead + this%gwtInterfaceModel%fmi%gwfspdis => this%gwfspdis + + ! connect pointers (used by BUY) + this%conc => this%gwtInterfaceModel%x + this%icbound => this%gwtInterfaceModel%ibound + + ! add connections from the interface model to solution matrix + call this%spatialcon_connect() + + end subroutine gwtgwtcon_df !> @brief Set required extent of the interface grid from !< the configuration -subroutine setGridExtent(this) - class(GwtGwtConnectionType) :: this !< the connection - ! local - logical(LGP) :: hasAdv, hasDsp - - hasAdv = this%gwtModel%inadv > 0 - hasDsp = this%gwtModel%indsp > 0 - - if (hasAdv) then - if (this%iIfaceAdvScheme == 2) then - this%exchangeStencilDepth = 2 - if (this%gwtModel%adv%iadvwt == 2) then - this%internalStencilDepth = 2 + subroutine setGridExtent(this) + class(GwtGwtConnectionType) :: this !< the connection + ! local + logical(LGP) :: hasAdv, hasDsp + + hasAdv = this%gwtModel%inadv > 0 + hasDsp = this%gwtModel%indsp > 0 + + if (hasAdv) then + if (this%iIfaceAdvScheme == 2) then + this%exchangeStencilDepth = 2 + if (this%gwtModel%adv%iadvwt == 2) then + this%internalStencilDepth = 2 + end if end if end if - end if - if (hasDsp) then - if (this%iIfaceXt3d > 0) then - this%exchangeStencilDepth = 2 - if (this%gwtModel%dsp%ixt3d > 0) then - this%internalStencilDepth = 2 + if (hasDsp) then + if (this%iIfaceXt3d > 0) then + this%exchangeStencilDepth = 2 + if (this%gwtModel%dsp%ixt3d > 0) then + this%internalStencilDepth = 2 + end if end if end if - end if -end subroutine setGridExtent + end subroutine setGridExtent !> @brief allocate and read/set the connection's data structures !< -subroutine gwtgwtcon_ar(this) - class(GwtGwtConnectionType) :: this !< the connection - ! local - integer(I4B) :: i, idx - class(GwtModelType), pointer :: gwtModel - class(*), pointer :: modelPtr - - ! check if we can construct an interface model - ! NB: only makes sense after the models' allocate&read have been - ! called, which is why we do it here - call this%validateConnection() - - ! fill porosity from mst packages, needed for dsp - if (this%gwtModel%inmst > 0) then - do i = 1, this%neq - modelPtr => this%gridConnection%idxToGlobal(i)%model - gwtModel => CastAsGwtModel(modelPtr) - idx = this%gridConnection%idxToGlobal(i)%index - this%gwtInterfaceModel%porosity(i) = gwtModel%mst%porosity(idx) - end do - end if - - ! allocate and read base - call this%spatialcon_ar() - - ! ... and now the interface model - call this%gwtInterfaceModel%model_ar() - - ! AR the movers and obs through the exchange - if (this%exchangeIsOwned) then - !cdl implement this when MVT is ready - !cdl if (this%gwtExchange%inmvt > 0) then - !cdl call this%gwtExchange%mvt%mvt_ar() - !cdl end if - if (this%gwtExchange%inobs > 0) then - call this%gwtExchange%obs%obs_ar() + subroutine gwtgwtcon_ar(this) + class(GwtGwtConnectionType) :: this !< the connection + ! local + integer(I4B) :: i, idx + class(GwtModelType), pointer :: gwtModel + class(*), pointer :: modelPtr + + ! check if we can construct an interface model + ! NB: only makes sense after the models' allocate&read have been + ! called, which is why we do it here + call this%validateConnection() + + ! fill porosity from mst packages, needed for dsp + if (this%gwtModel%inmst > 0) then + do i = 1, this%neq + modelPtr => this%gridConnection%idxToGlobal(i)%model + gwtModel => CastAsGwtModel(modelPtr) + idx = this%gridConnection%idxToGlobal(i)%index + this%gwtInterfaceModel%porosity(i) = gwtModel%mst%porosity(idx) + end do end if - end if -end subroutine gwtgwtcon_ar + ! allocate and read base + call this%spatialcon_ar() + + ! ... and now the interface model + call this%gwtInterfaceModel%model_ar() -!> @brief validate this connection prior to constructing + ! AR the movers and obs through the exchange + if (this%exchangeIsOwned) then + !cdl implement this when MVT is ready + !cdl if (this%gwtExchange%inmvt > 0) then + !cdl call this%gwtExchange%mvt%mvt_ar() + !cdl end if + if (this%gwtExchange%inobs > 0) then + call this%gwtExchange%obs%obs_ar() + end if + end if + + end subroutine gwtgwtcon_ar + +!> @brief validate this connection prior to constructing !< the interface model -subroutine validateConnection(this) - use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error - class(GwtGwtConnectionType) :: this !< this connection - - ! base validation, the spatial/geometry part - call this%SpatialModelConnectionType%validateConnection() - - ! GWT related matters - if ((this%gwtExchange%gwtmodel1%inadv > 0 .and. this%gwtExchange%gwtmodel2%inadv == 0) .or. & - (this%gwtExchange%gwtmodel2%inadv > 0 .and. this%gwtExchange%gwtmodel1%inadv == 0)) then - write(errmsg, '(1x,a,a,a)') 'Cannot connect GWT models in exchange ', & - trim(this%gwtExchange%name), ' because one model is configured with ADV & - &and the other one is not' - call store_error(errmsg) - end if - - if ((this%gwtExchange%gwtmodel1%indsp > 0 .and. this%gwtExchange%gwtmodel2%indsp == 0) .or. & - (this%gwtExchange%gwtmodel2%indsp > 0 .and. this%gwtExchange%gwtmodel1%indsp == 0)) then - write(errmsg, '(1x,a,a,a)') 'Cannot connect GWT models in exchange ', & - trim(this%gwtExchange%name), ' because one model is configured with DSP & - &and the other one is not' - call store_error(errmsg) - end if - - ! abort on errors - if(count_errors() > 0) then - write(errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' - call ustop() - end if - -end subroutine validateConnection + subroutine validateConnection(this) + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error + class(GwtGwtConnectionType) :: this !< this connection + ! base validation, the spatial/geometry part + call this%SpatialModelConnectionType%validateConnection() + + ! GWT related matters + if ((this%gwtExchange%gwtmodel1%inadv > 0 .and. & + this%gwtExchange%gwtmodel2%inadv == 0) .or. & + (this%gwtExchange%gwtmodel2%inadv > 0 .and. & + this%gwtExchange%gwtmodel1%inadv == 0)) then + write (errmsg, '(1x,a,a,a)') 'Cannot connect GWT models in exchange ', & + trim(this%gwtExchange%name), ' because one model is configured with ADV & + &and the other one is not' + call store_error(errmsg) + end if + + if ((this%gwtExchange%gwtmodel1%indsp > 0 .and. & + this%gwtExchange%gwtmodel2%indsp == 0) .or. & + (this%gwtExchange%gwtmodel2%indsp > 0 .and. & + this%gwtExchange%gwtmodel1%indsp == 0)) then + write (errmsg, '(1x,a,a,a)') 'Cannot connect GWT models in exchange ', & + trim(this%gwtExchange%name), ' because one model is configured with DSP & + &and the other one is not' + call store_error(errmsg) + end if + + ! abort on errors + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' + call ustop() + end if + + end subroutine validateConnection !> @brief add connections to the global system for !< this connection -subroutine gwtgwtcon_ac(this, sparse) - class(GwtGwtConnectionType) :: this !< this connection - type(sparsematrix), intent(inout) :: sparse !< sparse matrix to store the connections - ! local - integer(I4B) :: ic, iglo, jglo - type(GlobalCellType) :: boundaryCell, connectedCell - - ! connections to other models - do ic = 1, this%gridConnection%nrOfBoundaryCells - boundaryCell = this%gridConnection%boundaryCells(ic)%cell - connectedCell = this%gridConnection%connectedCells(ic)%cell - iglo = boundaryCell%index + boundaryCell%model%moffset - jglo = connectedCell%index + connectedCell%model%moffset - call sparse%addconnection(iglo, jglo, 1) - call sparse%addconnection(jglo, iglo, 1) - end do - - ! and internal connections - call this%spatialcon_ac(sparse) - -end subroutine gwtgwtcon_ac - -subroutine gwtgwtcon_rp(this) - class(GwtGwtConnectionType) :: this !< the connection - - ! Call exchange rp routines - if (this%exchangeIsOwned) then - call this%gwtExchange%exg_rp() - end if - -end subroutine gwtgwtcon_rp + subroutine gwtgwtcon_ac(this, sparse) + class(GwtGwtConnectionType) :: this !< this connection + type(sparsematrix), intent(inout) :: sparse !< sparse matrix to store the connections + ! local + integer(I4B) :: ic, iglo, jglo + type(GlobalCellType) :: boundaryCell, connectedCell + + ! connections to other models + do ic = 1, this%gridConnection%nrOfBoundaryCells + boundaryCell = this%gridConnection%boundaryCells(ic)%cell + connectedCell = this%gridConnection%connectedCells(ic)%cell + iglo = boundaryCell%index + boundaryCell%model%moffset + jglo = connectedCell%index + connectedCell%model%moffset + call sparse%addconnection(iglo, jglo, 1) + call sparse%addconnection(jglo, iglo, 1) + end do + + ! and internal connections + call this%spatialcon_ac(sparse) + end subroutine gwtgwtcon_ac + + subroutine gwtgwtcon_rp(this) + class(GwtGwtConnectionType) :: this !< the connection + + ! Call exchange rp routines + if (this%exchangeIsOwned) then + call this%gwtExchange%exg_rp() + end if + + end subroutine gwtgwtcon_rp !> @brief Advance this connection !< -subroutine gwtgwtcon_ad(this) - class(GwtGwtConnectionType) :: this !< this connection - - ! copy model data into interface model - call this%syncInterfaceModel() + subroutine gwtgwtcon_ad(this) + class(GwtGwtConnectionType) :: this !< this connection - ! recalculate dispersion ellipse - if (this%gwtInterfaceModel%indsp > 0) call this%gwtInterfaceModel%dsp%dsp_ad() + ! copy model data into interface model + call this%syncInterfaceModel() - if (this%exchangeIsOwned) then - call this%gwtExchange%exg_ad() - end if + ! recalculate dispersion ellipse + if (this%gwtInterfaceModel%indsp > 0) call this%gwtInterfaceModel%dsp%dsp_ad() -end subroutine gwtgwtcon_ad + if (this%exchangeIsOwned) then + call this%gwtExchange%exg_ad() + end if + end subroutine gwtgwtcon_ad -subroutine gwtgwtcon_cf(this, kiter) - class(GwtGwtConnectionType) :: this !< the connection - integer(I4B), intent(in) :: kiter !< the iteration counter - ! local - integer(I4B) :: i + subroutine gwtgwtcon_cf(this, kiter) + class(GwtGwtConnectionType) :: this !< the connection + integer(I4B), intent(in) :: kiter !< the iteration counter + ! local + integer(I4B) :: i - ! copy model data into interface model - ! (when kiter == 1, this is already done in _ad) - if (kiter > 1) call this%syncInterfaceModel() + ! copy model data into interface model + ! (when kiter == 1, this is already done in _ad) + if (kiter > 1) call this%syncInterfaceModel() - ! reset interface system - do i = 1, this%nja - this%amat(i) = 0.0_DP - end do - do i = 1, this%neq - this%rhs(i) = 0.0_DP - end do + ! reset interface system + do i = 1, this%nja + this%amat(i) = 0.0_DP + end do + do i = 1, this%neq + this%rhs(i) = 0.0_DP + end do - call this%gwtInterfaceModel%model_cf(kiter) - -end subroutine gwtgwtcon_cf + call this%gwtInterfaceModel%model_cf(kiter) + end subroutine gwtgwtcon_cf !> @brief called during advance (*_ad), to copy the data !! from the models into the connection's placeholder arrays !< -subroutine syncInterfaceModel(this) - class(GwtGwtConnectionType) :: this !< the connection - ! local - integer(I4B) :: i, n, m, ipos, iposLoc, idx - type(ConnectionsType), pointer :: imCon !< interface model connections - type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell - type(GlobalCellType), pointer :: boundaryCell, connectedCell - class(GwtModelType), pointer :: gwtModel - class(*), pointer :: modelPtr - - ! for readability - imCon => this%gwtInterfaceModel%dis%con - toGlobal => this%gridConnection%idxToGlobal - - ! loop over connections in interface - do n = 1, this%neq - do ipos = imCon%ia(n) + 1, imCon%ia(n+1) - 1 - m = imCon%ja(ipos) - if (associated(toGlobal(n)%model, toGlobal(m)%model)) then - ! internal connection for a model, copy from its flowja - iposLoc = getCSRIndex(toGlobal(n)%index, toGlobal(m)%index, & - toGlobal(n)%model%ia, toGlobal(n)%model%ja) - modelPtr => toGlobal(n)%model - gwtModel => CastAsGwtModel(modelPtr) - this%gwfflowja(ipos) = gwtModel%fmi%gwfflowja(iposLoc) - end if + subroutine syncInterfaceModel(this) + class(GwtGwtConnectionType) :: this !< the connection + ! local + integer(I4B) :: i, n, m, ipos, iposLoc, idx + type(ConnectionsType), pointer :: imCon !< interface model connections + type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell + type(GlobalCellType), pointer :: boundaryCell, connectedCell + class(GwtModelType), pointer :: gwtModel + class(*), pointer :: modelPtr + + ! for readability + imCon => this%gwtInterfaceModel%dis%con + toGlobal => this%gridConnection%idxToGlobal + + ! loop over connections in interface + do n = 1, this%neq + do ipos = imCon%ia(n) + 1, imCon%ia(n + 1) - 1 + m = imCon%ja(ipos) + if (associated(toGlobal(n)%model, toGlobal(m)%model)) then + ! internal connection for a model, copy from its flowja + iposLoc = getCSRIndex(toGlobal(n)%index, toGlobal(m)%index, & + toGlobal(n)%model%ia, toGlobal(n)%model%ja) + modelPtr => toGlobal(n)%model + gwtModel => CastAsGwtModel(modelPtr) + this%gwfflowja(ipos) = gwtModel%fmi%gwfflowja(iposLoc) + end if + end do end do - end do - - ! the flowja for exchange cells - do i = 1, this%gridConnection%nrOfBoundaryCells - boundaryCell => this%gridConnection%boundaryCells(i)%cell - connectedCell => this%gridConnection%connectedCells(i)%cell - n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & - boundaryCell%model) - m = this%gridConnection%getInterfaceIndex(connectedCell%index, & - connectedCell%model) - ipos = getCSRIndex(n, m, imCon%ia, imCon%ja) - this%gwfflowja(ipos) = this%exgflowja(i) * this%exgflowSign - ipos = getCSRIndex(m, n, imCon%ia, imCon%ja) - this%gwfflowja(ipos) = -this%exgflowja(i) * this%exgflowSign - end do - - ! copy concentrations - do i = 1, this%gridConnection%nrOfCells - idx = this%gridConnection%idxToGlobal(i)%index - this%x(i) = this%gridConnection%idxToGlobal(i)%model%x(idx) - this%gwtInterfaceModel%xold(i) = this%gridConnection%idxToGlobal(i)%model%xold(idx) - end do - - ! copy fmi - do i = 1, this%gridConnection%nrOfCells - idx = this%gridConnection%idxToGlobal(i)%index - modelPtr => this%gridConnection%idxToGlobal(i)%model - gwtModel => CastAsGwtModel(modelPtr) - - this%gwfsat(i) = gwtModel%fmi%gwfsat(idx) - this%gwfhead(i) = gwtModel%fmi%gwfhead(idx) - this%gwfspdis(1, i) = gwtModel%fmi%gwfspdis(1, idx) - this%gwfspdis(2, i) = gwtModel%fmi%gwfspdis(2, idx) - this%gwfspdis(3, i) = gwtModel%fmi%gwfspdis(3, idx) - end do - -end subroutine syncInterfaceModel - - -subroutine gwtgwtcon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) - class(GwtGwtConnectionType) :: this !< the connection - integer(I4B), intent(in) :: kiter !< the iteration counter - integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array - real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients - real(DP), dimension(:), intent(inout) ::rhssln !< global right-hand-side - integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag - ! local - integer(I4B) :: n, nglo, ipos - - call this%gwtInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) - - ! map back to solution matrix - do n = 1, this%neq - ! We only need the coefficients for our own model - ! (i.e. rows in the matrix that belong to this%owner): - if (.not. associated(this%gridConnection%idxToGlobal(n)%model, this%owner)) then - cycle - end if - - nglo = this%gridConnection%idxToGlobal(n)%index + this%gridConnection%idxToGlobal(n)%model%moffset - rhssln(nglo) = rhssln(nglo) + this%rhs(n) - - do ipos = this%ia(n), this%ia(n+1) - 1 - amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + this%amat(ipos) + + ! the flowja for exchange cells + do i = 1, this%gridConnection%nrOfBoundaryCells + boundaryCell => this%gridConnection%boundaryCells(i)%cell + connectedCell => this%gridConnection%connectedCells(i)%cell + n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & + boundaryCell%model) + m = this%gridConnection%getInterfaceIndex(connectedCell%index, & + connectedCell%model) + ipos = getCSRIndex(n, m, imCon%ia, imCon%ja) + this%gwfflowja(ipos) = this%exgflowja(i) * this%exgflowSign + ipos = getCSRIndex(m, n, imCon%ia, imCon%ja) + this%gwfflowja(ipos) = -this%exgflowja(i) * this%exgflowSign + end do + + ! copy concentrations + do i = 1, this%gridConnection%nrOfCells + idx = this%gridConnection%idxToGlobal(i)%index + this%x(i) = this%gridConnection%idxToGlobal(i)%model%x(idx) + this%gwtInterfaceModel%xold(i) = & + this%gridConnection%idxToGlobal(i)%model%xold(idx) + end do + + ! copy fmi + do i = 1, this%gridConnection%nrOfCells + idx = this%gridConnection%idxToGlobal(i)%index + modelPtr => this%gridConnection%idxToGlobal(i)%model + gwtModel => CastAsGwtModel(modelPtr) + + this%gwfsat(i) = gwtModel%fmi%gwfsat(idx) + this%gwfhead(i) = gwtModel%fmi%gwfhead(idx) + this%gwfspdis(1, i) = gwtModel%fmi%gwfspdis(1, idx) + this%gwfspdis(2, i) = gwtModel%fmi%gwfspdis(2, idx) + this%gwfspdis(3, i) = gwtModel%fmi%gwfspdis(3, idx) + end do + + end subroutine syncInterfaceModel + + subroutine gwtgwtcon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) + class(GwtGwtConnectionType) :: this !< the connection + integer(I4B), intent(in) :: kiter !< the iteration counter + integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array + real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients + real(DP), dimension(:), intent(inout) :: rhssln !< global right-hand-side + integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag + ! local + integer(I4B) :: n, nglo, ipos + + call this%gwtInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) + + ! map back to solution matrix + do n = 1, this%neq + ! We only need the coefficients for our own model + ! (i.e. rows in the matrix that belong to this%owner): + if (.not. associated(this%gridConnection%idxToGlobal(n)%model, & + this%owner)) then + cycle + end if + + nglo = this%gridConnection%idxToGlobal(n)%index + & + this%gridConnection%idxToGlobal(n)%model%moffset + rhssln(nglo) = rhssln(nglo) + this%rhs(n) + + do ipos = this%ia(n), this%ia(n + 1) - 1 + amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + & + this%amat(ipos) + end do end do - end do - ! FC the movers through the exchange; we can call - ! exg_fc() directly because it only handles mover terms (unlike in GwfExchange%exg_fc) - if (this%exchangeIsOwned) then - call this%gwtExchange%exg_fc(kiter, iasln, amatsln, rhssln, inwtflag) - end if + ! FC the movers through the exchange; we can call + ! exg_fc() directly because it only handles mover terms (unlike in GwfExchange%exg_fc) + if (this%exchangeIsOwned) then + call this%gwtExchange%exg_fc(kiter, iasln, amatsln, rhssln, inwtflag) + end if -end subroutine gwtgwtcon_fc + end subroutine gwtgwtcon_fc -subroutine gwtgwtcon_cq(this, icnvg, isuppress_output, isolnid) - class(GwtGwtConnectionType) :: this !< the connection - integer(I4B), intent(inout) :: icnvg !< convergence flag - integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 - integer(I4B), intent(in) :: isolnid !< solution id + subroutine gwtgwtcon_cq(this, icnvg, isuppress_output, isolnid) + class(GwtGwtConnectionType) :: this !< the connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id - call this%gwtInterfaceModel%model_cq(icnvg, isuppress_output) - call this%setFlowToExchange() + call this%gwtInterfaceModel%model_cq(icnvg, isuppress_output) + call this%setFlowToExchange() -end subroutine gwtgwtcon_cq + end subroutine gwtgwtcon_cq - !> @brief Set the flows (flowja from interface model) to the + !> @brief Set the flows (flowja from interface model) to the !< simvals in the exchange, leaving the budget calcution in there subroutine setFlowToExchange(this) class(GwtGwtConnectionType) :: this !< this connection @@ -528,16 +535,19 @@ subroutine setFlowToExchange(this) class(GwtExchangeType), pointer :: gwtEx gwtEx => this%gwtExchange - if (this%exchangeIsOwned) then + if (this%exchangeIsOwned) then do i = 1, gwtEx%nexg gwtEx%simvals(i) = DZERO - if (gwtEx%gwtmodel1%ibound(gwtEx%nodem1(i)) /= 0 .and. & + if (gwtEx%gwtmodel1%ibound(gwtEx%nodem1(i)) /= 0 .and. & gwtEx%gwtmodel2%ibound(gwtEx%nodem2(i)) /= 0) then - nIface = this%gridConnection%getInterfaceIndex(gwtEx%nodem1(i), gwtEx%model1) - mIface = this%gridConnection%getInterfaceIndex(gwtEx%nodem2(i), gwtEx%model2) - ipos = getCSRIndex(nIface, mIface, this%gwtInterfaceModel%ia, this%gwtInterfaceModel%ja) + nIface = this%gridConnection%getInterfaceIndex(gwtEx%nodem1(i), & + gwtEx%model1) + mIface = this%gridConnection%getInterfaceIndex(gwtEx%nodem2(i), & + gwtEx%model2) + ipos = getCSRIndex(nIface, mIface, this%gwtInterfaceModel%ia, & + this%gwtInterfaceModel%ja) gwtEx%simvals(i) = this%gwtInterfaceModel%flowja(ipos) end if @@ -546,84 +556,84 @@ subroutine setFlowToExchange(this) end subroutine setFlowToExchange -subroutine gwtgwtcon_bd(this, icnvg, isuppress_output, isolnid) - use BudgetModule, only: rate_accumulator - class(GwtGwtConnectionType) :: this !< the connection - integer(I4B), intent(inout) :: icnvg !< convergence flag - integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 - integer(I4B), intent(in) :: isolnid !< solution id - - ! call exchange budget routine, also calls bd - ! for movers. - if (this%exchangeIsOwned) then - call this%gwtExchange%exg_bd(icnvg, isuppress_output, isolnid) - end if - -end subroutine gwtgwtcon_bd - -subroutine gwtgwtcon_ot(this) - class(GwtGwtConnectionType) :: this !< the connection - - ! Call exg_ot() here as it handles all output processing - ! based on gwtExchange%simvals(:), which was correctly - ! filled from gwtgwtcon - if (this%exchangeIsOwned) then - call this%gwtExchange%exg_ot() - end if - -end subroutine gwtgwtcon_ot - -subroutine gwtgwtcon_da(this) - class(GwtGwtConnectionType) :: this !< the connection - ! local - logical(LGP) :: isOpen - - ! scalars - call mem_deallocate(this%iIfaceAdvScheme) - call mem_deallocate(this%iIfaceXt3d) - call mem_deallocate(this%exgflowSign) - - ! arrays - call mem_deallocate(this%gwfflowja) - call mem_deallocate(this%gwfsat) - call mem_deallocate(this%gwfhead) - call mem_deallocate(this%gwfspdis) - call mem_deallocate(this%exgflowjaGwt) - - ! interface model - call this%gwtInterfaceModel%model_da() - deallocate(this%gwtInterfaceModel) - - ! dealloc base - call this%spatialcon_da() - - inquire(this%iout, opened=isOpen) + subroutine gwtgwtcon_bd(this, icnvg, isuppress_output, isolnid) + use BudgetModule, only: rate_accumulator + class(GwtGwtConnectionType) :: this !< the connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id + + ! call exchange budget routine, also calls bd + ! for movers. + if (this%exchangeIsOwned) then + call this%gwtExchange%exg_bd(icnvg, isuppress_output, isolnid) + end if + + end subroutine gwtgwtcon_bd + + subroutine gwtgwtcon_ot(this) + class(GwtGwtConnectionType) :: this !< the connection + + ! Call exg_ot() here as it handles all output processing + ! based on gwtExchange%simvals(:), which was correctly + ! filled from gwtgwtcon + if (this%exchangeIsOwned) then + call this%gwtExchange%exg_ot() + end if + + end subroutine gwtgwtcon_ot + + subroutine gwtgwtcon_da(this) + class(GwtGwtConnectionType) :: this !< the connection + ! local + logical(LGP) :: isOpen + + ! scalars + call mem_deallocate(this%iIfaceAdvScheme) + call mem_deallocate(this%iIfaceXt3d) + call mem_deallocate(this%exgflowSign) + + ! arrays + call mem_deallocate(this%gwfflowja) + call mem_deallocate(this%gwfsat) + call mem_deallocate(this%gwfhead) + call mem_deallocate(this%gwfspdis) + call mem_deallocate(this%exgflowjaGwt) + + ! interface model + call this%gwtInterfaceModel%model_da() + deallocate (this%gwtInterfaceModel) + + ! dealloc base + call this%spatialcon_da() + + inquire (this%iout, opened=isOpen) if (isOpen) then - close(this%iout) + close (this%iout) end if - ! we need to deallocate the exchange we own: - if (this%exchangeIsOwned) then - call this%gwtExchange%exg_da() - end if + ! we need to deallocate the exchange we own: + if (this%exchangeIsOwned) then + call this%gwtExchange%exg_da() + end if -end subroutine gwtgwtcon_da + end subroutine gwtgwtcon_da !> @brief Cast to GwtGwtConnectionType !< -function CastAsGwtGwtConnection(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj !< object to be cast - class(GwtGwtConnectionType), pointer :: res !< the GwtGwtConnection - - res => null() - if (.not. associated(obj)) return - - select type (obj) - class is (GwtGwtConnectionType) - res => obj - end select - return -end function CastAsGwtGwtConnection - -end module \ No newline at end of file + function CastAsGwtGwtConnection(obj) result(res) + implicit none + class(*), pointer, intent(inout) :: obj !< object to be cast + class(GwtGwtConnectionType), pointer :: res !< the GwtGwtConnection + + res => null() + if (.not. associated(obj)) return + + select type (obj) + class is (GwtGwtConnectionType) + res => obj + end select + return + end function CastAsGwtGwtConnection + +end module diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 0e6f3423cb7..e23f6117273 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -1,34 +1,34 @@ module GwtInterfaceModelModule - use KindModule, only: I4B, DP + use KindModule, only: I4B, DP use MemoryManagerModule, only: mem_allocate, mem_deallocate use MemoryHelperModule, only: create_mem_path use NumericalModelModule, only: NumericalModelType use GwtModule, only: GwtModelType, CastAsGwtModel use GwfDisuModule, only: disu_cr, CastAsDisuType - use GwtFmiModule, only: fmi_cr, GwtFmiType - use GwtAdvModule, only: adv_cr, GwtAdvType - use GwtAdvOptionsModule, only: GwtAdvOptionsType + use TspFmiModule, only: fmi_cr, TspFmiType + use TspAdvModule, only: adv_cr, TspAdvType + use TspAdvOptionsModule, only: TspAdvOptionsType use GwtDspModule, only: dsp_cr, GwtDspType - use GwtDspOptionsModule, only: GwtDspOptionsType - use GwtDspGridDataModule, only: GwtDspGridDataType - use GwtObsModule, only: gwt_obs_cr + use TspDspOptionsModule, only: TspDspOptionsType + use TspDspGridDataModule, only: TspDspGridDataType + use TspObsModule, only: tsp_obs_cr use GridConnectionModule implicit none private !> The GWT Interface Model is a utility to calculate the solution's - !! exchange coefficients from the interface between a GWT model and - !! its GWT neighbors. The interface model itself will not be part - !! of the solution, it is not being solved. + !! exchange coefficients from the interface between a GWT model and + !! its GWT neighbors. The interface model itself will not be part + !! of the solution, it is not being solved. type, public, extends(GwtModelType) :: GwtInterfaceModelType - integer(i4B), pointer :: iAdvScheme => null() !< the advection scheme: 0 = up, 1 = central, 2 = tvd - integer(i4B), pointer :: ixt3d => null() !< xt3d setting: 0 = off, 1 = lhs, 2 = rhs + integer(i4B), pointer :: iAdvScheme => null() !< the advection scheme: 0 = up, 1 = central, 2 = tvd + integer(i4B), pointer :: ixt3d => null() !< xt3d setting: 0 = off, 1 = lhs, 2 = rhs - class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid - class(GwtModelType), private, pointer :: owner => null() !< the real GWT model for which the exchange coefficients - !! are calculated with this interface model + class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid + class(GwtModelType), private, pointer :: owner => null() !< the real GWT model for which the exchange coefficients + !! are calculated with this interface model real(DP), dimension(:), pointer, contiguous :: porosity => null() !< to be filled with MST porosity @@ -43,197 +43,194 @@ module GwtInterfaceModelModule contains -!> @brief Create the interface model, analogously to what +!> @brief Create the interface model, analogously to what !< happens in gwt_cr -subroutine gwtifmod_cr(this, name, iout, gridConn) - class(GwtInterfaceModelType) :: this !< the GWT interface model - character(len=*), intent(in) :: name !< the interface model's name - integer(I4B), intent(in) :: iout !< the output unit - class(GridConnectionType), pointer, intent(in) :: gridConn !< the grid connection data for creating a DISU - ! local - class(*), pointer :: modelPtr - integer(I4B), target :: inobs - integer(I4B) :: adv_unit, dsp_unit - - this%memoryPath = create_mem_path(name) - call this%allocate_scalars(name) - - ! defaults - this%iAdvScheme = 0 - this%ixt3d = 0 - - this%iout = iout - this%gridConnection => gridConn - modelPtr => gridConn%model - this%owner => CastAsGwtModel(modelPtr) - - inobs = 0 - adv_unit = 0 - dsp_unit = 0 - if (this%owner%inadv > 0) then - this%inadv = huge(1_I4B) - adv_unit = huge(1_I4B) - end if - if (this%owner%indsp > 0) then - this%indsp = huge(1_I4B) - dsp_unit = huge(1_I4B) - end if - - ! create dis and packages - call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout) - call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) - call gwt_obs_cr(this%obs, inobs) - -end subroutine gwtifmod_cr - -subroutine allocate_scalars(this, modelname) - class(GwtInterfaceModelType) :: this !< the GWT interface model - character(len=*), intent(in) :: modelname !< the model name - - call this%GwtModelType%allocate_scalars(modelname) - - call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) - call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) - -end subroutine allocate_scalars + subroutine gwtifmod_cr(this, name, iout, gridConn) + class(GwtInterfaceModelType) :: this !< the GWT interface model + character(len=*), intent(in) :: name !< the interface model's name + integer(I4B), intent(in) :: iout !< the output unit + class(GridConnectionType), pointer, intent(in) :: gridConn !< the grid connection data for creating a DISU + ! local + class(*), pointer :: modelPtr + integer(I4B), target :: inobs + integer(I4B) :: adv_unit, dsp_unit + + this%memoryPath = create_mem_path(name) + call this%allocate_scalars(name) + + ! defaults + this%iAdvScheme = 0 + this%ixt3d = 0 + + this%iout = iout + this%gridConnection => gridConn + modelPtr => gridConn%model + this%owner => CastAsGwtModel(modelPtr) + + inobs = 0 + adv_unit = 0 + dsp_unit = 0 + if (this%owner%inadv > 0) then + this%inadv = huge(1_I4B) + adv_unit = huge(1_I4B) + end if + if (this%owner%indsp > 0) then + this%indsp = huge(1_I4B) + dsp_unit = huge(1_I4B) + end if -!> @brief Define the GWT interface model -!< -subroutine gwtifmod_df(this) - class(GwtInterfaceModelType) :: this !< the GWT interface model - ! local - class(*), pointer :: disPtr - type(GwtAdvOptionsType) :: adv_options - type(GwtDspOptionsType) :: dsp_options - integer(I4B) :: i - - this%moffset = 0 - adv_options%iAdvScheme = this%iAdvScheme - dsp_options%ixt3d = this%ixt3d - - ! define DISU - disPtr => this%dis - call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) - call this%fmi%fmi_df(this%dis, 0) - - if (this%inadv > 0) then - call this%adv%adv_df(adv_options) - end if - if (this%indsp > 0) then - call this%dsp%dsp_df(this%dis, dsp_options) - end if - - ! assign or point model members to dis members - this%neq = this%dis%nodes - this%nja = this%dis%nja - this%ia => this%dis%con%ia - this%ja => this%dis%con%ja - ! - ! allocate model arrays, now that neq and nja are assigned - call this%allocate_arrays() - call mem_allocate(this%porosity, this%neq, 'POROSITY', this%memoryPath) - - do i = 1, size(this%flowja) - this%flowja = 0.0_DP - end do - do i = 1, this%neq - this%porosity = 0.0_DP - end do - -end subroutine gwtifmod_df - - -!> @brief Override allocate and read the GWT interface model and its -!! packages so that we can create stuff from memory instead of input -!< files -subroutine gwtifmod_ar(this) - class(GwtInterfaceModelType) :: this !< the GWT interface model - ! local - type(GwtDspGridDataType) :: dspGridData - - call this%fmi%fmi_ar(this%ibound) - if (this%inadv > 0) then - call this%adv%adv_ar(this%dis, this%ibound) - end if - if (this%indsp > 0) then - this%dsp%idiffc = this%owner%dsp%idiffc - this%dsp%idisp = this%owner%dsp%idisp - call dspGridData%construct(this%neq) - call this%setDspGridData(dspGridData) - call this%dsp%dsp_ar(this%ibound, this%porosity, dspGridData) - end if - -end subroutine gwtifmod_ar + ! create dis and packages + call disu_cr(this%dis, this%name, -1, this%iout) + call fmi_cr(this%fmi, this%name, 0, this%iout) + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) + call tsp_obs_cr(this%obs, inobs) + end subroutine gwtifmod_cr -!> @brief set dsp grid data from models + subroutine allocate_scalars(this, modelname) + class(GwtInterfaceModelType) :: this !< the GWT interface model + character(len=*), intent(in) :: modelname !< the model name + + call this%GwtModelType%allocate_scalars(modelname) + + call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) + call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + + end subroutine allocate_scalars + +!> @brief Define the GWT interface model !< -subroutine setDspGridData(this, gridData) - class(GwtInterfaceModelType) :: this !< the GWT interface model - type(GwtDspGridDataType) :: gridData !< the dsp grid data to be set - ! local - integer(I4B) :: i, idx - class(GwtModelType), pointer :: gwtModel - class(*), pointer :: modelPtr - - do i = 1, this%neq - modelPtr => this%gridConnection%idxToGlobal(i)%model - gwtModel => CastAsGwtModel(modelPtr) - idx = this%gridConnection%idxToGlobal(i)%index - - if (this%dsp%idiffc > 0) then - gridData%diffc(i) = gwtModel%dsp%diffc(idx) + subroutine gwtifmod_df(this) + class(GwtInterfaceModelType) :: this !< the GWT interface model + ! local + class(*), pointer :: disPtr + type(TspAdvOptionsType) :: adv_options + type(TspDspOptionsType) :: dsp_options + integer(I4B) :: i + + this%moffset = 0 + adv_options%iAdvScheme = this%iAdvScheme + dsp_options%ixt3d = this%ixt3d + + ! define DISU + disPtr => this%dis + call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) + call this%fmi%fmi_df(this%dis, 0) + + if (this%inadv > 0) then + call this%adv%adv_df(adv_options) + end if + if (this%indsp > 0) then + call this%dsp%dsp_df(this%dis, dsp_options) + end if + + ! assign or point model members to dis members + this%neq = this%dis%nodes + this%nja = this%dis%nja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja + ! + ! allocate model arrays, now that neq and nja are assigned + call this%allocate_arrays() + call mem_allocate(this%porosity, this%neq, 'POROSITY', this%memoryPath) + + do i = 1, size(this%flowja) + this%flowja = 0.0_DP + end do + do i = 1, this%neq + this%porosity = 0.0_DP + end do + + end subroutine gwtifmod_df + +!> @brief Override allocate and read the GWT interface model and its +!! packages so that we can create stuff from memory instead of input +!< files + subroutine gwtifmod_ar(this) + class(GwtInterfaceModelType) :: this !< the GWT interface model + ! local + type(TspDspGridDataType) :: dspGridData + + call this%fmi%fmi_ar(this%ibound) + if (this%inadv > 0) then + call this%adv%adv_ar(this%dis, this%ibound) end if - if (this%dsp%idisp > 0) then - gridData%alh(i) = gwtModel%dsp%alh(idx) - gridData%alv(i) = gwtModel%dsp%alv(idx) - gridData%ath1(i) = gwtModel%dsp%ath1(idx) - gridData%ath2(i) = gwtModel%dsp%ath2(idx) - gridData%atv(i) = gwtModel%dsp%atv(idx) + if (this%indsp > 0) then + this%dsp%idiffc = this%owner%dsp%idiffc + this%dsp%idisp = this%owner%dsp%idisp + call dspGridData%construct(this%neq) + call this%setDspGridData(dspGridData) + call this%dsp%dsp_ar(this%ibound, this%porosity, dspGridData) end if - end do + end subroutine gwtifmod_ar -end subroutine setDspGridData +!> @brief set dsp grid data from models +!< + subroutine setDspGridData(this, gridData) + class(GwtInterfaceModelType) :: this !< the GWT interface model + type(TspDspGridDataType) :: gridData !< the dsp grid data to be set + ! local + integer(I4B) :: i, idx + class(GwtModelType), pointer :: gwtModel + class(*), pointer :: modelPtr + + do i = 1, this%neq + modelPtr => this%gridConnection%idxToGlobal(i)%model + gwtModel => CastAsGwtModel(modelPtr) + idx = this%gridConnection%idxToGlobal(i)%index + + if (this%dsp%idiffc > 0) then + gridData%diffc(i) = gwtModel%dsp%diffc(idx) + end if + if (this%dsp%idisp > 0) then + gridData%alh(i) = gwtModel%dsp%alh(idx) + gridData%alv(i) = gwtModel%dsp%alv(idx) + gridData%ath1(i) = gwtModel%dsp%ath1(idx) + gridData%ath2(i) = gwtModel%dsp%ath2(idx) + gridData%atv(i) = gwtModel%dsp%atv(idx) + end if + + end do + + end subroutine setDspGridData !> @brief Clean up resources !< -subroutine gwtifmod_da(this) - class(GwtInterfaceModelType) :: this !< the GWT interface model - - ! this - call mem_deallocate(this%iAdvScheme) - call mem_deallocate(this%ixt3d) - call mem_deallocate(this%porosity) - - ! gwt packages - call this%dis%dis_da() - call this%fmi%fmi_da() - call this%adv%adv_da() - call this%dsp%dsp_da() - - deallocate(this%dis) - deallocate(this%fmi) - deallocate(this%adv) - deallocate(this%dsp) - - ! gwt scalars - call mem_deallocate(this%inic) - call mem_deallocate(this%infmi) - call mem_deallocate(this%inadv) - call mem_deallocate(this%indsp) - call mem_deallocate(this%inssm) - call mem_deallocate(this%inmst) - call mem_deallocate(this%inmvt) - call mem_deallocate(this%inoc) - call mem_deallocate(this%inobs) - - ! base - call this%NumericalModelType%model_da() - -end subroutine gwtifmod_da - - -end module GwtInterfaceModelModule \ No newline at end of file + subroutine gwtifmod_da(this) + class(GwtInterfaceModelType) :: this !< the GWT interface model + + ! this + call mem_deallocate(this%iAdvScheme) + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%porosity) + + ! gwt packages + call this%dis%dis_da() + call this%fmi%fmi_da() + call this%adv%adv_da() + call this%dsp%dsp_da() + + deallocate (this%dis) + deallocate (this%fmi) + deallocate (this%adv) + deallocate (this%dsp) + + ! gwt scalars + call mem_deallocate(this%inic) + call mem_deallocate(this%infmi) + call mem_deallocate(this%inadv) + call mem_deallocate(this%indsp) + call mem_deallocate(this%inssm) + call mem_deallocate(this%inmst) + call mem_deallocate(this%inmvt) + call mem_deallocate(this%inoc) + call mem_deallocate(this%inobs) + + ! base + call this%NumericalModelType%model_da() + + end subroutine gwtifmod_da + +end module GwtInterfaceModelModule diff --git a/src/Model/Connection/SpatialModelConnection.f90 b/src/Model/Connection/SpatialModelConnection.f90 index 19f1ba3c486..dc02bafc912 100644 --- a/src/Model/Connection/SpatialModelConnection.f90 +++ b/src/Model/Connection/SpatialModelConnection.f90 @@ -1,6 +1,6 @@ module SpatialModelConnectionModule use KindModule, only: I4B, DP, LGP - use SparseModule, only:sparsematrix + use SparseModule, only: sparsematrix use ConnectionsModule, only: ConnectionsType use CsrUtilsModule, only: getCSRIndex use SimModule, only: ustop @@ -11,63 +11,62 @@ module SpatialModelConnectionModule use MemoryHelperModule, only: create_mem_path use GridConnectionModule, only: GridConnectionType use ListModule, only: ListType - + implicit none private public :: CastAsSpatialModelConnectionClass public :: AddSpatialModelConnectionToList public :: GetSpatialModelConnectionFromList - !> Class to manage spatial connection of a model to one - !! or more models of the same type. Spatial connection here - !! means that the model domains (spatial discretization) are + !> Class to manage spatial connection of a model to one + !! or more models of the same type. Spatial connection here + !! means that the model domains (spatial discretization) are !! adjacent and connected via DisConnExchangeType object(s). - !! The connection itself is a Numerical Exchange as well, + !! The connection itself is a Numerical Exchange as well, !! and part of a Numerical Solution providing the amat and rhs !< values for the exchange. type, public, extends(NumericalExchangeType) :: SpatialModelConnectionType - class(NumericalModelType), pointer :: owner => null() !< the model whose connection this is - class(NumericalModelType), pointer :: interfaceModel => null() !< the interface model - integer(I4B), pointer :: nrOfConnections => null() !< total nr. of connected cells (primary) - - class(DisConnExchangeType), pointer :: primaryExchange => null() !< the exchange for which the interface model is created - type(ListType) :: globalExchanges !< all exchanges in the same solution - integer(I4B), pointer :: internalStencilDepth => null() !< size of the computational stencil for the interior - !! default = 1, xt3d = 2, ... - integer(I4B), pointer :: exchangeStencilDepth => null() !< size of the computational stencil at the interface - !! default = 1, xt3d = 2, ... - - + class(NumericalModelType), pointer :: owner => null() !< the model whose connection this is + class(NumericalModelType), pointer :: interfaceModel => null() !< the interface model + integer(I4B), pointer :: nrOfConnections => null() !< total nr. of connected cells (primary) + + class(DisConnExchangeType), pointer :: primaryExchange => null() !< the exchange for which the interface model is created + type(ListType) :: globalExchanges !< all exchanges in the same solution + integer(I4B), pointer :: internalStencilDepth => null() !< size of the computational stencil for the interior + !! default = 1, xt3d = 2, ... + integer(I4B), pointer :: exchangeStencilDepth => null() !< size of the computational stencil at the interface + !! default = 1, xt3d = 2, ... + ! The following variables are equivalent to those in Numerical Solution: - integer(I4B), pointer :: neq => null() !< nr. of equations in matrix system - integer(I4B), pointer :: nja => null() !< nr. of nonzero matrix elements - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< sparse indexing IA - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< sparse indexing JA - real(DP), dimension(:), pointer, contiguous :: amat => null() !< matrix coefficients - real(DP), dimension(:), pointer, contiguous :: rhs => null() !< rhs of interface system - real(DP), dimension(:), pointer, contiguous :: x => null() !< dependent variable of interface system - integer(I4B), dimension(:), pointer, contiguous :: active => null() !< cell status (c.f. ibound) of interface system - + integer(I4B), pointer :: neq => null() !< nr. of equations in matrix system + integer(I4B), pointer :: nja => null() !< nr. of nonzero matrix elements + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< sparse indexing IA + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< sparse indexing JA + real(DP), dimension(:), pointer, contiguous :: amat => null() !< matrix coefficients + real(DP), dimension(:), pointer, contiguous :: rhs => null() !< rhs of interface system + real(DP), dimension(:), pointer, contiguous :: x => null() !< dependent variable of interface system + integer(I4B), dimension(:), pointer, contiguous :: active => null() !< cell status (c.f. ibound) of interface system + ! these are not in the memory manager class(GridConnectionType), pointer :: gridConnection => null() !< facility to build the interface grid connection structure - integer(I4B), dimension(:), pointer :: mapIdxToSln => null() !< mapping between interface matrix and the solution matrix - + integer(I4B), dimension(:), pointer :: mapIdxToSln => null() !< mapping between interface matrix and the solution matrix + contains - + ! public procedure, pass(this) :: spatialConnection_ctor generic :: construct => spatialConnection_ctor ! partly overriding NumericalExchangeType: - procedure :: exg_df => spatialcon_df + procedure :: exg_df => spatialcon_df procedure :: exg_ar => spatialcon_ar procedure :: exg_ac => spatialcon_ac procedure :: exg_mc => spatialcon_mc procedure :: exg_da => spatialcon_da - + ! protected - procedure, pass(this) :: spatialcon_df + procedure, pass(this) :: spatialcon_df procedure, pass(this) :: spatialcon_ar procedure, pass(this) :: spatialcon_ac procedure, pass(this) :: spatialcon_da @@ -78,34 +77,34 @@ module SpatialModelConnectionModule ! private procedure, private, pass(this) :: setupGridConnection procedure, private, pass(this) :: setExchangeConnections - procedure, private, pass(this) :: getNrOfConnections + procedure, private, pass(this) :: getNrOfConnections procedure, private, pass(this) :: allocateScalars - procedure, private, pass(this) :: allocateArrays - procedure, private, pass(this) :: createCoefficientMatrix + procedure, private, pass(this) :: allocateArrays + procedure, private, pass(this) :: createCoefficientMatrix procedure, private, pass(this) :: maskOwnerConnections - + end type SpatialModelConnectionType contains ! module procedures - + !> @brief Construct the spatial connection base !! !! This constructor is typically called from a derived class. !< subroutine spatialConnection_ctor(this, model, exchange, name) - class(SpatialModelConnectionType) :: this !< the connection - class(NumericalModelType), intent(in), pointer :: model !< the model that owns the connection - class(DisConnExchangeType), intent(in), pointer :: exchange !< the primary exchange from which + class(SpatialModelConnectionType) :: this !< the connection + class(NumericalModelType), intent(in), pointer :: model !< the model that owns the connection + class(DisConnExchangeType), intent(in), pointer :: exchange !< the primary exchange from which !! the connection is created - character(len=*), intent(in) :: name !< the connection name (for memory management mostly) - + character(len=*), intent(in) :: name !< the connection name (for memory management mostly) + this%name = name this%memoryPath = create_mem_path(this%name) this%owner => model this%primaryExchange => exchange - allocate(this%gridConnection) + allocate (this%gridConnection) call this%allocateScalars() this%internalStencilDepth = 1 @@ -114,28 +113,29 @@ subroutine spatialConnection_ctor(this, model, exchange, name) ! this should be set in derived ctor this%interfaceModel => null() - + end subroutine spatialConnection_ctor - - + !> @brief Define this connection, mostly sets up the grid !< connection, allocates arrays, and links x,rhs, and ibound subroutine spatialcon_df(this) class(SpatialModelConnectionType) :: this !< this connection - + ! create the grid connection data structure this%nrOfConnections = this%getNrOfConnections() - call this%gridConnection%construct(this%owner, this%nrOfConnections, this%name) + call this%gridConnection%construct(this%owner, & + this%nrOfConnections, & + this%name) this%gridConnection%internalStencilDepth = this%internalStencilDepth this%gridConnection%exchangeStencilDepth = this%exchangeStencilDepth call this%setupGridConnection() - + this%neq = this%gridConnection%nrOfCells call this%allocateArrays() - + end subroutine spatialcon_df - !> @brief Allocate the connection, + !> @brief Allocate the connection, !< subroutine spatialcon_ar(this) class(SpatialModelConnectionType) :: this !< this connection @@ -143,12 +143,12 @@ subroutine spatialcon_ar(this) integer(I4B) :: icell, idx, localIdx class(GridConnectionType), pointer :: gc class(NumericalModelType), pointer :: model - + ! init x and ibound with model data gc => this%gridConnection do icell = 1, gc%nrOfCells idx = gc%idxToGlobal(icell)%index - model => gc%idxToGlobal(icell)%model + model => gc%idxToGlobal(icell)%model this%interfaceModel%x(icell) = model%x(idx) this%interfaceModel%ibound(icell) = model%ibound(idx) end do @@ -156,28 +156,34 @@ subroutine spatialcon_ar(this) ! fill mapping to global index (which can be ! done now because moffset is set in sln_df) do localIdx = 1, gc%nrOfCells - gc%idxToGlobalIdx(localIdx) = gc%idxToGlobal(localIdx)%index + & + gc%idxToGlobalIdx(localIdx) = gc%idxToGlobal(localIdx)%index + & gc%idxToGlobal(localIdx)%model%moffset end do end subroutine spatialcon_ar - !> @brief set model pointers to connection + !> @brief set model pointers to connection !< subroutine spatialcon_setmodelptrs(this) class(SpatialModelConnectionType) :: this !< this connection - + ! point x, ibound, and rhs to connection this%interfaceModel%x => this%x - call mem_checkin(this%interfaceModel%x, 'X', this%interfaceModel%memoryPath, 'X', this%memoryPath) + call mem_checkin(this%interfaceModel%x, 'X', & + this%interfaceModel%memoryPath, 'X', & + this%memoryPath) this%interfaceModel%rhs => this%rhs - call mem_checkin(this%interfaceModel%rhs, 'RHS', this%interfaceModel%memoryPath, 'RHS', this%memoryPath) + call mem_checkin(this%interfaceModel%rhs, 'RHS', & + this%interfaceModel%memoryPath, 'RHS', & + this%memoryPath) this%interfaceModel%ibound => this%active - call mem_checkin(this%interfaceModel%ibound, 'IBOUND', this%interfaceModel%memoryPath, 'IBOUND', this%memoryPath) + call mem_checkin(this%interfaceModel%ibound, 'IBOUND', & + this%interfaceModel%memoryPath, 'IBOUND', & + this%memoryPath) end subroutine spatialcon_setmodelptrs - !> @brief map interface model connections to our sparse matrix, + !> @brief map interface model connections to our sparse matrix, !< analogously to what happens in sln_connect. subroutine spatialcon_connect(this) class(SpatialModelConnectionType) :: this !< this connection @@ -186,21 +192,20 @@ subroutine spatialcon_connect(this) call sparse%init(this%neq, this%neq, 7) call this%interfaceModel%model_ac(sparse) - + ! create amat from sparse call this%createCoefficientMatrix(sparse) call sparse%destroy() - + ! map connections call this%interfaceModel%model_mc(this%ia, this%ja) call this%maskOwnerConnections() end subroutine spatialcon_connect - !> @brief Mask the owner's connections !! - !! Determine which connections are handled by the interface model + !! Determine which connections are handled by the interface model !! (using the connections object in its discretization) and !< set their mask to zero for the owning model. subroutine maskOwnerConnections(this) @@ -209,113 +214,121 @@ subroutine maskOwnerConnections(this) ! local integer(I4B) :: ipos, n, m, nloc, mloc, csrIdx type(ConnectionsType), pointer :: conn - + ! set the mask on connections that are calculated by the interface model conn => this%interfaceModel%dis%con do n = 1, conn%nodes ! only for connections internal to the owning model - if (.not. associated(this%gridConnection%idxToGlobal(n)%model, this%owner)) then + if (.not. associated(this%gridConnection%idxToGlobal(n)%model, & + this%owner)) then cycle end if nloc = this%gridConnection%idxToGlobal(n)%index - + do ipos = conn%ia(n) + 1, conn%ia(n + 1) - 1 m = conn%ja(ipos) - if (.not. associated(this%gridConnection%idxToGlobal(m)%model, this%owner)) then - cycle + if (.not. associated(this%gridConnection%idxToGlobal(m)%model, & + this%owner)) then + cycle end if mloc = this%gridConnection%idxToGlobal(m)%index - + if (conn%mask(ipos) > 0) then ! calculated by interface model, set local model's mask to zero - csrIdx = getCSRIndex(nloc, mloc, this%owner%ia, this%owner%ja) + csrIdx = getCSRIndex(nloc, mloc, this%owner%ia, this%owner%ja) if (csrIdx == -1) then - ! this can only happen with periodic boundary conditions, + ! this can only happen with periodic boundary conditions, ! then there is no need to set the mask if (this%gridConnection%isPeriodic(nloc, mloc)) cycle - - write(*,*) 'Error: cannot find cell connection in global system' + + write (*, *) 'Error: cannot find cell connection in global system' call ustop() - end if + end if if (this%owner%dis%con%mask(csrIdx) > 0) then call this%owner%dis%con%set_mask(csrIdx, 0) else ! edge case, someone will be calculating this connection ! so we ignore it here (TODO_MJR: add name) - write(*,*) 'Debug: overlap detected, ignoring connection ', & - nloc, ':', mloc, ' for model ', trim(this%owner%name), & - ' in Exchange ???' + write (*, *) 'Debug: overlap detected, ignoring connection ', & + nloc, ':', mloc, ' for model ', trim(this%owner%name), & + ' in Exchange ???' call conn%set_mask(ipos, 0) end if end if end do end do - + end subroutine maskOwnerConnections !> @brief Add connections, handled by the interface model, !< to the global system's sparse - subroutine spatialcon_ac(this, sparse) - class(SpatialModelConnectionType) :: this !< this connection + subroutine spatialcon_ac(this, sparse) + class(SpatialModelConnectionType) :: this !< this connection type(sparsematrix), intent(inout) :: sparse !< sparse matrix to store the connections ! local integer(I4B) :: n, m, ipos integer(I4B) :: nglo, mglo - + do n = 1, this%neq - if (.not. associated(this%gridConnection%idxToGlobal(n)%model, this%owner)) then + if (.not. associated(this%gridConnection%idxToGlobal(n)%model, & + this%owner)) then ! only add connections for own model to global matrix cycle end if - nglo = this%gridConnection%idxToGlobal(n)%index + this%gridConnection%idxToGlobal(n)%model%moffset - do ipos = this%ia(n) + 1, this%ia(n+1) - 1 + nglo = this%gridConnection%idxToGlobal(n)%index + & + this%gridConnection%idxToGlobal(n)%model%moffset + do ipos = this%ia(n) + 1, this%ia(n + 1) - 1 m = this%ja(ipos) - mglo = this%gridConnection%idxToGlobal(m)%index + this%gridConnection%idxToGlobal(m)%model%moffset - + mglo = this%gridConnection%idxToGlobal(m)%index + & + this%gridConnection%idxToGlobal(m)%model%moffset + call sparse%addconnection(nglo, mglo, 1) end do end do - + end subroutine spatialcon_ac - !> @brief Creates the mapping from the local system + !> @brief Creates the mapping from the local system !< matrix to the global one subroutine spatialcon_mc(this, iasln, jasln) use SimModule, only: ustop - class(SpatialModelConnectionType) :: this !< this connection + class(SpatialModelConnectionType) :: this !< this connection integer(I4B), dimension(:), intent(in) :: iasln !< global IA array integer(I4B), dimension(:), intent(in) :: jasln !< global JA array ! local integer(I4B) :: m, n, mglo, nglo, ipos, csrIdx logical(LGP) :: isOwnedConnection - - allocate(this%mapIdxToSln(this%nja)) - - do n = 1, this%neq - isOwnedConnection = associated(this%gridConnection%idxToGlobal(n)%model, this%owner) - do ipos = this%ia(n), this%ia(n+1)-1 - m = this%ja(ipos) - nglo = this%gridConnection%idxToGlobal(n)%index + this%gridConnection%idxToGlobal(n)%model%moffset - mglo = this%gridConnection%idxToGlobal(m)%index + this%gridConnection%idxToGlobal(m)%model%moffset + + allocate (this%mapIdxToSln(this%nja)) + + do n = 1, this%neq + isOwnedConnection = associated(this%gridConnection%idxToGlobal(n)%model, & + this%owner) + do ipos = this%ia(n), this%ia(n + 1) - 1 + m = this%ja(ipos) + nglo = this%gridConnection%idxToGlobal(n)%index + & + this%gridConnection%idxToGlobal(n)%model%moffset + mglo = this%gridConnection%idxToGlobal(m)%index + & + this%gridConnection%idxToGlobal(m)%model%moffset csrIdx = getCSRIndex(nglo, mglo, iasln, jasln) if (csrIdx == -1 .and. isOwnedConnection) then ! this should not be possible - write(*,*) 'Error: cannot find cell connection in global system' + write (*, *) 'Error: cannot find cell connection in global system' call ustop() end if - + this%mapIdxToSln(ipos) = csrIdx end do end do - + end subroutine spatialcon_mc - + !> @brief Deallocation !< subroutine spatialcon_da(this) class(SpatialModelConnectionType) :: this !< this connection - + call mem_deallocate(this%neq) call mem_deallocate(this%nja) call mem_deallocate(this%internalStencilDepth) @@ -325,41 +338,41 @@ subroutine spatialcon_da(this) call mem_deallocate(this%ia) call mem_deallocate(this%ja) call mem_deallocate(this%amat) - + call mem_deallocate(this%x) call mem_deallocate(this%rhs) call mem_deallocate(this%active) - + call this%gridConnection%destroy() - deallocate(this%gridConnection) - deallocate(this%mapIdxToSln) - + deallocate (this%gridConnection) + deallocate (this%mapIdxToSln) + end subroutine spatialcon_da - + !> @brief Set up the grid connection !! !! This works in three steps: !! 1. set the primary connections - !! 2. create the topology of connected models, finding + !! 2. create the topology of connected models, finding !! neighbors of neighboring models when required !! 3. extend the interface grid, using that information !< subroutine setupGridConnection(this) class(SpatialModelConnectionType) :: this !< this connection ! local - + ! set boundary cells call this%setExchangeConnections() - + ! create topology of models - call this%gridConnection%findModelNeighbors(this%globalExchanges, & + call this%gridConnection%findModelNeighbors(this%globalExchanges, & this%exchangeStencilDepth) - - ! now scan for nbr-of-nbrs and create final data structures + + ! now scan for nbr-of-nbrs and create final data structures call this%gridConnection%extendConnection() - + end subroutine setupGridConnection - + !> @brief Set the primary connections from the exchange data !< subroutine setExchangeConnections(this) @@ -367,31 +380,30 @@ subroutine setExchangeConnections(this) ! local integer(I4B) :: iconn type(DisConnExchangeType), pointer :: connEx - + ! set boundary cells connEx => this%primaryExchange - do iconn=1, connEx%nexg + do iconn = 1, connEx%nexg call this%gridConnection%connectCell(connEx%nodem1(iconn), connEx%model1, & connEx%nodem2(iconn), connEx%model2) end do - + end subroutine setExchangeConnections - !> @brief Allocation of scalars !< subroutine allocateScalars(this) use MemoryManagerModule, only: mem_allocate class(SpatialModelConnectionType) :: this !< this connection - + call mem_allocate(this%neq, 'NEQ', this%memoryPath) call mem_allocate(this%nja, 'NJA', this%memoryPath) call mem_allocate(this%internalStencilDepth, 'INTSTDEPTH', this%memoryPath) call mem_allocate(this%exchangeStencilDepth, 'EXGSTDEPTH', this%memoryPath) call mem_allocate(this%nrOfConnections, 'NROFCONNS', this%memoryPath) - + end subroutine allocateScalars - + !> @brief Allocation of arrays !< subroutine allocateArrays(this) @@ -400,40 +412,40 @@ subroutine allocateArrays(this) class(SpatialModelConnectionType) :: this !< this connection ! local integer(I4B) :: i - + call mem_allocate(this%x, this%neq, 'X', this%memoryPath) call mem_allocate(this%rhs, this%neq, 'RHS', this%memoryPath) call mem_allocate(this%active, this%neq, 'IACTIVE', this%memoryPath) - + ! c.f. NumericalSolution do i = 1, this%neq this%x(i) = DZERO this%active(i) = 1 ! default is active this%rhs(i) = DZERO - enddo - + end do + end subroutine allocateArrays - + !> @brief Returns total nr. of primary connections !< function getNrOfConnections(this) result(nrConns) class(SpatialModelConnectionType) :: this !< this connection - integer(I4B) :: nrConns + integer(I4B) :: nrConns !local - + nrConns = this%primaryExchange%nexg - + end function getNrOfConnections - + !> @brief Create connection's matrix (ia,ja,amat) from sparse !< subroutine createCoefficientMatrix(this, sparse) use SimModule, only: ustop - class(SpatialModelConnectionType) :: this !< this connection + class(SpatialModelConnectionType) :: this !< this connection type(sparsematrix), intent(inout) :: sparse !< the sparse matrix with the cell connections ! local integer(I4B) :: ierror - + this%nja = sparse%nnz call mem_allocate(this%ia, this%neq + 1, 'IA', this%memoryPath) call mem_allocate(this%ja, this%nja, 'JA', this%memoryPath) @@ -443,10 +455,10 @@ subroutine createCoefficientMatrix(this, sparse) call sparse%filliaja(this%ia, this%ja, ierror) if (ierror /= 0) then - write(*,*) 'Error: cannot fill ia/ja for model connection' + write (*, *) 'Error: cannot fill ia/ja for model connection' call ustop() end if - + end subroutine createCoefficientMatrix !> @brief Validate this connection @@ -459,31 +471,30 @@ subroutine validateConnection(this) class(DisConnExchangeType), pointer :: conEx => null() conEx => this%primaryExchange - if (conEx%ixt3d > 0) then + if (conEx%ixt3d > 0) then ! if XT3D, we need these angles: if (conEx%model1%dis%con%ianglex == 0) then - write(errmsg, '(1x,a,a,a,a,a)') 'XT3D configured on the exchange ', & - trim(conEx%name), ' but the discretization in model ', & - trim(conEx%model1%name), ' has no ANGLDEGX specified' + write (errmsg, '(1x,a,a,a,a,a)') 'XT3D configured on the exchange ', & + trim(conEx%name), ' but the discretization in model ', & + trim(conEx%model1%name), ' has no ANGLDEGX specified' call store_error(errmsg) end if if (conEx%model2%dis%con%ianglex == 0) then - write(errmsg, '(1x,a,a,a,a,a)') 'XT3D configured on the exchange ', & - trim(conEx%name), ' but the discretization in model ', & - trim(conEx%model2%name), ' has no ANGLDEGX specified' + write (errmsg, '(1x,a,a,a,a,a)') 'XT3D configured on the exchange ', & + trim(conEx%name), ' but the discretization in model ', & + trim(conEx%model2%name), ' has no ANGLDEGX specified' call store_error(errmsg) end if end if end subroutine validateConnection - !> @brief Cast to SpatialModelConnectionType !< - function CastAsSpatialModelConnectionClass(obj) result (res) + function CastAsSpatialModelConnectionClass(obj) result(res) implicit none - class(*), pointer, intent(inout) :: obj !< object to be cast - class(SpatialModelConnectionType), pointer :: res !< the instance of SpatialModelConnectionType + class(*), pointer, intent(inout) :: obj !< object to be cast + class(SpatialModelConnectionType), pointer :: res !< the instance of SpatialModelConnectionType ! res => null() if (.not. associated(obj)) return @@ -500,8 +511,8 @@ end function CastAsSpatialModelConnectionClass subroutine AddSpatialModelConnectionToList(list, conn) implicit none ! -- dummy - type(ListType), intent(inout) :: list !< the list - class(SpatialModelConnectionType), pointer, intent(in) :: conn !< the connection + type(ListType), intent(inout) :: list !< the list + class(SpatialModelConnectionType), pointer, intent(in) :: conn !< the connection ! -- local class(*), pointer :: obj ! @@ -514,16 +525,16 @@ end subroutine AddSpatialModelConnectionToList !> @brief Get the connection from a list !< function GetSpatialModelConnectionFromList(list, idx) result(res) - type(ListType), intent(inout) :: list !< the list - integer(I4B), intent(in) :: idx !< the index of the connection + type(ListType), intent(inout) :: list !< the list + integer(I4B), intent(in) :: idx !< the index of the connection class(SpatialModelConnectionType), pointer :: res !< the returned connection - + ! local class(*), pointer :: obj obj => list%GetItem(idx) res => CastAsSpatialModelConnectionClass(obj) ! return - end function GetSpatialModelConnectionFromList - + end function GetSpatialModelConnectionFromList + end module SpatialModelConnectionModule From d6d236db1b78947b18fb07c7322424ec53271dda Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 17:08:37 -0700 Subject: [PATCH 010/212] Updating the contents of the src/Model/Geometry directory with the fprettify stuff. I didn't have any local changes in this directory. --- src/Model/Geometry/BaseGeometry.f90 | 39 +++++----- src/Model/Geometry/CircularGeometry.f90 | 85 +++++++++++----------- src/Model/Geometry/RectangularGeometry.f90 | 66 ++++++++--------- 3 files changed, 95 insertions(+), 95 deletions(-) diff --git a/src/Model/Geometry/BaseGeometry.f90 b/src/Model/Geometry/BaseGeometry.f90 index 39bc2be3d4e..0216abb793f 100644 --- a/src/Model/Geometry/BaseGeometry.f90 +++ b/src/Model/Geometry/BaseGeometry.f90 @@ -1,13 +1,13 @@ module BaseGeometryModule - + use KindModule, only: DP, I4B - + implicit none private public BaseGeometryType - + integer(I4B), parameter :: GEONAMELEN = 20 - + type :: BaseGeometryType character(len=20) :: geo_type = 'UNDEFINED' integer(I4B) :: id = 0 @@ -21,8 +21,8 @@ module BaseGeometryModule procedure :: print_attributes end type BaseGeometryType - contains - +contains + function area_sat(this) ! -- return real(DP) :: area_sat @@ -32,8 +32,8 @@ function area_sat(this) ! -- return return end function area_sat - - function perimeter_sat(this) + + function perimeter_sat(this) ! -- return real(DP) :: perimeter_sat ! -- dummy @@ -42,29 +42,29 @@ function perimeter_sat(this) ! -- return return end function perimeter_sat - + function area_wet(this, depth) ! -- return real(DP) :: area_wet ! -- dummy class(BaseGeometryType) :: this - real(DP), intent(in) :: depth + real(DP), intent(in) :: depth area_wet = 0.d0 ! -- return return end function area_wet - + function perimeter_wet(this, depth) ! -- return real(DP) :: perimeter_wet ! -- dummy class(BaseGeometryType) :: this - real(DP), intent(in) :: depth + real(DP), intent(in) :: depth perimeter_wet = 0.d0 ! -- return return end function perimeter_wet - + subroutine set_attribute(this, line) ! -- dummy class(BaseGeometryType) :: this @@ -72,7 +72,7 @@ subroutine set_attribute(this, line) ! -- return return end subroutine set_attribute - + subroutine print_attributes(this, iout) ! ****************************************************************************** ! print_attributes -- print the attributes for this object @@ -89,13 +89,12 @@ subroutine print_attributes(this, iout) character(len=*), parameter :: fmtnm = "(4x,a,a)" ! ------------------------------------------------------------------------------ ! - write(iout, fmtid) 'ID = ', this%id - write(iout, fmtnm) 'NAME = ', trim(adjustl(this%name)) - write(iout, fmtnm) 'GEOMETRY TYPE = ', trim(adjustl(this%geo_type)) + write (iout, fmtid) 'ID = ', this%id + write (iout, fmtnm) 'NAME = ', trim(adjustl(this%name)) + write (iout, fmtnm) 'GEOMETRY TYPE = ', trim(adjustl(this%geo_type)) ! ! -- return return end subroutine print_attributes - - -end module BaseGeometryModule \ No newline at end of file + +end module BaseGeometryModule diff --git a/src/Model/Geometry/CircularGeometry.f90 b/src/Model/Geometry/CircularGeometry.f90 index b2c8cfcef5e..c49f4179e14 100644 --- a/src/Model/Geometry/CircularGeometry.f90 +++ b/src/Model/Geometry/CircularGeometry.f90 @@ -7,7 +7,7 @@ module CircularGeometryModule private public :: CircularGeometryType - + type, extends(BaseGeometryType) :: CircularGeometryType real(DP) :: radius = DZERO contains @@ -18,9 +18,9 @@ module CircularGeometryModule procedure :: set_attribute procedure :: print_attributes end type CircularGeometryType - - contains - + +contains + function area_sat(this) ! ****************************************************************************** ! area_sat -- return area as if geometry is fully saturated @@ -37,12 +37,12 @@ function area_sat(this) ! ------------------------------------------------------------------------------ ! ! -- Calculate area - area_sat = DPI * this%radius ** DTWO + area_sat = DPI * this%radius**DTWO ! ! -- Return return end function area_sat - + function perimeter_sat(this) ! ****************************************************************************** ! perimeter_sat -- return perimeter as if geometry is fully saturated @@ -64,7 +64,7 @@ function perimeter_sat(this) ! -- return return end function perimeter_sat - + function area_wet(this, depth) ! ****************************************************************************** ! area_wet -- return wetted area @@ -82,25 +82,26 @@ function area_wet(this, depth) ! ------------------------------------------------------------------------------ ! ! -- Calculate area - if(depth <= DZERO) then - area_wet = DZERO - elseif(depth <= this%radius) then - area_wet = this%radius * this%radius * & - acos((this%radius - depth) / this%radius) - & - (this%radius - depth) * sqrt(this%radius * this%radius - & - (this%radius - depth) ** DTWO) - elseif(depth <= DTWO * this%radius) then - area_wet = this%radius * this%radius * (DPI - acos((depth - this%radius) & - / this%radius)) - (this%radius - depth) * sqrt(this%radius * & - this%radius - (this%radius - depth) ** DTWO) + if (depth <= DZERO) then + area_wet = DZERO + elseif (depth <= this%radius) then + area_wet = this%radius * this%radius * & + acos((this%radius - depth) / this%radius) - & + (this%radius - depth) * & + sqrt(this%radius * this%radius - (this%radius - depth)**DTWO) + elseif (depth <= DTWO * this%radius) then + area_wet = this%radius * this%radius * & + (DPI - acos((depth - this%radius) / this%radius)) - & + (this%radius - depth) * & + sqrt(this%radius * this%radius - (this%radius - depth)**DTWO) else area_wet = DPI * this%radius * this%radius - endif + end if ! ! -- Return return end function area_wet - + function perimeter_wet(this, depth) ! ****************************************************************************** ! perimeter_wet -- return wetted perimeter @@ -118,22 +119,22 @@ function perimeter_wet(this, depth) ! ------------------------------------------------------------------------------ ! ! -- Calculate area - if(depth <= DZERO) then - perimeter_wet = DZERO - elseif(depth <= this%radius) then - perimeter_wet = DTWO * this%radius * acos((this%radius - depth) / & - this%radius) - elseif(depth <= DTWO * this%radius) then + if (depth <= DZERO) then + perimeter_wet = DZERO + elseif (depth <= this%radius) then + perimeter_wet = DTWO * this%radius * acos((this%radius - depth) / & + this%radius) + elseif (depth <= DTWO * this%radius) then perimeter_wet = DTWO * this%radius * (DPI - acos((depth - this%radius) / & - this%radius)) + this%radius)) else perimeter_wet = DTWO * DPI * this%radius - endif + end if ! ! -- return return end function perimeter_wet - + subroutine set_attribute(this, line) ! ****************************************************************************** ! set_attribute -- set a parameter for this circular object @@ -153,23 +154,23 @@ subroutine set_attribute(this, line) integer(I4B) :: lloc, istart, istop, ival real(DP) :: rval ! ------------------------------------------------------------------------------ - ! + ! ! -- should change this and set id if uninitialized or store it - lloc=1 + lloc = 1 call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) this%id = ival - + ! -- Parse the attribute call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('NAME') + select case (line(istart:istop)) + case ('NAME') call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) this%name = line(istart:istop) - case('RADIUS') + case ('RADIUS') call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%radius = rval + this%radius = rval case default - write(errmsg,'(4x,a,a)') & + write (errmsg, '(4x,a,a)') & 'Unknown circular geometry attribute: ', line(istart:istop) call store_error(errmsg, terminate=.TRUE.) end select @@ -198,12 +199,12 @@ subroutine print_attributes(this, iout) call this%BaseGeometryType%print_attributes(iout) ! ! -- Print specifics of this geometry type - write(iout, fmttd) 'RADIUS = ', this%radius - write(iout, fmttd) 'SATURATED AREA = ', this%area_sat() - write(iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() + write (iout, fmttd) 'RADIUS = ', this%radius + write (iout, fmttd) 'SATURATED AREA = ', this%area_sat() + write (iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() ! ! -- return return end subroutine print_attributes - -end module CircularGeometryModule \ No newline at end of file + +end module CircularGeometryModule diff --git a/src/Model/Geometry/RectangularGeometry.f90 b/src/Model/Geometry/RectangularGeometry.f90 index 59caca65127..dfe89ac50b4 100644 --- a/src/Model/Geometry/RectangularGeometry.f90 +++ b/src/Model/Geometry/RectangularGeometry.f90 @@ -5,10 +5,10 @@ module RectangularGeometryModule implicit none private public :: RectangularGeometryType - + type, extends(BaseGeometryType) :: RectangularGeometryType real(DP) :: height = DZERO - real(DP) :: width = DZERO + real(DP) :: width = DZERO contains procedure :: area_sat procedure :: perimeter_sat @@ -17,9 +17,9 @@ module RectangularGeometryModule procedure :: set_attribute procedure :: print_attributes end type RectangularGeometryType - - contains - + +contains + function area_sat(this) ! ****************************************************************************** ! area_sat -- return saturated area @@ -41,7 +41,7 @@ function area_sat(this) ! -- Return return end function area_sat - + function perimeter_sat(this) ! ****************************************************************************** ! perimeter_sat -- return saturated perimeter @@ -63,7 +63,7 @@ function perimeter_sat(this) ! -- return return end function perimeter_sat - + function area_wet(this, depth) ! ****************************************************************************** ! area_wet -- return wetted area @@ -81,18 +81,18 @@ function area_wet(this, depth) ! ------------------------------------------------------------------------------ ! ! -- Calculate area - if(depth <= DZERO) then - area_wet = DZERO - elseif(depth <= this%height) then + if (depth <= DZERO) then + area_wet = DZERO + elseif (depth <= this%height) then area_wet = depth * this%width else area_wet = this%width * this%height - endif + end if ! ! -- Return return end function area_wet - + function perimeter_wet(this, depth) ! ****************************************************************************** ! perimeter_wet -- return wetted perimeter @@ -110,18 +110,18 @@ function perimeter_wet(this, depth) ! ------------------------------------------------------------------------------ ! ! -- Calculate area - if(depth <= DZERO) then - perimeter_wet = DZERO - elseif(depth <= this%height) then + if (depth <= DZERO) then + perimeter_wet = DZERO + elseif (depth <= this%height) then perimeter_wet = DTWO * (depth + this%width) else perimeter_wet = DTWO * (this%height + this%width) - endif + end if ! ! -- return return end function perimeter_wet - + subroutine set_attribute(this, line) ! ****************************************************************************** ! set_attribute -- set a parameter for this rectangular object @@ -141,26 +141,26 @@ subroutine set_attribute(this, line) integer(I4B) :: lloc, istart, istop, ival real(DP) :: rval ! ------------------------------------------------------------------------------ - ! + ! ! -- should change this and set id if uninitialized or store it - lloc=1 + lloc = 1 call urword(line, lloc, istart, istop, 2, ival, rval, 0, 0) this%id = ival - + ! -- Parse the attribute call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) - select case(line(istart:istop)) - case('NAME') + select case (line(istart:istop)) + case ('NAME') call urword(line, lloc, istart, istop, 1, ival, rval, 0, 0) this%name = line(istart:istop) - case('HEIGHT') + case ('HEIGHT') call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%height = rval - case('WIDTH') + this%height = rval + case ('WIDTH') call urword(line, lloc, istart, istop, 3, ival, rval, 0, 0) - this%width = rval + this%width = rval case default - write(errmsg,'(4x,a,a)') & + write (errmsg, '(4x,a,a)') & 'Unknown rectangular geometry attribute: ', line(istart:istop) call store_error(errmsg, terminate=.TRUE.) end select @@ -189,13 +189,13 @@ subroutine print_attributes(this, iout) call this%BaseGeometryType%print_attributes(iout) ! ! -- Print specifics of this geometry type - write(iout, fmttd) 'HEIGHT = ', this%height - write(iout, fmttd) 'WIDTH = ', this%width - write(iout, fmttd) 'SATURATED AREA = ', this%area_sat() - write(iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() + write (iout, fmttd) 'HEIGHT = ', this%height + write (iout, fmttd) 'WIDTH = ', this%width + write (iout, fmttd) 'SATURATED AREA = ', this%area_sat() + write (iout, fmttd) 'SATURATED WETTED PERIMETER = ', this%perimeter_sat() ! ! -- return return end subroutine print_attributes - -end module RectangularGeometryModule \ No newline at end of file + +end module RectangularGeometryModule From 987079688b02bbf3218771632848aca09bb06c4e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 19:43:42 -0700 Subject: [PATCH 011/212] Updating the contents of the src/Model/GroundWaterTransport directory with the fprettify stuff. For completeness, probably best to rerun fprettify on all the materials in this directory (19 files) --- src/Model/GroundWaterTransport/gwt1.f90 | 640 ++++++------ src/Model/GroundWaterTransport/gwt1apt1.f90 | 947 +++++++++--------- src/Model/GroundWaterTransport/gwt1dsp.f90 | 409 ++++---- src/Model/GroundWaterTransport/gwt1ist1.f90 | 743 +++++++------- src/Model/GroundWaterTransport/gwt1lkt1.f90 | 325 +++--- src/Model/GroundWaterTransport/gwt1mst1.f90 | 827 ++++++++------- src/Model/GroundWaterTransport/gwt1mwt1.f90 | 223 ++--- src/Model/GroundWaterTransport/gwt1sft1.f90 | 306 +++--- src/Model/GroundWaterTransport/gwt1src1.f90 | 108 +- src/Model/GroundWaterTransport/gwt1uzt1.f90 | 246 +++-- .../{gwt1adv1.f90 => tsp1adv1.f90} | 226 +++-- .../{gwt1cnc1.f90 => tsp1cnc1.f90} | 153 +-- .../{gwt1fmi1.f90 => tsp1fmi1.f90} | 704 ++++++------- .../{gwt1ic1.f90 => tsp1ic1.f90} | 62 +- .../{gwt1mvt1.f90 => tsp1mvt1.f90} | 339 ++++--- .../{gwt1obs1.f90 => tsp1obs1.f90} | 162 +-- .../{gwt1oc1.f90 => tsp1oc1.f90} | 70 +- .../{gwt1ssm1.f90 => tsp1ssm1.f90} | 481 ++++----- 18 files changed, 3491 insertions(+), 3480 deletions(-) rename src/Model/GroundWaterTransport/{gwt1adv1.f90 => tsp1adv1.f90} (78%) rename src/Model/GroundWaterTransport/{gwt1cnc1.f90 => tsp1cnc1.f90} (81%) rename src/Model/GroundWaterTransport/{gwt1fmi1.f90 => tsp1fmi1.f90} (74%) rename src/Model/GroundWaterTransport/{gwt1ic1.f90 => tsp1ic1.f90} (68%) rename src/Model/GroundWaterTransport/{gwt1mvt1.f90 => tsp1mvt1.f90} (81%) rename src/Model/GroundWaterTransport/{gwt1obs1.f90 => tsp1obs1.f90} (71%) rename src/Model/GroundWaterTransport/{gwt1oc1.f90 => tsp1oc1.f90} (54%) rename src/Model/GroundWaterTransport/{gwt1ssm1.f90 => tsp1ssm1.f90} (73%) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 04e0ebb8977..17eaccda6b9 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -1,31 +1,32 @@ ! Groundwater Transport (GWT) Model ! The following are additional features/checks to add -! * Add check that discretization is the same between both models +! * Add check that discretization is the same between both models ! * Consider implementation of steady-state transport (affects MST, IST) ! * Check and handle pore space discrepancy between flow and transport (porosity vs specific yield) ! * UZT may not have the required porosity term - + module GwtModule - use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, upcase - use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC - use VersionModule, only: write_listfile_header - use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType - use BaseModelModule, only: BaseModelType - use BndModule, only: BndType, AddBndToList, GetBndFromList - use GwtIcModule, only: GwtIcType - use GwtFmiModule, only: GwtFmiType - use GwtAdvModule, only: GwtAdvType - use GwtDspModule, only: GwtDspType - use GwtSsmModule, only: GwtSsmType - use GwtMvtModule, only: GwtMvtType - use GwtMstModule, only: GwtMstType - use GwtOcModule, only: GwtOcType - use GwtObsModule, only: GwtObsType - use BudgetModule, only: BudgetType - + use KindModule, only: DP, I4B + use InputOutputModule, only: ParseLine, upcase + use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC + use VersionModule, only: write_listfile_header + use NumericalModelModule, only: NumericalModelType + use TransportModelModule, only: TransportModelType + use BaseModelModule, only: BaseModelType + use BndModule, only: BndType, AddBndToList, GetBndFromList + use TspIcModule, only: TspIcType + use TspFmiModule, only: TspFmiType + use TspAdvModule, only: TspAdvType + use TspSsmModule, only: TspSsmType + use TspMvtModule, only: TspMvtType + use TspOcModule, only: TspOcType + use TspObsModule, only: TspObsType + use GwtDspModule, only: GwtDspType + use GwtMstModule, only: GwtMstType + use BudgetModule, only: BudgetType + use TspLabelsModule, only: TspLabelsType + implicit none private @@ -34,44 +35,45 @@ module GwtModule public :: CastAsGwtModel type, extends(TransportModelType) :: GwtModelType - - type(GwtIcType), pointer :: ic => null() ! initial conditions package - type(GwtFmiType), pointer :: fmi => null() ! flow model interface - type(GwtMstType), pointer :: mst => null() ! mass storage and transfer package - type(GwtAdvType), pointer :: adv => null() ! advection package - type(GwtDspType), pointer :: dsp => null() ! dispersion package - type(GwtSsmType), pointer :: ssm => null() ! source sink mixing package - type(GwtMvtType), pointer :: mvt => null() ! mover transport package - type(GwtOcType), pointer :: oc => null() ! output control package - type(GwtObsType), pointer :: obs => null() ! observation package - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: infmi => null() ! unit number FMI - integer(I4B), pointer :: inmvt => null() ! unit number MVT - integer(I4B), pointer :: inmst => null() ! unit number MST - integer(I4B), pointer :: inadv => null() ! unit number ADV - integer(I4B), pointer :: indsp => null() ! unit number DSP - integer(I4B), pointer :: inssm => null() ! unit number SSM - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: inobs => null() ! unit number OBS - + + type(TspLabelsType), pointer :: tsplabel => null() ! object defining the appropriate labels + type(TspIcType), pointer :: ic => null() ! initial conditions package + type(TspFmiType), pointer :: fmi => null() ! flow model interface + type(TspAdvType), pointer :: adv => null() ! advection package + type(TspSsmType), pointer :: ssm => null() ! source sink mixing package + type(TspMvtType), pointer :: mvt => null() ! mover transport package + type(TspOcType), pointer :: oc => null() ! output control package + type(TspObsType), pointer :: obs => null() ! observation package + type(GwtMstType), pointer :: mst => null() ! mass storage and transfer package + type(GwtDspType), pointer :: dsp => null() ! dispersion package + type(BudgetType), pointer :: budget => null() ! budget object + integer(I4B), pointer :: inic => null() ! unit number IC + integer(I4B), pointer :: infmi => null() ! unit number FMI + integer(I4B), pointer :: inmvt => null() ! unit number MVT + integer(I4B), pointer :: inmst => null() ! unit number MST + integer(I4B), pointer :: inadv => null() ! unit number ADV + integer(I4B), pointer :: indsp => null() ! unit number DSP + integer(I4B), pointer :: inssm => null() ! unit number SSM + integer(I4B), pointer :: inoc => null() ! unit number OC + integer(I4B), pointer :: inobs => null() ! unit number OBS + contains - - procedure :: model_df => gwt_df - procedure :: model_ac => gwt_ac - procedure :: model_mc => gwt_mc - procedure :: model_ar => gwt_ar - procedure :: model_rp => gwt_rp - procedure :: model_ad => gwt_ad - procedure :: model_cf => gwt_cf - procedure :: model_fc => gwt_fc - procedure :: model_cc => gwt_cc - procedure :: model_cq => gwt_cq - procedure :: model_bd => gwt_bd - procedure :: model_ot => gwt_ot - procedure :: model_da => gwt_da - procedure :: model_bdentry => gwt_bdentry - + + procedure :: model_df => gwt_df + procedure :: model_ac => gwt_ac + procedure :: model_mc => gwt_mc + procedure :: model_ar => gwt_ar + procedure :: model_rp => gwt_rp + procedure :: model_ad => gwt_ad + procedure :: model_cf => gwt_cf + procedure :: model_fc => gwt_fc + procedure :: model_cc => gwt_cc + procedure :: model_cq => gwt_cq + procedure :: model_bd => gwt_bd + procedure :: model_ot => gwt_ot + procedure :: model_da => gwt_da + procedure :: model_bdentry => gwt_bdentry + procedure :: allocate_scalars procedure, private :: package_create procedure, private :: ftype_check @@ -81,21 +83,21 @@ module GwtModule procedure, private :: gwt_ot_dv procedure, private :: gwt_ot_bdsummary procedure, private :: gwt_ot_obs - + end type GwtModelType ! -- Module variables constant for simulation - integer(I4B), parameter :: NIUNIT=100 - character(len=LENFTYPE), dimension(NIUNIT) :: cunit - data cunit/ 'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 - 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 - 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 - 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - 'API6 ', ' ', ' ', ' ', ' ', & ! 25 - 75 * ' '/ - - contains - + !integer(I4B), parameter :: NIUNIT = 100 + !character(len=LENFTYPE), dimension(NIUNIT) :: cunit + !data cunit/'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 + ! &'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 + ! &'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 + ! &'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 + ! &'API6 ', ' ', ' ', ' ', ' ', & ! 25 + ! &75*' '/ + +contains + subroutine gwt_cr(filename, id, modelname) ! ****************************************************************************** ! gwt_cr -- Create a new groundwater transport model object @@ -104,45 +106,47 @@ subroutine gwt_cr(filename, id, modelname) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ListsModule, only: basemodellist - use BaseModelModule, only: AddBaseModelToList - use SimModule, only: store_error, count_errors - use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use ListsModule, only: basemodellist + use BaseModelModule, only: AddBaseModelToList + use SimModule, only: store_error, count_errors + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CompilerVersion - use MemoryManagerModule, only: mem_allocate - use MemoryHelperModule, only: create_mem_path - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use GwtIcModule, only: ic_cr - use GwtFmiModule, only: fmi_cr - use GwtMstModule, only: mst_cr - use GwtAdvModule, only: adv_cr - use GwtDspModule, only: dsp_cr - use GwtSsmModule, only: ssm_cr - use GwtMvtModule, only: mvt_cr - use GwtOcModule, only: oc_cr - use GwtObsModule, only: gwt_obs_cr - use BudgetModule, only: budget_cr - use NameFileModule, only: NameFileType + use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path + use GwfDisModule, only: dis_cr + use GwfDisvModule, only: disv_cr + use GwfDisuModule, only: disu_cr + use TspIcModule, only: ic_cr + use TspFmiModule, only: fmi_cr + use TspAdvModule, only: adv_cr + use TspSsmModule, only: ssm_cr + use TspMvtModule, only: mvt_cr + use TspOcModule, only: oc_cr + use TspObsModule, only: tsp_obs_cr + use GwtMstModule, only: mst_cr + use GwtDspModule, only: dsp_cr + use BudgetModule, only: budget_cr + use TspLabelsModule, only: tsplabels_cr + use NameFileModule, only: NameFileType ! -- dummy - character(len=*), intent(in) :: filename - integer(I4B), intent(in) :: id - character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: id + character(len=*), intent(in) :: modelname ! -- local integer(I4B) :: indis, indis6, indisu6, indisv6 integer(I4B) :: ipakid, i, j, iu, ipaknum character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname type(NameFileType) :: namefile_obj - type(GwtModelType), pointer :: this - class(BaseModelType), pointer :: model + type(GwtModelType), pointer :: this + class(BaseModelType), pointer :: model integer(I4B) :: nwords character(len=LINELENGTH), allocatable, dimension(:) :: words + cunit(10) = 'CNC6 ' ! ------------------------------------------------------------------------------ ! ! -- Allocate a new GWT Model (this) and add it to basemodellist - allocate(this) + allocate (this) ! ! -- Set this before any allocs in the memory manager can be done this%memoryPath = create_mem_path(modelname) @@ -170,32 +174,32 @@ subroutine gwt_cr(filename, id, modelname) ! ! -- if (size(namefile_obj%opts) > 0) then - write(this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' end if ! ! -- parse options in the gwt name file do i = 1, size(namefile_obj%opts) call ParseLine(namefile_obj%opts(i), nwords, words) call upcase(words(1)) - select case(words(1)) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - 'FOR ALL MODEL STRESS PACKAGES' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - 'FOR ALL MODEL PACKAGES' - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, '(4x,a)') & - 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - case default - write(errmsg,'(4x,a,a,a,a)') & - 'UNKNOWN GWT NAMEFILE (', & - trim(adjustl(this%filename)), ') OPTION: ', & - trim(adjustl(namefile_obj%opts(i))) - call store_error(errmsg, terminate=.TRUE.) + select case (words(1)) + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + 'FOR ALL MODEL STRESS PACKAGES' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + 'FOR ALL MODEL PACKAGES' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, '(4x,a)') & + 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + case default + write (errmsg, '(4x,a,a,a,a)') & + 'UNKNOWN GWT NAMEFILE (', & + trim(adjustl(this%filename)), ') OPTION: ', & + trim(adjustl(namefile_obj%opts(i))) + call store_error(errmsg, terminate=.TRUE.) end select end do ! @@ -207,32 +211,35 @@ subroutine gwt_cr(filename, id, modelname) indisu6 = 0 indisv6 = 0 call namefile_obj%get_unitnumber('DIS6', indis6, 1) - if(indis6 > 0) indis = indis6 - if(indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) - if(indisu6 > 0) indis = indisu6 - if(indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) - if(indisv6 > 0) indis = indisv6 - call namefile_obj%get_unitnumber('IC6', this%inic, 1) + if (indis6 > 0) indis = indis6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) + if (indisu6 > 0) indis = indisu6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) + if (indisv6 > 0) indis = indisv6 + call namefile_obj%get_unitnumber('IC6', this%inic, 1) call namefile_obj%get_unitnumber('FMI6', this%infmi, 1) call namefile_obj%get_unitnumber('MVT6', this%inmvt, 1) call namefile_obj%get_unitnumber('MST6', this%inmst, 1) call namefile_obj%get_unitnumber('ADV6', this%inadv, 1) call namefile_obj%get_unitnumber('DSP6', this%indsp, 1) call namefile_obj%get_unitnumber('SSM6', this%inssm, 1) - call namefile_obj%get_unitnumber('OC6', this%inoc, 1) + call namefile_obj%get_unitnumber('OC6', this%inoc, 1) call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) ! ! -- Check to make sure that required ftype's have been specified call this%ftype_check(namefile_obj, indis) ! + ! -- Prior to instantiating packages, assign appropriate labels (GWT or GWE) + !call tsplabels_cr(this%tsplabel + ! ! -- Create discretization object - if(indis6 > 0) then + if (indis6 > 0) then call dis_cr(this%dis, this%name, indis, this%iout) - elseif(indisu6 > 0) then + elseif (indisu6 > 0) then call disu_cr(this%dis, this%name, indis, this%iout) - elseif(indisv6 > 0) then + elseif (indisv6 > 0) then call disv_cr(this%dis, this%name, indis, this%iout) - endif + end if ! ! -- Create utility objects call budget_cr(this%budget, this%name) @@ -246,7 +253,7 @@ subroutine gwt_cr(filename, id, modelname) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) - call gwt_obs_cr(this%obs, this%inobs) + call tsp_obs_cr(this%obs, this%inobs) ! ! -- Create stress packages ipakid = 1 @@ -255,12 +262,12 @@ subroutine gwt_cr(filename, id, modelname) do j = 1, namefile_obj%get_nval_for_row(i) iu = namefile_obj%get_unitnumber_rowcol(i, j) call namefile_obj%get_pakname(i, j, pakname) - call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & - this%iout) + call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & + this%iout) ipaknum = ipaknum + 1 ipakid = ipakid + 1 - enddo - enddo + end do + end do ! ! -- return return @@ -296,8 +303,8 @@ subroutine gwt_df(this) ! -- Assign or point model members to dis members this%neq = this%dis%nodes this%nja = this%dis%nja - this%ia => this%dis%con%ia - this%ja => this%dis%con%ja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja ! ! -- Allocate model arrays, now that neq and nja are assigned call this%allocate_arrays() @@ -308,7 +315,7 @@ subroutine gwt_df(this) call packobj%bnd_df(this%neq, this%dis) packobj%TsManager%iout = this%iout packobj%TasManager%iout = this%iout - enddo + end do ! ! -- Store information needed for observations call this%obs%obs_df(this%iout, this%name, 'GWT', this%dis) @@ -343,7 +350,7 @@ subroutine gwt_ac(this, sparse) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ac(this%moffset, sparse) - enddo + end do ! ! -- return return @@ -372,10 +379,10 @@ subroutine gwt_mc(this, iasln, jasln) if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, iasln, jasln) ! ! -- Map any package connections - do ip=1,this%bndlist%Count() + do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_mc(this%moffset, iasln, jasln) - enddo + end do ! ! -- return return @@ -402,12 +409,12 @@ subroutine gwt_ar(this) ! -- Allocate and read modules attached to model call this%fmi%fmi_ar(this%ibound) if (this%inmvt > 0) call this%mvt%mvt_ar() - if (this%inic > 0) call this%ic%ic_ar(this%x) + if (this%inic > 0) call this%ic%ic_ar(this%x) if (this%inmst > 0) call this%mst%mst_ar(this%dis, this%ibound) if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound) if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) - if (this%inobs > 0) call this%obs%gwt_obs_ar(this%ic, this%x, this%flowja) + if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! ! -- Call dis_ar to write binary grid file !call this%dis%dis_ar(this%npf%icelltype) @@ -417,13 +424,13 @@ subroutine gwt_ar(this) call this%budget%set_ibudcsv(this%oc%ibudcsv) ! ! -- Package input files now open, so allocate and read - do ip=1,this%bndlist%Count() + do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) - call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & + call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & this%xold, this%flowja) ! -- Read and allocate package call packobj%bnd_ar() - enddo + end do ! ! -- return return @@ -454,18 +461,18 @@ subroutine gwt_rp(this) if (.not. readnewdata) return ! ! -- Read and prepare - if(this%inoc > 0) call this%oc%oc_rp() - if(this%inssm > 0) call this%ssm%ssm_rp() + if (this%inoc > 0) call this%oc%oc_rp() + if (this%inssm > 0) call this%ssm%ssm_rp() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_rp() call packobj%bnd_rp_obs() - enddo + end do ! ! -- Return return end subroutine gwt_rp - + subroutine gwt_ad(this) ! ****************************************************************************** ! gwt_ad -- GroundWater Transport Model Time Step Advance @@ -496,13 +503,13 @@ subroutine gwt_ad(this) else this%xold(n) = this%x(n) end if - enddo + end do else ! ! -- copy xold into x if this time step is a redo do n = 1, this%dis%nodes this%x(n) = this%xold(n) - enddo + end do end if ! ! -- Advance fmi @@ -510,15 +517,15 @@ subroutine gwt_ad(this) ! ! -- Advance !if(this%inmst > 0) call this%mst%mst_ad() - if(this%indsp > 0) call this%dsp%dsp_ad() - if(this%inssm > 0) call this%ssm%ssm_ad() + if (this%indsp > 0) call this%dsp%dsp_ad() + if (this%inssm > 0) call this%ssm%ssm_ad() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ad() if (isimcheck > 0) then call packobj%bnd_ck() end if - enddo + end do ! ! -- Push simulated values to preceding time/subtime step call this%obs%obs_ad() @@ -537,7 +544,7 @@ subroutine gwt_cf(this, kiter) ! -- modules ! -- dummy class(GwtModelType) :: this - integer(I4B),intent(in) :: kiter + integer(I4B), intent(in) :: kiter ! -- local class(BndType), pointer :: packobj integer(I4B) :: ip @@ -547,7 +554,7 @@ subroutine gwt_cf(this, kiter) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_cf() - enddo + end do ! ! -- return return @@ -573,32 +580,32 @@ subroutine gwt_fc(this, kiter, amatsln, njasln, inwtflag) ! ------------------------------------------------------------------------------ ! ! -- call fc routines - call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, njasln, & + call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, njasln, & amatsln, this%idxglo, this%rhs) if (this%inmvt > 0) then call this%mvt%mvt_fc(this%x, this%x) end if - if(this%inmst > 0) then - call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, njasln, & + if (this%inmst > 0) then + call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, njasln, & amatsln, this%idxglo, this%x, this%rhs, kiter) - endif - if(this%inadv > 0) then - call this%adv%adv_fc(this%dis%nodes, amatsln, this%idxglo, this%x, & + end if + if (this%inadv > 0) then + call this%adv%adv_fc(this%dis%nodes, amatsln, this%idxglo, this%x, & this%rhs) - endif - if(this%indsp > 0) then - call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, njasln, amatsln, & + end if + if (this%indsp > 0) then + call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, njasln, amatsln, & this%idxglo, this%rhs, this%x) - endif - if(this%inssm > 0) then + end if + if (this%inssm > 0) then call this%ssm%ssm_fc(amatsln, this%idxglo, this%rhs) - endif + end if ! ! -- packages do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) - enddo + end do ! ! -- return return @@ -614,10 +621,10 @@ subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this - integer(I4B),intent(in) :: innertot - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod + integer(I4B), intent(in) :: innertot + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod character(len=LENPAKLOC), intent(inout) :: cpak integer(I4B), intent(inout) :: ipak real(DP), intent(inout) :: dpak @@ -639,7 +646,7 @@ subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! -- return return end subroutine gwt_cc - + subroutine gwt_cq(this, icnvg, isuppress_output) ! ****************************************************************************** ! gwt_cq --Groundwater transport model calculate flow @@ -667,13 +674,13 @@ subroutine gwt_cq(this, icnvg, isuppress_output) ! its flow to this diagonal position. do i = 1, this%nja this%flowja(i) = DZERO - enddo - if(this%inadv > 0) call this%adv%adv_cq(this%x, this%flowja) - if(this%indsp > 0) call this%dsp%dsp_cq(this%x, this%flowja) - if(this%inmst > 0) call this%mst%mst_cq(this%dis%nodes, this%x, this%xold, & - this%flowja) - if(this%inssm > 0) call this%ssm%ssm_cq(this%flowja) - if(this%infmi > 0) call this%fmi%fmi_cq(this%x, this%flowja) + end do + if (this%inadv > 0) call this%adv%adv_cq(this%x, this%flowja) + if (this%indsp > 0) call this%dsp%dsp_cq(this%x, this%flowja) + if (this%inmst > 0) call this%mst%mst_cq(this%dis%nodes, this%x, this%xold, & + this%flowja) + if (this%inssm > 0) call this%ssm%ssm_cq(this%flowja) + if (this%infmi > 0) call this%fmi%fmi_cq(this%x, this%flowja) ! ! -- Go through packages and call cq routines. cf() routines are called ! first to regenerate non-linear terms to be consistent with the final @@ -682,7 +689,7 @@ subroutine gwt_cq(this, icnvg, isuppress_output) packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_cf(reset_mover=.false.) call packobj%bnd_cq(this%x, this%flowja) - enddo + end do ! ! -- Finalize calculation of flowja by adding face flows to the diagonal. ! This results in the flow residual being stored in the diagonal @@ -709,7 +716,7 @@ subroutine gwt_bd(this, icnvg, isuppress_output) integer(I4B), intent(in) :: isuppress_output ! -- local integer(I4B) :: ip - class(BndType),pointer :: packobj + class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ ! ! -- Save the solution convergence flag @@ -720,14 +727,14 @@ subroutine gwt_bd(this, icnvg, isuppress_output) ! should be added here to this%budget. In a subsequent exchange call, ! exchange flows might also be added. call this%budget%reset() - if(this%inmst > 0) call this%mst%mst_bd(isuppress_output, this%budget) - if(this%inssm > 0) call this%ssm%ssm_bd(isuppress_output, this%budget) - if(this%infmi > 0) call this%fmi%fmi_bd(isuppress_output, this%budget) - if(this%inmvt > 0) call this%mvt%mvt_bd(this%x, this%x) + if (this%inmst > 0) call this%mst%mst_bd(isuppress_output, this%budget) + if (this%inssm > 0) call this%ssm%ssm_bd(isuppress_output, this%budget) + if (this%infmi > 0) call this%fmi%fmi_bd(isuppress_output, this%budget) + if (this%inmvt > 0) call this%mvt%mvt_bd(this%x, this%x) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_bd(this%budget) - enddo + end do ! ! -- Return @@ -753,7 +760,7 @@ subroutine gwt_ot(this) integer(I4B) :: ibudfl integer(I4B) :: ipflag ! -- formats - character(len=*),parameter :: fmtnocnvg = & + character(len=*), parameter :: fmtnocnvg = & "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & &I0,' OF STRESS PERIOD ',I0,'****')" ! ------------------------------------------------------------------------------ @@ -763,10 +770,10 @@ subroutine gwt_ot(this) idvprint = 0 icbcfl = 0 ibudfl = 0 - if(this%oc%oc_save('CONCENTRATION')) idvsave = 1 - if(this%oc%oc_print('CONCENTRATION')) idvprint = 1 - if(this%oc%oc_save('BUDGET')) icbcfl = 1 - if(this%oc%oc_print('BUDGET')) ibudfl = 1 + if (this%oc%oc_save('CONCENTRATION')) idvsave = 1 + if (this%oc%oc_print('CONCENTRATION')) idvprint = 1 + if (this%oc%oc_save('BUDGET')) icbcfl = 1 + if (this%oc%oc_print('BUDGET')) ibudfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') ! ! -- Override ibudfl and idvprint flags for nonconvergence @@ -776,47 +783,47 @@ subroutine gwt_ot(this) ! ! Calculate and save observations call this%gwt_ot_obs() - ! + ! ! Save and print flows call this%gwt_ot_flow(icbcfl, ibudfl, icbcun) - ! + ! ! Save and print dependent variables call this%gwt_ot_dv(idvsave, idvprint, ipflag) - ! + ! ! Print budget summaries call this%gwt_ot_bdsummary(ibudfl, ipflag) ! ! -- Timing Output; if any dependendent variables or budgets ! are printed, then ipflag is set to 1. - if(ipflag == 1) call tdis_ot(this%iout) + if (ipflag == 1) call tdis_ot(this%iout) ! ! -- Write non-convergence message - if(this%icnvg == 0) then - write(this%iout, fmtnocnvg) kstp, kper - endif + if (this%icnvg == 0) then + write (this%iout, fmtnocnvg) kstp, kper + end if ! ! -- Return return end subroutine gwt_ot - + subroutine gwt_ot_obs(this) class(GwtModelType) :: this class(BndType), pointer :: packobj integer(I4B) :: ip - + ! -- Calculate and save observations call this%obs%obs_bd() call this%obs%obs_ot() - + ! -- Calculate and save package obserations do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_bd_obs() call packobj%bnd_ot_obs() end do - + end subroutine gwt_ot_obs - + subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) class(GwtModelType) :: this integer(I4B), intent(in) :: icbcfl @@ -827,20 +834,22 @@ subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) ! -- Save GWT flows call this%gwt_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if(this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) - if(this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) - if(this%inssm > 0) call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) + if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) + if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) + if (this%inssm > 0) then + call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) + end if do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) end do - + ! -- Save advanced package flows do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) end do - if(this%inmvt > 0) then + if (this%inmvt > 0) then call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) end if @@ -848,23 +857,25 @@ subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) ! no need to print flowja ! no need to print mst ! no need to print fmi - if(this%inssm > 0) call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) + if (this%inssm > 0) then + call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) + end if do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) end do - + ! -- Print advanced package flows do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) end do - if(this%inmvt > 0) then + if (this%inmvt > 0) then call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) end if - + end subroutine gwt_ot_flow - + subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) ! ****************************************************************************** ! gwt_ot_flowja -- Write intercell flows @@ -874,8 +885,8 @@ subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) ! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this - integer(I4B),intent(in) :: nja - real(DP),dimension(nja),intent(in) :: flowja + integer(I4B), intent(in) :: nja + real(DP), dimension(nja), intent(in) :: flowja integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: icbcun ! -- local @@ -884,19 +895,19 @@ subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) ! ------------------------------------------------------------------------------ ! ! -- Set unit number for binary output - if(this%ipakcb < 0) then + if (this%ipakcb < 0) then ibinun = icbcun - elseif(this%ipakcb == 0) then + elseif (this%ipakcb == 0) then ibinun = 0 else ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 + end if + if (icbcfl == 0) ibinun = 0 ! ! -- Write the face flows if requested - if(ibinun /= 0) then + if (ibinun /= 0) then call this%dis%record_connection_array(flowja, ibinun, this%iout) - endif + end if ! ! -- Return return @@ -909,18 +920,18 @@ subroutine gwt_ot_dv(this, idvsave, idvprint, ipflag) integer(I4B), intent(inout) :: ipflag class(BndType), pointer :: packobj integer(I4B) :: ip - + ! -- Print advanced package dependent variables do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_dv(idvsave, idvprint) end do - + ! -- save head and print head call this%oc%oc_ot(ipflag) - + end subroutine gwt_ot_dv - + subroutine gwt_ot_bdsummary(this, ibudfl, ipflag) use TdisModule, only: kstp, kper, totim class(GwtModelType) :: this @@ -934,24 +945,24 @@ subroutine gwt_ot_bdsummary(this, ibudfl, ipflag) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) - enddo - + end do + ! -- mover budget summary - if(this%inmvt > 0) then + if (this%inmvt > 0) then call this%mvt%mvt_ot_bdsummary(ibudfl) end if - + ! -- model budget summary if (ibudfl /= 0) then ipflag = 1 call this%budget%budget_ot(kstp, kper, this%iout) end if - + ! -- Write to budget csv call this%budget%writecsv(totim) - + end subroutine gwt_ot_bdsummary - + subroutine gwt_da(this) ! ****************************************************************************** ! gwt_da -- Deallocate @@ -965,7 +976,7 @@ subroutine gwt_da(this) class(GwtModelType) :: this ! -- local integer(I4B) :: ip - class(BndType),pointer :: packobj + class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ ! ! -- Internal flow packages deallocate @@ -982,24 +993,24 @@ subroutine gwt_da(this) call this%obs%obs_da() ! ! -- Internal package objects - deallocate(this%dis) - deallocate(this%ic) - deallocate(this%fmi) - deallocate(this%adv) - deallocate(this%dsp) - deallocate(this%ssm) - deallocate(this%mst) - deallocate(this%mvt) - deallocate(this%budget) - deallocate(this%oc) - deallocate(this%obs) + deallocate (this%dis) + deallocate (this%ic) + deallocate (this%fmi) + deallocate (this%adv) + deallocate (this%dsp) + deallocate (this%ssm) + deallocate (this%mst) + deallocate (this%mvt) + deallocate (this%budget) + deallocate (this%oc) + deallocate (this%obs) ! ! -- Boundary packages do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_da() - deallocate(packobj) - enddo + deallocate (packobj) + end do ! ! -- Scalars call mem_deallocate(this%inic) @@ -1030,7 +1041,7 @@ end subroutine gwt_da subroutine gwt_bdentry(this, budterm, budtxt, rowlabel) ! -- modules use ConstantsModule, only: LENBUDTXT - use TdisModule, only:delt + use TdisModule, only: delt ! -- dummy class(GwtModelType) :: this real(DP), dimension(:, :), intent(in) :: budterm @@ -1044,7 +1055,7 @@ subroutine gwt_bdentry(this, budterm, budtxt, rowlabel) return end subroutine gwt_bdentry - function gwt_get_iasym(this) result (iasym) + function gwt_get_iasym(this) result(iasym) ! ****************************************************************************** ! gwt_get_iasym -- return 1 if any package causes the matrix to be asymmetric. ! Otherwise return 0. @@ -1063,7 +1074,7 @@ function gwt_get_iasym(this) result (iasym) ! -- ADV if (this%inadv > 0) then if (this%adv%iasym /= 0) iasym = 1 - endif + end if ! ! -- return return @@ -1080,38 +1091,38 @@ subroutine allocate_scalars(this, modelname) use MemoryManagerModule, only: mem_allocate ! -- dummy class(GwtModelType) :: this - character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: modelname ! ------------------------------------------------------------------------------ ! ! -- allocate members from parent class call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class - call mem_allocate(this%inic , 'INIC', this%memoryPath) + call mem_allocate(this%inic, 'INIC', this%memoryPath) call mem_allocate(this%infmi, 'INFMI', this%memoryPath) call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) call mem_allocate(this%inmst, 'INMST', this%memoryPath) call mem_allocate(this%inadv, 'INADV', this%memoryPath) call mem_allocate(this%indsp, 'INDSP', this%memoryPath) call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - call mem_allocate(this%inoc, 'INOC ', this%memoryPath) + call mem_allocate(this%inoc, 'INOC ', this%memoryPath) call mem_allocate(this%inobs, 'INOBS', this%memoryPath) ! - this%inic = 0 + this%inic = 0 this%infmi = 0 this%inmvt = 0 this%inmst = 0 this%inadv = 0 this%indsp = 0 this%inssm = 0 - this%inoc = 0 + this%inoc = 0 this%inobs = 0 ! ! -- return return end subroutine allocate_scalars - subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & + subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) ! ****************************************************************************** ! package_create -- Create boundary condition packages for this model @@ -1122,7 +1133,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error - use GwtCncModule, only: cnc_create + use TspCncModule, only: cnc_create use GwtSrcModule, only: src_create use GwtIstModule, only: ist_create use GwtLktModule, only: lkt_create @@ -1132,13 +1143,13 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & use ApiModule, only: api_create ! -- dummy class(GwtModelType) :: this - character(len=*),intent(in) :: filtyp + character(len=*), intent(in) :: filtyp character(len=LINELENGTH) :: errmsg - integer(I4B),intent(in) :: ipakid - integer(I4B),intent(in) :: ipaknum + integer(I4B), intent(in) :: ipakid + integer(I4B), intent(in) :: ipaknum character(len=*), intent(in) :: pakname - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout ! -- local class(BndType), pointer :: packobj class(BndType), pointer :: packobj2 @@ -1146,44 +1157,44 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! ------------------------------------------------------------------------------ ! ! -- This part creates the package object - select case(filtyp) - case('CNC6') + select case (filtyp) + case ('CNC6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('SRC6') + case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - case('LKT6') - call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + case ('LKT6') + call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) - case('SFT6') - call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + case ('SFT6') + call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) - case('MWT6') - call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + case ('MWT6') + call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) - case('UZT6') - call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + case ('UZT6') + call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) - case('IST6') - call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + case ('IST6') + call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%mst) - case('API6') + case ('API6') call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) case default - write(errmsg, *) 'Invalid package type: ', filtyp + write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) end select ! ! -- Packages is the bndlist that is associated with the parent model ! -- The following statement puts a pointer to this package in the ipakid ! -- position of packages. - do ip = 1, this%bndlist%Count() - packobj2 => GetBndFromList(this%bndlist, ip) - if(packobj2%packName == pakname) then - write(errmsg, '(a,a)') 'Cannot create package. Package name ' // & - 'already exists: ', trim(pakname) - call store_error(errmsg, terminate=.TRUE.) - endif - enddo + do ip = 1, this%bndlist%Count() + packobj2 => GetBndFromList(this%bndlist, ip) + if (packobj2%packName == pakname) then + write (errmsg, '(a,a)') 'Cannot create package. Package name '// & + 'already exists: ', trim(pakname) + call store_error(errmsg, terminate=.TRUE.) + end if + end do call AddBndToList(this%bndlist, packobj) ! ! -- return @@ -1198,9 +1209,9 @@ subroutine ftype_check(this, namefile_obj, indis) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors - use NameFileModule, only: NameFileType + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors + use NameFileModule, only: NameFileType ! -- dummy class(GwtModelType) :: this type(NameFileType), intent(in) :: namefile_obj @@ -1208,49 +1219,50 @@ subroutine ftype_check(this, namefile_obj, indis) ! -- local character(len=LINELENGTH) :: errmsg integer(I4B) :: i, iu - character(len=LENFTYPE), dimension(10) :: nodupftype = & - (/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', 'DSP6 ', & - 'SSM6 ', 'OC6 ', 'OBS6 '/) + character(len=LENFTYPE), dimension(10) :: nodupftype = & + &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', 'DSP6 ', & + &'SSM6 ', 'OC6 ', 'OBS6 '/) ! ------------------------------------------------------------------------------ ! ! -- Check for IC6, DIS(u), and MST. Stop if not present. - if(this%inic == 0) then - write(errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' + if (this%inic == 0) then + write (errmsg, '(1x,a)') & + 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' call store_error(errmsg) - endif - if(indis == 0) then - write(errmsg, '(1x,a)') & + end if + if (indis == 0) then + write (errmsg, '(1x,a)') & 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' call store_error(errmsg) - endif - if(this%inmst == 0) then - write(errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & + end if + if (this%inmst == 0) then + write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & &PACKAGE NOT SPECIFIED.' call store_error(errmsg) - endif - if(count_errors() > 0) then - write(errmsg,'(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' + end if + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' call store_error(errmsg) - endif + end if ! ! -- Check to make sure that some GWT packages are not specified more ! than once do i = 1, size(nodupftype) call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) if (iu > 0) then - write(errmsg,'(1x, a, a, a)') & - 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & + write (errmsg, '(1x, a, a, a)') & + 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & ' NOT ALLOWED FOR GWT MODEL.' call store_error(errmsg) - endif - enddo + end if + end do ! ! -- Stop if errors - if(count_errors() > 0) then - write(errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & + if (count_errors() > 0) then + write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & trim(namefile_obj%filename) call store_error(errmsg, terminate=.TRUE.) - endif + end if ! ! -- return return @@ -1258,16 +1270,16 @@ end subroutine ftype_check !> @brief Cast to GwtModelType function CastAsGwtModel(model) result(gwtmodel) - class(*), pointer :: model !< The object to be cast + class(*), pointer :: model !< The object to be cast class(GwtModelType), pointer :: gwtmodel !< The GWT model - + gwtmodel => null() if (.not. associated(model)) return - select type(model) + select type (model) type is (GwtModelType) gwtmodel => model end select - + end function CastAsGwtModel - + end module GwtModule diff --git a/src/Model/GroundWaterTransport/gwt1apt1.f90 b/src/Model/GroundWaterTransport/gwt1apt1.f90 index f51ac8f02fb..98a4431abf9 100644 --- a/src/Model/GroundWaterTransport/gwt1apt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1apt1.f90 @@ -1,7 +1,7 @@ ! -- Advanced Package Transport Module ! -- This module contains most of the routines for simulating transport -! -- through the advanced packages. -! -- Future work: +! -- through the advanced packages. +! -- Future work: ! * support decay, sorption ! * dispersion in SFT and UZT? ! @@ -22,7 +22,7 @@ ! EXT-INFLOW idxbudiflw EXT-INFLOW q * ciflw ! WITHDRAWAL idxbudwdrl WITHDRAWAL q * cfeat ! EXT-OUTFLOW idxbudoutf EXT-OUTFLOW q * cfeat - + ! -- terms from a flow file that should be skipped ! CONSTANT none none none ! AUXILIARY none none none @@ -36,10 +36,10 @@ module GwtAptModule use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: DZERO, DONE, DEP20, LENFTYPE, LINELENGTH, & - LENBOUNDNAME, LENPACKAGENAME, NAMEDBOUNDFLAG, & - DNODATA, TABLEFT, TABCENTER, TABRIGHT, & - TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + use ConstantsModule, only: DZERO, DONE, DEP20, LENFTYPE, LINELENGTH, & + LENBOUNDNAME, LENPACKAGENAME, NAMEDBOUNDFLAG, & + DNODATA, TABLEFT, TABCENTER, TABRIGHT, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & LENAUXNAME use SimModule, only: store_error, store_error_unit, count_errors use SimVariablesModule, only: errmsg @@ -50,70 +50,71 @@ module GwtAptModule use ObserveModule, only: ObserveType use InputOutputModule, only: extract_idnum_or_bndname use BaseDisModule, only: DisBaseType - + implicit none - + public GwtAptType, apt_process_obsID - + character(len=LENFTYPE) :: ftype = 'APT' - character(len=16) :: text = ' APT' - + character(len=16) :: text = ' APT' + type, extends(BndType) :: GwtAptType - - character(len=LENPACKAGENAME) :: flowpackagename = '' !< name of corresponding flow package - character(len=8), dimension(:), pointer, contiguous :: status => null() !< active, inactive, constant - character(len=LENAUXNAME) :: cauxfpconc = '' !< name of aux column in flow package auxvar array for concentration - integer(I4B), pointer :: iauxfpconc => null() !< column in flow package bound array to insert concs - integer(I4B), pointer :: imatrows => null() !< if active, add new rows to matrix - integer(I4B), pointer :: iprconc => null() !< print conc to listing file - integer(I4B), pointer :: iconcout => null() !< unit number for conc output file - integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file - integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file - integer(I4B), pointer :: ncv => null() !< number of control volumes - integer(I4B), pointer :: igwfaptpak => null() !< package number of corresponding this package - real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration - integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< map position in global rhs and x array of pack entry - integer(I4B), dimension(:), pointer, contiguous :: idxpakdiag => null() !< map diag position of feature in global amat - integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !< map position in global array of package diagonal row entries - integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !< map position in global array of package off diagonal row entries - integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !< map position in global array of package diagonal entries to model rows - integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !< map position in global array of package off diagonal entries to model rows - integer(I4B), dimension(:), pointer, contiguous :: idxfjfdglo => null() !< map diagonal feature to feature in global amat - integer(I4B), dimension(:), pointer, contiguous :: idxfjfoffdglo => null() !< map off diagonal feature to feature in global amat - integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !< package ibound - real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !< feature concentration for current time step - real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !< feature concentration from previous time step - real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< temporary storage array - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: featname => null() - real(DP), dimension(:), pointer, contiguous :: concfeat => null() !< concentration of the feature - real(DP), dimension(:,:), pointer, contiguous :: lauxvar => null() !< auxiliary variable - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object - real(DP), dimension(:), pointer, contiguous :: qsto => null() !< mass flux due to storage change - real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass flux required to maintain constant concentration - integer(I4B), pointer :: idxbudfjf => null() !< index of flow ja face in flowbudptr - integer(I4B), pointer :: idxbudgwf => null() !< index of gwf terms in flowbudptr - integer(I4B), pointer :: idxbudsto => null() !< index of storage terms in flowbudptr - integer(I4B), pointer :: idxbudtmvr => null() !< index of to mover terms in flowbudptr - integer(I4B), pointer :: idxbudfmvr => null() !< index of from mover terms in flowbudptr - integer(I4B), pointer :: idxbudaux => null() !< index of auxiliary terms in flowbudptr - integer(I4B), dimension(:), pointer, contiguous :: idxbudssm => null() !< flag that flowbudptr%buditem is a general solute source/sink - integer(I4B), pointer :: nconcbudssm => null() !< number of concbudssm terms (columns) - real(DP), dimension(:, : ), pointer, contiguous :: concbudssm => null() !< user specified concentrations for flow terms - real(DP), dimension(:), pointer, contiguous :: qmfrommvr => null() !< a mass flow coming from the mover that needs to be added + + character(len=LENPACKAGENAME) :: flowpackagename = '' !< name of corresponding flow package + character(len=8), & + dimension(:), pointer, contiguous :: status => null() !< active, inactive, constant + character(len=LENAUXNAME) :: cauxfpconc = '' !< name of aux column in flow package auxvar array for concentration + integer(I4B), pointer :: iauxfpconc => null() !< column in flow package bound array to insert concs + integer(I4B), pointer :: imatrows => null() !< if active, add new rows to matrix + integer(I4B), pointer :: iprconc => null() !< print conc to listing file + integer(I4B), pointer :: iconcout => null() !< unit number for conc output file + integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + integer(I4B), pointer :: ncv => null() !< number of control volumes + integer(I4B), pointer :: igwfaptpak => null() !< package number of corresponding this package + real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration + integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< map position in global rhs and x array of pack entry + integer(I4B), dimension(:), pointer, contiguous :: idxpakdiag => null() !< map diag position of feature in global amat + integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !< map position in global array of package diagonal row entries + integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !< map position in global array of package off diagonal row entries + integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !< map position in global array of package diagonal entries to model rows + integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !< map position in global array of package off diagonal entries to model rows + integer(I4B), dimension(:), pointer, contiguous :: idxfjfdglo => null() !< map diagonal feature to feature in global amat + integer(I4B), dimension(:), pointer, contiguous :: idxfjfoffdglo => null() !< map off diagonal feature to feature in global amat + integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !< package ibound + real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !< feature concentration for current time step + real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !< feature concentration from previous time step + real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< temporary storage array + character(len=LENBOUNDNAME), & + dimension(:), pointer, contiguous :: featname => null() + real(DP), dimension(:), pointer, contiguous :: concfeat => null() !< concentration of the feature + real(DP), dimension(:, :), pointer, contiguous :: lauxvar => null() !< auxiliary variable + type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object + real(DP), dimension(:), pointer, contiguous :: qsto => null() !< mass flux due to storage change + real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass flux required to maintain constant concentration + integer(I4B), pointer :: idxbudfjf => null() !< index of flow ja face in flowbudptr + integer(I4B), pointer :: idxbudgwf => null() !< index of gwf terms in flowbudptr + integer(I4B), pointer :: idxbudsto => null() !< index of storage terms in flowbudptr + integer(I4B), pointer :: idxbudtmvr => null() !< index of to mover terms in flowbudptr + integer(I4B), pointer :: idxbudfmvr => null() !< index of from mover terms in flowbudptr + integer(I4B), pointer :: idxbudaux => null() !< index of auxiliary terms in flowbudptr + integer(I4B), dimension(:), pointer, contiguous :: idxbudssm => null() !< flag that flowbudptr%buditem is a general solute source/sink + integer(I4B), pointer :: nconcbudssm => null() !< number of concbudssm terms (columns) + real(DP), dimension(:, :), pointer, contiguous :: concbudssm => null() !< user specified concentrations for flow terms + real(DP), dimension(:), pointer, contiguous :: qmfrommvr => null() !< a mass flow coming from the mover that needs to be added ! ! -- pointer to flow package boundary - type(BndType), pointer :: flowpackagebnd => null() + type(BndType), pointer :: flowpackagebnd => null() ! ! -- budget objects - type(BudgetObjectType), pointer :: budobj => null() !< apt solute budget object - type(BudgetObjectType), pointer :: flowbudptr => null() !< GWF flow budget object + type(BudgetObjectType), pointer :: budobj => null() !< apt solute budget object + type(BudgetObjectType), pointer :: flowbudptr => null() !< GWF flow budget object ! ! -- table objects type(TableType), pointer :: dvtab => null() - + contains - + procedure :: set_pointers => apt_set_pointers procedure :: bnd_ac => apt_ac procedure :: bnd_mc => apt_mc @@ -163,11 +164,11 @@ module GwtAptModule procedure, private :: apt_fjf_term procedure, private :: apt_copy2flowp procedure, private :: apt_setup_tableobj - + end type GwtAptType - contains - +contains + subroutine apt_ac(this, moffset, sparse) ! ****************************************************************************** ! bnd_ac -- Add package connection to matrix @@ -178,7 +179,7 @@ subroutine apt_ac(this, moffset, sparse) use MemoryManagerModule, only: mem_setptr use SparseModule, only: sparsematrix ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this integer(I4B), intent(in) :: moffset type(sparsematrix), intent(inout) :: sparse ! -- local @@ -232,7 +233,7 @@ subroutine apt_mc(this, moffset, iasln, jasln) ! ------------------------------------------------------------------------------ use SparseModule, only: sparsematrix ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this integer(I4B), intent(in) :: moffset integer(I4B), dimension(:), intent(in) :: iasln integer(I4B), dimension(:), intent(in) :: jasln @@ -246,18 +247,18 @@ subroutine apt_mc(this, moffset, iasln, jasln) if (this%imatrows /= 0) then ! ! -- allocate pointers to global matrix - allocate(this%idxlocnode(this%ncv)) - allocate(this%idxpakdiag(this%ncv)) - allocate(this%idxdglo(this%maxbound)) - allocate(this%idxoffdglo(this%maxbound)) - allocate(this%idxsymdglo(this%maxbound)) - allocate(this%idxsymoffdglo(this%maxbound)) + allocate (this%idxlocnode(this%ncv)) + allocate (this%idxpakdiag(this%ncv)) + allocate (this%idxdglo(this%maxbound)) + allocate (this%idxoffdglo(this%maxbound)) + allocate (this%idxsymdglo(this%maxbound)) + allocate (this%idxsymoffdglo(this%maxbound)) n = 0 if (this%idxbudfjf /= 0) then n = this%flowbudptr%budterm(this%idxbudfjf)%maxlist end if - allocate(this%idxfjfdglo(n)) - allocate(this%idxfjfoffdglo(n)) + allocate (this%idxfjfdglo(n)) + allocate (this%idxfjfoffdglo(n)) ! ! -- Find the position of each connection in the global ia, ja structure ! and store them in idxglo. idxglo allows this model to insert or @@ -274,12 +275,12 @@ subroutine apt_mc(this, moffset, iasln, jasln) iglo = moffset + this%dis%nodes + this%ioffset + n jglo = j + moffset searchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then + if (jglo == jasln(jj)) then this%idxdglo(ipos) = iasln(iglo) this%idxoffdglo(ipos) = jj exit searchloop - endif - enddo searchloop + end if + end do searchloop end do ! ! -- apt contributions to gwf portion of global matrix @@ -289,12 +290,12 @@ subroutine apt_mc(this, moffset, iasln, jasln) iglo = j + moffset jglo = moffset + this%dis%nodes + this%ioffset + n symsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then + if (jglo == jasln(jj)) then this%idxsymdglo(ipos) = iasln(iglo) this%idxsymoffdglo(ipos) = jj exit symsearchloop - endif - enddo symsearchloop + end if + end do symsearchloop end do ! ! -- apt-apt contributions to gwf portion of global matrix @@ -305,24 +306,24 @@ subroutine apt_mc(this, moffset, iasln, jasln) iglo = moffset + this%dis%nodes + this%ioffset + n jglo = moffset + this%dis%nodes + this%ioffset + j fjfsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(jj)) then + if (jglo == jasln(jj)) then this%idxfjfdglo(ipos) = iasln(iglo) this%idxfjfoffdglo(ipos) = jj exit fjfsearchloop - endif - enddo fjfsearchloop + end if + end do fjfsearchloop end do end if else - allocate(this%idxlocnode(0)) - allocate(this%idxpakdiag(0)) - allocate(this%idxdglo(0)) - allocate(this%idxoffdglo(0)) - allocate(this%idxsymdglo(0)) - allocate(this%idxsymoffdglo(0)) - allocate(this%idxfjfdglo(0)) - allocate(this%idxfjfoffdglo(0)) - endif + allocate (this%idxlocnode(0)) + allocate (this%idxpakdiag(0)) + allocate (this%idxdglo(0)) + allocate (this%idxoffdglo(0)) + allocate (this%idxsymdglo(0)) + allocate (this%idxsymoffdglo(0)) + allocate (this%idxfjfdglo(0)) + allocate (this%idxfjfoffdglo(0)) + end if ! ! -- return return @@ -342,16 +343,16 @@ subroutine apt_ar(this) integer(I4B) :: j logical :: found ! -- formats - character(len=*), parameter :: fmtapt = & - "(1x,/1x,'APT -- ADVANCED PACKAGE TRANSPORT, VERSION 1, 3/5/2020', & + character(len=*), parameter :: fmtapt = & + "(1x,/1x,'APT -- ADVANCED PACKAGE TRANSPORT, VERSION 1, 3/5/2020', & &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! - ! -- Get obs setup + ! -- Get obs setup call this%obs%obs_ar() ! ! --print a message identifying the apt package. - write(this%iout, fmtapt) this%inunit + write (this%iout, fmtapt) this%inunit ! ! -- Allocate arrays call this%apt_allocate_arrays() @@ -359,7 +360,7 @@ subroutine apt_ar(this) ! -- read optional initial package parameters call this%read_initial_attr() ! - ! -- Find the package index in the GWF model or GWF budget file + ! -- Find the package index in the GWF model or GWF budget file ! for the corresponding apt flow package call this%fmi%get_package_index(this%flowpackagename, this%igwfaptpak) ! @@ -371,7 +372,7 @@ subroutine apt_ar(this) this%fmi%datp(this%igwfaptpak)%qmfrommvr => this%qmfrommvr ! ! -- If there is an associated flow package and the user wishes to put - ! simulated concentrations into a aux variable column, then find + ! simulated concentrations into a aux variable column, then find ! the column number. if (associated(this%flowpackagebnd)) then if (this%cauxfpconc /= '') then @@ -384,9 +385,9 @@ subroutine apt_ar(this) end if end do if (this%iauxfpconc == 0) then - errmsg = 'COULD NOT FIND AUXILIARY VARIABLE ' // & - trim(adjustl(this%cauxfpconc)) // ' IN FLOW PACKAGE ' // & - trim(adjustl(this%flowpackagename)) + errmsg = 'COULD NOT FIND AUXILIARY VARIABLE '// & + trim(adjustl(this%cauxfpconc))//' IN FLOW PACKAGE '// & + trim(adjustl(this%flowpackagename)) call store_error(errmsg) call this%parser%StoreErrorUnit() else @@ -422,10 +423,10 @@ subroutine apt_rp(this) integer(I4B) :: itemno integer(I4B) :: igwfnode ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Error. Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" ! ------------------------------------------------------------------------------ ! ! -- set nbound to maxbound @@ -433,7 +434,7 @@ subroutine apt_rp(this) ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- get stress period data if (this%ionper < kper) then @@ -441,7 +442,7 @@ subroutine apt_rp(this) ! -- get period block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -454,23 +455,23 @@ subroutine apt_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - endif + end if end if ! ! -- Read data if ionper == kper - if(this%ionper == kper) then + if (this%ionper == kper) then ! ! -- setup table for period data if (this%iprpak /= 0) then ! ! -- reset the input table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))//') DATA FOR PERIOD' + write (title, '(a,1x,i6)') trim(adjustl(title)), kper call table_cr(this%inputtab, this%packName, title) call this%inputtab%table_df(1, 4, this%iout, finalize=.FALSE.) text = 'NUMBER' @@ -478,7 +479,7 @@ subroutine apt_rp(this) text = 'KEYWORD' call this%inputtab%initialize_column(text, 20, alignment=TABLEFT) do n = 1, 2 - write(text, '(a,1x,i6)') 'VALUE', n + write (text, '(a,1x,i6)') 'VALUE', n call this%inputtab%initialize_column(text, 15, alignment=TABCENTER) end do end if @@ -504,11 +505,11 @@ subroutine apt_rp(this) if (this%iprpak /= 0) then call this%inputtab%finalize_table() end if - ! - ! -- using stress period data from the previous stress period + ! + ! -- using stress period data from the previous stress period else - write(this%iout,fmtlsp) trim(this%filtyp) - endif + write (this%iout, fmtlsp) trim(this%filtyp) + end if ! ! -- write summary of stress period error messages ierr = count_errors() @@ -537,7 +538,7 @@ subroutine apt_set_stressperiod(this, itemno) ! -- module use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno ! -- local character(len=LINELENGTH) :: text @@ -555,68 +556,69 @@ subroutine apt_set_stressperiod(this, itemno) ! STATUS ! CONCENTRATION ! WITHDRAWAL - ! AUXILIARY + ! AUXILIARY ! ! -- read line call this%parser%GetStringCaps(keyword) select case (keyword) - case ('STATUS') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetStringCaps(text) - this%status(itemno) = text(1:8) - if (text == 'CONSTANT') then - this%iboundpak(itemno) = -1 - else if (text == 'INACTIVE') then - this%iboundpak(itemno) = 0 - else if (text == 'ACTIVE') then - this%iboundpak(itemno) = 1 - else - write(errmsg,'(a,a)') & - 'Unknown ' // trim(this%text)//' status keyword: ', text // '.' - call store_error(errmsg) - end if - case ('CONCENTRATION') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if + case ('STATUS') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetStringCaps(text) + this%status(itemno) = text(1:8) + if (text == 'CONSTANT') then + this%iboundpak(itemno) = -1 + else if (text == 'INACTIVE') then + this%iboundpak(itemno) = 0 + else if (text == 'ACTIVE') then + this%iboundpak(itemno) = 1 + else + write (errmsg, '(a,a)') & + 'Unknown '//trim(this%text)//' status keyword: ', text//'.' + call store_error(errmsg) + end if + case ('CONCENTRATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 ! For feature concentration + bndElem => this%concfeat(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'CONCENTRATION') + case ('AUXILIARY') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetStringCaps(caux) + do jj = 1, this%naux + if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle call this%parser%GetString(text) - jj = 1 ! For feature concentration - bndElem => this%concfeat(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'CONCENTRATION') - case ('AUXILIARY') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetStringCaps(caux) - do jj = 1, this%naux - if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle - call this%parser%GetString(text) - ii = itemno - bndElem => this%lauxvar(jj, ii) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, & - this%packName, 'AUX', this%tsManager, & - this%iprpak, this%auxname(jj)) - exit - end do - case default - ! - ! -- call the specific package to look for stress period data - call this%pak_set_stressperiod(itemno, keyword, found) - ! - ! -- terminate with error if data not valid - if (.not. found) then - write(errmsg,'(2a)') & - 'Unknown ' // trim(adjustl(this%text)) // ' data keyword: ', & - trim(keyword) // '.' - call store_error(errmsg) - end if + ii = itemno + bndElem => this%lauxvar(jj, ii) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & + this%auxname(jj)) + exit + end do + case default + ! + ! -- call the specific package to look for stress period data + call this%pak_set_stressperiod(itemno, keyword, found) + ! + ! -- terminate with error if data not valid + if (.not. found) then + write (errmsg, '(2a)') & + 'Unknown '//trim(adjustl(this%text))//' data keyword: ', & + trim(keyword)//'.' + call store_error(errmsg) + end if end select ! ! -- terminate if any errors were detected @@ -637,7 +639,7 @@ subroutine pak_set_stressperiod(this, itemno, keyword, found) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno character(len=*), intent(in) :: keyword logical, intent(inout) :: found @@ -663,14 +665,14 @@ function apt_check_valid(this, itemno) result(ierr) ! -- return integer(I4B) :: ierr ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno ! -- local ! -- formats ! ------------------------------------------------------------------------------ ierr = 0 if (itemno < 1 .or. itemno > this%ncv) then - write(errmsg,'(4x,a,1x,i6,1x,a,1x,i6)') & + write (errmsg, '(4x,a,1x,i6,1x,a,1x,i6)') & '****ERROR. FEATURENO ', itemno, 'MUST BE > 0 and <= ', this%ncv call store_error(errmsg) ierr = 1 @@ -739,17 +741,17 @@ subroutine apt_ad(this) ! -- return return end subroutine apt_ad - + !> @ brief Formulate the package hcof and rhs terms. !! - !! For the APT Package, the sole purpose here is to + !! For the APT Package, the sole purpose here is to !! reset the qmfrommvr term. !! !< subroutine apt_cf(this, reset_mover) ! -- modules - class(GwtAptType) :: this !< GwtAptType object - logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover + class(GwtAptType) :: this !< GwtAptType object + logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover ! -- local integer(I4B) :: i logical :: lrm @@ -859,7 +861,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ------------------------------------------------------------------------------ ! ! -- call the specific method for the advanced transport package, such as - ! what would be overridden by + ! what would be overridden by ! GwtLktType, GwtSftType, GwtMwtType, GwtUztType ! This routine will add terms for rainfall, runoff, or other terms ! specific to the package @@ -867,7 +869,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ! -- mass storage in features do n = 1, this%ncv - cold = this%xoldpak(n) + cold = this%xoldpak(n) iloc = this%idxlocnode(n) iposd = this%idxpakdiag(n) call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) @@ -918,7 +920,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ipossymoffd = this%idxsymoffdglo(j) amatsln(ipossymd) = amatsln(ipossymd) - (DONE - omega) * qbnd amatsln(ipossymoffd) = amatsln(ipossymoffd) - omega * qbnd - end if + end if end do ! ! -- go through each apt-apt connection @@ -996,10 +998,10 @@ subroutine apt_cfupdate(this) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) omega = DZERO if (qbnd < DZERO) omega = DONE - this%hcof(j) = - (DONE - omega) * qbnd + this%hcof(j) = -(DONE - omega) * qbnd this%rhs(j) = omega * qbnd * this%xnewpak(n) - endif - end do + end if + end do ! ! -- Return return @@ -1023,7 +1025,7 @@ subroutine apt_cq(this, x, flowja, iadv) real(DP) :: rrate ! ------------------------------------------------------------------------------ ! - ! -- Solve the feature concentrations again or update the feature hcof + ! -- Solve the feature concentrations again or update the feature hcof ! and rhs terms if (this%imatrows == 0) then call this%apt_solve() @@ -1062,10 +1064,10 @@ subroutine apt_ot_package_flows(this, icbcfl, ibudfl) ! ! -- write the flows from the budobj ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & pertim, totim, this%iout) @@ -1075,7 +1077,7 @@ subroutine apt_ot_package_flows(this, icbcfl, ibudfl) if (ibudfl /= 0 .and. this%iprflow /= 0) then call this%budobj%write_flowtable(this%dis, kstp, kper) end if - + end subroutine apt_ot_package_flows subroutine apt_ot_dv(this, idvsave, idvprint) @@ -1091,10 +1093,10 @@ subroutine apt_ot_dv(this, idvsave, idvprint) ! ! -- set unit number for binary dependent variable output ibinun = 0 - if(this%iconcout /= 0) then + if (this%iconcout /= 0) then ibinun = this%iconcout end if - if(idvsave == 0) ibinun = 0 + if (idvsave == 0) ibinun = 0 ! ! -- write binary output if (ibinun > 0) then @@ -1105,44 +1107,44 @@ subroutine apt_ot_dv(this, idvsave, idvprint) end if this%dbuff(n) = c end do - call ulasav(this%dbuff, ' CONCENTRATION', kstp, kper, pertim, totim, & + call ulasav(this%dbuff, ' CONCENTRATION', kstp, kper, pertim, totim, & this%ncv, 1, 1, ibinun) end if - ! - ! -- write apt conc table - if (idvprint /= 0 .and. this%iprconc /= 0) then + ! + ! -- write apt conc table + if (idvprint /= 0 .and. this%iprconc /= 0) then ! ! -- set table kstp and kper call this%dvtab%set_kstpkper(kstp, kper) ! ! -- fill concentration data do n = 1, this%ncv - if(this%inamedbound==1) then + if (this%inamedbound == 1) then call this%dvtab%add_term(this%featname(n)) end if call this%dvtab%add_term(n) call this%dvtab%add_term(this%xnewpak(n)) end do - end if - + end if + end subroutine apt_ot_dv - + subroutine apt_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- module use TdisModule, only: totim ! -- dummy - class(GwtAptType) :: this !< GwtAptType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + class(GwtAptType) :: this !< GwtAptType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written ! call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) ! ! -- return return end subroutine apt_ot_bdsummary - + subroutine allocate_scalars(this) ! ****************************************************************************** ! allocate_scalars @@ -1176,7 +1178,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudfmvr, 'IDXBUDFMVR', this%memoryPath) call mem_allocate(this%idxbudaux, 'IDXBUDAUX', this%memoryPath) call mem_allocate(this%nconcbudssm, 'NCONCBUDSSM', this%memoryPath) - ! + ! ! -- Initialize this%iauxfpconc = 0 this%imatrows = 1 @@ -1215,7 +1217,7 @@ subroutine apt_allocate_arrays(this) ! ! -- call standard BndType allocate scalars call this%BndType%allocate_arrays() - ! + ! ! -- Allocate ! ! -- allocate and initialize dbuff @@ -1229,7 +1231,7 @@ subroutine apt_allocate_arrays(this) end if ! ! -- allocate character array for status - allocate(this%status(this%ncv)) + allocate (this%status(this%ncv)) ! ! -- time series call mem_allocate(this%concfeat, this%ncv, 'CONCFEAT', this%memoryPath) @@ -1240,7 +1242,7 @@ subroutine apt_allocate_arrays(this) ! ! -- concentration for budget terms call mem_allocate(this%concbudssm, this%nconcbudssm, this%ncv, & - 'CONCBUDSSM', this%memoryPath) + 'CONCBUDSSM', this%memoryPath) ! ! -- mass added from the mover transport package call mem_allocate(this%qmfrommvr, this%ncv, 'QMFROMMVR', this%memoryPath) @@ -1258,7 +1260,7 @@ subroutine apt_allocate_arrays(this) ! -- Return return end subroutine apt_allocate_arrays - + subroutine apt_da(this) ! ****************************************************************************** ! apt_da @@ -1287,30 +1289,30 @@ subroutine apt_da(this) call mem_deallocate(this%concbudssm) call mem_deallocate(this%concfeat) call mem_deallocate(this%qmfrommvr) - deallocate(this%status) - deallocate(this%featname) + deallocate (this%status) + deallocate (this%featname) ! ! -- budobj call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) + deallocate (this%budobj) + nullify (this%budobj) ! ! -- conc table if (this%iprconc > 0) then call this%dvtab%table_da() - deallocate(this%dvtab) - nullify(this%dvtab) + deallocate (this%dvtab) + nullify (this%dvtab) end if ! ! -- index pointers - deallocate(this%idxlocnode) - deallocate(this%idxpakdiag) - deallocate(this%idxdglo) - deallocate(this%idxoffdglo) - deallocate(this%idxsymdglo) - deallocate(this%idxsymoffdglo) - deallocate(this%idxfjfdglo) - deallocate(this%idxfjfoffdglo) + deallocate (this%idxlocnode) + deallocate (this%idxpakdiag) + deallocate (this%idxdglo) + deallocate (this%idxoffdglo) + deallocate (this%idxsymdglo) + deallocate (this%idxsymoffdglo) + deallocate (this%idxfjfdglo) + deallocate (this%idxfjfoffdglo) ! ! -- deallocate scalars call mem_deallocate(this%iauxfpconc) @@ -1353,13 +1355,13 @@ subroutine find_apt_package(this) ! ! -- this routine should never be called call store_error('Program error: pak_solve not implemented.', & - terminate=.TRUE.) + terminate=.TRUE.) ! ! -- Return return end subroutine find_apt_package - subroutine apt_options(this, option, found) + subroutine apt_options(this, option, found) ! ****************************************************************************** ! apt_options -- set options specific to GwtAptType ! @@ -1373,86 +1375,89 @@ subroutine apt_options(this, option, found) use InputOutputModule, only: urword, getunit, openfile ! -- dummy class(GwtAptType), intent(inout) :: this - character(len=*), intent(inout) :: option - logical, intent(inout) :: found + character(len=*), intent(inout) :: option + logical, intent(inout) :: found ! -- local character(len=MAXCHARLEN) :: fname, keyword ! -- formats - character(len=*),parameter :: fmtaptbin = & - "(4x, a, 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I0)" + character(len=*), parameter :: fmtaptbin = & + "(4x, a, 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, & + &/4x, 'OPENED ON UNIT: ', I0)" ! ------------------------------------------------------------------------------ ! select case (option) - case ('FLOW_PACKAGE_NAME') - call this%parser%GetStringCaps(this%flowpackagename) - write(this%iout,'(4x,a)') & - 'THIS '//trim(adjustl(this%text))//' PACKAGE CORRESPONDS TO A GWF & - &PACKAGE WITH THE NAME '//trim(adjustl(this%flowpackagename)) - found = .true. - case ('FLOW_PACKAGE_AUXILIARY_NAME') - call this%parser%GetStringCaps(this%cauxfpconc) - write(this%iout,'(4x,a)') & - 'SIMULATED CONCENTRATIONS WILL BE COPIED INTO THE FLOW PACKAGE & - &AUXILIARY VARIABLE WITH THE NAME ' //trim(adjustl(this%cauxfpconc)) - found = .true. - case ('DEV_NONEXPANDING_MATRIX') - ! -- use an iterative solution where concentration is not solved - ! as part of the matrix. It is instead solved separately with a - ! general mixing equation and then added to the RHS of the GWT - ! equations - call this%parser%DevOpt() - this%imatrows = 0 - write(this%iout,'(4x,a)') & - trim(adjustl(this%text))//' WILL NOT ADD ADDITIONAL ROWS TO THE A MATRIX.' + case ('FLOW_PACKAGE_NAME') + call this%parser%GetStringCaps(this%flowpackagename) + write (this%iout, '(4x,a)') & + 'THIS '//trim(adjustl(this%text))//' PACKAGE CORRESPONDS TO A GWF & + &PACKAGE WITH THE NAME '//trim(adjustl(this%flowpackagename)) + found = .true. + case ('FLOW_PACKAGE_AUXILIARY_NAME') + call this%parser%GetStringCaps(this%cauxfpconc) + write (this%iout, '(4x,a)') & + 'SIMULATED CONCENTRATIONS WILL BE COPIED INTO THE FLOW PACKAGE & + &AUXILIARY VARIABLE WITH THE NAME '//trim(adjustl(this%cauxfpconc)) + found = .true. + case ('DEV_NONEXPANDING_MATRIX') + ! -- use an iterative solution where concentration is not solved + ! as part of the matrix. It is instead solved separately with a + ! general mixing equation and then added to the RHS of the GWT + ! equations + call this%parser%DevOpt() + this%imatrows = 0 + write (this%iout, '(4x,a)') & + trim(adjustl(this%text))// & + ' WILL NOT ADD ADDITIONAL ROWS TO THE A MATRIX.' + found = .true. + case ('PRINT_CONCENTRATION') + this%iprconc = 1 + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' CONCENTRATIONS WILL BE PRINTED TO LISTING FILE.' + found = .true. + case ('CONCENTRATION') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%iconcout = getunit() + call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write (this%iout, fmtaptbin) & + trim(adjustl(this%text)), 'CONCENTRATION', trim(fname), this%iconcout found = .true. - case ('PRINT_CONCENTRATION') - this%iprconc = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' CONCENTRATIONS WILL BE PRINTED TO LISTING FILE.' + else + call store_error('OPTIONAL CONCENTRATION KEYWORD MUST & + &BE FOLLOWED BY FILEOUT') + end if + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write (this%iout, fmtaptbin) trim(adjustl(this%text)), 'BUDGET', & + trim(fname), this%ibudgetout found = .true. - case('CONCENTRATION') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%iconcout = getunit() - call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtaptbin) trim(adjustl(this%text)), 'CONCENTRATION', & - trim(fname), this%iconcout - found = .true. - else - call store_error('OPTIONAL CONCENTRATION KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtaptbin) trim(adjustl(this%text)), 'BUDGET', & - trim(fname), this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtaptbin) trim(adjustl(this%text)), 'BUDGET CSV', & - trim(fname), this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case default - ! - ! -- No options found - found = .false. + else + call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtaptbin) trim(adjustl(this%text)), 'BUDGET CSV', & + trim(fname), this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case default + ! + ! -- No options found + found = .false. end select ! ! -- return @@ -1467,7 +1472,7 @@ subroutine apt_read_dimensions(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this ! -- local integer(I4B) :: ierr ! -- format @@ -1476,11 +1481,11 @@ subroutine apt_read_dimensions(this) ! -- Set a pointer to the GWF LAK Package budobj if (this%flowpackagename == '') then this%flowpackagename = this%packName - write(this%iout,'(4x,a)') & + write (this%iout, '(4x,a)') & 'THE FLOW PACKAGE NAME FOR '//trim(adjustl(this%text))//' WAS NOT & &SPECIFIED. SETTING FLOW PACKAGE NAME TO '// & &trim(adjustl(this%flowpackagename)) - + end if call this%find_apt_package() ! @@ -1488,24 +1493,24 @@ subroutine apt_read_dimensions(this) this%ncv = this%flowbudptr%ncv this%maxbound = this%flowbudptr%budterm(this%idxbudgwf)%maxlist this%nbound = this%maxbound - write(this%iout, '(a, a)') 'SETTING DIMENSIONS FOR PACKAGE ', this%packName - write(this%iout,'(2x,a,i0)')'NUMBER OF CONTROL VOLUMES = ', this%ncv - write(this%iout,'(2x,a,i0)')'MAXBOUND = ', this%maxbound - write(this%iout,'(2x,a,i0)')'NBOUND = ', this%nbound + write (this%iout, '(a, a)') 'SETTING DIMENSIONS FOR PACKAGE ', this%packName + write (this%iout, '(2x,a,i0)') 'NUMBER OF CONTROL VOLUMES = ', this%ncv + write (this%iout, '(2x,a,i0)') 'MAXBOUND = ', this%maxbound + write (this%iout, '(2x,a,i0)') 'NBOUND = ', this%nbound if (this%imatrows /= 0) then this%npakeq = this%ncv - write(this%iout,'(2x,a)') trim(adjustl(this%text)) // & + write (this%iout, '(2x,a)') trim(adjustl(this%text))// & ' SOLVED AS PART OF GWT MATRIX EQUATIONS' else - write(this%iout,'(2x,a)') trim(adjustl(this%text)) // & + write (this%iout, '(2x,a)') trim(adjustl(this%text))// & ' SOLVED SEPARATELY FROM GWT MATRIX EQUATIONS ' end if - write(this%iout, '(a, //)') 'DONE SETTING DIMENSIONS FOR ' // & + write (this%iout, '(a, //)') 'DONE SETTING DIMENSIONS FOR '// & trim(adjustl(this%text)) ! ! -- Check for errors if (this%ncv < 0) then - write(errmsg, '(1x,a)') & + write (errmsg, '(1x,a)') & 'ERROR: NUMBER OF CONTROL VOLUMES COULD NOT BE DETERMINED CORRECTLY.' call store_error(errmsg) end if @@ -1544,7 +1549,7 @@ subroutine apt_read_cvs(this) use MemoryManagerModule, only: mem_allocate use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: text character(len=LENBOUNDNAME) :: bndName, bndNameTemp @@ -1567,7 +1572,8 @@ subroutine apt_read_cvs(this) ! ! -- allocate apt data call mem_allocate(this%strt, this%ncv, 'STRT', this%memoryPath) - call mem_allocate(this%lauxvar, this%naux, this%ncv, 'LAUXVAR', this%memoryPath) + call mem_allocate(this%lauxvar, this%naux, this%ncv, 'LAUXVAR', & + this%memoryPath) ! ! -- lake boundary and concentrations if (this%imatrows == 0) then @@ -1577,7 +1583,7 @@ subroutine apt_read_cvs(this) call mem_allocate(this%xoldpak, this%ncv, 'XOLDPAK', this%memoryPath) ! ! -- allocate character storage not managed by the memory manager - allocate(this%featname(this%ncv)) ! ditch after boundnames allocated?? + allocate (this%featname(this%ncv)) ! ditch after boundnames allocated?? !allocate(this%status(this%ncv)) ! do n = 1, this%ncv @@ -1592,21 +1598,22 @@ subroutine apt_read_cvs(this) ! ! -- allocate local storage for aux variables if (this%naux > 0) then - allocate(caux(this%naux)) + allocate (caux(this%naux)) end if ! ! -- allocate and initialize temporary variables - allocate(nboundchk(this%ncv)) + allocate (nboundchk(this%ncv)) do n = 1, this%ncv nboundchk(n) = 0 end do ! ! -- get packagedata block - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, supportOpenClose=.true.) + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportOpenClose=.true.) ! ! -- parse locations block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & ' PACKAGEDATA' nlak = 0 nconn = 0 @@ -1616,12 +1623,12 @@ subroutine apt_read_cvs(this) n = this%parser%GetInteger() if (n < 1 .or. n > this%ncv) then - write(errmsg,'(4x,a,1x,i6)') & + write (errmsg, '(4x,a,1x,i6)') & '****ERROR. itemno MUST BE > 0 and <= ', this%ncv call store_error(errmsg) cycle end if - + ! -- increment nboundchk nboundchk(n) = nboundchk(n) + 1 @@ -1634,15 +1641,15 @@ subroutine apt_read_cvs(this) end do ! -- set default bndName - write (cno,'(i9.9)') n - bndName = 'Feature' // cno + write (cno, '(i9.9)') n + bndName = 'Feature'//cno ! -- featname if (this%inamedbound /= 0) then call this%parser%GetStringCaps(bndNameTemp) if (bndNameTemp /= '') then bndName = bndNameTemp - endif + end if end if this%featname(n) = bndName @@ -1652,27 +1659,29 @@ subroutine apt_read_cvs(this) text = caux(jj) ii = n bndElem => this%lauxvar(jj, ii) - call read_value_or_time_series_adv(text, ii, jj, bndElem, this%packName, & - 'AUX', this%tsManager, this%iprpak, & + call read_value_or_time_series_adv(text, ii, jj, bndElem, & + this%packName, 'AUX', & + this%tsManager, this%iprpak, & this%auxname(jj)) end do - + nlak = nlak + 1 end do ! ! -- check for duplicate or missing lakes do n = 1, this%ncv if (nboundchk(n) == 0) then - write(errmsg,'(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR FEATURE', n + write (errmsg, '(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR FEATURE', n call store_error(errmsg) else if (nboundchk(n) > 1) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'ERROR. DATA FOR FEATURE', n, 'SPECIFIED', nboundchk(n), 'TIMES' call store_error(errmsg) end if end do - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' else call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') end if @@ -1684,16 +1693,16 @@ subroutine apt_read_cvs(this) ! ! -- deallocate local storage for aux variables if (this%naux > 0) then - deallocate(caux) + deallocate (caux) end if ! ! -- deallocate local storage for nboundchk - deallocate(nboundchk) + deallocate (nboundchk) ! ! -- return return end subroutine apt_read_cvs - + subroutine apt_read_initial_attr(this) ! ****************************************************************************** ! apt_read_initial_attr -- Read the initial parameters for this package @@ -1704,7 +1713,7 @@ subroutine apt_read_initial_attr(this) use ConstantsModule, only: LINELENGTH use BudgetModule, only: budget_cr ! -- dummy - class(GwtAptType),intent(inout) :: this + class(GwtAptType), intent(inout) :: this ! -- local !character(len=LINELENGTH) :: text integer(I4B) :: j, n @@ -1749,15 +1758,15 @@ subroutine apt_read_initial_attr(this) !call read_single_value_or_time_series(text, & ! this%stage(n)%value, & ! this%stage(n)%name, & - ! endtim, & + ! endtim, & ! this%name, 'BND', this%TsManager, & ! this%iprpak, n, jj, 'STAGE', & ! this%featname(n), this%inunit) ! -- todo: read aux - + ! -- todo: read boundname - + end do ! ! -- initialize status (iboundpak) of lakes to active @@ -1829,7 +1838,7 @@ subroutine apt_solve(this) end do end if ! - ! -- go through each gwf connection and accumulate + ! -- go through each gwf connection and accumulate ! total mass in dbuff mass do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) @@ -1848,7 +1857,7 @@ subroutine apt_solve(this) this%dbuff(n) = this%dbuff(n) + c1 end do ! - ! -- go through each lak-lak connection and accumulate + ! -- go through each lak-lak connection and accumulate ! total mass in dbuff mass if (this%idxbudfjf /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist @@ -1867,7 +1876,7 @@ subroutine apt_solve(this) this%dbuff(n) = this%dbuff(n) - rhsval ! ! -- Now to calculate c, need to divide dbuff by hcofval - c1 = - this%dbuff(n) / hcofval + c1 = -this%dbuff(n) / hcofval if (this%iboundpak(n) > 0) then this%xnewpak(n) = c1 end if @@ -1876,7 +1885,7 @@ subroutine apt_solve(this) ! -- Return return end subroutine apt_solve - + subroutine pak_solve(this) ! ****************************************************************************** ! pak_solve -- must be overridden @@ -1896,7 +1905,7 @@ subroutine pak_solve(this) ! -- Return return end subroutine pak_solve - + subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) ! ****************************************************************************** ! apt_accumulate_ccterm -- Accumulate constant concentration terms for budget. @@ -1947,21 +1956,21 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -2000,7 +2009,7 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ! -- return end subroutine apt_set_pointers - + subroutine get_volumes(this, icv, vnew, vold, delt) ! ****************************************************************************** ! get_volumes -- return the feature new volume and old volume @@ -2030,7 +2039,7 @@ subroutine get_volumes(this, icv, vnew, vold, delt) ! -- Return return end subroutine get_volumes - + function pak_get_nbudterms(this) result(nbudterms) ! ****************************************************************************** ! pak_get_nbudterms -- function to return the number of budget terms just for @@ -2049,10 +2058,10 @@ function pak_get_nbudterms(this) result(nbudterms) ! ! -- this routine should never be called call store_error('Program error: pak_get_nbudterms not implemented.', & - terminate=.TRUE.) + terminate=.TRUE.) nbudterms = 0 end function pak_get_nbudterms - + subroutine apt_setup_budobj(this) ! ****************************************************************************** ! apt_setup_budobj -- Set up the budget object that stores all the lake flows @@ -2082,7 +2091,7 @@ subroutine apt_setup_budobj(this) nlen = this%flowbudptr%budterm(this%idxbudfjf)%maxlist end if ! - ! -- Determine the number of lake budget terms. These are fixed for + ! -- Determine the number of lake budget terms. These are fixed for ! the simulation and cannot change ! -- the first 3 is for GWF, STORAGE, and CONSTANT nbudterm = 3 @@ -2126,10 +2135,10 @@ subroutine apt_setup_budobj(this) n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(n) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(n) call this%budobj%budterm(idx)%update_term(n1, n2, q) - end do + end do end if ! - ! -- + ! -- text = ' GWF' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudgwf)%maxlist @@ -2152,7 +2161,7 @@ subroutine apt_setup_budobj(this) ! -- Reserve space for the package specific terms call this%pak_setup_budobj(idx) ! - ! -- + ! -- text = ' STORAGE' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudsto)%maxlist @@ -2167,7 +2176,7 @@ subroutine apt_setup_budobj(this) naux, auxtxt) if (this%idxbudtmvr /= 0) then ! - ! -- + ! -- text = ' TO-MVR' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudtmvr)%maxlist @@ -2183,7 +2192,7 @@ subroutine apt_setup_budobj(this) end if if (this%idxbudfmvr /= 0) then ! - ! -- + ! -- text = ' FROM-MVR' idx = idx + 1 maxlist = this%ncv @@ -2197,7 +2206,7 @@ subroutine apt_setup_budobj(this) naux) end if ! - ! -- + ! -- text = ' CONSTANT' idx = idx + 1 maxlist = this%ncv @@ -2209,13 +2218,13 @@ subroutine apt_setup_budobj(this) this%packName, & maxlist, .false., .false., & naux) - + ! - ! -- + ! -- naux = this%naux if (naux > 0) then ! - ! -- + ! -- text = ' AUXILIARY' idx = idx + 1 maxlist = this%ncv @@ -2297,7 +2306,6 @@ subroutine apt_fill_budobj(this, x) this%ccterm(n1) = DZERO end do - ! -- FLOW JA FACE nlen = 0 if (this%idxbudfjf /= 0) then @@ -2312,10 +2320,9 @@ subroutine apt_fill_budobj(this, x) call this%apt_fjf_term(j, n1, n2, q) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) - end do + end do end if - ! -- GWF (LEAKAGE) idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) @@ -2325,21 +2332,19 @@ subroutine apt_fill_budobj(this, x) if (this%iboundpak(n1) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) q = this%hcof(j) * x(igwfnode) - this%rhs(j) - q = -q ! flip sign so relative to lake + q = -q ! flip sign so relative to lake end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! -- individual package terms call this%pak_fill_budobj(idx, x, ccratin, ccratout) - ! -- STORAGE idx = idx + 1 call this%budobj%budterm(idx)%reset(this%ncv) - allocate(auxvartmp(1)) + allocate (auxvartmp(1)) do n1 = 1, this%ncv call this%get_volumes(n1, v1, v0, delt) auxvartmp(1) = v1 * this%xnewpak(n1) @@ -2347,9 +2352,8 @@ subroutine apt_fill_budobj(this, x) call this%budobj%budterm(idx)%update_term(n1, n1, q, auxvartmp) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - deallocate(auxvartmp) - - + deallocate (auxvartmp) + ! -- TO MOVER if (this%idxbudtmvr /= 0) then idx = idx + 1 @@ -2361,7 +2365,7 @@ subroutine apt_fill_budobj(this, x) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! -- FROM MOVER if (this%idxbudfmvr /= 0) then idx = idx + 1 @@ -2373,7 +2377,7 @@ subroutine apt_fill_budobj(this, x) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! -- CONSTANT FLOW idx = idx + 1 call this%budobj%budterm(idx)%reset(this%ncv) @@ -2381,12 +2385,12 @@ subroutine apt_fill_budobj(this, x) q = this%ccterm(n1) call this%budobj%budterm(idx)%update_term(n1, n1, q) end do - + ! -- AUXILIARY VARIABLES naux = this%naux if (naux > 0) then idx = idx + 1 - allocate(auxvartmp(naux)) + allocate (auxvartmp(naux)) call this%budobj%budterm(idx)%reset(this%ncv) do n1 = 1, this%ncv q = DZERO @@ -2395,7 +2399,7 @@ subroutine apt_fill_budobj(this, x) end do call this%budobj%budterm(idx)%update_term(n1, n1, q, auxvartmp) end do - deallocate(auxvartmp) + deallocate (auxvartmp) end if ! ! --Terms are filled, now accumulate them for this time step @@ -2424,8 +2428,8 @@ subroutine pak_fill_budobj(this, idx, x, ccratin, ccratout) ! ----------------------------------------------------------------------------- ! ! -- this routine should never be called - call store_error('Program error: pak_fill_budobj not implemented.', & - terminate=.TRUE.) + call store_error('Program error: pak_fill_budobj not implemented.', & + terminate=.TRUE.) ! ! -- return return @@ -2447,7 +2451,7 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & n2 = ientry call this%get_volumes(n1, v1, v0, delt) c0 = this%xoldpak(n1) - c1 = this%xnewpak(n1) + c1 = this%xnewpak(n1) if (present(rrate)) rrate = -c1 * v1 / delt + c0 * v0 / delt if (present(rhsval)) rhsval = -c0 * v0 / delt if (present(hcofval)) hcofval = -v1 / delt @@ -2455,7 +2459,7 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine apt_stor_term - + subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) class(GwtAptType) :: this @@ -2478,7 +2482,7 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine apt_tmvr_term - + subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) class(GwtAptType) :: this @@ -2505,7 +2509,7 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine apt_fjf_term - + subroutine apt_copy2flowp(this) ! ****************************************************************************** ! apt_copy2flowp -- copy concentrations into flow package aux variable @@ -2535,7 +2539,7 @@ subroutine apt_copy2flowp(this) ! -- return return end subroutine apt_copy2flowp - + logical function apt_obs_supported(this) ! ****************************************************************************** ! apt_obs_supported -- obs are supported? @@ -2556,7 +2560,7 @@ logical function apt_obs_supported(this) ! -- return return end function apt_obs_supported - + subroutine apt_df_obs(this) ! ****************************************************************************** ! apt_df_obs -- obs are supported? @@ -2602,7 +2606,7 @@ subroutine apt_df_obs(this) ! for storage observation type. call this%obs%StoreObsType('storage', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID - ! + ! ! -- Store obs type and assign procedure pointer ! for constant observation type. call this%obs%StoreObsType('constant', .true., indx) @@ -2613,7 +2617,7 @@ subroutine apt_df_obs(this) ! return end subroutine apt_df_obs - + subroutine pak_df_obs(this) ! ****************************************************************************** ! pak_df_obs -- obs are supported? @@ -2635,10 +2639,10 @@ subroutine pak_df_obs(this) ! return end subroutine pak_df_obs - -subroutine apt_rp_obs(this) + + subroutine apt_rp_obs(this) ! ****************************************************************************** -! apt_rp_obs -- +! apt_rp_obs -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -2658,13 +2662,13 @@ subroutine apt_rp_obs(this) class(ObserveType), pointer :: obsrv => null() ! ------------------------------------------------------------------------------ ! -- formats -10 format('Boundary "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') +10 format('Boundary "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') ! do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv ! - ! -- indxbnds needs to be reset each stress period because + ! -- indxbnds needs to be reset each stress period because ! list of boundaries can change each stress period. call obsrv%ResetObsIndex() ! @@ -2685,7 +2689,7 @@ subroutine apt_rp_obs(this) call obsrv%AddObsIndex(j) end if end do - else if (obsrv%ObsTypeId=='FLOW-JA-FACE') then + else if (obsrv%ObsTypeId == 'FLOW-JA-FACE') then do j = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist n = this%flowbudptr%budterm(this%idxbudfjf)%id1(j) if (this%featname(n) == bname) then @@ -2702,7 +2706,7 @@ subroutine apt_rp_obs(this) end do end if if (.not. jfound) then - write(errmsg,10) trim(bname), trim(obsrv%Name), trim(this%packName) + write (errmsg, 10) trim(bname), trim(obsrv%Name), trim(this%packName) call store_error(errmsg) end if end if @@ -2726,7 +2730,7 @@ subroutine apt_rp_obs(this) '(does not correspond to control volume ', nn1, ')' call store_error(errmsg) end if - else if (obsrv%ObsTypeId=='FLOW-JA-FACE') then + else if (obsrv%ObsTypeId == 'FLOW-JA-FACE') then nn2 = obsrv%NodeNumber2 ! -- Look for the first occurrence of nn1, then set indxbnds ! to the nn2 record after that @@ -2752,7 +2756,7 @@ subroutine apt_rp_obs(this) else errmsg = 'Programming error in apt_rp_obs' call store_error(errmsg) - endif + end if end if ! ! -- catch non-cumulative observation assigned to observation defined @@ -2768,13 +2772,13 @@ subroutine apt_rp_obs(this) end if ! ! -- check that index values are valid - if (obsrv%ObsTypeId=='TO-MVR' .or. & - obsrv%ObsTypeId=='EXT-OUTFLOW') then + if (obsrv%ObsTypeId == 'TO-MVR' .or. & + obsrv%ObsTypeId == 'EXT-OUTFLOW') then ntmvr = this%flowbudptr%budterm(this%idxbudtmvr)%nlist do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > ntmvr) then - write(errmsg, '(a, a, i0, a, i0, a)') & + write (errmsg, '(a, a, i0, a, i0, a)') & trim(adjustl(obsrv%ObsTypeId)), & ' must be > 0 or <= ', ntmvr, & '. (specified value is ', nn1, ').' @@ -2784,7 +2788,7 @@ subroutine apt_rp_obs(this) else if (obsrv%ObsTypeId == trim(adjustl(this%text)) .or. & obsrv%ObsTypeId == 'FLOW-JA-FACE') then do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > this%maxbound) then write (errmsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & @@ -2795,7 +2799,7 @@ subroutine apt_rp_obs(this) end do else do j = 1, obsrv%indxbnds_count - nn1 = obsrv%indxbnds(j) + nn1 = obsrv%indxbnds(j) if (nn1 < 1 .or. nn1 > this%ncv) then write (errmsg, '(4x,a,1x,a,1x,a,1x,i0,1x,a,1x,i0,1x,a)') & 'ERROR:', trim(adjustl(obsrv%ObsTypeId)), & @@ -2814,7 +2818,7 @@ subroutine apt_rp_obs(this) ! return end subroutine apt_rp_obs - + subroutine apt_bd_obs(this) ! ****************************************************************************** ! apt_bd_obs -- Calculate observations common to SFT/LKT/MWT/UZT @@ -2847,55 +2851,55 @@ subroutine apt_bd_obs(this) v = DNODATA jj = obsrv%indxbnds(j) select case (obsrv%ObsTypeId) - case ('CONCENTRATION') - if (this%iboundpak(jj) /= 0) then - v = this%xnewpak(jj) - end if - case ('LKT', 'SFT', 'MWT', 'UZT') - n = this%flowbudptr%budterm(this%idxbudgwf)%id1(jj) - if (this%iboundpak(n) /= 0) then - igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(jj) - v = this%hcof(jj) * this%xnew(igwfnode) - this%rhs(jj) - v = -v - end if - case ('FLOW-JA-FACE') - n = this%flowbudptr%budterm(this%idxbudgwf)%id1(jj) + case ('CONCENTRATION') + if (this%iboundpak(jj) /= 0) then + v = this%xnewpak(jj) + end if + case ('LKT', 'SFT', 'MWT', 'UZT') + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(jj) + if (this%iboundpak(n) /= 0) then + igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(jj) + v = this%hcof(jj) * this%xnew(igwfnode) - this%rhs(jj) + v = -v + end if + case ('FLOW-JA-FACE') + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(jj) + if (this%iboundpak(n) /= 0) then + call this%apt_fjf_term(jj, n1, n2, v) + end if + case ('STORAGE') + if (this%iboundpak(jj) /= 0) then + v = this%qsto(jj) + end if + case ('CONSTANT') + if (this%iboundpak(jj) /= 0) then + v = this%ccterm(jj) + end if + case ('FROM-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudfmvr > 0) then + v = this%qmfrommvr(jj) + end if + case ('TO-MVR') + if (this%idxbudtmvr > 0) then + n = this%flowbudptr%budterm(this%idxbudtmvr)%id1(jj) if (this%iboundpak(n) /= 0) then - call this%apt_fjf_term(jj, n1, n2, v) - end if - case ('STORAGE') - if (this%iboundpak(jj) /= 0) then - v = this%qsto(jj) - end if - case ('CONSTANT') - if (this%iboundpak(jj) /= 0) then - v = this%ccterm(jj) - end if - case ('FROM-MVR') - if (this%iboundpak(jj) /= 0 .and. this%idxbudfmvr > 0) then - v = this%qmfrommvr(jj) - end if - case ('TO-MVR') - if (this%idxbudtmvr > 0) then - n = this%flowbudptr%budterm(this%idxbudtmvr)%id1(jj) - if (this%iboundpak(n) /= 0) then - call this%apt_tmvr_term(jj, n1, n2, v) - end if - end if - case default - found = .false. - ! - ! -- check the child package for any specific obs - call this%pak_bd_obs(obsrv%ObsTypeId, jj, v, found) - ! - ! -- if none found then terminate with an error - if (.not. found) then - errmsg = 'Unrecognized observation type "' // & - trim(obsrv%ObsTypeId) // '" for ' // & - trim(adjustl(this%text)) // ' package ' // & - trim(this%packName) - call store_error(errmsg, terminate=.TRUE.) + call this%apt_tmvr_term(jj, n1, n2, v) end if + end if + case default + found = .false. + ! + ! -- check the child package for any specific obs + call this%pak_bd_obs(obsrv%ObsTypeId, jj, v, found) + ! + ! -- if none found then terminate with an error + if (.not. found) then + errmsg = 'Unrecognized observation type "'// & + trim(obsrv%ObsTypeId)//'" for '// & + trim(adjustl(this%text))//' package '// & + trim(this%packName) + call store_error(errmsg, terminate=.TRUE.) + end if end select call this%obs%SaveOneSimval(obsrv, v) end do @@ -2912,7 +2916,7 @@ end subroutine apt_bd_obs subroutine pak_bd_obs(this, obstypeid, jj, v, found) ! ****************************************************************************** -! pak_bd_obs -- +! pak_bd_obs -- ! -- check for observations in concrete packages. ! ****************************************************************************** ! @@ -2945,9 +2949,9 @@ subroutine apt_process_obsID(obsrv, dis, inunitobs, iout) ! -- modules ! -- dummy type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1, nn2 integer(I4B) :: icol, istart, istop @@ -2981,18 +2985,18 @@ subroutine apt_process_obsID(obsrv, dis, inunitobs, iout) end if !! -- store connection number (NodeNumber2) !obsrv%NodeNumber2 = nn2 - endif - endif + end if + end if ! -- store lake number (NodeNumber) obsrv%NodeNumber = nn1 ! return end subroutine apt_process_obsID - + subroutine apt_setup_tableobj(this) ! ****************************************************************************** -! apt_setup_tableobj -- Set up the table object that is used to write the apt -! conc data. The terms listed here must correspond in +! apt_setup_tableobj -- Set up the table object that is used to write the apt +! conc data. The terms listed here must correspond in ! in the apt_ot method. ! ****************************************************************************** ! @@ -3016,12 +3020,13 @@ subroutine apt_setup_tableobj(this) if (this%inamedbound == 1) nterms = nterms + 1 ! ! -- set up table title - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(adjustl(this%packName)) //') CONCENTRATION FOR EACH CONTROL VOLUME' + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(adjustl(this%packName))// & + ') CONCENTRATION FOR EACH CONTROL VOLUME' ! ! -- set up dv tableobj call table_cr(this%dvtab, this%packName, title) - call this%dvtab%table_df(this%ncv, nterms, this%iout, & + call this%dvtab%table_df(this%ncv, nterms, this%iout, & transient=.TRUE.) ! ! -- Go through and set up table budget term @@ -3043,4 +3048,4 @@ subroutine apt_setup_tableobj(this) return end subroutine apt_setup_tableobj -end module GwtAptModule \ No newline at end of file +end module GwtAptModule diff --git a/src/Model/GroundWaterTransport/gwt1dsp.f90 b/src/Model/GroundWaterTransport/gwt1dsp.f90 index d2a8fdd6d47..08d68b06d86 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp.f90 @@ -1,13 +1,13 @@ module GwtDspModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DONE, DZERO, DHALF, DPI + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, DHALF, DPI use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType - use Xt3dModule, only: Xt3dType, xt3d_cr - use GwtDspOptionsModule, only: GwtDspOptionsType - use GwtDspGridDataModule, only: GwtDspGridDataType + use BaseDisModule, only: DisBaseType + use TspFmiModule, only: TspFmiType + use Xt3dModule, only: Xt3dType, xt3d_cr + use TspDspOptionsModule, only: TspDspOptionsType + use TspDspGridDataModule, only: TspDspGridDataType implicit none private @@ -15,35 +15,35 @@ module GwtDspModule public :: dsp_cr type, extends(NumericalPackageType) :: GwtDspType - - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWT model ibound - type(GwtFmiType), pointer :: fmi => null() ! pointer to GWT fmi object - real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWT storage porosity - real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell - real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: alv => null() ! longitudinal vertical dispersivity - real(DP), dimension(:), pointer, contiguous :: ath1 => null() ! transverse horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: ath2 => null() ! transverse horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity - integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active - integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active - integer(I4B), pointer :: ixt3d => null() ! flag indicating xt3d is active - type(Xt3dType), pointer :: xt3d => null() ! xt3d object - real(DP), dimension(:), pointer, contiguous :: dispcoef => null() ! disp coefficient (only if xt3d not active) - integer(I4B), pointer :: id22 => null() ! flag indicating d22 is available - integer(I4B), pointer :: id33 => null() ! flag indicating d33 is available - real(DP), dimension(:), pointer, contiguous :: d11 => null() ! dispersion coefficient - real(DP), dimension(:), pointer, contiguous :: d22 => null() ! dispersion coefficient - real(DP), dimension(:), pointer, contiguous :: d33 => null() ! dispersion coefficient - real(DP), dimension(:), pointer, contiguous :: angle1 => null() ! rotation angle 1 - real(DP), dimension(:), pointer, contiguous :: angle2 => null() ! rotation angle 2 - real(DP), dimension(:), pointer, contiguous :: angle3 => null() ! rotation angle 3 - integer(I4B), pointer :: iangle1 => null() ! flag indicating angle1 is available - integer(I4B), pointer :: iangle2 => null() ! flag indicating angle2 is available - integer(I4B), pointer :: iangle3 => null() ! flag indicating angle3 is available - + + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWT model ibound + type(TspFmiType), pointer :: fmi => null() ! pointer to GWT fmi object + real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWT storage porosity + real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell + real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: alv => null() ! longitudinal vertical dispersivity + real(DP), dimension(:), pointer, contiguous :: ath1 => null() ! transverse horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: ath2 => null() ! transverse horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity + integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active + integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active + integer(I4B), pointer :: ixt3d => null() ! flag indicating xt3d is active + type(Xt3dType), pointer :: xt3d => null() ! xt3d object + real(DP), dimension(:), pointer, contiguous :: dispcoef => null() ! disp coefficient (only if xt3d not active) + integer(I4B), pointer :: id22 => null() ! flag indicating d22 is available + integer(I4B), pointer :: id33 => null() ! flag indicating d33 is available + real(DP), dimension(:), pointer, contiguous :: d11 => null() ! dispersion coefficient + real(DP), dimension(:), pointer, contiguous :: d22 => null() ! dispersion coefficient + real(DP), dimension(:), pointer, contiguous :: d33 => null() ! dispersion coefficient + real(DP), dimension(:), pointer, contiguous :: angle1 => null() ! rotation angle 1 + real(DP), dimension(:), pointer, contiguous :: angle2 => null() ! rotation angle 2 + real(DP), dimension(:), pointer, contiguous :: angle3 => null() ! rotation angle 3 + integer(I4B), pointer :: iangle1 => null() ! flag indicating angle1 is available + integer(I4B), pointer :: iangle2 => null() ! flag indicating angle2 is available + integer(I4B), pointer :: iangle3 => null() ! flag indicating angle3 is available + contains - + procedure :: dsp_df procedure :: dsp_ac procedure :: dsp_mc @@ -59,11 +59,11 @@ module GwtDspModule procedure, private :: set_data procedure, private :: calcdispellipse procedure, private :: calcdispcoef - + end type GwtDspType - - contains - + +contains + subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) ! ****************************************************************************** ! dsp_cr -- Create a new DSP object @@ -76,11 +76,11 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout - type(GwtFmiType), intent(in), target :: fmi + type(TspFmiType), intent(in), target :: fmi ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(dspobj) + allocate (dspobj) ! ! -- create name and memory path call dspobj%set_names(1, name_model, 'DSP', 'DSP') @@ -108,12 +108,12 @@ subroutine dsp_df(this, dis, dspOptions) ! -- dummy class(GwtDspType) :: this class(DisBaseType), pointer :: dis - type(GwtDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not + type(TspDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not !! creating DSP from file ! -- local ! -- formats - character(len=*), parameter :: fmtdsp = & - "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & + character(len=*), parameter :: fmtdsp = & + "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! @@ -127,7 +127,7 @@ subroutine dsp_df(this, dis, dspOptions) ! -- Read dispersion options if (present(dspOptions)) then this%ixt3d = dspOptions%ixt3d - else + else ! ! -- Initialize block parser call this%parser%Initialize(this%inunit, this%iout) @@ -135,12 +135,12 @@ subroutine dsp_df(this, dis, dspOptions) end if ! ! -- xt3d create - if(this%ixt3d > 0) then - call xt3d_cr(this%xt3d, this%name_model, this%inunit, this%iout, & + if (this%ixt3d > 0) then + call xt3d_cr(this%xt3d, this%name_model, this%inunit, this%iout, & ldispopt=.true.) this%xt3d%ixt3d = this%ixt3d call this%xt3d%xt3d_df(dis) - endif + end if ! ! -- Return return @@ -188,7 +188,7 @@ subroutine dsp_mc(this, moffset, iasln, jasln) ! ------------------------------------------------------------------------------ ! ! -- Call xt3d map connections - if(this%ixt3d > 0) call this%xt3d%xt3d_mc(moffset, iasln, jasln) + if (this%ixt3d > 0) call this%xt3d%xt3d_mc(moffset, iasln, jasln) ! ! -- Return return @@ -210,18 +210,18 @@ subroutine dsp_ar(this, ibound, porosity, grid_data) !! to create the package without input file ! -- local ! -- formats - character(len=*), parameter :: fmtdsp = & - "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & + character(len=*), parameter :: fmtdsp = & + "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! -- dsp pointers to arguments that were passed in - this%ibound => ibound + this%ibound => ibound this%porosity => porosity ! ! -- Print a message identifying the dispersion package. if (this%iout > 0) then - write(this%iout, fmtdsp) this%inunit + write (this%iout, fmtdsp) this%inunit end if ! ! -- Allocate arrays @@ -231,7 +231,7 @@ subroutine dsp_ar(this, ibound, porosity, grid_data) ! -- Set dispersion data call this%set_data(grid_data) else - ! -- Read dispersion data + ! -- Read dispersion data call this%read_data() end if ! @@ -257,11 +257,13 @@ subroutine dsp_ad(this) ! TODO: might consider adding a new mf6 level set pointers method, and ! doing this stuff there instead of in the time step loop. if (kstp * kper == 1) then - if(this%ixt3d > 0) call this%xt3d%xt3d_ar(this%fmi%ibdgwfsat0, & - this%d11, this%id33, this%d33, this%fmi%gwfsat, this%id22, this%d22, & - this%iangle1, this%iangle2, this%iangle3, & - this%angle1, this%angle2, this%angle3) - endif + if (this%ixt3d > 0) then + call this%xt3d%xt3d_ar(this%fmi%ibdgwfsat0, this%d11, this%id33, & + this%d33, this%fmi%gwfsat, this%id22, this%d22, & + this%iangle1, this%iangle2, this%iangle3, & + this%angle1, this%angle2, this%angle3) + end if + end if ! ! -- Fill d11, d22, d33, angle1, angle2, angle3 using specific discharge call this%calcdispellipse() @@ -272,7 +274,7 @@ subroutine dsp_ad(this) call this%calcdispcoef() else if (this%ixt3d > 0) then call this%xt3d%xt3d_fcpc(this%dis%nodes, .false.) - endif + end if end if ! ! -- Return @@ -290,29 +292,29 @@ subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) ! -- dummy class(GwtDspType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amatsln - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),intent(inout),dimension(nodes) :: rhs - real(DP),intent(inout),dimension(nodes) :: cnew + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amatsln + integer(I4B), intent(in), dimension(nja) :: idxglo + real(DP), intent(inout), dimension(nodes) :: rhs + real(DP), intent(inout), dimension(nodes) :: cnew ! -- local integer(I4B) :: n, m, idiag, idiagm, ipos, isympos, isymcon real(DP) :: dnm ! ------------------------------------------------------------------------------ ! - if(this%ixt3d > 0) then + if (this%ixt3d > 0) then call this%xt3d%xt3d_fc(kiter, njasln, amatsln, idxglo, rhs, cnew) else do n = 1, nodes - if(this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%ibdgwfsat0(n) == 0) cycle idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 if (this%dis%con%mask(ipos) == 0) cycle m = this%dis%con%ja(ipos) if (m < n) cycle - if(this%fmi%ibdgwfsat0(m) == 0) cycle + if (this%fmi%ibdgwfsat0(m) == 0) cycle isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) ! @@ -325,14 +327,14 @@ subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) isymcon = this%dis%con%isym(ipos) amatsln(idxglo(isymcon)) = amatsln(idxglo(isymcon)) + dnm amatsln(idxglo(idiagm)) = amatsln(idxglo(idiagm)) - dnm - enddo - enddo - endif + end do + end do + end if ! ! -- Return return end subroutine dsp_fc - + subroutine dsp_cq(this, cnew, flowja) ! ****************************************************************************** ! dsp_cq -- Calculate dispersion contribution to flowja @@ -351,25 +353,25 @@ subroutine dsp_cq(this, cnew, flowja) ! ------------------------------------------------------------------------------ ! ! -- Calculate dispersion and add to flowja - if(this%ixt3d > 0) then + if (this%ixt3d > 0) then call this%xt3d%xt3d_flowja(cnew, flowja) else do n = 1, this%dis%nodes - if(this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%ibdgwfsat0(n) == 0) cycle do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) - if(this%fmi%ibdgwfsat0(m) == 0) cycle + if (this%fmi%ibdgwfsat0(m) == 0) cycle isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) flowja(ipos) = flowja(ipos) + dnm * (cnew(m) - cnew(n)) - enddo - enddo - endif + end do + end do + end if ! ! -- Return return end subroutine dsp_cq - + subroutine allocate_scalars(this) ! ****************************************************************************** ! allocate_scalars @@ -444,11 +446,11 @@ subroutine allocate_arrays(this, nodes) ! ! -- Allocate dispersion coefficient array if xt3d not in use if (this%ixt3d == 0) then - call mem_allocate(this%dispcoef, this%dis%njas, 'DISPCOEF', & - trim(this%memoryPath)) + call mem_allocate(this%dispcoef, this%dis%njas, 'DISPCOEF', & + trim(this%memoryPath)) else call mem_allocate(this%dispcoef, 0, 'DISPCOEF', trim(this%memoryPath)) - endif + end if ! ! -- Return return @@ -487,7 +489,7 @@ subroutine dsp_da(this) end if ! ! -- deallocate objects - if (this%ixt3d > 0) deallocate(this%xt3d) + if (this%ixt3d > 0) deallocate (this%xt3d) ! ! -- deallocate scalars call mem_deallocate(this%idiffc) @@ -514,8 +516,8 @@ subroutine read_options(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error ! -- dummy class(GwtDspType) :: this ! -- local @@ -531,27 +533,27 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING DISPERSION OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING DISPERSION OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('XT3D_OFF') - this%ixt3d = 0 - write(this%iout, '(4x,a)') & - 'XT3D FORMULATION HAS BEEN SHUT OFF.' - case ('XT3D_RHS') - this%ixt3d = 2 - write(this%iout, '(4x,a)') & - 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' - case default - write(errmsg,'(4x,a,a)')'UNKNOWN DISPERSION OPTION: ', & - trim(keyword) - call store_error(errmsg, terminate=.TRUE.) + case ('XT3D_OFF') + this%ixt3d = 0 + write (this%iout, '(4x,a)') & + 'XT3D FORMULATION HAS BEEN SHUT OFF.' + case ('XT3D_RHS') + this%ixt3d = 2 + write (this%iout, '(4x,a)') & + 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' + case default + write (errmsg, '(4x,a,a)') 'UNKNOWN DISPERSION OPTION: ', & + trim(keyword) + call store_error(errmsg, terminate=.TRUE.) end select end do - write(this%iout,'(1x,a)')'END OF DISPERSION OPTIONS' + write (this%iout, '(1x,a)') 'END OF DISPERSION OPTIONS' end if ! ! -- Return @@ -565,8 +567,8 @@ subroutine read_data(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors use MemoryManagerModule, only: mem_reallocate, mem_copyptr, mem_reassignptr ! -- dummy class(GwtDsptype) :: this @@ -575,16 +577,16 @@ subroutine read_data(this) character(len=:), allocatable :: line integer(I4B) :: istart, istop, lloc, ierr logical :: isfound, endOfBlock - logical, dimension(6) :: lname + logical, dimension(6) :: lname character(len=24), dimension(6) :: aname ! -- formats ! -- data - data aname(1) /' DIFFUSION COEFFICIENT'/ - data aname(2) /' ALH'/ - data aname(3) /' ALV'/ - data aname(4) /' ATH1'/ - data aname(5) /' ATH2'/ - data aname(6) /' ATV'/ + data aname(1)/' DIFFUSION COEFFICIENT'/ + data aname(2)/' ALH'/ + data aname(3)/' ALV'/ + data aname(4)/' ATH1'/ + data aname(5)/' ATH2'/ + data aname(6)/' ATV'/ ! ------------------------------------------------------------------------------ ! ! -- initialize @@ -593,8 +595,8 @@ subroutine read_data(this) ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -603,130 +605,131 @@ subroutine read_data(this) lloc = 1 select case (keyword) case ('DIFFC') - call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & + call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%diffc, & - aname(1)) - lname(1) = .true. + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%diffc, & + aname(1)) + lname(1) = .true. case ('ALH') - call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%alh, & - aname(2)) - lname(2) = .true. + call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%alh, & + aname(2)) + lname(2) = .true. case ('ALV') - call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%alv, & - aname(3)) - lname(3) = .true. + call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%alv, & + aname(3)) + lname(3) = .true. case ('ATH1') - call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ath1, & - aname(4)) + call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%ath1, & + aname(4)) lname(4) = .true. case ('ATH2') - call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ath2, & - aname(5)) + call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%ath2, & + aname(5)) lname(5) = .true. case ('ATV') - call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%atv, & - aname(6)) - lname(6) = .true. + call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%atv, & + aname(6)) + lname(6) = .true. case default - write(errmsg,'(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) + write (errmsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) call store_error(errmsg) call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else - write(errmsg,'(1x,a)') 'Required GRIDDATA block not found.' + write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if ! - if(lname(1)) this%idiffc = 1 - if(lname(2)) this%idisp = this%idisp + 1 - if(lname(3)) this%idisp = this%idisp + 1 - if(lname(4)) this%idisp = this%idisp + 1 - if(lname(5)) this%idisp = this%idisp + 1 + if (lname(1)) this%idiffc = 1 + if (lname(2)) this%idisp = this%idisp + 1 + if (lname(3)) this%idisp = this%idisp + 1 + if (lname(4)) this%idisp = this%idisp + 1 + if (lname(5)) this%idisp = this%idisp + 1 ! ! -- if dispersivities are specified, then both alh and ath1 must be included - if(this%idisp > 0) then + if (this%idisp > 0) then ! ! -- make sure alh was specified if (.not. lname(2)) then - write(errmsg,'(1x,a)') 'IF DISPERSIVITIES ARE SPECIFIED THEN ALH IS REQUIRED.' + write (errmsg, '(1x,a)') & + 'IF DISPERSIVITIES ARE SPECIFIED THEN ALH IS REQUIRED.' call store_error(errmsg) - endif + end if ! ! -- make sure ath1 was specified if (.not. lname(4)) then - write(errmsg,'(1x,a)') 'IF DISPERSIVITIES ARE SPECIFIED THEN ATH1 IS REQUIRED.' + write (errmsg, '(1x,a)') & + 'IF DISPERSIVITIES ARE SPECIFIED THEN ATH1 IS REQUIRED.' call store_error(errmsg) - endif + end if ! ! -- If alv not specified then point it to alh - if(.not. lname(3)) then - call mem_reassignptr(this%alv, 'ALV', trim(this%memoryPath), & - 'ALH', trim(this%memoryPath)) - endif + if (.not. lname(3)) then + call mem_reassignptr(this%alv, 'ALV', trim(this%memoryPath), & + 'ALH', trim(this%memoryPath)) + end if ! ! -- If ath2 not specified then assign it to ath1 if (.not. lname(5)) then - call mem_reassignptr(this%ath2, 'ATH2', trim(this%memoryPath), & - 'ATH1', trim(this%memoryPath)) - endif + call mem_reassignptr(this%ath2, 'ATH2', trim(this%memoryPath), & + 'ATH1', trim(this%memoryPath)) + end if ! ! -- If atv not specified then assign it to ath2 if (.not. lname(6)) then - call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & - 'ATH2', trim(this%memoryPath)) - endif - endif + call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & + 'ATH2', trim(this%memoryPath)) + end if + end if ! ! -- terminate if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return end subroutine read_data - !< @brief Set the grid data to the package !< subroutine set_data(this, grid_data) use MemoryManagerModule, only: mem_reallocate - class(GwtDspType) :: this !< this DSP package + class(GwtDspType) :: this !< this DSP package type(GwtDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data ! local integer(I4B) :: i - call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & + call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & trim(this%memoryPath)) - call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & + call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & trim(this%memoryPath)) - call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & + call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & trim(this%memoryPath)) - call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & + call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & trim(this%memoryPath)) - call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & + call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & trim(this%memoryPath)) - call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & + call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & trim(this%memoryPath)) do i = 1, this%dis%nodes @@ -770,7 +773,7 @@ subroutine calcdispellipse(this) this%angle1(n) = DZERO this%angle2(n) = DZERO this%angle3(n) = DZERO - if(this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%ibdgwfsat0(n) == 0) cycle ! ! -- specific discharge qx = DZERO @@ -780,7 +783,7 @@ subroutine calcdispellipse(this) qx = this%fmi%gwfspdis(1, n) qy = this%fmi%gwfspdis(2, n) qz = this%fmi%gwfspdis(3, n) - q = qx ** 2 + qy ** 2 + qz ** 2 + q = qx**2 + qy**2 + qz**2 if (q > DZERO) q = sqrt(q) ! ! -- dispersion coefficients @@ -795,22 +798,22 @@ subroutine calcdispellipse(this) ath1 = this%ath1(n) ath2 = this%ath2(n) atv = this%atv(n) - endif + end if dstar = DZERO if (this%idiffc > 0) then dstar = this%diffc(n) * this%porosity(n) - endif + end if ! ! -- Calculate the longitudal and transverse dispersivities al = DZERO at1 = DZERO at2 = DZERO if (q > DZERO) then - qzoqsquared = (qz / q) ** 2 + qzoqsquared = (qz / q)**2 al = alh * (DONE - qzoqsquared) + alv * qzoqsquared at1 = ath1 * (DONE - qzoqsquared) + atv * qzoqsquared at2 = ath2 * (DONE - qzoqsquared) + atv * qzoqsquared - endif + end if ! ! -- Calculate and save the diagonal components of the dispersion tensor this%d11(n) = al * q + dstar @@ -839,7 +842,7 @@ subroutine calcdispellipse(this) a = qx / a else a = DZERO - endif + end if ! ! -- acos(1) not defined, so set to zero if necessary if (a <= -DONE) then @@ -848,10 +851,10 @@ subroutine calcdispellipse(this) this%angle1(n) = DZERO else this%angle1(n) = acos(a) - endif + end if ! - endif - enddo + end if + end do ! ! -- Return return @@ -885,7 +888,7 @@ subroutine calcdispcoef(this) ! -- Proces connections nodes = size(this%d11) do n = 1, nodes - if(this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%ibdgwfsat0(n) == 0) cycle idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 ! @@ -896,7 +899,7 @@ subroutine calcdispcoef(this) if (m < n) cycle isympos = this%dis%con%jas(ipos) this%dispcoef(isympos) = DZERO - if(this%fmi%ibdgwfsat0(m) == 0) cycle + if (this%fmi%ibdgwfsat0(m) == 0) cycle ! ! -- cell dimensions hwva = this%dis%con%hwva(isympos) @@ -916,16 +919,16 @@ subroutine calcdispcoef(this) ! normal to the shared n-m face and for cell m in the direction ! normal to the shared n-m face. call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, ipos) - dn = hyeff_calc(this%d11(n), this%d22(n), this%d33(n), & - this%angle1(n), this%angle2(n), this%angle3(n), & + dn = hyeff_calc(this%d11(n), this%d22(n), this%d33(n), & + this%angle1(n), this%angle2(n), this%angle3(n), & vg1, vg2, vg3, iavgmeth) - dm = hyeff_calc(this%d11(m), this%d22(m), this%d33(m), & - this%angle1(m), this%angle2(m), this%angle3(m), & + dm = hyeff_calc(this%d11(m), this%d22(m), this%d33(m), & + this%angle1(m), this%angle2(m), this%angle3(m), & vg1, vg2, vg3, iavgmeth) ! ! -- Calculate dispersion conductance based on NPF subroutines and the ! effective dispersion coefficients dn and dm. - if(ihc == 0) then + if (ihc == 0) then clnm = satn * (topn - botn) * DHALF clmn = satm * (topm - botm) * DHALF anm = hwva @@ -935,18 +938,18 @@ subroutine calcdispcoef(this) anm = DZERO else if (n > m .and. satn < DONE) then anm = DZERO - endif + end if ! ! -- m is convertible and unsaturated if (satm == DZERO) then anm = DZERO else if (m > n .and. satm < DONE) then anm = DZERO - endif + end if ! ! -- amn is the same as anm for vertical flow amn = anm - ! + ! else ! ! -- horizontal conductance @@ -971,7 +974,7 @@ subroutine calcdispcoef(this) if (satn == DZERO .or. satm == DZERO) then anm = DZERO amn = DZERO - endif + end if ! end if ! @@ -990,11 +993,11 @@ subroutine calcdispcoef(this) ! -- Assign the calculated dispersion conductance this%dispcoef(isympos) = cond ! - enddo - enddo + end do + end do ! ! -- Return return end subroutine calcdispcoef - + end module GwtDspModule diff --git a/src/Model/GroundWaterTransport/gwt1ist1.f90 b/src/Model/GroundWaterTransport/gwt1ist1.f90 index 83e0e9daea4..eb44d228d29 100644 --- a/src/Model/GroundWaterTransport/gwt1ist1.f90 +++ b/src/Model/GroundWaterTransport/gwt1ist1.f90 @@ -1,6 +1,6 @@ !> -- @ brief Immobile Storage and Transfer (IST) Module !! -!! The GwtIstModule is contains the GwtIstType, which is the +!! The GwtIstModule is contains the GwtIstType, which is the !! derived type responsible for adding the effects of an !! immobile domain. In addition to representing transfer !! of mass between the mobile and immobile domain, the IST @@ -13,69 +13,69 @@ !< module GwtIstModule - use KindModule, only: DP, I4B - use ConstantsModule, only: DONE, DZERO, LENFTYPE, & - LENPACKAGENAME, & - LENBUDTXT, DHNOFLO - use BndModule, only: BndType - use BudgetModule, only: BudgetType - use GwtFmiModule, only: GwtFmiType - use GwtMstModule, only: GwtMstType, get_zero_order_decay - use OutputControlDataModule, only: OutputControlDataType + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, LENFTYPE, & + LENPACKAGENAME, & + LENBUDTXT, DHNOFLO + use BndModule, only: BndType + use BudgetModule, only: BudgetType + use TspFmiModule, only: TspFmiType + use GwtMstModule, only: GwtMstType, get_zero_order_decay + use OutputControlDataModule, only: OutputControlDataType ! implicit none ! private public :: ist_create ! - character(len=LENFTYPE) :: ftype = 'IST' - character(len=LENPACKAGENAME) :: text = ' IMMOBILE DOMAIN' + character(len=LENFTYPE) :: ftype = 'IST' + character(len=LENPACKAGENAME) :: text = ' IMMOBILE DOMAIN' integer(I4B), parameter :: NBDITEMS = 5 character(len=LENBUDTXT), dimension(NBDITEMS) :: budtxt - data budtxt / ' STORAGE-AQUEOUS', ' STORAGE-SORBED', & - ' DECAY-AQUEOUS', ' DECAY-SORBED', & - ' MOBILE-DOMAIN' / + data budtxt/' STORAGE-AQUEOUS', ' STORAGE-SORBED', & + ' DECAY-AQUEOUS', ' DECAY-SORBED', & + ' MOBILE-DOMAIN'/ !> @ brief Immobile storage and transfer !! !! Data and methods for handling the effects of an !! immobile domain. Note that there can be as many of these !! domains as necessary. Each immobile domain represents - !! changes in immobile solute storage, decay of dissolved - !! immobile solute mass, sorption within the immobile domain, + !! changes in immobile solute storage, decay of dissolved + !! immobile solute mass, sorption within the immobile domain, !! and decay of immobile domain sorbed mass. The immobile !! domain also includes exchange with the mobile domain. !< type, extends(BndType) :: GwtIstType - - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object - type(GwtMstType), pointer :: mst => null() !< pointer to mst object - - integer(I4B), pointer :: icimout => null() !< unit number for binary cim output - integer(I4B), pointer :: ibudgetout => null() !< binary budget output file - integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file - integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) - integer(I4B), pointer :: isrb => null() !< sorption active flag (0:off, 1:on) - integer(I4B), pointer :: kiter => null() !< picard iteration counter - real(DP), dimension(:), pointer, contiguous :: cim => null() !< concentration for immobile domain - real(DP), dimension(:), pointer, contiguous :: cimnew => null() !< immobile concentration at end of current time step - real(DP), dimension(:), pointer, contiguous :: cimold => null() !< immobile concentration at end of last time step - real(DP), dimension(:), pointer, contiguous :: zetaim => null() !< mass transfer rate to immobile domain - real(DP), dimension(:), pointer, contiguous :: thetaim => null() !< porosity of the immobile domain - real(DP), dimension(:), pointer, contiguous :: bulk_density => null() !< bulk density - real(DP), dimension(:), pointer, contiguous :: distcoef => null() !< distribution coefficient - real(DP), dimension(:), pointer, contiguous :: decay => null() !< first or zero order rate constant for liquid - real(DP), dimension(:), pointer, contiguous :: decaylast => null() !< decay rate used for last iteration (needed for zero order decay) - real(DP), dimension(:), pointer, contiguous :: decayslast => null() !< sorbed decay rate used for last iteration (needed for zero order decay) - real(DP), dimension(:), pointer, contiguous :: decay_sorbed => null() !< first or zero order rate constant for sorbed mass - real(DP), dimension(:), pointer, contiguous :: strg => null() !< mass transfer rate - real(DP), dimension(2, NBDITEMS) :: budterm !< immmobile domain mass summaries - - type(BudgetType), pointer :: budget => null() !< budget object - type(OutputControlDataType), pointer :: ocd => null() !< output control object for cim - + + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + type(GwtMstType), pointer :: mst => null() !< pointer to mst object + + integer(I4B), pointer :: icimout => null() !< unit number for binary cim output + integer(I4B), pointer :: ibudgetout => null() !< binary budget output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) + integer(I4B), pointer :: isrb => null() !< sorption active flag (0:off, 1:on) + integer(I4B), pointer :: kiter => null() !< picard iteration counter + real(DP), dimension(:), pointer, contiguous :: cim => null() !< concentration for immobile domain + real(DP), dimension(:), pointer, contiguous :: cimnew => null() !< immobile concentration at end of current time step + real(DP), dimension(:), pointer, contiguous :: cimold => null() !< immobile concentration at end of last time step + real(DP), dimension(:), pointer, contiguous :: zetaim => null() !< mass transfer rate to immobile domain + real(DP), dimension(:), pointer, contiguous :: thetaim => null() !< porosity of the immobile domain + real(DP), dimension(:), pointer, contiguous :: bulk_density => null() !< bulk density + real(DP), dimension(:), pointer, contiguous :: distcoef => null() !< distribution coefficient + real(DP), dimension(:), pointer, contiguous :: decay => null() !< first or zero order rate constant for liquid + real(DP), dimension(:), pointer, contiguous :: decaylast => null() !< decay rate used for last iteration (needed for zero order decay) + real(DP), dimension(:), pointer, contiguous :: decayslast => null() !< sorbed decay rate used for last iteration (needed for zero order decay) + real(DP), dimension(:), pointer, contiguous :: decay_sorbed => null() !< first or zero order rate constant for sorbed mass + real(DP), dimension(:), pointer, contiguous :: strg => null() !< mass transfer rate + real(DP), dimension(2, NBDITEMS) :: budterm !< immmobile domain mass summaries + + type(BudgetType), pointer :: budget => null() !< budget object + type(OutputControlDataType), pointer :: ocd => null() !< output control object for cim + contains - + procedure :: bnd_ar => ist_ar procedure :: bnd_rp => ist_rp procedure :: bnd_ad => ist_ad @@ -91,11 +91,11 @@ module GwtIstModule procedure :: read_options procedure, private :: ist_allocate_arrays procedure, private :: read_data - + end type GwtIstType - - contains - + +contains + !> @ brief Create a new package object !! !! Create a new IST object @@ -104,20 +104,20 @@ module GwtIstModule subroutine ist_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, mst) ! -- dummy - class(BndType), pointer :: packobj !< BndType pointer that will point to new IST Package - integer(I4B),intent(in) :: id !< name of the model - integer(I4B),intent(in) :: ibcnum !< consecutive package number - integer(I4B),intent(in) :: inunit !< unit number of package input file - integer(I4B),intent(in) :: iout !< unit number of model listing file - character(len=*), intent(in) :: namemodel !< name of the model - character(len=*), intent(in) :: pakname !< name of the package + class(BndType), pointer :: packobj !< BndType pointer that will point to new IST Package + integer(I4B), intent(in) :: id !< name of the model + integer(I4B), intent(in) :: ibcnum !< consecutive package number + integer(I4B), intent(in) :: inunit !< unit number of package input file + integer(I4B), intent(in) :: iout !< unit number of model listing file + character(len=*), intent(in) :: namemodel !< name of the model + character(len=*), intent(in) :: pakname !< name of the package ! -- local type(GwtIstType), pointer :: istobj - type(GwtFmiType), pointer :: fmi + type(TspFmiType), pointer :: fmi type(GwtMstType), pointer :: mst ! ! -- allocate the object and assign values to object variables - allocate(istobj) + allocate (istobj) packobj => istobj ! ! -- create name and memory path @@ -156,16 +156,16 @@ subroutine ist_ar(this) use SimModule, only: store_error, count_errors use BudgetModule, only: budget_cr ! -- dummy - class(GwtIstType), intent(inout) :: this !< GwtIstType object + class(GwtIstType), intent(inout) :: this !< GwtIstType object ! -- local integer(I4B) :: n ! -- formats - character(len=*), parameter :: fmtist = & - "(1x,/1x,'IST -- IMMOBILE DOMAIN STORAGE AND TRANSFER PACKAGE, ', & + character(len=*), parameter :: fmtist = & + "(1x,/1x,'IST -- IMMOBILE DOMAIN STORAGE AND TRANSFER PACKAGE, ', & &'VERSION 1, 12/24/2018 INPUT READ FROM UNIT ', i0, //)" ! ! --print a message identifying the immobile domain package. - write(this%iout, fmtist) this%inunit + write (this%iout, fmtist) this%inunit ! ! -- Read immobile domain options call this%read_options() @@ -173,11 +173,11 @@ subroutine ist_ar(this) ! -- Allocate arrays call this%ist_allocate_arrays() ! - ! -- Now that arrays are allocated, check in the cimnew array to + ! -- Now that arrays are allocated, check in the cimnew array to ! the output control manager for subsequent printing/saving - call this%ocd%init_dbl('CIM', this%cimnew, this%dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & - this%iout, DHNOFLO) + call this%ocd%init_dbl('CIM', this%cimnew, this%dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + this%iout, DHNOFLO) ! ! -- read the data block call this%read_data() @@ -195,16 +195,16 @@ subroutine ist_ar(this) call this%budget%budget_df(NBDITEMS, 'MASS', 'M', bdzone=this%packName) call this%budget%set_ibudcsv(this%ibudcsv) ! - ! -- Perform a check to ensure that sorption and decay are set + ! -- Perform a check to ensure that sorption and decay are set ! consistently between the MST and IST packages. if (this%idcy /= this%mst%idcy) then call store_error('DECAY MUST BE ACTIVATED CONSISTENTLY BETWEEN THE & &MST AND IST PACKAGES. TURN DECAY ON OR OFF FOR BOTH PACKAGES.') - endif + end if if (this%isrb /= this%mst%isrb) then call store_error('SORPTION MUST BE ACTIVATED CONSISTENTLY BETWEEN THE & &MST AND IST PACKAGES. TURN SORPTION ON OR OFF FOR BOTH PACKAGES.') - endif + end if if (count_errors() > 0) then call this%parser%StoreErrorUnit() end if @@ -212,7 +212,7 @@ subroutine ist_ar(this) ! -- Return return end subroutine ist_ar - + !> @ brief Read and prepare method for package !! !! Method to read and prepare package data @@ -220,7 +220,7 @@ end subroutine ist_ar !< subroutine ist_rp(this) ! -- dummy - class(GwtIstType), intent(inout) :: this !< GwtIstType object + class(GwtIstType), intent(inout) :: this !< GwtIstType object ! -- local ! -- format ! @@ -238,7 +238,7 @@ subroutine ist_ad(this) ! -- modules use SimVariablesModule, only: iFailedStepRetry ! -- dummy variables - class(GwtIstType) :: this !< GwtIstType object + class(GwtIstType) :: this !< GwtIstType object ! -- local variables integer(I4B) :: n ! @@ -272,11 +272,11 @@ subroutine ist_fc(this, rhs, ia, idxglo, amatsln) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtIstType) :: this !< GwtIstType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + class(GwtIstType) :: this !< GwtIstType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix ! -- local integer(I4B) :: n, idiag real(DP) :: tled @@ -307,7 +307,7 @@ subroutine ist_fc(this, rhs, ia, idxglo, amatsln) do n = 1, this%dis%nodes ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- calculate new and old water volumes vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) @@ -316,7 +316,7 @@ subroutine ist_fc(this, rhs, ia, idxglo, amatsln) thetaim = this%thetaim(n) idiag = ia(n) ! - ! -- set exchange coefficient + ! -- set exchange coefficient zetaim = this%zetaim(n) ! ! -- Set thetamfrac and thetaimfrac @@ -334,8 +334,8 @@ subroutine ist_fc(this, rhs, ia, idxglo, amatsln) ! -- setup decay variables if (this%idcy == 1) lambda1im = this%decay(n) if (this%idcy == 2) then - gamma1im = get_zero_order_decay(this%decay(n), this%decaylast(n), & - this%kiter, this%cimold(n), & + gamma1im = get_zero_order_decay(this%decay(n), this%decaylast(n), & + this%kiter, this%cimold(n), & this%cimnew(n), delt) this%decaylast(n) = gamma1im end if @@ -348,17 +348,17 @@ subroutine ist_fc(this, rhs, ia, idxglo, amatsln) if (this%idcy == 2) then cimsrbold = this%cimold(n) * kd cimsrbnew = this%cimnew(n) * kd - gamma2im = get_zero_order_decay(this%decay_sorbed(n), & - this%decayslast(n), & - this%kiter, cimsrbold, & + gamma2im = get_zero_order_decay(this%decay_sorbed(n), & + this%decayslast(n), & + this%kiter, cimsrbold, & cimsrbnew, delt) this%decayslast(n) = gamma2im end if end if ! ! -- calculate the terms and then get the hcof and rhs contributions - call get_ddterm(thetaim, vcell, delt, swtpdt, & - thetaimfrac, rhob, kd, lambda1im, lambda2im, & + call get_ddterm(thetaim, vcell, delt, swtpdt, & + thetaimfrac, rhob, kd, lambda1im, lambda2im, & gamma1im, gamma2im, zetaim, ddterm, f) cimold = this%cimold(n) call get_hcofrhs(ddterm, f, cimold, hhcof, rrhs) @@ -367,15 +367,15 @@ subroutine ist_fc(this, rhs, ia, idxglo, amatsln) amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof rhs(n) = rhs(n) + rrhs ! - enddo + end do ! ! -- Return return end subroutine ist_fc - + !> @ brief Calculate package flows. !! - !! Calculate the flow between connected package control volumes. + !! Calculate the flow between connected package control volumes. !! !< subroutine ist_cq(this, x, flowja, iadv) @@ -383,10 +383,10 @@ subroutine ist_cq(this, x, flowja, iadv) use TdisModule, only: delt use ConstantsModule, only: DZERO ! -- dummy - class(GwtIstType), intent(inout) :: this !< GwtIstType object - real(DP), dimension(:), intent(in) :: x !< current dependent-variable value - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes - integer(I4B), optional, intent(in) :: iadv !< flag that indicates if this is an advance package + class(GwtIstType), intent(inout) :: this !< GwtIstType object + real(DP), dimension(:), intent(in) :: x !< current dependent-variable value + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + integer(I4B), optional, intent(in) :: iadv !< flag that indicates if this is an advance package ! -- local integer(I4B) :: idiag integer(I4B) :: n @@ -413,7 +413,7 @@ subroutine ist_cq(this, x, flowja, iadv) ! -- formats ! ! -- initialize - this%budterm(:, :) = DZERO + this%budterm(:, :) = DZERO ! ! -- Calculate immobile domain transfer rate do n = 1, this%dis%nodes @@ -421,7 +421,7 @@ subroutine ist_cq(this, x, flowja, iadv) ! -- skip if transport inactive rate = DZERO cimnew = DZERO - if(this%ibound(n) > 0) then + if (this%ibound(n) > 0) then ! ! -- calculate new and old water volumes vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) @@ -429,7 +429,7 @@ subroutine ist_cq(this, x, flowja, iadv) swt = this%fmi%gwfsatold(n, delt) thetaim = this%thetaim(n) ! - ! -- set exchange coefficient + ! -- set exchange coefficient zetaim = this%zetaim(n) ! ! -- Set thetamfrac and thetaimfrac @@ -458,16 +458,16 @@ subroutine ist_cq(this, x, flowja, iadv) if (this%idcy == 2) then cimsrbold = this%cimold(n) * kd cimsrbnew = this%cimnew(n) * kd - gamma2im = get_zero_order_decay(this%decay_sorbed(n), & - this%decayslast(n), & - 0, cimsrbold, & + gamma2im = get_zero_order_decay(this%decay_sorbed(n), & + this%decayslast(n), & + 0, cimsrbold, & cimsrbnew, delt) end if end if ! ! -- calculate the terms and then get the hcof and rhs contributions - call get_ddterm(thetaim, vcell, delt, swtpdt, & - thetaimfrac, rhob, kd, lambda1im, lambda2im, & + call get_ddterm(thetaim, vcell, delt, swtpdt, & + thetaimfrac, rhob, kd, lambda1im, lambda2im, & gamma1im, gamma2im, zetaim, ddterm, f) cimold = this%cimold(n) call get_hcofrhs(ddterm, f, cimold, hhcof, rrhs) @@ -479,7 +479,7 @@ subroutine ist_cq(this, x, flowja, iadv) cimnew = get_ddconc(ddterm, f, cimold, x(n)) ! ! -- accumulate the budget terms - call accumulate_budterm(this%budterm, ddterm, cimnew, cimold, x(n), & + call accumulate_budterm(this%budterm, ddterm, cimnew, cimold, x(n), & this%idcy) end if ! @@ -491,14 +491,14 @@ subroutine ist_cq(this, x, flowja, iadv) ! -- store immobile domain concentration this%cimnew(n) = cimnew ! - enddo + end do return end subroutine ist_cq !> @ brief Add package flows to model budget. !! - !! Add the flow between IST package and the model (ratin and ratout) to the - !! model budget. + !! Add the flow between IST package and the model (ratin and ratout) to the + !! model budget. !! !< subroutine ist_bd(this, model_budget) @@ -506,34 +506,34 @@ subroutine ist_bd(this, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator ! -- dummy - class(GwtIstType) :: this !< GwtIstType object - type(BudgetType), intent(inout) :: model_budget !< model budget object + class(GwtIstType) :: this !< GwtIstType object + type(BudgetType), intent(inout) :: model_budget !< model budget object ! -- local real(DP) :: ratin real(DP) :: ratout integer(I4B) :: isuppress_output isuppress_output = 0 call rate_accumulator(this%strg(:), ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, this%text, & + call model_budget%addentry(ratin, ratout, delt, this%text, & isuppress_output, this%packName) return end subroutine ist_bd !> @ brief Output model flow terms. !! - !! Output flow terms between the IST package and model to a binary file and/or - !! print flows to the model listing file. + !! Output flow terms between the IST package and model to a binary file and/or + !! print flows to the model listing file. !! !< subroutine ist_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) ! -- modules use ConstantsModule, only: DZERO ! -- dummy - class(GwtIstType) :: this !< GwtIstType object - integer(I4B), intent(in) :: icbcfl !< flag for cell-by-cell output - integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved - integer(I4B), intent(in) :: icbcun !< unit number for cell-by-cell output - integer(I4B), dimension(:), optional, intent(in) :: imap !< mapping vector + class(GwtIstType) :: this !< GwtIstType object + integer(I4B), intent(in) :: icbcfl !< flag for cell-by-cell output + integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved + integer(I4B), intent(in) :: icbcun !< unit number for cell-by-cell output + integer(I4B), dimension(:), optional, intent(in) :: imap !< mapping vector ! -- loca integer(I4B) :: n integer(I4B) :: ibinun @@ -542,32 +542,33 @@ subroutine ist_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) real(DP) :: rate ! ! -- Set unit number for binary output - if(this%ipakcb < 0) then + if (this%ipakcb < 0) then ibinun = icbcun - elseif(this%ipakcb == 0) then + elseif (this%ipakcb == 0) then ibinun = 0 else ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 + end if + if (icbcfl == 0) ibinun = 0 ! ! -- Record the storage rate if requested ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun /= 0) then + if (ibinun /= 0) then nbound = this%dis%nodes naux = 0 - call this%dis%record_srcdst_list_header(this%text, this%name_model, & - this%name_model, this%name_model, this%packName, naux, & - this%auxname, ibinun, nbound, this%iout) - endif + call this%dis%record_srcdst_list_header(this%text, this%name_model, & + this%name_model, this%name_model, & + this%packName, naux, this%auxname, & + ibinun, nbound, this%iout) + end if ! ! -- Calculate immobile domain rhs and hcof do n = 1, this%dis%nodes ! ! -- skip if transport inactive rate = DZERO - if(this%ibound(n) > 0) then + if (this%ibound(n) > 0) then ! ! -- set rate from this%strg rate = this%strg(n) @@ -575,28 +576,28 @@ subroutine ist_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) ! ! -- If saving cell-by-cell flows in list, write flow if (ibinun /= 0) then - call this%dis%record_mf6_list_entry(ibinun, n, n, rate, & - naux, this%auxvar(:,n), & - olconv=.TRUE., & + call this%dis%record_mf6_list_entry(ibinun, n, n, rate, & + naux, this%auxvar(:, n), & + olconv=.TRUE., & olconv2=.TRUE.) end if ! - enddo + end do ! ! -- Return return end subroutine ist_ot_model_flows - + !> @ brief Output immobile domain concentration. !! !< subroutine ist_ot_dv(this, idvsave, idvprint) ! -- modules use TdisModule, only: kstp, endofperiod - ! -- dummy variables - class(GwtIstType) :: this !< BndType object - integer(I4B), intent(in) :: idvsave !< flag and unit number for dependent-variable output - integer(I4B), intent(in) :: idvprint !< flag indicating if dependent-variable should be written to the model listing file + ! -- dummy variables + class(GwtIstType) :: this !< BndType object + integer(I4B), intent(in) :: idvsave !< flag and unit number for dependent-variable output + integer(I4B), intent(in) :: idvprint !< flag indicating if dependent-variable should be written to the model listing file ! -- local integer(I4B) :: ipflg integer(I4B) :: ibinun @@ -606,22 +607,22 @@ subroutine ist_ot_dv(this, idvsave, idvprint) ! for it. ipflg = 0 ibinun = 1 - if(idvsave == 0) ibinun = 0 + if (idvsave == 0) ibinun = 0 if (ibinun /= 0) then - call this%ocd%ocd_ot(ipflg, kstp, endofperiod, this%iout, & + call this%ocd%ocd_ot(ipflg, kstp, endofperiod, this%iout, & iprint_opt=0, isav_opt=ibinun) - endif + end if ! ! -- Print immobile domain concentrations to listing file if (idvprint /= 0) then - call this%ocd%ocd_ot(ipflg, kstp, endofperiod, this%iout, & + call this%ocd%ocd_ot(ipflg, kstp, endofperiod, this%iout, & iprint_opt=idvprint, isav_opt=0) - endif + end if end subroutine ist_ot_dv - + !> @ brief Output IST package budget summary. !! - !! Output advanced boundary package budget summary. This method only needs + !! Output advanced boundary package budget summary. This method only needs !! to be overridden for advanced packages that save budget summaries !! to the model listing file. !! @@ -630,11 +631,11 @@ subroutine ist_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- modules use TdisModule, only: delt, totim ! -- dummy variables - class(GwtIstType) :: this !< GwtIstType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + class(GwtIstType) :: this !< GwtIstType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written ! -- local integer(I4B) :: isuppress_output = 0 ! @@ -651,20 +652,20 @@ subroutine ist_ot_bdsummary(this, kstp, kper, iout, ibudfl) call this%budget%writecsv(totim) return end subroutine ist_ot_bdsummary - + !> @ brief Deallocate package memory !! - !! Deallocate package scalars and arrays. + !! Deallocate package scalars and arrays. !! !< subroutine ist_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtIstType) :: this !< GwtIstType object + class(GwtIstType) :: this !< GwtIstType object ! ! -- Deallocate arrays if package was active - if(this%inunit > 0) then + if (this%inunit > 0) then call mem_deallocate(this%icimout) call mem_deallocate(this%ibudgetout) call mem_deallocate(this%ibudcsv) @@ -685,15 +686,15 @@ subroutine ist_da(this) call mem_deallocate(this%strg) this%fmi => null() this%mst => null() - endif + end if ! ! -- Scalars ! ! -- Objects call this%budget%budget_da() - deallocate(this%budget) + deallocate (this%budget) call this%ocd%ocd_da() - deallocate(this%ocd) + deallocate (this%ocd) ! ! -- deallocate parent call this%BndType%bnd_da() @@ -704,7 +705,7 @@ end subroutine ist_da !> @ brief Allocate package scalars !! - !! Allocate and initialize package scalars. + !! Allocate and initialize package scalars. !! !< subroutine allocate_scalars(this) @@ -712,7 +713,7 @@ subroutine allocate_scalars(this) use MemoryManagerModule, only: mem_allocate, mem_setptr use OutputControlDataModule, only: ocd_cr ! -- dummy - class(GwtIstType) :: this !< GwtIstType object + class(GwtIstType) :: this !< GwtIstType object ! -- local ! ! -- call standard BndType allocate scalars @@ -744,14 +745,14 @@ end subroutine allocate_scalars !> @ brief Allocate package arrays !! - !! Allocate and initialize package arrays. + !! Allocate and initialize package arrays. !! !< subroutine ist_allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtIstType), intent(inout) :: this !< GwtIstType object + class(GwtIstType), intent(inout) :: this !< GwtIstType object ! -- local integer(I4B) :: n ! @@ -768,25 +769,25 @@ subroutine ist_allocate_arrays(this) call mem_allocate(this%thetaim, this%dis%nodes, 'THETAIM', this%memoryPath) if (this%isrb == 0) then call mem_allocate(this%bulk_density, 1, 'BULK_DENSITY', this%memoryPath) - call mem_allocate(this%distcoef, 1, 'DISTCOEF', this%memoryPath) + call mem_allocate(this%distcoef, 1, 'DISTCOEF', this%memoryPath) else - call mem_allocate(this%bulk_density, this%dis%nodes, 'BULK_DENSITY', & + call mem_allocate(this%bulk_density, this%dis%nodes, 'BULK_DENSITY', & this%memoryPath) - call mem_allocate(this%distcoef, this%dis%nodes, 'DISTCOEF', & + call mem_allocate(this%distcoef, this%dis%nodes, 'DISTCOEF', & this%memoryPath) - endif + end if if (this%idcy == 0) then call mem_allocate(this%decay, 1, 'DECAY', this%memoryPath) call mem_allocate(this%decaylast, 1, 'DECAYLAST', this%memoryPath) else call mem_allocate(this%decay, this%dis%nodes, 'DECAY', this%memoryPath) - call mem_allocate(this%decaylast, this%dis%nodes, 'DECAYLAST', & + call mem_allocate(this%decaylast, this%dis%nodes, 'DECAYLAST', & this%memoryPath) - endif + end if if (this%isrb == 0 .and. this%idcy == 0) then call mem_allocate(this%decayslast, 1, 'DECAYSLAST', this%memoryPath) else - call mem_allocate(this%decayslast, this%dis%nodes, 'DECAYSLAST', & + call mem_allocate(this%decayslast, this%dis%nodes, 'DECAYSLAST', & this%memoryPath) end if call mem_allocate(this%decay_sorbed, 1, 'DECAY_SORBED', this%memoryPath) @@ -799,14 +800,14 @@ subroutine ist_allocate_arrays(this) this%cimold(n) = DZERO this%zetaim(n) = DZERO this%thetaim(n) = DZERO - enddo + end do do n = 1, size(this%decay) this%decay(n) = DZERO this%decaylast(n) = DZERO - enddo + end do do n = 1, size(this%decayslast) this%decayslast(n) = DZERO - enddo + end do ! ! -- Set pointers this%ocd%dis => this%dis @@ -822,12 +823,12 @@ end subroutine ist_allocate_arrays !< subroutine read_options(this) ! -- modules - use ConstantsModule, only: LINELENGTH, MNORMAL - use SimModule, only: store_error - use OpenSpecModule, only: access, form + use ConstantsModule, only: LINELENGTH, MNORMAL + use SimModule, only: store_error + use OpenSpecModule, only: access, form use InputOutputModule, only: getunit, openfile ! -- dummy - class(GwtIstType), intent(inout) :: this !< GwtIstType object + class(GwtIstType), intent(inout) :: this !< GwtIstType object ! -- local character(len=LINELENGTH) :: errmsg, keyword character(len=LINELENGTH) :: fname @@ -836,17 +837,18 @@ subroutine read_options(this) logical :: isfound, endOfBlock logical :: found ! -- formats - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisrb = & - "(4x,'LINEAR SORPTION IS SELECTED. ')" - character(len=*), parameter :: fmtidcy1 = & - "(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" - character(len=*), parameter :: fmtidcy2 = & - "(4x,'ZERO-ORDER DECAY IS ACTIVE. ')" - character(len=*),parameter :: fmtistbin = & - "(4x, 'IST ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I0)" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtisrb = & + &"(4x,'LINEAR SORPTION IS SELECTED. ')" + character(len=*), parameter :: fmtidcy1 = & + &"(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" + character(len=*), parameter :: fmtidcy2 = & + &"(4x,'ZERO-ORDER DECAY IS ACTIVE. ')" + character(len=*), parameter :: fmtistbin = & + "(4x, 'IST ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, & + &/4x, 'OPENED ON UNIT: ', I0)" ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & @@ -854,60 +856,61 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)') 'PROCESSING IMMOBILE STORAGE AND TRANSFER & + write (this%iout, '(1x,a)') 'PROCESSING IMMOBILE STORAGE AND TRANSFER & &OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtisvflow) - case('CIM') - call this%parser%GetRemainingLine(keyword2) - call this%ocd%set_option(keyword2, this%inunit, this%iout) - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE', mode_opt=MNORMAL) - write(this%iout,fmtistbin) 'BUDGET', fname, this%ibudgetout - found = .true. - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtistbin) 'BUDGET CSV', fname, this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case ('SORBTION', 'SORPTION') - this%isrb = 1 - write(this%iout, fmtisrb) - case ('FIRST_ORDER_DECAY') - this%idcy = 1 - write(this%iout, fmtidcy1) - case ('ZERO_ORDER_DECAY') - this%idcy = 2 - write(this%iout, fmtidcy2) - case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN IST OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtisvflow) + case ('CIM') + call this%parser%GetRemainingLine(keyword2) + call this%ocd%set_option(keyword2, this%inunit, this%iout) + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE', mode_opt=MNORMAL) + write (this%iout, fmtistbin) 'BUDGET', fname, this%ibudgetout + found = .true. + else + call store_error('OPTIONAL BUDGET KEYWORD MUST & + &BE FOLLOWED BY FILEOUT') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtistbin) 'BUDGET CSV', fname, this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case ('SORBTION', 'SORPTION') + this%isrb = 1 + write (this%iout, fmtisrb) + case ('FIRST_ORDER_DECAY') + this%idcy = 1 + write (this%iout, fmtidcy1) + case ('ZERO_ORDER_DECAY') + this%idcy = 2 + write (this%iout, fmtidcy2) + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN IST OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)') 'END OF IMMOBILE STORAGE AND TRANSFER & + write (this%iout, '(1x,a)') 'END OF IMMOBILE STORAGE AND TRANSFER & &OPTIONS' end if ! @@ -922,7 +925,7 @@ end subroutine read_options !< subroutine ist_read_dimensions(this) ! -- dummy - class(GwtIstType),intent(inout) :: this !< GwtIstType object + class(GwtIstType), intent(inout) :: this !< GwtIstType object ! -- local ! -- format ! @@ -937,11 +940,11 @@ end subroutine ist_read_dimensions !< subroutine read_data(this) ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors use MemoryManagerModule, only: mem_reallocate, mem_reassignptr ! -- dummy - class(GwtIstType) :: this !< GwtIstType object + class(GwtIstType) :: this !< GwtIstType object ! -- local character(len=LINELENGTH) :: errmsg, keyword character(len=:), allocatable :: line @@ -951,13 +954,13 @@ subroutine read_data(this) character(len=24), dimension(7) :: aname ! -- formats ! -- data - data aname(1) /' BULK DENSITY'/ - data aname(2) /'DISTRIBUTION COEFFICIENT'/ - data aname(3) /' DECAY RATE'/ - data aname(4) /' DECAY SORBED RATE'/ - data aname(5) /' INITIAL IMMOBILE CONC'/ - data aname(6) /' FIRST ORDER TRANS RATE'/ - data aname(7) /'IMMOBILE DOMAIN POROSITY'/ + data aname(1)/' BULK DENSITY'/ + data aname(2)/'DISTRIBUTION COEFFICIENT'/ + data aname(3)/' DECAY RATE'/ + data aname(4)/' DECAY SORBED RATE'/ + data aname(5)/' INITIAL IMMOBILE CONC'/ + data aname(6)/' FIRST ORDER TRANS RATE'/ + data aname(7)/'IMMOBILE DOMAIN POROSITY'/ ! ! -- initialize isfound = .false. @@ -965,8 +968,8 @@ subroutine read_data(this) ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -974,61 +977,61 @@ subroutine read_data(this) call this%parser%GetRemainingLine(line) lloc = 1 select case (keyword) - case ('BULK_DENSITY') - if (this%isrb == 0) & - call mem_reallocate(this%bulk_density, this%dis%nodes, & - 'BULK_DENSITY', trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, & - this%bulk_density, aname(1)) - lname(1) = .true. - case ('DISTCOEF') - if (this%isrb == 0) & - call mem_reallocate(this%distcoef, this%dis%nodes, 'DISTCOEF', & + case ('BULK_DENSITY') + if (this%isrb == 0) & + call mem_reallocate(this%bulk_density, this%dis%nodes, & + 'BULK_DENSITY', trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, & + this%bulk_density, aname(1)) + lname(1) = .true. + case ('DISTCOEF') + if (this%isrb == 0) & + call mem_reallocate(this%distcoef, this%dis%nodes, 'DISTCOEF', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%distcoef, & + aname(2)) + lname(2) = .true. + case ('DECAY') + if (this%idcy == 0) & + call mem_reallocate(this%decay, this%dis%nodes, 'DECAY', & trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%distcoef, & - aname(2)) - lname(2) = .true. - case ('DECAY') - if (this%idcy == 0) & - call mem_reallocate(this%decay, this%dis%nodes, 'DECAY', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%decay, & - aname(3)) - lname(3) = .true. - case ('DECAY_SORBED') - call mem_reallocate(this%decay_sorbed, this%dis%nodes, & - 'DECAY_SORBED', trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, & - this%decay_sorbed, aname(4)) - lname(4) = .true. - case ('CIM') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%cim, & - aname(5)) - lname(5) = .true. - case ('ZETAIM') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%zetaim, & - aname(6)) - lname(6) = .true. - case ('THETAIM') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%thetaim, & - aname(7)) - lname(7) = .true. - case default - write(errmsg,'(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%decay, & + aname(3)) + lname(3) = .true. + case ('DECAY_SORBED') + call mem_reallocate(this%decay_sorbed, this%dis%nodes, & + 'DECAY_SORBED', trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, & + this%decay_sorbed, aname(4)) + lname(4) = .true. + case ('CIM') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%cim, & + aname(5)) + lname(5) = .true. + case ('ZETAIM') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%zetaim, & + aname(6)) + lname(6) = .true. + case ('THETAIM') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%thetaim, & + aname(7)) + lname(7) = .true. + case default + write (errmsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else - write(errmsg,'(1x,a)')'Required GRIDDATA block not found.' + write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if @@ -1036,86 +1039,86 @@ subroutine read_data(this) ! -- Check for required sorption variables if (this%isrb > 0) then if (.not. lname(1)) then - write(errmsg, '(1x,a)') 'ERROR. SORPTION IS ACTIVE BUT BULK_DENSITY & + write (errmsg, '(1x,a)') 'ERROR. SORPTION IS ACTIVE BUT BULK_DENSITY & &NOT SPECIFIED. BULK_DENSITY MUST BE SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if if (.not. lname(2)) then - write(errmsg, '(1x,a)') 'ERROR. SORPTION IS ACTIVE BUT DISTRIBUTION & + write (errmsg, '(1x,a)') 'ERROR. SORPTION IS ACTIVE BUT DISTRIBUTION & &COEFFICIENT NOT SPECIFIED. DISTCOEF MUST BE SPECIFIED IN & &GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if else if (lname(1)) then - write(this%iout, '(1x,a)') 'WARNING. SORPTION IS NOT ACTIVE BUT & + write (this%iout, '(1x,a)') 'WARNING. SORPTION IS NOT ACTIVE BUT & &BULK_DENSITY WAS SPECIFIED. BULK_DENSITY WILL HAVE NO AFFECT ON & &SIMULATION RESULTS.' - endif + end if if (lname(2)) then - write(this%iout, '(1x,a)') 'WARNING. SORPTION IS NOT ACTIVE BUT & + write (this%iout, '(1x,a)') 'WARNING. SORPTION IS NOT ACTIVE BUT & &DISTRIBUTION COEFFICIENT WAS SPECIFIED. DISTCOEF WILL HAVE & &NO AFFECT ON SIMULATION RESULTS.' - endif - endif + end if + end if ! ! -- Check for required decay/production rate coefficients if (this%idcy > 0) then if (.not. lname(3)) then - write(errmsg, '(1x,a)') 'ERROR. FIRST OR ZERO ORDER DECAY IS & + write (errmsg, '(1x,a)') 'ERROR. FIRST OR ZERO ORDER DECAY IS & &ACTIVE BUT THE FIRST RATE COEFFICIENT IS NOT SPECIFIED. & &DECAY MUST BE SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if if (.not. lname(4)) then ! ! -- If DECAY_SORBED not specified and sorption is active, then set ! decay_sorbed equal to decay if (this%isrb > 0) then - write(errmsg, '(a)') 'DECAY_SORBED not provided in GRIDDATA & + write (errmsg, '(a)') 'DECAY_SORBED not provided in GRIDDATA & &block but decay and sorption are active. Specify DECAY_SORBED & &in GRIDDATA block.' call store_error(errmsg) - endif - endif + end if + end if else if (lname(3)) then - write(this%iout, '(1x,a)') 'WARNING. FIRST OR ZERO ORER DECAY & + write (this%iout, '(1x,a)') 'WARNING. FIRST OR ZERO ORER DECAY & &IS NOT ACTIVE BUT DECAY WAS SPECIFIED. DECAY WILL & &HAVE NO AFFECT ON SIMULATION RESULTS.' - endif + end if if (lname(4)) then - write(this%iout, '(1x,a)') 'WARNING. FIRST OR ZERO ORER DECAY & + write (this%iout, '(1x,a)') 'WARNING. FIRST OR ZERO ORER DECAY & &IS NOT ACTIVE BUT DECAY_SORBED MUST WAS SPECIFIED. & &DECAY_SORBED MUST WILL HAVE NO AFFECT ON SIMULATION & &RESULTS.' - endif - endif + end if + end if ! ! -- Check for required dual domain arrays or warn if they are specified ! but won't be used. if (.not. lname(5)) then - write(this%iout, '(1x,a)') 'WARNING. DUAL DOMAIN IS ACTIVE BUT & + write (this%iout, '(1x,a)') 'WARNING. DUAL DOMAIN IS ACTIVE BUT & &INITIAL IMMOBILE DOMAIN CONCENTRATION WAS NOT SPECIFIED. & &SETTING CIM TO ZERO.' - endif + end if if (.not. lname(6)) then - write(errmsg, '(1x,a)') 'DUAL DOMAIN IS ACTIVE BUT DUAL & + write (errmsg, '(1x,a)') 'DUAL DOMAIN IS ACTIVE BUT DUAL & &DOMAIN MASS TRANSFER RATE (ZETAIM) WAS NOT SPECIFIED. ZETAIM & &MUST BE SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if if (.not. lname(7)) then - write(errmsg, '(1x,a)') 'DUAL DOMAIN IS ACTIVE BUT & + write (errmsg, '(1x,a)') 'DUAL DOMAIN IS ACTIVE BUT & &IMMOBILE DOMAIN POROSITY (THETAIM) WAS NOT SPECIFIED. THETAIM & &MUST BE SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if ! ! -- terminate if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return @@ -1129,31 +1132,31 @@ end subroutine read_data !! for the immobile domain. !! !< - subroutine get_ddterm(thetaim, vcell, delt, swtpdt, & - thetaimfrac, rhob, kd, lambda1im, lambda2im, & + subroutine get_ddterm(thetaim, vcell, delt, swtpdt, & + thetaimfrac, rhob, kd, lambda1im, lambda2im, & gamma1im, gamma2im, zetaim, ddterm, f) ! -- dummy - real(DP), intent(in) :: thetaim !< immobile domain porosity - real(DP), intent(in) :: vcell !< volume of cell - real(DP), intent(in) :: delt !< length of time step - real(DP), intent(in) :: swtpdt !< cell saturation at end of time step - real(DP), intent(in) :: thetaimfrac !< fraction of total porosity this is immobile - real(DP), intent(in) :: rhob !< bulk density - real(DP), intent(in) :: kd !< distribution coefficient for linear isotherm - real(DP), intent(in) :: lambda1im !< first-order decay rate in aqueous phase - real(DP), intent(in) :: lambda2im !< first-order decay rate in sorbed phase - real(DP), intent(in) :: gamma1im !< zero-order decay rate in aqueous phase - real(DP), intent(in) :: gamma2im !< zero-order decay rate in sorbed phase - real(DP), intent(in) :: zetaim !< transfer coefficient between mobile and immobile domains - real(DP), dimension(:), intent(inout) :: ddterm !< nine terms comprising the balance equation of the immobile domain - real(DP), intent(inout) :: f !< the f term used to calculate the immobile domain concentration + real(DP), intent(in) :: thetaim !< immobile domain porosity + real(DP), intent(in) :: vcell !< volume of cell + real(DP), intent(in) :: delt !< length of time step + real(DP), intent(in) :: swtpdt !< cell saturation at end of time step + real(DP), intent(in) :: thetaimfrac !< fraction of total porosity this is immobile + real(DP), intent(in) :: rhob !< bulk density + real(DP), intent(in) :: kd !< distribution coefficient for linear isotherm + real(DP), intent(in) :: lambda1im !< first-order decay rate in aqueous phase + real(DP), intent(in) :: lambda2im !< first-order decay rate in sorbed phase + real(DP), intent(in) :: gamma1im !< zero-order decay rate in aqueous phase + real(DP), intent(in) :: gamma2im !< zero-order decay rate in sorbed phase + real(DP), intent(in) :: zetaim !< transfer coefficient between mobile and immobile domains + real(DP), dimension(:), intent(inout) :: ddterm !< nine terms comprising the balance equation of the immobile domain + real(DP), intent(inout) :: f !< the f term used to calculate the immobile domain concentration ! -- local real(DP) :: tled ! ! -- initialize tled = DONE / delt ! - ! -- Calculate terms. These terms correspond to the concentration + ! -- Calculate terms. These terms correspond to the concentration ! coefficients in equation 7-4 of the GWT model report ddterm(1) = thetaim * vcell * tled ddterm(2) = thetaim * vcell * tled @@ -1180,14 +1183,14 @@ end subroutine get_ddterm !< subroutine get_hcofrhs(ddterm, f, cimold, hcof, rhs) ! -- dummy - real(DP), dimension(:), intent(in) :: ddterm !< terms comprising the balance equation of the immobile domain - real(DP), intent(in) :: f !< the f term used to calculate the immobile domain concentration - real(DP), intent(in) :: cimold !< immobile domain concentration at end of last time step - real(DP), intent(inout) :: hcof !< calculated contribution for the a-matrix diagonal position - real(DP), intent(inout) :: rhs !< calculated contribution for the solution right-hand side + real(DP), dimension(:), intent(in) :: ddterm !< terms comprising the balance equation of the immobile domain + real(DP), intent(in) :: f !< the f term used to calculate the immobile domain concentration + real(DP), intent(in) :: cimold !< immobile domain concentration at end of last time step + real(DP), intent(inout) :: hcof !< calculated contribution for the a-matrix diagonal position + real(DP), intent(inout) :: rhs !< calculated contribution for the solution right-hand side ! ! -- calculate hcof - hcof = ddterm(9) ** 2 / f - ddterm(9) + hcof = ddterm(9)**2 / f - ddterm(9) ! ! -- calculate rhs, and switch the sign because this term needs to ! be moved to the left hand side @@ -1204,25 +1207,25 @@ end subroutine get_hcofrhs !! This function calculates the concentration of the immobile domain. !! !< - function get_ddconc(ddterm, f, cimold, cnew) result (cimnew) + function get_ddconc(ddterm, f, cimold, cnew) result(cimnew) ! -- dummy - real(DP), dimension(:), intent(in) :: ddterm !< terms comprising the balance equation of the immobile domain - real(DP), intent(in) :: f !< the f term used to calculate the immobile domain concentration - real(DP), intent(in) :: cimold !< immobile domain concentration at end of last time step - real(DP), intent(in) :: cnew !< concentration of the mobile domain at the end of the time step + real(DP), dimension(:), intent(in) :: ddterm !< terms comprising the balance equation of the immobile domain + real(DP), intent(in) :: f !< the f term used to calculate the immobile domain concentration + real(DP), intent(in) :: cimold !< immobile domain concentration at end of last time step + real(DP), intent(in) :: cnew !< concentration of the mobile domain at the end of the time step ! -- result - real(DP) :: cimnew !< calculated concentration of the immobile domain + real(DP) :: cimnew !< calculated concentration of the immobile domain ! -- local ! ! -- calculate ddconc - cimnew = (ddterm(2) + ddterm(4)) * cimold + ddterm(9) * cnew - ddterm(7) & + cimnew = (ddterm(2) + ddterm(4)) * cimold + ddterm(9) * cnew - ddterm(7) & - ddterm(8) cimnew = cimnew / f ! ! -- Return return end function get_ddconc - + !> @ brief Calculate the immobile domain budget terms !! !! This subroutine calculates and accumulates the immobile domain @@ -1232,64 +1235,64 @@ end function get_ddconc subroutine accumulate_budterm(budterm, ddterm, cimnew, cimold, cnew, idcy) ! -- modules ! -- dummy - real(DP), dimension(:, :), intent(inout) :: budterm !< - real(DP), dimension(:), intent(in) :: ddterm !< terms comprising the balance equation of the immobile domain - real(DP), intent(in) :: cimnew !< immobile domain concenration at the end of this time step - real(DP), intent(in) :: cimold !< immobile domain concentration at end of last time step - real(DP), intent(in) :: cnew !< mobile domain concentration at the end of this time step - integer(I4B), intent(in) :: idcy !< order of decay rate (0:none, 1:first, 2:zero) + real(DP), dimension(:, :), intent(inout) :: budterm !< + real(DP), dimension(:), intent(in) :: ddterm !< terms comprising the balance equation of the immobile domain + real(DP), intent(in) :: cimnew !< immobile domain concenration at the end of this time step + real(DP), intent(in) :: cimold !< immobile domain concentration at end of last time step + real(DP), intent(in) :: cnew !< mobile domain concentration at the end of this time step + integer(I4B), intent(in) :: idcy !< order of decay rate (0:none, 1:first, 2:zero) ! -- local real(DP) :: rate integer(I4B) :: i ! ! -- calculate STORAGE-AQUEOUS i = 1 - rate = - ddterm(1) * cimnew + ddterm(2) * cimold + rate = -ddterm(1) * cimnew + ddterm(2) * cimold if (rate > DZERO) then budterm(1, i) = budterm(1, i) + rate else budterm(2, i) = budterm(2, i) - rate - endif + end if ! ! -- calculate STORAGE-SORBED i = 2 - rate = - ddterm(3) * cimnew + ddterm(4) * cimold + rate = -ddterm(3) * cimnew + ddterm(4) * cimold if (rate > DZERO) then budterm(1, i) = budterm(1, i) + rate else budterm(2, i) = budterm(2, i) - rate - endif + end if ! ! -- calculate DECAY-AQUEOUS i = 3 rate = DZERO if (idcy == 1) then - rate = - ddterm(5) * cimnew + rate = -ddterm(5) * cimnew else if (idcy == 2) then - rate = - ddterm(7) + rate = -ddterm(7) else rate = DZERO - endif + end if if (rate > DZERO) then budterm(1, i) = budterm(1, i) + rate else budterm(2, i) = budterm(2, i) - rate - endif + end if ! ! -- calculate DECAY-SORBED i = 4 if (idcy == 1) then - rate = - ddterm(6) * cimnew + rate = -ddterm(6) * cimnew else if (idcy == 2) then - rate = - ddterm(8) + rate = -ddterm(8) else rate = DZERO - endif + end if if (rate > DZERO) then budterm(1, i) = budterm(1, i) + rate else budterm(2, i) = budterm(2, i) - rate - endif + end if ! ! -- calculate MOBILE-DOMAIN i = 5 @@ -1298,11 +1301,11 @@ subroutine accumulate_budterm(budterm, ddterm, cimnew, cimold, cnew, idcy) budterm(1, i) = budterm(1, i) + rate else budterm(2, i) = budterm(2, i) - rate - endif + end if ! ! ! -- Return return end subroutine accumulate_budterm -end module GwtIstModule \ No newline at end of file +end module GwtIstModule diff --git a/src/Model/GroundWaterTransport/gwt1lkt1.f90 b/src/Model/GroundWaterTransport/gwt1lkt1.f90 index 3092980ec05..8f28d8ebc5b 100644 --- a/src/Model/GroundWaterTransport/gwt1lkt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1lkt1.f90 @@ -5,7 +5,7 @@ ! ! LAK flows (lakbudptr) index var LKT term Transport Type !--------------------------------------------------------------------------------- - + ! -- terms from LAK that will be handled by parent APT Package ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf @@ -20,7 +20,7 @@ ! EXT-INFLOW idxbudiflw EXT-INFLOW q * ciflw ! WITHDRAWAL idxbudwdrl WITHDRAWAL q * cfeat ! EXT-OUTFLOW idxbudoutf EXT-OUTFLOW q * cfeat - + ! -- terms from a flow file that should be skipped ! CONSTANT none none none ! AUXILIARY none none none @@ -37,34 +37,34 @@ module GwtLktModule use ConstantsModule, only: DZERO, DONE, LINELENGTH use SimModule, only: store_error use BndModule, only: BndType, GetBndFromList - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use LakModule, only: LakType use GwtAptModule, only: GwtAptType - + implicit none - + public lkt_create - + character(len=*), parameter :: ftype = 'LKT' character(len=*), parameter :: flowtype = 'LAK' - character(len=16) :: text = ' LKT' - + character(len=16) :: text = ' LKT' + type, extends(GwtAptType) :: GwtLktType - - integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr - integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr - integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr - integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr - integer(I4B), pointer :: idxbudwdrl => null() ! index of withdrawal terms in flowbudptr - integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr - real(DP), dimension(:), pointer, contiguous :: concrain => null() ! rainfall concentration - real(DP), dimension(:), pointer, contiguous :: concevap => null() ! evaporation concentration - real(DP), dimension(:), pointer, contiguous :: concroff => null() ! runoff concentration - real(DP), dimension(:), pointer, contiguous :: conciflw => null() ! inflow concentration + integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr + integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr + integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr + integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr + integer(I4B), pointer :: idxbudwdrl => null() ! index of withdrawal terms in flowbudptr + integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + + real(DP), dimension(:), pointer, contiguous :: concrain => null() ! rainfall concentration + real(DP), dimension(:), pointer, contiguous :: concevap => null() ! evaporation concentration + real(DP), dimension(:), pointer, contiguous :: concroff => null() ! runoff concentration + real(DP), dimension(:), pointer, contiguous :: conciflw => null() ! inflow concentration contains - + procedure :: bnd_da => lkt_da procedure :: allocate_scalars procedure :: apt_allocate_arrays => lkt_allocate_arrays @@ -83,11 +83,11 @@ module GwtLktModule procedure :: pak_df_obs => lkt_df_obs procedure :: pak_bd_obs => lkt_bd_obs procedure :: pak_set_stressperiod => lkt_set_stressperiod - + end type GwtLktType - contains - +contains + subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi) ! ****************************************************************************** @@ -98,19 +98,19 @@ subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname - type(GwtFmiType), pointer :: fmi + type(TspFmiType), pointer :: fmi ! -- local type(GwtLktType), pointer :: lktobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(lktobj) + allocate (lktobj) packobj => lktobj ! ! -- create name and memory path @@ -129,7 +129,7 @@ subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ibcnum = ibcnum packobj%ncolbnd = 1 packobj%iscloc = 1 - + ! -- Store pointer to flow model interface. When the GwfGwt exchange is ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages @@ -171,7 +171,7 @@ subroutine find_lkt_package(this) ! else if (associated(this%fmi%gwfbndlist)) then - ! -- Look through gwfbndlist for a flow package with the same name as + ! -- Look through gwfbndlist for a flow package with the same name as ! this transport package name do ip = 1, this%fmi%gwfbndlist%Count() packobj => GetBndFromList(this%fmi%gwfbndlist, ip) @@ -182,8 +182,8 @@ subroutine find_lkt_package(this) ! use the select type to point to the budobj in flow package this%flowpackagebnd => packobj select type (packobj) - type is (LakType) - this%flowbudptr => packobj%budobj + type is (LakType) + this%flowbudptr => packobj%budobj end select end if if (found) exit @@ -193,60 +193,60 @@ subroutine find_lkt_package(this) ! ! -- error if flow package not found if (.not. found) then - write(errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& - &// trim(adjustl(this%flowpackagename)) // '.' + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! - ! -- allocate space for idxbudssm, which indicates whether this is a + ! -- allocate space for idxbudssm, which indicates whether this is a ! special budget term or one that is a general source and sink nbudterm = this%flowbudptr%nbudterm call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) ! ! -- Process budget terms and identify special budget terms - write(this%iout, '(/, a, a)') & - 'PROCESSING ' // ftype // ' INFORMATION FOR ', this%packName - write(this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN ' // flowtype // ' PACKAGE' - write(this%iout, '(a, i0)') & - ' NUMBER OF ' // flowtype // ' = ', this%flowbudptr%ncv + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv icount = 1 do ip = 1, this%flowbudptr%nbudterm - select case(trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) - case('FLOW-JA-FACE') + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') this%idxbudfjf = ip this%idxbudssm(ip) = 0 - case('GWF') + case ('GWF') this%idxbudgwf = ip this%idxbudssm(ip) = 0 - case('STORAGE') + case ('STORAGE') this%idxbudsto = ip this%idxbudssm(ip) = 0 - case('RAINFALL') + case ('RAINFALL') this%idxbudrain = ip this%idxbudssm(ip) = 0 - case('EVAPORATION') + case ('EVAPORATION') this%idxbudevap = ip this%idxbudssm(ip) = 0 - case('RUNOFF') + case ('RUNOFF') this%idxbudroff = ip this%idxbudssm(ip) = 0 - case('EXT-INFLOW') + case ('EXT-INFLOW') this%idxbudiflw = ip this%idxbudssm(ip) = 0 - case('WITHDRAWAL') + case ('WITHDRAWAL') this%idxbudwdrl = ip this%idxbudssm(ip) = 0 - case('EXT-OUTFLOW') + case ('EXT-OUTFLOW') this%idxbudoutf = ip this%idxbudssm(ip) = 0 - case('TO-MVR') + case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 - case('FROM-MVR') + case ('FROM-MVR') this%idxbudfmvr = ip this%idxbudssm(ip) = 0 - case('AUXILIARY') + case ('AUXILIARY') this%idxbudaux = ip this%idxbudssm(ip) = 0 case default @@ -256,15 +256,15 @@ subroutine find_lkt_package(this) this%idxbudssm(ip) = icount icount = icount + 1 end select - write(this%iout, '(a, i0, " = ", a,/, a, i0)') & + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist end do - write(this%iout, '(a, //)') 'DONE PROCESSING ' // ftype // ' INFORMATION' + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! ! -- Return return -end subroutine find_lkt_package + end subroutine find_lkt_package subroutine lkt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** @@ -426,7 +426,7 @@ subroutine lkt_solve(this) ! -- Return return end subroutine lkt_solve - + function lkt_get_nbudterms(this) result(nbudterms) ! ****************************************************************************** ! lkt_get_nbudterms -- function to return the number of budget terms just for @@ -449,7 +449,7 @@ function lkt_get_nbudterms(this) result(nbudterms) ! -- Return return end function lkt_get_nbudterms - + subroutine lkt_setup_budobj(this, idx) ! ****************************************************************************** ! lkt_setup_budobj -- Set up the budget object that stores all the lake flows @@ -467,7 +467,7 @@ subroutine lkt_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- text = ' RAINFALL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist @@ -480,7 +480,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EVAPORATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist @@ -493,7 +493,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' RUNOFF' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist @@ -506,7 +506,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EXT-INFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist @@ -519,7 +519,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' WITHDRAWAL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudwdrl)%maxlist @@ -532,7 +532,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EXT-OUTFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist @@ -569,7 +569,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! -- RAIN idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist @@ -579,8 +579,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- EVAPORATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist @@ -590,8 +589,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- RUNOFF idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist @@ -601,8 +599,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- EXT-INFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist @@ -612,8 +609,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- WITHDRAWAL idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudwdrl)%nlist @@ -623,8 +619,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- EXT-OUTFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist @@ -634,7 +629,6 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! ! -- return @@ -665,7 +659,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) call mem_allocate(this%idxbudwdrl, 'IDXBUDWDRL', this%memoryPath) call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) - ! + ! ! -- Initialize this%idxbudrain = 0 this%idxbudevap = 0 @@ -692,7 +686,7 @@ subroutine lkt_allocate_arrays(this) ! -- local integer(I4B) :: n ! ------------------------------------------------------------------------------ - ! + ! ! -- time series call mem_allocate(this%concrain, this%ncv, 'CONCRAIN', this%memoryPath) call mem_allocate(this%concevap, this%ncv, 'CONCEVAP', this%memoryPath) @@ -714,7 +708,7 @@ subroutine lkt_allocate_arrays(this) ! -- Return return end subroutine lkt_allocate_arrays - + subroutine lkt_da(this) ! ****************************************************************************** ! lkt_da @@ -781,7 +775,7 @@ subroutine lkt_rain_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine lkt_rain_term - + subroutine lkt_evap_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -816,13 +810,13 @@ subroutine lkt_evap_term(this, ientry, n1, n2, rrate, & if (present(rrate)) & rrate = omega * qbnd * this%xnewpak(n1) + & (DONE - omega) * qbnd * ctmp - if (present(rhsval)) rhsval = - (DONE - omega) * qbnd * ctmp + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! ! -- return return end subroutine lkt_evap_term - + subroutine lkt_roff_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -854,7 +848,7 @@ subroutine lkt_roff_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine lkt_roff_term - + subroutine lkt_iflw_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -886,7 +880,7 @@ subroutine lkt_iflw_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine lkt_iflw_term - + subroutine lkt_wdrl_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -918,7 +912,7 @@ subroutine lkt_wdrl_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine lkt_wdrl_term - + subroutine lkt_outf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -950,7 +944,7 @@ subroutine lkt_outf_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine lkt_outf_term - + subroutine lkt_df_obs(this) ! ****************************************************************************** ! lkt_df_obs -- obs are supported? @@ -1000,7 +994,7 @@ subroutine lkt_df_obs(this) ! return end subroutine lkt_df_obs - + subroutine lkt_bd_obs(this, obstypeid, jj, v, found) ! ****************************************************************************** ! lkt_bd_obs -- calculate observation value and pass it back to APT @@ -1020,32 +1014,32 @@ subroutine lkt_bd_obs(this, obstypeid, jj, v, found) ! found = .true. select case (obstypeid) - case ('RAINFALL') - if (this%iboundpak(jj) /= 0) then - call this%lkt_rain_term(jj, n1, n2, v) - end if - case ('EVAPORATION') - if (this%iboundpak(jj) /= 0) then - call this%lkt_evap_term(jj, n1, n2, v) - end if - case ('RUNOFF') - if (this%iboundpak(jj) /= 0) then - call this%lkt_roff_term(jj, n1, n2, v) - end if - case ('EXT-INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lkt_iflw_term(jj, n1, n2, v) - end if - case ('WITHDRAWAL') - if (this%iboundpak(jj) /= 0) then - call this%lkt_wdrl_term(jj, n1, n2, v) - end if - case ('EXT-OUTFLOW') - if (this%iboundpak(jj) /= 0) then - call this%lkt_outf_term(jj, n1, n2, v) - end if - case default - found = .false. + case ('RAINFALL') + if (this%iboundpak(jj) /= 0) then + call this%lkt_rain_term(jj, n1, n2, v) + end if + case ('EVAPORATION') + if (this%iboundpak(jj) /= 0) then + call this%lkt_evap_term(jj, n1, n2, v) + end if + case ('RUNOFF') + if (this%iboundpak(jj) /= 0) then + call this%lkt_roff_term(jj, n1, n2, v) + end if + case ('EXT-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lkt_iflw_term(jj, n1, n2, v) + end if + case ('WITHDRAWAL') + if (this%iboundpak(jj) /= 0) then + call this%lkt_wdrl_term(jj, n1, n2, v) + end if + case ('EXT-OUTFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lkt_outf_term(jj, n1, n2, v) + end if + case default + found = .false. end select ! return @@ -1060,7 +1054,7 @@ subroutine lkt_set_stressperiod(this, itemno, keyword, found) ! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtLktType),intent(inout) :: this + class(GwtLktType), intent(inout) :: this integer(I4B), intent(in) :: itemno character(len=*), intent(in) :: keyword logical, intent(inout) :: found @@ -1080,61 +1074,60 @@ subroutine lkt_set_stressperiod(this, itemno, keyword, found) ! found = .true. select case (keyword) - case ('RAINFALL') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concrain(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RAINFALL') - case ('EVAPORATION') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concevap(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'EVAPORATION') - case ('RUNOFF') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concroff(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RUNOFF') - case ('EXT-INFLOW') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%conciflw(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'EXT-INFLOW') - case default - ! - ! -- keyword not recognized so return to caller with found = .false. - found = .false. + case ('RAINFALL') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concrain(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RAINFALL') + case ('EVAPORATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concevap(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EVAPORATION') + case ('RUNOFF') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concroff(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RUNOFF') + case ('EXT-INFLOW') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%conciflw(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EXT-INFLOW') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. end select ! -999 continue +999 continue ! ! -- return return end subroutine lkt_set_stressperiod - end module GwtLktModule diff --git a/src/Model/GroundWaterTransport/gwt1mst1.f90 b/src/Model/GroundWaterTransport/gwt1mst1.f90 index a390ba211ec..65daf3de200 100644 --- a/src/Model/GroundWaterTransport/gwt1mst1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mst1.f90 @@ -1,6 +1,6 @@ !> -- @ brief Mobile Storage and Transfer (MST) Module !! -!! The GwtMstModule is contains the GwtMstType, which is the +!! The GwtMstModule is contains the GwtMstType, which is the !! derived type responsible for adding the effects of !! 1. Changes in dissolved solute mass !! 2. Decay of dissolved solute mass @@ -8,24 +8,24 @@ !! 4. Decay of sorbed solute mass !< module GwtMstModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DONE, DZERO, DTWO, DHALF, LENBUDTXT - use SimVariablesModule, only: errmsg, warnmsg - use SimModule, only: store_error, count_errors, & - store_warning + + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, DTWO, DHALF, LENBUDTXT + use SimVariablesModule, only: errmsg, warnmsg + use SimModule, only: store_error, count_errors, & + store_warning use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType - + use BaseDisModule, only: DisBaseType + use TspFmiModule, only: TspFmiType + implicit none public :: GwtMstType public :: mst_cr ! integer(I4B), parameter :: NBDITEMS = 4 character(len=LENBUDTXT), dimension(NBDITEMS) :: budtxt - data budtxt / ' STORAGE-AQUEOUS', ' DECAY-AQUEOUS', & - ' STORAGE-SORBED', ' DECAY-SORBED' / + data budtxt/' STORAGE-AQUEOUS', ' DECAY-AQUEOUS', & + ' STORAGE-SORBED', ' DECAY-SORBED'/ !> @ brief Mobile storage and transfer !! @@ -36,32 +36,32 @@ module GwtMstModule type, extends(NumericalPackageType) :: GwtMstType ! ! -- storage - real(DP), dimension(:), pointer, contiguous :: porosity => null() !< porosity - real(DP), dimension(:), pointer, contiguous :: prsity2 => null() !< sum of immobile porosity - real(DP), dimension(:), pointer, contiguous :: ratesto => null() !< rate of mobile storage + real(DP), dimension(:), pointer, contiguous :: porosity => null() !< porosity + real(DP), dimension(:), pointer, contiguous :: prsity2 => null() !< sum of immobile porosity + real(DP), dimension(:), pointer, contiguous :: ratesto => null() !< rate of mobile storage ! ! -- decay - integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) - real(DP), dimension(:), pointer, contiguous :: decay => null() !< first or zero order decay rate (aqueous) - real(DP), dimension(:), pointer, contiguous :: decay_sorbed => null() !< first or zero order decay rate (sorbed) - real(DP), dimension(:), pointer, contiguous :: ratedcy => null() !< rate of decay - real(DP), dimension(:), pointer, contiguous :: decaylast => null() !< decay rate used for last iteration (needed for zero order decay) - real(DP), dimension(:), pointer, contiguous :: decayslast => null() !< sorbed decay rate used for last iteration (needed for zero order decay) + integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) + real(DP), dimension(:), pointer, contiguous :: decay => null() !< first or zero order decay rate (aqueous) + real(DP), dimension(:), pointer, contiguous :: decay_sorbed => null() !< first or zero order decay rate (sorbed) + real(DP), dimension(:), pointer, contiguous :: ratedcy => null() !< rate of decay + real(DP), dimension(:), pointer, contiguous :: decaylast => null() !< decay rate used for last iteration (needed for zero order decay) + real(DP), dimension(:), pointer, contiguous :: decayslast => null() !< sorbed decay rate used for last iteration (needed for zero order decay) ! ! -- sorption - integer(I4B), pointer :: isrb => null() !< sorption active flag (0:off, 1:linear, 2:freundlich, 3:langmuir) - real(DP), dimension(:), pointer, contiguous :: bulk_density => null() !< bulk density - real(DP), dimension(:), pointer, contiguous :: distcoef => null() !< kd distribution coefficient - real(DP), dimension(:), pointer, contiguous :: sp2 => null() !< second sorption parameter - real(DP), dimension(:), pointer, contiguous :: ratesrb => null() !< rate of sorption - real(DP), dimension(:), pointer, contiguous :: ratedcys => null() !< rate of sorbed mass decay + integer(I4B), pointer :: isrb => null() !< sorption active flag (0:off, 1:linear, 2:freundlich, 3:langmuir) + real(DP), dimension(:), pointer, contiguous :: bulk_density => null() !< bulk density + real(DP), dimension(:), pointer, contiguous :: distcoef => null() !< kd distribution coefficient + real(DP), dimension(:), pointer, contiguous :: sp2 => null() !< second sorption parameter + real(DP), dimension(:), pointer, contiguous :: ratesrb => null() !< rate of sorption + real(DP), dimension(:), pointer, contiguous :: ratedcys => null() !< rate of sorbed mass decay ! ! -- misc - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object contains - + procedure :: mst_ar procedure :: mst_fc procedure :: mst_fc_sto @@ -83,11 +83,11 @@ module GwtMstModule procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: read_data - + end type GwtMstType - - contains - + +contains + !> @ brief Create a new package object !! !! Create a new MST object @@ -95,14 +95,14 @@ module GwtMstModule !< subroutine mst_cr(mstobj, name_model, inunit, iout, fmi) ! -- dummy - type(GwtMstType), pointer :: mstobj !< unallocated new mst object to create - character(len=*), intent(in) :: name_model !< name of the model - integer(I4B), intent(in) :: inunit !< unit number of WEL package input file - integer(I4B), intent(in) :: iout !< unit number of model listing file - type(GwtFmiType), intent(in), target :: fmi !< fmi package for this GWT model + type(GwtMstType), pointer :: mstobj !< unallocated new mst object to create + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< unit number of WEL package input file + integer(I4B), intent(in) :: iout !< unit number of model listing file + type(TspFmiType), intent(in), target :: fmi !< fmi package for this GWT model ! ! -- Create the object - allocate(mstobj) + allocate (mstobj) ! ! -- create name and memory path call mstobj%set_names(1, name_model, 'MST', 'MST') @@ -130,24 +130,24 @@ end subroutine mst_cr subroutine mst_ar(this, dis, ibound) ! -- modules ! -- dummy - class(GwtMstType), intent(inout) :: this !< GwtMstType object - class(DisBaseType), pointer, intent(in) :: dis !< pointer to dis package - integer(I4B), dimension(:), pointer, contiguous :: ibound !< pointer to GWT ibound array + class(GwtMstType), intent(inout) :: this !< GwtMstType object + class(DisBaseType), pointer, intent(in) :: dis !< pointer to dis package + integer(I4B), dimension(:), pointer, contiguous :: ibound !< pointer to GWT ibound array ! -- local ! -- formats - character(len=*), parameter :: fmtmst = & + character(len=*), parameter :: fmtmst = & "(1x,/1x,'MST -- MOBILE STORAGE AND TRANSFER PACKAGE, VERSION 1, & &7/29/2020 INPUT READ FROM UNIT ', i0, //)" ! ! --print a message identifying the immobile domain package. - write(this%iout, fmtmst) this%inunit + write (this%iout, fmtmst) this%inunit ! ! -- Read options call this%read_options() ! ! -- store pointers to arguments that were passed in - this%dis => dis - this%ibound => ibound + this%dis => dis + this%ibound => ibound ! ! -- Allocate arrays call this%allocate_arrays(dis%nodes) @@ -158,7 +158,7 @@ subroutine mst_ar(this, dis, ibound) ! -- Return return end subroutine mst_ar - + !> @ brief Fill coefficient method for package !! !! Method to calculate and fill coefficients for the package. @@ -168,16 +168,16 @@ subroutine mst_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, cnew, & rhs, kiter) ! -- modules ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer, intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - integer(I4B), intent(in) :: nja !< number of GWT connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix - integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - integer(I4B), intent(in) :: kiter !< solution outer iteration number + class(GwtMstType) :: this !< GwtMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + integer(I4B), intent(in) :: nja !< number of GWT connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + integer(I4B), intent(in) :: kiter !< solution outer iteration number ! -- local ! ! -- storage contribution @@ -203,7 +203,7 @@ subroutine mst_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, cnew, & ! -- Return return end subroutine mst_fc - + !> @ brief Fill storage coefficient method for package !! !! Method to calculate and fill storage coefficients for the package. @@ -213,14 +213,14 @@ subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer, intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - integer(I4B), intent(in) :: nja !< number of GWT connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix - integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + class(GwtMstType) :: this !< GwtMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + integer(I4B), intent(in) :: nja !< number of GWT connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model ! -- local integer(I4B) :: n, idiag real(DP) :: tled @@ -234,7 +234,7 @@ subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) do n = 1, this%dis%nodes ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- calculate new and old water volumes vnew = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) * & @@ -249,32 +249,32 @@ subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) idiag = this%dis%con%ia(n) amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof rhs(n) = rhs(n) + rrhs - enddo + end do ! ! -- Return return end subroutine mst_fc_sto - + !> @ brief Fill decay coefficient method for package !! !! Method to calculate and fill decay coefficients for the package. !! !< - subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & + subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & idxglo, rhs, kiter) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer, intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - integer(I4B), intent(in) :: nja !< number of GWT connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix - integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model - integer(I4B), intent(in) :: kiter !< solution outer iteration number + class(GwtMstType) :: this !< GwtMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + integer(I4B), intent(in) :: nja !< number of GWT connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + integer(I4B), intent(in) :: kiter !< solution outer iteration number ! -- local integer(I4B) :: n, idiag real(DP) :: hhcof, rrhs @@ -286,7 +286,7 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & do n = 1, this%dis%nodes ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- calculate new and old water volumes vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) @@ -304,14 +304,14 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & ! ! -- Call function to get zero-order decay rate, which may be changed ! from the user-specified rate to prevent negative concentrations - decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), kiter, & - cold(n), cnew(n), delt) + decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & + kiter, cold(n), cnew(n), delt) this%decaylast(n) = decay_rate rrhs = decay_rate * vcell * swtpdt * this%porosity(n) rhs(n) = rhs(n) + rrhs - endif + end if ! - enddo + end do ! ! -- Return return @@ -322,20 +322,20 @@ end subroutine mst_fc_dcy !! Method to calculate and fill sorption coefficients for the package. !! !< - subroutine mst_fc_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs, & + subroutine mst_fc_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs, & cnew) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer, intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - integer(I4B), intent(in) :: nja !< number of GWT connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix - integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + class(GwtMstType) :: this !< GwtMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + integer(I4B), intent(in) :: nja !< number of GWT connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step ! -- local integer(I4B) :: n, idiag real(DP) :: tled @@ -354,7 +354,7 @@ subroutine mst_fc_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs, & do n = 1, this%dis%nodes ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- assign variables vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) @@ -366,43 +366,43 @@ subroutine mst_fc_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs, & const2 = 0. if (this%isrb > 1) const2 = this%sp2(n) rhob = this%bulk_density(n) - call mst_srb_term(this%isrb, thetamfrac, rhob, vcell, tled, cnew(n), & - cold(n), swtpdt, swt, const1, const2, & - hcofval=hhcof, rhsval=rrhs) + call mst_srb_term(this%isrb, thetamfrac, rhob, vcell, tled, cnew(n), & + cold(n), swtpdt, swt, const1, const2, & + hcofval=hhcof, rhsval=rrhs) ! ! -- Add hhcof to diagonal and rrhs to right-hand side amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof rhs(n) = rhs(n) + rrhs ! - enddo + end do ! ! -- Return return end subroutine mst_fc_srb - + !> @ brief Calculate sorption terms !! !! Subroutine to calculate sorption terms !! !< - subroutine mst_srb_term(isrb, thetamfrac, rhob, vcell, tled, cnew, cold, & - swnew, swold, const1, const2, rate, hcofval, rhsval) + subroutine mst_srb_term(isrb, thetamfrac, rhob, vcell, tled, cnew, cold, & + swnew, swold, const1, const2, rate, hcofval, rhsval) ! -- modules ! -- dummy - integer(I4B), intent(in) :: isrb !< sorption flag 1, 2, 3 are linear, freundlich, and langmuir - real(DP), intent(in) :: thetamfrac !< fraction of total porosity that is mobile - real(DP), intent(in) :: rhob !< bulk density - real(DP), intent(in) :: vcell !< volume of cell - real(DP), intent(in) :: tled !< one over time step length - real(DP), intent(in) :: cnew !< concentration at end of this time step - real(DP), intent(in) :: cold !< concentration at end of last time step - real(DP), intent(in) :: swnew !< cell saturation at end of this time step - real(DP), intent(in) :: swold !< cell saturation at end of last time step - real(DP), intent(in) :: const1 !< distribution coefficient or freundlich or langmuir constant - real(DP), intent(in) :: const2 !< zero, freundlich exponent, or langmuir sorption sites - real(DP), intent(out), optional :: rate !< calculated sorption rate - real(DP), intent(out), optional :: hcofval !< diagonal contribution to solution coefficient matrix - real(DP), intent(out), optional :: rhsval !< contribution to solution right-hand-side + integer(I4B), intent(in) :: isrb !< sorption flag 1, 2, 3 are linear, freundlich, and langmuir + real(DP), intent(in) :: thetamfrac !< fraction of total porosity that is mobile + real(DP), intent(in) :: rhob !< bulk density + real(DP), intent(in) :: vcell !< volume of cell + real(DP), intent(in) :: tled !< one over time step length + real(DP), intent(in) :: cnew !< concentration at end of this time step + real(DP), intent(in) :: cold !< concentration at end of last time step + real(DP), intent(in) :: swnew !< cell saturation at end of this time step + real(DP), intent(in) :: swold !< cell saturation at end of last time step + real(DP), intent(in) :: const1 !< distribution coefficient or freundlich or langmuir constant + real(DP), intent(in) :: const2 !< zero, freundlich exponent, or langmuir sorption sites + real(DP), intent(out), optional :: rate !< calculated sorption rate + real(DP), intent(out), optional :: hcofval !< diagonal contribution to solution coefficient matrix + real(DP), intent(out), optional :: rhsval !< contribution to solution right-hand-side ! -- local real(DP) :: term real(DP) :: derv @@ -415,14 +415,14 @@ subroutine mst_srb_term(isrb, thetamfrac, rhob, vcell, tled, cnew, cold, & ! -- Calculate based on type of sorption if (isrb == 1) then ! -- linear - term = - thetamfrac * rhob * vcell * tled * const1 + term = -thetamfrac * rhob * vcell * tled * const1 if (present(hcofval)) hcofval = term * swnew if (present(rhsval)) rhsval = term * swold * cold if (present(rate)) rate = term * swnew * cnew - term * swold * cold else ! ! -- calculate average aqueous concentration - cavg = DHALF * (cold + cnew) + cavg = DHALF * (cold + cnew) ! ! -- set values based on isotherm if (isrb == 2) then @@ -438,7 +438,7 @@ subroutine mst_srb_term(isrb, thetamfrac, rhob, vcell, tled, cnew, cold, & end if ! ! -- calculate hcof, rhs, and rate for freundlich and langmuir - term = - thetamfrac * rhob * vcell * tled + term = -thetamfrac * rhob * vcell * tled cbaravg = (cbarold + cbarnew) * DHALF swavg = (swnew + swold) * DHALF if (present(hcofval)) then @@ -460,21 +460,21 @@ end subroutine mst_srb_term !! Method to calculate and fill sorption-decay coefficients for the package. !! !< - subroutine mst_fc_dcy_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, & + subroutine mst_fc_dcy_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, & rhs, cnew, kiter) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer, intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - integer(I4B), intent(in) :: nja !< number of GWT connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix - integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - integer(I4B), intent(in) :: kiter !< solution outer iteration number + class(GwtMstType) :: this !< GwtMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + integer(I4B), intent(in) :: nja !< number of GWT connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + integer(I4B), intent(in) :: kiter !< solution outer iteration number ! -- local integer(I4B) :: n, idiag real(DP) :: hhcof, rrhs @@ -492,17 +492,17 @@ subroutine mst_fc_dcy_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, & do n = 1, this%dis%nodes ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- set variables hhcof = DZERO rrhs = DZERO vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) - swnew = this%fmi%gwfsat(n) + swnew = this%fmi%gwfsat(n) distcoef = this%distcoef(n) idiag = this%dis%con%ia(n) thetamfrac = this%get_thetamfrac(n) - term = this%decay_sorbed(n) * thetamfrac * this%bulk_density(n) * & + term = this%decay_sorbed(n) * thetamfrac * this%bulk_density(n) * & swnew * vcell ! ! -- add sorbed mass decay rate terms to accumulators @@ -512,7 +512,7 @@ subroutine mst_fc_dcy_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, & ! ! -- first order decay rate is a function of concentration, so add ! to left hand side - hhcof = - term * distcoef + hhcof = -term * distcoef else if (this%isrb == 2) then ! ! -- nonlinear Freundlich sorption, so add to RHS @@ -529,7 +529,7 @@ subroutine mst_fc_dcy_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, & ! -- Call function to get zero-order decay rate, which may be changed ! from the user-specified rate to prevent negative concentrations if (distcoef > DZERO) then - + if (this%isrb == 1) then csrbold = cold(n) * distcoef csrbnew = cnew(n) * distcoef @@ -540,26 +540,26 @@ subroutine mst_fc_dcy_srb(this, nodes, cold, nja, njasln, amatsln, idxglo, & csrbold = get_langmuir_conc(cold(n), distcoef, this%sp2(n)) csrbnew = get_langmuir_conc(cnew(n), distcoef, this%sp2(n)) end if - - decay_rate = get_zero_order_decay(this%decay_sorbed(n), & - this%decayslast(n), & + + decay_rate = get_zero_order_decay(this%decay_sorbed(n), & + this%decayslast(n), & kiter, csrbold, csrbnew, delt) this%decayslast(n) = decay_rate rrhs = decay_rate * thetamfrac * this%bulk_density(n) * swnew * vcell end if - - endif + + end if ! ! -- Add hhcof to diagonal and rrhs to right-hand side amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof rhs(n) = rhs(n) + rrhs ! - enddo + end do ! ! -- Return return end subroutine mst_fc_dcy_srb - + !> @ brief Calculate flows for package !! !! Method to calculate flows for the package. @@ -568,11 +568,11 @@ end subroutine mst_fc_dcy_srb subroutine mst_cq(this, nodes, cnew, cold, flowja) ! -- modules ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes ! -- local ! ! - storage @@ -606,11 +606,11 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes ! -- local integer(I4B) :: n integer(I4B) :: idiag @@ -619,7 +619,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) real(DP) :: vnew, vold real(DP) :: hhcof, rrhs ! - ! -- initialize + ! -- initialize tled = DONE / delt ! ! -- Calculate storage change @@ -627,7 +627,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) this%ratesto(n) = DZERO ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- calculate new and old water volumes vnew = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) * & @@ -643,7 +643,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) this%ratesto(n) = rate idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate - enddo + end do ! ! -- Return return @@ -658,11 +658,11 @@ subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes ! -- local integer(I4B) :: n integer(I4B) :: idiag @@ -672,14 +672,14 @@ subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) real(DP) :: vcell real(DP) :: decay_rate ! - ! -- initialize + ! -- initialize ! ! -- Calculate decay change do n = 1, nodes ! ! -- skip if transport inactive this%ratedcy(n) = DZERO - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- calculate new and old water volumes vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) @@ -692,16 +692,16 @@ subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) if (this%idcy == 1) then hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) elseif (this%idcy == 2) then - decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & + decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & 0, cold(n), cnew(n), delt) rrhs = decay_rate * vcell * swtpdt * this%porosity(n) - endif + end if rate = hhcof * cnew(n) - rrhs this%ratedcy(n) = rate idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate ! - enddo + end do ! ! -- Return return @@ -716,11 +716,11 @@ subroutine mst_cq_srb(this, nodes, cnew, cold, flowja) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes ! -- local integer(I4B) :: n integer(I4B) :: idiag @@ -733,7 +733,7 @@ subroutine mst_cq_srb(this, nodes, cnew, cold, flowja) real(DP) :: const2 real(DP) :: thetamfrac ! - ! -- initialize + ! -- initialize tled = DONE / delt ! ! -- Calculate sorption change @@ -743,7 +743,7 @@ subroutine mst_cq_srb(this, nodes, cnew, cold, flowja) this%ratesrb(n) = DZERO ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- assign variables vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) @@ -754,14 +754,14 @@ subroutine mst_cq_srb(this, nodes, cnew, cold, flowja) const1 = this%distcoef(n) const2 = 0. if (this%isrb > 1) const2 = this%sp2(n) - call mst_srb_term(this%isrb, thetamfrac, rhob, vcell, tled, cnew(n), & - cold(n), swtpdt, swt, const1, const2, & - rate=rate) + call mst_srb_term(this%isrb, thetamfrac, rhob, vcell, tled, cnew(n), & + cold(n), swtpdt, swt, const1, const2, & + rate=rate) this%ratesrb(n) = rate idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate ! - enddo + end do ! ! -- Return return @@ -776,11 +776,11 @@ subroutine mst_cq_dcy_srb(this, nodes, cnew, cold, flowja) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: nodes !< number of nodes - real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step - real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< concentration at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< concentration at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes ! -- local integer(I4B) :: n integer(I4B) :: idiag @@ -804,16 +804,16 @@ subroutine mst_cq_dcy_srb(this, nodes, cnew, cold, flowja) this%ratedcys(n) = DZERO ! ! -- skip if transport inactive - if(this%ibound(n) <= 0) cycle + if (this%ibound(n) <= 0) cycle ! ! -- set variables hhcof = DZERO rrhs = DZERO vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) - swnew = this%fmi%gwfsat(n) + swnew = this%fmi%gwfsat(n) distcoef = this%distcoef(n) thetamfrac = this%get_thetamfrac(n) - term = this%decay_sorbed(n) * thetamfrac * this%bulk_density(n) * & + term = this%decay_sorbed(n) * thetamfrac * this%bulk_density(n) * & swnew * vcell ! ! -- add sorbed mass decay rate terms to accumulators @@ -823,7 +823,7 @@ subroutine mst_cq_dcy_srb(this, nodes, cnew, cold, flowja) ! ! -- first order decay rate is a function of concentration, so add ! to left hand side - hhcof = - term * distcoef + hhcof = -term * distcoef else if (this%isrb == 2) then ! ! -- nonlinear Freundlich sorption, so add to RHS @@ -850,12 +850,12 @@ subroutine mst_cq_dcy_srb(this, nodes, cnew, cold, flowja) csrbold = get_langmuir_conc(cold(n), distcoef, this%sp2(n)) csrbnew = get_langmuir_conc(cnew(n), distcoef, this%sp2(n)) end if - decay_rate = get_zero_order_decay(this%decay_sorbed(n), & - this%decayslast(n), & + decay_rate = get_zero_order_decay(this%decay_sorbed(n), & + this%decayslast(n), & 0, csrbold, csrbnew, delt) rrhs = decay_rate * thetamfrac * this%bulk_density(n) * swnew * vcell - end if - endif + end if + end if ! ! -- calculate rate rate = hhcof * cnew(n) - rrhs @@ -863,7 +863,7 @@ subroutine mst_cq_dcy_srb(this, nodes, cnew, cold, flowja) idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate ! - enddo + end do ! ! -- Return return @@ -879,43 +879,43 @@ subroutine mst_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: isuppress_output !< flag to supress output - type(BudgetType), intent(inout) :: model_budget !< model budget object + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: isuppress_output !< flag to supress output + type(BudgetType), intent(inout) :: model_budget !< model budget object ! -- local real(DP) :: rin real(DP) :: rout ! ! -- sto call rate_accumulator(this%ratesto, rin, rout) - call model_budget%addentry(rin, rout, delt, budtxt(1), & + call model_budget%addentry(rin, rout, delt, budtxt(1), & isuppress_output, rowlabel=this%packName) ! ! -- dcy if (this%idcy /= 0) then call rate_accumulator(this%ratedcy, rin, rout) - call model_budget%addentry(rin, rout, delt, budtxt(2), & - isuppress_output, rowlabel=this%packName) + call model_budget%addentry(rin, rout, delt, budtxt(2), & + isuppress_output, rowlabel=this%packName) end if ! ! -- srb if (this%isrb /= 0) then call rate_accumulator(this%ratesrb, rin, rout) - call model_budget%addentry(rin, rout, delt, budtxt(3), & - isuppress_output, rowlabel=this%packName) + call model_budget%addentry(rin, rout, delt, budtxt(3), & + isuppress_output, rowlabel=this%packName) end if ! ! -- srb dcy if (this%isrb /= 0 .and. this%idcy /= 0) then call rate_accumulator(this%ratedcys, rin, rout) - call model_budget%addentry(rin, rout, delt, budtxt(4), & - isuppress_output, rowlabel=this%packName) + call model_budget%addentry(rin, rout, delt, budtxt(4), & + isuppress_output, rowlabel=this%packName) end if ! ! -- Return return end subroutine mst_bd - + !> @ brief Output flow terms for package !! !! Method to output terms for the package. @@ -923,54 +923,54 @@ end subroutine mst_bd !< subroutine mst_ot_flow(this, icbcfl, icbcun) ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output - integer(I4B), intent(in) :: icbcun !< flag indication if cell-by-cell data should be saved + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output + integer(I4B), intent(in) :: icbcun !< flag indication if cell-by-cell data should be saved ! -- local integer(I4B) :: ibinun !character(len=16), dimension(2) :: aname integer(I4B) :: iprint, nvaluesp, nwidthp - character(len=1) :: cdatafmp=' ', editdesc=' ' + character(len=1) :: cdatafmp = ' ', editdesc = ' ' real(DP) :: dinact ! ! -- Set unit number for binary output - if(this%ipakcb < 0) then + if (this%ipakcb < 0) then ibinun = icbcun - elseif(this%ipakcb == 0) then + elseif (this%ipakcb == 0) then ibinun = 0 else ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 + end if + if (icbcfl == 0) ibinun = 0 ! ! -- Record the storage rate if requested - if(ibinun /= 0) then + if (ibinun /= 0) then iprint = 0 dinact = DZERO ! ! -- sto - call this%dis%record_array(this%ratesto, this%iout, iprint, -ibinun, & - budtxt(1), cdatafmp, nvaluesp, & + call this%dis%record_array(this%ratesto, this%iout, iprint, -ibinun, & + budtxt(1), cdatafmp, nvaluesp, & nwidthp, editdesc, dinact) ! ! -- dcy if (this%idcy /= 0) & - call this%dis%record_array(this%ratedcy, this%iout, iprint, -ibinun, & - budtxt(2), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) + call this%dis%record_array(this%ratedcy, this%iout, iprint, -ibinun, & + budtxt(2), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) ! ! -- srb if (this%isrb /= 0) & - call this%dis%record_array(this%ratesrb, this%iout, iprint, -ibinun, & - budtxt(3), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) + call this%dis%record_array(this%ratesrb, this%iout, iprint, -ibinun, & + budtxt(3), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) ! ! -- dcy srb if (this%isrb /= 0 .and. this%idcy /= 0) & - call this%dis%record_array(this%ratedcys, this%iout, iprint, -ibinun, & - budtxt(4), cdatafmp, nvaluesp, & - nwidthp, editdesc, dinact) - endif + call this%dis%record_array(this%ratedcys, this%iout, iprint, -ibinun, & + budtxt(4), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if ! ! -- Return return @@ -985,10 +985,10 @@ subroutine mst_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtMstType) :: this !< GwtMstType object + class(GwtMstType) :: this !< GwtMstType object ! ! -- Deallocate arrays if package was active - if(this%inunit > 0) then + if (this%inunit > 0) then call mem_deallocate(this%porosity) call mem_deallocate(this%prsity2) call mem_deallocate(this%ratesto) @@ -1006,7 +1006,7 @@ subroutine mst_da(this) call mem_deallocate(this%ratedcys) this%ibound => null() this%fmi => null() - endif + end if ! ! -- Scalars ! @@ -1026,7 +1026,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtMstType) :: this !< GwtMstType object + class(GwtMstType) :: this !< GwtMstType object ! -- local ! ! -- Allocate scalars in NumericalPackageType @@ -1054,8 +1054,8 @@ subroutine allocate_arrays(this, nodes) use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: nodes !< number of nodes + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: nodes !< number of nodes ! -- local integer(I4B) :: n ! @@ -1076,26 +1076,26 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%decaylast, nodes, 'DECAYLAST', this%memoryPath) end if if (this%idcy /= 0 .and. this%isrb /= 0) then - call mem_allocate(this%ratedcys, this%dis%nodes, 'RATEDCYS', & + call mem_allocate(this%ratedcys, this%dis%nodes, 'RATEDCYS', & this%memoryPath) - call mem_allocate(this%decayslast, this%dis%nodes, 'DECAYSLAST', & + call mem_allocate(this%decayslast, this%dis%nodes, 'DECAYSLAST', & this%memoryPath) else call mem_allocate(this%ratedcys, 1, 'RATEDCYS', this%memoryPath) call mem_allocate(this%decayslast, 1, 'DECAYSLAST', this%memoryPath) - endif - call mem_allocate(this%decay_sorbed, 1, 'DECAY_SORBED', & + end if + call mem_allocate(this%decay_sorbed, 1, 'DECAY_SORBED', & this%memoryPath) ! ! -- srb if (this%isrb == 0) then call mem_allocate(this%bulk_density, 1, 'BULK_DENSITY', this%memoryPath) call mem_allocate(this%sp2, 1, 'SP2', this%memoryPath) - call mem_allocate(this%distcoef, 1, 'DISTCOEF', this%memoryPath) + call mem_allocate(this%distcoef, 1, 'DISTCOEF', this%memoryPath) call mem_allocate(this%ratesrb, 1, 'RATESRB', this%memoryPath) else call mem_allocate(this%bulk_density, nodes, 'BULK_DENSITY', this%memoryPath) - call mem_allocate(this%distcoef, nodes, 'DISTCOEF', this%memoryPath) + call mem_allocate(this%distcoef, nodes, 'DISTCOEF', this%memoryPath) call mem_allocate(this%ratesrb, nodes, 'RATESRB', this%memoryPath) if (this%isrb == 1) then call mem_allocate(this%sp2, 1, 'SP2', this%memoryPath) @@ -1109,7 +1109,7 @@ subroutine allocate_arrays(this, nodes) this%porosity(n) = DZERO this%prsity2(n) = DZERO this%ratesto(n) = DZERO - enddo + end do do n = 1, size(this%decay) this%decay(n) = DZERO this%ratedcy(n) = DZERO @@ -1139,27 +1139,27 @@ end subroutine allocate_arrays !< subroutine read_options(this) ! -- modules - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwtMstType) :: this !< GwtMstType object + class(GwtMstType) :: this !< GwtMstType object ! -- local character(len=LINELENGTH) :: keyword, keyword2 integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisrb = & - "(4x,'LINEAR SORPTION IS ACTIVE. ')" - character(len=*), parameter :: fmtfreundlich = & - "(4x,'FREUNDLICH SORPTION IS ACTIVE. ')" - character(len=*), parameter :: fmtlangmuir = & - "(4x,'LANGMUIR SORPTION IS ACTIVE. ')" - character(len=*), parameter :: fmtidcy1 = & - "(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" - character(len=*), parameter :: fmtidcy2 = & - "(4x,'ZERO-ORDER DECAY IS ACTIVE. ')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtisrb = & + &"(4x,'LINEAR SORPTION IS ACTIVE. ')" + character(len=*), parameter :: fmtfreundlich = & + &"(4x,'FREUNDLICH SORPTION IS ACTIVE. ')" + character(len=*), parameter :: fmtlangmuir = & + &"(4x,'LANGMUIR SORPTION IS ACTIVE. ')" + character(len=*), parameter :: fmtidcy1 = & + &"(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" + character(len=*), parameter :: fmtidcy2 = & + &"(4x,'ZERO-ORDER DECAY IS ACTIVE. ')" ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & @@ -1167,42 +1167,42 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)') 'PROCESSING MOBILE STORAGE AND TRANSFER OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING MOBILE STORAGE AND TRANSFER OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtisvflow) - case ('SORBTION', 'SORPTION') - this%isrb = 1 - call this%parser%GetStringCaps(keyword2) - if (trim(adjustl(keyword2)) == 'LINEAR') this%isrb = 1 - if (trim(adjustl(keyword2)) == 'FREUNDLICH') this%isrb = 2 - if (trim(adjustl(keyword2)) == 'LANGMUIR') this%isrb = 3 - select case (this%isrb) - case(1) - write(this%iout, fmtisrb) - case(2) - write(this%iout, fmtfreundlich) - case(3) - write(this%iout, fmtlangmuir) - end select - case ('FIRST_ORDER_DECAY') - this%idcy = 1 - write(this%iout, fmtidcy1) - case ('ZERO_ORDER_DECAY') - this%idcy = 2 - write(this%iout, fmtidcy2) - case default - write(errmsg,'(a,a)') 'UNKNOWN MST OPTION: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtisvflow) + case ('SORBTION', 'SORPTION') + this%isrb = 1 + call this%parser%GetStringCaps(keyword2) + if (trim(adjustl(keyword2)) == 'LINEAR') this%isrb = 1 + if (trim(adjustl(keyword2)) == 'FREUNDLICH') this%isrb = 2 + if (trim(adjustl(keyword2)) == 'LANGMUIR') this%isrb = 3 + select case (this%isrb) + case (1) + write (this%iout, fmtisrb) + case (2) + write (this%iout, fmtfreundlich) + case (3) + write (this%iout, fmtlangmuir) + end select + case ('FIRST_ORDER_DECAY') + this%idcy = 1 + write (this%iout, fmtidcy1) + case ('ZERO_ORDER_DECAY') + this%idcy = 2 + write (this%iout, fmtidcy2) + case default + write (errmsg, '(a,a)') 'UNKNOWN MST OPTION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)') 'END OF MOBILE STORAGE AND TRANSFER OPTIONS' + write (this%iout, '(1x,a)') 'END OF MOBILE STORAGE AND TRANSFER OPTIONS' end if ! ! -- Return @@ -1216,10 +1216,10 @@ end subroutine read_options !< subroutine read_data(this) ! -- modules - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH use MemoryManagerModule, only: mem_reallocate, mem_reassignptr ! -- dummy - class(GwtMstType) :: this !< GwtMstType object + class(GwtMstType) :: this !< GwtMstType object ! -- local character(len=LINELENGTH) :: keyword character(len=:), allocatable :: line @@ -1229,12 +1229,12 @@ subroutine read_data(this) character(len=24), dimension(6) :: aname ! -- formats ! -- data - data aname(1) /' MOBILE DOMAIN POROSITY'/ - data aname(2) /' BULK DENSITY'/ - data aname(3) /'DISTRIBUTION COEFFICIENT'/ - data aname(4) /' DECAY RATE'/ - data aname(5) /' DECAY SORBED RATE'/ - data aname(6) /' SECOND SORPTION PARAM'/ + data aname(1)/' MOBILE DOMAIN POROSITY'/ + data aname(2)/' BULK DENSITY'/ + data aname(3)/'DISTRIBUTION COEFFICIENT'/ + data aname(4)/' DECAY RATE'/ + data aname(5)/' DECAY SORBED RATE'/ + data aname(6)/' SECOND SORPTION PARAM'/ ! ! -- initialize isfound = .false. @@ -1242,8 +1242,8 @@ subroutine read_data(this) ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -1251,85 +1251,85 @@ subroutine read_data(this) call this%parser%GetRemainingLine(line) lloc = 1 select case (keyword) - case ('POROSITY') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%porosity, & - aname(1)) - lname(1) = .true. - case ('BULK_DENSITY') - if (this%isrb == 0) & - call mem_reallocate(this%bulk_density, this%dis%nodes, & - 'BULK_DENSITY', trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, & - this%bulk_density, aname(2)) - lname(2) = .true. - case ('DISTCOEF') - if (this%isrb == 0) & - call mem_reallocate(this%distcoef, this%dis%nodes, 'DISTCOEF', & + case ('POROSITY') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%porosity, & + aname(1)) + lname(1) = .true. + case ('BULK_DENSITY') + if (this%isrb == 0) & + call mem_reallocate(this%bulk_density, this%dis%nodes, & + 'BULK_DENSITY', trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, & + this%bulk_density, aname(2)) + lname(2) = .true. + case ('DISTCOEF') + if (this%isrb == 0) & + call mem_reallocate(this%distcoef, this%dis%nodes, 'DISTCOEF', & trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%distcoef, & - aname(3)) - lname(3) = .true. - case ('DECAY') - if (this%idcy == 0) & - call mem_reallocate(this%decay, this%dis%nodes, 'DECAY', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%decay, & - aname(4)) - lname(4) = .true. - case ('DECAY_SORBED') - call mem_reallocate(this%decay_sorbed, this%dis%nodes, & - 'DECAY_SORBED', trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, & - this%decay_sorbed, aname(5)) - lname(5) = .true. - case ('SP2') - if (this%isrb < 2) & - call mem_reallocate(this%sp2, this%dis%nodes, 'SP2', & + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%distcoef, & + aname(3)) + lname(3) = .true. + case ('DECAY') + if (this%idcy == 0) & + call mem_reallocate(this%decay, this%dis%nodes, 'DECAY', & trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& - this%parser%iuactive, this%sp2, & - aname(6)) - lname(6) = .true. - case default - write(errmsg,'(a,a)') 'UNKNOWN GRIDDATA TAG: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%decay, & + aname(4)) + lname(4) = .true. + case ('DECAY_SORBED') + call mem_reallocate(this%decay_sorbed, this%dis%nodes, & + 'DECAY_SORBED', trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, & + this%decay_sorbed, aname(5)) + lname(5) = .true. + case ('SP2') + if (this%isrb < 2) & + call mem_reallocate(this%sp2, this%dis%nodes, 'SP2', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%sp2, & + aname(6)) + lname(6) = .true. + case default + write (errmsg, '(a,a)') 'UNKNOWN GRIDDATA TAG: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)') 'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else - write(errmsg,'(a)') 'REQUIRED GRIDDATA BLOCK NOT FOUND.' + write (errmsg, '(a)') 'REQUIRED GRIDDATA BLOCK NOT FOUND.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if ! ! -- Check for rquired porosity - if(.not. lname(1)) then - write(errmsg, '(a)') 'POROSITY NOT SPECIFIED IN GRIDDATA BLOCK.' + if (.not. lname(1)) then + write (errmsg, '(a)') 'POROSITY NOT SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) end if ! ! -- Check for required sorption variables if (this%isrb > 0) then if (.not. lname(2)) then - write(errmsg, '(a)') 'SORPTION IS ACTIVE BUT BULK_DENSITY & + write (errmsg, '(a)') 'SORPTION IS ACTIVE BUT BULK_DENSITY & &NOT SPECIFIED. BULK_DENSITY MUST BE SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if if (.not. lname(3)) then - write(errmsg, '(a)') 'SORPTION IS ACTIVE BUT DISTRIBUTION & + write (errmsg, '(a)') 'SORPTION IS ACTIVE BUT DISTRIBUTION & &COEFFICIENT NOT SPECIFIED. DISTCOEF MUST BE SPECIFIED IN & &GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if if (this%isrb > 1) then if (.not. lname(6)) then - write(errmsg, '(a)') 'FREUNDLICH OR LANGMUIR SORPTION IS ACTIVE & + write (errmsg, '(a)') 'FREUNDLICH OR LANGMUIR SORPTION IS ACTIVE & &BUT SP2 NOT SPECIFIED. SP2 MUST BE SPECIFIED IN & &GRIDDATA BLOCK.' call store_error(errmsg) @@ -1337,68 +1337,68 @@ subroutine read_data(this) end if else if (lname(2)) then - write(warnmsg, '(a)') 'SORPTION IS NOT ACTIVE BUT & + write (warnmsg, '(a)') 'SORPTION IS NOT ACTIVE BUT & &BULK_DENSITY WAS SPECIFIED. BULK_DENSITY WILL HAVE NO AFFECT ON & &SIMULATION RESULTS.' call store_warning(warnmsg) - write(this%iout, '(1x,a)') 'WARNING. ' // warnmsg - endif + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if if (lname(3)) then - write(warnmsg, '(a)') 'SORPTION IS NOT ACTIVE BUT & + write (warnmsg, '(a)') 'SORPTION IS NOT ACTIVE BUT & &DISTRIBUTION COEFFICIENT WAS SPECIFIED. DISTCOEF WILL HAVE & &NO AFFECT ON SIMULATION RESULTS.' call store_warning(warnmsg) - write(this%iout, '(1x,a)') 'WARNING. ' // warnmsg - endif + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if if (lname(6)) then - write(warnmsg, '(a)') 'SORPTION IS NOT ACTIVE BUT & + write (warnmsg, '(a)') 'SORPTION IS NOT ACTIVE BUT & &SP2 WAS SPECIFIED. SP2 WILL HAVE & &NO AFFECT ON SIMULATION RESULTS.' call store_warning(warnmsg) - write(this%iout, '(1x,a)') 'WARNING. ' // warnmsg - endif - endif + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if + end if ! ! -- Check for required decay/production rate coefficients if (this%idcy > 0) then if (.not. lname(4)) then - write(errmsg, '(a)') 'FIRST OR ZERO ORDER DECAY IS & + write (errmsg, '(a)') 'FIRST OR ZERO ORDER DECAY IS & &ACTIVE BUT THE FIRST RATE COEFFICIENT IS NOT SPECIFIED. DECAY & &MUST BE SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) - endif + end if if (.not. lname(5)) then ! ! -- If DECAY_SORBED not specified and sorption is active, then ! terminate with an error if (this%isrb > 0) then - write(errmsg, '(a)') 'DECAY_SORBED not provided in GRIDDATA & + write (errmsg, '(a)') 'DECAY_SORBED not provided in GRIDDATA & &block but decay and sorption are active. Specify DECAY_SORBED & &in GRIDDATA block.' call store_error(errmsg) - endif - endif + end if + end if else if (lname(4)) then - write(warnmsg, '(a)') 'FIRST OR ZERO ORER DECAY & + write (warnmsg, '(a)') 'FIRST OR ZERO ORER DECAY & &IS NOT ACTIVE BUT DECAY WAS SPECIFIED. DECAY WILL & &HAVE NO AFFECT ON SIMULATION RESULTS.' call store_warning(warnmsg) - write(this%iout, '(1x,a)') 'WARNING. ' // warnmsg - endif + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if if (lname(5)) then - write(warnmsg, '(a)') 'FIRST OR ZERO ORER DECAY & + write (warnmsg, '(a)') 'FIRST OR ZERO ORER DECAY & &IS NOT ACTIVE BUT DECAY_SORBED WAS SPECIFIED. & &DECAY_SORBED WILL HAVE NO AFFECT ON SIMULATION RESULTS.' call store_warning(warnmsg) - write(this%iout, '(1x,a)') 'WARNING. ' // warnmsg - endif - endif + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if + end if ! ! -- terminate if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return @@ -1406,15 +1406,15 @@ end subroutine read_data !> @ brief Add porosity values to prsity2 !! - !! Method to add immobile domain porosities, which are stored as a + !! Method to add immobile domain porosities, which are stored as a !! cumulative value in prsity2. !! !< subroutine addto_prsity2(this, thetaim) ! -- modules ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - real(DP), dimension(:), intent(in) :: thetaim !< immobile domain porosity that contributes to total porosity + class(GwtMstType) :: this !< GwtMstType object + real(DP), dimension(:), intent(in) :: thetaim !< immobile domain porosity that contributes to total porosity ! -- local integer(I4B) :: n ! @@ -1436,8 +1436,8 @@ end subroutine addto_prsity2 function get_thetamfrac(this, node) result(thetamfrac) ! -- modules ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: node !< node number + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: node !< node number ! -- return real(DP) :: thetamfrac ! @@ -1447,7 +1447,7 @@ function get_thetamfrac(this, node) result(thetamfrac) ! -- Return return end function get_thetamfrac - + !> @ brief Return immobile porosity fraction !! !! Pass in an immobile domain porosity and calculate the fraction @@ -1457,19 +1457,19 @@ end function get_thetamfrac function get_thetaimfrac(this, node, thetaim) result(thetaimfrac) ! -- modules ! -- dummy - class(GwtMstType) :: this !< GwtMstType object - integer(I4B), intent(in) :: node !< node number - real(DP), intent(in) :: thetaim !< immobile domain porosity + class(GwtMstType) :: this !< GwtMstType object + integer(I4B), intent(in) :: node !< node number + real(DP), intent(in) :: thetaim !< immobile domain porosity ! -- return real(DP) :: thetaimfrac ! thetaimfrac = thetaim / & - (this%porosity(node) + this%prsity2(node)) + (this%porosity(node) + this%prsity2(node)) ! ! -- Return return end function get_thetaimfrac - + !> @ brief Calculate sorption concentration using Freundlich !! !! Function to calculate sorption concentration using Freundlich @@ -1477,20 +1477,20 @@ end function get_thetaimfrac !< function get_freundlich_conc(conc, kf, a) result(cbar) ! -- dummy - real(DP), intent(in) :: conc !< solute concentration - real(DP), intent(in) :: kf !< freundlich constant - real(DP), intent(in) :: a !< freundlich exponent + real(DP), intent(in) :: conc !< solute concentration + real(DP), intent(in) :: kf !< freundlich constant + real(DP), intent(in) :: a !< freundlich exponent ! -- return real(DP) :: cbar ! if (conc > DZERO) then - cbar = kf * conc ** a + cbar = kf * conc**a else cbar = DZERO end if return - end function - + end function + !> @ brief Calculate sorption concentration using Langmuir !! !! Function to calculate sorption concentration using Langmuir @@ -1498,9 +1498,9 @@ function get_freundlich_conc(conc, kf, a) result(cbar) !< function get_langmuir_conc(conc, kl, sbar) result(cbar) ! -- dummy - real(DP), intent(in) :: conc !< solute concentration - real(DP), intent(in) :: kl !< langmuir constant - real(DP), intent(in) :: sbar !< langmuir sorption sites + real(DP), intent(in) :: conc !< solute concentration + real(DP), intent(in) :: kl !< langmuir constant + real(DP), intent(in) :: sbar !< langmuir sorption sites ! -- return real(DP) :: cbar ! @@ -1510,8 +1510,8 @@ function get_langmuir_conc(conc, kl, sbar) result(cbar) cbar = DZERO end if return - end function - + end function + !> @ brief Calculate sorption derivative using Freundlich !! !! Function to calculate sorption derivative using Freundlich @@ -1519,20 +1519,20 @@ function get_langmuir_conc(conc, kl, sbar) result(cbar) !< function get_freundlich_derivative(conc, kf, a) result(derv) ! -- dummy - real(DP), intent(in) :: conc !< solute concentration - real(DP), intent(in) :: kf !< freundlich constant - real(DP), intent(in) :: a !< freundlich exponent + real(DP), intent(in) :: conc !< solute concentration + real(DP), intent(in) :: kf !< freundlich constant + real(DP), intent(in) :: a !< freundlich exponent ! -- return real(DP) :: derv ! if (conc > DZERO) then - derv = kf * a * conc ** (a - DONE) + derv = kf * a * conc**(a - DONE) else derv = DZERO end if return - end function - + end function + !> @ brief Calculate sorption derivative using Langmuir !! !! Function to calculate sorption derivative using Langmuir @@ -1540,20 +1540,20 @@ function get_freundlich_derivative(conc, kf, a) result(derv) !< function get_langmuir_derivative(conc, kl, sbar) result(derv) ! -- dummy - real(DP), intent(in) :: conc !< solute concentration - real(DP), intent(in) :: kl !< langmuir constant - real(DP), intent(in) :: sbar !< langmuir sorption sites + real(DP), intent(in) :: conc !< solute concentration + real(DP), intent(in) :: kl !< langmuir constant + real(DP), intent(in) :: sbar !< langmuir sorption sites ! -- return real(DP) :: derv ! if (conc > DZERO) then - derv = (kl * sbar) / (DONE + kl * conc) ** DTWO + derv = (kl * sbar) / (DONE + kl * conc)**DTWO else derv = DZERO end if return - end function - + end function + !> @ brief Calculate zero-order decay rate and constrain if necessary !! !! Function to calculate the zero-order decay rate from the user specified @@ -1565,14 +1565,14 @@ function get_langmuir_derivative(conc, kl, sbar) result(derv) function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & cold, cnew, delt) result(decay_rate) ! -- dummy - real(DP), intent(in) :: decay_rate_usr !< user-entered decay rate - real(DP), intent(in) :: decay_rate_last !< decay rate used for last iteration - integer(I4B), intent(in) :: kiter !< Picard iteration counter - real(DP), intent(in) :: cold !< concentration at end of last time step - real(DP), intent(in) :: cnew !< concentration at end of this time step - real(DP), intent(in) :: delt !< length of time step + real(DP), intent(in) :: decay_rate_usr !< user-entered decay rate + real(DP), intent(in) :: decay_rate_last !< decay rate used for last iteration + integer(I4B), intent(in) :: kiter !< Picard iteration counter + real(DP), intent(in) :: cold !< concentration at end of last time step + real(DP), intent(in) :: cnew !< concentration at end of this time step + real(DP), intent(in) :: delt !< length of time step ! -- return - real(DP) :: decay_rate !< returned value for decay rate + real(DP) :: decay_rate !< returned value for decay rate ! ! -- Return user rate if production, otherwise constrain, if necessary if (decay_rate_usr < DZERO) then @@ -1599,6 +1599,5 @@ function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & end if return end function get_zero_order_decay - - -end module GwtMstModule \ No newline at end of file + +end module GwtMstModule diff --git a/src/Model/GroundWaterTransport/gwt1mwt1.f90 b/src/Model/GroundWaterTransport/gwt1mwt1.f90 index d9bcd38f22d..c63d690d627 100644 --- a/src/Model/GroundWaterTransport/gwt1mwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mwt1.f90 @@ -18,11 +18,11 @@ ! FW-RATE idxbudfwrt FW-RATE q * cwell ! RATE-TO-MVR idxbudrtmv RATE-TO-MVR q * cwell ! FW-RATE-TO-MVR idxbudfrtm FW-RATE-TO-MVR q * cwell - + ! -- terms from MAW that should be skipped ! CONSTANT-TO-MVR ? CONSTANT-TO-MVR q * cwell - ! -- terms from a flow file that should be skipped +! -- terms from a flow file that should be skipped ! CONSTANT none none none ! AUXILIARY none none none @@ -31,35 +31,35 @@ ! none none AUXILIARY none ! none none CONSTANT accumulate ! -! +! module GwtMwtModule use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, LINELENGTH use SimModule, only: store_error use BndModule, only: BndType, GetBndFromList - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use MawModule, only: MawType use GwtAptModule, only: GwtAptType - + implicit none - + public mwt_create - + character(len=*), parameter :: ftype = 'MWT' character(len=*), parameter :: flowtype = 'MAW' - character(len=16) :: text = ' MWT' - + character(len=16) :: text = ' MWT' + type, extends(GwtAptType) :: GwtMwtType - - integer(I4B), pointer :: idxbudrate => null() ! index of well rate terms in flowbudptr - integer(I4B), pointer :: idxbudfwrt => null() ! index of flowing well rate terms in flowbudptr - integer(I4B), pointer :: idxbudrtmv => null() ! index of rate to mover terms in flowbudptr - integer(I4B), pointer :: idxbudfrtm => null() ! index of flowing well rate to mover terms in flowbudptr - real(DP), dimension(:), pointer, contiguous :: concrate => null() ! well rate concentration + + integer(I4B), pointer :: idxbudrate => null() ! index of well rate terms in flowbudptr + integer(I4B), pointer :: idxbudfwrt => null() ! index of flowing well rate terms in flowbudptr + integer(I4B), pointer :: idxbudrtmv => null() ! index of rate to mover terms in flowbudptr + integer(I4B), pointer :: idxbudfrtm => null() ! index of flowing well rate to mover terms in flowbudptr + real(DP), dimension(:), pointer, contiguous :: concrate => null() ! well rate concentration contains - + procedure :: bnd_da => mwt_da procedure :: allocate_scalars procedure :: apt_allocate_arrays => mwt_allocate_arrays @@ -76,11 +76,11 @@ module GwtMwtModule procedure :: pak_df_obs => mwt_df_obs procedure :: pak_bd_obs => mwt_bd_obs procedure :: pak_set_stressperiod => mwt_set_stressperiod - + end type GwtMwtType - contains - +contains + subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi) ! ****************************************************************************** @@ -91,19 +91,19 @@ subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname - type(GwtFmiType), pointer :: fmi + type(TspFmiType), pointer :: fmi ! -- local type(GwtMwtType), pointer :: mwtobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(mwtobj) + allocate (mwtobj) packobj => mwtobj ! ! -- create name and memory path @@ -122,7 +122,7 @@ subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ibcnum = ibcnum packobj%ncolbnd = 1 packobj%iscloc = 1 - + ! -- Store pointer to flow model interface. When the GwfGwt exchange is ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages @@ -164,7 +164,7 @@ subroutine find_mwt_package(this) ! else if (associated(this%fmi%gwfbndlist)) then - ! -- Look through gwfbndlist for a flow package with the same name as + ! -- Look through gwfbndlist for a flow package with the same name as ! this transport package name do ip = 1, this%fmi%gwfbndlist%Count() packobj => GetBndFromList(this%fmi%gwfbndlist, ip) @@ -175,8 +175,8 @@ subroutine find_mwt_package(this) ! use the select type to point to the budobj in flow package this%flowpackagebnd => packobj select type (packobj) - type is (MawType) - this%flowbudptr => packobj%budobj + type is (MawType) + this%flowbudptr => packobj%budobj end select end if if (found) exit @@ -186,54 +186,54 @@ subroutine find_mwt_package(this) ! ! -- error if flow package not found if (.not. found) then - write(errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& - &// trim(adjustl(this%flowpackagename)) // '.' + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! - ! -- allocate space for idxbudssm, which indicates whether this is a + ! -- allocate space for idxbudssm, which indicates whether this is a ! special budget term or one that is a general source and sink nbudterm = this%flowbudptr%nbudterm call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) ! ! -- Process budget terms and identify special budget terms - write(this%iout, '(/, a, a)') & - 'PROCESSING ' // ftype // ' INFORMATION FOR ', this%packName - write(this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN ' // flowtype // ' PACKAGE' - write(this%iout, '(a, i0)') & - ' NUMBER OF ' // flowtype // ' = ', this%flowbudptr%ncv + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv icount = 1 do ip = 1, this%flowbudptr%nbudterm - select case(trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) - case('FLOW-JA-FACE') + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') this%idxbudfjf = ip this%idxbudssm(ip) = 0 - case('GWF') + case ('GWF') this%idxbudgwf = ip this%idxbudssm(ip) = 0 - case('STORAGE') + case ('STORAGE') this%idxbudsto = ip this%idxbudssm(ip) = 0 - case('RATE') + case ('RATE') this%idxbudrate = ip this%idxbudssm(ip) = 0 - case('FW-RATE') + case ('FW-RATE') this%idxbudfwrt = ip this%idxbudssm(ip) = 0 - case('RATE-TO-MVR') + case ('RATE-TO-MVR') this%idxbudrtmv = ip this%idxbudssm(ip) = 0 - case('FW-RATE-TO-MVR') + case ('FW-RATE-TO-MVR') this%idxbudfrtm = ip this%idxbudssm(ip) = 0 - case('TO-MVR') + case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 - case('FROM-MVR') + case ('FROM-MVR') this%idxbudfmvr = ip this%idxbudssm(ip) = 0 - case('AUXILIARY') + case ('AUXILIARY') this%idxbudaux = ip this%idxbudssm(ip) = 0 case default @@ -243,11 +243,11 @@ subroutine find_mwt_package(this) this%idxbudssm(ip) = icount icount = icount + 1 end select - write(this%iout, '(a, i0, " = ", a,/, a, i0)') & + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist end do - write(this%iout, '(a, //)') 'DONE PROCESSING ' // ftype // ' INFORMATION' + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! ! -- Return return @@ -328,7 +328,7 @@ end subroutine mwt_fc_expanded subroutine mwt_solve(this) ! ****************************************************************************** ! mwt_solve -- add terms specific to multi-aquifer wells to the explicit multi- -! aquifer well solve +! aquifer well solve ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -376,7 +376,7 @@ subroutine mwt_solve(this) ! -- Return return end subroutine mwt_solve - + function mwt_get_nbudterms(this) result(nbudterms) ! ****************************************************************************** ! mwt_get_nbudterms -- function to return the number of budget terms just for @@ -402,7 +402,7 @@ function mwt_get_nbudterms(this) result(nbudterms) ! -- Return return end function mwt_get_nbudterms - + subroutine mwt_setup_budobj(this, idx) ! ****************************************************************************** ! mwt_setup_budobj -- Set up the budget object that stores all the multi- @@ -421,7 +421,7 @@ subroutine mwt_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- text = ' RATE' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrate)%maxlist @@ -433,9 +433,9 @@ subroutine mwt_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - + ! - ! -- + ! -- if (this%idxbudfwrt /= 0) then text = ' FW-RATE' idx = idx + 1 @@ -449,9 +449,9 @@ subroutine mwt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! - ! -- + ! -- if (this%idxbudrtmv /= 0) then text = ' RATE-TO-MVR' idx = idx + 1 @@ -465,9 +465,9 @@ subroutine mwt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! - ! -- + ! -- if (this%idxbudfrtm /= 0) then text = ' FW-RATE-TO-MVR' idx = idx + 1 @@ -481,7 +481,7 @@ subroutine mwt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! ! -- return return @@ -507,7 +507,7 @@ subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! -- RATE idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrate)%nlist @@ -517,7 +517,7 @@ subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! -- FW-RATE if (this%idxbudfwrt /= 0) then idx = idx + 1 @@ -529,7 +529,7 @@ subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! -- RATE-TO-MVR if (this%idxbudrtmv /= 0) then idx = idx + 1 @@ -541,7 +541,7 @@ subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! -- FW-RATE-TO-MVR if (this%idxbudfrtm /= 0) then idx = idx + 1 @@ -553,7 +553,7 @@ subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- return return @@ -581,7 +581,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudfwrt, 'IDXBUDFWRT', this%memoryPath) call mem_allocate(this%idxbudrtmv, 'IDXBUDRTMV', this%memoryPath) call mem_allocate(this%idxbudfrtm, 'IDXBUDFRTM', this%memoryPath) - ! + ! ! -- Initialize this%idxbudrate = 0 this%idxbudfwrt = 0 @@ -606,7 +606,7 @@ subroutine mwt_allocate_arrays(this) ! -- local integer(I4B) :: n ! ------------------------------------------------------------------------------ - ! + ! ! -- time series call mem_allocate(this%concrate, this%ncv, 'CONCRATE', this%memoryPath) ! @@ -622,7 +622,7 @@ subroutine mwt_allocate_arrays(this) ! -- Return return end subroutine mwt_allocate_arrays - + subroutine mwt_da(this) ! ****************************************************************************** ! mwt_da @@ -694,7 +694,7 @@ subroutine mwt_rate_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine mwt_rate_term - + subroutine mwt_fwrt_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -726,7 +726,7 @@ subroutine mwt_fwrt_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine mwt_fwrt_term - + subroutine mwt_rtmv_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -758,7 +758,7 @@ subroutine mwt_rtmv_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine mwt_rtmv_term - + subroutine mwt_frtm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -790,7 +790,7 @@ subroutine mwt_frtm_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine mwt_frtm_term - + subroutine mwt_df_obs(this) ! ****************************************************************************** ! mwt_df_obs -- obs are supported? @@ -830,7 +830,7 @@ subroutine mwt_df_obs(this) ! return end subroutine mwt_df_obs - + subroutine mwt_bd_obs(this, obstypeid, jj, v, found) ! ****************************************************************************** ! mwt_bd_obs -- calculate observation value and pass it back to APT @@ -850,24 +850,24 @@ subroutine mwt_bd_obs(this, obstypeid, jj, v, found) ! found = .true. select case (obstypeid) - case ('RATE') - if (this%iboundpak(jj) /= 0) then - call this%mwt_rate_term(jj, n1, n2, v) - end if - case ('FW-RATE') - if (this%iboundpak(jj) /= 0 .and. this%idxbudfwrt > 0) then - call this%mwt_fwrt_term(jj, n1, n2, v) - end if - case ('RATE-TO-MVR') - if (this%iboundpak(jj) /= 0 .and. this%idxbudrtmv > 0) then - call this%mwt_rtmv_term(jj, n1, n2, v) - end if - case ('FW-RATE-TO-MVR') - if (this%iboundpak(jj) /= 0 .and. this%idxbudfrtm > 0) then - call this%mwt_frtm_term(jj, n1, n2, v) - end if - case default - found = .false. + case ('RATE') + if (this%iboundpak(jj) /= 0) then + call this%mwt_rate_term(jj, n1, n2, v) + end if + case ('FW-RATE') + if (this%iboundpak(jj) /= 0 .and. this%idxbudfwrt > 0) then + call this%mwt_fwrt_term(jj, n1, n2, v) + end if + case ('RATE-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudrtmv > 0) then + call this%mwt_rtmv_term(jj, n1, n2, v) + end if + case ('FW-RATE-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudfrtm > 0) then + call this%mwt_frtm_term(jj, n1, n2, v) + end if + case default + found = .false. end select ! return @@ -882,7 +882,7 @@ subroutine mwt_set_stressperiod(this, itemno, keyword, found) ! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtMwtType),intent(inout) :: this + class(GwtMwtType), intent(inout) :: this integer(I4B), intent(in) :: itemno character(len=*), intent(in) :: keyword logical, intent(inout) :: found @@ -898,28 +898,27 @@ subroutine mwt_set_stressperiod(this, itemno, keyword, found) ! found = .true. select case (keyword) - case ('RATE') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concrate(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RATE') - case default - ! - ! -- keyword not recognized so return to caller with found = .false. - found = .false. + case ('RATE') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concrate(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RATE') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. end select ! -999 continue +999 continue ! ! -- return return end subroutine mwt_set_stressperiod - -end module GwtMwtModule \ No newline at end of file +end module GwtMwtModule diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index bfc886db307..d1722b3e133 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -5,7 +5,7 @@ ! ! SFR flows (sfrbudptr) index var SFT term Transport Type !--------------------------------------------------------------------------------- - + ! -- terms from SFR that will be handled by parent APT Package ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf @@ -19,7 +19,7 @@ ! RUNOFF idxbudroff RUNOFF q * croff ! EXT-INFLOW idxbudiflw EXT-INFLOW q * ciflw ! EXT-OUTFLOW idxbudoutf EXT-OUTFLOW q * cfeat - + ! -- terms from a flow file that should be skipped ! CONSTANT none none none ! AUXILIARY none none none @@ -36,33 +36,33 @@ module GwtSftModule use ConstantsModule, only: DZERO, DONE, LINELENGTH use SimModule, only: store_error use BndModule, only: BndType, GetBndFromList - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use SfrModule, only: SfrType use GwtAptModule, only: GwtAptType - + implicit none - + public sft_create - + character(len=*), parameter :: ftype = 'SFT' character(len=*), parameter :: flowtype = 'SFR' - character(len=16) :: text = ' SFT' - + character(len=16) :: text = ' SFT' + type, extends(GwtAptType) :: GwtSftType - - integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr - integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr - integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr - integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr - integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr - real(DP), dimension(:), pointer, contiguous :: concrain => null() ! rainfall concentration - real(DP), dimension(:), pointer, contiguous :: concevap => null() ! evaporation concentration - real(DP), dimension(:), pointer, contiguous :: concroff => null() ! runoff concentration - real(DP), dimension(:), pointer, contiguous :: conciflw => null() ! inflow concentration + integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr + integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr + integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr + integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr + integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + + real(DP), dimension(:), pointer, contiguous :: concrain => null() ! rainfall concentration + real(DP), dimension(:), pointer, contiguous :: concevap => null() ! evaporation concentration + real(DP), dimension(:), pointer, contiguous :: concroff => null() ! runoff concentration + real(DP), dimension(:), pointer, contiguous :: conciflw => null() ! inflow concentration contains - + procedure :: bnd_da => sft_da procedure :: allocate_scalars procedure :: apt_allocate_arrays => sft_allocate_arrays @@ -80,11 +80,11 @@ module GwtSftModule procedure :: pak_df_obs => sft_df_obs procedure :: pak_bd_obs => sft_bd_obs procedure :: pak_set_stressperiod => sft_set_stressperiod - + end type GwtSftType - contains - +contains + subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi) ! ****************************************************************************** @@ -95,19 +95,19 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname - type(GwtFmiType), pointer :: fmi + type(TspFmiType), pointer :: fmi ! -- local type(GwtSftType), pointer :: lktobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(lktobj) + allocate (lktobj) packobj => lktobj ! ! -- create name and memory path @@ -126,7 +126,7 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ibcnum = ibcnum packobj%ncolbnd = 1 packobj%iscloc = 1 - + ! -- Store pointer to flow model interface. When the GwfGwt exchange is ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages @@ -168,7 +168,7 @@ subroutine find_sft_package(this) ! else if (associated(this%fmi%gwfbndlist)) then - ! -- Look through gwfbndlist for a flow package with the same name as + ! -- Look through gwfbndlist for a flow package with the same name as ! this transport package name do ip = 1, this%fmi%gwfbndlist%Count() packobj => GetBndFromList(this%fmi%gwfbndlist, ip) @@ -179,8 +179,8 @@ subroutine find_sft_package(this) ! use the select type to point to the budobj in flow package this%flowpackagebnd => packobj select type (packobj) - type is (SfrType) - this%flowbudptr => packobj%budobj + type is (SfrType) + this%flowbudptr => packobj%budobj end select end if if (found) exit @@ -190,57 +190,57 @@ subroutine find_sft_package(this) ! ! -- error if flow package not found if (.not. found) then - write(errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& - &// trim(adjustl(this%flowpackagename)) // '.' + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! - ! -- allocate space for idxbudssm, which indicates whether this is a + ! -- allocate space for idxbudssm, which indicates whether this is a ! special budget term or one that is a general source and sink nbudterm = this%flowbudptr%nbudterm call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) ! ! -- Process budget terms and identify special budget terms - write(this%iout, '(/, a, a)') & - 'PROCESSING ' // ftype // ' INFORMATION FOR ', this%packName - write(this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN ' // flowtype // ' PACKAGE' - write(this%iout, '(a, i0)') & - ' NUMBER OF ' // flowtype // ' = ', this%flowbudptr%ncv + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv icount = 1 do ip = 1, this%flowbudptr%nbudterm - select case(trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) - case('FLOW-JA-FACE') + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') this%idxbudfjf = ip this%idxbudssm(ip) = 0 - case('GWF') + case ('GWF') this%idxbudgwf = ip this%idxbudssm(ip) = 0 - case('STORAGE') + case ('STORAGE') this%idxbudsto = ip this%idxbudssm(ip) = 0 - case('RAINFALL') + case ('RAINFALL') this%idxbudrain = ip this%idxbudssm(ip) = 0 - case('EVAPORATION') + case ('EVAPORATION') this%idxbudevap = ip this%idxbudssm(ip) = 0 - case('RUNOFF') + case ('RUNOFF') this%idxbudroff = ip this%idxbudssm(ip) = 0 - case('EXT-INFLOW') + case ('EXT-INFLOW') this%idxbudiflw = ip this%idxbudssm(ip) = 0 - case('EXT-OUTFLOW') + case ('EXT-OUTFLOW') this%idxbudoutf = ip this%idxbudssm(ip) = 0 - case('TO-MVR') + case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 - case('FROM-MVR') + case ('FROM-MVR') this%idxbudfmvr = ip this%idxbudssm(ip) = 0 - case('AUXILIARY') + case ('AUXILIARY') this%idxbudaux = ip this%idxbudssm(ip) = 0 case default @@ -250,15 +250,15 @@ subroutine find_sft_package(this) this%idxbudssm(ip) = icount icount = icount + 1 end select - write(this%iout, '(a, i0, " = ", a,/, a, i0)') & + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist end do - write(this%iout, '(a, //)') 'DONE PROCESSING ' // ftype // ' INFORMATION' + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! ! -- Return return -end subroutine find_sft_package + end subroutine find_sft_package subroutine sft_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** @@ -401,7 +401,7 @@ subroutine sft_solve(this) ! -- Return return end subroutine sft_solve - + function sft_get_nbudterms(this) result(nbudterms) ! ****************************************************************************** ! sft_get_nbudterms -- function to return the number of budget terms just for @@ -424,7 +424,7 @@ function sft_get_nbudterms(this) result(nbudterms) ! -- Return return end function sft_get_nbudterms - + subroutine sft_setup_budobj(this, idx) ! ****************************************************************************** ! sft_setup_budobj -- Set up the budget object that stores all the sfr flows @@ -442,7 +442,7 @@ subroutine sft_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- text = ' RAINFALL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist @@ -455,7 +455,7 @@ subroutine sft_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EVAPORATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist @@ -468,7 +468,7 @@ subroutine sft_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' RUNOFF' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist @@ -481,7 +481,7 @@ subroutine sft_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EXT-INFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist @@ -494,7 +494,7 @@ subroutine sft_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- text = ' EXT-OUTFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist @@ -531,7 +531,7 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! -- RAIN idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist @@ -541,8 +541,7 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- EVAPORATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist @@ -552,8 +551,7 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- RUNOFF idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist @@ -563,8 +561,7 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- EXT-INFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist @@ -574,8 +571,7 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - - + ! -- EXT-OUTFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist @@ -585,7 +581,6 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! ! -- return @@ -615,7 +610,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath) call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) - ! + ! ! -- Initialize this%idxbudrain = 0 this%idxbudevap = 0 @@ -641,7 +636,7 @@ subroutine sft_allocate_arrays(this) ! -- local integer(I4B) :: n ! ------------------------------------------------------------------------------ - ! + ! ! -- time series call mem_allocate(this%concrain, this%ncv, 'CONCRAIN', this%memoryPath) call mem_allocate(this%concevap, this%ncv, 'CONCEVAP', this%memoryPath) @@ -663,7 +658,7 @@ subroutine sft_allocate_arrays(this) ! -- Return return end subroutine sft_allocate_arrays - + subroutine sft_da(this) ! ****************************************************************************** ! sft_da @@ -729,7 +724,7 @@ subroutine sft_rain_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine sft_rain_term - + subroutine sft_evap_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -764,13 +759,13 @@ subroutine sft_evap_term(this, ientry, n1, n2, rrate, & if (present(rrate)) & rrate = omega * qbnd * this%xnewpak(n1) + & (DONE - omega) * qbnd * ctmp - if (present(rhsval)) rhsval = - (DONE - omega) * qbnd * ctmp + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! ! -- return return end subroutine sft_evap_term - + subroutine sft_roff_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -802,7 +797,7 @@ subroutine sft_roff_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine sft_roff_term - + subroutine sft_iflw_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -834,7 +829,7 @@ subroutine sft_iflw_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine sft_iflw_term - + subroutine sft_outf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -866,7 +861,7 @@ subroutine sft_outf_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine sft_outf_term - + subroutine sft_df_obs(this) ! ****************************************************************************** ! sft_df_obs -- obs are supported? @@ -911,7 +906,7 @@ subroutine sft_df_obs(this) ! return end subroutine sft_df_obs - + subroutine sft_bd_obs(this, obstypeid, jj, v, found) ! ****************************************************************************** ! sft_bd_obs -- calculate observation value and pass it back to APT @@ -931,28 +926,28 @@ subroutine sft_bd_obs(this, obstypeid, jj, v, found) ! found = .true. select case (obstypeid) - case ('RAINFALL') - if (this%iboundpak(jj) /= 0) then - call this%sft_rain_term(jj, n1, n2, v) - end if - case ('EVAPORATION') - if (this%iboundpak(jj) /= 0) then - call this%sft_evap_term(jj, n1, n2, v) - end if - case ('RUNOFF') - if (this%iboundpak(jj) /= 0) then - call this%sft_roff_term(jj, n1, n2, v) - end if - case ('EXT-INFLOW') - if (this%iboundpak(jj) /= 0) then - call this%sft_iflw_term(jj, n1, n2, v) - end if - case ('EXT-OUTFLOW') - if (this%iboundpak(jj) /= 0) then - call this%sft_outf_term(jj, n1, n2, v) - end if - case default - found = .false. + case ('RAINFALL') + if (this%iboundpak(jj) /= 0) then + call this%sft_rain_term(jj, n1, n2, v) + end if + case ('EVAPORATION') + if (this%iboundpak(jj) /= 0) then + call this%sft_evap_term(jj, n1, n2, v) + end if + case ('RUNOFF') + if (this%iboundpak(jj) /= 0) then + call this%sft_roff_term(jj, n1, n2, v) + end if + case ('EXT-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%sft_iflw_term(jj, n1, n2, v) + end if + case ('EXT-OUTFLOW') + if (this%iboundpak(jj) /= 0) then + call this%sft_outf_term(jj, n1, n2, v) + end if + case default + found = .false. end select ! return @@ -967,7 +962,7 @@ subroutine sft_set_stressperiod(this, itemno, keyword, found) ! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtSftType),intent(inout) :: this + class(GwtSftType), intent(inout) :: this integer(I4B), intent(in) :: itemno character(len=*), intent(in) :: keyword logical, intent(inout) :: found @@ -987,61 +982,60 @@ subroutine sft_set_stressperiod(this, itemno, keyword, found) ! found = .true. select case (keyword) - case ('RAINFALL') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concrain(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RAINFALL') - case ('EVAPORATION') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concevap(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'EVAPORATION') - case ('RUNOFF') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concroff(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'RUNOFF') - case ('INFLOW') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%conciflw(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'INFLOW') - case default - ! - ! -- keyword not recognized so return to caller with found = .false. - found = .false. + case ('RAINFALL') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concrain(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RAINFALL') + case ('EVAPORATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concevap(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EVAPORATION') + case ('RUNOFF') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concroff(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RUNOFF') + case ('INFLOW') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%conciflw(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'INFLOW') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. end select ! -999 continue +999 continue ! ! -- return return end subroutine sft_set_stressperiod - end module GwtSftModule diff --git a/src/Model/GroundWaterTransport/gwt1src1.f90 b/src/Model/GroundWaterTransport/gwt1src1.f90 index 605bcb10fc6..137a931dd15 100644 --- a/src/Model/GroundWaterTransport/gwt1src1.f90 +++ b/src/Model/GroundWaterTransport/gwt1src1.f90 @@ -14,7 +14,7 @@ module GwtSrcModule public :: src_create ! character(len=LENFTYPE) :: ftype = 'SRC' - character(len=16) :: text = ' SRC' + character(len=16) :: text = ' SRC' ! type, extends(BndType) :: GwtSrcType contains @@ -43,10 +43,10 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local @@ -54,7 +54,7 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(srcobj) + allocate (srcobj) packobj => srcobj ! ! -- create name and memory path @@ -142,26 +142,26 @@ subroutine src_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! ! -- Return if no sources - if(this%nbound == 0) return + if (this%nbound == 0) return ! ! -- pakmvrobj cf lrm = .true. if (present(reset_mover)) lrm = reset_mover - if(this%imover == 1 .and. lrm) then + if (this%imover == 1 .and. lrm) then call this%pakmvrobj%cf() - endif + end if ! ! -- Calculate hcof and rhs for each source entry do i = 1, this%nbound node = this%nodelist(i) this%hcof(i) = DZERO - if(this%ibound(node) <= 0) then + if (this%ibound(node) <= 0) then this%rhs(i) = DZERO cycle end if - q = this%bound(1,i) + q = this%bound(1, i) this%rhs(i) = -q - enddo + end do ! return end subroutine src_cf @@ -184,9 +184,9 @@ subroutine src_fc(this, rhs, ia, idxglo, amatsln) ! -------------------------------------------------------------------------- ! ! -- pakmvrobj fc - if(this%imover == 1) then + if (this%imover == 1) then call this%pakmvrobj%fc() - endif + end if ! ! -- Copy package rhs and hcof into solution rhs and amat do i = 1, this%nbound @@ -197,10 +197,10 @@ subroutine src_fc(this, rhs, ia, idxglo, amatsln) ! ! -- If mover is active and mass is being withdrawn, ! store available mass (as positive value). - if(this%imover == 1 .and. this%rhs(i) > DZERO) then + if (this%imover == 1 .and. this%rhs(i) > DZERO) then call this%pakmvrobj%accumulate_qformvr(i, this%rhs(i)) - endif - enddo + end if + end do ! ! -- return return @@ -218,21 +218,21 @@ subroutine define_listlabel(this) ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -240,36 +240,36 @@ end subroutine define_listlabel ! -- Procedures related to observations logical function src_obs_supported(this) - ! ****************************************************************************** - ! src_obs_supported - ! -- Return true because SRC package supports observations. - ! -- Overrides BndType%bnd_obs_supported() - ! ****************************************************************************** - ! - ! SPECIFICATIONS: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! src_obs_supported + ! -- Return true because SRC package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ implicit none class(GwtSrcType) :: this - ! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ src_obs_supported = .true. return end function src_obs_supported 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: - ! ------------------------------------------------------------------------------ + ! ****************************************************************************** + ! 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 ! @@ -296,14 +296,14 @@ subroutine src_rp_ts(this) type(TimeSeriesLinkType), pointer :: tslink => null() ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then - if (tslink%JCol==1) then + if (tslink%JCol == 1) then tslink%Text = 'SMASSRATE' - endif - endif - enddo + end if + end if + end do ! return end subroutine src_rp_ts diff --git a/src/Model/GroundWaterTransport/gwt1uzt1.f90 b/src/Model/GroundWaterTransport/gwt1uzt1.f90 index a5206a87bbd..b14d53b57e7 100644 --- a/src/Model/GroundWaterTransport/gwt1uzt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1uzt1.f90 @@ -13,7 +13,7 @@ ! STORAGE (aux VOLUME) idxbudsto none used for water volumes ! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) ! AUXILIARY none none none -! none none STORAGE (aux MASS) +! none none STORAGE (aux MASS) ! none none AUXILIARY none ! -- terms from UZF that need to be handled here @@ -23,37 +23,36 @@ ! REJ-INF-TO-MVR idxbudritm REJ-INF-TO-MVR q * cinfil? ! -- terms from UZF that should be skipped - - + module GwtUztModule use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, DONE, LINELENGTH use SimModule, only: store_error use BndModule, only: BndType, GetBndFromList - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use UzfModule, only: UzfType use GwtAptModule, only: GwtAptType - + implicit none - + public uzt_create - + character(len=*), parameter :: ftype = 'UZT' character(len=*), parameter :: flowtype = 'UZF' - character(len=16) :: text = ' UZT' - + character(len=16) :: text = ' UZT' + type, extends(GwtAptType) :: GwtUztType - - integer(I4B), pointer :: idxbudinfl => null() ! index of uzf infiltration terms in flowbudptr - integer(I4B), pointer :: idxbudrinf => null() ! index of rejected infiltration terms in flowbudptr - integer(I4B), pointer :: idxbuduzet => null() ! index of unsat et terms in flowbudptr - integer(I4B), pointer :: idxbudritm => null() ! index of rej infil to mover rate to mover terms in flowbudptr - real(DP), dimension(:), pointer, contiguous :: concinfl => null() ! infiltration concentration - real(DP), dimension(:), pointer, contiguous :: concuzet => null() ! unsat et concentration + + integer(I4B), pointer :: idxbudinfl => null() ! index of uzf infiltration terms in flowbudptr + integer(I4B), pointer :: idxbudrinf => null() ! index of rejected infiltration terms in flowbudptr + integer(I4B), pointer :: idxbuduzet => null() ! index of unsat et terms in flowbudptr + integer(I4B), pointer :: idxbudritm => null() ! index of rej infil to mover rate to mover terms in flowbudptr + real(DP), dimension(:), pointer, contiguous :: concinfl => null() ! infiltration concentration + real(DP), dimension(:), pointer, contiguous :: concuzet => null() ! unsat et concentration contains - + procedure :: bnd_da => uzt_da procedure :: allocate_scalars procedure :: apt_allocate_arrays => uzt_allocate_arrays @@ -70,11 +69,11 @@ module GwtUztModule procedure :: pak_df_obs => uzt_df_obs procedure :: pak_bd_obs => uzt_bd_obs procedure :: pak_set_stressperiod => uzt_set_stressperiod - + end type GwtUztType - contains - +contains + subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi) ! ****************************************************************************** @@ -85,19 +84,19 @@ subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname - type(GwtFmiType), pointer :: fmi + type(TspFmiType), pointer :: fmi ! -- local type(GwtUztType), pointer :: uztobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(uztobj) + allocate (uztobj) packobj => uztobj ! ! -- create name and memory path @@ -116,7 +115,7 @@ subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ibcnum = ibcnum packobj%ncolbnd = 1 packobj%iscloc = 1 - + ! -- Store pointer to flow model interface. When the GwfGwt exchange is ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages @@ -158,7 +157,7 @@ subroutine find_uzt_package(this) ! else if (associated(this%fmi%gwfbndlist)) then - ! -- Look through gwfbndlist for a flow package with the same name as + ! -- Look through gwfbndlist for a flow package with the same name as ! this transport package name do ip = 1, this%fmi%gwfbndlist%Count() packobj => GetBndFromList(this%fmi%gwfbndlist, ip) @@ -169,8 +168,8 @@ subroutine find_uzt_package(this) ! use the select type to point to the budobj in flow package this%flowpackagebnd => packobj select type (packobj) - type is (UzfType) - this%flowbudptr => packobj%budobj + type is (UzfType) + this%flowbudptr => packobj%budobj end select end if if (found) exit @@ -180,54 +179,54 @@ subroutine find_uzt_package(this) ! ! -- error if flow package not found if (.not. found) then - write(errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& - &// trim(adjustl(this%flowpackagename)) // '.' + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! - ! -- allocate space for idxbudssm, which indicates whether this is a + ! -- allocate space for idxbudssm, which indicates whether this is a ! special budget term or one that is a general source and sink nbudterm = this%flowbudptr%nbudterm call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) ! ! -- Process budget terms and identify special budget terms - write(this%iout, '(/, a, a)') & - 'PROCESSING ' // ftype // ' INFORMATION FOR ', this%packName - write(this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN ' // flowtype // ' PACKAGE' - write(this%iout, '(a, i0)') & - ' NUMBER OF ' // flowtype // ' = ', this%flowbudptr%ncv + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv icount = 1 do ip = 1, this%flowbudptr%nbudterm - select case(trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) - case('FLOW-JA-FACE') + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') this%idxbudfjf = ip this%idxbudssm(ip) = 0 - case('GWF') + case ('GWF') this%idxbudgwf = ip this%idxbudssm(ip) = 0 - case('STORAGE') + case ('STORAGE') this%idxbudsto = ip this%idxbudssm(ip) = 0 - case('INFILTRATION') + case ('INFILTRATION') this%idxbudinfl = ip this%idxbudssm(ip) = 0 - case('REJ-INF') + case ('REJ-INF') this%idxbudrinf = ip this%idxbudssm(ip) = 0 - case('UZET') + case ('UZET') this%idxbuduzet = ip this%idxbudssm(ip) = 0 - case('REJ-INF-TO-MVR') + case ('REJ-INF-TO-MVR') this%idxbudritm = ip this%idxbudssm(ip) = 0 - case('TO-MVR') + case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 - case('FROM-MVR') + case ('FROM-MVR') this%idxbudfmvr = ip this%idxbudssm(ip) = 0 - case('AUXILIARY') + case ('AUXILIARY') this%idxbudaux = ip this%idxbudssm(ip) = 0 case default @@ -237,11 +236,11 @@ subroutine find_uzt_package(this) this%idxbudssm(ip) = icount icount = icount + 1 end select - write(this%iout, '(a, i0, " = ", a,/, a, i0)') & + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist end do - write(this%iout, '(a, //)') 'DONE PROCESSING ' // ftype // ' INFORMATION' + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! ! -- Return return @@ -321,7 +320,7 @@ end subroutine uzt_fc_expanded subroutine uzt_solve(this) ! ****************************************************************************** -! uzt_solve -- add terms specific to the unsaturated zone to the explicit +! uzt_solve -- add terms specific to the unsaturated zone to the explicit ! unsaturated-zone solve ! ****************************************************************************** ! @@ -370,7 +369,7 @@ subroutine uzt_solve(this) ! -- Return return end subroutine uzt_solve - + function uzt_get_nbudterms(this) result(nbudterms) ! ****************************************************************************** ! uzt_get_nbudterms -- function to return the number of budget terms just for @@ -397,7 +396,7 @@ function uzt_get_nbudterms(this) result(nbudterms) ! -- Return return end function uzt_get_nbudterms - + subroutine uzt_setup_budobj(this, idx) ! ****************************************************************************** ! uzt_setup_budobj -- Set up the budget object that stores all the unsaturated- @@ -416,7 +415,7 @@ subroutine uzt_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- text = ' INFILTRATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudinfl)%maxlist @@ -428,9 +427,9 @@ subroutine uzt_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - + ! - ! -- + ! -- if (this%idxbudrinf /= 0) then text = ' REJ-INF' idx = idx + 1 @@ -444,9 +443,9 @@ subroutine uzt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! - ! -- + ! -- if (this%idxbuduzet /= 0) then text = ' UZET' idx = idx + 1 @@ -460,9 +459,9 @@ subroutine uzt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! - ! -- + ! -- if (this%idxbudritm /= 0) then text = ' INF-REJ-TO-MVR' idx = idx + 1 @@ -476,7 +475,7 @@ subroutine uzt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! ! -- return return @@ -502,7 +501,7 @@ subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! -- INFILTRATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist @@ -512,7 +511,7 @@ subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! -- REJ-INF if (this%idxbudrinf /= 0) then idx = idx + 1 @@ -524,7 +523,7 @@ subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! -- UZET if (this%idxbuduzet /= 0) then idx = idx + 1 @@ -536,7 +535,7 @@ subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! -- REJ-INF-TO-MVR if (this%idxbudritm /= 0) then idx = idx + 1 @@ -548,7 +547,7 @@ subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- return return @@ -576,7 +575,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudrinf, 'IDXBUDRINF', this%memoryPath) call mem_allocate(this%idxbuduzet, 'IDXBUDUZET', this%memoryPath) call mem_allocate(this%idxbudritm, 'IDXBUDRITM', this%memoryPath) - ! + ! ! -- Initialize this%idxbudinfl = 0 this%idxbudrinf = 0 @@ -601,7 +600,7 @@ subroutine uzt_allocate_arrays(this) ! -- local integer(I4B) :: n ! ------------------------------------------------------------------------------ - ! + ! ! -- time series call mem_allocate(this%concinfl, this%ncv, 'CONCINFL', this%memoryPath) call mem_allocate(this%concuzet, this%ncv, 'CONCUZET', this%memoryPath) @@ -619,7 +618,7 @@ subroutine uzt_allocate_arrays(this) ! -- Return return end subroutine uzt_allocate_arrays - + subroutine uzt_da(this) ! ****************************************************************************** ! uzt_da @@ -692,7 +691,7 @@ subroutine uzt_infl_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine uzt_infl_term - + subroutine uzt_rinf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -724,7 +723,7 @@ subroutine uzt_rinf_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine uzt_rinf_term - + subroutine uzt_uzet_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -759,13 +758,13 @@ subroutine uzt_uzet_term(this, ientry, n1, n2, rrate, & if (present(rrate)) & rrate = omega * qbnd * this%xnewpak(n1) + & (DONE - omega) * qbnd * ctmp - if (present(rhsval)) rhsval = - (DONE - omega) * qbnd * ctmp + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! ! -- return return end subroutine uzt_uzet_term - + subroutine uzt_ritm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! ****************************************************************************** @@ -797,7 +796,7 @@ subroutine uzt_ritm_term(this, ientry, n1, n2, rrate, & ! -- return return end subroutine uzt_ritm_term - + subroutine uzt_df_obs(this) ! ****************************************************************************** ! uzt_df_obs -- obs are supported? @@ -837,7 +836,7 @@ subroutine uzt_df_obs(this) ! return end subroutine uzt_df_obs - + subroutine uzt_bd_obs(this, obstypeid, jj, v, found) ! ****************************************************************************** ! uzt_bd_obs -- calculate observation value and pass it back to APT @@ -857,24 +856,24 @@ subroutine uzt_bd_obs(this, obstypeid, jj, v, found) ! found = .true. select case (obstypeid) - case ('INFILTRATION') - if (this%iboundpak(jj) /= 0 .and. this%idxbudinfl > 0) then - call this%uzt_infl_term(jj, n1, n2, v) - end if - case ('REJ-INF') - if (this%iboundpak(jj) /= 0 .and. this%idxbudrinf > 0) then - call this%uzt_rinf_term(jj, n1, n2, v) - end if - case ('UZET') - if (this%iboundpak(jj) /= 0 .and. this%idxbuduzet > 0) then - call this%uzt_uzet_term(jj, n1, n2, v) - end if - case ('REJ-INF-TO-MVR') - if (this%iboundpak(jj) /= 0 .and. this%idxbudritm > 0) then - call this%uzt_ritm_term(jj, n1, n2, v) - end if - case default - found = .false. + case ('INFILTRATION') + if (this%iboundpak(jj) /= 0 .and. this%idxbudinfl > 0) then + call this%uzt_infl_term(jj, n1, n2, v) + end if + case ('REJ-INF') + if (this%iboundpak(jj) /= 0 .and. this%idxbudrinf > 0) then + call this%uzt_rinf_term(jj, n1, n2, v) + end if + case ('UZET') + if (this%iboundpak(jj) /= 0 .and. this%idxbuduzet > 0) then + call this%uzt_uzet_term(jj, n1, n2, v) + end if + case ('REJ-INF-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudritm > 0) then + call this%uzt_ritm_term(jj, n1, n2, v) + end if + case default + found = .false. end select ! return @@ -889,7 +888,7 @@ subroutine uzt_set_stressperiod(this, itemno, keyword, found) ! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtUztType),intent(inout) :: this + class(GwtUztType), intent(inout) :: this integer(I4B), intent(in) :: itemno character(len=*), intent(in) :: keyword logical, intent(inout) :: found @@ -906,39 +905,38 @@ subroutine uzt_set_stressperiod(this, itemno, keyword, found) ! found = .true. select case (keyword) - case ('INFILTRATION') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concinfl(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'INFILTRATION') - case ('UZET') - ierr = this%apt_check_valid(itemno) - if (ierr /= 0) then - goto 999 - end if - call this%parser%GetString(text) - jj = 1 - bndElem => this%concuzet(itemno) - call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'UZET') - case default - ! - ! -- keyword not recognized so return to caller with found = .false. - found = .false. + case ('INFILTRATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concinfl(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'INFILTRATION') + case ('UZET') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%concuzet(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'UZET') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. end select ! -999 continue +999 continue ! ! -- return return end subroutine uzt_set_stressperiod - end module GwtUztModule diff --git a/src/Model/GroundWaterTransport/gwt1adv1.f90 b/src/Model/GroundWaterTransport/tsp1adv1.f90 similarity index 78% rename from src/Model/GroundWaterTransport/gwt1adv1.f90 rename to src/Model/GroundWaterTransport/tsp1adv1.f90 index 9ade154fac6..edebad0f5c5 100644 --- a/src/Model/GroundWaterTransport/gwt1adv1.f90 +++ b/src/Model/GroundWaterTransport/tsp1adv1.f90 @@ -1,41 +1,41 @@ -module GwtAdvModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DONE, DZERO, DHALF, DTWO +module TspAdvModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, DHALF, DTWO use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType - use GwtAdvOptionsModule, only: GwtAdvOptionsType + use BaseDisModule, only: DisBaseType + use TspFmiModule, only: TspFmiType + use TspAdvOptionsModule, only: TspAdvOptionsType implicit none private - public :: GwtAdvType + public :: TspAdvType public :: adv_cr - type, extends(NumericalPackageType) :: GwtAdvType - - integer(I4B), pointer :: iadvwt => null() !< advection scheme (0 up, 1 central, 2 tvd) - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object - + type, extends(NumericalPackageType) :: TspAdvType + + integer(I4B), pointer :: iadvwt => null() !< advection scheme (0 up, 1 central, 2 tvd) + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + contains - + procedure :: adv_df procedure :: adv_ar procedure :: adv_fc procedure :: adv_cq procedure :: adv_da - + procedure :: allocate_scalars procedure, private :: read_options procedure, private :: advqtvd procedure, private :: advtvd_bd procedure :: adv_weight procedure :: advtvd - - end type GwtAdvType - - contains + + end type TspAdvType + +contains subroutine adv_cr(advobj, name_model, inunit, iout, fmi) ! ****************************************************************************** @@ -45,15 +45,15 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtAdvType), pointer :: advobj + type(TspAdvType), pointer :: advobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout - type(GwtFmiType), intent(in), target :: fmi + type(TspFmiType), intent(in), target :: fmi ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(advobj) + allocate (advobj) ! ! -- create name and memory path call advobj%set_names(1, name_model, 'ADV', 'ADV') @@ -71,22 +71,22 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi) end subroutine adv_cr subroutine adv_df(this, adv_options) - class(GwtAdvType) :: this - type(GwtAdvOptionsType), optional, intent(in) :: adv_options !< the optional options, for when not constructing from file + class(TspAdvType) :: this + type(TspAdvOptionsType), optional, intent(in) :: adv_options !< the optional options, for when not constructing from file ! local - character(len=*), parameter :: fmtadv = & - "(1x,/1x,'ADV-- ADVECTION PACKAGE, VERSION 1, 8/25/2017', & + character(len=*), parameter :: fmtadv = & + "(1x,/1x,'ADV-- ADVECTION PACKAGE, VERSION 1, 8/25/2017', & &' INPUT READ FROM UNIT ', i0, //)" ! ! -- Read or set advection options - if (.not. present(adv_options)) then + if (.not. present(adv_options)) then ! ! -- Initialize block parser (adv has no define, so it's ! not done until here) call this%parser%Initialize(this%inunit, this%iout) ! ! --print a message identifying the advection package. - write(this%iout, fmtadv) this%inunit + write (this%iout, fmtadv) this%inunit ! ! --read options from file call this%read_options() @@ -107,19 +107,19 @@ subroutine adv_ar(this, dis, ibound) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this class(DisBaseType), pointer, intent(in) :: dis integer(I4B), dimension(:), pointer, contiguous :: ibound ! -- local ! -- formats -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! ! -- adv pointers to arguments that were passed in - this%dis => dis - this%ibound => ibound + this%dis => dis + this%ibound => ibound ! ! -- Allocate arrays (not needed for adv) - !call this%allocate_arrays(dis%nodes) + !call this%allocate_arrays(dis%nodes) ! ! -- Return return @@ -134,7 +134,7 @@ subroutine adv_fc(this, nodes, amatsln, idxglo, cnew, rhs) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this integer, intent(in) :: nodes real(DP), dimension(:), intent(inout) :: amatsln integer(I4B), intent(in), dimension(:) :: idxglo @@ -145,7 +145,7 @@ subroutine adv_fc(this, nodes, amatsln, idxglo, cnew, rhs) real(DP) :: omega, qnm ! ------------------------------------------------------------------------------ ! - ! -- Calculate advection terms and add to solution rhs and hcof. qnm + ! -- Calculate advection terms and add to solution rhs and hcof. qnm ! is the volumetric flow rate and has dimensions of L^/T. do n = 1, nodes if (this%ibound(n) == 0) cycle @@ -158,21 +158,21 @@ subroutine adv_fc(this, nodes, amatsln, idxglo, cnew, rhs) omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + qnm * (DONE - omega) amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + qnm * omega - enddo - enddo + end do + end do ! ! -- TVD if (this%iadvwt == 2) then do n = 1, nodes - if(this%ibound(n) == 0) cycle + if (this%ibound(n) == 0) cycle call this%advtvd(n, cnew, rhs) - enddo - endif + end do + end if ! ! -- Return return end subroutine adv_fc - + subroutine advtvd(this, n, cnew, rhs) ! ****************************************************************************** ! advtvd -- Calculate TVD @@ -181,8 +181,8 @@ subroutine advtvd(this, n, cnew, rhs) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - ! -- dummy - class(GwtAdvType) :: this + ! -- dummy + class(TspAdvType) :: this integer(I4B), intent(in) :: n real(DP), dimension(:), intent(in) :: cnew real(DP), dimension(:), intent(inout) :: rhs @@ -199,8 +199,8 @@ subroutine advtvd(this, n, cnew, rhs) qtvd = this%advqtvd(n, m, ipos, cnew) rhs(n) = rhs(n) - qtvd rhs(m) = rhs(m) + qtvd - endif - enddo + end if + end do ! ! -- Return return @@ -217,8 +217,8 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) use ConstantsModule, only: DPREC ! -- return real(DP) :: qtvd - ! -- dummy - class(GwtAdvType) :: this + ! -- dummy + class(TspAdvType) :: this integer(I4B), intent(in) :: n integer(I4B), intent(in) :: m integer(I4B), intent(in) :: iposnm @@ -242,7 +242,7 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) else iup = n idn = m - endif + end if elupdn = this%dis%con%cl1(isympos) + this%dis%con%cl2(isympos) ! ! -- Find second node upstream to iup @@ -257,22 +257,22 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) qmax = qupj i2up = j elup2up = this%dis%con%cl1(isympos) + this%dis%con%cl2(isympos) - endif - enddo + end if + end do ! ! -- Calculate flux limiting term if (i2up > 0) then smooth = DZERO cdiff = ABS(cnew(idn) - cnew(iup)) if (cdiff > DPREC) then - smooth = (cnew(iup) - cnew(i2up)) / elup2up * & + smooth = (cnew(iup) - cnew(i2up)) / elup2up * & elupdn / (cnew(idn) - cnew(iup)) - endif + end if if (smooth > DZERO) then alimiter = DTWO * smooth / (DONE + smooth) qtvd = DHALF * alimiter * qnm * (cnew(idn) - cnew(iup)) - endif - endif + end if + end if ! ! -- Return return @@ -287,7 +287,7 @@ subroutine adv_cq(this, cnew, flowja) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this real(DP), intent(in), dimension(:) :: cnew real(DP), intent(inout), dimension(:) :: flowja ! -- local @@ -307,10 +307,10 @@ subroutine adv_cq(this, cnew, flowja) if (this%ibound(m) == 0) cycle qnm = this%fmi%gwfflowja(ipos) omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) - flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & - qnm * (DONE - omega) * cnew(m) - enddo - enddo + flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & + qnm * (DONE - omega) * cnew(m) + end do + end do ! ! -- TVD if (this%iadvwt == 2) call this%advtvd_bd(cnew, flowja) @@ -318,7 +318,7 @@ subroutine adv_cq(this, cnew, flowja) ! -- Return return end subroutine adv_cq - + subroutine advtvd_bd(this, cnew, flowja) ! ****************************************************************************** ! advtvd_bd -- Add TVD contribution to flowja @@ -327,8 +327,8 @@ subroutine advtvd_bd(this, cnew, flowja) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - ! -- dummy - class(GwtAdvType) :: this + ! -- dummy + class(TspAdvType) :: this real(DP), dimension(:), intent(in) :: cnew real(DP), dimension(:), intent(inout) :: flowja ! -- local @@ -345,9 +345,9 @@ subroutine advtvd_bd(this, cnew, flowja) qnm = this%fmi%gwfflowja(ipos) qtvd = this%advqtvd(n, m, ipos, cnew) flowja(ipos) = flowja(ipos) + qtvd - endif - enddo - enddo + end if + end do + end do ! ! -- Return return @@ -363,12 +363,12 @@ subroutine adv_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this ! ------------------------------------------------------------------------------ ! ! -- Deallocate arrays if package was active - if(this%inunit > 0) then - endif + if (this%inunit > 0) then + end if ! ! -- nullify pointers this%ibound => null() @@ -393,7 +393,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -421,17 +421,17 @@ subroutine read_options(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this ! -- local character(len=LINELENGTH) :: errmsg, keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtiadvwt = & - "(4x,'ADVECTION WEIGHTING SCHEME HAS BEEN SET TO: ', a)" + character(len=*), parameter :: fmtiadvwt = & + &"(4x,'ADVECTION WEIGHTING SCHEME HAS BEEN SET TO: ', a)" ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -440,46 +440,46 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING ADVECTION OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING ADVECTION OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('SCHEME') - call this%parser%GetStringCaps(keyword) - select case (keyword) - case('UPSTREAM') - this%iadvwt = 0 - this%iasym = 1 - write(this%iout, fmtiadvwt) 'UPSTREAM' - case ('CENTRAL') - this%iadvwt = 1 - write(this%iout, fmtiadvwt) 'CENTRAL' - case('TVD') - this%iadvwt = 2 - write(this%iout, fmtiadvwt) 'TVD' - case default - write(errmsg,'(4x, a, a)') & - 'ERROR. UNKNOWN SCHEME: ', trim(keyword) - call store_error(errmsg) - write(errmsg,'(4x, a, a)') & - 'SCHEME MUST BE "UPSTREAM", "CENTRAL" OR "TVD"' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select + case ('SCHEME') + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('UPSTREAM') + this%iadvwt = 0 + this%iasym = 1 + write (this%iout, fmtiadvwt) 'UPSTREAM' + case ('CENTRAL') + this%iadvwt = 1 + write (this%iout, fmtiadvwt) 'CENTRAL' + case ('TVD') + this%iadvwt = 2 + write (this%iout, fmtiadvwt) 'TVD' case default - write(errmsg,'(4x,a,a)')'Unknown ADVECTION option: ', & - trim(keyword) - call store_error(errmsg, terminate=.TRUE.) + write (errmsg, '(4x, a, a)') & + 'ERROR. UNKNOWN SCHEME: ', trim(keyword) + call store_error(errmsg) + write (errmsg, '(4x, a, a)') & + 'SCHEME MUST BE "UPSTREAM", "CENTRAL" OR "TVD"' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + case default + write (errmsg, '(4x,a,a)') 'Unknown ADVECTION option: ', & + trim(keyword) + call store_error(errmsg, terminate=.TRUE.) end select end do if (this%iadvwt /= 1) then this%iasym = 1 - write(this%iout,'(1x,a)')'SELECTED ADVECTION SCHEME RESULTS IN AN & + write (this%iout, '(1x,a)') 'SELECTED ADVECTION SCHEME RESULTS IN AN & &ASYMMETRIC MATRIX.' - endif - write(this%iout,'(1x,a)')'END OF ADVECTION OPTIONS' + end if + write (this%iout, '(1x,a)') 'END OF ADVECTION OPTIONS' end if ! ! -- Return @@ -496,7 +496,7 @@ function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) ! -- return real(DP) :: omega ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this integer, intent(in) :: iadvwt integer, intent(in) :: ipos integer, intent(in) :: n @@ -505,8 +505,8 @@ function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) ! -- local real(DP) :: lnm, lmn ! ------------------------------------------------------------------------------ - select case(iadvwt) - case(1) + select case (iadvwt) + case (1) ! -- calculate weight based on distances between nodes and the shared ! face of the connection if (this%dis%con%ihc(this%dis%con%jas(ipos)) == 0) then @@ -517,21 +517,19 @@ function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) ! -- horizontal connection lnm = this%dis%con%cl1(this%dis%con%jas(ipos)) lmn = this%dis%con%cl2(this%dis%con%jas(ipos)) - endif + end if omega = lmn / (lnm + lmn) - case(0, 2) + case (0, 2) ! -- use upstream weighting for upstream and tvd schemes - if(qnm > DZERO) then + if (qnm > DZERO) then omega = DZERO else omega = DONE - endif + end if end select ! ! -- return return end function adv_weight - - -end module GwtAdvModule \ No newline at end of file +end module TspAdvModule diff --git a/src/Model/GroundWaterTransport/gwt1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 similarity index 81% rename from src/Model/GroundWaterTransport/gwt1cnc1.f90 rename to src/Model/GroundWaterTransport/tsp1cnc1.f90 index 5ef0f25e7d5..601acb93243 100644 --- a/src/Model/GroundWaterTransport/gwt1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -1,11 +1,11 @@ -module GwtCncModule +module TspCncModule ! - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & - LENPACKAGENAME - use ObsModule, only: DefaultObsIdProcessor - use BndModule, only: BndType - use ObserveModule, only: ObserveType + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & + LENPACKAGENAME + use ObsModule, only: DefaultObsIdProcessor + use BndModule, only: BndType + use ObserveModule, only: ObserveType use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList ! @@ -14,13 +14,13 @@ module GwtCncModule private public :: cnc_create ! - character(len=LENFTYPE) :: ftype = 'CNC' - character(len=LENPACKAGENAME) :: text = ' CNC' + character(len=LENFTYPE) :: ftype = 'CNC' + character(len=LENPACKAGENAME) :: text = ' CNC' ! - type, extends(BndType) :: GwtCncType - real(DP), dimension(:), pointer, contiguous :: ratecncin => null() !simulated flows into constant conc (excluding other concs) - real(DP), dimension(:), pointer, contiguous :: ratecncout => null() !simulated flows out of constant conc (excluding to other concs) - contains + type, extends(BndType) :: TspCncType + real(DP), dimension(:), pointer, contiguous :: ratecncin => null() !simulated flows into constant conc (excluding other concs) + real(DP), dimension(:), pointer, contiguous :: ratecncout => null() !simulated flows out of constant conc (excluding to other concs) + contains procedure :: bnd_rp => cnc_rp procedure :: bnd_ad => cnc_ad procedure :: bnd_ck => cnc_ck @@ -35,7 +35,7 @@ module GwtCncModule procedure, public :: bnd_df_obs => cnc_df_obs ! -- method for time series procedure, public :: bnd_rp_ts => cnc_rp_ts - end type GwtCncType + end type TspCncType contains @@ -50,18 +50,18 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj - integer(I4B),intent(in) :: id - integer(I4B),intent(in) :: ibcnum - integer(I4B),intent(in) :: inunit - integer(I4B),intent(in) :: iout + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname ! -- local - type(GwtCncType), pointer :: cncobj + type(TspCncType), pointer :: cncobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate(cncobj) + allocate (cncobj) packobj => cncobj ! ! -- create name and memory path @@ -96,7 +96,7 @@ subroutine cnc_allocate_arrays(this, nodelist, auxvar) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtCncType) :: this + class(TspCncType) :: this integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist real(DP), dimension(:, :), pointer, contiguous, optional :: auxvar ! -- local @@ -108,7 +108,8 @@ subroutine cnc_allocate_arrays(this, nodelist, auxvar) ! ! -- allocate ratecncex call mem_allocate(this%ratecncin, this%maxbound, 'RATECNCIN', this%memoryPath) - call mem_allocate(this%ratecncout, this%maxbound, 'RATECNCOUT', this%memoryPath) + call mem_allocate(this%ratecncout, this%maxbound, 'RATECNCOUT', & + this%memoryPath) do i = 1, this%maxbound this%ratecncin(i) = DZERO this%ratecncout(i) = DZERO @@ -117,7 +118,7 @@ subroutine cnc_allocate_arrays(this, nodelist, auxvar) ! -- return return end subroutine cnc_allocate_arrays - + subroutine cnc_rp(this) ! ****************************************************************************** ! cnc_rp -- Read and prepare @@ -127,39 +128,39 @@ subroutine cnc_rp(this) ! ------------------------------------------------------------------------------ use SimModule, only: store_error implicit none - class(GwtCncType), intent(inout) :: this + class(TspCncType), intent(inout) :: this integer(I4B) :: i, node, ibd, ierr character(len=30) :: nodestr ! ------------------------------------------------------------------------------ ! ! -- Reset previous CNCs to active cell - do i=1,this%nbound - node = this%nodelist(i) - this%ibound(node) = this%ibcnum - enddo + do i = 1, this%nbound + node = this%nodelist(i) + this%ibound(node) = this%ibcnum + end do ! ! -- Call the parent class read and prepare call this%BndType%bnd_rp() ! ! -- Set ibound to -(ibcnum + 1) for constant concentration cells ierr = 0 - do i=1,this%nbound + do i = 1, this%nbound node = this%nodelist(i) ibd = this%ibound(node) - if(ibd < 0) then + if (ibd < 0) then call this%dis%noder_to_string(node, nodestr) call store_error('Error. Cell is already a constant concentration: ' & - // trim(adjustl(nodestr))) + //trim(adjustl(nodestr))) ierr = ierr + 1 else this%ibound(node) = -this%ibcnum - endif - enddo + end if + end do ! ! -- Stop if errors detected - if(ierr > 0) then + if (ierr > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return @@ -174,7 +175,7 @@ subroutine cnc_ad(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtCncType) :: this + class(TspCncType) :: this ! -- local integer(I4B) :: i, node real(DP) :: cb @@ -190,7 +191,7 @@ subroutine cnc_ad(this) cb = this%bound(1, i) this%xnew(node) = cb this%xold(node) = this%xnew(node) - enddo + end do ! ! -- For each observation, push simulated value and corresponding ! simulation time from "current" to "preceding" and reset @@ -212,7 +213,7 @@ subroutine cnc_ck(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit ! -- dummy - class(GwtCncType),intent(inout) :: this + class(TspCncType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: errmsg character(len=30) :: nodestr @@ -220,18 +221,18 @@ subroutine cnc_ck(this) integer(I4B) :: node ! -- formats character(len=*), parameter :: fmtcncerr = & - "('CNC BOUNDARY ',i0,' CONC (',g0,') IS LESS THAN ZERO FOR CELL', a)" + &"('CNC BOUNDARY ',i0,' CONC (',g0,') IS LESS THAN ZERO FOR CELL', a)" ! ------------------------------------------------------------------------------ ! ! -- check stress period data do i = 1, this%nbound - node = this%nodelist(i) - ! -- accumulate errors - if (this%bound(1,i) < DZERO) then - call this%dis%noder_to_string(node, nodestr) - write(errmsg, fmt=fmtcncerr) i, this%bound(1,i), trim(nodestr) - call store_error(errmsg) - end if + node = this%nodelist(i) + ! -- accumulate errors + if (this%bound(1, i) < DZERO) then + call this%dis%noder_to_string(node, nodestr) + write (errmsg, fmt=fmtcncerr) i, this%bound(1, i), trim(nodestr) + call store_error(errmsg) + end if end do ! ! -- write summary of cnc package error messages @@ -251,7 +252,7 @@ subroutine cnc_fc(this, rhs, ia, idxglo, amatsln) ! SPECIFICATIONS: ! -------------------------------------------------------------------------- ! -- dummy - class(GwtCncType) :: this + class(TspCncType) :: this real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo @@ -272,7 +273,7 @@ subroutine cnc_cq(this, x, flowja, iadv) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtCncType), intent(inout) :: this + class(TspCncType), intent(inout) :: this real(DP), dimension(:), intent(in) :: x real(DP), dimension(:), contiguous, intent(inout) :: flowja integer(I4B), optional, intent(in) :: iadv @@ -288,7 +289,7 @@ subroutine cnc_cq(this, x, flowja, iadv) ! ------------------------------------------------------------------------------ ! ! -- If no boundaries, skip flow calculations. - if(this%nbound > 0) then + if (this%nbound > 0) then ! ! -- Loop through each boundary calculating flow. do i = 1, this%nbound @@ -300,7 +301,7 @@ subroutine cnc_cq(this, x, flowja, iadv) ! ! -- Calculate the flow rate into the cell. do ipos = this%dis%con%ia(node) + 1, & - this%dis%con%ia(node + 1) - 1 + this%dis%con%ia(node + 1) - 1 q = flowja(ipos) rate = rate - q ! -- only accumulate chin and chout for active @@ -315,7 +316,7 @@ subroutine cnc_cq(this, x, flowja, iadv) end if end do ! - ! -- For CNC, store total flow in rhs so it is available for other + ! -- For CNC, store total flow in rhs so it is available for other ! calculations this%rhs(i) = -rate this%hcof(i) = DZERO @@ -338,7 +339,7 @@ subroutine cnc_bd(this, model_budget) ! -- add package ratin/ratout to model budget use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator - class(GwtCncType) :: this + class(TspCncType) :: this type(BudgetType), intent(inout) :: model_budget real(DP) :: ratin real(DP) :: ratout @@ -347,7 +348,7 @@ subroutine cnc_bd(this, model_budget) isuppress_output = 0 call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratecncout(1:this%nbound), ratout, dum) - call model_budget%addentry(ratin, ratout, delt, this%text, & + call model_budget%addentry(ratin, ratout, delt, this%text, & isuppress_output, this%packName) end subroutine cnc_bd @@ -361,7 +362,7 @@ subroutine cnc_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtCncType) :: this + class(TspCncType) :: this ! ------------------------------------------------------------------------------ ! ! -- Deallocate parent package @@ -383,25 +384,25 @@ subroutine define_listlabel(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - class(GwtCncType), intent(inout) :: this + class(TspCncType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! -- create the header list label - this%listlabel = trim(this%filtyp) // ' NO.' - if(this%dis%ndim == 3) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' - elseif(this%dis%ndim == 2) then - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' else - write(this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' - endif - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'CONCENTRATION' - if(this%inamedbound == 1) then - write(this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' - endif + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'CONCENTRATION' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if ! ! -- return return @@ -419,7 +420,7 @@ logical function cnc_obs_supported(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtCncType) :: this + class(TspCncType) :: this ! ------------------------------------------------------------------------------ ! cnc_obs_supported = .true. @@ -438,7 +439,7 @@ subroutine cnc_df_obs(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtCncType) :: this + class(TspCncType) :: this ! -- local integer(I4B) :: indx ! ------------------------------------------------------------------------------ @@ -463,25 +464,25 @@ subroutine cnc_rp_ts(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtCncType), intent(inout) :: this + class(TspCncType), intent(inout) :: this ! -- local integer(I4B) :: i, nlinks type(TimeSeriesLinkType), pointer :: tslink => null() ! ------------------------------------------------------------------------------ ! nlinks = this%TsManager%boundtslinks%Count() - do i=1,nlinks + do i = 1, nlinks tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) if (associated(tslink)) then select case (tslink%JCol) case (1) tslink%Text = 'CONCENTRATION' end select - endif - enddo + end if + end do ! ! -- return return end subroutine cnc_rp_ts -end module GwtCncModule +end module TspCncModule diff --git a/src/Model/GroundWaterTransport/gwt1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 similarity index 74% rename from src/Model/GroundWaterTransport/gwt1fmi1.f90 rename to src/Model/GroundWaterTransport/tsp1fmi1.f90 index 4d687e6576c..50f8baa9ee1 100644 --- a/src/Model/GroundWaterTransport/gwt1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -1,68 +1,69 @@ -module GwtFmiModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DONE, DZERO, DHALF, LINELENGTH, LENBUDTXT, & - LENPACKAGENAME - use SimModule, only: store_error, store_error_unit - use SimVariablesModule, only: errmsg +module TspFmiModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, DHALF, LINELENGTH, LENBUDTXT, & + LENPACKAGENAME + use SimModule, only: store_error, store_error_unit + use SimVariablesModule, only: errmsg use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use ListModule, only: ListType + use BaseDisModule, only: DisBaseType + use ListModule, only: ListType use BudgetFileReaderModule, only: BudgetFileReaderType - use HeadFileReaderModule, only: HeadFileReaderType - use PackageBudgetModule, only: PackageBudgetType - use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr_bfr + use HeadFileReaderModule, only: HeadFileReaderType + use PackageBudgetModule, only: PackageBudgetType + use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr_bfr implicit none private - public :: GwtFmiType + public :: TspFmiType public :: fmi_cr integer(I4B), parameter :: NBDITEMS = 2 character(len=LENBUDTXT), dimension(NBDITEMS) :: budtxt - data budtxt / ' FLOW-ERROR', ' FLOW-CORRECTION' / - + data budtxt/' FLOW-ERROR', ' FLOW-CORRECTION'/ + type :: DataAdvancedPackageType real(DP), dimension(:), contiguous, pointer :: concpack => null() real(DP), dimension(:), contiguous, pointer :: qmfrommvr => null() end type - + type :: BudObjPtrArray type(BudgetObjectType), pointer :: ptr - end type BudObjPtrArray - - type, extends(NumericalPackageType) :: GwtFmiType - - logical, pointer :: flows_from_file => null() !< if .false., then flows come from GWF through GWF-GWT exg - integer(I4B), dimension(:), pointer, contiguous :: iatp => null() !< advanced transport package applied to gwfpackages - type(ListType), pointer :: gwfbndlist => null() !< list of gwf stress packages - integer(I4B), pointer :: iflowsupdated => null() !< flows were updated for this time step - integer(I4B), pointer :: iflowerr => null() !< add the flow error correction - real(DP), dimension(:), pointer, contiguous :: flowcorrect => null() !< mass flow correction - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to GWT ibound - real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< pointer to the GWF flowja array - real(DP), dimension(:, :), pointer, contiguous :: gwfspdis => null() !< pointer to npf specific discharge array - real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< pointer to the GWF head array - real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< pointer to the GWF saturation array - integer(I4B), dimension(:), pointer, contiguous :: ibdgwfsat0 => null() !< mark cells with saturation = 0 to exclude from dispersion - real(DP), dimension(:), pointer, contiguous :: gwfstrgss => null() !< pointer to flow model QSTOSS - real(DP), dimension(:), pointer, contiguous :: gwfstrgsy => null() !< pointer to flow model QSTOSY - integer(I4B), pointer :: igwfstrgss => null() !< indicates if gwfstrgss is available - integer(I4B), pointer :: igwfstrgsy => null() !< indicates if gwfstrgsy is available - integer(I4B), pointer :: iubud => null() !< unit number GWF budget file - integer(I4B), pointer :: iuhds => null() !< unit number GWF head file - integer(I4B), pointer :: iumvr => null() !< unit number GWF mover budget file - integer(I4B), pointer :: nflowpack => null() !< number of GWF flow packages - integer(I4B), dimension(:), pointer, contiguous :: igwfmvrterm => null() !< flag to indicate that gwf package is a mover term - type(BudgetFileReaderType) :: bfr !< budget file reader - type(HeadFileReaderType) :: hfr !< head file reader - type(PackageBudgetType), dimension(:), allocatable :: gwfpackages !< used to get flows between a package and gwf - type(BudgetObjectType), pointer :: mvrbudobj => null() !< pointer to the mover budget budget object - type(DataAdvancedPackageType), dimension(:), pointer, contiguous :: datp => null() - character(len=16), dimension(:), allocatable :: flowpacknamearray !< array of boundary package names (e.g. LAK-1, SFR-3, etc.) - type(BudObjPtrArray), dimension(:), allocatable :: aptbudobj !< flow budget objects for the advanced packages + end type BudObjPtrArray + + type, extends(NumericalPackageType) :: TspFmiType + + logical, pointer :: flows_from_file => null() !< if .false., then flows come from GWF through GWF-GWT exg + integer(I4B), dimension(:), pointer, contiguous :: iatp => null() !< advanced transport package applied to gwfpackages + type(ListType), pointer :: gwfbndlist => null() !< list of gwf stress packages + integer(I4B), pointer :: iflowsupdated => null() !< flows were updated for this time step + integer(I4B), pointer :: iflowerr => null() !< add the flow error correction + real(DP), dimension(:), pointer, contiguous :: flowcorrect => null() !< mass flow correction + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to GWT ibound + real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< pointer to the GWF flowja array + real(DP), dimension(:, :), pointer, contiguous :: gwfspdis => null() !< pointer to npf specific discharge array + real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< pointer to the GWF head array + real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< pointer to the GWF saturation array + integer(I4B), dimension(:), pointer, contiguous :: ibdgwfsat0 => null() !< mark cells with saturation = 0 to exclude from dispersion + real(DP), dimension(:), pointer, contiguous :: gwfstrgss => null() !< pointer to flow model QSTOSS + real(DP), dimension(:), pointer, contiguous :: gwfstrgsy => null() !< pointer to flow model QSTOSY + integer(I4B), pointer :: igwfstrgss => null() !< indicates if gwfstrgss is available + integer(I4B), pointer :: igwfstrgsy => null() !< indicates if gwfstrgsy is available + integer(I4B), pointer :: iubud => null() !< unit number GWF budget file + integer(I4B), pointer :: iuhds => null() !< unit number GWF head file + integer(I4B), pointer :: iumvr => null() !< unit number GWF mover budget file + integer(I4B), pointer :: nflowpack => null() !< number of GWF flow packages + integer(I4B), dimension(:), pointer, contiguous :: igwfmvrterm => null() !< flag to indicate that gwf package is a mover term + type(BudgetFileReaderType) :: bfr !< budget file reader + type(HeadFileReaderType) :: hfr !< head file reader + type(PackageBudgetType), dimension(:), allocatable :: gwfpackages !< used to get flows between a package and gwf + type(BudgetObjectType), pointer :: mvrbudobj => null() !< pointer to the mover budget budget object + type(DataAdvancedPackageType), & + dimension(:), pointer, contiguous :: datp => null() + character(len=16), dimension(:), allocatable :: flowpacknamearray !< array of boundary package names (e.g. LAK-1, SFR-3, etc.) + type(BudObjPtrArray), dimension(:), allocatable :: aptbudobj !< flow budget objects for the advanced packages contains - + procedure :: fmi_df procedure :: fmi_ar procedure :: fmi_rp @@ -89,11 +90,11 @@ module GwtFmiModule procedure :: deallocate_gwfpackages procedure :: get_package_index procedure :: set_aptbudobj_pointer - - end type GwtFmiType - contains - + end type TspFmiType + +contains + subroutine fmi_cr(fmiobj, name_model, inunit, iout) ! ****************************************************************************** ! fmi_cr -- Create a new FMI object @@ -102,14 +103,14 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtFmiType), pointer :: fmiobj + type(TspFmiType), pointer :: fmiobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(fmiobj) + allocate (fmiobj) ! ! -- create name and memory path call fmiobj%set_names(1, name_model, 'FMI', 'FMI') @@ -142,31 +143,31 @@ subroutine fmi_df(this, dis, inssm) ! -- modules use SimModule, only: store_error ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this class(DisBaseType), pointer, intent(in) :: dis integer(I4B), intent(in) :: inssm ! -- local ! -- formats - character(len=*), parameter :: fmtfmi = & - "(1x,/1x,'FMI -- FLOW MODEL INTERFACE, VERSION 1, 8/29/2017', & + character(len=*), parameter :: fmtfmi = & + "(1x,/1x,'FMI -- FLOW MODEL INTERFACE, VERSION 1, 8/29/2017', & &' INPUT READ FROM UNIT ', i0, //)" - character(len=*), parameter :: fmtfmi0 = & - "(1x,/1x,'FMI -- FLOW MODEL INTERFACE, VERSION 1, 8/29/2017')" + character(len=*), parameter :: fmtfmi0 = & + &"(1x,/1x,'FMI -- FLOW MODEL INTERFACE, VERSION 1, 8/29/2017')" ! ------------------------------------------------------------------------------ ! ! --print a message identifying the FMI package. if (this%iout > 0) then if (this%inunit /= 0) then - write(this%iout, fmtfmi) this%inunit + write (this%iout, fmtfmi) this%inunit else - write(this%iout, fmtfmi0) + write (this%iout, fmtfmi0) if (this%flows_from_file) then - write(this%iout, '(a)') ' FLOWS ARE ASSUMED TO BE ZERO.' + write (this%iout, '(a)') ' FLOWS ARE ASSUMED TO BE ZERO.' else - write(this%iout, '(a)') ' FLOWS PROVIDED BY A GWF MODEL IN THIS & + write (this%iout, '(a)') ' FLOWS PROVIDED BY A GWF MODEL IN THIS & &SIMULATION' - endif - endif + end if + end if end if ! ! -- store pointers to arguments that were passed in @@ -194,13 +195,13 @@ subroutine fmi_df(this, dis, inssm) call store_error('FLOW MODEL HAS BOUNDARY PACKAGES, BUT THERE & &IS NO SSM PACKAGE. THE SSM PACKAGE MUST BE ACTIVATED.', & terminate=.TRUE.) - endif - endif + end if + end if ! ! -- Return return end subroutine fmi_df - + subroutine fmi_ar(this, ibound) ! ****************************************************************************** ! fmi_ar -- Allocate and Read @@ -211,14 +212,14 @@ subroutine fmi_ar(this, ibound) ! -- modules use SimModule, only: store_error ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), dimension(:), pointer, contiguous :: ibound ! -- local ! -- formats ! ------------------------------------------------------------------------------ ! ! -- store pointers to arguments that were passed in - this%ibound => ibound + this%ibound => ibound ! ! -- Allocate arrays call this%allocate_arrays(this%dis%nodes) @@ -226,7 +227,7 @@ subroutine fmi_ar(this, ibound) ! -- Return return end subroutine fmi_ar - + subroutine fmi_rp(this, inmvr) ! ****************************************************************************** ! fmi_rp -- Read and prepare @@ -237,23 +238,23 @@ subroutine fmi_rp(this, inmvr) ! -- modules use TdisModule, only: kper, kstp ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: inmvr ! -- local ! -- formats ! ------------------------------------------------------------------------------ ! ! --Check to make sure MVT Package is active if mvr flows are available. - ! This cannot be checked until RP because exchange doesn't set a pointer + ! This cannot be checked until RP because exchange doesn't set a pointer ! to mvrbudobj until exg_ar(). if (kper * kstp == 1) then if (associated(this%mvrbudobj) .and. inmvr == 0) then - write(errmsg,'(4x,a)') 'GWF WATER MOVER IS ACTIVE BUT THE GWT MVT & + write (errmsg, '(4x,a)') 'GWF WATER MOVER IS ACTIVE BUT THE GWT MVT & &PACKAGE HAS NOT BEEN SPECIFIED. ACTIVATE GWT MVT PACKAGE.' call store_error(errmsg, terminate=.TRUE.) end if if (.not. associated(this%mvrbudobj) .and. inmvr > 0) then - write(errmsg,'(4x,a)') 'GWF WATER MOVER TERMS ARE NOT AVAILABLE & + write (errmsg, '(4x,a)') 'GWF WATER MOVER TERMS ARE NOT AVAILABLE & &BUT THE GWT MVT PACKAGE HAS BEEN ACTIVATED. GWF-GWT EXCHANGE & &OR SPECIFY GWFMOVER IN FMI PACKAGEDATA.' call store_error(errmsg, terminate=.TRUE.) @@ -263,7 +264,7 @@ subroutine fmi_rp(this, inmvr) ! -- Return return end subroutine fmi_rp - + subroutine fmi_ad(this, cnew) ! ****************************************************************************** ! fmi_ad -- advance @@ -274,14 +275,14 @@ subroutine fmi_ad(this, cnew) ! -- modules use ConstantsModule, only: DHDRY ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this real(DP), intent(inout), dimension(:) :: cnew ! -- local integer(I4B) :: n integer(I4B) :: m integer(I4B) :: ipos real(DP) :: crewet, tflow, flownm - character (len=15) :: nodestr + character(len=15) :: nodestr character(len=*), parameter :: fmtdry = & &"(/1X,'WARNING: DRY CELL ENCOUNTERED AT ',a,'; RESET AS INACTIVE & &WITH DRY CONCENTRATION = ', G13.5)" @@ -298,12 +299,12 @@ subroutine fmi_ad(this, cnew) ! -- If reading flows from a budget file, read the next set of records if (this%iubud /= 0) then call this%advance_bfr() - endif + end if ! ! -- If reading heads from a head file, read the next set of records if (this%iuhds /= 0) then call this%advance_hfr() - endif + end if ! ! -- If mover flows are being read from file, read the next set of records if (this%iumvr /= 0) then @@ -320,7 +321,7 @@ subroutine fmi_ad(this, cnew) ! -- if flow cell is dry, then set gwt%ibound = 0 and conc to dry do n = 1, this%dis%nodes ! - ! -- Calculate the ibound-like array that has 0 if saturation + ! -- 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 @@ -335,9 +336,9 @@ subroutine fmi_ad(this, cnew) this%ibound(n) = 0 cnew(n) = DHDRY call this%dis%noder_to_string(n, nodestr) - write(this%iout, fmtdry) trim(nodestr), DHDRY - endif - endif + write (this%iout, fmtdry) trim(nodestr), DHDRY + end if + end if ! ! -- Convert dry transport cell to active if flow has rewet if (cnew(n) == DHDRY) then @@ -353,28 +354,28 @@ subroutine fmi_ad(this, cnew) if (this%ibound(m) /= 0) then crewet = crewet + cnew(m) * flownm tflow = tflow + this%gwfflowja(ipos) - endif - endif - enddo + end if + end if + end do if (tflow > DZERO) then crewet = crewet / tflow else crewet = DZERO - endif + end if ! ! -- cell is now wet this%ibound(n) = 1 cnew(n) = crewet call this%dis%noder_to_string(n, nodestr) - write(this%iout, fmtrewet) trim(nodestr), crewet - endif - endif - enddo + write (this%iout, fmtrewet) trim(nodestr), crewet + end if + end if + end do ! ! -- Return return end subroutine fmi_ad - + subroutine fmi_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) ! ****************************************************************************** ! fmi_fc -- Calculate coefficients and fill amat and rhs @@ -385,7 +386,7 @@ subroutine fmi_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) ! -- modules !use BndModule, only: BndType, GetBndFromList ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer, intent(in) :: nodes real(DP), intent(in), dimension(nodes) :: cold integer(I4B), intent(in) :: nja @@ -406,13 +407,13 @@ subroutine fmi_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) idiag = idxglo(this%dis%con%ia(n)) ipos = this%dis%con%ia(n) amatsln(idiag) = amatsln(idiag) - this%gwfflowja(ipos) - enddo + end do end if ! ! -- Return return end subroutine fmi_fc - + subroutine fmi_cq(this, cnew, flowja) ! ****************************************************************************** ! fmi_cq -- Calculate flow correction @@ -422,7 +423,7 @@ subroutine fmi_cq(this, cnew, flowja) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this real(DP), intent(in), dimension(:) :: cnew real(DP), dimension(:), contiguous, intent(inout) :: flowja ! -- local @@ -443,13 +444,13 @@ subroutine fmi_cq(this, cnew, flowja) end if this%flowcorrect(n) = rate flowja(idiag) = flowja(idiag) + rate - enddo + end do end if ! ! -- Return return end subroutine fmi_cq - + subroutine fmi_bd(this, isuppress_output, model_budget) ! ****************************************************************************** ! mst_bd -- Calculate budget terms @@ -461,7 +462,7 @@ subroutine fmi_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: isuppress_output type(BudgetType), intent(inout) :: model_budget ! -- local @@ -478,7 +479,7 @@ subroutine fmi_bd(this, isuppress_output, model_budget) ! -- Return return end subroutine fmi_bd - + subroutine fmi_ot_flow(this, icbcfl, icbcun) ! ****************************************************************************** ! fmi_ot_flow -- Save budget terms @@ -487,39 +488,39 @@ subroutine fmi_ot_flow(this, icbcfl, icbcun) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: icbcun ! -- local integer(I4B) :: ibinun integer(I4B) :: iprint, nvaluesp, nwidthp - character(len=1) :: cdatafmp=' ', editdesc=' ' + character(len=1) :: cdatafmp = ' ', editdesc = ' ' real(DP) :: dinact ! ------------------------------------------------------------------------------ ! ! -- Set unit number for binary output - if(this%ipakcb < 0) then + if (this%ipakcb < 0) then ibinun = icbcun - elseif(this%ipakcb == 0) then + elseif (this%ipakcb == 0) then ibinun = 0 else ibinun = this%ipakcb - endif - if(icbcfl == 0) ibinun = 0 + end if + if (icbcfl == 0) ibinun = 0 ! ! -- Do not save flow corrections if not active - if(this%iflowerr == 0) ibinun = 0 + if (this%iflowerr == 0) ibinun = 0 ! ! -- Record the storage rates if requested - if(ibinun /= 0) then + if (ibinun /= 0) then iprint = 0 dinact = DZERO ! ! -- flow correction call this%dis%record_array(this%flowcorrect, this%iout, iprint, -ibinun, & - budtxt(2), cdatafmp, nvaluesp, & + budtxt(2), cdatafmp, nvaluesp, & nwidthp, editdesc, dinact) - endif + end if ! ! -- Return return @@ -535,7 +536,7 @@ subroutine fmi_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! ------------------------------------------------------------------------------ ! -- todo: finalize hfr and bfr either here or in a finalize routine ! @@ -544,14 +545,14 @@ subroutine fmi_da(this) ! ! -- deallocate fmi arrays if (associated(this%datp)) then - deallocate(this%datp) - deallocate(this%gwfpackages) - deallocate(this%flowpacknamearray) + deallocate (this%datp) + deallocate (this%gwfpackages) + deallocate (this%flowpacknamearray) call mem_deallocate(this%iatp) call mem_deallocate(this%igwfmvrterm) end if - deallocate(this%aptbudobj) + deallocate (this%aptbudobj) call mem_deallocate(this%flowcorrect) call mem_deallocate(this%ibdgwfsat0) if (this%flows_from_file) then @@ -580,7 +581,7 @@ subroutine fmi_da(this) ! -- Return return end subroutine fmi_da - + subroutine allocate_scalars(this) ! ****************************************************************************** ! allocate_scalars @@ -591,7 +592,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -611,7 +612,7 @@ subroutine allocate_scalars(this) ! ! -- Although not a scalar, allocate the advanced package transport ! budget object to zero so that it can be dynamically resized later - allocate(this%aptbudobj(0)) + allocate (this%aptbudobj(0)) ! ! -- Initialize this%flows_from_file = .true. @@ -639,7 +640,7 @@ subroutine allocate_arrays(this, nodes) !modules use ConstantsModule, only: DZERO ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: nodes ! -- local integer(I4B) :: n @@ -653,7 +654,7 @@ subroutine allocate_arrays(this, nodes) end if do n = 1, size(this%flowcorrect) this%flowcorrect(n) = DZERO - enddo + end do ! ! -- Allocate ibdgwfsat0, which is an indicator array marking cells with ! saturation greater than 0.0 with a value of 1 @@ -665,7 +666,8 @@ subroutine allocate_arrays(this, nodes) ! -- Allocate differently depending on whether or not flows are ! being read from a file. if (this%flows_from_file) then - call mem_allocate(this%gwfflowja, this%dis%con%nja, 'GWFFLOWJA', this%memoryPath) + call mem_allocate(this%gwfflowja, this%dis%con%nja, 'GWFFLOWJA', & + this%memoryPath) call mem_allocate(this%gwfsat, nodes, 'GWFSAT', this%memoryPath) call mem_allocate(this%gwfhead, nodes, 'GWFHEAD', this%memoryPath) call mem_allocate(this%gwfspdis, 3, nodes, 'GWFSPDIS', this%memoryPath) @@ -704,7 +706,7 @@ subroutine allocate_arrays(this, nodes) ! -- Return return end subroutine allocate_arrays - + function gwfsatold(this, n, delt) result(satold) ! ****************************************************************************** ! gwfsatold -- calculate the groundwater cell head saturation for the end of @@ -715,7 +717,7 @@ function gwfsatold(this, n, delt) result(satold) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: n real(DP), intent(in) :: delt ! -- result @@ -737,7 +739,7 @@ function gwfsatold(this, n, delt) result(satold) ! -- Return return end function gwfsatold - + subroutine read_options(this) ! ****************************************************************************** ! read_options -- Read Options @@ -751,16 +753,16 @@ subroutine read_options(this) use InputOutputModule, only: getunit, openfile, urdaux use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO AND FLOW IMBALANCE CORRECTION ACTIVE.')" - character(len=*), parameter :: fmtifc = & - "(4x,'MASS WILL BE ADDED OR REMOVED TO COMPENSATE FOR FLOW IMBALANCE.')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO AND FLOW IMBALANCE CORRECTION ACTIVE.')" + character(len=*), parameter :: fmtifc = & + &"(4x,'MASS WILL BE ADDED OR REMOVED TO COMPENSATE FOR FLOW IMBALANCE.')" ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -769,26 +771,26 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING FMI OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING FMI OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtisvflow) - case ('FLOW_IMBALANCE_CORRECTION') - write(this%iout, fmtifc) - this%iflowerr = 1 - case default - write(errmsg,'(4x,a,a)')'***ERROR. UNKNOWN FMI OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtisvflow) + case ('FLOW_IMBALANCE_CORRECTION') + write (this%iout, fmtifc) + this%iflowerr = 1 + case default + write (errmsg, '(4x,a,a)') '***ERROR. UNKNOWN FMI OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)') 'END OF FMI OPTIONS' + write (this%iout, '(1x,a)') 'END OF FMI OPTIONS' end if ! ! -- return @@ -809,7 +811,7 @@ subroutine read_packagedata(this) use InputOutputModule, only: getunit, openfile, urdaux use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local type(BudgetObjectType), pointer :: budobjptr character(len=LINELENGTH) :: keyword, fname @@ -829,109 +831,109 @@ subroutine read_packagedata(this) blockrequired = .true. ! ! -- get options block - call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & - blockRequired=blockRequired, & + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + blockRequired=blockRequired, & supportOpenClose=.true.) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING FMI PACKAGEDATA' + write (this%iout, '(1x,a)') 'PROCESSING FMI PACKAGEDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('GWFBUDGET') - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('GWFBUDGET KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - endif - call this%parser%GetString(fname) - inunit = getunit() - inquire(file=trim(fname), exist=exist) - if (.not. exist) then - call store_error('Could not find file '//trim(fname)) - call this%parser%StoreErrorUnit() - end if - call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & - ACCESS, 'UNKNOWN') - this%iubud = inunit - call this%initialize_bfr() - case ('GWFHEAD') - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('GWFHEAD KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - endif - call this%parser%GetString(fname) - inquire(file=trim(fname), exist=exist) - if (.not. exist) then - call store_error('Could not find file '//trim(fname)) - call this%parser%StoreErrorUnit() - end if - inunit = getunit() - call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & - ACCESS, 'UNKNOWN') - this%iuhds = inunit - call this%initialize_hfr() - case ('GWFMOVER') - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('GWFMOVER KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - endif - call this%parser%GetString(fname) - inunit = getunit() - call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & - ACCESS, 'UNKNOWN') - this%iumvr = inunit - call budgetobject_cr_bfr(this%mvrbudobj, 'MVT', this%iumvr, & - this%iout) - call this%mvrbudobj%fill_from_bfr(this%dis, this%iout) - case default - ! - ! --expand the size of aptbudobj, which stores a pointer to the budobj - allocate(tmpbudobj(iapt)) - do i = 1, size(this%aptbudobj) - tmpbudobj(i)%ptr => this%aptbudobj(i)%ptr - end do - deallocate(this%aptbudobj) - allocate(this%aptbudobj(iapt + 1)) - do i = 1, size(tmpbudobj) - this%aptbudobj(i)%ptr => tmpbudobj(i)%ptr - end do - deallocate(tmpbudobj) - ! - ! -- Open the budget file and start filling it - iapt = iapt + 1 - pname = keyword(1:LENPACKAGENAME) - call this%parser%GetStringCaps(keyword) - if(keyword /= 'FILEIN') then - call store_error('PACKAGE NAME MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') - call this%parser%StoreErrorUnit() - endif - call this%parser%GetString(fname) - inunit = getunit() - call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & - ACCESS, 'UNKNOWN') - call budgetobject_cr_bfr(budobjptr, pname, inunit, & - this%iout, colconv2=['GWF ']) - call budobjptr%fill_from_bfr(this%dis, this%iout) - this%aptbudobj(iapt)%ptr => budobjptr + case ('GWFBUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword /= 'FILEIN') then + call store_error('GWFBUDGET KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + end if + call this%parser%GetString(fname) + inunit = getunit() + inquire (file=trim(fname), exist=exist) + if (.not. exist) then + call store_error('Could not find file '//trim(fname)) + call this%parser%StoreErrorUnit() + end if + call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & + ACCESS, 'UNKNOWN') + this%iubud = inunit + call this%initialize_bfr() + case ('GWFHEAD') + call this%parser%GetStringCaps(keyword) + if (keyword /= 'FILEIN') then + call store_error('GWFHEAD KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + end if + call this%parser%GetString(fname) + inquire (file=trim(fname), exist=exist) + if (.not. exist) then + call store_error('Could not find file '//trim(fname)) + call this%parser%StoreErrorUnit() + end if + inunit = getunit() + call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & + ACCESS, 'UNKNOWN') + this%iuhds = inunit + call this%initialize_hfr() + case ('GWFMOVER') + call this%parser%GetStringCaps(keyword) + if (keyword /= 'FILEIN') then + call store_error('GWFMOVER KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + end if + call this%parser%GetString(fname) + inunit = getunit() + call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & + ACCESS, 'UNKNOWN') + this%iumvr = inunit + call budgetobject_cr_bfr(this%mvrbudobj, 'MVT', this%iumvr, & + this%iout) + call this%mvrbudobj%fill_from_bfr(this%dis, this%iout) + case default + ! + ! --expand the size of aptbudobj, which stores a pointer to the budobj + allocate (tmpbudobj(iapt)) + do i = 1, size(this%aptbudobj) + tmpbudobj(i)%ptr => this%aptbudobj(i)%ptr + end do + deallocate (this%aptbudobj) + allocate (this%aptbudobj(iapt + 1)) + do i = 1, size(tmpbudobj) + this%aptbudobj(i)%ptr => tmpbudobj(i)%ptr + end do + deallocate (tmpbudobj) + ! + ! -- Open the budget file and start filling it + iapt = iapt + 1 + pname = keyword(1:LENPACKAGENAME) + call this%parser%GetStringCaps(keyword) + if (keyword /= 'FILEIN') then + call store_error('PACKAGE NAME MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') + call this%parser%StoreErrorUnit() + end if + call this%parser%GetString(fname) + inunit = getunit() + call openfile(inunit, this%iout, fname, 'DATA(BINARY)', FORM, & + ACCESS, 'UNKNOWN') + call budgetobject_cr_bfr(budobjptr, pname, inunit, & + this%iout, colconv2=['GWF ']) + call budobjptr%fill_from_bfr(this%dis, this%iout) + this%aptbudobj(iapt)%ptr => budobjptr end select end do - write(this%iout,'(1x,a)') 'END OF FMI PACKAGEDATA' + write (this%iout, '(1x,a)') 'END OF FMI PACKAGEDATA' end if ! ! -- return return end subroutine read_packagedata - + subroutine set_aptbudobj_pointer(this, name, budobjptr) ! ****************************************************************************** ! set_aptbudobj_pointer -- an advanced transport can pass in a name and a @@ -943,7 +945,7 @@ subroutine set_aptbudobj_pointer(this, name, budobjptr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dumm character(len=*), intent(in) :: name type(BudgetObjectType), pointer :: budobjptr @@ -971,7 +973,7 @@ subroutine initialize_bfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy integer(I4B) :: ncrbud ! ------------------------------------------------------------------------------ @@ -982,7 +984,7 @@ subroutine initialize_bfr(this) ! -- todo: need to run through the budget terms ! and do some checking end subroutine initialize_bfr - + subroutine advance_bfr(this) ! ****************************************************************************** ! advance_bfr -- advance the budget file reader by reading the next chunk @@ -994,7 +996,7 @@ subroutine advance_bfr(this) ! -- modules use TdisModule, only: kstp, kper ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local logical :: success integer(I4B) :: n @@ -1003,10 +1005,10 @@ subroutine advance_bfr(this) integer(I4B) :: ip, i logical :: readnext ! -- format - character(len=*), parameter :: fmtkstpkper = & - "(1x,/1x,'FMI READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" + character(len=*), parameter :: fmtkstpkper = & + &"(1x,/1x,'FMI READING BUDGET TERMS FOR KSTP ', i0, ' KPER ', i0)" character(len=*), parameter :: fmtbudkstpkper = & - "(1x,/1x, 'FMI SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & + "(1x,/1x, 'FMI SETTING BUDGET TERMS FOR KSTP ', i0, ' AND KPER ', & &i0, ' TO BUDGET FILE TERMS FROM KSTP ', i0, ' AND KPER ', i0)" ! ------------------------------------------------------------------------------ ! @@ -1023,19 +1025,19 @@ subroutine advance_bfr(this) readnext = .false. end if else if (this%bfr%endoffile) then - write(errmsg,'(4x,a)') 'REACHED END OF GWF BUDGET & + write (errmsg, '(4x,a)') 'REACHED END OF GWF BUDGET & &FILE BEFORE READING SUFFICIENT BUDGET INFORMATION FOR THIS & &GWT SIMULATION.' call store_error(errmsg) call store_error_unit(this%iubud) - end if + end if end if ! ! -- Read the next record if (readnext) then ! ! -- Write the current time step and stress period - write(this%iout, fmtkstpkper) kstp, kper + write (this%iout, fmtkstpkper) kstp, kper ! ! -- loop through the budget terms for this stress period ! i is the counter for gwf flow packages @@ -1043,95 +1045,95 @@ subroutine advance_bfr(this) do n = 1, this%bfr%nbudterms call this%bfr%read_record(success, this%iout) if (.not. success) then - write(errmsg,'(4x,a)') 'GWF BUDGET READ NOT SUCCESSFUL' + write (errmsg, '(4x,a)') 'GWF BUDGET READ NOT SUCCESSFUL' call store_error(errmsg) call store_error_unit(this%iubud) - endif + end if ! ! -- Ensure kper is same between model and budget file if (kper /= this%bfr%kper) then - write(errmsg,'(4x,a)') 'PERIOD NUMBER IN BUDGET FILE & + write (errmsg, '(4x,a)') 'PERIOD NUMBER IN BUDGET FILE & &DOES NOT MATCH PERIOD NUMBER IN TRANSPORT MODEL. IF THERE & &IS MORE THAN ONE TIME STEP IN THE BUDGET FILE FOR A GIVEN STRESS & &PERIOD, BUDGET FILE TIME STEPS MUST MATCH GWT MODEL TIME STEPS & &ONE-FOR-ONE IN THAT STRESS PERIOD.' call store_error(errmsg) call store_error_unit(this%iubud) - endif + end if ! ! -- if budget file kstp > 1, then kstp must match if (this%bfr%kstp > 1 .and. (kstp /= this%bfr%kstp)) then - write(errmsg,'(4x,a)') 'TIME STEP NUMBER IN BUDGET FILE & + write (errmsg, '(4x,a)') 'TIME STEP NUMBER IN BUDGET FILE & &DOES NOT MATCH TIME STEP NUMBER IN TRANSPORT MODEL. IF THERE & &IS MORE THAN ONE TIME STEP IN THE BUDGET FILE FOR A GIVEN STRESS & &PERIOD, BUDGET FILE TIME STEPS MUST MATCH GWT MODEL TIME STEPS & &ONE-FOR-ONE IN THAT STRESS PERIOD.' call store_error(errmsg) call store_error_unit(this%iubud) - endif + end if ! ! -- parse based on the type of data, and compress all user node ! numbers into reduced node numbers - select case(trim(adjustl(this%bfr%budtxt))) - case('FLOW-JA-FACE') - ! - ! -- bfr%flowja contains only reduced connections so there is - ! a one-to-one match with this%gwfflowja - do ipos = 1, size(this%bfr%flowja) - this%gwfflowja(ipos) = this%bfr%flowja(ipos) - end do - case('DATA-SPDIS') - do i = 1, this%bfr%nlist - nu = this%bfr%nodesrc(i) - nr = this%dis%get_nodenumber(nu, 0) - if (nr <= 0) cycle - this%gwfspdis(1, nr) = this%bfr%auxvar(1, i) - this%gwfspdis(2, nr) = this%bfr%auxvar(2, i) - this%gwfspdis(3, nr) = this%bfr%auxvar(3, i) - end do - case('DATA-SAT') - do i = 1, this%bfr%nlist - nu = this%bfr%nodesrc(i) - nr = this%dis%get_nodenumber(nu, 0) - if (nr <= 0) cycle - this%gwfsat(nr) = this%bfr%auxvar(1, i) - end do - case('STO-SS') - do nu = 1, this%dis%nodesuser - nr = this%dis%get_nodenumber(nu, 0) - if (nr <= 0) cycle - this%gwfstrgss(nr) = this%bfr%flow(nu) - end do - case('STO-SY') - do nu = 1, this%dis%nodesuser - nr = this%dis%get_nodenumber(nu, 0) - if (nr <= 0) cycle - this%gwfstrgsy(nr) = this%bfr%flow(nu) - end do - case default - call this%gwfpackages(ip)%copy_values( & - this%bfr%nlist, & - this%bfr%nodesrc, & - this%bfr%flow, & - this%bfr%auxvar) - do i = 1, this%gwfpackages(ip)%nbound - nu = this%gwfpackages(ip)%nodelist(i) - nr = this%dis%get_nodenumber(nu, 0) - this%gwfpackages(ip)%nodelist(i) = nr - end do - ip = ip + 1 + select case (trim(adjustl(this%bfr%budtxt))) + case ('FLOW-JA-FACE') + ! + ! -- bfr%flowja contains only reduced connections so there is + ! a one-to-one match with this%gwfflowja + do ipos = 1, size(this%bfr%flowja) + this%gwfflowja(ipos) = this%bfr%flowja(ipos) + end do + case ('DATA-SPDIS') + do i = 1, this%bfr%nlist + nu = this%bfr%nodesrc(i) + nr = this%dis%get_nodenumber(nu, 0) + if (nr <= 0) cycle + this%gwfspdis(1, nr) = this%bfr%auxvar(1, i) + this%gwfspdis(2, nr) = this%bfr%auxvar(2, i) + this%gwfspdis(3, nr) = this%bfr%auxvar(3, i) + end do + case ('DATA-SAT') + do i = 1, this%bfr%nlist + nu = this%bfr%nodesrc(i) + nr = this%dis%get_nodenumber(nu, 0) + if (nr <= 0) cycle + this%gwfsat(nr) = this%bfr%auxvar(1, i) + end do + case ('STO-SS') + do nu = 1, this%dis%nodesuser + nr = this%dis%get_nodenumber(nu, 0) + if (nr <= 0) cycle + this%gwfstrgss(nr) = this%bfr%flow(nu) + end do + case ('STO-SY') + do nu = 1, this%dis%nodesuser + nr = this%dis%get_nodenumber(nu, 0) + if (nr <= 0) cycle + this%gwfstrgsy(nr) = this%bfr%flow(nu) + end do + case default + call this%gwfpackages(ip)%copy_values( & + this%bfr%nlist, & + this%bfr%nodesrc, & + this%bfr%flow, & + this%bfr%auxvar) + do i = 1, this%gwfpackages(ip)%nbound + nu = this%gwfpackages(ip)%nodelist(i) + nr = this%dis%get_nodenumber(nu, 0) + this%gwfpackages(ip)%nodelist(i) = nr + end do + ip = ip + 1 end select end do else ! ! -- write message to indicate that flows are being reused - write(this%iout, fmtbudkstpkper) kstp, kper, this%bfr%kstp, this%bfr%kper + write (this%iout, fmtbudkstpkper) kstp, kper, this%bfr%kstp, this%bfr%kper ! ! -- set the flag to indicate that flows were not updated this%iflowsupdated = 0 - endif + end if end subroutine advance_bfr - + subroutine finalize_bfr(this) ! ****************************************************************************** ! finalize_bfr -- finalize the budget file reader @@ -1140,7 +1142,7 @@ subroutine finalize_bfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -1148,7 +1150,7 @@ subroutine finalize_bfr(this) call this%bfr%finalize() ! end subroutine finalize_bfr - + subroutine initialize_hfr(this) ! ****************************************************************************** ! initialize_hfr -- initalize the head file reader @@ -1157,7 +1159,7 @@ subroutine initialize_hfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -1167,7 +1169,7 @@ subroutine initialize_hfr(this) ! -- todo: need to run through the head terms ! and do some checking end subroutine initialize_hfr - + subroutine advance_hfr(this) ! ****************************************************************************** ! advance_hfr -- advance the head file reader @@ -1177,16 +1179,16 @@ subroutine advance_hfr(this) ! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B) :: nu, nr, i, ilay integer(I4B) :: ncpl real(DP) :: val logical :: readnext logical :: success - character(len=*), parameter :: fmtkstpkper = & - "(1x,/1x,'FMI READING HEAD FOR KSTP ', i0, ' KPER ', i0)" + character(len=*), parameter :: fmtkstpkper = & + &"(1x,/1x,'FMI READING HEAD FOR KSTP ', i0, ' KPER ', i0)" character(len=*), parameter :: fmthdskstpkper = & - "(1x,/1x, 'FMI SETTING HEAD FOR KSTP ', i0, ' AND KPER ', & + "(1x,/1x, 'FMI SETTING HEAD FOR KSTP ', i0, ' AND KPER ', & &i0, ' TO BINARY FILE HEADS FROM KSTP ', i0, ' AND KPER ', i0)" ! ------------------------------------------------------------------------------ ! @@ -1203,19 +1205,19 @@ subroutine advance_hfr(this) readnext = .false. end if else if (this%hfr%endoffile) then - write(errmsg,'(4x,a)') 'REACHED END OF GWF HEAD & + write (errmsg, '(4x,a)') 'REACHED END OF GWF HEAD & &FILE BEFORE READING SUFFICIENT HEAD INFORMATION FOR THIS & &GWT SIMULATION.' call store_error(errmsg) call store_error_unit(this%iuhds) - end if + end if end if ! ! -- Read the next record if (readnext) then ! ! -- write to list file that heads are being read - write(this%iout, fmtkstpkper) kstp, kper + write (this%iout, fmtkstpkper) kstp, kper ! ! -- loop through the layered heads for this time step do ilay = 1, this%hfr%nlay @@ -1223,32 +1225,32 @@ subroutine advance_hfr(this) ! -- read next head chunk call this%hfr%read_record(success, this%iout) if (.not. success) then - write(errmsg,'(4x,a)') 'GWF HEAD READ NOT SUCCESSFUL' + write (errmsg, '(4x,a)') 'GWF HEAD READ NOT SUCCESSFUL' call store_error(errmsg) call store_error_unit(this%iuhds) - endif + end if ! ! -- Ensure kper is same between model and head file if (kper /= this%hfr%kper) then - write(errmsg,'(4x,a)') 'PERIOD NUMBER IN HEAD FILE & + write (errmsg, '(4x,a)') 'PERIOD NUMBER IN HEAD FILE & &DOES NOT MATCH PERIOD NUMBER IN TRANSPORT MODEL. IF THERE & &IS MORE THAN ONE TIME STEP IN THE HEAD FILE FOR A GIVEN STRESS & &PERIOD, HEAD FILE TIME STEPS MUST MATCH GWT MODEL TIME STEPS & &ONE-FOR-ONE IN THAT STRESS PERIOD.' call store_error(errmsg) call store_error_unit(this%iuhds) - endif + end if ! ! -- if head file kstp > 1, then kstp must match if (this%hfr%kstp > 1 .and. (kstp /= this%hfr%kstp)) then - write(errmsg,'(4x,a)') 'TIME STEP NUMBER IN HEAD FILE & + write (errmsg, '(4x,a)') 'TIME STEP NUMBER IN HEAD FILE & &DOES NOT MATCH TIME STEP NUMBER IN TRANSPORT MODEL. IF THERE & &IS MORE THAN ONE TIME STEP IN THE HEAD FILE FOR A GIVEN STRESS & &PERIOD, HEAD FILE TIME STEPS MUST MATCH GWT MODEL TIME STEPS & &ONE-FOR-ONE IN THAT STRESS PERIOD.' call store_error(errmsg) call store_error_unit(this%iuhds) - endif + end if ! ! -- fill the head array for this layer and ! compress into reduced form @@ -1258,13 +1260,13 @@ subroutine advance_hfr(this) nr = this%dis%get_nodenumber(nu, 0) val = this%hfr%head(i) if (nr > 0) this%gwfhead(nr) = val - enddo + end do end do else - write(this%iout, fmthdskstpkper) kstp, kper, this%hfr%kstp, this%hfr%kper - endif + write (this%iout, fmthdskstpkper) kstp, kper, this%hfr%kstp, this%hfr%kper + end if end subroutine advance_hfr - + subroutine finalize_hfr(this) ! ****************************************************************************** ! finalize_hfr -- finalize the head file reader @@ -1273,15 +1275,15 @@ subroutine finalize_hfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy ! ------------------------------------------------------------------------------ ! ! -- Finalize the head file reader - close(this%iuhds) + close (this%iuhds) ! end subroutine finalize_hfr - + subroutine initialize_gwfterms_from_bfr(this) ! ****************************************************************************** ! initialize_gwfterms_from_bfr -- initalize terms and figure out how many @@ -1294,7 +1296,7 @@ subroutine initialize_gwfterms_from_bfr(this) use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local integer(I4B) :: nflowpack integer(I4B) :: i, ip @@ -1308,7 +1310,7 @@ subroutine initialize_gwfterms_from_bfr(this) ! ------------------------------------------------------------------------------ ! ! -- Calculate the number of gwf flow packages - allocate(imap(this%bfr%nbudterms)) + allocate (imap(this%bfr%nbudterms)) imap(:) = 0 nflowpack = 0 found_flowja = .false. @@ -1317,7 +1319,7 @@ subroutine initialize_gwfterms_from_bfr(this) found_stoss = .false. found_stosy = .false. do i = 1, this%bfr%nbudterms - select case(trim(adjustl(this%bfr%budtxtarray(i)))) + select case (trim(adjustl(this%bfr%budtxtarray(i)))) case ('FLOW-JA-FACE') found_flowja = .true. case ('DATA-SPDIS') @@ -1363,19 +1365,19 @@ subroutine initialize_gwfterms_from_bfr(this) ! ! -- Error if specific discharge, saturation or flowja not found if (.not. found_dataspdis) then - write(errmsg, '(4x,a)') 'SPECIFIC DISCHARGE NOT FOUND IN & + write (errmsg, '(4x,a)') 'SPECIFIC DISCHARGE NOT FOUND IN & &BUDGET FILE. SAVE_SPECIFIC_DISCHARGE AND & &SAVE_FLOWS MUST BE ACTIVATED IN THE NPF PACKAGE.' call store_error(errmsg) end if if (.not. found_datasat) then - write(errmsg, '(4x,a)') 'SATURATION NOT FOUND IN & + write (errmsg, '(4x,a)') 'SATURATION NOT FOUND IN & &BUDGET FILE. SAVE_SATURATION AND & &SAVE_FLOWS MUST BE ACTIVATED IN THE NPF PACKAGE.' call store_error(errmsg) end if if (.not. found_flowja) then - write(errmsg, '(4x,a)') 'FLOWJA NOT FOUND IN & + write (errmsg, '(4x,a)') 'FLOWJA NOT FOUND IN & &BUDGET FILE. SAVE_FLOWS MUST & &BE ACTIVATED IN THE NPF PACKAGE.' call store_error(errmsg) @@ -1387,7 +1389,7 @@ subroutine initialize_gwfterms_from_bfr(this) ! -- return return end subroutine initialize_gwfterms_from_bfr - + subroutine initialize_gwfterms_from_gwfbndlist(this) ! ****************************************************************************** ! initialize_gwfterms_from_gwfbndlist -- flows are coming from a gwf-gwt @@ -1399,7 +1401,7 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) ! -- modules use BndModule, only: BndType, GetBndFromList ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local integer(I4B) :: ngwfpack integer(I4B) :: ngwfterms @@ -1407,7 +1409,7 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) integer(I4B) :: imover integer(I4B) :: ntomvr integer(I4B) :: iterm - character (len=LENPACKAGENAME) :: budtxt + character(len=LENPACKAGENAME) :: budtxt class(BndType), pointer :: packobj => null() ! ------------------------------------------------------------------------------ ! @@ -1427,7 +1429,7 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) end if end do ! - ! -- Allocate arrays in fmi of size ngwfterms, which is the number of + ! -- Allocate arrays in fmi of size ngwfterms, which is the number of ! packages plus the number of packages with mover terms. ngwfterms = ngwfpack + ntomvr call this%allocate_gwfpackages(ngwfterms) @@ -1441,7 +1443,7 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) budtxt = adjustl(packobj%text) call this%gwfpackages(iterm)%set_name(packobj%packName, budtxt) this%flowpacknamearray(iterm) = packobj%packName - call this%gwfpackages(iterm)%set_auxname(packobj%naux, & + call this%gwfpackages(iterm)%set_auxname(packobj%naux, & packobj%auxname) iterm = iterm + 1 ! @@ -1450,10 +1452,10 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) imover = packobj%imover if (packobj%isadvpak /= 0) imover = 0 if (imover /= 0) then - budtxt = trim(adjustl(packobj%text)) // '-TO-MVR' + budtxt = trim(adjustl(packobj%text))//'-TO-MVR' call this%gwfpackages(iterm)%set_name(packobj%packName, budtxt) this%flowpacknamearray(iterm) = packobj%packName - call this%gwfpackages(iterm)%set_auxname(packobj%naux, & + call this%gwfpackages(iterm)%set_auxname(packobj%naux, & packobj%auxname) this%igwfmvrterm(iterm) = 1 iterm = iterm + 1 @@ -1461,10 +1463,10 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) end do return end subroutine initialize_gwfterms_from_gwfbndlist - + subroutine allocate_gwfpackages(this, ngwfterms) ! ****************************************************************************** -! allocate_gwfpackages -- gwfpackages is an array of PackageBudget objects. +! allocate_gwfpackages -- gwfpackages is an array of PackageBudget objects. ! This routine allocates gwfpackages to the proper size and initializes some ! member variables. ! ****************************************************************************** @@ -1475,7 +1477,7 @@ subroutine allocate_gwfpackages(this, ngwfterms) use ConstantsModule, only: LENMEMPATH use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: ngwfterms ! -- local integer(I4B) :: n @@ -1483,9 +1485,9 @@ subroutine allocate_gwfpackages(this, ngwfterms) ! ------------------------------------------------------------------------------ ! ! -- direct allocate - allocate(this%gwfpackages(ngwfterms)) - allocate(this%flowpacknamearray(ngwfterms)) - allocate(this%datp(ngwfterms)) + allocate (this%gwfpackages(ngwfterms)) + allocate (this%flowpacknamearray(ngwfterms)) + allocate (this%datp(ngwfterms)) ! ! -- mem_allocate call mem_allocate(this%iatp, ngwfterms, 'IATP', this%memoryPath) @@ -1498,16 +1500,16 @@ subroutine allocate_gwfpackages(this, ngwfterms) this%igwfmvrterm(n) = 0 this%flowpacknamearray(n) = '' ! - ! -- Create a mempath for each individual flow package data set + ! -- Create a mempath for each individual flow package data set ! of the form, MODELNAME/FMI-FTn - write(memPath, '(a, i0)') trim(this%memoryPath) // '-FT', n + write (memPath, '(a, i0)') trim(this%memoryPath)//'-FT', n call this%gwfpackages(n)%initialize(memPath) end do ! ! -- return return end subroutine allocate_gwfpackages - + subroutine deallocate_gwfpackages(this) ! ****************************************************************************** ! deallocate_gwfpackages -- memory in the gwfpackages array @@ -1517,7 +1519,7 @@ subroutine deallocate_gwfpackages(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local integer(I4B) :: n ! ------------------------------------------------------------------------------ @@ -1530,7 +1532,7 @@ subroutine deallocate_gwfpackages(this) ! -- return return end subroutine deallocate_gwfpackages - + subroutine get_package_index(this, name, idx) ! ****************************************************************************** ! get_package_index -- find the package index for package called name @@ -1539,7 +1541,7 @@ subroutine get_package_index(this, name, idx) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ use BndModule, only: BndType, GetBndFromList - class(GwtFmiType) :: this + class(TspFmiType) :: this character(len=*), intent(in) :: name integer(I4B), intent(inout) :: idx ! -- local @@ -1562,5 +1564,5 @@ subroutine get_package_index(this, name, idx) ! -- return return end subroutine get_package_index - -end module GwtFmiModule + +end module TspFmiModule diff --git a/src/Model/GroundWaterTransport/gwt1ic1.f90 b/src/Model/GroundWaterTransport/tsp1ic1.f90 similarity index 68% rename from src/Model/GroundWaterTransport/gwt1ic1.f90 rename to src/Model/GroundWaterTransport/tsp1ic1.f90 index c6aa511e37d..8875d2f16e6 100644 --- a/src/Model/GroundWaterTransport/gwt1ic1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ic1.f90 @@ -1,22 +1,22 @@ -module GwtIcModule - - use KindModule, only: DP, I4B - use GwfIcModule, only: GwfIcType - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType +module TspIcModule + + use KindModule, only: DP, I4B + use GwfIcModule, only: GwfIcType + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType implicit none private - public :: GwtIcType + public :: TspIcType public :: ic_cr - ! -- Most of the GwtIcType functionality comes from GwfIcType - type, extends(GwfIcType) :: GwtIcType + ! -- Most of the TspIcType functionality comes from GwfIcType + type, extends(GwfIcType) :: TspIcType contains procedure :: read_data - end type GwtIcType + end type TspIcType - contains +contains subroutine ic_cr(ic, name_model, inunit, iout, dis) ! ****************************************************************************** @@ -26,7 +26,7 @@ subroutine ic_cr(ic, name_model, inunit, iout, dis) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtIcType), pointer :: ic + type(TspIcType), pointer :: ic character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout @@ -34,7 +34,7 @@ subroutine ic_cr(ic, name_model, inunit, iout, dis) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(ic) + allocate (ic) ! ! -- create name and memory path call ic%set_names(1, name_model, 'IC', 'IC') @@ -63,10 +63,10 @@ subroutine read_data(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error ! -- dummy - class(GwtIcType) :: this + class(TspIcType) :: this ! -- local character(len=LINELENGTH) :: errmsg, keyword character(len=:), allocatable :: line @@ -81,8 +81,8 @@ subroutine read_data(this) ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING GRIDDATA' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -90,18 +90,18 @@ subroutine read_data(this) call this%parser%GetRemainingLine(line) lloc = 1 select case (keyword) - case ('STRT') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%strt, & - aname(1)) - case default - write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN GRIDDATA TAG: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('STRT') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%strt, & + aname(1)) + case default + write (errmsg, '(4x,a,a)') 'ERROR. UNKNOWN GRIDDATA TAG: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END PROCESSING GRIDDATA' + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' else call store_error('ERROR. REQUIRED GRIDDATA BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() @@ -110,7 +110,5 @@ subroutine read_data(this) ! -- Return return end subroutine read_data - - -end module GwtIcModule - \ No newline at end of file + +end module TspIcModule diff --git a/src/Model/GroundWaterTransport/gwt1mvt1.f90 b/src/Model/GroundWaterTransport/tsp1mvt1.f90 similarity index 81% rename from src/Model/GroundWaterTransport/gwt1mvt1.f90 rename to src/Model/GroundWaterTransport/tsp1mvt1.f90 index 1045983ff9a..a65b689e4f4 100644 --- a/src/Model/GroundWaterTransport/gwt1mvt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1mvt1.f90 @@ -1,40 +1,40 @@ ! -- Groundwater Transport Mover Module ! -- This module is responsible for sending mass from providers into ! -- receiver qmfrommvr arrays and writing a mover transport budget - -module GwtMvtModule - + +module TspMvtModule + use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, MAXCHARLEN, DZERO, LENPAKLOC, & DNODATA, LENPACKAGENAME, TABCENTER, LENMODELNAME - + use SimModule, only: store_error use BaseDisModule, only: DisBaseType use NumericalPackageModule, only: NumericalPackageType - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use BudgetModule, only: BudgetType, budget_cr use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr use TableModule, only: TableType, table_cr implicit none - + private - public :: GwtMvtType + public :: TspMvtType public :: mvt_cr - - type, extends(NumericalPackageType) :: GwtMvtType - character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of model 1 - character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of model 2 (set to modelname 1 for single model MVT) - integer(I4B), pointer :: maxpackages !< max number of packages - integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file - integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file - type(GwtFmiType), pointer :: fmi1 => null() !< pointer to fmi object for model 1 - type(GwtFmiType), pointer :: fmi2 => null() !< pointer to fmi object for model 2 (set to fmi1 for single model) - type(BudgetType), pointer :: budget => null() !< mover transport budget object (used to write balance table) - type(BudgetObjectType), pointer :: budobj => null() !< budget container (used to write binary file) - type(BudgetObjectType), pointer :: mvrbudobj => null() !< pointer to the water mover budget object - character(len=LENPACKAGENAME), & - dimension(:), pointer, contiguous :: paknames => null() !< array of package names + + type, extends(NumericalPackageType) :: TspMvtType + character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of model 1 + character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of model 2 (set to modelname 1 for single model MVT) + integer(I4B), pointer :: maxpackages !< max number of packages + integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file + integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + type(TspFmiType), pointer :: fmi1 => null() !< pointer to fmi object for model 1 + type(TspFmiType), pointer :: fmi2 => null() !< pointer to fmi object for model 2 (set to fmi1 for single model) + type(BudgetType), pointer :: budget => null() !< mover transport budget object (used to write balance table) + type(BudgetObjectType), pointer :: budobj => null() !< budget container (used to write binary file) + type(BudgetObjectType), pointer :: mvrbudobj => null() !< pointer to the water mover budget object + character(len=LENPACKAGENAME), & + dimension(:), pointer, contiguous :: paknames => null() !< array of package names ! ! -- table objects type(TableType), pointer :: outputtab => null() @@ -58,9 +58,9 @@ module GwtMvtModule procedure :: set_fmi_pr_rc procedure, private :: mvt_setup_outputtab procedure, private :: mvt_print_outputtab - end type GwtMvtType + end type TspMvtType - contains +contains subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & gwfmodelname2, fmi2) @@ -71,18 +71,18 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtMvtType), pointer :: mvt + type(TspMvtType), pointer :: mvt character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout - type(GwtFmiType), intent(in), target :: fmi1 + type(TspFmiType), intent(in), target :: fmi1 character(len=*), intent(in), optional :: gwfmodelname1 character(len=*), intent(in), optional :: gwfmodelname2 - type(GwtFmiType), intent(in), target, optional :: fmi2 + type(TspFmiType), intent(in), target, optional :: fmi2 ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(mvt) + allocate (mvt) ! ! -- create name and memory path call mvt%set_names(1, name_model, 'MVT', 'MVT') @@ -104,10 +104,10 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & ! ! -- set model names if (present(gwfmodelname1)) then - mvt%gwfmodelname1 = gwfmodelname1 + mvt%gwfmodelname1 = gwfmodelname1 end if if (present(gwfmodelname2)) then - mvt%gwfmodelname2 = gwfmodelname2 + mvt%gwfmodelname2 = gwfmodelname2 end if ! ! -- create the budget object @@ -126,12 +126,12 @@ subroutine mvt_df(this, dis) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this class(DisBaseType), pointer, intent(in) :: dis ! -- local ! -- formats - character(len=*), parameter :: fmtmvt = & - "(1x,/1x,'MVT -- MOVER TRANSPORT PACKAGE, VERSION 1, 4/15/2020', & + character(len=*), parameter :: fmtmvt = & + "(1x,/1x,'MVT -- MOVER TRANSPORT PACKAGE, VERSION 1, 4/15/2020', & &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! @@ -139,7 +139,7 @@ subroutine mvt_df(this, dis) this%dis => dis ! ! -- print a message identifying the MVT package. - write(this%iout, fmtmvt) this%inunit + write (this%iout, fmtmvt) this%inunit ! ! -- Initialize block parser call this%parser%Initialize(this%inunit, this%iout) @@ -153,7 +153,7 @@ subroutine mvt_df(this, dis) ! -- Return return end subroutine mvt_df - + !> @ brief Set pointer to mvrbudobj !! !! Store a pointer to mvrbudobj, which contains the simulated water @@ -162,11 +162,11 @@ end subroutine mvt_df !! !< subroutine set_pointer_mvrbudobj(this, mvrbudobj) - class(GwtMvtType) :: this + class(TspMvtType) :: this type(BudgetObjectType), intent(in), target :: mvrbudobj this%mvrbudobj => mvrbudobj end subroutine set_pointer_mvrbudobj - + subroutine mvt_ar(this) ! ****************************************************************************** ! mvt_ar -- Allocate and read water mover information @@ -176,7 +176,7 @@ subroutine mvt_ar(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this ! -- locals ! ------------------------------------------------------------------------------ ! @@ -197,7 +197,7 @@ subroutine mvt_rp(this) ! -- modules use TdisModule, only: kper, kstp ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this ! -- local ! -- formats ! ------------------------------------------------------------------------------ @@ -223,7 +223,7 @@ subroutine mvt_rp(this) ! -- Return return end subroutine mvt_rp - + subroutine mvt_fc(this, cnew1, cnew2) ! ****************************************************************************** ! mvt_fc -- Calculate coefficients and fill amat and rhs @@ -239,7 +239,7 @@ subroutine mvt_fc(this, cnew1, cnew2) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this real(DP), intent(in), dimension(:), contiguous, target :: cnew1 real(DP), intent(in), dimension(:), contiguous, target :: cnew2 ! -- local @@ -251,8 +251,8 @@ subroutine mvt_fc(this, cnew1, cnew2) real(DP) :: q, cp real(DP), dimension(:), pointer :: concpak real(DP), dimension(:), contiguous, pointer :: cnew - type(GwtFmiType), pointer :: fmi_pr !< pointer to provider model fmi package - type(GwtFmiType), pointer :: fmi_rc !< pointer to receiver model fmi package + type(TspFmiType), pointer :: fmi_pr !< pointer to provider model fmi package + type(TspFmiType), pointer :: fmi_rc !< pointer to receiver model fmi package ! ------------------------------------------------------------------------------ ! ! -- Add mover QC terms to the receiver packages @@ -302,17 +302,18 @@ subroutine mvt_fc(this, cnew1, cnew2) ! ! -- Provider is a regular stress package (WEL, DRN, RIV, etc.) or the ! provider is an advanced stress package but is not represented with - ! SFT, LKT, MWT, or UZT, so use the GWT cell concentration + ! SFT, LKT, MWT, or UZT, so use the GWT cell concentration igwtnode = fmi_pr%gwfpackages(ipr)%nodelist(id1) cp = cnew(igwtnode) - + end if ! ! -- add the mover rate times the provider concentration into the receiver ! make sure these are accumulated since multiple providers can move ! water into the same receiver if (fmi_rc%iatp(irc) /= 0) then - fmi_rc%datp(irc)%qmfrommvr(id2) = fmi_rc%datp(irc)%qmfrommvr(id2) - q * cp + fmi_rc%datp(irc)%qmfrommvr(id2) = fmi_rc%datp(irc)%qmfrommvr(id2) - & + q * cp end if end do end if @@ -321,23 +322,23 @@ subroutine mvt_fc(this, cnew1, cnew2) ! -- Return return end subroutine mvt_fc - + !> @ brief Set the fmi_pr and fmi_rc pointers !! !! The fmi_pr and fmi_rc arguments are pointers to the provider !! and receiver FMI Packages. If this MVT Package is owned by !! a single GWT model, then these pointers are both set to the !! FMI Package of this GWT model's FMI Package. If this MVT - !! Package is owned by a GWTGWT Exchange, then the fmi_pr and + !! Package is owned by a GWTGWT Exchange, then the fmi_pr and !! fmi_rc pointers may be assigned to FMI Packages in different models. !! !< subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this integer(I4B), intent(in) :: ibudterm - type(GwtFmiType), pointer :: fmi_pr - type(GwtFmiType), pointer :: fmi_rc + type(TspFmiType), pointer :: fmi_pr + type(TspFmiType), pointer :: fmi_rc fmi_pr => null() fmi_rc => null() @@ -349,7 +350,8 @@ subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) if (this%mvrbudobj%budterm(ibudterm)%text1id1 == this%gwfmodelname1) then ! -- model 1 is the provider fmi_pr => this%fmi1 - else if (this%mvrbudobj%budterm(ibudterm)%text1id1 == this%gwfmodelname2) then + else if (this%mvrbudobj%budterm(ibudterm)%text1id1 == & + this%gwfmodelname2) then ! -- model 2 is the provider fmi_pr => this%fmi2 else @@ -360,12 +362,13 @@ subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) print *, this%gwfmodelname2 stop "error in set_fmi_pr_rc" end if - + ! modelname for receiver is this%mvrbudobj%budterm(i)%text1id2 if (this%mvrbudobj%budterm(ibudterm)%text1id2 == this%gwfmodelname1) then ! -- model 1 is the receiver fmi_rc => this%fmi1 - else if (this%mvrbudobj%budterm(ibudterm)%text1id2 == this%gwfmodelname2) then + else if (this%mvrbudobj%budterm(ibudterm)%text1id2 == & + this%gwfmodelname2) then ! -- model 2 is the receiver fmi_rc => this%fmi2 else @@ -377,7 +380,7 @@ subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) stop "error in set_fmi_pr_rc" end if end if - + if (.not. associated(fmi_pr)) then print *, 'Could not find FMI Package...' stop "error in set_fmi_pr_rc" @@ -398,15 +401,15 @@ subroutine mvt_cc(this, kiter, iend, icnvgmod, cpak, dpak) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtMvtType) :: this - integer(I4B),intent(in) :: kiter - integer(I4B),intent(in) :: iend - integer(I4B),intent(in) :: icnvgmod + class(TspMvtType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod character(len=LENPAKLOC), intent(inout) :: cpak real(DP), intent(inout) :: dpak ! -- local ! -- formats - character(len=*),parameter :: fmtmvrcnvg = & + character(len=*), parameter :: fmtmvrcnvg = & "(/,1x,'MOVER PACKAGE REQUIRES AT LEAST TWO OUTER ITERATIONS. CONVERGE & &FLAG HAS BEEN RESET TO FALSE.')" ! ------------------------------------------------------------------------------ @@ -416,14 +419,14 @@ subroutine mvt_cc(this, kiter, iend, icnvgmod, cpak, dpak) if (icnvgmod == 1 .and. kiter == 1) then dpak = DNODATA cpak = trim(this%packName) - write(this%iout, fmtmvrcnvg) - endif - endif + write (this%iout, fmtmvrcnvg) + end if + end if ! ! -- return return end subroutine mvt_cc - + subroutine mvt_bd(this, cnew1, cnew2) ! ****************************************************************************** ! mvt_bd -- Write mover terms to listing file @@ -433,9 +436,9 @@ subroutine mvt_bd(this, cnew1, cnew2) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtMvtType) :: this - real(DP), dimension(:), contiguous, intent(in) :: cnew1 - real(DP), dimension(:), contiguous, intent(in) :: cnew2 + class(TspMvtType) :: this + real(DP), dimension(:), contiguous, intent(in) :: cnew1 + real(DP), dimension(:), contiguous, intent(in) :: cnew2 ! -- local ! ------------------------------------------------------------------------------ ! @@ -445,7 +448,7 @@ subroutine mvt_bd(this, cnew1, cnew2) ! -- return return end subroutine mvt_bd - + subroutine mvt_ot_saveflow(this, icbcfl, ibudfl) ! ****************************************************************************** ! mvt_bd -- Write mover terms @@ -454,9 +457,9 @@ subroutine mvt_ot_saveflow(this, icbcfl, ibudfl) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only : kstp, kper, delt, pertim, totim + use TdisModule, only: kstp, kper, delt, pertim, totim ! -- dummy - class(GwtMvttype) :: this + class(TspMvttype) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: ibudfl ! -- locals @@ -465,13 +468,13 @@ subroutine mvt_ot_saveflow(this, icbcfl, ibudfl) ! ! -- Save the mover flows from the budobj to a mover binary file ibinun = 0 - if(this%ibudgetout /= 0) then + if (this%ibudgetout /= 0) then ibinun = this%ibudgetout end if - if(icbcfl == 0) ibinun = 0 + if (icbcfl == 0) ibinun = 0 if (ibinun > 0) then call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, & - pertim, totim, this%iout) + pertim, totim, this%iout) end if ! ! -- Return @@ -487,7 +490,7 @@ subroutine mvt_ot_printflow(this, icbcfl, ibudfl) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: ibudfl ! -- locals @@ -513,7 +516,7 @@ subroutine mvt_ot_bdsummary(this, ibudfl) use TdisModule, only: kstp, kper, delt, totim use ArrayHandlersModule, only: ifind, expandarray ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this integer(I4B), intent(in) :: ibudfl ! -- locals integer(I4B) :: i, j, n @@ -521,42 +524,42 @@ subroutine mvt_ot_bdsummary(this, ibudfl) ! ------------------------------------------------------------------------------ ! ! -- Allocate and initialize ratin/ratout - allocate(ratin(this%maxpackages), ratout(this%maxpackages)) + allocate (ratin(this%maxpackages), ratout(this%maxpackages)) do j = 1, this%maxpackages ratin(j) = DZERO ratout(j) = DZERO - enddo + end do ! ! -- Accumulate the rates do i = 1, this%maxpackages - + do j = 1, this%budobj%nbudterm - + do n = 1, this%budobj%budterm(j)%nlist ! ! -- provider is inflow to mover - if(this%paknames(i) == this%budobj%budterm(j)%text2id1) then + if (this%paknames(i) == this%budobj%budterm(j)%text2id1) then ratin(i) = ratin(i) + this%budobj%budterm(j)%flow(n) - endif + end if ! ! -- receiver is outflow from mover - if(this%paknames(i) == this%budobj%budterm(j)%text2id2) then + if (this%paknames(i) == this%budobj%budterm(j)%text2id2) then ratout(i) = ratout(i) + this%budobj%budterm(j)%flow(n) - endif - + end if + end do - + end do - + end do - + ! ! -- Send rates to budget object call this%budget%reset() do j = 1, this%maxpackages call this%budget%addentry(ratin(j), ratout(j), delt, this%paknames(j)) - enddo + end do ! ! -- Write the budget if (ibudfl /= 0) then @@ -567,7 +570,7 @@ subroutine mvt_ot_bdsummary(this, ibudfl) call this%budget%writecsv(totim) ! ! -- Deallocate - deallocate(ratin, ratout) + deallocate (ratin, ratout) ! ! -- Output mvr budget ! Not using budobj write_table here because it would result @@ -589,32 +592,32 @@ subroutine mvt_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this ! -- local ! ------------------------------------------------------------------------------ ! ! -- Deallocate arrays if package was active - if(this%inunit > 0) then + if (this%inunit > 0) then ! ! -- character array - deallocate(this%paknames) + deallocate (this%paknames) ! ! -- budget object call this%budget%budget_da() - deallocate(this%budget) + deallocate (this%budget) ! ! -- budobj call this%budobj%budgetobject_da() - deallocate(this%budobj) - nullify(this%budobj) + deallocate (this%budobj) + nullify (this%budobj) ! ! -- output table object if (associated(this%outputtab)) then call this%outputtab%table_da() - deallocate(this%outputtab) - nullify(this%outputtab) + deallocate (this%outputtab) + nullify (this%outputtab) end if - endif + end if ! ! -- Scalars this%fmi1 => null() @@ -641,7 +644,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -673,16 +676,17 @@ subroutine read_options(this) use OpenSpecModule, only: access, form use InputOutputModule, only: getunit, openfile ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this ! -- local character(len=LINELENGTH) :: errmsg, keyword character(len=MAXCHARLEN) :: fname integer(I4B) :: ierr logical :: isfound, endOfBlock - character(len=*),parameter :: fmtflow = & - "(4x, a, 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I0)" - character(len=*),parameter :: fmtflow2 = & - "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE')" + character(len=*), parameter :: fmtflow = & + "(4x, a, 1x, a, 1x, ' WILL BE SAVED TO FILE: ', a, & + &/4x, 'OPENED ON UNIT: ', I0)" + character(len=*), parameter :: fmtflow2 = & + &"(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE')" ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -691,53 +695,54 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING MVT OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING MVT OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtflow2) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'MVT INPUT WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') & - 'MVT FLOWS WILL BE PRINTED TO LISTING FILE.' - case('BUDGET') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudgetout = getunit() - call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & - form, access, 'REPLACE') - write(this%iout,fmtflow) 'MVT', 'BUDGET', fname, this%ibudgetout - else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') - end if - case('BUDGETCSV') - call this%parser%GetStringCaps(keyword) - if (keyword == 'FILEOUT') then - call this%parser%GetString(fname) - this%ibudcsv = getunit() - call openfile(this%ibudcsv, this%iout, fname, 'CSV', & - filstat_opt='REPLACE') - write(this%iout,fmtflow) 'MVT', 'BUDGET CSV', fname, this%ibudcsv - else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & - &FILEOUT') - end if - case default - write(errmsg,'(4x,a,a)')'***ERROR. UNKNOWN MVT OPTION: ', & - trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtflow2) + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'MVT INPUT WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') & + 'MVT FLOWS WILL BE PRINTED TO LISTING FILE.' + case ('BUDGET') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudgetout = getunit() + call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write (this%iout, fmtflow) 'MVT', 'BUDGET', fname, this%ibudgetout + else + call store_error('OPTIONAL BUDGET KEYWORD MUST & + &BE FOLLOWED BY FILEOUT') + end if + case ('BUDGETCSV') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ibudcsv = getunit() + call openfile(this%ibudcsv, this%iout, fname, 'CSV', & + filstat_opt='REPLACE') + write (this%iout, fmtflow) 'MVT', 'BUDGET CSV', fname, this%ibudcsv + else + call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + &FILEOUT') + end if + case default + write (errmsg, '(4x,a,a)') '***ERROR. UNKNOWN MVT OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)') 'END OF MVT OPTIONS' + write (this%iout, '(1x,a)') 'END OF MVT OPTIONS' end if ! ! -- return @@ -754,15 +759,15 @@ subroutine mvt_setup_budobj(this) ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this ! -- local integer(I4B) :: nbudterm integer(I4B) :: ncv integer(I4B) :: maxlist integer(I4B) :: i integer(I4B) :: naux - character (len=LENMODELNAME) :: modelname1, modelname2 - character (len=LENPACKAGENAME) :: packagename1, packagename2 + character(len=LENMODELNAME) :: modelname1, modelname2 + character(len=LENPACKAGENAME) :: packagename1, packagename2 character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! @@ -791,7 +796,7 @@ subroutine mvt_setup_budobj(this) maxlist, .false., .false., & naux) end do - + ! ! -- return return @@ -806,12 +811,12 @@ subroutine mvt_fill_budobj(this, cnew1, cnew2) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtMvtType) :: this + class(TspMvtType) :: this real(DP), intent(in), dimension(:), contiguous, target :: cnew1 real(DP), intent(in), dimension(:), contiguous, target :: cnew2 ! -- local - type(GwtFmiType), pointer :: fmi_pr - type(GwtFmiType), pointer :: fmi_rc + type(TspFmiType), pointer :: fmi_pr + type(TspFmiType), pointer :: fmi_rc real(DP), dimension(:), contiguous, pointer :: cnew integer(I4B) :: nbudterm integer(I4B) :: nlist @@ -880,7 +885,7 @@ subroutine mvt_scan_mvrbudobj(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - class(GwtMvtType) :: this + class(TspMvtType) :: this integer(I4B) :: nbudterm integer(I4B) :: maxpackages integer(I4B) :: i, j @@ -899,7 +904,7 @@ subroutine mvt_scan_mvrbudobj(this) this%maxpackages = maxpackages ! ! -- allocate paknames - allocate(this%paknames(this%maxpackages)) + allocate (this%paknames(this%maxpackages)) do i = 1, this%maxpackages this%paknames(i) = '' end do @@ -923,7 +928,7 @@ subroutine mvt_scan_mvrbudobj(this) ! -- Return return end subroutine mvt_scan_mvrbudobj - + subroutine mvt_setup_outputtab(this) ! ****************************************************************************** ! mvt_setup_outputtab -- set up output table @@ -932,7 +937,7 @@ subroutine mvt_setup_outputtab(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtMvtType),intent(inout) :: this + class(TspMvtType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -949,15 +954,15 @@ subroutine mvt_setup_outputtab(this) maxrow = 0 ! ! -- initialize the output table object - title = 'TRANSPORT MOVER PACKAGE (' // trim(this%packName) // & + title = 'TRANSPORT MOVER PACKAGE ('//trim(this%packName)// & ') FLOW RATES' call table_cr(this%outputtab, this%packName, title) call this%outputtab%table_df(maxrow, ntabcol, this%iout, & - transient=.TRUE.) + transient=.TRUE.) text = 'NUMBER' call this%outputtab%initialize_column(text, 10, alignment=TABCENTER) text = 'PROVIDER LOCATION' - ilen = LENMODELNAME+LENPACKAGENAME+1 + ilen = LENMODELNAME + LENPACKAGENAME + 1 call this%outputtab%initialize_column(text, ilen) text = 'PROVIDER ID' call this%outputtab%initialize_column(text, 10) @@ -966,11 +971,11 @@ subroutine mvt_setup_outputtab(this) text = 'PROVIDER TRANSPORT RATE' call this%outputtab%initialize_column(text, 10) text = 'RECEIVER LOCATION' - ilen = LENMODELNAME+LENPACKAGENAME+1 + ilen = LENMODELNAME + LENPACKAGENAME + 1 call this%outputtab%initialize_column(text, ilen) text = 'RECEIVER ID' call this%outputtab%initialize_column(text, 10) - + end if ! ! -- return @@ -987,10 +992,10 @@ subroutine mvt_print_outputtab(this) ! -- module use TdisModule, only: kstp, kper ! -- dummy - class(GwtMvttype),intent(inout) :: this + class(TspMvttype), intent(inout) :: this ! -- local - character (len=LINELENGTH) :: title - character(len=LENMODELNAME+LENPACKAGENAME+1) :: cloc1, cloc2 + character(len=LINELENGTH) :: title + character(len=LENMODELNAME + LENPACKAGENAME + 1) :: cloc1, cloc2 integer(I4B) :: i integer(I4B) :: n integer(I4B) :: inum @@ -1009,7 +1014,7 @@ subroutine mvt_print_outputtab(this) call this%outputtab%set_kstpkper(kstp, kper) ! ! -- Add terms and print the table - title = 'TRANSPORT MOVER PACKAGE (' // trim(this%packName) // & + title = 'TRANSPORT MOVER PACKAGE ('//trim(this%packName)// & ') FLOW RATES' call this%outputtab%set_title(title) call this%outputtab%set_maxbound(ntabrows) @@ -1019,9 +1024,9 @@ subroutine mvt_print_outputtab(this) do i = 1, this%budobj%nbudterm nlist = this%budobj%budterm(i)%nlist do n = 1, nlist - cloc1 = trim(adjustl(this%budobj%budterm(i)%text1id1)) // ' ' // & + cloc1 = trim(adjustl(this%budobj%budterm(i)%text1id1))//' '// & trim(adjustl(this%budobj%budterm(i)%text2id1)) - cloc2 = trim(adjustl(this%budobj%budterm(i)%text1id2)) // ' ' // & + cloc2 = trim(adjustl(this%budobj%budterm(i)%text1id2))//' '// & trim(adjustl(this%budobj%budterm(i)%text2id2)) call this%outputtab%add_term(inum) call this%outputtab%add_term(cloc1) @@ -1038,5 +1043,5 @@ subroutine mvt_print_outputtab(this) return end subroutine mvt_print_outputtab -end module GwtMvtModule - \ No newline at end of file +end module TspMvtModule + diff --git a/src/Model/GroundWaterTransport/gwt1obs1.f90 b/src/Model/GroundWaterTransport/tsp1obs1.f90 similarity index 71% rename from src/Model/GroundWaterTransport/gwt1obs1.f90 rename to src/Model/GroundWaterTransport/tsp1obs1.f90 index 13645031db9..c0d7bcc3e58 100644 --- a/src/Model/GroundWaterTransport/gwt1obs1.f90 +++ b/src/Model/GroundWaterTransport/tsp1obs1.f90 @@ -1,39 +1,39 @@ -module GwtObsModule +module TspObsModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, MAXOBSTYPES - use BaseDisModule, only: DisBaseType - use GwtIcModule, only: GwtIcType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use SimModule, only: count_errors, store_error, & - store_error_unit + use KindModule, only: DP, I4B + use ConstantsModule, only: LINELENGTH, MAXOBSTYPES + use BaseDisModule, only: DisBaseType + use TspIcModule, only: TspIcType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, & + store_error_unit implicit none private - public :: GwtObsType, gwt_obs_cr + public :: TspObsType, tsp_obs_cr - type, extends(ObsType) :: GwtObsType + type, extends(ObsType) :: TspObsType ! -- Private members - type(GwtIcType), pointer, private :: ic => null() ! initial conditions - real(DP), dimension(:), pointer, contiguous, private :: x => null() ! concentration - real(DP), dimension(:), pointer, contiguous, private :: flowja => null() ! intercell flows + type(TspIcType), pointer, private :: ic => null() ! initial conditions + real(DP), dimension(:), pointer, contiguous, private :: x => null() ! concentration + real(DP), dimension(:), pointer, contiguous, private :: flowja => null() ! intercell flows contains ! -- Public procedures - procedure, public :: gwt_obs_ar - procedure, public :: obs_bd => gwt_obs_bd - procedure, public :: obs_df => gwt_obs_df - procedure, public :: obs_rp => gwt_obs_rp - procedure, public :: obs_da => gwt_obs_da + procedure, public :: tsp_obs_ar + procedure, public :: obs_bd => tsp_obs_bd + procedure, public :: obs_df => tsp_obs_df + procedure, public :: obs_rp => tsp_obs_rp + procedure, public :: obs_da => tsp_obs_da ! -- Private procedures procedure, private :: set_pointers - end type GwtObsType + end type TspObsType contains - subroutine gwt_obs_cr(obs, inobs) + subroutine tsp_obs_cr(obs, inobs) ! ****************************************************************************** -! gwt_obs_cr -- Create a new GwtObsType object +! tsp_obs_cr -- Create a new TspObsType object ! Subroutine: (1) creates object ! (2) allocates pointers ! (3) initializes values @@ -42,29 +42,29 @@ subroutine gwt_obs_cr(obs, inobs) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtObsType), pointer, intent(out) :: obs + type(TspObsType), pointer, intent(out) :: obs integer(I4B), pointer, intent(in) :: inobs ! ------------------------------------------------------------------------------ ! - allocate(obs) + allocate (obs) call obs%allocate_scalars() obs%active = .false. obs%inputFilename = '' obs%inUnitObs => inobs ! return - end subroutine gwt_obs_cr + end subroutine tsp_obs_cr - subroutine gwt_obs_ar(this, ic, x, flowja) + subroutine tsp_obs_ar(this, ic, x, flowja) ! ****************************************************************************** -! gwt_obs_ar -- allocate and read +! tsp_obs_ar -- allocate and read ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtObsType), intent(inout) :: this - type(GwtIcType), pointer, intent(in) :: ic + class(TspObsType), intent(inout) :: this + type(TspIcType), pointer, intent(in) :: ic real(DP), dimension(:), pointer, contiguous, intent(in) :: x real(DP), dimension(:), pointer, contiguous, intent(in) :: flowja ! ------------------------------------------------------------------------------ @@ -76,21 +76,21 @@ subroutine gwt_obs_ar(this, ic, x, flowja) call this%set_pointers(ic, x, flowja) ! return - end subroutine gwt_obs_ar + end subroutine tsp_obs_ar - subroutine gwt_obs_df(this, iout, pkgname, filtyp, dis) + subroutine tsp_obs_df(this, iout, pkgname, filtyp, dis) ! ****************************************************************************** -! gwt_obs_df -- define +! tsp_obs_df -- define ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtObsType), intent(inout) :: this + class(TspObsType), intent(inout) :: this integer(I4B), intent(in) :: iout character(len=*), intent(in) :: pkgname character(len=*), intent(in) :: filtyp - class(DisBaseType), pointer :: dis + class(DisBaseType), pointer :: dis ! -- local integer(I4B) :: indx ! ------------------------------------------------------------------------------ @@ -107,20 +107,20 @@ subroutine gwt_obs_df(this, iout, pkgname, filtyp, dis) ! ! -- Store obs type and assign procedure pointer for flow-ja-face observation type call this%StoreObsType('flow-ja-face', .true., indx) - this%obsData(indx)%ProcessIdPtr => gwt_process_intercell_obs_id + this%obsData(indx)%ProcessIdPtr => tsp_process_intercell_obs_id ! return - end subroutine gwt_obs_df + end subroutine tsp_obs_df - subroutine gwt_obs_bd(this) + subroutine tsp_obs_bd(this) ! ****************************************************************************** -! gwt_obs_bd -- save obs +! tsp_obs_bd -- save obs ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtObsType), intent(inout) :: this + class(TspObsType), intent(inout) :: this ! -- local integer(I4B) :: i, jaindex, nodenumber character(len=100) :: msg @@ -131,7 +131,7 @@ subroutine gwt_obs_bd(this) ! ! -- iterate through all GWT observations if (this%npakobs > 0) then - do i=1,this%npakobs + do i = 1, this%npakobs obsrv => this%pakobs(i)%obsrv nodenumber = obsrv%NodeNumber jaindex = obsrv%JaIndex @@ -141,48 +141,48 @@ subroutine gwt_obs_bd(this) case ('FLOW-JA-FACE') call this%SaveOneSimval(obsrv, this%flowja(jaindex)) case default - msg = 'Error: Unrecognized observation type: ' // trim(obsrv%ObsTypeId) + msg = 'Error: Unrecognized observation type: '//trim(obsrv%ObsTypeId) call store_error(msg) call store_error_unit(this%inUnitObs) end select - enddo - endif + end do + end if ! return - end subroutine gwt_obs_bd + end subroutine tsp_obs_bd - subroutine gwt_obs_rp(this) + subroutine tsp_obs_rp(this) ! ****************************************************************************** -! gwt_obs_rp +! tsp_obs_rp ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - class(GwtObsType), intent(inout) :: this + class(TspObsType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! Do GWT observations need any checking? If so, add checks here return - end subroutine gwt_obs_rp + end subroutine tsp_obs_rp - subroutine gwt_obs_da(this) + subroutine tsp_obs_da(this) ! ****************************************************************************** -! gwt_obs_da +! tsp_obs_da ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtObsType), intent(inout) :: this + class(TspObsType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! - nullify(this%ic) - nullify(this%x) - nullify(this%flowja) + nullify (this%ic) + nullify (this%x) + nullify (this%flowja) call this%ObsType%obs_da() ! return - end subroutine gwt_obs_da + end subroutine tsp_obs_da subroutine set_pointers(this, ic, x, flowja) ! ****************************************************************************** @@ -192,8 +192,8 @@ subroutine set_pointers(this, ic, x, flowja) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtObsType), intent(inout) :: this - type(GwtIcType), pointer, intent(in) :: ic + class(TspObsType), intent(inout) :: this + type(TspIcType), pointer, intent(in) :: ic real(DP), dimension(:), pointer, contiguous, intent(in) :: x real(DP), dimension(:), pointer, contiguous, intent(in) :: flowja ! ------------------------------------------------------------------------------ @@ -215,10 +215,10 @@ subroutine gwt_process_concentration_obs_id(obsrv, dis, inunitobs, iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1 integer(I4B) :: icol, istart, istop @@ -240,29 +240,29 @@ subroutine gwt_process_concentration_obs_id(obsrv, dis, inunitobs, iout) ermsg = 'Error reading data from ID string' call store_error(ermsg) call store_error_unit(inunitobs) - endif + end if ! return end subroutine gwt_process_concentration_obs_id - subroutine gwt_process_intercell_obs_id(obsrv, dis, inunitobs, iout) + subroutine tsp_process_intercell_obs_id(obsrv, dis, inunitobs, iout) ! ****************************************************************************** -! gwt_process_intercell_obs_id +! tsp_process_intercell_obs_id ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: nn1, nn2 integer(I4B) :: icol, istart, istop, jaidx character(len=LINELENGTH) :: ermsg, strng ! formats - 70 format('Error: No connection exists between cells identified in text: ',a) +70 format('Error: No connection exists between cells identified in text: ', a) ! ------------------------------------------------------------------------------ ! ! -- Initialize variables @@ -277,34 +277,34 @@ subroutine gwt_process_intercell_obs_id(obsrv, dis, inunitobs, iout) if (nn1 > 0) then obsrv%NodeNumber = nn1 else - ermsg = 'Error reading data from ID string: ' // strng(istart:istop) + ermsg = 'Error reading data from ID string: '//strng(istart:istop) call store_error(ermsg) - endif + end if ! ! Get node number, with option for ID string to be either node ! number or lay, row, column (when dis is structured). nn2 = dis%noder_from_string(icol, istart, istop, inunitobs, & - iout, strng, .false.) + iout, strng, .false.) if (nn2 > 0) then obsrv%NodeNumber2 = nn2 else - ermsg = 'Error reading data from ID string: ' // strng(istart:istop) + ermsg = 'Error reading data from ID string: '//strng(istart:istop) call store_error(ermsg) - endif + end if ! ! -- store JA index - jaidx = dis%con%getjaindex(nn1,nn2) - if (jaidx==0) then - write(ermsg,70)trim(strng) + jaidx = dis%con%getjaindex(nn1, nn2) + if (jaidx == 0) then + write (ermsg, 70) trim(strng) call store_error(ermsg) - endif + end if obsrv%JaIndex = jaidx ! if (count_errors() > 0) then call store_error_unit(inunitobs) - endif + end if ! return - end subroutine gwt_process_intercell_obs_id + end subroutine tsp_process_intercell_obs_id -end module GwtObsModule +end module TspObsModule diff --git a/src/Model/GroundWaterTransport/gwt1oc1.f90 b/src/Model/GroundWaterTransport/tsp1oc1.f90 similarity index 54% rename from src/Model/GroundWaterTransport/gwt1oc1.f90 rename to src/Model/GroundWaterTransport/tsp1oc1.f90 index 7d55fa3e6d1..53b24880f0e 100644 --- a/src/Model/GroundWaterTransport/gwt1oc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1oc1.f90 @@ -1,42 +1,42 @@ -module GwtOcModule +module TspOcModule - use BaseDisModule, only: DisBaseType - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME - use OutputControlModule, only: OutputControlType - use OutputControlDataModule, only: OutputControlDataType, ocd_cr + use BaseDisModule, only: DisBaseType + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME + use OutputControlModule, only: OutputControlType + use OutputControlDataModule, only: OutputControlDataType, ocd_cr implicit none private - public GwtOcType, oc_cr + public TspOcType, oc_cr !> @ brief Output control for GWT !! !! Concrete implementation of OutputControlType for the !! GWT Model !< - type, extends(OutputControlType) :: GwtOcType + type, extends(OutputControlType) :: TspOcType contains procedure :: oc_ar - end type GwtOcType - - contains + end type TspOcType + +contains - !> @ brief Create GwtOcType + !> @ brief Create TspOcType !! - !! Create by allocating a new GwtOcType object and initializing + !! Create by allocating a new TspOcType object and initializing !! member variables. !! !< subroutine oc_cr(ocobj, name_model, inunit, iout) ! -- dummy - type(GwtOcType), pointer :: ocobj !< GwtOcType object - character(len=*), intent(in) :: name_model !< name of the model - integer(I4B), intent(in) :: inunit !< unit number for input - integer(I4B), intent(in) :: iout !< unit number for output + type(TspOcType), pointer :: ocobj !< TspOcType object + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< unit number for input + integer(I4B), intent(in) :: iout !< unit number for output ! ! -- Create the object - allocate(ocobj) + allocate (ocobj) ! ! -- Allocate scalars call ocobj%allocate_scalars(name_model) @@ -52,49 +52,49 @@ subroutine oc_cr(ocobj, name_model, inunit, iout) return end subroutine oc_cr - !> @ brief Allocate and read GwtOcType + !> @ brief Allocate and read TspOcType !! !! Setup concentration and budget as output control variables. !! !< subroutine oc_ar(this, conc, dis, dnodata) ! -- dummy - class(GwtOcType) :: this !< GwtOcType object - real(DP), dimension(:), pointer, contiguous, intent(in) :: conc !< model concentration - class(DisBaseType), pointer, intent(in) :: dis !< model discretization package - real(DP), intent(in) :: dnodata !< no data value + class(TspOcType) :: this !< TspOcType object + real(DP), dimension(:), pointer, contiguous, intent(in) :: conc !< model concentration + class(DisBaseType), pointer, intent(in) :: dis !< model discretization package + real(DP), intent(in) :: dnodata !< no data value ! -- local integer(I4B) :: i, nocdobj, inodata - type(OutputControlDataType), pointer :: ocdobjptr + type(OutputControlDataType), pointer :: ocdobjptr real(DP), dimension(:), pointer, contiguous :: nullvec => null() ! ! -- Initialize variables inodata = 0 nocdobj = 2 - allocate(this%ocdobj(nocdobj)) + allocate (this%ocdobj(nocdobj)) do i = 1, nocdobj call ocd_cr(ocdobjptr) select case (i) case (1) - call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & this%iout, dnodata) case (2) - call ocdobjptr%init_dbl('CONCENTRATION', conc, dis, 'PRINT LAST ', & - 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & + call ocdobjptr%init_dbl('CONCENTRATION', conc, dis, 'PRINT LAST ', & + 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & this%iout, dnodata) end select this%ocdobj(i) = ocdobjptr - deallocate(ocdobjptr) - enddo + deallocate (ocdobjptr) + end do ! ! -- Read options or set defaults if this package not on - if(this%inunit > 0) then + if (this%inunit > 0) then call this%read_options() - endif + end if ! ! -- Return return end subroutine oc_ar - -end module GwtOcModule + +end module TspOcModule diff --git a/src/Model/GroundWaterTransport/gwt1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 similarity index 73% rename from src/Model/GroundWaterTransport/gwt1ssm1.f90 rename to src/Model/GroundWaterTransport/tsp1ssm1.f90 index 0bc5073c902..15d28dfd32e 100644 --- a/src/Model/GroundWaterTransport/gwt1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -1,51 +1,51 @@ -!> @brief This module contains the GwtSsm Module +!> @brief This module contains the TspSsm Module !! -!! This module contains the code for handling sources and sinks +!! This module contains the code for handling sources and sinks !! associated with groundwater flow model stress packages. !! !! todo: need observations for SSM terms !< -module GwtSsmModule - - use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: DONE, DZERO, LENAUXNAME, LENFTYPE, & - LENPACKAGENAME, LINELENGTH, & - TABLEFT, TABCENTER, LENBUDROWLABEL - use SimModule, only: store_error, count_errors, store_error_unit - use SimVariablesModule, only: errmsg +module TspSsmModule + + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: DONE, DZERO, LENAUXNAME, LENFTYPE, & + LENPACKAGENAME, LINELENGTH, & + TABLEFT, TABCENTER, LENBUDROWLABEL + use SimModule, only: store_error, count_errors, store_error_unit + use SimVariablesModule, only: errmsg use NumericalPackageModule, only: NumericalPackageType - use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType - use TableModule, only: TableType, table_cr - use GwtSpcModule, only: GwtSpcType - + use BaseDisModule, only: DisBaseType + use TspFmiModule, only: TspFmiType + use TableModule, only: TableType, table_cr + use GwtSpcModule, only: GwtSpcType + implicit none - public :: GwtSsmType + public :: TspSsmType public :: ssm_cr - character(len=LENFTYPE) :: ftype = 'SSM' - character(len=LENPACKAGENAME) :: text = ' SOURCE-SINK MIX' + character(len=LENFTYPE) :: ftype = 'SSM' + character(len=LENPACKAGENAME) :: text = ' SOURCE-SINK MIX' - !> @brief Derived type for the SSM Package + !> @brief Derived type for the SSM Package !! !! This derived type corresponds to the SSM Package, which adds !! the effects of groundwater sources and sinks to the solute transport - !! equation. + !! equation. !! !< - type, extends(NumericalPackageType) :: GwtSsmType - - integer(I4B), pointer :: nbound !< total number of flow boundaries in this time step - integer(I4B), dimension(:), pointer, contiguous :: isrctype => null() !< source type 0 is unspecified, 1 is aux, 2 is auxmixed, 3 is ssmi, 4 is ssmimixed - integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - real(DP), dimension(:), pointer, contiguous :: cnew => null() !< pointer to gwt%x - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object - type(TableType), pointer :: outputtab => null() !< output table object - type(GwtSpcType), dimension(:), pointer :: ssmivec => null() !< array of stress package concentration objects - + type, extends(NumericalPackageType) :: TspSsmType + + integer(I4B), pointer :: nbound !< total number of flow boundaries in this time step + integer(I4B), dimension(:), pointer, contiguous :: isrctype => null() !< source type 0 is unspecified, 1 is aux, 2 is auxmixed, 3 is ssmi, 4 is ssmimixed + integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + real(DP), dimension(:), pointer, contiguous :: cnew => null() !< pointer to gwt%x + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + type(TableType), pointer :: outputtab => null() !< output table object + type(GwtSpcType), dimension(:), pointer :: ssmivec => null() !< array of stress package concentration objects + contains - + procedure :: ssm_df procedure :: ssm_ar procedure :: ssm_rp @@ -66,27 +66,27 @@ module GwtSsmModule procedure, private :: set_iauxpak procedure, private :: set_ssmivec procedure, private :: get_ssm_conc - - end type GwtSsmType - - contains - + + end type TspSsmType + +contains + !> @ brief Create a new SSM package !! !! Create a new SSM package by defining names, allocating scalars - !! and initializing the parser. + !! and initializing the parser. !! !< subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) ! -- dummy - type(GwtSsmType), pointer :: ssmobj !< GwtSsmType object - character(len=*), intent(in) :: name_model !< name of the model - integer(I4B), intent(in) :: inunit !< fortran unit for input - integer(I4B), intent(in) :: iout !< fortran unit for output - type(GwtFmiType), intent(in), target :: fmi !< GWT FMI package + type(TspSsmType), pointer :: ssmobj !< TspSsmType object + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< fortran unit for input + integer(I4B), intent(in) :: iout !< fortran unit for output + type(TspFmiType), intent(in), target :: fmi !< GWT FMI package ! ! -- Create the object - allocate(ssmobj) + allocate (ssmobj) ! ! -- create name and memory path call ssmobj%set_names(1, name_model, 'SSM', 'SSM') @@ -117,7 +117,7 @@ subroutine ssm_df(this) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local ! -- formats ! @@ -135,27 +135,27 @@ subroutine ssm_ar(this, dis, ibound, cnew) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object - class(DisBaseType), pointer, intent(in) :: dis !< discretization package - integer(I4B), dimension(:), pointer, contiguous :: ibound !< GWT model ibound - real(DP), dimension(:), pointer, contiguous :: cnew !< GWT model dependent variable + class(TspSsmType) :: this !< TspSsmType object + class(DisBaseType), pointer, intent(in) :: dis !< discretization package + integer(I4B), dimension(:), pointer, contiguous :: ibound !< GWT model ibound + real(DP), dimension(:), pointer, contiguous :: cnew !< GWT model dependent variable ! -- local ! -- formats - character(len=*), parameter :: fmtssm = & - "(1x,/1x,'SSM -- SOURCE-SINK MIXING PACKAGE, VERSION 1, 8/25/2017', & + character(len=*), parameter :: fmtssm = & + "(1x,/1x,'SSM -- SOURCE-SINK MIXING PACKAGE, VERSION 1, 8/25/2017', & &' INPUT READ FROM UNIT ', i0, //)" ! ! --print a message identifying the storage package. - write(this%iout, fmtssm) this%inunit + write (this%iout, fmtssm) this%inunit ! ! -- store pointers to arguments that were passed in - this%dis => dis - this%ibound => ibound - this%cnew => cnew + this%dis => dis + this%ibound => ibound + this%cnew => cnew ! ! -- Check to make sure that there are flow packages if (this%fmi%nflowpack == 0) then - write(errmsg, '(a)') 'SSM PACKAGE DOES NOT DETECT ANY BOUNDARY FLOWS & + write (errmsg, '(a)') 'SSM PACKAGE DOES NOT DETECT ANY BOUNDARY FLOWS & &THAT REQUIRE SSM TERMS. ACTIVATE GWF-GWT & &EXCHANGE OR ACTIVATE FMI PACKAGE AND PROVIDE A & &BUDGET FILE THAT CONTAINS BOUNDARY FLOWS. IF NO & @@ -163,7 +163,7 @@ subroutine ssm_ar(this, dis, ibound, cnew) &MODEL THEN THIS SSM PACKAGE SHOULD BE REMOVED.' call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Allocate arrays call this%allocate_arrays() @@ -192,7 +192,7 @@ end subroutine ssm_ar subroutine ssm_rp(this) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -223,7 +223,7 @@ end subroutine ssm_rp subroutine ssm_ad(this) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -245,13 +245,13 @@ subroutine ssm_ad(this) end do end do ! - ! -- Call the ad method on any ssm input files so that values for + ! -- Call the ad method on any ssm input files so that values for ! time-series are interpolated do ip = 1, this%fmi%nflowpack if (this%fmi%iatp(ip) /= 0) cycle if (this%isrctype(ip) == 3 .or. this%isrctype(ip) == 4) then ssmiptr => this%ssmivec(ip) - call ssmiptr%spc_ad(this%fmi%gwfpackages(ip)%nbound, & + call ssmiptr%spc_ad(this%fmi%gwfpackages(ip)%nbound, & this%fmi%gwfpackages(ip)%budtxt) end if end do @@ -259,26 +259,26 @@ subroutine ssm_ad(this) ! -- Return return end subroutine ssm_ad - + !> @ brief Calculate the SSM mass flow rate and hcof and rhs values !! !! This is the primary SSM routine that calculates the matrix coefficient !! and right-hand-side value for any package and package entry. It returns - !! several different optional variables that are used throughout this + !! several different optional variables that are used throughout this !! package to update matrix terms, budget calculations, and output tables. !! !< - subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & + subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & cssm, qssm) ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType - integer(I4B), intent(in) :: ipackage !< package number - integer(I4B), intent(in) :: ientry !< bound number - real(DP), intent(out), optional :: rrate !< calculated mass flow rate - real(DP), intent(out), optional :: rhsval !< calculated rhs value - real(DP), intent(out), optional :: hcofval !< calculated hcof value - real(DP), intent(out), optional :: cssm !< calculated source concentration depending on flow direction - real(DP), intent(out), optional :: qssm !< water flow rate into model cell from boundary package + class(TspSsmType) :: this !< TspSsmType + integer(I4B), intent(in) :: ipackage !< package number + integer(I4B), intent(in) :: ientry !< bound number + real(DP), intent(out), optional :: rrate !< calculated mass flow rate + real(DP), intent(out), optional :: rhsval !< calculated rhs value + real(DP), intent(out), optional :: hcofval !< calculated hcof value + real(DP), intent(out), optional :: cssm !< calculated source concentration depending on flow direction + real(DP), intent(out), optional :: qssm !< water flow rate into model cell from boundary package ! -- local logical(LGP) :: lauxmixed integer(I4B) :: n @@ -303,46 +303,46 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & call this%get_ssm_conc(ipackage, ientry, ctmp, lauxmixed) ! ! -- assign values for hcoftmp, rhstmp, and ctmp for subsequent assigment - ! of hcof, rhs, and rate - if(.not. lauxmixed) then + ! of hcof, rhs, and rate + if (.not. lauxmixed) then ! - ! -- If qbnd is positive, then concentration represents the inflow + ! -- If qbnd is positive, then concentration represents the inflow ! concentration. If qbnd is negative, then the outflow concentration ! is set equal to the simulated cell concentration if (qbnd >= DZERO) then - omega = DZERO ! rhs + omega = DZERO ! rhs else ctmp = this%cnew(n) - omega = DONE ! lhs + omega = DONE ! lhs if (ctmp < DZERO) then omega = DZERO ! concentration is negative, so set mass flux to zero end if end if else ! - ! -- lauxmixed value indicates that this is a mixed sink type where - ! the concentration value represents the injected concentration if - ! qbnd is positive. If qbnd is negative, then the withdrawn water - ! is equal to the minimum of the aux concentration and the cell + ! -- lauxmixed value indicates that this is a mixed sink type where + ! the concentration value represents the injected concentration if + ! qbnd is positive. If qbnd is negative, then the withdrawn water + ! is equal to the minimum of the aux concentration and the cell ! concentration. if (qbnd >= DZERO) then - omega = DZERO ! rhs (ctmp is aux value) + omega = DZERO ! rhs (ctmp is aux value) else if (ctmp < this%cnew(n)) then - omega = DZERO ! rhs (ctmp is aux value) + omega = DZERO ! rhs (ctmp is aux value) else omega = DONE ! lhs (ctmp is cell concentration) ctmp = this%cnew(n) end if end if - endif + end if ! ! -- Add terms based on qbnd sign - if(qbnd <= DZERO) then + if (qbnd <= DZERO) then hcoftmp = qbnd * omega else rhstmp = -qbnd * ctmp * (DONE - omega) - endif + end if ! ! -- end of active ibound end if @@ -357,44 +357,44 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! -- return return end subroutine ssm_term - + !> @ brief Provide bound concentration and mixed flag !! !! SSM concentrations can be provided in auxiliary variables or !! through separate SPC files. If not provided, the default !! concentration is zero. This single routine provides the SSM !! bound concentration based on these different approaches. - !! The mixed flag indicates whether or not + !! The mixed flag indicates whether or not !! !< subroutine get_ssm_conc(this, ipackage, ientry, conc, lauxmixed) ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType - integer(I4B), intent(in) :: ipackage !< package number - integer(I4B), intent(in) :: ientry !< bound number - real(DP), intent(out) :: conc !< user-specified concentration for this bound - logical(LGP), intent(out) :: lauxmixed !< user-specified flag for marking this as a mixed boundary + class(TspSsmType) :: this !< TspSsmType + integer(I4B), intent(in) :: ipackage !< package number + integer(I4B), intent(in) :: ientry !< bound number + real(DP), intent(out) :: conc !< user-specified concentration for this bound + logical(LGP), intent(out) :: lauxmixed !< user-specified flag for marking this as a mixed boundary ! -- local integer(I4B) :: isrctype integer(I4B) :: iauxpos - + conc = DZERO lauxmixed = .false. isrctype = this%isrctype(ipackage) - - select case(isrctype) - case(1, 2) + + select case (isrctype) + case (1, 2) iauxpos = this%iauxpak(ipackage) conc = this%fmi%gwfpackages(ipackage)%auxvar(iauxpos, ientry) if (isrctype == 2) lauxmixed = .true. - case(3, 4) + case (3, 4) conc = this%ssmivec(ipackage)%get_value(ientry) if (isrctype == 4) lauxmixed = .true. end select - + return end subroutine get_ssm_conc - + !> @ brief Fill coefficients !! !! This routine adds the effects of the SSM to the matrix equations by @@ -404,7 +404,7 @@ end subroutine get_ssm_conc subroutine ssm_fc(this, amatsln, idxglo, rhs) ! -- modules ! -- dummy - class(GwtSsmType) :: this + class(TspSsmType) :: this real(DP), dimension(:), intent(inout) :: amatsln integer(I4B), intent(in), dimension(:) :: idxglo real(DP), intent(inout), dimension(:) :: rhs @@ -433,14 +433,14 @@ subroutine ssm_fc(this, amatsln, idxglo, rhs) amatsln(idiag) = amatsln(idiag) + hcofval rhs(n) = rhs(n) + rhsval ! - enddo + end do ! - enddo + end do ! ! -- Return return end subroutine ssm_fc - + !> @ brief Calculate flow !! !! Calulate the resulting mass flow between the boundary and the connected @@ -451,8 +451,8 @@ end subroutine ssm_fc subroutine ssm_cq(this, flowja) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow across each face in the model grid + class(TspSsmType) :: this !< TspSsmType object + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow across each face in the model grid ! -- local integer(I4B) :: ip integer(I4B) :: i @@ -474,9 +474,9 @@ subroutine ssm_cq(this, flowja) idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate ! - enddo + end do ! - enddo + end do ! ! -- Return return @@ -493,9 +493,9 @@ subroutine ssm_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object - integer(I4B), intent(in) :: isuppress_output !< flag to suppress output - type(BudgetType), intent(inout) :: model_budget !< budget object for the GWT model + class(TspSsmType) :: this !< TspSsmType object + integer(I4B), intent(in) :: isuppress_output !< flag to suppress output + type(BudgetType), intent(inout) :: model_budget !< budget object for the GWT model ! -- local character(len=LENBUDROWLABEL) :: rowlabel integer(I4B) :: ip @@ -521,19 +521,19 @@ subroutine ssm_bd(this, isuppress_output, model_budget) n = this%fmi%gwfpackages(ip)%nodelist(i) if (n <= 0) cycle call this%ssm_term(ip, i, rrate=rate) - if(rate < DZERO) then + if (rate < DZERO) then rout = rout - rate else rin = rin + rate - endif + end if ! - enddo + end do ! - rowlabel = 'SSM_' // adjustl(trim(this%fmi%flowpacknamearray(ip))) - call model_budget%addentry(rin, rout, delt, & - this%fmi%gwfpackages(ip)%budtxt, & + rowlabel = 'SSM_'//adjustl(trim(this%fmi%flowpacknamearray(ip))) + call model_budget%addentry(rin, rout, delt, & + this%fmi%gwfpackages(ip)%budtxt, & isuppress_output, rowlabel=rowlabel) - enddo + end do ! ! -- Return return @@ -551,12 +551,12 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) use TdisModule, only: kstp, kper use ConstantsModule, only: LENPACKAGENAME, LENBOUNDNAME, LENAUXNAME, DZERO ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object - integer(I4B), intent(in) :: icbcfl !< flag for writing binary budget terms - integer(I4B), intent(in) :: ibudfl !< flag for printing budget terms to list file - integer(I4B), intent(in) :: icbcun !< fortran unit number for binary budget file + class(TspSsmType) :: this !< TspSsmType object + integer(I4B), intent(in) :: icbcfl !< flag for writing binary budget terms + integer(I4B), intent(in) :: ibudfl !< flag for printing budget terms to list file + integer(I4B), intent(in) :: icbcun !< fortran unit number for binary budget file ! -- local - character (len=LINELENGTH) :: title + character(len=LINELENGTH) :: title integer(I4B) :: node, nodeu character(len=20) :: nodestr integer(I4B) :: maxrows @@ -566,13 +566,13 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) real(DP) :: qssm real(DP) :: cssm integer(I4B) :: naux - real(DP), dimension(0,0) :: auxvar + real(DP), dimension(0, 0) :: auxvar character(len=LENAUXNAME), dimension(0) :: auxname ! -- for observations character(len=LENBOUNDNAME) :: bname ! -- formats character(len=*), parameter :: fmttkk = & - "(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" + &"(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)" ! ! -- set maxrows maxrows = 0 @@ -592,7 +592,7 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) if (maxrows > 0) then call this%outputtab%set_maxbound(maxrows) end if - title = 'SSM PACKAGE (' // trim(this%packName) // & + title = 'SSM PACKAGE ('//trim(this%packName)// & ') FLOW RATES' call this%outputtab%set_title(title) end if @@ -608,15 +608,16 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) if (icbcfl == 0) ibinun = 0 ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun /= 0) then + if (ibinun /= 0) then naux = 0 - call this%dis%record_srcdst_list_header(text, this%name_model, & - this%name_model, this%name_model, this%packName, naux, & - auxname, ibinun, this%nbound, this%iout) - endif + call this%dis%record_srcdst_list_header(text, this%name_model, & + this%name_model, this%name_model, & + this%packName, naux, auxname, & + ibinun, this%nbound, this%iout) + end if ! ! -- If no boundaries, skip flow calculations. - if(this%nbound > 0) then + if (this%nbound > 0) then ! ! -- Loop through each boundary calculating flow. do ip = 1, this%fmi%nflowpack @@ -651,18 +652,18 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) ! -- If saving cell-by-cell flows in list, write flow if (ibinun /= 0) then n2 = i - call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & - naux, auxvar(:,i), & + call this%dis%record_mf6_list_entry(ibinun, node, n2, rrate, & + naux, auxvar(:, i), & olconv2=.FALSE.) end if ! - enddo + end do ! - enddo - endif + end do + end if if (ibudfl /= 0) then if (this%iprflow /= 0) then - write(this%iout,'(1x)') + write (this%iout, '(1x)') end if end if ! @@ -679,35 +680,35 @@ subroutine ssm_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr ! ! -- Deallocate the ssmi objects if package was active - if(this%inunit > 0) then + if (this%inunit > 0) then do ip = 1, size(this%ssmivec) if (this%isrctype(ip) == 3 .or. this%isrctype(ip) == 4) then ssmiptr => this%ssmivec(ip) call ssmiptr%spc_da() end if end do - deallocate(this%ssmivec) + deallocate (this%ssmivec) end if ! ! -- Deallocate arrays if package was active - if(this%inunit > 0) then + if (this%inunit > 0) then call mem_deallocate(this%iauxpak) call mem_deallocate(this%isrctype) this%ibound => null() this%fmi => null() - endif + end if ! ! -- output table object if (associated(this%outputtab)) then call this%outputtab%table_da() - deallocate(this%outputtab) - nullify(this%outputtab) + deallocate (this%outputtab) + nullify (this%outputtab) end if ! ! -- Scalars @@ -729,7 +730,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local ! ! -- allocate scalars in NumericalPackageType @@ -754,11 +755,11 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: nflowpack integer(I4B) :: i - ! + ! ! -- Allocate nflowpack = this%fmi%nflowpack call mem_allocate(this%iauxpak, nflowpack, 'IAUXPAK', this%memoryPath) @@ -771,12 +772,12 @@ subroutine allocate_arrays(this) end do ! ! -- Allocate the ssmivec array - allocate(this%ssmivec(nflowpack)) + allocate (this%ssmivec(nflowpack)) ! ! -- Return return end subroutine allocate_arrays - + !> @ brief Read package options !! !! Read and set the SSM Package options @@ -785,18 +786,18 @@ end subroutine allocate_arrays subroutine read_options(this) ! -- modules ! -- dummy - class(GwtSSMType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtiprflow = & - "(4x,'SSM FLOW INFORMATION WILL BE PRINTED TO LISTING FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" - character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE " // & - "WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtiprflow = & + "(4x,'SSM FLOW INFORMATION WILL BE PRINTED TO LISTING FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE & + &WHENEVER ICBCFL IS NOT ZERO.')" ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & @@ -804,25 +805,25 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING SSM OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING SSM OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout, fmtiprflow) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtisvflow) - case default - write(errmsg,'(4x,a,a)') 'UNKNOWN SSM OPTION: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, fmtiprflow) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtisvflow) + case default + write (errmsg, '(4x,a,a)') 'UNKNOWN SSM OPTION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF SSM OPTIONS' + write (this%iout, '(1x,a)') 'END OF SSM OPTIONS' end if ! ! -- Return @@ -836,7 +837,7 @@ end subroutine read_options !< subroutine read_data(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! ! -- read and process required SOURCES block call this%read_sources_aux() @@ -845,7 +846,7 @@ subroutine read_data(this) call this%read_sources_fileinput() return end subroutine read_data - + !> @ brief Read SOURCES block !! !! Read SOURCES block and look for auxiliary columns in @@ -854,7 +855,7 @@ end subroutine read_data !< subroutine read_sources_aux(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword character(len=20) :: srctype @@ -874,11 +875,11 @@ subroutine read_sources_aux(this) nflowpack = this%fmi%nflowpack ! ! -- get sources block - call this%parser%GetBlock('SOURCES', isfound, ierr, & - supportOpenClose=.true., & + call this%parser%GetBlock('SOURCES', isfound, ierr, & + supportOpenClose=.true., & blockrequired=.true.) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING SOURCES' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING SOURCES' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -890,18 +891,18 @@ subroutine read_sources_aux(this) if (trim(adjustl(this%fmi%gwfpackages(ip)%name)) == keyword) then pakfound = .true. exit - endif - enddo + end if + end do if (.not. pakfound) then - write(errmsg,'(1x, a, a)') 'FLOW PACKAGE CANNOT BE FOUND: ', & - trim(keyword) + write (errmsg, '(1x, a, a)') 'FLOW PACKAGE CANNOT BE FOUND: ', & + trim(keyword) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Ensure package was not specified more than once in SOURCES block if (this%isrctype(ip) /= 0) then - write(errmsg,'(1x, a, a)') & + write (errmsg, '(1x, a, a)') & 'A PACKAGE CANNOT BE SPECIFIED MORE THAN ONCE IN THE SSM SOURCES & &BLOCK. THE FOLLOWING PACKAGE WAS SPECIFIED MORE THAN ONCE: ', & trim(keyword) @@ -911,16 +912,16 @@ subroutine read_sources_aux(this) ! ! -- read the source type call this%parser%GetStringCaps(srctype) - select case(srctype) - case('AUX') - write(this%iout,'(1x,a)') 'AUX SOURCE DETECTED.' + select case (srctype) + case ('AUX') + write (this%iout, '(1x,a)') 'AUX SOURCE DETECTED.' isrctype = 1 - case('AUXMIXED') - write(this%iout,'(1x,a)') 'AUXMIXED SOURCE DETECTED.' + case ('AUXMIXED') + write (this%iout, '(1x,a)') 'AUXMIXED SOURCE DETECTED.' lauxmixed = .true. isrctype = 2 case default - write(errmsg,'(1x, a, a)') & + write (errmsg, '(1x, a, a)') & 'SRCTYPE MUST BE AUX OR AUXMIXED. FOUND: ', trim(srctype) call store_error(errmsg) call this%parser%StoreErrorUnit() @@ -931,24 +932,24 @@ subroutine read_sources_aux(this) ! ! -- Find and store the auxiliary column call this%set_iauxpak(ip, trim(keyword)) - + end do - write(this%iout,'(1x,a)')'END PROCESSING SOURCES' + write (this%iout, '(1x,a)') 'END PROCESSING SOURCES' else - write(errmsg,'(1x,a)')'ERROR. REQUIRED SOURCES BLOCK NOT FOUND.' + write (errmsg, '(1x,a)') 'ERROR. REQUIRED SOURCES BLOCK NOT FOUND.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if ! ! -- terminate if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return end subroutine read_sources_aux - + !> @ brief Read FILEINPUT block !! !! Read optional FILEINPUT block and initialize an @@ -957,7 +958,7 @@ end subroutine read_sources_aux !< subroutine read_sources_fileinput(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword character(len=LINELENGTH) :: keyword2 @@ -978,11 +979,11 @@ subroutine read_sources_fileinput(this) nflowpack = this%fmi%nflowpack ! ! -- get sources_file block - call this%parser%GetBlock('FILEINPUT', isfound, ierr, & - supportOpenClose=.true., & + call this%parser%GetBlock('FILEINPUT', isfound, ierr, & + supportOpenClose=.true., & blockrequired=.false.) - if(isfound) then - write(this%iout,'(1x,a)')'PROCESSING FILEINPUT' + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING FILEINPUT' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -994,18 +995,18 @@ subroutine read_sources_fileinput(this) if (trim(adjustl(this%fmi%gwfpackages(ip)%name)) == keyword) then pakfound = .true. exit - endif - enddo + end if + end do if (.not. pakfound) then - write(errmsg,'(1x, a, a)') 'FLOW PACKAGE CANNOT BE FOUND: ', & - trim(keyword) + write (errmsg, '(1x, a, a)') 'FLOW PACKAGE CANNOT BE FOUND: ', & + trim(keyword) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- Ensure package was not specified more than once in SOURCES block if (this%isrctype(ip) /= 0) then - write(errmsg,'(1x, a, a)') & + write (errmsg, '(1x, a, a)') & 'A PACKAGE CANNOT BE SPECIFIED MORE THAN ONCE IN THE SSM SOURCES & &AND SOURCES_FILES BLOCKS. THE FOLLOWING PACKAGE WAS SPECIFIED & &MORE THAN ONCE: ', & @@ -1016,16 +1017,16 @@ subroutine read_sources_fileinput(this) ! ! -- read the source type call this%parser%GetStringCaps(srctype) - select case(srctype) - case('SPC6') - write(this%iout,'(1x,a)') 'SPC6 SOURCE DETECTED.' + select case (srctype) + case ('SPC6') + write (this%iout, '(1x,a)') 'SPC6 SOURCE DETECTED.' isrctype = 3 ! ! verify filein is next call this%parser%GetStringCaps(keyword2) - if(trim(adjustl(keyword2)) /= 'FILEIN') then - errmsg = 'SPC6 keyword must be followed by "FILEIN" ' // & - 'then by filename and optionally by .' + if (trim(adjustl(keyword2)) /= 'FILEIN') then + errmsg = 'SPC6 keyword must be followed by "FILEIN" '// & + 'then by filename and optionally by .' call store_error(errmsg) call this%parser%StoreErrorUnit() end if @@ -1038,11 +1039,11 @@ subroutine read_sources_fileinput(this) call this%parser%GetStringCaps(keyword2) if (trim(keyword2) == 'MIXED') then isrctype = 4 - write(this%iout,'(1x,a,a)') 'ASSIGNED MIXED SSM TYPE TO PACKAGE ',& + write (this%iout, '(1x,a,a)') 'ASSIGNED MIXED SSM TYPE TO PACKAGE ', & trim(keyword) end if case default - write(errmsg,'(1x, a, a)') & + write (errmsg, '(1x, a, a)') & 'SRCTYPE MUST BE SPC6. FOUND: ', trim(srctype) call store_error(errmsg) call this%parser%StoreErrorUnit() @@ -1050,23 +1051,23 @@ subroutine read_sources_fileinput(this) ! ! -- Store the source type (3 or 4) this%isrctype(ip) = isrctype - + end do - write(this%iout,'(1x,a)')'END PROCESSING FILEINPUT' + write (this%iout, '(1x,a)') 'END PROCESSING FILEINPUT' else - write(this%iout,'(1x,a)') & + write (this%iout, '(1x,a)') & 'OPTIONAL FILEINPUT BLOCK NOT FOUND. CONTINUING.' end if ! ! -- terminate if errors - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return end subroutine read_sources_fileinput - + !> @ brief Set iauxpak array value for package ip !! !! The next call to parser will return the auxiliary name for @@ -1078,11 +1079,11 @@ end subroutine read_sources_fileinput !< subroutine set_iauxpak(this, ip, packname) ! -- dummy - class(GwtSsmtype),intent(inout) :: this !< GwtSsmtype - integer(I4B), intent(in) :: ip !< package number + class(TspSsmType), intent(inout) :: this !< TspSsmType + integer(I4B), intent(in) :: ip !< package number character(len=*), intent(in) :: packname !< name of package ! -- local - character(len=LENAUXNAME) :: auxname + character(len=LENAUXNAME) :: auxname logical :: auxfound integer(I4B) :: iaux ! @@ -1090,28 +1091,28 @@ subroutine set_iauxpak(this, ip, packname) call this%parser%GetStringCaps(auxname) auxfound = .false. do iaux = 1, this%fmi%gwfpackages(ip)%naux - if (trim(this%fmi%gwfpackages(ip)%auxname(iaux)) == & + if (trim(this%fmi%gwfpackages(ip)%auxname(iaux)) == & trim(auxname)) then auxfound = .true. exit - endif - enddo + end if + end do if (.not. auxfound) then - write(errmsg,'(1x, a, a)') & + write (errmsg, '(1x, a, a)') & 'AUXILIARY NAME CANNOT BE FOUND: ', trim(auxname) call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- set iauxpak and write message this%iauxpak(ip) = iaux - write(this%iout, '(4x, a, i0, a, a)') 'USING AUX COLUMN ', & + write (this%iout, '(4x, a, i0, a, a)') 'USING AUX COLUMN ', & iaux, ' IN PACKAGE ', trim(packname) ! ! -- return return end subroutine set_iauxpak - + !> @ brief Set ssmivec array value for package ip !! !! The next call to parser will return the input file name for @@ -1121,10 +1122,10 @@ end subroutine set_iauxpak !< subroutine set_ssmivec(this, ip, packname) ! -- module - use InputOutputModule, only: openfile, getunit + use InputOutputModule, only: openfile, getunit ! -- dummy - class(GwtSsmtype),intent(inout) :: this !< GwtSsmtype - integer(I4B), intent(in) :: ip !< package number + class(TspSsmType), intent(inout) :: this !< TspSsmType + integer(I4B), intent(in) :: ip !< package number character(len=*), intent(in) :: packname !< name of package ! -- local character(len=LINELENGTH) :: filename @@ -1135,19 +1136,19 @@ subroutine set_ssmivec(this, ip, packname) call this%parser%GetString(filename) inunit = getunit() call openfile(inunit, this%iout, filename, 'SPC', filstat_opt='OLD') - + ! -- Create the SPC file object ssmiptr => this%ssmivec(ip) - call ssmiptr%initialize(this%dis, ip, inunit, this%iout, this%name_model, & + call ssmiptr%initialize(this%dis, ip, inunit, this%iout, this%name_model, & trim(packname)) - - write(this%iout, '(4x, a, a, a, a)') 'USING SPC INPUT FILE ', & + + write (this%iout, '(4x, a, a, a, a)') 'USING SPC INPUT FILE ', & trim(filename), ' TO SET CONCENTRATIONS FOR PACKAGE ', trim(packname) ! ! -- return return end subroutine set_ssmivec - + !> @ brief Setup the output table !! !! Setup the output table by creating the column headers. @@ -1155,7 +1156,7 @@ end subroutine set_ssmivec !< subroutine pak_setup_outputtab(this) ! -- dummy - class(GwtSsmtype),intent(inout) :: this + class(TspSsmType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -1171,7 +1172,7 @@ subroutine pak_setup_outputtab(this) !end if ! ! -- initialize the output table object - title = 'SSM PACKAGE (' // trim(this%packName) // & + title = 'SSM PACKAGE ('//trim(this%packName)// & ') FLOW RATES' call table_cr(this%outputtab, this%packName, title) call this%outputtab%table_df(1, ntabcol, this%iout, transient=.TRUE.) @@ -1197,4 +1198,4 @@ subroutine pak_setup_outputtab(this) return end subroutine pak_setup_outputtab -end module GwtSsmModule \ No newline at end of file +end module TspSsmModule From 0fa48655930a86f20f353333e2454b88755cc031 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 13 Jul 2022 20:01:01 -0700 Subject: [PATCH 012/212] Updating the contents of the src/Model/ModelUtilities directory with the fprettify stuff. For completeness, probably best to rerun fprettify on these files TspAdvOptions, TspDspGridData, TspDspOptions, TspLabels --- src/Model/ModelUtilities/BoundaryPackage.f90 | 3260 +++++++++-------- src/Model/ModelUtilities/Connections.f90 | 793 ++-- .../ModelUtilities/DiscretizationBase.f90 | 602 +-- src/Model/ModelUtilities/DisvGeom.f90 | 139 +- src/Model/ModelUtilities/GwfBuyInputData.f90 | 32 +- src/Model/ModelUtilities/GwfMvrPeriodData.f90 | 119 +- src/Model/ModelUtilities/GwfNpfGridData.f90 | 112 +- src/Model/ModelUtilities/GwfNpfOptions.f90 | 26 +- src/Model/ModelUtilities/GwfStorageUtils.f90 | 68 +- src/Model/ModelUtilities/GwtSpc.f90 | 354 +- src/Model/ModelUtilities/Mover.f90 | 183 +- src/Model/ModelUtilities/PackageMover.f90 | 78 +- .../ModelUtilities/SfrCrossSectionManager.f90 | 268 +- .../ModelUtilities/SfrCrossSectionUtils.f90 | 168 +- .../{GwtAdvOptions.f90 => TspAdvOptions.f90} | 8 +- ...{GwtDspGridData.f90 => TspDspGridData.f90} | 26 +- .../{GwtDspOptions.f90 => TspDspOptions.f90} | 8 +- src/Model/ModelUtilities/TspLabels.f90 | 182 + src/Model/ModelUtilities/UzfCellGroup.f90 | 766 ++-- src/Model/ModelUtilities/Xt3dAlgorithm.f90 | 240 +- src/Model/ModelUtilities/Xt3dInterface.f90 | 892 ++--- 21 files changed, 4283 insertions(+), 4041 deletions(-) rename src/Model/ModelUtilities/{GwtAdvOptions.f90 => TspAdvOptions.f90} (53%) rename src/Model/ModelUtilities/{GwtDspGridData.f90 => TspDspGridData.f90} (63%) rename src/Model/ModelUtilities/{GwtDspOptions.f90 => TspDspOptions.f90} (68%) create mode 100644 src/Model/ModelUtilities/TspLabels.f90 diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index b42503a1252..27f83471224 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -1,35 +1,35 @@ -!> @brief This module contains the base boundary package +!> @brief This module contains the base boundary package !! -!! This module contains the base model boundary package class that is -!! extended by all model boundary packages. The base model boundary +!! This module contains the base model boundary package class that is +!! extended by all model boundary packages. The base model boundary !! package extends the NumericalPackageType. !! !< module BndModule - use KindModule, only: DP, LGP, I4B - use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LENFTYPE, & - DZERO, DONE, & - LENMODELNAME, LENPACKAGENAME, & - LENMEMPATH, MAXCHARLEN, LINELENGTH, & - DNODATA, LENLISTLABEL, LENPAKLOC, & - TABLEFT, TABCENTER - use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, & - store_error_unit - use NumericalPackageModule, only: NumericalPackageType - use ObsModule, only: ObsType, obs_cr - use TdisModule, only: delt, totimc - use ObserveModule, only: ObserveType - use InputOutputModule, only: GetUnit, openfile + use KindModule, only: DP, LGP, I4B + use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LENFTYPE, & + DZERO, DONE, & + LENMODELNAME, LENPACKAGENAME, & + LENMEMPATH, MAXCHARLEN, LINELENGTH, & + DNODATA, LENLISTLABEL, LENPAKLOC, & + TABLEFT, TABCENTER + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error, & + store_error_unit + use NumericalPackageModule, only: NumericalPackageType + use ObsModule, only: ObsType, obs_cr + use TdisModule, only: delt, totimc + use ObserveModule, only: ObserveType + use InputOutputModule, only: GetUnit, openfile use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType - use TimeSeriesLinkModule, only: TimeSeriesLinkType - use TimeSeriesManagerModule, only: TimeSeriesManagerType - use ListModule, only: ListType - use PackageMoverModule, only: PackageMoverType - use BaseDisModule, only: DisBaseType - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr + use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesManagerModule, only: TimeSeriesManagerType + use ListModule, only: ListType + use PackageMoverModule, only: PackageMoverType + use BaseDisModule, only: DisBaseType + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr implicit none @@ -45,64 +45,63 @@ module BndModule !< type, extends(NumericalPackageType) :: BndType ! -- characters - character(len=LENLISTLABEL), pointer :: listlabel => null() !< title of table written for RP - character(len=LENPACKAGENAME) :: text = '' !< text string for package flow term - character(len=LENAUXNAME), dimension(:), pointer, & - contiguous :: auxname => null() !< vector of auxname - character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: boundname => null() !< vector of boundnames + character(len=LENLISTLABEL), pointer :: listlabel => null() !< title of table written for RP + character(len=LENPACKAGENAME) :: text = '' !< text string for package flow term + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: auxname => null() !< vector of auxname + character(len=LENBOUNDNAME), dimension(:), pointer, & + contiguous :: boundname => null() !< vector of boundnames ! ! -- scalars - integer(I4B), pointer :: isadvpak => null() !< flag indicating package is advanced (1) or not (0) - integer(I4B), pointer :: ibcnum => null() !< consecutive package number for this boundary condition - integer(I4B), pointer :: maxbound => null() !< max number of boundaries - integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period - integer(I4B), pointer :: ncolbnd => null() !< number of columns of the bound array - integer(I4B), pointer :: iscloc => null() !< bound column to scale with SFAC - integer(I4B), pointer :: naux => null() !< number of auxiliary variables - integer(I4B), pointer :: inamedbound => null() !< flag to read boundnames - integer(I4B), pointer :: iauxmultcol => null() !< column to use as multiplier for column iscloc - integer(I4B), pointer :: npakeq => null() !< number of equations in this package (normally 0 unless package adds rows to matrix) - integer(I4B), pointer :: ioffset => null() !< offset of this package in the model + integer(I4B), pointer :: isadvpak => null() !< flag indicating package is advanced (1) or not (0) + integer(I4B), pointer :: ibcnum => null() !< consecutive package number for this boundary condition + integer(I4B), pointer :: maxbound => null() !< max number of boundaries + integer(I4B), pointer :: nbound => null() !< number of boundaries for current stress period + integer(I4B), pointer :: ncolbnd => null() !< number of columns of the bound array + integer(I4B), pointer :: iscloc => null() !< bound column to scale with SFAC + integer(I4B), pointer :: naux => null() !< number of auxiliary variables + integer(I4B), pointer :: inamedbound => null() !< flag to read boundnames + integer(I4B), pointer :: iauxmultcol => null() !< column to use as multiplier for column iscloc + integer(I4B), pointer :: npakeq => null() !< number of equations in this package (normally 0 unless package adds rows to matrix) + integer(I4B), pointer :: ioffset => null() !< offset of this package in the model ! -- arrays - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< vector of reduced node numbers - integer(I4B), dimension(:), pointer, contiguous :: noupdateauxvar => null() !< override auxvars from being updated - real(DP), dimension(:,:), pointer, contiguous :: bound => null() !< array of package specific boundary numbers - real(DP), dimension(:), pointer, contiguous :: hcof => null() !< diagonal contribution - real(DP), dimension(:), pointer, contiguous :: rhs => null() !< right-hand side contribution - real(DP), dimension(:,:), pointer, contiguous :: auxvar => null() !< auxiliary variable array - real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated values - real(DP), dimension(:), pointer, contiguous :: simtomvr => null() !< simulated to mover values + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< vector of reduced node numbers + integer(I4B), dimension(:), pointer, contiguous :: noupdateauxvar => null() !< override auxvars from being updated + real(DP), dimension(:, :), pointer, contiguous :: bound => null() !< array of package specific boundary numbers + real(DP), dimension(:), pointer, contiguous :: hcof => null() !< diagonal contribution + real(DP), dimension(:), pointer, contiguous :: rhs => null() !< right-hand side contribution + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< auxiliary variable array + real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated values + real(DP), dimension(:), pointer, contiguous :: simtomvr => null() !< simulated to mover values ! ! -- water mover flag and object - integer(I4B), pointer :: imover => null() !< flag indicating of the mover is active in the package - type(PackageMoverType), pointer :: pakmvrobj => null() !< mover object for package + integer(I4B), pointer :: imover => null() !< flag indicating of the mover is active in the package + type(PackageMoverType), pointer :: pakmvrobj => null() !< mover object for package ! ! -- timeseries - type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager - type(TimeArraySeriesManagerType), pointer :: TasManager => null() !< time array series manager - integer(I4B) :: indxconvertflux = 0 !< indxconvertflux is column of bound to multiply by area to convert flux to rate + type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager + type(TimeArraySeriesManagerType), pointer :: TasManager => null() !< time array series manager + integer(I4B) :: indxconvertflux = 0 !< indxconvertflux is column of bound to multiply by area to convert flux to rate logical(LGP) :: AllowTimeArraySeries = .false. ! ! -- pointers for observations - integer(I4B), pointer :: inobspkg => null() !< unit number for obs package - type(ObsType), pointer :: obs => null() !< observation package + integer(I4B), pointer :: inobspkg => null() !< unit number for obs package + type(ObsType), pointer :: obs => null() !< observation package ! ! -- pointers to model/solution variables - integer(I4B), pointer :: neq !< number of equations for model - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< model ibound array - real(DP), dimension(:), pointer, contiguous :: xnew => null() !< model dependent variable (head) for this time step - real(DP), dimension(:), pointer, contiguous :: xold => null() !< model dependent variable for last time step - real(DP), dimension(:), pointer, contiguous :: flowja => null() !< model intercell flows - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< pointer to icelltype array in NPF - character(len=LENMEMPATH) :: ictMemPath = '' !< memory path to the icelltype data (for GWF this is in NPF) + integer(I4B), pointer :: neq !< number of equations for model + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< model ibound array + real(DP), dimension(:), pointer, contiguous :: xnew => null() !< model dependent variable (head) for this time step + real(DP), dimension(:), pointer, contiguous :: xold => null() !< model dependent variable for last time step + real(DP), dimension(:), pointer, contiguous :: flowja => null() !< model intercell flows + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< pointer to icelltype array in NPF + character(len=LENMEMPATH) :: ictMemPath = '' !< memory path to the icelltype data (for GWF this is in NPF) ! ! -- table objects - type(TableType), pointer :: inputtab => null() !< input table object - type(TableType), pointer :: outputtab => null() !< output table object for package flows writtent to the model listing file - type(TableType), pointer :: errortab => null() !< package error table + type(TableType), pointer :: inputtab => null() !< input table object + type(TableType), pointer :: outputtab => null() !< output table object for package flows writtent to the model listing file + type(TableType), pointer :: errortab => null() !< package error table - contains procedure :: bnd_df procedure :: bnd_ac @@ -127,8 +126,8 @@ module BndModule procedure :: allocate_scalars procedure :: allocate_arrays procedure :: pack_initialize - procedure :: read_options => bnd_read_options - procedure :: read_dimensions => bnd_read_dimensions + procedure :: read_options => bnd_read_options + procedure :: read_dimensions => bnd_read_dimensions procedure :: read_initial_attr => bnd_read_initial_attr procedure :: bnd_options procedure :: bnd_cq_simrate @@ -149,1396 +148,1407 @@ module BndModule ! end type BndType - contains +contains - !> @ brief Define boundary package options and dimensions + !> @ brief Define boundary package options and dimensions !! - !! Define base boundary package options and dimensions for + !! Define base boundary package options and dimensions for !! a model boundary package. !! - !< - subroutine bnd_df(this, neq, dis) - ! -- modules - use TimeSeriesManagerModule, only: tsmanager_cr - use TimeArraySeriesManagerModule, only: tasmanager_cr - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - integer(I4B), intent(inout) :: neq !< number of equations - class(DisBaseType), pointer :: dis !< discretization object - ! - ! -- set pointer to dis object for the model - this%dis => dis - ! - ! -- Create time series managers - call tsmanager_cr(this%TsManager, this%iout) - call tasmanager_cr(this%TasManager, dis, this%iout) - ! - ! -- create obs package - call obs_cr(this%obs, this%inobspkg) - ! - ! -- Write information to model list file - write(this%iout,1) this%filtyp, trim(adjustl(this%text)), this%inunit - 1 format(1X,/1X,a,' -- ',a,' PACKAGE, VERSION 8, 2/22/2014', & - ' INPUT READ FROM UNIT ',I0) - ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - ! - ! -- set and read options - call this%read_options() - ! - ! -- Now that time series will have been read, need to call the df - ! routine to define the manager - call this%tsmanager%tsmanager_df() - call this%tasmanager%tasmanager_df() - ! - ! -- read the package dimensions block - call this%read_dimensions() - ! - ! -- update package moffset for packages that add rows - if (this%npakeq > 0) then - this%ioffset = neq - this%dis%nodes - end if - ! - ! -- update neq - neq = neq + this%npakeq - ! - ! -- Store information needed for observations - if (this%bnd_obs_supported()) then - call this%obs%obs_df(this%iout, this%packName, this%filtyp, this%dis) - call this%bnd_df_obs() - endif - ! - ! -- return - return - end subroutine bnd_df + !< + subroutine bnd_df(this, neq, dis) + ! -- modules + use TimeSeriesManagerModule, only: tsmanager_cr + use TimeArraySeriesManagerModule, only: tasmanager_cr + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + integer(I4B), intent(inout) :: neq !< number of equations + class(DisBaseType), pointer :: dis !< discretization object + ! + ! -- set pointer to dis object for the model + this%dis => dis + ! + ! -- Create time series managers + call tsmanager_cr(this%TsManager, this%iout) + call tasmanager_cr(this%TasManager, dis, this%iout) + ! + ! -- create obs package + call obs_cr(this%obs, this%inobspkg) + ! + ! -- Write information to model list file + write (this%iout, 1) this%filtyp, trim(adjustl(this%text)), this%inunit +1 format(1X, /1X, a, ' -- ', a, ' PACKAGE, VERSION 8, 2/22/2014', & + ' INPUT READ FROM UNIT ', I0) + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + ! + ! -- set and read options + call this%read_options() + ! + ! -- Now that time series will have been read, need to call the df + ! routine to define the manager + call this%tsmanager%tsmanager_df() + call this%tasmanager%tasmanager_df() + ! + ! -- read the package dimensions block + call this%read_dimensions() + ! + ! -- update package moffset for packages that add rows + if (this%npakeq > 0) then + this%ioffset = neq - this%dis%nodes + end if + ! + ! -- update neq + neq = neq + this%npakeq + ! + ! -- Store information needed for observations + if (this%bnd_obs_supported()) then + call this%obs%obs_df(this%iout, this%packName, this%filtyp, this%dis) + call this%bnd_df_obs() + end if + ! + ! -- return + return + end subroutine bnd_df - !> @ brief Add boundary package connection to matrix + !> @ brief Add boundary package connection to matrix !! - !! Add boundary package connection to the matrix for packages that add - !! connections to the coefficient matrix. An example would be the GWF model + !! Add boundary package connection to the matrix for packages that add + !! connections to the coefficient matrix. An example would be the GWF model !! MAW package. Base implementation that must be extended. !! - !< - subroutine bnd_ac(this, moffset, sparse) - ! -- modules - use SparseModule, only: sparsematrix - use SimModule, only: store_error - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - integer(I4B), intent(in) :: moffset !< solution matrix model offset - type(sparsematrix), intent(inout) :: sparse !< sparse object - ! - ! -- return - return - end subroutine bnd_ac + !< + subroutine bnd_ac(this, moffset, sparse) + ! -- modules + use SparseModule, only: sparsematrix + use SimModule, only: store_error + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + integer(I4B), intent(in) :: moffset !< solution matrix model offset + type(sparsematrix), intent(inout) :: sparse !< sparse object + ! + ! -- return + return + end subroutine bnd_ac - !> @ brief Map boundary package connection to matrix + !> @ brief Map boundary package connection to matrix !! - !! Map boundary package connection to the matrix for packages that add - !! connections to the coefficient matrix. An example would be the GWF model + !! Map boundary package connection to the matrix for packages that add + !! connections to the coefficient matrix. An example would be the GWF model !! MAW package. Base implementation that must be extended. !! - !< - subroutine bnd_mc(this, moffset, iasln, jasln) - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - integer(I4B), intent(in) :: moffset !< solution matrix model offset - integer(I4B), dimension(:), intent(in) :: iasln !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: jasln !< solution CRS column pointers - ! - ! -- return - return - end subroutine bnd_mc + !< + subroutine bnd_mc(this, moffset, iasln, jasln) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + integer(I4B), intent(in) :: moffset !< solution matrix model offset + integer(I4B), dimension(:), intent(in) :: iasln !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: jasln !< solution CRS column pointers + ! + ! -- return + return + end subroutine bnd_mc - !> @ brief Allocate and read method for boundary package + !> @ brief Allocate and read method for boundary package !! - !! Generic method to allocate and read static data for model boundary + !! Generic method to allocate and read static data for model boundary !! packages. A boundary package only needs to overide this method if !! input data varies from the standard boundary package. !! - !< - subroutine bnd_ar(this) - ! -- modules - use MemoryManagerModule, only: mem_setptr - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! - ! -- allocate and read observations - call this%obs%obs_ar() - ! - ! -- Allocate arrays in package superclass - call this%allocate_arrays() - ! - ! -- read optional initial package parameters - call this%read_initial_attr() - ! - ! -- setup pakmvrobj for standard stress packages - if (this%imover == 1) then - allocate(this%pakmvrobj) - call this%pakmvrobj%ar(this%maxbound, 0, this%memoryPath) - endif - ! - ! -- return - return - end subroutine bnd_ar - - !> @ brief Allocate and read method for package + !< + subroutine bnd_ar(this) + ! -- modules + use MemoryManagerModule, only: mem_setptr + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! + ! -- allocate and read observations + call this%obs%obs_ar() + ! + ! -- Allocate arrays in package superclass + call this%allocate_arrays() + ! + ! -- read optional initial package parameters + call this%read_initial_attr() + ! + ! -- setup pakmvrobj for standard stress packages + if (this%imover == 1) then + allocate (this%pakmvrobj) + call this%pakmvrobj%ar(this%maxbound, 0, this%memoryPath) + end if + ! + ! -- return + return + end subroutine bnd_ar + + !> @ brief Allocate and read method for package !! - !! Generic method to read and prepare period data for model boundary + !! Generic method to read and prepare period data for model boundary !! packages. A boundary package only needs to overide this method if !! period data varies from the standard boundary package. !! - !< - subroutine bnd_rp(this) - ! -- modules - use TdisModule, only: kper, nper - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! -- local variables - integer(I4B) :: ierr - integer(I4B) :: nlist - logical(LGP) :: isfound - character(len=LINELENGTH) :: line - ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" - character(len=*), parameter :: fmtnbd = & - "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & - &') IS GREATER THAN MAXIMUM(',I6,')')" - ! - ! -- Set ionper to the stress period number for which a new block of data - ! will be read. - if(this%inunit == 0) return + !< + subroutine bnd_rp(this) + ! -- modules + use TdisModule, only: kper, nper + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! -- local variables + integer(I4B) :: ierr + integer(I4B) :: nlist + logical(LGP) :: isfound + character(len=LINELENGTH) :: line + ! -- formats + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtnbd = & + "(1X,/1X,'THE NUMBER OF ACTIVE ',A,'S (',I6, & + &') IS GREATER THAN MAXIMUM(',I6,')')" + ! + ! -- Set ionper to the stress period number for which a new block of data + ! will be read. + if (this%inunit == 0) return + ! + ! -- get stress period data + if (this%ionper < kper) then ! - ! -- get stress period data - if (this%ionper < kper) then + ! -- get period block + call this%parser%GetBlock('PERIOD', isfound, ierr, & + supportOpenClose=.true.) + if (isfound) then ! - ! -- get period block - call this%parser%GetBlock('PERIOD', isfound, ierr, & - supportOpenClose=.true.) - if (isfound) then - ! - ! -- read ionper and check for increasing period numbers - call this%read_check_ionper() + ! -- read ionper and check for increasing period numbers + call this%read_check_ionper() + else + ! + ! -- PERIOD block not found + if (ierr < 0) then + ! -- End of file found; data applies for remainder of simulation. + this%ionper = nper + 1 else - ! - ! -- PERIOD block not found - if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. - this%ionper = nper + 1 - else - ! -- Found invalid block - call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if - endif + ! -- Found invalid block + call this%parser%GetCurrentLine(line) + write (errmsg, fmtblkerr) adjustl(trim(line)) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if end if - ! - ! -- read data if ionper == kper - if(this%ionper == kper) then - nlist = -1 - ! -- Remove all time-series and time-array-series links associated with - ! this package. - call this%TsManager%Reset(this%packName) - call this%TasManager%Reset(this%packName) - ! - ! -- Read data as a list - call this%dis%read_list(this%parser%iuactive, this%iout, & - this%iprpak, nlist, this%inamedbound, & - this%iauxmultcol, this%nodelist, & - this%bound, this%auxvar, this%auxname, & - this%boundname, this%listlabel, & - this%packName, this%tsManager, this%iscloc) - this%nbound = nlist - ! - ! Define the tsLink%Text value(s) appropriately. - ! E.g. for WEL package, entry 1, assign tsLink%Text = 'Q' - ! For RIV package, entry 1 text = 'STAGE', entry 2 text = 'COND', - ! entry 3 text = 'RBOT'; etc. - call this%bnd_rp_ts() - ! - ! -- Terminate the block - call this%parser%terminateblock() - ! - else - write(this%iout,fmtlsp) trim(this%filtyp) - endif - ! - ! -- return - return - end subroutine bnd_rp + end if + ! + ! -- read data if ionper == kper + if (this%ionper == kper) then + nlist = -1 + ! -- Remove all time-series and time-array-series links associated with + ! this package. + call this%TsManager%Reset(this%packName) + call this%TasManager%Reset(this%packName) + ! + ! -- Read data as a list + call this%dis%read_list(this%parser%iuactive, this%iout, & + this%iprpak, nlist, this%inamedbound, & + this%iauxmultcol, this%nodelist, & + this%bound, this%auxvar, this%auxname, & + this%boundname, this%listlabel, & + this%packName, this%tsManager, this%iscloc) + this%nbound = nlist + ! + ! Define the tsLink%Text value(s) appropriately. + ! E.g. for WEL package, entry 1, assign tsLink%Text = 'Q' + ! For RIV package, entry 1 text = 'STAGE', entry 2 text = 'COND', + ! entry 3 text = 'RBOT'; etc. + call this%bnd_rp_ts() + ! + ! -- Terminate the block + call this%parser%terminateblock() + ! + else + write (this%iout, fmtlsp) trim(this%filtyp) + end if + ! + ! -- return + return + end subroutine bnd_rp - !> @ brief Advance the boundary package + !> @ brief Advance the boundary package !! !! Advance data in the boundary package. The method sets advances - !! time series, time array series, and observation data. A boundary + !! time series, time array series, and observation data. A boundary !! package only needs to overide this method if additional data !! needs to be advanced. !! - !< - subroutine bnd_ad(this) - ! -- dummy variables - class(BndType) :: this !< BndType object - ! -- local variables - real(DP) :: begintime, endtime - ! - ! -- Initialize time variables - begintime = totimc - endtime = begintime + delt - ! - ! -- Advance the time series managers - call this%TsManager%ad() - call this%TasManager%ad() - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - return - end subroutine bnd_ad + !< + subroutine bnd_ad(this) + ! -- dummy variables + class(BndType) :: this !< BndType object + ! -- local variables + real(DP) :: begintime, endtime + ! + ! -- Initialize time variables + begintime = totimc + endtime = begintime + delt + ! + ! -- Advance the time series managers + call this%TsManager%ad() + call this%TasManager%ad() + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + return + end subroutine bnd_ad - !> @ brief Check boundary package period data + !> @ brief Check boundary package period data !! - !! Check the boundary package period data. Base implementation that + !! Check the boundary package period data. Base implementation that !! must be extended by each model boundary package. !! - !< - subroutine bnd_ck(this) - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! - ! -- check stress period data - ! -- each package must override generic functionality - ! - ! -- return - return - end subroutine bnd_ck + !< + subroutine bnd_ck(this) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! + ! -- check stress period data + ! -- each package must override generic functionality + ! + ! -- return + return + end subroutine bnd_ck - !> @ brief Formulate the package hcof and rhs terms. + !> @ brief Formulate the package hcof and rhs terms. !! !! Formulate the hcof and rhs terms for the package that will be !! added to the coefficient matrix and right-hand side vector. - !! Base implementation that must be extended by each model + !! Base implementation that must be extended by each model !! boundary package. !! - !< - subroutine bnd_cf(this, reset_mover) - ! -- modules - class(BndType) :: this !< BndType object - logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover - ! - ! -- bnd has no cf routine - ! - ! -- return - return - end subroutine bnd_cf + !< + subroutine bnd_cf(this, reset_mover) + ! -- modules + class(BndType) :: this !< BndType object + logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover + ! + ! -- bnd has no cf routine + ! + ! -- return + return + end subroutine bnd_cf - !> @ brief Copy hcof and rhs terms into solution. + !> @ brief Copy hcof and rhs terms into solution. !! - !! Add the hcof and rhs terms for the boundary package to the - !! coefficient matrix and right-hand side vector. A boundary + !! Add the hcof and rhs terms for the boundary package to the + !! coefficient matrix and right-hand side vector. A boundary !! package only needs to overide this method if it is different for !! a specific boundary package. !! - !< - subroutine bnd_fc(this, rhs, ia, idxglo, amatsln) - ! -- dummy variables - class(BndType) :: this !< BndType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix - ! -- local variables - integer(I4B) :: i - integer(I4B) :: n - integer(I4B) :: ipos - ! - ! -- Copy package rhs and hcof into solution rhs and amat - do i = 1, this%nbound - n = this%nodelist(i) - rhs(n) = rhs(n) + this%rhs(i) - ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) - end do - ! - ! -- return - return - end subroutine bnd_fc + !< + subroutine bnd_fc(this, rhs, ia, idxglo, amatsln) + ! -- dummy variables + class(BndType) :: this !< BndType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + ! -- local variables + integer(I4B) :: i + integer(I4B) :: n + integer(I4B) :: ipos + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + end do + ! + ! -- return + return + end subroutine bnd_fc - !> @ brief Add Newton-Raphson terms for package into solution. + !> @ brief Add Newton-Raphson terms for package into solution. !! - !! Calculate and add the Newton-Raphson terms for the boundary package - !! to the coefficient matrix and right-hand side vector. A boundary - !! package only needs to overide this method if a specific boundary + !! Calculate and add the Newton-Raphson terms for the boundary package + !! to the coefficient matrix and right-hand side vector. A boundary + !! package only needs to overide this method if a specific boundary !! package needs to add Newton-Raphson terms. !! - !< - subroutine bnd_fn(this, rhs, ia, idxglo, amatsln) - ! -- dummy variables - class(BndType) :: this !< BndType object - real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model - integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix - ! - ! -- No addition terms for Newton-Raphson with constant conductance - ! boundary conditions - ! - ! -- return - return - end subroutine bnd_fn + !< + subroutine bnd_fn(this, rhs, ia, idxglo, amatsln) + ! -- dummy variables + class(BndType) :: this !< BndType object + real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model + integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers + integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + ! + ! -- No addition terms for Newton-Raphson with constant conductance + ! boundary conditions + ! + ! -- return + return + end subroutine bnd_fn - !> @ brief Apply Newton-Raphson under-relaxation for package. + !> @ brief Apply Newton-Raphson under-relaxation for package. !! - !! Apply Newton-Raphson under-relaxation for a boundary package. A boundary - !! package only needs to overide this method if a specific boundary + !! Apply Newton-Raphson under-relaxation for a boundary package. A boundary + !! package only needs to overide this method if a specific boundary !! package needs to apply Newton-Raphson under-relaxation. An example is !! the MAW package which adds rows to the system of equations and may need !! to have the dependent-variable constrained by the bottom of the model. !! - !< - subroutine bnd_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) - ! -- dummy variables - class(BndType), intent(inout) :: this !< BndType object - integer(I4B), intent(in) :: neqpak !< number of equations in the package - real(DP), dimension(neqpak), intent(inout) :: x !< dependent variable - real(DP), dimension(neqpak), intent(in) :: xtemp !< previous dependent variable - real(DP), dimension(neqpak), intent(inout) :: dx !< change in dependent variable - integer(I4B), intent(inout) :: inewtonur !< flag indicating if newton-raphson under-relaxation should be applied - real(DP), intent(inout) :: dxmax !< maximum change in the dependent variable - integer(I4B), intent(inout) :: locmax !< location of the maximum change in the dependent variable - ! -- local variables - ! - ! -- Newton-Raphson under-relaxation - ! - ! -- return - return - end subroutine bnd_nur + !< + subroutine bnd_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + integer(I4B), intent(in) :: neqpak !< number of equations in the package + real(DP), dimension(neqpak), intent(inout) :: x !< dependent variable + real(DP), dimension(neqpak), intent(in) :: xtemp !< previous dependent variable + real(DP), dimension(neqpak), intent(inout) :: dx !< change in dependent variable + integer(I4B), intent(inout) :: inewtonur !< flag indicating if newton-raphson under-relaxation should be applied + real(DP), intent(inout) :: dxmax !< maximum change in the dependent variable + integer(I4B), intent(inout) :: locmax !< location of the maximum change in the dependent variable + ! -- local variables + ! + ! -- Newton-Raphson under-relaxation + ! + ! -- return + return + end subroutine bnd_nur - !> @ brief Convergence check for package. + !> @ brief Convergence check for package. !! !! Perform additional convergence checks on the flow between the package !! and the model it is attached to. This additional convergence check is !! applied to pacakages that solve their own continuity equation as !! part of the formulate step at the beginning of a Picard iteration. - !! A boundary package only needs to overide this method if a specific boundary - !! package solves its own continuity equation. Example packages that implement + !! A boundary package only needs to overide this method if a specific boundary + !! package solves its own continuity equation. Example packages that implement !! this additional convergence check is the CSUB, SFR, LAK, and UZF packages. !! - !< - subroutine bnd_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) - ! -- dummy variables - class(BndType), intent(inout) :: this !< BndType object - integer(I4B), intent(in) :: innertot !< total number of inner iterations - integer(I4B), intent(in) :: kiter !< Picard iteration number - integer(I4B),intent(in) :: iend !< flag indicating if this is the last Picard iteration - integer(I4B), intent(in) :: icnvgmod !< flag inficating if the model has met specific convergence criteria - character(len=LENPAKLOC), intent(inout) :: cpak !< string for user node - integer(I4B), intent(inout) :: ipak !< location of the maximum dependent variable change - real(DP), intent(inout) :: dpak !< maximum dependent variable change - ! - ! -- No addition convergence check for boundary conditions - ! - ! -- return - return - end subroutine bnd_cc + !< + subroutine bnd_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + integer(I4B), intent(in) :: innertot !< total number of inner iterations + integer(I4B), intent(in) :: kiter !< Picard iteration number + integer(I4B), intent(in) :: iend !< flag indicating if this is the last Picard iteration + integer(I4B), intent(in) :: icnvgmod !< flag inficating if the model has met specific convergence criteria + character(len=LENPAKLOC), intent(inout) :: cpak !< string for user node + integer(I4B), intent(inout) :: ipak !< location of the maximum dependent variable change + real(DP), intent(inout) :: dpak !< maximum dependent variable change + ! + ! -- No addition convergence check for boundary conditions + ! + ! -- return + return + end subroutine bnd_cc - !> @ brief Calculate advanced package flows. + !> @ brief Calculate advanced package flows. !! - !! Calculate the flow between connected advanced package control volumes. + !! Calculate the flow between connected advanced package control volumes. !! Only advanced boundary packages need to overide this method. !! - !< - subroutine bnd_cq(this, x, flowja, iadv) - ! -- dummy variables - class(BndType), intent(inout) :: this !< BndType object - real(DP), dimension(:), intent(in) :: x !< current dependent-variable value - real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes - integer(I4B), optional, intent(in) :: iadv !< flag that indicates if this is an advance package - ! -- local variables - integer(I4B) :: imover - ! ------------------------------------------------------------------------------ - ! - ! -- check for iadv optional variable to indicate this is an advanced - ! package and that mover calculations should not be done here - if (present(iadv)) then - if (iadv == 1) then - imover = 0 - else - imover = 1 - end if + !< + subroutine bnd_cq(this, x, flowja, iadv) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + real(DP), dimension(:), intent(in) :: x !< current dependent-variable value + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + integer(I4B), optional, intent(in) :: iadv !< flag that indicates if this is an advance package + ! -- local variables + integer(I4B) :: imover + ! ------------------------------------------------------------------------------ + ! + ! -- check for iadv optional variable to indicate this is an advanced + ! package and that mover calculations should not be done here + if (present(iadv)) then + if (iadv == 1) then + imover = 0 else - imover = this%imover + imover = 1 end if - ! - ! -- Calculate package flows. In the first call, simval is calculated - ! from hcof, rhs, and head. The second call may reduce the value in - ! simval by what is sent to the mover. The mover rate is stored in - ! simtomvr. imover is set to zero here for advanced packages, which - ! handle and store mover quantities separately. - call this%bnd_cq_simrate(x, flowja, imover) - if (imover == 1) then - call this%bnd_cq_simtomvr(flowja) - end if - ! - ! -- return - return - end subroutine bnd_cq + else + imover = this%imover + end if + ! + ! -- Calculate package flows. In the first call, simval is calculated + ! from hcof, rhs, and head. The second call may reduce the value in + ! simval by what is sent to the mover. The mover rate is stored in + ! simtomvr. imover is set to zero here for advanced packages, which + ! handle and store mover quantities separately. + call this%bnd_cq_simrate(x, flowja, imover) + if (imover == 1) then + call this%bnd_cq_simtomvr(flowja) + end if + ! + ! -- return + return + end subroutine bnd_cq - !> @ brief Calculate simrate. + !> @ brief Calculate simrate. !! - !! Calculate the flow between package and the model (for example, GHB and - !! groundwater cell) and store in the simvals variable. This method only + !! Calculate the flow between package and the model (for example, GHB and + !! groundwater cell) and store in the simvals variable. This method only !! needs to be overridden if a different calculation needs to be made. !! - !< - subroutine bnd_cq_simrate(this, hnew, flowja, imover) - ! -- dummy variables - class(BndType) :: this !< BndType object - real(DP), dimension(:), intent(in) :: hnew !< current dependent-variable value - real(DP), dimension(:), intent(inout) :: flowja !< flow between package and model - integer(I4B), intent(in) :: imover !< flag indicating if the mover package is active - ! -- local variables - integer(I4B) :: i - integer(I4B) :: node - integer(I4B) :: idiag - real(DP) :: rrate - ! -- formats - ! ------------------------------------------------------------------------------ + !< + subroutine bnd_cq_simrate(this, hnew, flowja, imover) + ! -- dummy variables + class(BndType) :: this !< BndType object + real(DP), dimension(:), intent(in) :: hnew !< current dependent-variable value + real(DP), dimension(:), intent(inout) :: flowja !< flow between package and model + integer(I4B), intent(in) :: imover !< flag indicating if the mover package is active + ! -- local variables + integer(I4B) :: i + integer(I4B) :: node + integer(I4B) :: idiag + real(DP) :: rrate + ! -- formats + ! ------------------------------------------------------------------------------ + ! + ! -- If no boundaries, skip flow calculations. + if (this%nbound > 0) then ! - ! -- If no boundaries, skip flow calculations. - if (this%nbound > 0) then + ! -- Loop through each boundary calculating flow. + do i = 1, this%nbound + node = this%nodelist(i) ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nbound - node = this%nodelist(i) - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (node > 0) then - idiag = this%dis%con%ia(node) - if(this%ibound(node) > 0) then - ! - ! -- Calculate the flow rate into the cell. - rrate = this%hcof(i) * hnew(node) - this%rhs(i) - end if - flowja(idiag) = flowja(idiag) + rrate + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (node > 0) then + idiag = this%dis%con%ia(node) + if (this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + rrate = this%hcof(i) * hnew(node) - this%rhs(i) end if - ! - ! -- Save simulated value to simvals array. - this%simvals(i) = rrate - ! - end do - endif - ! - ! -- return - return - end subroutine bnd_cq_simrate + flowja(idiag) = flowja(idiag) + rrate + end if + ! + ! -- Save simulated value to simvals array. + this%simvals(i) = rrate + ! + end do + end if + ! + ! -- return + return + end subroutine bnd_cq_simrate - !> @ brief Calculate flow to the mover. + !> @ brief Calculate flow to the mover. !! - !! Calculate the flow between package and the model that is sent to the - !! mover package and store in the simtomvr variable. This method only + !! Calculate the flow between package and the model that is sent to the + !! mover package and store in the simtomvr variable. This method only !! needs to be overridden if a different calculation needs to be made. !! - !< - subroutine bnd_cq_simtomvr(this, flowja) - ! -- dummy variables - class(BndType) :: this !< BndType object - real(DP), dimension(:), intent(inout) :: flowja !< flow between package and model - ! -- local variables - integer(I4B) :: i - integer(I4B) :: node - real(DP) :: q - real(DP) :: fact - real(DP) :: rrate + !< + subroutine bnd_cq_simtomvr(this, flowja) + ! -- dummy variables + class(BndType) :: this !< BndType object + real(DP), dimension(:), intent(inout) :: flowja !< flow between package and model + ! -- local variables + integer(I4B) :: i + integer(I4B) :: node + real(DP) :: q + real(DP) :: fact + real(DP) :: rrate + ! + ! -- If no boundaries, skip flow calculations. + if (this%nbound > 0) then ! - ! -- If no boundaries, skip flow calculations. - if (this%nbound > 0) then + ! -- Loop through each boundary calculating flow. + do i = 1, this%nbound + node = this%nodelist(i) ! - ! -- Loop through each boundary calculating flow. - do i = 1, this%nbound - node = this%nodelist(i) - ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (node > 0) then - if(this%ibound(node) > 0) then + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (node > 0) then + if (this%ibound(node) > 0) then + ! + ! -- Calculate the flow rate into the cell. + q = this%simvals(i) + + if (q < DZERO) then + rrate = this%pakmvrobj%get_qtomvr(i) ! - ! -- Calculate the flow rate into the cell. - q = this%simvals(i) - - - if (q < DZERO) then - rrate = this%pakmvrobj%get_qtomvr(i) - ! - ! -- Evaluate if qtomvr exceeds the calculated rrate. - ! When fact is greater than 1, qtomvr is numerically - ! larger than rrate (which should never happen) and - ! represents a water budget error. When this happens, - ! rrate is set to 0. so that the water budget error is - ! correctly accounted for in the listing water budget. - fact = -rrate / q - if (fact > DONE) then - ! -- all flow goes to mover - q = DZERO - else - ! -- magnitude of rrate (which is negative) is reduced by - ! qtomvr (which is positive) - q = q + rrate - end if - this%simvals(i) = q - - if (rrate > DZERO) then - rrate = -rrate - end if + ! -- Evaluate if qtomvr exceeds the calculated rrate. + ! When fact is greater than 1, qtomvr is numerically + ! larger than rrate (which should never happen) and + ! represents a water budget error. When this happens, + ! rrate is set to 0. so that the water budget error is + ! correctly accounted for in the listing water budget. + fact = -rrate / q + if (fact > DONE) then + ! -- all flow goes to mover + q = DZERO + else + ! -- magnitude of rrate (which is negative) is reduced by + ! qtomvr (which is positive) + q = q + rrate + end if + this%simvals(i) = q + + if (rrate > DZERO) then + rrate = -rrate end if end if end if - ! - ! -- Save simulated value to simtomvr array. - this%simtomvr(i) = rrate - ! - end do - endif - ! - ! -- return - return - end subroutine bnd_cq_simtomvr - - !> @ brief Add package flows to model budget. - !! - !! Add the flow between package and the model (ratin and ratout) to the - !! model budget. This method only needs to be overridden if a different + end if + ! + ! -- Save simulated value to simtomvr array. + this%simtomvr(i) = rrate + ! + end do + end if + ! + ! -- return + return + end subroutine bnd_cq_simtomvr + + !> @ brief Add package flows to model budget. + !! + !! Add the flow between package and the model (ratin and ratout) to the + !! model budget. This method only needs to be overridden if a different !! calculation needs to be made. !! - !< - subroutine bnd_bd(this, model_budget) - ! -- modules - use TdisModule, only: delt - use BudgetModule, only: BudgetType, rate_accumulator - ! -- dummy variables - class(BndType) :: this !< BndType object - type(BudgetType), intent(inout) :: model_budget !< model budget object - ! -- local variables - character (len=LENPACKAGENAME) :: text - real(DP) :: ratin - real(DP) :: ratout - integer(I4B) :: isuppress_output - ! - ! -- initialize local variables - isuppress_output = 0 - ! - ! -- call accumulator and add to the model budget - call rate_accumulator(this%simvals(1:this%nbound), ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, this%text, & - isuppress_output, this%packName) - if (this%imover == 1 .and. this%isadvpak == 0) then - text = trim(adjustl(this%text)) // '-TO-MVR' - text = adjustr(text) - call rate_accumulator(this%simtomvr(1:this%nbound), ratin, ratout) - call model_budget%addentry(ratin, ratout, delt, text, & - isuppress_output, this%packName) - end if - ! - ! -- return - return - end subroutine bnd_bd + !< + subroutine bnd_bd(this, model_budget) + ! -- modules + use TdisModule, only: delt + use BudgetModule, only: BudgetType, rate_accumulator + ! -- dummy variables + class(BndType) :: this !< BndType object + type(BudgetType), intent(inout) :: model_budget !< model budget object + ! -- local variables + character(len=LENPACKAGENAME) :: text + real(DP) :: ratin + real(DP) :: ratout + integer(I4B) :: isuppress_output + ! + ! -- initialize local variables + isuppress_output = 0 + ! + ! -- call accumulator and add to the model budget + call rate_accumulator(this%simvals(1:this%nbound), ratin, ratout) + call model_budget%addentry(ratin, ratout, delt, this%text, & + isuppress_output, this%packName) + if (this%imover == 1 .and. this%isadvpak == 0) then + text = trim(adjustl(this%text))//'-TO-MVR' + text = adjustr(text) + call rate_accumulator(this%simtomvr(1:this%nbound), ratin, ratout) + call model_budget%addentry(ratin, ratout, delt, text, & + isuppress_output, this%packName) + end if + ! + ! -- return + return + end subroutine bnd_bd - !> @ brief Output advanced package flow terms. + !> @ brief Output advanced package flow terms. !! !! Output advanced boundary package flow terms. This method only needs to - !! be overridden for advanced packages that save flow terms than contribute + !! be overridden for advanced packages that save flow terms than contribute !! to the continuity equation for each control volume. !! - !< - subroutine bnd_ot_package_flows(this, icbcfl, ibudfl) - ! -- dummy variables - class(BndType) :: this !< BndType object - integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output - integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved - ! - ! -- override for advanced packages - ! - ! -- return - return - end subroutine bnd_ot_package_flows - - !> @ brief Output advanced package dependent-variable terms. + !< + subroutine bnd_ot_package_flows(this, icbcfl, ibudfl) + ! -- dummy variables + class(BndType) :: this !< BndType object + integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output + integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved + ! + ! -- override for advanced packages + ! + ! -- return + return + end subroutine bnd_ot_package_flows + + !> @ brief Output advanced package dependent-variable terms. !! - !! Output advanced boundary package dependent-variable terms. This method only needs + !! Output advanced boundary package dependent-variable terms. This method only needs !! to be overridden for advanced packages that save dependent variable terms !! for each control volume. !! - !< - subroutine bnd_ot_dv(this, idvsave, idvprint) - ! -- dummy variables - class(BndType) :: this !< BndType object - integer(I4B), intent(in) :: idvsave !< flag and unit number for dependent-variable output - integer(I4B), intent(in) :: idvprint !< flag indicating if dependent-variable should be written to the model listing file - ! - ! -- override for advanced packages - ! - ! -- return - return - end subroutine bnd_ot_dv - - !> @ brief Output advanced package budget summary. + !< + subroutine bnd_ot_dv(this, idvsave, idvprint) + ! -- dummy variables + class(BndType) :: this !< BndType object + integer(I4B), intent(in) :: idvsave !< flag and unit number for dependent-variable output + integer(I4B), intent(in) :: idvprint !< flag indicating if dependent-variable should be written to the model listing file + ! + ! -- override for advanced packages + ! + ! -- return + return + end subroutine bnd_ot_dv + + !> @ brief Output advanced package budget summary. !! - !! Output advanced boundary package budget summary. This method only needs + !! Output advanced boundary package budget summary. This method only needs !! to be overridden for advanced packages that save budget summaries !! to the model listing file. !! - !< - subroutine bnd_ot_bdsummary(this, kstp, kper, iout, ibudfl) - ! -- dummy variables - class(BndType) :: this !< BndType object - integer(I4B), intent(in) :: kstp !< time step number - integer(I4B), intent(in) :: kper !< period number - integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file - integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written - ! - ! -- override for advanced packages - ! - ! -- return - return - end subroutine bnd_ot_bdsummary - - !> @ brief Output package flow terms. + !< + subroutine bnd_ot_bdsummary(this, kstp, kper, iout, ibudfl) + ! -- dummy variables + class(BndType) :: this !< BndType object + integer(I4B), intent(in) :: kstp !< time step number + integer(I4B), intent(in) :: kper !< period number + integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file + integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written + ! + ! -- override for advanced packages + ! + ! -- return + return + end subroutine bnd_ot_bdsummary + + !> @ brief Output package flow terms. !! - !! Output flow terms between the boundary package and model to a binary file and/or + !! Output flow terms between the boundary package and model to a binary file and/or !! print flows to the model listing file. This method should not need to !! be overridden. !! - !< - subroutine bnd_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) - ! -- dummy variables - class(BndType) :: this !< BndType object - integer(I4B), intent(in) :: icbcfl !< flag for cell-by-cell output - integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved - integer(I4B), intent(in) :: icbcun !< unit number for cell-by-cell output - integer(I4B), dimension(:), optional, intent(in) :: imap !< mapping vector that converts the 1 to nbound values to lake number, maw number, etc. - ! -- local variables - character (len=LINELENGTH) :: title - character (len=LENPACKAGENAME) :: text - integer(I4B) :: imover - ! - ! -- Call generic subroutine to save and print simvals and simtomvr - title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%packName) // & - ') FLOW RATES' - if (present(imap)) then - call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, this%simvals, & - this%ibound, title, this%text, this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, & - this%boundname, imap) - else - call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, this%simvals, & - this%ibound, title, this%text, this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, & - this%boundname) - end if - ! - ! -- Set mover flag, and shut off if this is an advanced package. Advanced - ! packages must handle mover flows differently by including them in - ! their balance equations. These simtomvr flows are the general - ! flow to mover terms calculated by bnd_cq_simtomvr() - imover = this%imover - if (this%isadvpak /= 0) imover = 0 - if (imover == 1) then - text = trim(adjustl(this%text)) // '-TO-MVR' - text = adjustr(text) - title = trim(adjustl(this%text)) // ' PACKAGE (' // & - trim(this%packName) // ') FLOW RATES TO-MVR' - call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & - this%outputtab, this%nbound, this%nodelist, this%simtomvr, & - this%ibound, title, text, this%ipakcb, this%dis, this%naux, & - this%name_model, this%name_model, this%name_model, this%packName, & - this%auxname, this%auxvar, this%iout, this%inamedbound, this%boundname) - end if - ! - ! -- return - return - end subroutine bnd_ot_model_flows + !< + subroutine bnd_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap) + ! -- dummy variables + class(BndType) :: this !< BndType object + integer(I4B), intent(in) :: icbcfl !< flag for cell-by-cell output + integer(I4B), intent(in) :: ibudfl !< flag indication if cell-by-cell data should be saved + integer(I4B), intent(in) :: icbcun !< unit number for cell-by-cell output + integer(I4B), dimension(:), optional, intent(in) :: imap !< mapping vector that converts the 1 to nbound values to lake number, maw number, etc. + ! -- local variables + character(len=LINELENGTH) :: title + character(len=LENPACKAGENAME) :: text + integer(I4B) :: imover + ! + ! -- Call generic subroutine to save and print simvals and simtomvr + title = trim(adjustl(this%text))//' PACKAGE ('//trim(this%packName)// & + ') FLOW RATES' + if (present(imap)) then + call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & + this%outputtab, this%nbound, this%nodelist, & + this%simvals, this%ibound, title, this%text, & + this%ipakcb, this%dis, this%naux, & + this%name_model, this%name_model, & + this%name_model, this%packName, & + this%auxname, this%auxvar, this%iout, & + this%inamedbound, this%boundname, imap) + else + call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & + this%outputtab, this%nbound, this%nodelist, & + this%simvals, this%ibound, title, this%text, & + this%ipakcb, this%dis, this%naux, & + this%name_model, this%name_model, & + this%name_model, this%packName, & + this%auxname, this%auxvar, this%iout, & + this%inamedbound, this%boundname) + end if + ! + ! -- Set mover flag, and shut off if this is an advanced package. Advanced + ! packages must handle mover flows differently by including them in + ! their balance equations. These simtomvr flows are the general + ! flow to mover terms calculated by bnd_cq_simtomvr() + imover = this%imover + if (this%isadvpak /= 0) imover = 0 + if (imover == 1) then + text = trim(adjustl(this%text))//'-TO-MVR' + text = adjustr(text) + title = trim(adjustl(this%text))//' PACKAGE ('// & + trim(this%packName)//') FLOW RATES TO-MVR' + call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, & + this%outputtab, this%nbound, this%nodelist, & + this%simtomvr, this%ibound, title, text, & + this%ipakcb, this%dis, this%naux, & + this%name_model, this%name_model, & + this%name_model, this%packName, & + this%auxname, this%auxvar, this%iout, & + this%inamedbound, this%boundname) + end if + ! + ! -- return + return + end subroutine bnd_ot_model_flows - !> @ brief Deallocate package memory + !> @ brief Deallocate package memory !! - !! Deallocate base boundary package scalars and arrays. This method - !! only needs to be overridden if additional variables are defined + !! Deallocate base boundary package scalars and arrays. This method + !! only needs to be overridden if additional variables are defined !! for a specific package. !! - !< - subroutine bnd_da(this) - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy variables - class(BndType) :: this !< BndType object - ! - ! -- deallocate arrays - call mem_deallocate(this%nodelist, 'NODELIST', this%memoryPath) - call mem_deallocate(this%noupdateauxvar, 'NOUPDATEAUXVAR', this%memoryPath) - call mem_deallocate(this%bound, 'BOUND', this%memoryPath) - call mem_deallocate(this%hcof, 'HCOF', this%memoryPath) - call mem_deallocate(this%rhs, 'RHS', this%memoryPath) - call mem_deallocate(this%simvals, 'SIMVALS', this%memoryPath) - call mem_deallocate(this%simtomvr, 'SIMTOMVR', this%memoryPath) - call mem_deallocate(this%auxvar, 'AUXVAR', this%memoryPath) - call mem_deallocate(this%boundname, 'BOUNDNAME', this%memoryPath) - call mem_deallocate(this%auxname, 'AUXNAME', this%memoryPath) - nullify(this%icelltype) - ! - ! -- pakmvrobj - if (this%imover /= 0) then - call this%pakmvrobj%da() - deallocate(this%pakmvrobj) - nullify(this%pakmvrobj) - endif - ! - ! -- input table object - if (associated(this%inputtab)) then - call this%inputtab%table_da() - deallocate(this%inputtab) - nullify(this%inputtab) - end if - ! - ! -- output table object - if (associated(this%outputtab)) then - call this%outputtab%table_da() - deallocate(this%outputtab) - nullify(this%outputtab) - end if - ! - ! -- error table object - if (associated(this%errortab)) then - call this%errortab%table_da() - deallocate(this%errortab) - nullify(this%errortab) - end if - ! - ! -- deallocate character variables - call mem_deallocate(this%listlabel, 'LISTLABEL', this%memoryPath) - ! - ! -- Deallocate scalars - call mem_deallocate(this%isadvpak) - call mem_deallocate(this%ibcnum) - call mem_deallocate(this%maxbound) - call mem_deallocate(this%nbound) - call mem_deallocate(this%ncolbnd) - call mem_deallocate(this%iscloc) - call mem_deallocate(this%naux) - call mem_deallocate(this%inamedbound) - call mem_deallocate(this%iauxmultcol) - call mem_deallocate(this%inobspkg) - call mem_deallocate(this%imover) - call mem_deallocate(this%npakeq) - call mem_deallocate(this%ioffset) - ! - ! -- deallocate methods on objects - call this%obs%obs_da() - call this%TsManager%da() - call this%TasManager%da() - ! - ! -- deallocate objects - deallocate(this%obs) - deallocate(this%TsManager) - deallocate(this%TasManager) - nullify(this%TsManager) - nullify(this%TasManager) - ! - ! -- Deallocate parent object - call this%NumericalPackageType%da() - ! - ! -- return - return - end subroutine bnd_da + !< + subroutine bnd_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy variables + class(BndType) :: this !< BndType object + ! + ! -- deallocate arrays + call mem_deallocate(this%nodelist, 'NODELIST', this%memoryPath) + call mem_deallocate(this%noupdateauxvar, 'NOUPDATEAUXVAR', this%memoryPath) + call mem_deallocate(this%bound, 'BOUND', this%memoryPath) + call mem_deallocate(this%hcof, 'HCOF', this%memoryPath) + call mem_deallocate(this%rhs, 'RHS', this%memoryPath) + call mem_deallocate(this%simvals, 'SIMVALS', this%memoryPath) + call mem_deallocate(this%simtomvr, 'SIMTOMVR', this%memoryPath) + call mem_deallocate(this%auxvar, 'AUXVAR', this%memoryPath) + call mem_deallocate(this%boundname, 'BOUNDNAME', this%memoryPath) + call mem_deallocate(this%auxname, 'AUXNAME', this%memoryPath) + nullify (this%icelltype) + ! + ! -- pakmvrobj + if (this%imover /= 0) then + call this%pakmvrobj%da() + deallocate (this%pakmvrobj) + nullify (this%pakmvrobj) + end if + ! + ! -- input table object + if (associated(this%inputtab)) then + call this%inputtab%table_da() + deallocate (this%inputtab) + nullify (this%inputtab) + end if + ! + ! -- output table object + if (associated(this%outputtab)) then + call this%outputtab%table_da() + deallocate (this%outputtab) + nullify (this%outputtab) + end if + ! + ! -- error table object + if (associated(this%errortab)) then + call this%errortab%table_da() + deallocate (this%errortab) + nullify (this%errortab) + end if + ! + ! -- deallocate character variables + call mem_deallocate(this%listlabel, 'LISTLABEL', this%memoryPath) + ! + ! -- Deallocate scalars + call mem_deallocate(this%isadvpak) + call mem_deallocate(this%ibcnum) + call mem_deallocate(this%maxbound) + call mem_deallocate(this%nbound) + call mem_deallocate(this%ncolbnd) + call mem_deallocate(this%iscloc) + call mem_deallocate(this%naux) + call mem_deallocate(this%inamedbound) + call mem_deallocate(this%iauxmultcol) + call mem_deallocate(this%inobspkg) + call mem_deallocate(this%imover) + call mem_deallocate(this%npakeq) + call mem_deallocate(this%ioffset) + ! + ! -- deallocate methods on objects + call this%obs%obs_da() + call this%TsManager%da() + call this%TasManager%da() + ! + ! -- deallocate objects + deallocate (this%obs) + deallocate (this%TsManager) + deallocate (this%TasManager) + nullify (this%TsManager) + nullify (this%TasManager) + ! + ! -- Deallocate parent object + call this%NumericalPackageType%da() + ! + ! -- return + return + end subroutine bnd_da - !> @ brief Allocate package scalars - !! - !! Allocate and initialize base boundary package scalars. This method - !! only needs to be overridden if additional scalars are defined - !! for a specific package. - !! - !< - subroutine allocate_scalars(this) - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - use MemoryHelperModule, only: create_mem_path - ! -- dummy variables - class(BndType) :: this !< BndType object - ! -- local variables - integer(I4B), pointer :: imodelnewton => null() - ! - ! -- allocate scalars in NumericalPackageType - call this%NumericalPackageType%allocate_scalars() - ! - ! -- allocate character variables - call mem_allocate(this%listlabel, LENLISTLABEL, 'LISTLABEL', this%memoryPath) - ! - ! -- allocate integer variables - call mem_allocate(this%isadvpak, 'ISADVPAK', this%memoryPath) - call mem_allocate(this%ibcnum, 'IBCNUM', this%memoryPath) - call mem_allocate(this%maxbound, 'MAXBOUND', this%memoryPath) - call mem_allocate(this%nbound, 'NBOUND', this%memoryPath) - call mem_allocate(this%ncolbnd, 'NCOLBND', this%memoryPath) - call mem_allocate(this%iscloc, 'ISCLOC', this%memoryPath) - call mem_allocate(this%naux, 'NAUX', this%memoryPath) - call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%memoryPath) - call mem_allocate(this%iauxmultcol, 'IAUXMULTCOL', this%memoryPath) - call mem_allocate(this%inobspkg, 'INOBSPKG', this%memoryPath) - ! - ! -- allocate the object and assign values to object variables - call mem_allocate(this%imover, 'IMOVER', this%memoryPath) - ! - ! -- allocate scalars for packages that add rows to the matrix (e.g. MAW) - call mem_allocate(this%npakeq, 'NPAKEQ', this%memoryPath) - call mem_allocate(this%ioffset, 'IOFFSET', this%memoryPath) - ! - ! -- allocate TS objects - allocate(this%TsManager) - allocate(this%TasManager) - ! - ! -- allocate text strings - call mem_allocate(this%auxname, LENAUXNAME, 0, 'AUXNAME', this%memoryPath) - ! - ! -- Initialize variables - this%isadvpak = 0 - this%ibcnum = 0 - this%maxbound = 0 - this%nbound = 0 - this%ncolbnd = 0 - this%iscloc = 0 - this%naux = 0 - this%inamedbound = 0 - this%iauxmultcol = 0 - this%inobspkg = 0 - this%imover = 0 - this%npakeq = 0 - this%ioffset = 0 - ! - ! -- Set pointer to model inewton variable - call mem_setptr(imodelnewton, 'INEWTON', create_mem_path(this%name_model)) - this%inewton = imodelnewton - imodelnewton => null() - ! - ! -- return - return - end subroutine allocate_scalars + !> @ brief Allocate package scalars + !! + !! Allocate and initialize base boundary package scalars. This method + !! only needs to be overridden if additional scalars are defined + !! for a specific package. + !! + !< + subroutine allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + use MemoryHelperModule, only: create_mem_path + ! -- dummy variables + class(BndType) :: this !< BndType object + ! -- local variables + integer(I4B), pointer :: imodelnewton => null() + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- allocate character variables + call mem_allocate(this%listlabel, LENLISTLABEL, 'LISTLABEL', & + this%memoryPath) + ! + ! -- allocate integer variables + call mem_allocate(this%isadvpak, 'ISADVPAK', this%memoryPath) + call mem_allocate(this%ibcnum, 'IBCNUM', this%memoryPath) + call mem_allocate(this%maxbound, 'MAXBOUND', this%memoryPath) + call mem_allocate(this%nbound, 'NBOUND', this%memoryPath) + call mem_allocate(this%ncolbnd, 'NCOLBND', this%memoryPath) + call mem_allocate(this%iscloc, 'ISCLOC', this%memoryPath) + call mem_allocate(this%naux, 'NAUX', this%memoryPath) + call mem_allocate(this%inamedbound, 'INAMEDBOUND', this%memoryPath) + call mem_allocate(this%iauxmultcol, 'IAUXMULTCOL', this%memoryPath) + call mem_allocate(this%inobspkg, 'INOBSPKG', this%memoryPath) + ! + ! -- allocate the object and assign values to object variables + call mem_allocate(this%imover, 'IMOVER', this%memoryPath) + ! + ! -- allocate scalars for packages that add rows to the matrix (e.g. MAW) + call mem_allocate(this%npakeq, 'NPAKEQ', this%memoryPath) + call mem_allocate(this%ioffset, 'IOFFSET', this%memoryPath) + ! + ! -- allocate TS objects + allocate (this%TsManager) + allocate (this%TasManager) + ! + ! -- allocate text strings + call mem_allocate(this%auxname, LENAUXNAME, 0, 'AUXNAME', this%memoryPath) + ! + ! -- Initialize variables + this%isadvpak = 0 + this%ibcnum = 0 + this%maxbound = 0 + this%nbound = 0 + this%ncolbnd = 0 + this%iscloc = 0 + this%naux = 0 + this%inamedbound = 0 + this%iauxmultcol = 0 + this%inobspkg = 0 + this%imover = 0 + this%npakeq = 0 + this%ioffset = 0 + ! + ! -- Set pointer to model inewton variable + call mem_setptr(imodelnewton, 'INEWTON', create_mem_path(this%name_model)) + this%inewton = imodelnewton + imodelnewton => null() + ! + ! -- return + return + end subroutine allocate_scalars - !> @ brief Allocate package arrays - !! - !! Allocate and initialize base boundary package arrays. This method - !! only needs to be overridden if additional arrays are defined - !! for a specific package. - !! - !< - subroutine allocate_arrays(this, nodelist, auxvar) - ! -- modules - use MemoryManagerModule, only: mem_allocate, mem_setptr - ! -- dummy variables - class(BndType) :: this !< BndType object - integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist !< package nodelist - real(DP), dimension(:, :), pointer, contiguous, optional :: auxvar !< package aux variable array - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - ! - ! -- Point nodelist if it is passed in, otherwise allocate - if(present(nodelist)) then - this%nodelist => nodelist - else - call mem_allocate(this%nodelist, this%maxbound, 'NODELIST', & - this%memoryPath) - do j = 1, this%maxbound - this%nodelist(j) = 0 - end do - endif - ! - ! -- noupdateauxvar (allows an external caller to stop auxvars from being - ! recalculated - call mem_allocate(this%noupdateauxvar, this%naux, 'NOUPDATEAUXVAR', this%memoryPath) - this%noupdateauxvar(:) = 0 - ! - ! -- Allocate the bound array - call mem_allocate(this%bound, this%ncolbnd, this%maxbound, 'BOUND', & + !> @ brief Allocate package arrays + !! + !! Allocate and initialize base boundary package arrays. This method + !! only needs to be overridden if additional arrays are defined + !! for a specific package. + !! + !< + subroutine allocate_arrays(this, nodelist, auxvar) + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy variables + class(BndType) :: this !< BndType object + integer(I4B), dimension(:), pointer, contiguous, optional :: nodelist !< package nodelist + real(DP), dimension(:, :), pointer, contiguous, optional :: auxvar !< package aux variable array + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + ! + ! -- Point nodelist if it is passed in, otherwise allocate + if (present(nodelist)) then + this%nodelist => nodelist + else + call mem_allocate(this%nodelist, this%maxbound, 'NODELIST', & this%memoryPath) - ! - ! -- Allocate hcof and rhs - call mem_allocate(this%hcof, this%maxbound, 'HCOF', this%memoryPath) - call mem_allocate(this%rhs, this%maxbound, 'RHS', this%memoryPath) - ! - ! -- Allocate the simvals array - call mem_allocate(this%simvals, this%maxbound, 'SIMVALS', this%memoryPath) - if (this%imover == 1) then - call mem_allocate(this%simtomvr, this%maxbound, 'SIMTOMVR', this%memoryPath) - do i = 1, this%maxbound - this%simtomvr(i) = DZERO - enddo - else - call mem_allocate(this%simtomvr, 0, 'SIMTOMVR', this%memoryPath) - endif - ! - ! -- Point or allocate auxvar - if(present(auxvar)) then - this%auxvar => auxvar - else - call mem_allocate(this%auxvar, this%naux, this%maxbound, 'AUXVAR', & - this%memoryPath) - do i = 1, this%maxbound - do j = 1, this%naux - this%auxvar(j, i) = DZERO - end do - end do - endif - ! - ! -- Allocate boundname - if (this%inamedbound /= 0) then - call mem_allocate(this%boundname, LENBOUNDNAME, this%maxbound, & - 'BOUNDNAME', this%memoryPath) - else - call mem_allocate(this%boundname, LENBOUNDNAME, 0, & - 'BOUNDNAME', this%memoryPath) - end if - ! - ! -- Set pointer to ICELLTYPE. For GWF boundary packages, - ! this%ictMemPath will be 'NPF'. If boundary packages do not set - ! this%ictMemPath, then icelltype will remain as null() - if (this%ictMemPath /= '') then - call mem_setptr(this%icelltype, 'ICELLTYPE', this%ictMemPath) - end if - ! - ! -- Initialize values do j = 1, this%maxbound - do i = 1, this%ncolbnd - this%bound(i, j) = DZERO - end do + this%nodelist(j) = 0 + end do + end if + ! + ! -- noupdateauxvar (allows an external caller to stop auxvars from being + ! recalculated + call mem_allocate(this%noupdateauxvar, this%naux, 'NOUPDATEAUXVAR', & + this%memoryPath) + this%noupdateauxvar(:) = 0 + ! + ! -- Allocate the bound array + call mem_allocate(this%bound, this%ncolbnd, this%maxbound, 'BOUND', & + this%memoryPath) + ! + ! -- Allocate hcof and rhs + call mem_allocate(this%hcof, this%maxbound, 'HCOF', this%memoryPath) + call mem_allocate(this%rhs, this%maxbound, 'RHS', this%memoryPath) + ! + ! -- Allocate the simvals array + call mem_allocate(this%simvals, this%maxbound, 'SIMVALS', this%memoryPath) + if (this%imover == 1) then + call mem_allocate(this%simtomvr, this%maxbound, 'SIMTOMVR', & + this%memoryPath) + do i = 1, this%maxbound + this%simtomvr(i) = DZERO end do + else + call mem_allocate(this%simtomvr, 0, 'SIMTOMVR', this%memoryPath) + end if + ! + ! -- Point or allocate auxvar + if (present(auxvar)) then + this%auxvar => auxvar + else + call mem_allocate(this%auxvar, this%naux, this%maxbound, 'AUXVAR', & + this%memoryPath) do i = 1, this%maxbound - this%hcof(i) = DZERO - this%rhs(i) = DZERO + do j = 1, this%naux + this%auxvar(j, i) = DZERO + end do end do - ! - ! -- setup the output table - call this%pak_setup_outputtab() - ! - ! -- return - return - end subroutine allocate_arrays + end if + ! + ! -- Allocate boundname + if (this%inamedbound /= 0) then + call mem_allocate(this%boundname, LENBOUNDNAME, this%maxbound, & + 'BOUNDNAME', this%memoryPath) + else + call mem_allocate(this%boundname, LENBOUNDNAME, 0, & + 'BOUNDNAME', this%memoryPath) + end if + ! + ! -- Set pointer to ICELLTYPE. For GWF boundary packages, + ! this%ictMemPath will be 'NPF'. If boundary packages do not set + ! this%ictMemPath, then icelltype will remain as null() + if (this%ictMemPath /= '') then + call mem_setptr(this%icelltype, 'ICELLTYPE', this%ictMemPath) + end if + ! + ! -- Initialize values + do j = 1, this%maxbound + do i = 1, this%ncolbnd + this%bound(i, j) = DZERO + end do + end do + do i = 1, this%maxbound + this%hcof(i) = DZERO + this%rhs(i) = DZERO + end do + ! + ! -- setup the output table + call this%pak_setup_outputtab() + ! + ! -- return + return + end subroutine allocate_arrays - !> @ brief Allocate and initialize select package members + !> @ brief Allocate and initialize select package members !! - !! Allocate and initialize select base boundary package members. - !! This method needs to be overridden by a package if it is + !! Allocate and initialize select base boundary package members. + !! This method needs to be overridden by a package if it is !! needed for a specific package. !! - !< - subroutine pack_initialize(this) - ! -- dummy variables - class(BndType) :: this !< BndType object - ! - ! -- return - return - end subroutine pack_initialize + !< + subroutine pack_initialize(this) + ! -- dummy variables + class(BndType) :: this !< BndType object + ! + ! -- return + return + end subroutine pack_initialize - !> @ brief Set pointers to model variables + !> @ brief Set pointers to model variables !! !! Set pointers to model variables so that a package has access to these !! variables. This base method should not need to be overridden. !! - !< - subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) - ! -- dummy variables - class(BndType) :: this !< BndType object - integer(I4B), pointer :: neq !< number of equations in the model - integer(I4B), dimension(:), pointer, contiguous :: ibound !< model idomain - real(DP), dimension(:), pointer, contiguous :: xnew !< current dependent variable - real(DP), dimension(:), pointer, contiguous :: xold !< previous dependent variable - real(DP), dimension(:), pointer, contiguous :: flowja !< connection flow terms - ! - ! -- Set the pointers - this%neq => neq - this%ibound => ibound - this%xnew => xnew - this%xold => xold - this%flowja => flowja - ! - ! -- return - end subroutine set_pointers + !< + subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) + ! -- dummy variables + class(BndType) :: this !< BndType object + integer(I4B), pointer :: neq !< number of equations in the model + integer(I4B), dimension(:), pointer, contiguous :: ibound !< model idomain + real(DP), dimension(:), pointer, contiguous :: xnew !< current dependent variable + real(DP), dimension(:), pointer, contiguous :: xold !< previous dependent variable + real(DP), dimension(:), pointer, contiguous :: flowja !< connection flow terms + ! + ! -- Set the pointers + this%neq => neq + this%ibound => ibound + this%xnew => xnew + this%xold => xold + this%flowja => flowja + ! + ! -- return + end subroutine set_pointers - !> @ brief Read additional options for package + !> @ brief Read additional options for package !! !! Read base options for boundary packages. !! - !< - subroutine bnd_read_options(this) - ! -- modules - use InputOutputModule, only: urdaux - use MemoryManagerModule, only: mem_reallocate - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! -- local variables - character(len=:), allocatable :: line - character(len=LINELENGTH) :: fname - character(len=LINELENGTH) :: keyword - character(len=LENAUXNAME) :: sfacauxname - character(len=LENAUXNAME), dimension(:), allocatable :: caux - integer(I4B) :: lloc - integer(I4B) :: istart - integer(I4B) :: istop - integer(I4B) :: n - integer(I4B) :: ierr - integer(I4B) :: inobs - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - logical(LGP) :: foundchildclassoption - ! -- format - character(len=*),parameter :: fmtflow = & - "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" - character(len=*),parameter :: fmtflow2 = & - "(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" - character(len=*), parameter :: fmttas = & - "(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" - character(len=*), parameter :: fmtts = & - "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" - character(len=*), parameter :: fmtnme = & - "(a, i0, a)" - ! - ! -- set default options - ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected - if (isfound) then - write(this%iout,'(/1x,a)') 'PROCESSING '//trim(adjustl(this%text)) & - //' OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) then - exit + !< + subroutine bnd_read_options(this) + ! -- modules + use InputOutputModule, only: urdaux + use MemoryManagerModule, only: mem_reallocate + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! -- local variables + character(len=:), allocatable :: line + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: keyword + character(len=LENAUXNAME) :: sfacauxname + character(len=LENAUXNAME), dimension(:), allocatable :: caux + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: n + integer(I4B) :: ierr + integer(I4B) :: inobs + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + logical(LGP) :: foundchildclassoption + ! -- format + character(len=*), parameter :: fmtflow = & + &"(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtflow2 = & + &"(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')" + character(len=*), parameter :: fmttas = & + &"(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*), parameter :: fmtts = & + &"(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + character(len=*), parameter :: fmtnme = & + &"(a, i0, a)" + ! + ! -- set default options + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text)) & + //' OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) then + exit + end if + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('AUX', 'AUXILIARY') + call this%parser%GetRemainingLine(line) + lloc = 1 + call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & + istart, istop, caux, line, this%text) + call mem_reallocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', this%memoryPath) + do n = 1, this%naux + this%auxname(n) = caux(n) + end do + deallocate (caux) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtflow2) + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') & + 'LISTS OF '//trim(adjustl(this%text))//' CELLS WILL BE PRINTED.' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' FLOWS WILL BE PRINTED TO LISTING FILE.' + case ('BOUNDNAMES') + this%inamedbound = 1 + write (this%iout, '(4x,a)') trim(adjustl(this%text))// & + ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' + case ('TS6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' + call store_error(errmsg) + end if + call this%parser%GetString(fname) + write (this%iout, fmtts) trim(fname) + call this%TsManager%add_tsfile(fname, this%inunit) + case ('TAS6') + if (this%AllowTimeArraySeries) then + if (.not. this%dis%supports_layers()) then + errmsg = 'TAS6 FILE cannot be used '// & + 'with selected discretization type.' + call store_error(errmsg) + end if + else + errmsg = 'The '//trim(this%filtyp)// & + ' package does not support TIMEARRAYSERIESFILE' + call store_error(errmsg) + call this%parser%StoreErrorUnit() end if call this%parser%GetStringCaps(keyword) - select case (keyword) - case('AUX', 'AUXILIARY') - call this%parser%GetRemainingLine(line) - lloc = 1 - call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & - istart, istop, caux, line, this%text) - call mem_reallocate(this%auxname, LENAUXNAME, this%naux, & - 'AUXNAME', this%memoryPath) - do n = 1, this%naux - this%auxname(n) = caux(n) - end do - deallocate(caux) - case ('SAVE_FLOWS') - this%ipakcb = -1 - write(this%iout, fmtflow2) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout,'(4x,a)') 'LISTS OF '//trim(adjustl(this%text))// & - ' CELLS WILL BE PRINTED.' - case ('PRINT_FLOWS') - this%iprflow = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' FLOWS WILL BE PRINTED TO LISTING FILE.' - case ('BOUNDNAMES') - this%inamedbound = 1 - write(this%iout,'(4x,a)') trim(adjustl(this%text))// & - ' BOUNDARIES HAVE NAMES IN LAST COLUMN.' - case ('TS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - endif - call this%parser%GetString(fname) - write(this%iout,fmtts)trim(fname) - call this%TsManager%add_tsfile(fname, this%inunit) - case ('TAS6') - if (this%AllowTimeArraySeries) then - if (.not. this%dis%supports_layers()) then - errmsg = 'TAS6 FILE cannot be used ' // & - 'with selected discretization type.' - call store_error(errmsg) - endif - else - errmsg = 'The ' // trim(this%filtyp) // & - ' package does not support TIMEARRAYSERIESFILE' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - call this%parser%GetString(fname) - write(this%iout,fmttas)trim(fname) - call this%TasManager%add_tasfile(fname) - case ('AUXMULTNAME') - call this%parser%GetStringCaps(sfacauxname) - this%iauxmultcol = -1 - write(this%iout, '(4x,a,a)') & - 'AUXILIARY MULTIPLIER NAME: ', sfacauxname - case ('OBS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'OBS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - if (this%obs%active) then - errmsg = 'Multiple OBS6 keywords detected in OPTIONS block. ' // & - 'Only one OBS6 entry allowed for a package.' - call store_error(errmsg) - endif - this%obs%active = .true. - call this%parser%GetString(this%obs%inputFilename) - inobs = GetUnit() - call openfile(inobs, this%iout, this%obs%inputFilename, 'OBS') - this%obs%inUnitObs = inobs - ! - ! -- right now these are options that are only available in the - ! development version and are not included in the documentation. - ! These options are only available when IDEVELOPMODE in - ! constants module is set to 1 - case ('DEV_NO_NEWTON') - call this%parser%DevOpt() - this%inewton = 0 - write(this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method disabled for unconfined cells' - case default - ! - ! -- Check for child class options - call this%bnd_options(keyword, foundchildclassoption) - ! - ! -- No child class options found, so print error message - if(.not. foundchildclassoption) then - write(errmsg,'(a,3(1x,a))') & - 'UNKNOWN', trim(adjustl(this%text)), 'OPTION:', trim(keyword) - call store_error(errmsg) - endif - end select - end do - write(this%iout,'(1x,a)') 'END OF '//trim(adjustl(this%text)) // ' OPTIONS' - else - write(this%iout,'(1x,a)') 'NO '//trim(adjustl(this%text)) // & - ' OPTION BLOCK DETECTED.' + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + call this%parser%GetString(fname) + write (this%iout, fmttas) trim(fname) + call this%TasManager%add_tasfile(fname) + case ('AUXMULTNAME') + call this%parser%GetStringCaps(sfacauxname) + this%iauxmultcol = -1 + write (this%iout, '(4x,a,a)') & + 'AUXILIARY MULTIPLIER NAME: ', sfacauxname + case ('OBS6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'OBS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + if (this%obs%active) then + errmsg = 'Multiple OBS6 keywords detected in OPTIONS block. '// & + 'Only one OBS6 entry allowed for a package.' + call store_error(errmsg) + end if + this%obs%active = .true. + call this%parser%GetString(this%obs%inputFilename) + inobs = GetUnit() + call openfile(inobs, this%iout, this%obs%inputFilename, 'OBS') + this%obs%inUnitObs = inobs + ! + ! -- right now these are options that are only available in the + ! development version and are not included in the documentation. + ! These options are only available when IDEVELOPMODE in + ! constants module is set to 1 + case ('DEV_NO_NEWTON') + call this%parser%DevOpt() + this%inewton = 0 + write (this%iout, '(4x,a)') & + 'NEWTON-RAPHSON method disabled for unconfined cells' + case default + ! + ! -- Check for child class options + call this%bnd_options(keyword, foundchildclassoption) + ! + ! -- No child class options found, so print error message + if (.not. foundchildclassoption) then + write (errmsg, '(a,3(1x,a))') & + 'UNKNOWN', trim(adjustl(this%text)), 'OPTION:', trim(keyword) + call store_error(errmsg) + end if + end select + end do + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' OPTIONS' + else + write (this%iout, '(1x,a)') 'NO '//trim(adjustl(this%text))// & + ' OPTION BLOCK DETECTED.' + end if + ! + ! -- AUXMULTNAME was specified, so find column of auxvar that will be multiplier + if (this%iauxmultcol < 0) then + ! + ! -- Error if no aux variable specified + if (this%naux == 0) then + write (errmsg, '(a,2(1x,a))') & + 'AUXMULTNAME WAS SPECIFIED AS', trim(adjustl(sfacauxname)), & + 'BUT NO AUX VARIABLES SPECIFIED.' + call store_error(errmsg) end if ! - ! -- AUXMULTNAME was specified, so find column of auxvar that will be multiplier - if(this%iauxmultcol < 0) then - ! - ! -- Error if no aux variable specified - if(this%naux == 0) then - write(errmsg,'(a,2(1x,a))') & - 'AUXMULTNAME WAS SPECIFIED AS', trim(adjustl(sfacauxname)), & - 'BUT NO AUX VARIABLES SPECIFIED.' - call store_error(errmsg) - endif - ! - ! -- Assign mult column - this%iauxmultcol = 0 - do n = 1, this%naux - if(sfacauxname == this%auxname(n)) then - this%iauxmultcol = n - exit - endif - enddo - ! - ! -- Error if aux variable cannot be found - if(this%iauxmultcol == 0) then - write(errmsg,'(a,2(1x,a))') & - 'AUXMULTNAME WAS SPECIFIED AS', trim(adjustl(sfacauxname)), & - 'BUT NO AUX VARIABLE FOUND WITH THIS NAME.' - call store_error(errmsg) - endif - end if + ! -- Assign mult column + this%iauxmultcol = 0 + do n = 1, this%naux + if (sfacauxname == this%auxname(n)) then + this%iauxmultcol = n + exit + end if + end do ! - ! -- terminate if errors were detected - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- Error if aux variable cannot be found + if (this%iauxmultcol == 0) then + write (errmsg, '(a,2(1x,a))') & + 'AUXMULTNAME WAS SPECIFIED AS', trim(adjustl(sfacauxname)), & + 'BUT NO AUX VARIABLE FOUND WITH THIS NAME.' + call store_error(errmsg) end if - ! - ! -- return - return - end subroutine bnd_read_options + end if + ! + ! -- terminate if errors were detected + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- return + return + end subroutine bnd_read_options - !> @ brief Read dimensions for package + !> @ brief Read dimensions for package !! !! Read base dimensions for boundary packages. This method should not !! need to be overridden unless more than MAXBOUND is specified in the !! DIMENSIONS block. !! - !< - subroutine bnd_read_dimensions(this) - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! -- local variables - character(len=LINELENGTH) :: keyword - logical(LGP) :: isfound - logical(LGP) :: endOfBlock - integer(I4B) :: ierr - ! - ! -- get dimensions block - call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & - supportOpenClose=.true.) - ! - ! -- parse dimensions block if detected - if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(this%text))// & - ' DIMENSIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('MAXBOUND') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - case default - write(errmsg,'(a,3(1x,a))') & - 'UNKNOWN', trim(this%text), 'DIMENSION:', trim(keyword) - call store_error(errmsg) - end select - end do - ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(this%text))//' DIMENSIONS' - else - call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.') - call this%parser%StoreErrorUnit() - end if - ! - ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(a)') 'MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' - call store_error(errmsg) - end if - ! - ! -- terminate if there are errors - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() - end if - ! - ! -- Call define_listlabel to construct the list label that is written - ! when PRINT_INPUT option is used. - call this%define_listlabel() + !< + subroutine bnd_read_dimensions(this) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! -- local variables + character(len=LINELENGTH) :: keyword + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + integer(I4B) :: ierr + ! + ! -- get dimensions block + call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse dimensions block if detected + if (isfound) then + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// & + ' DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('MAXBOUND') + this%maxbound = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'MAXBOUND = ', this%maxbound + case default + write (errmsg, '(a,3(1x,a))') & + 'UNKNOWN', trim(this%text), 'DIMENSION:', trim(keyword) + call store_error(errmsg) + end select + end do ! - ! -- return - return - end subroutine bnd_read_dimensions + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(this%text))//' DIMENSIONS' + else + call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + end if + ! + ! -- verify dimensions were set + if (this%maxbound <= 0) then + write (errmsg, '(a)') 'MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' + call store_error(errmsg) + end if + ! + ! -- terminate if there are errors + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- Call define_listlabel to construct the list label that is written + ! when PRINT_INPUT option is used. + call this%define_listlabel() + ! + ! -- return + return + end subroutine bnd_read_dimensions - !> @ brief Read initial parameters for package + !> @ brief Read initial parameters for package !! !! Read initial parameters for a boundary package. This method is not !! needed for most boundary packages. The SFR package is an example of a !! package that has overridden this method. !! - !< - subroutine bnd_read_initial_attr(this) - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! - ! -- return - return - end subroutine bnd_read_initial_attr + !< + subroutine bnd_read_initial_attr(this) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! + ! -- return + return + end subroutine bnd_read_initial_attr - !> @ brief Read additional options for package + !> @ brief Read additional options for package !! !! Read additional options for a boundary package. This method should !! be overridden options in addition to the base options are implemented !! in a boundary package. !! - !< - subroutine bnd_options(this, option, found) - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - character(len=*), intent(inout) :: option !< option keyword string - logical(LGP), intent(inout) :: found !< boolean indicating if the option was found - ! - ! Return with found = .false. - found = .false. - ! - ! -- return - return - end subroutine bnd_options + !< + subroutine bnd_options(this, option, found) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + character(len=*), intent(inout) :: option !< option keyword string + logical(LGP), intent(inout) :: found !< boolean indicating if the option was found + ! + ! Return with found = .false. + found = .false. + ! + ! -- return + return + end subroutine bnd_options - !> @ brief Setup output table for package + !> @ brief Setup output table for package !! !! Setup output table for a boundary package that is used to output !! package to model flow terms to the model listing file. !! - !< - subroutine pak_setup_outputtab(this) - ! -- dummy variables - class(BndType),intent(inout) :: this !< BndType object - ! -- local variables - character(len=LINELENGTH) :: title - character(len=LINELENGTH) :: text - integer(I4B) :: ntabcol + !< + subroutine pak_setup_outputtab(this) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! -- local variables + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: ntabcol + ! + ! -- allocate and initialize the output table + if (this%iprflow /= 0) then ! - ! -- allocate and initialize the output table - if (this%iprflow /= 0) then - ! - ! -- dimension table - ntabcol = 3 - if (this%inamedbound > 0) then - ntabcol = ntabcol + 1 - end if - ! - ! -- initialize the output table object - title = trim(adjustl(this%text)) // ' PACKAGE (' // trim(this%packName) // & - ') FLOW RATES' - call table_cr(this%outputtab, this%packName, title) - call this%outputtab%table_df(this%maxbound, ntabcol, this%iout, & - transient=.TRUE.) - text = 'NUMBER' - call this%outputtab%initialize_column(text, 10, alignment=TABCENTER) - text = 'CELLID' - call this%outputtab%initialize_column(text, 20, alignment=TABLEFT) - text = 'RATE' - call this%outputtab%initialize_column(text, 15, alignment=TABCENTER) - if (this%inamedbound > 0) then - text = 'NAME' - call this%outputtab%initialize_column(text, LENBOUNDNAME, alignment=TABLEFT) - end if + ! -- dimension table + ntabcol = 3 + if (this%inamedbound > 0) then + ntabcol = ntabcol + 1 end if ! - ! -- return - return - end subroutine pak_setup_outputtab - + ! -- initialize the output table object + title = trim(adjustl(this%text))//' PACKAGE ('//trim(this%packName)// & + ') FLOW RATES' + call table_cr(this%outputtab, this%packName, title) + call this%outputtab%table_df(this%maxbound, ntabcol, this%iout, & + transient=.TRUE.) + text = 'NUMBER' + call this%outputtab%initialize_column(text, 10, alignment=TABCENTER) + text = 'CELLID' + call this%outputtab%initialize_column(text, 20, alignment=TABLEFT) + text = 'RATE' + call this%outputtab%initialize_column(text, 15, alignment=TABCENTER) + if (this%inamedbound > 0) then + text = 'NAME' + call this%outputtab%initialize_column(text, LENBOUNDNAME, & + alignment=TABLEFT) + end if + end if + ! + ! -- return + return + end subroutine pak_setup_outputtab - !> @ brief Define the list label for the package + !> @ brief Define the list label for the package !! !! Method defined the list label for the boundary package. This method !! needs to be overridden by each boundary package. !! - !< - subroutine define_listlabel(this) - ! -- dummy variables - class(BndType), intent(inout) :: this !< BndType object - ! - ! -- return - return - end subroutine define_listlabel + !< + subroutine define_listlabel(this) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! + ! -- return + return + end subroutine define_listlabel - ! -- Procedures related to observations + ! -- Procedures related to observations - !> @brief Determine if observations are supported. + !> @brief Determine if observations are supported. !! !! Function to determine if observations are supported by the boundary package. !! By default, observations are not supported. This method should be overridden @@ -1546,405 +1556,407 @@ end subroutine define_listlabel !! !! @return supported boolean indicating if observations are supported !! - !< - function bnd_obs_supported(this) result(supported) - ! -- return variable - logical(LGP) :: supported !< boolean indicating if observations are supported - ! -- dummy variables - class(BndType) :: this !< BndType object - ! - ! -- initialize return variables - supported = .false. - ! - ! -- return - return - end function bnd_obs_supported + !< + function bnd_obs_supported(this) result(supported) + ! -- return variable + logical(LGP) :: supported !< boolean indicating if observations are supported + ! -- dummy variables + class(BndType) :: this !< BndType object + ! + ! -- initialize return variables + supported = .false. + ! + ! -- return + return + end function bnd_obs_supported - !> @brief Define the observation types available in the package + !> @brief Define the observation types available in the package !! - !! Method to define the observation types available in a boundary - !! package. This method should be overridden if observations are + !! Method to define the observation types available in a boundary + !! package. This method should be overridden if observations are !! supported in a boundary package. !! - !< - subroutine bnd_df_obs(this) - ! - ! -- dummy variables - class(BndType) :: this !< BndType object - ! - ! -- do nothing here. Override as needed. - ! - ! -- return - return - end subroutine bnd_df_obs + !< + subroutine bnd_df_obs(this) + ! + ! -- dummy variables + class(BndType) :: this !< BndType object + ! + ! -- do nothing here. Override as needed. + ! + ! -- return + return + end subroutine bnd_df_obs - !> @brief Read and prepare observations for a package + !> @brief Read and prepare observations for a package !! !! Method to read and prepare observations for a boundary package !! This method should not need to be overridden for most boundary !! packages. !! - !< - subroutine bnd_rp_obs(this) - ! -- dummy variables - class(BndType), intent(inout) :: this !< BndType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: j - class(ObserveType), pointer :: obsrv => null() - character(len=LENBOUNDNAME) :: bname - logical(LGP) :: jfound + !< + subroutine bnd_rp_obs(this) + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + class(ObserveType), pointer :: obsrv => null() + character(len=LENBOUNDNAME) :: bname + logical(LGP) :: jfound + ! + if (.not. this%bnd_obs_supported()) return + ! + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv ! - if (.not. this%bnd_obs_supported()) return + ! -- indxbnds needs to be reset each stress period because + ! list of boundaries can change each stress period. + call obsrv%ResetObsIndex() + obsrv%BndFound = .false. ! - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv + bname = obsrv%FeatureName + if (bname /= '') then ! - ! -- indxbnds needs to be reset each stress period because - ! list of boundaries can change each stress period. - call obsrv%ResetObsIndex() - obsrv%BndFound = .false. + ! -- Observation location(s) is(are) based on a boundary name. + ! Iterate through all boundaries to identify and store + ! corresponding index(indices) in bound array. + jfound = .false. + do j = 1, this%nbound + if (this%boundname(j) == bname) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call obsrv%AddObsIndex(j) + end if + end do + else ! - bname = obsrv%FeatureName - if (bname /= '') then - ! - ! -- Observation location(s) is(are) based on a boundary name. - ! Iterate through all boundaries to identify and store - ! corresponding index(indices) in bound array. - jfound = .false. - do j=1,this%nbound - if (this%boundname(j) == bname) then - jfound = .true. - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call obsrv%AddObsIndex(j) - end if - end do - else - ! - ! -- Observation location is a single node number - jfound = .false. - jloop: do j=1,this%nbound - if (this%nodelist(j) == obsrv%NodeNumber) then - jfound = .true. - obsrv%BndFound = .true. - obsrv%CurrentTimeStepEndValue = DZERO - call obsrv%AddObsIndex(j) - end if - end do jloop - end if - end do - ! - if (count_errors() > 0) then - call store_error_unit(this%inunit) - endif - ! - return - end subroutine bnd_rp_obs + ! -- Observation location is a single node number + jfound = .false. + jloop: do j = 1, this%nbound + if (this%nodelist(j) == obsrv%NodeNumber) then + jfound = .true. + obsrv%BndFound = .true. + obsrv%CurrentTimeStepEndValue = DZERO + call obsrv%AddObsIndex(j) + end if + end do jloop + end if + end do + ! + if (count_errors() > 0) then + call store_error_unit(this%inunit) + end if + ! + return + end subroutine bnd_rp_obs - !> @brief Save observations for the package + !> @brief Save observations for the package !! !! Method to save simulated values for the boundary package. !! This method will need to be overridden for boundary packages !! with more observations than the calculate flow term (simvals) !! and to-mover. !! - !< - subroutine bnd_bd_obs(this) - ! -- dummy variables - class(BndType) :: this !< BndType object - ! -- local variables - integer(I4B) :: i - integer(I4B) :: n - real(DP) :: v - type(ObserveType), pointer :: obsrv => null() - ! - ! -- clear the observations - call this%obs%obs_bd_clear() - ! - ! -- Save simulated values for all of package's observations. - do i = 1, this%obs%npakobs - obsrv => this%obs%pakobs(i)%obsrv - if (obsrv%BndFound) then - do n = 1, obsrv%indxbnds_count - if (obsrv%ObsTypeId == 'TO-MVR') then - if (this%imover == 1) then - v = this%pakmvrobj%get_qtomvr(obsrv%indxbnds(n)) - if (v > DZERO) then - v = -v - end if - else - v = DNODATA + !< + subroutine bnd_bd_obs(this) + ! -- dummy variables + class(BndType) :: this !< BndType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: n + real(DP) :: v + type(ObserveType), pointer :: obsrv => null() + ! + ! -- clear the observations + call this%obs%obs_bd_clear() + ! + ! -- Save simulated values for all of package's observations. + do i = 1, this%obs%npakobs + obsrv => this%obs%pakobs(i)%obsrv + if (obsrv%BndFound) then + do n = 1, obsrv%indxbnds_count + if (obsrv%ObsTypeId == 'TO-MVR') then + if (this%imover == 1) then + v = this%pakmvrobj%get_qtomvr(obsrv%indxbnds(n)) + if (v > DZERO) then + v = -v end if else - v = this%simvals(obsrv%indxbnds(n)) + v = DNODATA end if - call this%obs%SaveOneSimval(obsrv, v) - end do - else - call this%obs%SaveOneSimval(obsrv, DNODATA) - end if - end do - ! - ! -- return - return - end subroutine bnd_bd_obs + else + v = this%simvals(obsrv%indxbnds(n)) + end if + call this%obs%SaveOneSimval(obsrv, v) + end do + else + call this%obs%SaveOneSimval(obsrv, DNODATA) + end if + end do + ! + ! -- return + return + end subroutine bnd_bd_obs - !> @brief Output observations for the package + !> @brief Output observations for the package !! !! Method to output simulated values for the boundary package. !! This method should not need to be overridden. !! - !< - subroutine bnd_ot_obs(this) - ! -- dummy variables - class(BndType) :: this !< BndType object - ! - ! -- call the observation output method - call this%obs%obs_ot() - ! - ! -- return - return - end subroutine bnd_ot_obs + !< + subroutine bnd_ot_obs(this) + ! -- dummy variables + class(BndType) :: this !< BndType object + ! + ! -- call the observation output method + call this%obs%obs_ot() + ! + ! -- return + return + end subroutine bnd_ot_obs - ! -- Procedures related to time series + ! -- Procedures related to time series - !> @brief Assign time series links for the package + !> @brief Assign time series links for the package !! !! Assign the time series links for the boundary package. This !! method will need to be overridden for boundary packages that !! support time series. !! - !< - subroutine bnd_rp_ts(this) - ! -- dummy variables - class(BndType), intent(inout) :: this - ! - ! -- return - return - end subroutine bnd_rp_ts + !< + subroutine bnd_rp_ts(this) + ! -- dummy variables + class(BndType), intent(inout) :: this + ! + ! -- return + return + end subroutine bnd_rp_ts - ! -- Procedures related to casting + ! -- Procedures related to casting - !> @brief Cast as a boundary tyoe + !> @brief Cast as a boundary tyoe !! !! Subroutine to cast an object as a boundary package type. !! - !< - function CastAsBndClass(obj) result(res) - class(*), pointer, intent(inout) :: obj !< input object - class(BndType), pointer :: res !< output class of type BndType - ! - ! -- initialize res - res => null() - ! - ! -- make sure obj is associated - if (.not. associated(obj)) return - ! - ! -- point res to obj - select type (obj) - class is (BndType) - res => obj - end select - ! - ! -- return - return - end function CastAsBndClass + !< + function CastAsBndClass(obj) result(res) + class(*), pointer, intent(inout) :: obj !< input object + class(BndType), pointer :: res !< output class of type BndType + ! + ! -- initialize res + res => null() + ! + ! -- make sure obj is associated + if (.not. associated(obj)) return + ! + ! -- point res to obj + select type (obj) + class is (BndType) + res => obj + end select + ! + ! -- return + return + end function CastAsBndClass - !> @brief Add boundary to package list + !> @brief Add boundary to package list !! !! Subroutine to add a boundary package to a package list. !! - !< - subroutine AddBndToList(list, bnd) - ! -- dummy variables - type(ListType), intent(inout) :: list !< package list - class(BndType), pointer, intent(inout) :: bnd !< boundary package - ! -- local variables - class(*), pointer :: obj - ! - obj => bnd - call list%Add(obj) - ! - ! -- return - return - end subroutine AddBndToList + !< + subroutine AddBndToList(list, bnd) + ! -- dummy variables + type(ListType), intent(inout) :: list !< package list + class(BndType), pointer, intent(inout) :: bnd !< boundary package + ! -- local variables + class(*), pointer :: obj + ! + obj => bnd + call list%Add(obj) + ! + ! -- return + return + end subroutine AddBndToList - !> @brief Get boundary from package list + !> @brief Get boundary from package list !! !! Function to get a boundary package from a package list. !! !! @return res boundary package object !! - !< - function GetBndFromList(list, idx) result (res) - ! -- dummy variables - type(ListType), intent(inout) :: list !< package list - integer(I4B), intent(in) :: idx !< package number - class(BndType), pointer :: res !< boundary package idx - ! -- local variables - class(*), pointer :: obj - ! - ! -- get the package from the list - obj => list%GetItem(idx) - res => CastAsBndClass(obj) - ! - ! -- return - return - end function GetBndFromList + !< + function GetBndFromList(list, idx) result(res) + ! -- dummy variables + type(ListType), intent(inout) :: list !< package list + integer(I4B), intent(in) :: idx !< package number + class(BndType), pointer :: res !< boundary package idx + ! -- local variables + class(*), pointer :: obj + ! + ! -- get the package from the list + obj => list%GetItem(idx) + res => CastAsBndClass(obj) + ! + ! -- return + return + end function GetBndFromList - !> @brief Save and/or print flows for a package + !> @brief Save and/or print flows for a package !! !! Subroutine to save and/or print package flows to a model to a !! binary cell-by-cell flow file and the model listing file. !! - !< - subroutine save_print_model_flows(icbcfl, ibudfl, icbcun, iprflow, & - outputtab, nbound, nodelist, flow, ibound, title, text, ipakcb, dis, naux, & - textmodel, textpackage, dstmodel, dstpackage, auxname, auxvar, iout, & - inamedbound, boundname, imap) - ! -- modules - use TdisModule, only: kstp, kper - ! -- dummy variables - integer(I4B), intent(in) :: icbcfl !< flag indicating if the flow should be saved to the binary cell-by-cell flow file - integer(I4B), intent(in) :: ibudfl !< flag indicating if the flow should be saved or printed - integer(I4B), intent(in) :: icbcun !< file unit number for the binary cell-by-cell file - integer(I4B), intent(in) :: iprflow !< print flows to list file - type(TableType), pointer, intent(inout) :: outputtab !< output table object - integer(I4B), intent(in) :: nbound !< number of boundaries this stress period - integer(I4B), dimension(:), contiguous, intent(in) :: nodelist !< boundary node list - real(DP), dimension(:), contiguous, intent(in) :: flow !< boundary flow terms - integer(I4B), dimension(:), contiguous, intent(in) :: ibound !< ibound array for the model - character(len=*), intent(in) :: title !< title for the output table - character(len=*), intent(in) :: text !< flow term description - integer(I4B), intent(in) :: ipakcb !< flag indicating if flows will be saved - class(DisBaseType), intent(in) :: dis !< model discretization object - integer(I4B), intent(in) :: naux !< number of aux variables - character(len=*), intent(in) :: textmodel !< model name - character(len=*), intent(in) :: textpackage !< package name - character(len=*), intent(in) :: dstmodel !< mover destination model - character(len=*), intent(in) :: dstpackage !< mover destination package - character(len=*), dimension(:), intent(in) :: auxname !< aux variable name - real(DP), dimension(:, :), intent(in) :: auxvar !< aux variable - integer(I4B), intent(in) :: iout !< model listing file unit - integer(I4B), intent(in) :: inamedbound !< flag indicating if boundnames are defined for the boundary entries - character(len=LENBOUNDNAME), dimension(:), contiguous :: boundname !< bound names - integer(I4B), dimension(:), optional, intent(in) :: imap !< mapping array - ! -- local variables - character(len=20) :: nodestr - integer(I4B) :: nodeu - integer(I4B) :: maxrows - integer(I4B) :: i - integer(I4B) :: node - integer(I4B) :: n2 - integer(I4B) :: ibinun - integer(I4B) :: nboundcount - real(DP) :: rrate - ! -- for observations - character(len=LENBOUNDNAME) :: bname - ! - ! -- set table kstp and kper - if (iprflow /= 0) then - call outputtab%set_kstpkper(kstp, kper) - end if - ! - ! -- set maxrows - maxrows = 0 - if (ibudfl /= 0 .and. iprflow /= 0) then - do i = 1, nbound - node = nodelist(i) - if (node > 0) then - maxrows = maxrows + 1 - end if - end do - if (maxrows > 0) then - call outputtab%set_maxbound(maxrows) + !< + subroutine save_print_model_flows(icbcfl, ibudfl, icbcun, iprflow, & + outputtab, nbound, nodelist, flow, ibound, & + title, text, ipakcb, dis, naux, textmodel, & + textpackage, dstmodel, dstpackage, & + auxname, auxvar, iout, inamedbound, & + boundname, imap) + ! -- modules + use TdisModule, only: kstp, kper + ! -- dummy variables + integer(I4B), intent(in) :: icbcfl !< flag indicating if the flow should be saved to the binary cell-by-cell flow file + integer(I4B), intent(in) :: ibudfl !< flag indicating if the flow should be saved or printed + integer(I4B), intent(in) :: icbcun !< file unit number for the binary cell-by-cell file + integer(I4B), intent(in) :: iprflow !< print flows to list file + type(TableType), pointer, intent(inout) :: outputtab !< output table object + integer(I4B), intent(in) :: nbound !< number of boundaries this stress period + integer(I4B), dimension(:), contiguous, intent(in) :: nodelist !< boundary node list + real(DP), dimension(:), contiguous, intent(in) :: flow !< boundary flow terms + integer(I4B), dimension(:), contiguous, intent(in) :: ibound !< ibound array for the model + character(len=*), intent(in) :: title !< title for the output table + character(len=*), intent(in) :: text !< flow term description + integer(I4B), intent(in) :: ipakcb !< flag indicating if flows will be saved + class(DisBaseType), intent(in) :: dis !< model discretization object + integer(I4B), intent(in) :: naux !< number of aux variables + character(len=*), intent(in) :: textmodel !< model name + character(len=*), intent(in) :: textpackage !< package name + character(len=*), intent(in) :: dstmodel !< mover destination model + character(len=*), intent(in) :: dstpackage !< mover destination package + character(len=*), dimension(:), intent(in) :: auxname !< aux variable name + real(DP), dimension(:, :), intent(in) :: auxvar !< aux variable + integer(I4B), intent(in) :: iout !< model listing file unit + integer(I4B), intent(in) :: inamedbound !< flag indicating if boundnames are defined for the boundary entries + character(len=LENBOUNDNAME), dimension(:), contiguous :: boundname !< bound names + integer(I4B), dimension(:), optional, intent(in) :: imap !< mapping array + ! -- local variables + character(len=20) :: nodestr + integer(I4B) :: nodeu + integer(I4B) :: maxrows + integer(I4B) :: i + integer(I4B) :: node + integer(I4B) :: n2 + integer(I4B) :: ibinun + integer(I4B) :: nboundcount + real(DP) :: rrate + ! -- for observations + character(len=LENBOUNDNAME) :: bname + ! + ! -- set table kstp and kper + if (iprflow /= 0) then + call outputtab%set_kstpkper(kstp, kper) + end if + ! + ! -- set maxrows + maxrows = 0 + if (ibudfl /= 0 .and. iprflow /= 0) then + do i = 1, nbound + node = nodelist(i) + if (node > 0) then + maxrows = maxrows + 1 end if - call outputtab%set_title(title) - end if - ! - ! -- Set unit number for binary output - if (ipakcb < 0) then - ibinun = icbcun - else if (ipakcb == 0) then - ibinun = 0 - else - ibinun = ipakcb - end if - if (icbcfl == 0) then - ibinun = 0 + end do + if (maxrows > 0) then + call outputtab%set_maxbound(maxrows) end if - ! - ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun /= 0) then - ! - ! -- Count nbound as the number of entries with node > 0 - ! SFR, for example, can have a 'none' connection, which - ! means it should be excluded from budget file - nboundcount = 0 - do i = 1, nbound - node = nodelist(i) - if (node > 0) nboundcount = nboundcount + 1 - end do - call dis%record_srcdst_list_header(text, textmodel, textpackage, & - dstmodel, dstpackage, naux, & - auxname, ibinun, nboundcount, iout) - endif - ! - ! -- If no boundaries, skip flow calculations. - if (nbound > 0) then + call outputtab%set_title(title) + end if + ! + ! -- Set unit number for binary output + if (ipakcb < 0) then + ibinun = icbcun + else if (ipakcb == 0) then + ibinun = 0 + else + ibinun = ipakcb + end if + if (icbcfl == 0) then + ibinun = 0 + end if + ! + ! -- If cell-by-cell flows will be saved as a list, write header. + if (ibinun /= 0) then + ! + ! -- Count nbound as the number of entries with node > 0 + ! SFR, for example, can have a 'none' connection, which + ! means it should be excluded from budget file + nboundcount = 0 + do i = 1, nbound + node = nodelist(i) + if (node > 0) nboundcount = nboundcount + 1 + end do + call dis%record_srcdst_list_header(text, textmodel, textpackage, & + dstmodel, dstpackage, naux, & + auxname, ibinun, nboundcount, iout) + end if + ! + ! -- If no boundaries, skip flow calculations. + if (nbound > 0) then + ! + ! -- Loop through each boundary calculating flow. + do i = 1, nbound + node = nodelist(i) + ! -- assign boundary name + if (inamedbound > 0) then + bname = boundname(i) + else + bname = '' + end if ! - ! -- Loop through each boundary calculating flow. - do i = 1, nbound - node = nodelist(i) - ! -- assign boundary name - if (inamedbound > 0) then - bname = boundname(i) - else - bname = '' - end if + ! -- If cell is no-flow or constant-head, then ignore it. + rrate = DZERO + if (node > 0) then ! - ! -- If cell is no-flow or constant-head, then ignore it. - rrate = DZERO - if (node > 0) then - ! - ! -- Use simval, which was calculated in cq() - rrate = flow(i) - ! - ! -- Print the individual rates if the budget is being printed - ! and PRINT_FLOWS was specified (iprflow < 0). Rates are - ! printed even if ibound < 1. - if (ibudfl /= 0) then - if (iprflow /= 0) then - ! - ! -- set nodestr and write outputtab table - nodeu = dis%get_nodeuser(node) - call dis%nodeu_to_string(nodeu, nodestr) - call outputtab%print_list_entry(i, trim(adjustl(nodestr)), & - rrate, bname) - end if - end if - ! - ! -- If saving cell-by-cell flows in list, write flow - if (ibinun /= 0) then - n2 = i - if (present(imap)) n2 = imap(i) - call dis%record_mf6_list_entry(ibinun, node, n2, rrate, naux, & - auxvar(:,i), olconv2=.FALSE.) + ! -- Use simval, which was calculated in cq() + rrate = flow(i) + ! + ! -- Print the individual rates if the budget is being printed + ! and PRINT_FLOWS was specified (iprflow < 0). Rates are + ! printed even if ibound < 1. + if (ibudfl /= 0) then + if (iprflow /= 0) then + ! + ! -- set nodestr and write outputtab table + nodeu = dis%get_nodeuser(node) + call dis%nodeu_to_string(nodeu, nodestr) + call outputtab%print_list_entry(i, trim(adjustl(nodestr)), & + rrate, bname) end if end if ! - end do - if (ibudfl /= 0) then - if (iprflow /= 0) then - write(iout,'(1x)') + ! -- If saving cell-by-cell flows in list, write flow + if (ibinun /= 0) then + n2 = i + if (present(imap)) n2 = imap(i) + call dis%record_mf6_list_entry(ibinun, node, n2, rrate, naux, & + auxvar(:, i), olconv2=.FALSE.) end if end if + ! + end do + if (ibudfl /= 0) then + if (iprflow /= 0) then + write (iout, '(1x)') + end if + end if - endif - ! - ! -- return - return - end subroutine save_print_model_flows + end if + ! + ! -- return + return + end subroutine save_print_model_flows end module BndModule diff --git a/src/Model/ModelUtilities/Connections.f90 b/src/Model/ModelUtilities/Connections.f90 index 27cae2d2d97..88159aa8a5d 100644 --- a/src/Model/ModelUtilities/Connections.f90 +++ b/src/Model/ModelUtilities/Connections.f90 @@ -6,7 +6,7 @@ module ConnectionsModule use GenericUtilitiesModule, only: sim_message use SimVariablesModule, only: errmsg use BlockParserModule, only: BlockParserType - + implicit none private public :: ConnectionsType @@ -14,27 +14,27 @@ module ConnectionsModule public :: fillisym public :: filljas - + type ConnectionsType - character(len=LENMEMPATH) :: memoryPath !< memory path of the connections data - character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model - integer(I4B), pointer :: nodes => null() !< number of nodes - integer(I4B), pointer :: nja => null() !< number of connections - integer(I4B), pointer :: njas => null() !< number of symmetric connections - integer(I4B), pointer :: ianglex => null() !< indicates whether or not anglex is present - integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< (size:nodes+1) csr index array - integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< (size:nja) csr pointer array - integer(I4B), dimension(:), pointer, contiguous :: mask => null() !< (size:nja) to mask certain connections: ==0 means masked. Do not set the mask directly, use set_mask instead! - real(DP), dimension(:), pointer, contiguous :: cl1 => null() !< (size:njas) connection length between node n and shared face with node m - real(DP), dimension(:), pointer, contiguous :: cl2 => null() !< (size:njas) connection length between node m and shared face with node n - real(DP), dimension(:), pointer, contiguous :: hwva => null() !< (size:njas) horizontal perpendicular width (ihc>0) or vertical flow area (ihc=0) - real(DP), dimension(:), pointer, contiguous :: anglex => null() !< (size:njas) connection angle of face normal with x axis (read in degrees, stored as radians) - integer(I4B), dimension(:), pointer, contiguous :: isym => null() !< (size:nja) returns csr index of symmetric counterpart - integer(I4B), dimension(:), pointer, contiguous :: jas => null() !< (size:nja) map any connection to upper triangle (for pulling out of symmetric array) - integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !< (size:njas) horizontal connection (0:vertical, 1:mean thickness, 2:staggered) - integer(I4B), dimension(:), pointer, contiguous :: iausr => null() !< (size:nodesusr+1) - integer(I4B), dimension(:), pointer, contiguous :: jausr => null() !< (size:nja) - type(BlockParserType) :: parser !< block parser + character(len=LENMEMPATH) :: memoryPath !< memory path of the connections data + character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model + integer(I4B), pointer :: nodes => null() !< number of nodes + integer(I4B), pointer :: nja => null() !< number of connections + integer(I4B), pointer :: njas => null() !< number of symmetric connections + integer(I4B), pointer :: ianglex => null() !< indicates whether or not anglex is present + integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< (size:nodes+1) csr index array + integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< (size:nja) csr pointer array + integer(I4B), dimension(:), pointer, contiguous :: mask => null() !< (size:nja) to mask certain connections: ==0 means masked. Do not set the mask directly, use set_mask instead! + real(DP), dimension(:), pointer, contiguous :: cl1 => null() !< (size:njas) connection length between node n and shared face with node m + real(DP), dimension(:), pointer, contiguous :: cl2 => null() !< (size:njas) connection length between node m and shared face with node n + real(DP), dimension(:), pointer, contiguous :: hwva => null() !< (size:njas) horizontal perpendicular width (ihc>0) or vertical flow area (ihc=0) + real(DP), dimension(:), pointer, contiguous :: anglex => null() !< (size:njas) connection angle of face normal with x axis (read in degrees, stored as radians) + integer(I4B), dimension(:), pointer, contiguous :: isym => null() !< (size:nja) returns csr index of symmetric counterpart + integer(I4B), dimension(:), pointer, contiguous :: jas => null() !< (size:nja) map any connection to upper triangle (for pulling out of symmetric array) + integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !< (size:njas) horizontal connection (0:vertical, 1:mean thickness, 2:staggered) + integer(I4B), dimension(:), pointer, contiguous :: iausr => null() !< (size:nodesusr+1) + integer(I4B), dimension(:), pointer, contiguous :: jausr => null() !< (size:nja) + type(BlockParserType) :: parser !< block parser contains procedure :: con_da procedure :: allocate_scalars @@ -50,8 +50,8 @@ module ConnectionsModule procedure :: set_mask end type ConnectionsType - contains - +contains + subroutine con_da(this) ! ****************************************************************************** ! con_da -- Deallocate connection variables @@ -66,7 +66,7 @@ subroutine con_da(this) ! ------------------------------------------------------------------------------ ! ! -- Strings - deallocate(this%name_model) + deallocate (this%name_model) ! ! -- Scalars call mem_deallocate(this%nodes) @@ -75,38 +75,38 @@ subroutine con_da(this) call mem_deallocate(this%ianglex) ! ! -- iausr and jausr - if(associated(this%iausr, this%ia)) then - nullify(this%iausr) + if (associated(this%iausr, this%ia)) then + nullify (this%iausr) else call mem_deallocate(this%iausr) - endif - if(associated(this%jausr, this%ja)) then - nullify(this%jausr) + end if + if (associated(this%jausr, this%ja)) then + nullify (this%jausr) else call mem_deallocate(this%jausr) - endif + end if ! -- mask if (associated(this%mask, this%ja)) then - nullify(this%mask) + nullify (this%mask) else call mem_deallocate(this%mask) - end if + end if ! ! -- Arrays call mem_deallocate(this%ia) - call mem_deallocate(this%ja) + call mem_deallocate(this%ja) call mem_deallocate(this%isym) call mem_deallocate(this%jas) call mem_deallocate(this%hwva) call mem_deallocate(this%anglex) call mem_deallocate(this%ihc) call mem_deallocate(this%cl1) - call mem_deallocate(this%cl2) + call mem_deallocate(this%cl2) ! ! -- return return end subroutine con_da - + subroutine allocate_scalars(this, name_model) ! ****************************************************************************** ! allocate_scalars -- Allocate scalars for ConnectionsType @@ -123,8 +123,8 @@ subroutine allocate_scalars(this, name_model) ! ------------------------------------------------------------------------------ ! ! -- allocate - allocate(this%name_model) - + allocate (this%name_model) + this%memoryPath = create_mem_path(name_model, 'CON') call mem_allocate(this%nodes, 'NODES', this%memoryPath) call mem_allocate(this%nja, 'NJA', this%memoryPath) @@ -153,7 +153,7 @@ subroutine allocate_arrays(this) ! ------------------------------------------------------------------------------ ! ! -- allocate space for connection arrays - call mem_allocate(this%ia, this%nodes+1, 'IA', this%memoryPath) + call mem_allocate(this%ia, this%nodes + 1, 'IA', this%memoryPath) call mem_allocate(this%ja, this%nja, 'JA', this%memoryPath) call mem_allocate(this%isym, this%nja, 'ISYM', this%memoryPath) call mem_allocate(this%jas, this%nja, 'JAS', this%memoryPath) @@ -164,15 +164,15 @@ subroutine allocate_arrays(this) call mem_allocate(this%cl2, this%njas, 'CL2', this%memoryPath) call mem_allocate(this%iausr, 1, 'IAUSR', this%memoryPath) call mem_allocate(this%jausr, 1, 'JAUSR', this%memoryPath) - ! - ! -- let mask point to ja, which is always nonzero, + ! + ! -- let mask point to ja, which is always nonzero, ! until someone decides to do a 'set_mask' this%mask => this%ja ! ! -- Return return end subroutine allocate_arrays - + subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) ! ****************************************************************************** ! con_finalize -- Finalize connection data @@ -192,60 +192,60 @@ subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) ! -- local integer(I4B) :: ii, n, m integer(I4B), parameter :: nname = 6 - character(len=24),dimension(nname) :: aname(nname) + character(len=24), dimension(nname) :: aname(nname) ! -- formats - character(len=*),parameter :: fmtsymerr = & - &"('Error in array: ',a,'.', & - &' Array is not symmetric in positions: ',i0,' and ',i0,'.', & - &' Values in these positions are: ',1pg15.6,' and ', 1pg15.6, & + character(len=*), parameter :: fmtsymerr = & + &"('Error in array: ',a,'.', & + &' Array is not symmetric in positions: ',i0,' and ',i0,'.', & + &' Values in these positions are: ',1pg15.6,' and ', 1pg15.6, & &' For node ',i0,' connected to node ',i0)" - character(len=*),parameter :: fmtsymerrja = & - &"('Error in array: ',a,'.', & - &' Array does not have symmetric counterpart in position ',i0, & + character(len=*), parameter :: fmtsymerrja = & + &"('Error in array: ',a,'.', & + &' Array does not have symmetric counterpart in position ',i0, & &' for cell ',i0,' connected to cell ',i0)" - character(len=*),parameter :: fmtjanmerr = & - &"('Error in array: ',a,'.', & - &' First value for cell : ',i0,' must equal ',i0,'.', & + character(len=*), parameter :: fmtjanmerr = & + &"('Error in array: ',a,'.', & + &' First value for cell : ',i0,' must equal ',i0,'.', & &' Found ',i0,' instead.')" - character(len=*),parameter :: fmtjasorterr = & - &"('Error in array: ',a,'.', & - &' Entries not sorted for row: ',i0,'.', & + character(len=*), parameter :: fmtjasorterr = & + &"('Error in array: ',a,'.', & + &' Entries not sorted for row: ',i0,'.', & &' Offending entries are: ',i0,' and ',i0)" - character(len=*),parameter :: fmtihcerr = & - "('IHC must be 0, 1, or 2. Found: ',i0)" + character(len=*), parameter :: fmtihcerr = & + "('IHC must be 0, 1, or 2. Found: ',i0)" ! -- data - data aname(1) /' IAC'/ - data aname(2) /' JA'/ - data aname(3) /' IHC'/ - data aname(4) /' CL12'/ - data aname(5) /' HWVA'/ - data aname(6) /' ANGLDEGX'/ + data aname(1)/' IAC'/ + data aname(2)/' JA'/ + data aname(3)/' IHC'/ + data aname(4)/' CL12'/ + data aname(5)/' HWVA'/ + data aname(6)/' ANGLDEGX'/ ! ------------------------------------------------------------------------------ ! ! -- Convert any negative ja numbers to positive do ii = 1, this%nja - if(this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) - enddo + if (this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) + end do ! ! -- Ensure ja is sorted with the row column listed first do n = 1, this%nodes m = this%ja(this%ia(n)) if (n /= m) then - write(errmsg, fmtjanmerr) trim(adjustl(aname(2))), n, n, m + write (errmsg, fmtjanmerr) trim(adjustl(aname(2))), n, n, m call store_error(errmsg) - endif + end if do ii = this%ia(n) + 1, this%ia(n + 1) - 2 m = this%ja(ii) - if(m > this%ja(ii+1)) then - write(errmsg, fmtjasorterr) trim(adjustl(aname(2))), n, & - m, this%ja(ii+1) + if (m > this%ja(ii + 1)) then + write (errmsg, fmtjasorterr) trim(adjustl(aname(2))), n, & + m, this%ja(ii + 1) call store_error(errmsg) - endif - enddo - enddo - if(count_errors() > 0) then + end if + end do + end do + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- fill the isym arrays call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) @@ -255,15 +255,15 @@ subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) do n = 1, this%nodes do ii = this%ia(n), this%ia(n + 1) - 1 m = this%ja(ii) - if(this%isym(ii) == 0) then - write(errmsg, fmtsymerrja) trim(adjustl(aname(2))), ii, n, m + if (this%isym(ii) == 0) then + write (errmsg, fmtsymerrja) trim(adjustl(aname(2))), ii, n, m call store_error(errmsg) - endif - enddo - enddo - if(count_errors() > 0) then + end if + end do + end do + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Fill the jas array, which maps any connection to upper triangle call filljas(this%nodes, this%nja, this%ia, this%ja, this%isym, this%jas) @@ -272,30 +272,30 @@ subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) do n = 1, this%nodes do ii = this%ia(n) + 1, this%ia(n + 1) - 1 m = this%ja(ii) - if(ihctemp(ii) /= ihctemp(this%isym(ii))) then - write(errmsg, fmtsymerr) trim(adjustl(aname(3))), ii, this%isym(ii), & - ihctemp(ii), ihctemp(this%isym(ii)), n, m + if (ihctemp(ii) /= ihctemp(this%isym(ii))) then + write (errmsg, fmtsymerr) trim(adjustl(aname(3))), ii, this%isym(ii), & + ihctemp(ii), ihctemp(this%isym(ii)), n, m call store_error(errmsg) else this%ihc(this%jas(ii)) = ihctemp(ii) - endif - enddo - enddo - if(count_errors() > 0) then + end if + end do + end do + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Put cl12 into symmetric arrays cl1 and cl2 do n = 1, this%nodes do ii = this%ia(n) + 1, this%ia(n + 1) - 1 m = this%ja(ii) - if(m > n) then + if (m > n) then this%cl1(this%jas(ii)) = cl12temp(ii) - elseif(n > m) then + elseif (n > m) then this%cl2(this%jas(ii)) = cl12temp(ii) - endif - enddo - enddo + end if + end do + end do ! ! -- Put HWVA into symmetric array based on the value of IHC ! IHC = 0, vertical connection, HWVA is vertical flow area @@ -306,41 +306,41 @@ subroutine con_finalize(this, ihctemp, cl12temp, hwvatemp, angldegx) do n = 1, this%nodes do ii = this%ia(n) + 1, this%ia(n + 1) - 1 m = this%ja(ii) - if(hwvatemp(ii) /= hwvatemp(this%isym(ii))) then - write(errmsg, fmtsymerr) trim(adjustl(aname(5))), ii, this%isym(ii), & - hwvatemp(ii), hwvatemp(this%isym(ii)), n, m + if (hwvatemp(ii) /= hwvatemp(this%isym(ii))) then + write (errmsg, fmtsymerr) trim(adjustl(aname(5))), ii, this%isym(ii), & + hwvatemp(ii), hwvatemp(this%isym(ii)), n, m call store_error(errmsg) - endif - if(ihctemp(ii) < 0 .or. ihctemp(ii) > 2) then - write(errmsg, fmtihcerr) ihctemp(ii) + end if + if (ihctemp(ii) < 0 .or. ihctemp(ii) > 2) then + write (errmsg, fmtihcerr) ihctemp(ii) call store_error(errmsg) - endif + end if this%hwva(this%jas(ii)) = hwvatemp(ii) - enddo - enddo - if(count_errors() > 0) then + end do + end do + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Put anglextemp into this%anglex; store only upper triangle - if(this%ianglex /= 0) then + if (this%ianglex /= 0) then do n = 1, this%nodes do ii = this%ia(n) + 1, this%ia(n + 1) - 1 m = this%ja(ii) - if(n > m) cycle + if (n > m) cycle this%anglex(this%jas(ii)) = angldegx(ii) * DPIO180 - enddo - enddo + end do + end do else do n = 1, size(this%anglex) this%anglex(n) = DNODATA - enddo - endif + end do + end if ! ! -- Return return end subroutine con_finalize - + subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) ! ****************************************************************************** ! read_connectivity_from_block -- Read and process IAC and JA from an @@ -361,22 +361,22 @@ subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) ! -- local character(len=LINELENGTH) :: line character(len=LINELENGTH) :: keyword - integer(I4B) :: ii,n,m + integer(I4B) :: ii, n, m integer(I4B) :: ierr logical :: isfound, endOfBlock integer(I4B), parameter :: nname = 2 - logical,dimension(nname) :: lname - character(len=24),dimension(nname) :: aname(nname) + logical, dimension(nname) :: lname + character(len=24), dimension(nname) :: aname(nname) ! -- formats - character(len=*),parameter :: fmtsymerr = & + character(len=*), parameter :: fmtsymerr = & &"(/,'Error in array: ',(a),/, & &'Array is not symmetric in positions: ',2i9,/, & &'Values in these positions are: ', 2(1pg15.6))" - character(len=*),parameter :: fmtihcerr = & + character(len=*), parameter :: fmtihcerr = & &"(/,'IHC must be 0, 1, or 2. Found: ',i0)" ! -- data - data aname(1) /' IAC'/ - data aname(2) /' JA'/ + data aname(1)/' IAC'/ + data aname(2)/' JA'/ ! ------------------------------------------------------------------------------ ! ! -- Allocate and initialize dimensions @@ -391,28 +391,29 @@ subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) ! -- get connectiondata block call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr) lname(:) = .false. - if(isfound) then - write(iout,'(1x,a)')'PROCESSING CONNECTIONDATA' + if (isfound) then + write (iout, '(1x,a)') 'PROCESSING CONNECTIONDATA' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('IAC') - call ReadArray(this%parser%iuactive, this%ia, aname(1), 1, & - this%nodes, iout, 0) - lname(1) = .true. - case ('JA') - call ReadArray(this%parser%iuactive, this%ja, aname(2), 1, & - this%nja, iout, 0) - lname(2) = .true. - case default - write(errmsg,'(4x,a,a)') 'UNKNOWN CONNECTIONDATA TAG: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() + case ('IAC') + call ReadArray(this%parser%iuactive, this%ia, aname(1), 1, & + this%nodes, iout, 0) + lname(1) = .true. + case ('JA') + call ReadArray(this%parser%iuactive, this%ja, aname(2), 1, & + this%nja, iout, 0) + lname(2) = .true. + case default + write (errmsg, '(4x,a,a)') & + 'UNKNOWN CONNECTIONDATA TAG: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(iout,'(1x,a)')'END PROCESSING CONNECTIONDATA' + write (iout, '(1x,a)') 'END PROCESSING CONNECTIONDATA' else call store_error('REQUIRED CONNECTIONDATA BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() @@ -420,29 +421,29 @@ subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) ! ! -- verify all items were read do n = 1, nname - if(.not. lname(n)) then - write(errmsg,'(1x,a,a)') & - 'REQUIRED INPUT WAS NOT SPECIFIED: ',aname(n) + if (.not. lname(n)) then + write (errmsg, '(1x,a,a)') & + 'REQUIRED INPUT WAS NOT SPECIFIED: ', aname(n) call store_error(errmsg) - endif - enddo + end if + end do if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Convert iac to ia do n = 2, this%nodes + 1 - this%ia(n) = this%ia(n) + this%ia(n-1) - enddo + this%ia(n) = this%ia(n) + this%ia(n - 1) + end do do n = this%nodes + 1, 2, -1 this%ia(n) = this%ia(n - 1) + 1 - enddo + end do this%ia(1) = 1 ! ! -- Convert any negative ja numbers to positive do ii = 1, this%nja - if(this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) - enddo + if (this%ja(ii) < 0) this%ja(ii) = -this%ja(ii) + end do ! ! -- fill the isym and jas arrays call fillisym(this%nodes, this%nja, this%ia, this%ja, this%isym) @@ -453,25 +454,25 @@ subroutine read_connectivity_from_block(this, name_model, nodes, nja, iout) do n = 1, this%nodes do ii = this%ia(n), this%ia(n + 1) - 1 m = this%ja(ii) - if(n /= this%ja(this%isym(ii))) then - write(line, fmtsymerr) aname(2), ii, this%isym(ii) + if (n /= this%ja(this%isym(ii))) then + write (line, fmtsymerr) aname(2), ii, this%isym(ii) call sim_message(line) call this%parser%StoreErrorUnit() - endif - enddo - enddo + end if + end do + end do ! - if(count_errors() > 0) then + if (count_errors() > 0) then call this%parser%StoreErrorUnit() - endif + end if ! ! -- Return return end subroutine read_connectivity_from_block - + subroutine set_cl1_cl2_from_fleng(this, fleng) ! ****************************************************************************** -! set_cl1_cl2_from_fleng -- Using a vector of cell lengths, +! set_cl1_cl2_from_fleng -- Using a vector of cell lengths, ! calculate the cl1 and cl2 arrays. ! ****************************************************************************** ! @@ -492,15 +493,15 @@ subroutine set_cl1_cl2_from_fleng(this, fleng) m = this%ja(ii) this%cl1(this%jas(ii)) = fleng(n) * DHALF this%cl2(this%jas(ii)) = fleng(m) * DHALF - enddo - enddo + end do + end do ! ! -- Return return end subroutine set_cl1_cl2_from_fleng - - subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & - nrsize, delr, delc, top, bot, nodereduced, & + + subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & + nrsize, delr, delc, top, bot, nodereduced, & nodeuser) ! ****************************************************************************** ! disconnections -- Construct the connectivity arrays for a structured @@ -521,12 +522,12 @@ subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & integer(I4B), intent(in) :: nrow integer(I4B), intent(in) :: nlay integer(I4B), intent(in) :: nrsize - real(DP), dimension(ncol), intent(in) :: delr - real(DP), dimension(nrow), intent(in) :: delc - real(DP), dimension(nodes), intent(in) :: top - real(DP), dimension(nodes), intent(in) :: bot - integer(I4B), dimension(:), target, intent(in) :: nodereduced - integer(I4B), dimension(:), intent(in) :: nodeuser + real(DP), dimension(ncol), intent(in) :: delr + real(DP), dimension(nrow), intent(in) :: delc + real(DP), dimension(nodes), intent(in) :: top + real(DP), dimension(nodes), intent(in) :: bot + integer(I4B), dimension(:), target, intent(in) :: nodereduced + integer(I4B), dimension(:), intent(in) :: nodeuser ! -- local integer(I4B), dimension(:, :, :), pointer :: nrdcd_ptr => null() !non-contiguous because is a slice integer(I4B), dimension(:), allocatable :: rowmaxnnz @@ -543,16 +544,16 @@ subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & this%ianglex = 1 ! ! -- Setup the sparse matrix object - allocate(rowmaxnnz(this%nodes)) + allocate (rowmaxnnz(this%nodes)) do i = 1, this%nodes rowmaxnnz(i) = 6 - enddo + end do call sparse%init(this%nodes, this%nodes, rowmaxnnz) ! ! -- Create a 3d pointer to nodereduced for easier processing - if(nrsize /= 0) then + if (nrsize /= 0) then nrdcd_ptr(1:ncol, 1:nrow, 1:nlay) => nodereduced - endif + end if ! ! -- Add connections to sparse do k = 1, nlay @@ -561,96 +562,96 @@ subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & ! ! -- Find the reduced node number and then cycle if the ! node is always inactive - if(nrsize == 0) then + if (nrsize == 0) then nr = get_node(k, i, j, nlay, nrow, ncol) else nr = nrdcd_ptr(j, i, k) - endif - if(nr <= 0) cycle + end if + if (nr <= 0) cycle ! ! -- Process diagonal call sparse%addconnection(nr, nr, 1) ! ! -- Up direction - if(k > 1) then + if (k > 1) then do kk = k - 1, 1, -1 - if(nrsize == 0) then + if (nrsize == 0) then mr = get_node(kk, i, j, nlay, nrow, ncol) else mr = nrdcd_ptr(j, i, kk) - endif - if(mr >= 0) exit - enddo - if(mr > 0) then + end if + if (mr >= 0) exit + end do + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif + end if + end if ! ! -- Back direction - if(i > 1) then - if(nrsize == 0) then - mr = get_node(k, i-1, j, nlay, nrow, ncol) + if (i > 1) then + if (nrsize == 0) then + mr = get_node(k, i - 1, j, nlay, nrow, ncol) else - mr = nrdcd_ptr(j, i-1, k) - endif - if(mr > 0) then + mr = nrdcd_ptr(j, i - 1, k) + end if + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif + end if + end if ! ! -- Left direction - if(j > 1) then - if(nrsize == 0) then - mr = get_node(k, i, j-1, nlay, nrow, ncol) + if (j > 1) then + if (nrsize == 0) then + mr = get_node(k, i, j - 1, nlay, nrow, ncol) else - mr = nrdcd_ptr(j-1, i, k) - endif - if(mr > 0) then + mr = nrdcd_ptr(j - 1, i, k) + end if + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif + end if + end if ! ! -- Right direction - if(j < ncol) then - if(nrsize == 0) then - mr = get_node(k, i, j+1, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j+1, i, k) - endif - if(mr > 0) then + if (j < ncol) then + if (nrsize == 0) then + mr = get_node(k, i, j + 1, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j + 1, i, k) + end if + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif + end if + end if ! ! -- Front direction - if(i < nrow) then !front - if(nrsize == 0) then - mr = get_node(k, i+1, j, nlay, nrow, ncol) - else - mr = nrdcd_ptr(j, i+1, k) - endif - if(mr > 0) then + if (i < nrow) then !front + if (nrsize == 0) then + mr = get_node(k, i + 1, j, nlay, nrow, ncol) + else + mr = nrdcd_ptr(j, i + 1, k) + end if + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif + end if + end if ! ! -- Down direction - if(k < nlay) then + if (k < nlay) then do kk = k + 1, nlay - if(nrsize == 0) then + if (nrsize == 0) then mr = get_node(kk, i, j, nlay, nrow, ncol) else mr = nrdcd_ptr(j, i, kk) - endif - if(mr >= 0) exit - enddo - if(mr > 0) then + end if + if (mr >= 0) exit + end do + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif - enddo - enddo - enddo + end if + end if + end do + end do + end do this%nja = sparse%nnz this%njas = (this%nja - this%nodes) / 2 ! @@ -672,72 +673,72 @@ subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & do j = 1, ncol ! ! -- cycle if node is always inactive - if(nrsize == 0) then + if (nrsize == 0) then nr = get_node(k, i, j, nlay, nrow, ncol) else nr = nrdcd_ptr(j, i, k) - endif - if(nr <= 0) cycle + end if + if (nr <= 0) cycle ! ! -- right connection - if(j < ncol) then - if(nrsize == 0) then - mr = get_node(k, i, j+1, nlay, nrow, ncol) + if (j < ncol) then + if (nrsize == 0) then + mr = get_node(k, i, j + 1, nlay, nrow, ncol) else - mr = nrdcd_ptr(j+1, i, k) - endif - if(mr > 0) then + mr = nrdcd_ptr(j + 1, i, k) + end if + if (mr > 0) then this%ihc(isympos) = 1 this%cl1(isympos) = DHALF * delr(j) this%cl2(isympos) = DHALF * delr(j + 1) this%hwva(isympos) = delc(i) this%anglex(isympos) = DZERO isympos = isympos + 1 - endif - endif + end if + end if ! ! -- front connection - if(i < nrow) then - if(nrsize == 0) then - mr = get_node(k, i+1, j, nlay, nrow, ncol) + if (i < nrow) then + if (nrsize == 0) then + mr = get_node(k, i + 1, j, nlay, nrow, ncol) else - mr = nrdcd_ptr(j, i+1, k) - endif - if(mr > 0) then + mr = nrdcd_ptr(j, i + 1, k) + end if + if (mr > 0) then this%ihc(isympos) = 1 this%cl1(isympos) = DHALF * delc(i) this%cl2(isympos) = DHALF * delc(i + 1) this%hwva(isympos) = delr(j) this%anglex(isympos) = DTHREE / DTWO * DPI isympos = isympos + 1 - endif - endif + end if + end if ! ! -- down connection - if(k < nlay) then + if (k < nlay) then do kk = k + 1, nlay - if(nrsize == 0) then + if (nrsize == 0) then mr = get_node(kk, i, j, nlay, nrow, ncol) else mr = nrdcd_ptr(j, i, kk) - endif - if(mr >= 0) exit - enddo - if(mr > 0) then + end if + if (mr >= 0) exit + end do + if (mr > 0) then this%ihc(isympos) = 0 this%cl1(isympos) = DHALF * (top(nr) - bot(nr)) this%cl2(isympos) = DHALF * (top(mr) - bot(mr)) this%hwva(isympos) = delr(j) * delc(i) this%anglex(isympos) = DZERO isympos = isympos + 1 - endif - endif - enddo - enddo - enddo + end if + end if + end do + end do + end do ! ! -- Deallocate temporary arrays - deallocate(rowmaxnnz) + deallocate (rowmaxnnz) ! ! -- If reduced system, then need to build iausr and jausr, otherwise point ! them to ia and ja. @@ -748,8 +749,8 @@ subroutine disconnections(this, name_model, nodes, ncol, nrow, nlay, & return end subroutine disconnections - subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & - nvert, vertex, iavert, javert, cellxy, & + subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & + nvert, vertex, iavert, javert, cellxy, & top, bot, nodereduced, nodeuser) ! ****************************************************************************** ! disvconnections -- Construct the connectivity arrays using cell disv @@ -765,21 +766,21 @@ subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & use DisvGeom, only: DisvGeomType use MemoryManagerModule, only: mem_reallocate ! -- dummy - class(ConnectionsType) :: this - character(len=*), intent(in) :: name_model - integer(I4B), intent(in) :: nodes - integer(I4B), intent(in) :: ncpl - integer(I4B), intent(in) :: nlay - integer(I4B), intent(in) :: nrsize - integer(I4B), intent(in) :: nvert - real(DP), dimension(2, nvert), intent(in) :: vertex - integer(I4B), dimension(:), intent(in) :: iavert - integer(I4B), dimension(:), intent(in) :: javert - real(DP), dimension(2, ncpl), intent(in) :: cellxy - real(DP), dimension(nodes), intent(in) :: top - real(DP), dimension(nodes), intent(in) :: bot - integer(I4B), dimension(:), intent(in) :: nodereduced - integer(I4B), dimension(:), intent(in) :: nodeuser + class(ConnectionsType) :: this + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: ncpl + integer(I4B), intent(in) :: nlay + integer(I4B), intent(in) :: nrsize + integer(I4B), intent(in) :: nvert + real(DP), dimension(2, nvert), intent(in) :: vertex + integer(I4B), dimension(:), intent(in) :: iavert + integer(I4B), dimension(:), intent(in) :: javert + real(DP), dimension(2, ncpl), intent(in) :: cellxy + real(DP), dimension(nodes), intent(in) :: top + real(DP), dimension(nodes), intent(in) :: bot + integer(I4B), dimension(:), intent(in) :: nodereduced + integer(I4B), dimension(:), intent(in) :: nodeuser ! -- local integer(I4B), dimension(:), allocatable :: itemp type(sparsematrix) :: sparse, vertcellspm @@ -795,28 +796,28 @@ subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & this%ianglex = 1 ! ! -- Initialize DisvGeomType objects - call cell1%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & + call cell1%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & cellxy, nodereduced, nodeuser) - call cell2%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & + call cell2%init(nlay, ncpl, nodes, top, bot, iavert, javert, vertex, & cellxy, nodereduced, nodeuser) ! ! -- Create a sparse matrix array with a row for each vertex. The columns ! in the sparse matrix contains the cells that include that vertex. ! This array will be used to determine horizontal cell connectivity. - allocate(itemp(nvert)) + allocate (itemp(nvert)) do i = 1, nvert itemp(i) = 4 - enddo + end do call vertcellspm%init(nvert, ncpl, itemp) - deallocate(itemp) + deallocate (itemp) do j = 1, ncpl do i = iavert(j), iavert(j + 1) - 1 call vertcellspm%addconnection(javert(i), j, 1) - enddo - enddo + end do + end do ! ! -- Call routine to build a sparse matrix of the connections - call vertexconnect(this%nodes, nrsize, 6, nlay, ncpl, sparse, & + call vertexconnect(this%nodes, nrsize, 6, nlay, ncpl, sparse, & vertcellspm, cell1, cell2, nodereduced) this%nja = sparse%nnz this%njas = (this%nja - this%nodes) / 2 @@ -838,14 +839,14 @@ subroutine disvconnections(this, name_model, nodes, ncpl, nlay, nrsize, & call cell1%set_nodered(n) do ipos = this%ia(n) + 1, this%ia(n + 1) - 1 m = this%ja(ipos) - if(m < n) cycle + if (m < n) cycle call cell2%set_nodered(m) - call cell1%cprops(cell2, this%hwva(this%jas(ipos)), & - this%cl1(this%jas(ipos)), this%cl2(this%jas(ipos)), & - this%anglex(this%jas(ipos)), & + call cell1%cprops(cell2, this%hwva(this%jas(ipos)), & + this%cl1(this%jas(ipos)), this%cl2(this%jas(ipos)), & + this%anglex(this%jas(ipos)), & this%ihc(this%jas(ipos))) - enddo - enddo + end do + end do ! ! -- If reduced system, then need to build iausr and jausr, otherwise point ! them to ia and ja. @@ -887,10 +888,10 @@ subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & real(DP), dimension(:), contiguous, intent(in) :: angldegxinp integer(I4B), intent(in) :: iangledegx ! -- local - integer(I4B),dimension(:),allocatable :: ihctemp - real(DP),dimension(:),allocatable :: cl12temp - real(DP),dimension(:),allocatable :: hwvatemp - real(DP),dimension(:),allocatable :: angldegxtemp + integer(I4B), dimension(:), allocatable :: ihctemp + real(DP), dimension(:), allocatable :: cl12temp + real(DP), dimension(:), allocatable :: hwvatemp + real(DP), dimension(:), allocatable :: angldegxtemp integer(I4B) :: nr, nu, mr, mu, ipos, iposr, ierror integer(I4B), dimension(:), allocatable :: rowmaxnnz type(sparsematrix) :: sparse @@ -925,11 +926,11 @@ subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & ! -- reduced system requires more work ! ! -- Setup the sparse matrix object - allocate(rowmaxnnz(this%nodes)) + allocate (rowmaxnnz(this%nodes)) do nr = 1, this%nodes nu = nodeuser(nr) rowmaxnnz(nr) = iainp(nu + 1) - iainp(nu) - enddo + end do call sparse%init(this%nodes, this%nodes, rowmaxnnz) ! ! -- go through user connectivity and create sparse @@ -942,8 +943,8 @@ subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & if (nr < 1) cycle if (mr < 1) cycle call sparse%addconnection(nr, mr, 1) - enddo - enddo + end do + end do this%nja = sparse%nnz this%njas = (this%nja - this%nodes) / 2 ! @@ -954,13 +955,13 @@ subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & call sparse%sort() call sparse%filliaja(this%ia, this%ja, ierror) call sparse%destroy() - deallocate(rowmaxnnz) + deallocate (rowmaxnnz) ! ! -- At this point, need to reduce ihc, cl12, hwva, and angldegx - allocate(ihctemp(this%nja)) - allocate(cl12temp(this%nja)) - allocate(hwvatemp(this%nja)) - allocate(angldegxtemp(this%nja)) + allocate (ihctemp(this%nja)) + allocate (cl12temp(this%nja)) + allocate (hwvatemp(this%nja)) + allocate (angldegxtemp(this%nja)) ! ! -- Compress user arrays into reduced arrays iposr = 1 @@ -982,10 +983,10 @@ subroutine disuconnections(this, name_model, nodes, nodesuser, nrsize, & call this%con_finalize(ihctemp, cl12temp, hwvatemp, angldegxtemp) ! ! -- deallocate temporary arrays - deallocate(ihctemp) - deallocate(cl12temp) - deallocate(hwvatemp) - deallocate(angldegxtemp) + deallocate (ihctemp) + deallocate (cl12temp) + deallocate (hwvatemp) + deallocate (angldegxtemp) end if ! ! -- If reduced system, then need to build iausr and jausr, otherwise point @@ -1018,20 +1019,20 @@ subroutine iajausr(this, nrsize, nodesuser, nodereduced, nodeuser) ! ! -- If reduced system, then need to build iausr and jausr, otherwise point ! them to ia and ja. - if(nrsize > 0) then + if (nrsize > 0) then ! ! -- Create the iausr array of size nodesuser + 1. For excluded cells, ! iausr(n) and iausr(n + 1) should be equal to indicate no connections. - call mem_reallocate(this%iausr, nodesuser+1, 'IAUSR', this%memoryPath) + call mem_reallocate(this%iausr, nodesuser + 1, 'IAUSR', this%memoryPath) this%iausr(nodesuser + 1) = this%ia(this%nodes + 1) do n = nodesuser, 1, -1 nr = nodereduced(n) - if(nr < 1) then + if (nr < 1) then this%iausr(n) = this%iausr(n + 1) else this%iausr(n) = this%ia(nr) - endif - enddo + end if + end do ! ! -- Create the jausr array, which is the same size as ja, but it ! contains user node numbers instead of reduced node numbers @@ -1040,20 +1041,20 @@ subroutine iajausr(this, nrsize, nodesuser, nodereduced, nodeuser) nr = this%ja(ipos) n = nodeuser(nr) this%jausr(ipos) = n - enddo + end do else ! -- iausr and jausr will be pointers call mem_deallocate(this%iausr) call mem_deallocate(this%jausr) call mem_setptr(this%iausr, 'IA', this%memoryPath) call mem_setptr(this%jausr, 'JA', this%memoryPath) - endif + end if ! ! -- Return return end subroutine iajausr - function getjaindex(this,node1,node2) + function getjaindex(this, node1, node2) ! ****************************************************************************** ! Get the index in the JA array corresponding to the connection between ! two nodes of interest. Node1 is used as the index in the IA array, and @@ -1070,34 +1071,35 @@ function getjaindex(this,node1,node2) integer(I4B) :: getjaindex ! -- dummy class(ConnectionsType) :: this - integer(I4B), intent(in) :: node1, node2 ! nodes of interest + integer(I4B), intent(in) :: node1, node2 ! nodes of interest ! -- local integer(I4B) :: i ! ------------------------------------------------------------------------------ ! ! -- error checking - if (node1<1 .or. node1>this%nodes .or. node2<1 .or. node2>this%nodes) then - getjaindex = -1 ! indicates error (an invalid node number) + if (node1 < 1 .or. node1 > this%nodes .or. node2 < 1 .or. & + node2 > this%nodes) then + getjaindex = -1 ! indicates error (an invalid node number) return - endif + end if ! ! -- If node1==node2, just return the position for the diagonal. - if (node1==node2) then + if (node1 == node2) then getjaindex = this%ia(node1) return - endif + end if ! ! -- Look for connection among nonzero elements defined for row node1. - do i=this%ia(node1)+1,this%ia(node1+1)-1 - if (this%ja(i)==node2) then + do i = this%ia(node1) + 1, this%ia(node1 + 1) - 1 + if (this%ja(i) == node2) then getjaindex = i return - endif - enddo + end if + end do ! ! -- If execution reaches here, no connection exists ! between nodes of interest. - getjaindex = 0 ! indicates no connection exists + getjaindex = 0 ! indicates no connection exists return end function getjaindex @@ -1109,31 +1111,31 @@ subroutine fillisym(neq, nja, ia, ja, isym) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - integer(I4B),intent(in) :: neq - integer(I4B),intent(in) :: nja - integer(I4B),intent(inout),dimension(nja) :: isym + integer(I4B), intent(in) :: neq + integer(I4B), intent(in) :: nja + integer(I4B), intent(inout), dimension(nja) :: isym ! -- local - integer(I4B),intent(in),dimension(neq+1) :: ia - integer(I4B),intent(in),dimension(nja) :: ja + integer(I4B), intent(in), dimension(neq + 1) :: ia + integer(I4B), intent(in), dimension(nja) :: ja integer(I4B) :: n, m, ii, jj ! ------------------------------------------------------------------------------ ! - do n=1, neq + do n = 1, neq do ii = ia(n), ia(n + 1) - 1 m = ja(ii) - if(m /= n) then + if (m /= n) then isym(ii) = 0 search: do jj = ia(m), ia(m + 1) - 1 - if(ja(jj) == n) then + if (ja(jj) == n) then isym(ii) = jj exit search - endif - enddo search + end if + end do search else isym(ii) = ii - endif - enddo - enddo + end if + end do + end do ! ! -- Return return @@ -1147,12 +1149,12 @@ subroutine filljas(neq, nja, ia, ja, isym, jas) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - integer(I4B),intent(in) :: neq - integer(I4B),intent(in) :: nja - integer(I4B),intent(in),dimension(neq+1) :: ia - integer(I4B),intent(in),dimension(nja) :: ja - integer(I4B),intent(in),dimension(nja) :: isym - integer(I4B),intent(inout),dimension(nja) :: jas + integer(I4B), intent(in) :: neq + integer(I4B), intent(in) :: nja + integer(I4B), intent(in), dimension(neq + 1) :: ia + integer(I4B), intent(in), dimension(nja) :: ja + integer(I4B), intent(in), dimension(nja) :: isym + integer(I4B), intent(inout), dimension(nja) :: jas ! -- local integer(I4B) :: n, m, ii, ipos ! ------------------------------------------------------------------------------ @@ -1163,29 +1165,28 @@ subroutine filljas(neq, nja, ia, ja, isym, jas) jas(ia(n)) = 0 do ii = ia(n) + 1, ia(n + 1) - 1 m = ja(ii) - if(m > n) then + if (m > n) then jas(ii) = ipos ipos = ipos + 1 - endif - enddo - enddo + end if + end do + end do ! ! -- fill lower do n = 1, neq do ii = ia(n), ia(n + 1) - 1 m = ja(ii) - if(m < n) then + if (m < n) then jas(ii) = jas(isym(ii)) - endif - enddo - enddo + end if + end do + end do ! ! -- Return return end subroutine filljas - - subroutine vertexconnect(nodes, nrsize, maxnnz, nlay, ncpl, sparse, & + subroutine vertexconnect(nodes, nrsize, maxnnz, nlay, ncpl, sparse, & vertcellspm, cell1, cell2, nodereduced) ! ****************************************************************************** ! vertexconnect -- routine to make cell connections from vertices @@ -1213,49 +1214,49 @@ subroutine vertexconnect(nodes, nrsize, maxnnz, nlay, ncpl, sparse, & ! ------------------------------------------------------------------------------ ! ! -- Allocate and fill the ia and ja arrays - allocate(rowmaxnnz(nodes)) + allocate (rowmaxnnz(nodes)) do i = 1, nodes rowmaxnnz(i) = maxnnz - enddo + end do call sparse%init(nodes, nodes, rowmaxnnz) - deallocate(rowmaxnnz) + deallocate (rowmaxnnz) do k = 1, nlay do j = 1, ncpl ! ! -- Find the reduced node number and then cycle if the ! node is always inactive nr = get_node(k, 1, j, nlay, 1, ncpl) - if(nrsize > 0) nr = nodereduced(nr) - if(nr <= 0) cycle + if (nrsize > 0) nr = nodereduced(nr) + if (nr <= 0) cycle ! ! -- Process diagonal call sparse%addconnection(nr, nr, 1) ! ! -- Up direction - if(k > 1) then + if (k > 1) then do kk = k - 1, 1, -1 mr = get_node(kk, 1, j, nlay, 1, ncpl) - if(nrsize > 0) mr = nodereduced(mr) - if(mr >= 0) exit - enddo - if(mr > 0) then + if (nrsize > 0) mr = nodereduced(mr) + if (mr >= 0) exit + end do + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif + end if + end if ! ! -- Down direction - if(k < nlay) then + if (k < nlay) then do kk = k + 1, nlay mr = get_node(kk, 1, j, nlay, 1, ncpl) - if(nrsize > 0) mr = nodereduced(mr) - if(mr >= 0) exit - enddo - if(mr > 0) then + if (nrsize > 0) mr = nodereduced(mr) + if (mr >= 0) exit + end do + if (mr > 0) then call sparse%addconnection(nr, mr, 1) - endif - endif - enddo - enddo + end if + end if + end do + end do ! ! -- Go through each vertex and connect up all the cells that use ! this vertex in their definition and share an edge. @@ -1265,50 +1266,50 @@ subroutine vertexconnect(nodes, nrsize, maxnnz, nlay, ncpl, sparse, & j1 = vertcellspm%row(i)%icolarray(icol1) do k = 1, nlay nr = get_node(k, 1, j1, nlay, 1, ncpl) - if(nrsize > 0) nr = nodereduced(nr) - if(nr <= 0) cycle + if (nrsize > 0) nr = nodereduced(nr) + if (nr <= 0) cycle call cell1%set_nodered(nr) do icol2 = 1, vertcellspm%row(i)%nnz j2 = vertcellspm%row(i)%icolarray(icol2) - if(j1 == j2) cycle + if (j1 == j2) cycle mr = get_node(k, 1, j2, nlay, 1, ncpl) - if(nrsize > 0) mr = nodereduced(mr) - if(mr <= 0) cycle + if (nrsize > 0) mr = nodereduced(mr) + if (mr <= 0) cycle call cell2%set_nodered(mr) - if(cell1%shares_edge(cell2)) then + if (cell1%shares_edge(cell2)) then call sparse%addconnection(nr, mr, 1) - endif - enddo - enddo - enddo - enddo + end if + end do + end do + end do + end do ! ! -- return return end subroutine vertexconnect - + subroutine set_mask(this, ipos, maskval) ! ****************************************************************************** -! set_mask -- routine to set a value in the mask array +! set_mask -- routine to set a value in the mask array ! (which has the same shape as this%ja) ! ****************************************************************************** ! ! SPECIFICATIONS: -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ use MemoryManagerModule, only: mem_allocate class(ConnectionsType) :: this integer(I4B), intent(in) :: ipos integer(I4B), intent(in) :: maskval ! local integer(I4B) :: i -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! ! if we still point to this%ja, we first need to allocate space if (associated(this%mask, this%ja)) then call mem_allocate(this%mask, this%nja, 'MASK', this%memoryPath) ! and initialize with unmasked do i = 1, this%nja - this%mask(i) = 1 + this%mask(i) = 1 end do end if ! @@ -1318,28 +1319,28 @@ subroutine set_mask(this, ipos, maskval) ! -- return return end subroutine set_mask - + subroutine iac_to_ia(ia) ! ****************************************************************************** ! iac_to_ia -- convert an iac array into an ia array ! ****************************************************************************** ! ! SPECIFICATIONS: -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! -- dummy integer(I4B), dimension(:), contiguous, intent(inout) :: ia ! -- local integer(I4B) :: n, nodes -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! ! -- Convert iac to ia nodes = size(ia) - 1 do n = 2, nodes + 1 - ia(n) = ia(n) + ia(n-1) - enddo + ia(n) = ia(n) + ia(n - 1) + end do do n = nodes + 1, 2, -1 ia(n) = ia(n - 1) + 1 - enddo + end do ia(1) = 1 ! ! -- return diff --git a/src/Model/ModelUtilities/DiscretizationBase.f90 b/src/Model/ModelUtilities/DiscretizationBase.f90 index 2d954b0be08..1bf1f14d77f 100644 --- a/src/Model/ModelUtilities/DiscretizationBase.f90 +++ b/src/Model/ModelUtilities/DiscretizationBase.f90 @@ -1,51 +1,51 @@ module BaseDisModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENAUXNAME, LINELENGTH, & - DZERO, LENMEMPATH, DPIO180 - use SmoothingModule, only: sQuadraticSaturation - use ConnectionsModule, only: ConnectionsType - use InputOutputModule, only: URWORD, ubdsv1 - use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error, & - store_error_unit - use BlockParserModule, only: BlockParserType - use MemoryManagerModule, only: mem_allocate - use MemoryHelperModule, only: create_mem_path - use TdisModule, only: kstp, kper, pertim, totim, delt + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMODELNAME, LENAUXNAME, LINELENGTH, & + DZERO, LENMEMPATH, DPIO180 + use SmoothingModule, only: sQuadraticSaturation + use ConnectionsModule, only: ConnectionsType + use InputOutputModule, only: URWORD, ubdsv1 + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error, & + store_error_unit + use BlockParserModule, only: BlockParserType + use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path + use TdisModule, only: kstp, kper, pertim, totim, delt use TimeSeriesManagerModule, only: TimeSeriesManagerType implicit none - + private public :: DisBaseType type :: DisBaseType - character(len=LENMEMPATH) :: memoryPath !< path for memory allocation - character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model - integer(I4B), pointer :: inunit => null() !< unit number for input file - integer(I4B), pointer :: iout => null() !< unit number for output file - integer(I4B), pointer :: nodes => null() !< number of nodes in solution - integer(I4B), pointer :: nodesuser => null() !< number of user nodes (same as nodes for disu grid) - integer(I4B), pointer :: nja => null() !< number of connections plus number of nodes - integer(I4B), pointer :: njas => null() !< (nja-nodes)/2 - integer(I4B), pointer :: lenuni => null() !< length unit - integer(I4B), pointer :: ndim => null() !< number of spatial model dimensions (1 for disu grid) - integer(I4B), pointer :: icondir => null() !< flag indicating if grid has enough info to calculate connection vectors - logical, pointer :: writegrb => null() !< write binary grid file - real(DP), pointer :: yorigin => null() !< y-position of the lower-left grid corner (default is 0.) - real(DP), pointer :: xorigin => null() !< x-position of the lower-left grid corner (default is 0.) - real(DP), pointer :: angrot => null() !< counter-clockwise rotation angle of the lower-left corner (default is 0.0) - integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !< shape of the model; (nodes) for DisBaseType - real(DP), dimension(:), pointer, contiguous :: top => null() !< (size:nodes) cell top elevation - real(DP), dimension(:), pointer, contiguous :: bot => null() !< (size:nodes) cell bottom elevation - real(DP), dimension(:), pointer, contiguous :: area => null() !< (size:nodes) cell area, in plan view - type(ConnectionsType), pointer :: con => null() !< connections object - type(BlockParserType) :: parser !< object to read blocks - real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< helper double array of size nodesuser - integer(I4B), dimension(:), pointer, contiguous :: ibuff => null() !< helper int array of size nodesuser - integer(I4B), dimension(:), pointer, contiguous :: nodereduced => null() !< (size:nodesuser)contains reduced nodenumber (size 0 if not reduced); -1 means vertical pass through, 0 is idomain = 0 - integer(I4B), dimension(:), pointer, contiguous :: nodeuser => null() !< (size:nodes) given a reduced nodenumber, provide the user nodenumber (size 0 if not reduced) + character(len=LENMEMPATH) :: memoryPath !< path for memory allocation + character(len=LENMODELNAME), pointer :: name_model => null() !< name of the model + integer(I4B), pointer :: inunit => null() !< unit number for input file + integer(I4B), pointer :: iout => null() !< unit number for output file + integer(I4B), pointer :: nodes => null() !< number of nodes in solution + integer(I4B), pointer :: nodesuser => null() !< number of user nodes (same as nodes for disu grid) + integer(I4B), pointer :: nja => null() !< number of connections plus number of nodes + integer(I4B), pointer :: njas => null() !< (nja-nodes)/2 + integer(I4B), pointer :: lenuni => null() !< length unit + integer(I4B), pointer :: ndim => null() !< number of spatial model dimensions (1 for disu grid) + integer(I4B), pointer :: icondir => null() !< flag indicating if grid has enough info to calculate connection vectors + logical, pointer :: writegrb => null() !< write binary grid file + real(DP), pointer :: yorigin => null() !< y-position of the lower-left grid corner (default is 0.) + real(DP), pointer :: xorigin => null() !< x-position of the lower-left grid corner (default is 0.) + real(DP), pointer :: angrot => null() !< counter-clockwise rotation angle of the lower-left corner (default is 0.0) + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !< shape of the model; (nodes) for DisBaseType + real(DP), dimension(:), pointer, contiguous :: top => null() !< (size:nodes) cell top elevation + real(DP), dimension(:), pointer, contiguous :: bot => null() !< (size:nodes) cell bottom elevation + real(DP), dimension(:), pointer, contiguous :: area => null() !< (size:nodes) cell area, in plan view + type(ConnectionsType), pointer :: con => null() !< connections object + type(BlockParserType) :: parser !< object to read blocks + real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< helper double array of size nodesuser + integer(I4B), dimension(:), pointer, contiguous :: ibuff => null() !< helper int array of size nodesuser + integer(I4B), dimension(:), pointer, contiguous :: nodereduced => null() !< (size:nodesuser)contains reduced nodenumber (size 0 if not reduced); -1 means vertical pass through, 0 is idomain = 0 + integer(I4B), dimension(:), pointer, contiguous :: nodeuser => null() !< (size:nodes) given a reduced nodenumber, provide the user nodenumber (size 0 if not reduced) contains procedure :: dis_df procedure :: dis_ac @@ -57,11 +57,11 @@ module BaseDisModule ! -- get_nodenumber is an overloaded integer function that will always ! return the reduced nodenumber. For all grids, get_nodenumber can ! be passed the user nodenumber. For some other grids, it can also - ! be passed an index. For dis3d the index is k, i, j, and for + ! be passed an index. For dis3d the index is k, i, j, and for ! disv the index is k, n. - generic :: get_nodenumber => get_nodenumber_idx1, & - get_nodenumber_idx2, & - get_nodenumber_idx3 + generic :: get_nodenumber => get_nodenumber_idx1, & + get_nodenumber_idx2, & + get_nodenumber_idx3 procedure :: get_nodenumber_idx1 procedure :: get_nodenumber_idx2 procedure :: get_nodenumber_idx3 @@ -83,30 +83,30 @@ module BaseDisModule procedure :: get_cell_volume procedure :: write_grb ! - procedure :: read_int_array - procedure :: read_dbl_array - generic, public :: read_grid_array => read_int_array, read_dbl_array - procedure, public :: read_layer_array - procedure :: fill_int_array - procedure :: fill_dbl_array - generic, public :: fill_grid_array => fill_int_array, fill_dbl_array - procedure, public :: read_list - ! - procedure, public :: record_array - procedure, public :: record_connection_array - procedure, public :: noder_to_string - procedure, public :: noder_to_array - procedure, public :: record_srcdst_list_header + procedure :: read_int_array + procedure :: read_dbl_array + generic, public :: read_grid_array => read_int_array, read_dbl_array + procedure, public :: read_layer_array + procedure :: fill_int_array + procedure :: fill_dbl_array + generic, public :: fill_grid_array => fill_int_array, fill_dbl_array + procedure, public :: read_list + ! + procedure, public :: record_array + procedure, public :: record_connection_array + procedure, public :: noder_to_string + procedure, public :: noder_to_array + procedure, public :: record_srcdst_list_header procedure, private :: record_srcdst_list_entry - generic, public :: record_mf6_list_entry => record_srcdst_list_entry - procedure, public :: nlarray_to_nodelist - procedure, public :: highest_active - procedure, public :: get_area - procedure, public :: transform_xy - + generic, public :: record_mf6_list_entry => record_srcdst_list_entry + procedure, public :: nlarray_to_nodelist + procedure, public :: highest_active + procedure, public :: get_area + procedure, public :: transform_xy + end type DisBaseType - - contains + +contains subroutine dis_df(this) ! ****************************************************************************** @@ -144,13 +144,13 @@ subroutine dis_ac(this, moffset, sparse) ! ------------------------------------------------------------------------------ ! do i = 1, this%nodes - do ipos = this%con%ia(i), this%con%ia(i+1) - 1 + do ipos = this%con%ia(i), this%con%ia(i + 1) - 1 j = this%con%ja(ipos) iglo = i + moffset jglo = j + moffset call sparse%addconnection(iglo, jglo, 1) - enddo - enddo + end do + end do ! ! -- Return return @@ -181,13 +181,13 @@ subroutine dis_mc(this, moffset, idxglo, iasln, jasln) j = this%con%ja(ipos) jglo = j + moffset searchloop: do ipossln = iasln(iglo), iasln(iglo + 1) - 1 - if(jglo == jasln(ipossln)) then + if (jglo == jasln(ipossln)) then idxglo(ipos) = ipossln exit searchloop - endif - enddo searchloop - enddo - enddo + end if + end do searchloop + end do + end do ! ! -- Return return @@ -210,15 +210,15 @@ subroutine dis_ar(this, icelltype) ! ------------------------------------------------------------------------------ ! ! -- Expand icelltype to full grid; fill with 0 if cell is excluded - allocate(ict(this%nodesuser)) + allocate (ict(this%nodesuser)) do nu = 1, this%nodesuser nr = this%get_nodenumber(nu, 0) if (nr > 0) then ict(nu) = icelltype(nr) else ict(nu) = 0 - endif - enddo + end if + end do ! if (this%writegrb) call this%write_grb(ict) ! @@ -262,7 +262,7 @@ subroutine dis_da(this) ! ------------------------------------------------------------------------------ ! ! -- Strings - deallocate(this%name_model) + deallocate (this%name_model) ! ! -- Scalars call mem_deallocate(this%inunit) @@ -289,7 +289,7 @@ subroutine dis_da(this) ! ! -- Connections call this%con%con_da() - deallocate(this%con) + deallocate (this%con) ! ! -- Return return @@ -320,7 +320,7 @@ end subroutine nodeu_to_string subroutine nodeu_to_array(this, nodeu, arr) ! ****************************************************************************** ! nodeu_to_array -- Convert user node number to cellid and fill array with -! (nodenumber) or (k,j) or (k,i,j) +! (nodenumber) or (k,j) or (k,i,j) ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -353,11 +353,11 @@ function get_nodeuser(this, noder) result(nodenumber) integer(I4B), intent(in) :: noder ! ------------------------------------------------------------------------------ ! - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then nodenumber = this%nodeuser(noder) else nodenumber = noder - endif + end if ! ! -- return return @@ -440,10 +440,10 @@ function get_nodenumber_idx3(this, k, i, j, icheck) result(nodenumber) return end function get_nodenumber_idx3 - subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & + subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ipos) ! ****************************************************************************** -! connection_normal -- calculate the normal vector components for reduced +! connection_normal -- calculate the normal vector components for reduced ! nodenumber cell (noden) and its shared face with cell nodem. ihc is the ! horizontal connection flag. ! ****************************************************************************** @@ -469,11 +469,11 @@ subroutine connection_normal(this, noden, nodem, ihc, xcomp, ycomp, zcomp, & ! -- return return end subroutine connection_normal - - subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & + + subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & xcomp, ycomp, zcomp, conlen) ! ****************************************************************************** -! connection_vector -- calculate the unit vector components from reduced +! connection_vector -- calculate the unit vector components from reduced ! nodenumber cell (noden) to its neighbor cell (nodem). The saturation for ! for these cells are also required so that the vertical position of the cell ! cell centers can be calculated. ihc is the horizontal flag. Also return @@ -500,47 +500,47 @@ subroutine connection_vector(this, noden, nodem, nozee, satn, satm, ihc, & ! ------------------------------------------------------------------------------ ! call store_error('Program error: connection_vector not implemented.', & - terminate=.TRUE.) + terminate=.TRUE.) ! ! -- return return end subroutine connection_vector - + ! return x,y coordinate for a node subroutine get_cellxy(this, node, xcell, ycell) - class(DisBaseType), intent(in) :: this - integer(I4B), intent(in) :: node - real(DP), intent(out) :: xcell, ycell - + class(DisBaseType), intent(in) :: this + integer(I4B), intent(in) :: node + real(DP), intent(out) :: xcell, ycell + ! suppress warning xcell = -999999.0 ycell = -999999.0 - + call store_error('Program error: get_cellxy not implemented.', & - terminate=.TRUE.) - + terminate=.TRUE.) + end subroutine get_cellxy - + !> @brief get the x,y for a node transformed into !! 'global coordinates' using xorigin, yorigin, angrot, - !< analogously to how flopy does this. + !< analogously to how flopy does this. subroutine transform_xy(this, x, y, xglo, yglo) class(DisBaseType), intent(in) :: this !< this DIS - real(DP), intent(in) :: x !< the cell-x coordinate to transform - real(DP), intent(in) :: y !< the cell-y coordinate to transform - real(DP), intent(out) :: xglo !< the global cell-x coordinate - real(DP), intent(out) :: yglo !< the global cell-y coordinate + real(DP), intent(in) :: x !< the cell-x coordinate to transform + real(DP), intent(in) :: y !< the cell-y coordinate to transform + real(DP), intent(out) :: xglo !< the global cell-x coordinate + real(DP), intent(out) :: yglo !< the global cell-y coordinate ! local real(DP) :: ang - + xglo = x yglo = y ! first _rotate_ to 'real world' - ang = this%angrot*DPIO180 + ang = this%angrot * DPIO180 if (ang /= DZERO) then - xglo = x*cos(ang) - y*sin(ang) - yglo = x*sin(ang) + y*cos(ang) + xglo = x * cos(ang) - y * sin(ang) + yglo = x * sin(ang) + y * cos(ang) end if ! then _translate_ @@ -548,20 +548,20 @@ subroutine transform_xy(this, x, y, xglo, yglo) yglo = yglo + this%yorigin end subroutine transform_xy - + ! return discretization type subroutine get_dis_type(this, dis_type) - class(DisBaseType), intent(in) :: this - character(len=*), intent(out) :: dis_type - + class(DisBaseType), intent(in) :: this + character(len=*), intent(out) :: dis_type + ! suppress warning - dis_type = "Not implemented" - + dis_type = "Not implemented" + call store_error('Program error: get_dis_type not implemented.', & - terminate=.TRUE.) - + terminate=.TRUE.) + end subroutine get_dis_type - + subroutine allocate_scalars(this, name_model) ! ****************************************************************************** ! allocate_scalars -- Allocate and initialize scalar variables in this class @@ -581,7 +581,7 @@ subroutine allocate_scalars(this, name_model) this%memoryPath = create_mem_path(name_model, 'DIS') ! ! -- Allocate - allocate(this%name_model) + allocate (this%name_model) ! call mem_allocate(this%inunit, 'INUNIT', this%memoryPath) call mem_allocate(this%iout, 'IOUT', this%memoryPath) @@ -608,7 +608,7 @@ subroutine allocate_scalars(this, name_model) this%writegrb = .true. this%xorigin = DZERO this%yorigin = DZERO - this%angrot = DZERO + this%angrot = DZERO this%nja = 0 this%njas = 0 this%lenuni = 0 @@ -641,11 +641,11 @@ subroutine allocate_arrays(this) this%mshape(1) = this%nodes ! ! -- Determine size of buff memory - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then isize = this%nodesuser else isize = this%nodes - endif + end if ! ! -- Allocate the arrays call mem_allocate(this%dbuff, isize, 'DBUFF', this%name_model) ! TODO_MJR: is this correct?? @@ -660,42 +660,42 @@ function nodeu_from_string(this, lloc, istart, istop, in, iout, line, & ! ****************************************************************************** ! nodeu_from_string -- Receive a string and convert the string to a user ! nodenumber. The model is unstructured; just read user nodenumber. -! If flag_string argument is present and true, the first token in string +! If flag_string argument is present and true, the first token in string ! is allowed to be a string (e.g. boundary name). In this case, if a string ! is encountered, return value as -2. ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero - integer(I4B) :: nodeu - ! -- local + ! -- dummy + class(DisBaseType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero + integer(I4B) :: nodeu + ! -- local ! ------------------------------------------------------------------------------ - ! - ! - nodeu = 0 - call store_error('Program error: DisBaseType method nodeu_from_string & - ¬ implemented.', terminate=.TRUE.) - ! - ! -- return - return + ! + ! + nodeu = 0 + call store_error('Program error: DisBaseType method nodeu_from_string & + ¬ implemented.', terminate=.TRUE.) + ! + ! -- return + return end function nodeu_from_string - - function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(nodeu) + + function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(nodeu) ! ****************************************************************************** ! nodeu_from_cellid -- Receive cellid as a string and convert the string to a -! user nodenumber. -! If flag_string argument is present and true, the first token in string +! user nodenumber. +! If flag_string argument is present and true, the first token in string ! is allowed to be a string (e.g. boundary name). In this case, if a string ! is encountered, return value as -2. ! If allow_zero argument is present and true, if all indices equal zero, the @@ -706,12 +706,12 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero + class(DisBaseType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero integer(I4B) :: nodeu ! ------------------------------------------------------------------------------ ! @@ -722,13 +722,13 @@ function nodeu_from_cellid(this, cellid, inunit, iout, flag_string, & ! -- return return end function nodeu_from_cellid - - function noder_from_string(this, lloc, istart, istop, in, iout, line, & + + function noder_from_string(this, lloc, istart, istop, in, iout, line, & flag_string) result(noder) ! ****************************************************************************** ! noder_from_string -- Receive a string and convert the string to a reduced ! nodenumber. The model is unstructured; just read user nodenumber. -! If flag_string argument is present and true, the first token in string +! If flag_string argument is present and true, the first token in string ! is allowed to be a string (e.g. boundary name). In this case, if a string ! is encountered, return value as -2. ! ****************************************************************************** @@ -736,15 +736,15 @@ function noder_from_string(this, lloc, istart, istop, in, iout, line, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType) :: this - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: line - logical, optional, intent(in) :: flag_string - integer(I4B) :: noder + class(DisBaseType) :: this + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: line + logical, optional, intent(in) :: flag_string + integer(I4B) :: noder ! -- local integer(I4B) :: nodeu character(len=LINELENGTH) :: nodestr @@ -755,8 +755,8 @@ function noder_from_string(this, lloc, istart, istop, in, iout, line, & flag_string_local = flag_string else flag_string_local = .false. - endif - nodeu = this%nodeu_from_string(lloc, istart, istop, in, iout, line, & + end if + nodeu = this%nodeu_from_string(lloc, istart, istop, in, iout, line, & flag_string_local) ! ! -- Convert user-based nodenumber to reduced node number @@ -764,25 +764,25 @@ function noder_from_string(this, lloc, istart, istop, in, iout, line, & noder = this%get_nodenumber(nodeu, 0) else noder = nodeu - endif - if(noder <= 0 .and. .not. flag_string_local) then + end if + if (noder <= 0 .and. .not. flag_string_local) then call this%nodeu_to_string(nodeu, nodestr) - write(errmsg, *) & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write (errmsg, *) & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) call store_error(errmsg) - endif + end if ! ! -- return return end function noder_from_string - - function noder_from_cellid(this, cellid, inunit, iout, flag_string, & - allow_zero) result(noder) + + function noder_from_cellid(this, cellid, inunit, iout, flag_string, & + allow_zero) result(noder) ! ****************************************************************************** ! noder_from_cellid -- Receive cellid as a string and convert it to a reduced -! nodenumber. -! If flag_string argument is present and true, the first token in string +! nodenumber. +! If flag_string argument is present and true, the first token in string ! is allowed to be a string (e.g. boundary name). In this case, if a string ! is encountered, return value as -2. ! If allow_zero argument is present and true, if all indices equal zero, the @@ -795,12 +795,12 @@ function noder_from_cellid(this, cellid, inunit, iout, flag_string, & ! -- return integer(I4B) :: noder ! -- dummy - class(DisBaseType) :: this - character(len=*), intent(inout) :: cellid - integer(I4B), intent(in) :: inunit - integer(I4B), intent(in) :: iout - logical, optional, intent(in) :: flag_string - logical, optional, intent(in) :: allow_zero + class(DisBaseType) :: this + character(len=*), intent(inout) :: cellid + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + logical, optional, intent(in) :: flag_string + logical, optional, intent(in) :: allow_zero ! -- local integer(I4B) :: nodeu logical :: allowzerolocal @@ -812,14 +812,14 @@ function noder_from_cellid(this, cellid, inunit, iout, flag_string, & flag_string_local = flag_string else flag_string_local = .false. - endif + end if if (present(allow_zero)) then allowzerolocal = allow_zero else allowzerolocal = .false. - endif + end if ! - nodeu = this%nodeu_from_cellid(cellid, inunit, iout, flag_string_local, & + nodeu = this%nodeu_from_cellid(cellid, inunit, iout, flag_string_local, & allowzerolocal) ! ! -- Convert user-based nodenumber to reduced node number @@ -827,19 +827,19 @@ function noder_from_cellid(this, cellid, inunit, iout, flag_string, & noder = this%get_nodenumber(nodeu, 0) else noder = nodeu - endif - if(noder <= 0 .and. .not. flag_string_local) then + end if + if (noder <= 0 .and. .not. flag_string_local) then call this%nodeu_to_string(nodeu, nodestr) - write(errmsg, *) & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write (errmsg, *) & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) call store_error(errmsg) - endif + end if ! ! -- return return end function noder_from_cellid - + logical function supports_layers(this) ! ****************************************************************************** ! supports_layers @@ -881,7 +881,7 @@ function get_ncpl(this) ! -- Return return end function get_ncpl - + function get_cell_volume(this, n, x) ! ****************************************************************************** ! get_cell_volume -- Return volume of cell n based on x value passed. @@ -923,15 +923,15 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(DisBaseType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: iarray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! ! -- store error errmsg = 'Programmer error: read_int_array needs to be overridden & @@ -942,7 +942,7 @@ subroutine read_int_array(this, line, lloc, istart, istop, iout, in, & return end subroutine read_int_array - subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & + subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & darray, aname) ! ****************************************************************************** ! read_dbl_array -- Read a GWF double precision array @@ -951,15 +951,15 @@ subroutine read_dbl_array(this, line, lloc, istart, istop, iout, in, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType), intent(inout) :: this - character(len=*), intent(inout) :: line - integer(I4B), intent(inout) :: lloc - integer(I4B), intent(inout) :: istart - integer(I4B), intent(inout) :: istop - integer(I4B), intent(in) :: in - integer(I4B), intent(in) :: iout + class(DisBaseType), intent(inout) :: this + character(len=*), intent(inout) :: line + integer(I4B), intent(inout) :: lloc + integer(I4B), intent(inout) :: istart + integer(I4B), intent(inout) :: istop + integer(I4B), intent(in) :: in + integer(I4B), intent(in) :: iout real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - character(len=*), intent(in) :: aname + character(len=*), intent(in) :: aname ! ! -- str=ore error message errmsg = 'Programmer error: read_dbl_array needs to be overridden & @@ -978,8 +978,8 @@ subroutine fill_int_array(this, ibuff1, ibuff2) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType), intent(inout) :: this - integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ibuff1 + class(DisBaseType), intent(inout) :: this + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ibuff1 integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibuff2 ! -- local integer(I4B) :: nodeu @@ -987,7 +987,7 @@ subroutine fill_int_array(this, ibuff1, ibuff2) ! ------------------------------------------------------------------------------ do nodeu = 1, this%nodesuser noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle + if (noder <= 0) cycle ibuff2(noder) = ibuff1(nodeu) end do ! @@ -1003,8 +1003,8 @@ subroutine fill_dbl_array(this, buff1, buff2) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType), intent(inout) :: this - real(DP), dimension(:), pointer, contiguous, intent(in) :: buff1 + class(DisBaseType), intent(inout) :: this + real(DP), dimension(:), pointer, contiguous, intent(in) :: buff1 real(DP), dimension(:), pointer, contiguous, intent(inout) :: buff2 ! -- local integer(I4B) :: nodeu @@ -1012,21 +1012,21 @@ subroutine fill_dbl_array(this, buff1, buff2) ! ------------------------------------------------------------------------------ do nodeu = 1, this%nodesuser noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) cycle + if (noder <= 0) cycle buff2(noder) = buff1(nodeu) end do ! ! -- return return end subroutine fill_dbl_array - - subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & - iauxmultcol, nodelist, rlist, auxvar, auxname, & - boundname, label, pkgname, tsManager, iscloc, & - indxconvertflux) + + subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & + iauxmultcol, nodelist, rlist, auxvar, auxname, & + boundname, label, pkgname, tsManager, iscloc, & + indxconvertflux) ! ****************************************************************************** ! read_list -- Read a list using the list reader object. -! Convert user node numbers to reduced numbers. +! Convert user node numbers to reduced numbers. ! Terminate if any nodenumbers are within an inactive domain. ! Set up time series and multiply by iauxmultcol if it exists. ! Write the list to iout if iprpak is set. @@ -1039,7 +1039,7 @@ subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & use ListReaderModule, only: ListReaderType use SimModule, only: store_error, store_error_unit, count_errors use InputOutputModule, only: urword - use TimeSeriesLinkModule, only: TimeSeriesLinkType + use TimeSeriesLinkModule, only: TimeSeriesLinkType use TimeSeriesManagerModule, only: read_value_or_time_series ! -- dummy class(DisBaseType) :: this @@ -1050,16 +1050,16 @@ subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & integer(I4B), intent(in) :: inamedbound integer(I4B), intent(in) :: iauxmultcol integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: nodelist - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: rlist - real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: auxvar + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: rlist + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: auxvar character(len=LENAUXNAME), dimension(:), intent(inout) :: auxname - character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, & - intent(inout) :: boundname + character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, & + intent(inout) :: boundname !character(len=:), dimension(:), pointer, contiguous, intent(inout) :: auxname !character(len=:), dimension(:), pointer, contiguous, intent(inout) :: boundname character(len=*), intent(in) :: label - character(len=*), intent(in) :: pkgName - type(TimeSeriesManagerType) :: tsManager + character(len=*), intent(in) :: pkgName + type(TimeSeriesManagerType) :: tsManager integer(I4B), intent(in) :: iscloc integer(I4B), intent(in), optional :: indxconvertflux ! -- local @@ -1074,32 +1074,33 @@ subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & ! ------------------------------------------------------------------------------ ! ! -- Read the list - call lstrdobj%read_list(in, iout, nlist, inamedbound, this%mshape, & + call lstrdobj%read_list(in, iout, nlist, inamedbound, this%mshape, & nodelist, rlist, auxvar, auxname, boundname, label) ! ! -- Go through all locations where a text string was found instead of ! a double precision value and make time-series links to rlist - if(lstrdobj%ntxtrlist > 0) then + if (lstrdobj%ntxtrlist > 0) then do l = 1, lstrdobj%ntxtrlist ii = lstrdobj%idxtxtrow(l) jj = lstrdobj%idxtxtcol(l) tsLinkBnd => NULL() bndElem => rlist(jj, ii) - call read_value_or_time_series(lstrdobj%txtrlist(l), ii, jj, & - bndElem, pkgName, 'BND', tsManager, iprpak, tsLinkBnd) + call read_value_or_time_series(lstrdobj%txtrlist(l), ii, jj, bndElem, & + pkgName, 'BND', tsManager, iprpak, & + tsLinkBnd) if (associated(tsLinkBnd)) then ! ! -- If iauxmultcol is active and this column is the column - ! to be scaled, then assign tsLinkBnd%RMultiplier to auxvar + ! to be scaled, then assign tsLinkBnd%RMultiplier to auxvar ! multiplier if (iauxmultcol > 0 .and. jj == iscloc) then tsLinkBnd%RMultiplier => auxvar(iauxmultcol, ii) - endif + end if ! ! -- If boundaries are named, save the name in the link if (lstrdobj%inamedbound == 1) then tsLinkBnd%BndName = lstrdobj%boundname(tsLinkBnd%IRow) - endif + end if ! ! -- if the value is a flux and needs to be converted to a flow ! then set the tsLinkBnd appropriately @@ -1109,71 +1110,72 @@ subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & nodeu = nodelist(ii) noder = this%get_nodenumber(nodeu, 0) tsLinkBnd%CellArea = this%get_area(noder) - endif - endif + end if + end if ! - endif - enddo - endif + end if + end do + end if ! ! -- Make time-series substitutions for auxvar - if(lstrdobj%ntxtauxvar > 0) then + if (lstrdobj%ntxtauxvar > 0) then do l = 1, lstrdobj%ntxtauxvar ii = lstrdobj%idxtxtauxrow(l) jj = lstrdobj%idxtxtauxcol(l) tsLinkAux => NULL() bndElem => auxvar(jj, ii) - call read_value_or_time_series(lstrdobj%txtauxvar(l), ii, jj, & - bndElem, pkgName, 'AUX', tsManager, iprpak, tslinkAux) + call read_value_or_time_series(lstrdobj%txtauxvar(l), ii, jj, bndElem, & + pkgName, 'AUX', tsManager, iprpak, & + tslinkAux) if (lstrdobj%inamedbound == 1) then if (associated(tsLinkAux)) then tsLinkAux%BndName = lstrdobj%boundname(tsLinkAux%IRow) - endif - endif - enddo - endif + end if + end if + end do + end if ! ! -- Multiply rlist by the multiplier column in auxvar - if(iauxmultcol > 0) then + if (iauxmultcol > 0) then do l = 1, nlist rlist(iscloc, l) = rlist(iscloc, l) * auxvar(iauxmultcol, l) - enddo - endif + end do + end if ! ! -- Write the list to iout if requested - if(iprpak /= 0) then + if (iprpak /= 0) then call lstrdobj%write_list() - endif + end if ! ! -- Convert user nodenumbers to reduced nodenumbers, if necessary. ! Conversion to reduced nodenumbers must be done last, after the ! list is written so that correct indices are written to the list. - if(this%nodes < this%nodesuser) then + if (this%nodes < this%nodesuser) then do l = 1, nlist nodeu = nodelist(l) noder = this%get_nodenumber(nodeu, 0) - if(noder <= 0) then + if (noder <= 0) then call this%nodeu_to_string(nodeu, nodestr) - write(errmsg, *) & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write (errmsg, *) & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) call store_error(errmsg) - endif + end if nodelist(l) = noder - enddo + end do ! ! -- Check for errors and terminate if encountered - if(count_errors() > 0) then - write(errmsg, *) count_errors(), ' errors encountered.' + if (count_errors() > 0) then + write (errmsg, *) count_errors(), ' errors encountered.' call store_error(errmsg) call store_error_unit(in) - endif - endif + end if + end if ! ! -- return end subroutine read_list - subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & + subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & icolbnd, aname, inunit, iout) ! ****************************************************************************** ! read_layer_array -- Read a 2d double array into col icolbnd of darray. @@ -1202,9 +1204,9 @@ subroutine read_layer_array(this, nodelist, darray, ncolbnd, maxbnd, & ! ! -- return end subroutine read_layer_array - - subroutine record_array(this, darray, iout, iprint, idataun, aname, & - cdatafmp, nvaluesp, nwidthp, editdesc, dinact) + + subroutine record_array(this, darray, iout, iprint, idataun, aname, & + cdatafmp, nvaluesp, nwidthp, editdesc, dinact) ! ****************************************************************************** ! record_array -- Record a double precision array. The array will be ! printed to an external file and/or written to an unformatted external file @@ -1226,19 +1228,19 @@ subroutine record_array(this, darray, iout, iprint, idataun, aname, & ! from the model domain ! ------------------------------------------------------------------------------ ! -- dummy - class(DisBaseType), intent(inout) :: this + class(DisBaseType), intent(inout) :: this real(DP), dimension(:), pointer, contiguous, intent(inout) :: darray - integer(I4B), intent(in) :: iout - integer(I4B), intent(in) :: iprint - integer(I4B), intent(in) :: idataun - character(len=*), intent(in) :: aname - character(len=*), intent(in) :: cdatafmp - integer(I4B), intent(in) :: nvaluesp - integer(I4B), intent(in) :: nwidthp - character(len=*), intent(in) :: editdesc - real(DP), intent(in) :: dinact - ! - ! -- + integer(I4B), intent(in) :: iout + integer(I4B), intent(in) :: iprint + integer(I4B), intent(in) :: idataun + character(len=*), intent(in) :: aname + character(len=*), intent(in) :: cdatafmp + integer(I4B), intent(in) :: nvaluesp + integer(I4B), intent(in) :: nwidthp + character(len=*), intent(in) :: editdesc + real(DP), intent(in) :: dinact + ! + ! -- errmsg = 'Programmer error: record_array needs to be overridden & &in any DIS type that extends DisBaseType' call store_error(errmsg, terminate=.TRUE.) @@ -1261,11 +1263,11 @@ subroutine record_connection_array(this, flowja, ibinun, iout) ! -- local character(len=16), dimension(1) :: text ! -- data - data text(1) /' FLOW-JA-FACE'/ + data text(1)/' FLOW-JA-FACE'/ ! ------------------------------------------------------------------------------ ! ! -- write full ja array - call ubdsv1(kstp, kper, text(1), ibinun, flowja, size(flowja), 1, 1, & + call ubdsv1(kstp, kper, text(1), ibinun, flowja, size(flowja), 1, 1, & iout, delt, pertim, totim) ! ! -- return @@ -1299,7 +1301,7 @@ end subroutine noder_to_string subroutine noder_to_array(this, noder, arr) ! ****************************************************************************** ! noder_to_array -- Convert reduced node number to cellid and fill array with -! (nodenumber) or (k,j) or (k,i,j) +! (nodenumber) or (k,j) or (k,i,j) ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -1320,8 +1322,8 @@ subroutine noder_to_array(this, noder, arr) return end subroutine noder_to_array - subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & - dstmodel, dstpackage, naux, auxtxt, & + subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & + dstmodel, dstpackage, naux, auxtxt, & ibdchn, nlist, iout) ! ****************************************************************************** ! record_srcdst_list_header -- Record list header for imeth=6 @@ -1342,7 +1344,7 @@ subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & integer(I4B), intent(in) :: nlist integer(I4B), intent(in) :: iout ! - ! -- + ! -- errmsg = 'Programmer error: record_srcdst_list_header needs to be & &overridden in any DIS type that extends DisBaseType' call store_error(errmsg, terminate=.TRUE.) @@ -1351,7 +1353,7 @@ subroutine record_srcdst_list_header(this, text, textmodel, textpackage, & return end subroutine record_srcdst_list_header - subroutine record_srcdst_list_entry(this, ibdchn, noder, noder2, q, & + subroutine record_srcdst_list_entry(this, ibdchn, noder, noder2, q, & naux, aux, olconv, olconv2) ! ****************************************************************************** ! record_srcdst_list_header -- Record list header @@ -1405,7 +1407,7 @@ subroutine record_srcdst_list_entry(this, ibdchn, noder, noder2, q, & return end subroutine record_srcdst_list_entry - subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & + subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & inunit, iout) ! ****************************************************************************** ! nlarray_to_nodelist -- Read an integer array into nodelist. For structured @@ -1427,7 +1429,7 @@ subroutine nlarray_to_nodelist(this, nodelist, maxbnd, nbound, aname, & integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout ! - ! -- + ! -- errmsg = 'Programmer error: nlarray_to_nodelist needs to be & &overridden in any DIS type that extends DisBaseType' call store_error(errmsg, terminate=.TRUE.) @@ -1448,36 +1450,36 @@ subroutine highest_active(this, n, ibound) integer(I4B), intent(inout) :: n integer(I4B), dimension(:), intent(in) :: ibound ! -- locals - integer(I4B) :: m,ii,iis + integer(I4B) :: m, ii, iis logical done, bottomcell ! ------------------------------------------------------------------------------ ! ! -- Loop through connected cells until the highest active one (including a ! constant head cell) is found. Return that cell as n. - done=.false. - do while(.not. done) + done = .false. + do while (.not. done) bottomcell = .true. - cloop: do ii = this%con%ia(n) + 1, this%con%ia(n+1)-1 + cloop: do ii = this%con%ia(n) + 1, this%con%ia(n + 1) - 1 m = this%con%ja(ii) iis = this%con%jas(ii) - if(this%con%ihc(iis) == 0 .and. m > n) then + if (this%con%ihc(iis) == 0 .and. m > n) then ! ! -- this cannot be a bottom cell bottomcell = .false. ! ! -- vertical down - if(ibound(m) /= 0) then + if (ibound(m) /= 0) then n = m done = .true. exit cloop else n = m exit cloop - endif - endif - enddo cloop - if(bottomcell) done = .true. - enddo + end if + end if + end do cloop + if (bottomcell) done = .true. + end do ! ! -- return return diff --git a/src/Model/ModelUtilities/DisvGeom.f90 b/src/Model/ModelUtilities/DisvGeom.f90 index c433f5f215f..581ad424b88 100644 --- a/src/Model/ModelUtilities/DisvGeom.f90 +++ b/src/Model/ModelUtilities/DisvGeom.f90 @@ -1,12 +1,12 @@ module DisvGeom - + use KindModule, only: DP, I4B use InputOutputModule, only: get_node, get_jk implicit none private public :: DisvGeomType public :: line_unit_vector - + type DisvGeomType integer(I4B) :: k integer(I4B) :: j @@ -15,7 +15,7 @@ module DisvGeom integer(I4B) :: nlay integer(I4B) :: ncpl logical :: reduced - integer(I4B) :: nodes ! number of reduced nodes; nodes = nlay *ncpl when grid is NOT reduced + integer(I4B) :: nodes ! number of reduced nodes; nodes = nlay *ncpl when grid is NOT reduced real(DP) :: top real(DP) :: bot real(DP), pointer, dimension(:) :: top_grid => null() @@ -24,8 +24,8 @@ module DisvGeom integer(I4B), pointer, dimension(:) :: javert => null() real(DP), pointer, dimension(:, :) :: vertex_grid => null() real(DP), pointer, dimension(:, :) :: cellxy_grid => null() - integer(I4B), pointer, dimension(:, :) :: nodereduced => null() ! nodered = nodereduced(nodeusr) - integer(I4B), pointer, dimension(:) :: nodeuser => null() ! nodeusr = nodesuser(nodered) + integer(I4B), pointer, dimension(:, :) :: nodereduced => null() ! nodered = nodereduced(nodeusr) + integer(I4B), pointer, dimension(:) :: nodeuser => null() ! nodeusr = nodesuser(nodered) contains procedure :: init generic :: set => set_kj, set_nodered @@ -38,10 +38,10 @@ module DisvGeom procedure :: shares_edge procedure :: get_area end type DisvGeomType - - contains - - subroutine init(this, nlay, ncpl, nodes, top_grid, bot_grid, iavert, & + +contains + + subroutine init(this, nlay, ncpl, nodes, top_grid, bot_grid, iavert, & javert, vertex_grid, cellxy_grid, nodereduced, nodeuser) class(DisvGeomType) :: this integer(I4B), intent(in) :: nlay @@ -69,13 +69,13 @@ subroutine init(this, nlay, ncpl, nodes, top_grid, bot_grid, iavert, & this%nodereduced => nodereduced this%nodeuser => nodeuser nodesuser = ncpl * nlay - if(nodes < nodesuser) then + if (nodes < nodesuser) then this%reduced = .true. else this%reduced = .false. - endif + end if end subroutine init - + subroutine set_kj(this, k, j) class(DisvGeomType) :: this integer(I4B), intent(in) :: k @@ -83,11 +83,11 @@ subroutine set_kj(this, k, j) this%k = k this%j = j this%nodeusr = get_node(k, 1, j, this%nlay, 1, this%ncpl) - if(this%reduced) then + if (this%reduced) then this%nodered = this%nodereduced(k, j) else this%nodered = this%nodeusr - endif + end if call this%cell_setup() return end subroutine set_kj @@ -96,11 +96,11 @@ subroutine set_nodered(this, nodered) class(DisvGeomType) :: this integer(I4B), intent(in) :: nodered this%nodered = nodered - if(this%reduced) then + if (this%reduced) then this%nodeusr = this%nodeuser(nodered) else this%nodeusr = nodered - endif + end if call get_jk(this%nodeusr, this%ncpl, this%nlay, this%j, this%k) call this%cell_setup() return @@ -111,7 +111,7 @@ subroutine cell_setup(this) this%top = this%top_grid(this%nodered) this%bot = this%bot_grid(this%nodered) end subroutine cell_setup - + subroutine cprops(this, cell2, hwva, cl1, cl2, ax, ihc) ! -- module use ConstantsModule, only: DZERO, DHALF, DONE @@ -127,7 +127,7 @@ subroutine cprops(this, cell2, hwva, cl1, cl2, ax, ihc) integer(I4B) :: istart1, istart2, istop1, istop2 real(DP) :: x0, y0, x1, y1, x2, y2 ! - if(this%j == cell2%j) then + if (this%j == cell2%j) then ! ! -- Cells share same j index, so must be a vertical connection ihc = 0 @@ -146,7 +146,7 @@ subroutine cprops(this, cell2, hwva, cl1, cl2, ax, ihc) call shared_edge(this%javert(istart1:istop1), & this%javert(istart2:istop2), & ivert1, ivert2) - if(ivert1 == 0 .or. ivert2 == 0) then + if (ivert1 == 0 .or. ivert2 == 0) then ! ! -- Cells do not share an edge hwva = DZERO @@ -175,11 +175,11 @@ subroutine cprops(this, cell2, hwva, cl1, cl2, ax, ihc) x2 = this%vertex_grid(1, ivert2) y2 = this%vertex_grid(2, ivert2) ax = anglex(x1, y1, x2, y2) - endif - endif - return + end if + end if + return end subroutine cprops - + subroutine edge_normal(this, cell2, xcomp, ycomp) ! return the x and y components of an outward normal ! facing vector @@ -200,19 +200,19 @@ subroutine edge_normal(this, cell2, xcomp, ycomp) istart2 = cell2%iavert(cell2%j) istop2 = this%iavert(cell2%j + 1) - 1 call shared_edge(this%javert(istart1:istop1), & - this%javert(istart2:istop2), & - ivert1, ivert2) + this%javert(istart2:istop2), & + ivert1, ivert2) x1 = this%vertex_grid(1, ivert1) y1 = this%vertex_grid(2, ivert1) x2 = this%vertex_grid(1, ivert2) y2 = this%vertex_grid(2, ivert2) ! call line_unit_normal(x1, y1, x2, y2, xcomp, ycomp) - return + return end subroutine edge_normal - - subroutine connection_vector(this, cell2, nozee, satn, satm, xcomp, & - ycomp, zcomp, conlen) + + subroutine connection_vector(this, cell2, nozee, satn, satm, xcomp, & + ycomp, zcomp, conlen) ! return the x y and z components of a unit vector that points ! from the center of this to the center of cell2, and the ! straight-line connection length @@ -243,11 +243,11 @@ subroutine connection_vector(this, cell2, nozee, satn, satm, xcomp, & z2 = cell2%bot + DHALF * satm * (cell2%top - cell2%bot) end if ! - call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, & + call line_unit_vector(x1, y1, z1, x2, y2, z2, xcomp, ycomp, zcomp, & conlen) - return + return end subroutine connection_vector - + function shares_edge(this, cell2) result(l) ! ****************************************************************************** ! shares_edge -- Return true if this shares a horizontal edge with cell2 @@ -266,15 +266,15 @@ function shares_edge(this, cell2) result(l) istart2 = cell2%iavert(cell2%j) istop2 = this%iavert(cell2%j + 1) - 1 call shared_edge(this%javert(istart1:istop1), & - this%javert(istart2:istop2), & - ivert1, ivert2) + this%javert(istart2:istop2), & + ivert1, ivert2) l = .true. - if(ivert1 == 0 .or. ivert2 == 0) then + if (ivert1 == 0 .or. ivert2 == 0) then l = .false. - endif - return + end if + return end function shares_edge - + subroutine shared_edge(ivlist1, ivlist2, ivert1, ivert2) ! ****************************************************************************** ! shared_edge -- Find two common vertices shared by cell1 and cell2. @@ -304,22 +304,22 @@ subroutine shared_edge(ivlist1, ivlist2, ivert1, ivert2) ivert2 = 0 outerloop: do il1 = 1, nv1 - 1 do il2 = nv2, 2, -1 - if(ivlist1(il1) == ivlist2(il2) .and. & - ivlist1(il1 + 1) == ivlist2(il2 - 1)) then + if (ivlist1(il1) == ivlist2(il2) .and. & + ivlist1(il1 + 1) == ivlist2(il2 - 1)) then found = .true. ivert1 = ivlist1(il1) ivert2 = ivlist1(il1 + 1) exit outerloop - endif - enddo - if(found) exit - enddo outerloop + end if + end do + if (found) exit + end do outerloop end subroutine shared_edge - + function get_area(this) result(area) ! ****************************************************************************** ! get_cell2d_area -- Calculate and return the area of the cell -! a = 1/2 *[(x1*y2 + x2*y3 + x3*y4 + ... + xn*y1) - +! a = 1/2 *[(x1*y2 + x2*y3 + x3*y4 + ... + xn*y1) - ! (x2*y1 + x3*y2 + x4*y3 + ... + x1*yn)] ! ****************************************************************************** ! @@ -344,37 +344,37 @@ function get_area(this) result(area) icount = 1 do ivert = this%iavert(this%j), this%iavert(this%j + 1) - 1 x = this%vertex_grid(1, this%javert(ivert)) - if(icount < nvert) then + if (icount < nvert) then y = this%vertex_grid(2, this%javert(ivert + 1)) else y = this%vertex_grid(2, this%javert(this%iavert(this%j))) - endif + end if area = area + x * y icount = icount + 1 - enddo + end do ! icount = 1 do ivert = this%iavert(this%j), this%iavert(this%j + 1) - 1 y = this%vertex_grid(2, this%javert(ivert)) - if(icount < nvert) then + if (icount < nvert) then x = this%vertex_grid(1, this%javert(ivert + 1)) else x = this%vertex_grid(1, this%javert(this%iavert(this%j))) - endif + end if area = area - x * y icount = icount + 1 - enddo + end do ! area = abs(area) * DHALF ! ! -- return return end function get_area - + function anglex(x1, y1, x2, y2) result(ax) ! ****************************************************************************** -! anglex -- Calculate the angle that the x-axis makes with a line that is -! normal to the two points. This assumes that vertices are numbered +! anglex -- Calculate the angle that the x-axis makes with a line that is +! normal to the two points. This assumes that vertices are numbered ! clockwise so that the angle is for the normal outward of cell n. ! ****************************************************************************** ! @@ -392,10 +392,10 @@ function anglex(x1, y1, x2, y2) result(ax) dx = x2 - x1 dy = y2 - y1 ax = atan2(dx, -dy) - if(ax < DZERO) ax = DTWO * DPI + ax + if (ax < DZERO) ax = DTWO * DPI + ax return end function anglex - + function distance(x1, y1, x2, y2) result(d) ! ****************************************************************************** ! distance -- Calculate distance between two points @@ -409,11 +409,11 @@ function distance(x1, y1, x2, y2) result(d) real(DP), intent(in) :: y2 real(DP) :: d ! ------------------------------------------------------------------------------ - d = (x1 - x2) ** 2 + (y1 - y2) ** 2 + d = (x1 - x2)**2 + (y1 - y2)**2 d = sqrt(d) return end function distance - + function distance_normal(x0, y0, x1, y1, x2, y2) result(d) ! ****************************************************************************** ! distance_normal -- Calculate normal distance from point (x0, y0) to line @@ -434,10 +434,10 @@ function distance_normal(x0, y0, x1, y1, x2, y2) result(d) d = d / distance(x1, y1, x2, y2) return end function distance_normal - + subroutine line_unit_normal(x0, y0, x1, y1, xcomp, ycomp) ! ****************************************************************************** -! line_unit_normal -- Calculate the normal vector components (xcomp and ycomp) +! line_unit_normal -- Calculate the normal vector components (xcomp and ycomp) ! for a line defined by two points, (x0, y0), (x1, y1) ! ****************************************************************************** ! @@ -453,16 +453,16 @@ subroutine line_unit_normal(x0, y0, x1, y1, xcomp, ycomp) ! ------------------------------------------------------------------------------ dx = x1 - x0 dy = y1 - y0 - vmag = sqrt(dx ** 2 + dy ** 2) + vmag = sqrt(dx**2 + dy**2) xcomp = -dy / vmag ycomp = dx / vmag return end subroutine line_unit_normal - - subroutine line_unit_vector(x0, y0, z0, x1, y1, z1, & - xcomp, ycomp, zcomp, vmag) + + subroutine line_unit_vector(x0, y0, z0, x1, y1, z1, & + xcomp, ycomp, zcomp, vmag) ! ****************************************************************************** -! line_unit_vector -- Calculate the vector components (xcomp, ycomp, and zcomp) +! line_unit_vector -- Calculate the vector components (xcomp, ycomp, and zcomp) ! for a line defined by two points, (x0, y0, z0), (x1, y1, z1). Also return ! the magnitude of the original vector, vmag. ! ****************************************************************************** @@ -483,12 +483,11 @@ subroutine line_unit_vector(x0, y0, z0, x1, y1, z1, & dx = x1 - x0 dy = y1 - y0 dz = z1 - z0 - vmag = sqrt(dx ** 2 + dy ** 2 + dz ** 2) + vmag = sqrt(dx**2 + dy**2 + dz**2) xcomp = dx / vmag ycomp = dy / vmag zcomp = dz / vmag return end subroutine line_unit_vector - - -end module DisvGeom \ No newline at end of file + +end module DisvGeom diff --git a/src/Model/ModelUtilities/GwfBuyInputData.f90 b/src/Model/ModelUtilities/GwfBuyInputData.f90 index b3c9944addb..6e35997a0f2 100644 --- a/src/Model/ModelUtilities/GwfBuyInputData.f90 +++ b/src/Model/ModelUtilities/GwfBuyInputData.f90 @@ -10,15 +10,15 @@ module GwfBuyInputDataModule type, public :: GwfBuyInputDataType ! options - integer(I4B) :: iform !< see BUY for description - real(DP) :: denseref !< see BUY for description + integer(I4B) :: iform !< see BUY for description + real(DP) :: denseref !< see BUY for description ! dim - integer(I4B) :: nrhospecies !< see BUY for description + integer(I4B) :: nrhospecies !< see BUY for description ! pkg data - real(DP), dimension(:), pointer, contiguous :: drhodc => null() !< see BUY for description - real(DP), dimension(:), pointer, contiguous :: crhoref => null() !< see BUY for description - character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname !< see BUY for description + real(DP), dimension(:), pointer, contiguous :: drhodc => null() !< see BUY for description + real(DP), dimension(:), pointer, contiguous :: crhoref => null() !< see BUY for description + character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname !< see BUY for description character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname !< see BUY for description contains @@ -32,12 +32,12 @@ module GwfBuyInputDataModule !< subroutine construct(this, nrhospecies) class(GwfBuyInputDataType) :: this !< the input data block - integer(I4B) :: nrhospecies !< the number of species + integer(I4B) :: nrhospecies !< the number of species - allocate(this%drhodc(nrhospecies)) - allocate(this%crhoref(nrhospecies)) - allocate(this%cmodelname(nrhospecies)) - allocate(this%cauxspeciesname(nrhospecies)) + allocate (this%drhodc(nrhospecies)) + allocate (this%crhoref(nrhospecies)) + allocate (this%cmodelname(nrhospecies)) + allocate (this%cauxspeciesname(nrhospecies)) end subroutine construct @@ -46,11 +46,11 @@ end subroutine construct subroutine destruct(this) class(GwfBuyInputDataType) :: this !< the input data block - deallocate(this%drhodc) - deallocate(this%crhoref) - deallocate(this%cmodelname) - deallocate(this%cauxspeciesname) + deallocate (this%drhodc) + deallocate (this%crhoref) + deallocate (this%cmodelname) + deallocate (this%cauxspeciesname) end subroutine destruct -end module GwfBuyInputDataModule \ No newline at end of file +end module GwfBuyInputDataModule diff --git a/src/Model/ModelUtilities/GwfMvrPeriodData.f90 b/src/Model/ModelUtilities/GwfMvrPeriodData.f90 index d6e614500ee..c65b6b55cb6 100644 --- a/src/Model/ModelUtilities/GwfMvrPeriodData.f90 +++ b/src/Model/ModelUtilities/GwfMvrPeriodData.f90 @@ -5,40 +5,44 @@ !! !< module GwfMvrPeriodDataModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMEMPATH, LENMODELNAME, LENPACKAGENAME, & - LINELENGTH - use SimVariablesModule, only: errmsg - use SimModule, only: store_error - use BlockParserModule, only: BlockParserType - + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMEMPATH, LENMODELNAME, LENPACKAGENAME, & + LINELENGTH + use SimVariablesModule, only: errmsg + use SimModule, only: store_error + use BlockParserModule, only: BlockParserType + implicit none private public GwfMvrPeriodDataType - - !> @brief Derived type for GwfMvrPeriodDataType + + !> @brief Derived type for GwfMvrPeriodDataType !! !! This derived type contains information and methods for !! the data read for the GwfMvr Package. !! !< type GwfMvrPeriodDataType - character(len=LENMODELNAME), dimension(:), pointer, contiguous :: mname1 => null() !< provider model name - character(len=LENPACKAGENAME), dimension(:), pointer, contiguous :: pname1 => null() !< provider package name - character(len=LENMODELNAME), dimension(:), pointer, contiguous :: mname2 => null() !< receiver model name - character(len=LENPACKAGENAME), dimension(:), pointer, contiguous :: pname2 => null() !< receiver package name - integer(I4B), dimension(:), pointer, contiguous :: id1 => null() !< provider reach number - integer(I4B), dimension(:), pointer, contiguous :: id2 => null() !< receiver reach number - integer(I4B), dimension(:), pointer, contiguous :: imvrtype => null() !< mover type (1, 2, 3, 4) corresponds to mvrtypes - real(DP), dimension(:), pointer, contiguous :: value => null() !< factor or rate depending on mvrtype + character(len=LENMODELNAME), & + dimension(:), pointer, contiguous :: mname1 => null() !< provider model name + character(len=LENPACKAGENAME), & + dimension(:), pointer, contiguous :: pname1 => null() !< provider package name + character(len=LENMODELNAME), & + dimension(:), pointer, contiguous :: mname2 => null() !< receiver model name + character(len=LENPACKAGENAME), & + dimension(:), pointer, contiguous :: pname2 => null() !< receiver package name + integer(I4B), dimension(:), pointer, contiguous :: id1 => null() !< provider reach number + integer(I4B), dimension(:), pointer, contiguous :: id2 => null() !< receiver reach number + integer(I4B), dimension(:), pointer, contiguous :: imvrtype => null() !< mover type (1, 2, 3, 4) corresponds to mvrtypes + real(DP), dimension(:), pointer, contiguous :: value => null() !< factor or rate depending on mvrtype contains procedure :: construct procedure :: read_from_parser procedure :: destroy end type GwfMvrPeriodDataType - contains - +contains + !> @ brief Construct arrays !! !! Allocate maximum space for mover input. @@ -48,16 +52,16 @@ subroutine construct(this, maxsize, memoryPath) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwfMvrPeriodDataType) :: this !< GwfMvrPeriodDataType - integer(I4B), intent(in) :: maxsize !< size of arrays - character(len=LENMEMPATH), intent(in) :: memoryPath !< memory manager path - + class(GwfMvrPeriodDataType) :: this !< GwfMvrPeriodDataType + integer(I4B), intent(in) :: maxsize !< size of arrays + character(len=LENMEMPATH), intent(in) :: memoryPath !< memory manager path + ! -- character arrays - allocate(this%mname1(maxsize)) - allocate(this%pname1(maxsize)) - allocate(this%mname2(maxsize)) - allocate(this%pname2(maxsize)) - + allocate (this%mname1(maxsize)) + allocate (this%pname1(maxsize)) + allocate (this%mname2(maxsize)) + allocate (this%pname2(maxsize)) + ! -- integer and real call mem_allocate(this%id1, maxsize, 'ID1', memoryPath) call mem_allocate(this%id2, maxsize, 'ID2', memoryPath) @@ -66,7 +70,7 @@ subroutine construct(this, maxsize, memoryPath) return end subroutine construct - + !> @ brief Fill the arrays from parser !! !! Use the provided block parser to fill the input arrays. @@ -74,10 +78,10 @@ end subroutine construct !< subroutine read_from_parser(this, parser, nmvr, modelname) ! -- dummy - class(GwfMvrPeriodDataType) :: this !< GwfMvrPeriodDataType - type(BlockParserType), intent(inout) :: parser !< block parser - integer(I4B), intent(out) :: nmvr !< number of mover entries read - character(len=LENMODELNAME), intent(in) :: modelname !< name of model or empty string + class(GwfMvrPeriodDataType) :: this !< GwfMvrPeriodDataType + type(BlockParserType), intent(inout) :: parser !< block parser + integer(I4B), intent(out) :: nmvr !< number of mover entries read + character(len=LENMODELNAME), intent(in) :: modelname !< name of model or empty string ! -- local integer(I4B) :: i integer(I4B) :: maxmvr @@ -97,11 +101,11 @@ subroutine read_from_parser(this, parser, nmvr, modelname) ! -- Raise error if movers exceeds maxmvr if (i > maxmvr) then call parser%GetCurrentLine(line) - write(errmsg,'(4x,a,a)') 'MOVERS EXCEED MAXMVR ON LINE: ', & - trim(adjustl(line)) + write (errmsg, '(4x,a,a)') 'MOVERS EXCEED MAXMVR ON LINE: ', & + trim(adjustl(line)) call store_error(errmsg) call parser%StoreErrorUnit() - endif + end if ! ! -- modelname, package name, id for provider if (modelname == '') then @@ -123,18 +127,18 @@ subroutine read_from_parser(this, parser, nmvr, modelname) ! ! -- Mover type and value call parser%GetStringCaps(mvrtype_char) - select case(mvrtype_char) - case('FACTOR') - this%imvrtype(i) = 1 - case('EXCESS') - this%imvrtype(i) = 2 - case('THRESHOLD') - this%imvrtype(i) = 3 - case('UPTO') - this%imvrtype(i) = 4 - case default - call store_error('INVALID MOVER TYPE: '//trim(mvrtype_char)) - call parser%StoreErrorUnit() + select case (mvrtype_char) + case ('FACTOR') + this%imvrtype(i) = 1 + case ('EXCESS') + this%imvrtype(i) = 2 + case ('THRESHOLD') + this%imvrtype(i) = 3 + case ('UPTO') + this%imvrtype(i) = 4 + case default + call store_error('INVALID MOVER TYPE: '//trim(mvrtype_char)) + call parser%StoreErrorUnit() end select this%value(i) = parser%GetDouble() i = i + 1 @@ -151,24 +155,23 @@ end subroutine read_from_parser subroutine destroy(this) ! -- modules use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(GwfMvrPeriodDataType) :: this !< GwfMvrPeriodDataType + ! -- dummy + class(GwfMvrPeriodDataType) :: this !< GwfMvrPeriodDataType ! -- character arrays - deallocate(this%mname1) - deallocate(this%pname1) - deallocate(this%mname2) - deallocate(this%pname2) - + deallocate (this%mname1) + deallocate (this%pname1) + deallocate (this%mname2) + deallocate (this%pname2) + ! -- integer and real call mem_deallocate(this%id1) call mem_deallocate(this%id2) call mem_deallocate(this%imvrtype) call mem_deallocate(this%value) - + return end subroutine destroy - end module GwfMvrPeriodDataModule - + diff --git a/src/Model/ModelUtilities/GwfNpfGridData.f90 b/src/Model/ModelUtilities/GwfNpfGridData.f90 index 2992b6294f8..eaafea9a08a 100644 --- a/src/Model/ModelUtilities/GwfNpfGridData.f90 +++ b/src/Model/ModelUtilities/GwfNpfGridData.f90 @@ -2,29 +2,29 @@ module GwfNpfGridDataModule use KindModule, only: I4B, DP use ConstantsModule, only: DZERO implicit none - private + private !> Data structure and helper methods for passing NPF grid data !! into npf_ar, as an alternative to reading those from file. !! As this is a temporary object, the variables are not !! allocated inside the memory manager. !< - type, public :: GwfNpfGridDataType + type, public :: GwfNpfGridDataType ! grid data - integer(I4B) :: ik22 !< flag equals 1 when present - integer(I4B) :: ik33 !< flag equals 1 when present + integer(I4B) :: ik22 !< flag equals 1 when present + integer(I4B) :: ik33 !< flag equals 1 when present integer(I4B) :: iwetdry !< flag equals 1 when present integer(I4B) :: iangle1 !< flag equals 1 when present integer(I4B) :: iangle2 !< flag equals 1 when present integer(I4B) :: iangle3 !< flag equals 1 when present - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: k11 => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: k22 => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: k33 => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: wetdry => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< same as npf variable - real(DP), dimension(:), pointer, contiguous :: angle3 => null() !< same as npf variable + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: k11 => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: k22 => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: k33 => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: wetdry => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: angle3 => null() !< same as npf variable contains procedure, pass(this) :: construct procedure, pass(this) :: destroy @@ -36,55 +36,55 @@ module GwfNpfGridDataModule !! the arrays at proper size and initializing the variables !! at their defaults !< -subroutine construct(this, nodes) - class(GwfNpfGridDataType), intent(inout) :: this !< the NPF grid data, as in the input GRIDDATA block - integer(I4B) :: nodes !< the number of nodes in the solution - ! local - integer(I4B) :: i - - this%ik22 = 0 - this%ik33 = 0 - this%iwetdry = 0 - this%iangle1 = 0 - this%iangle2 = 0 - this%iangle3 = 0 - - allocate(this%icelltype(nodes)) - allocate(this%k11(nodes)) - allocate(this%k22(nodes)) - allocate(this%k33(nodes)) - allocate(this%wetdry(nodes)) - allocate(this%angle1(nodes)) - allocate(this%angle2(nodes)) - allocate(this%angle3(nodes)) + subroutine construct(this, nodes) + class(GwfNpfGridDataType), intent(inout) :: this !< the NPF grid data, as in the input GRIDDATA block + integer(I4B) :: nodes !< the number of nodes in the solution + ! local + integer(I4B) :: i - do i = 1, nodes - this%icelltype(i) = DZERO - this%k11(i) = DZERO - this%k22(i) = DZERO - this%k33(i) = DZERO - this%wetdry(i) = DZERO - this%angle1(i) = DZERO - this%angle2(i) = DZERO - this%angle3(i) = DZERO - end do + this%ik22 = 0 + this%ik33 = 0 + this%iwetdry = 0 + this%iangle1 = 0 + this%iangle2 = 0 + this%iangle3 = 0 -end subroutine construct + allocate (this%icelltype(nodes)) + allocate (this%k11(nodes)) + allocate (this%k22(nodes)) + allocate (this%k33(nodes)) + allocate (this%wetdry(nodes)) + allocate (this%angle1(nodes)) + allocate (this%angle2(nodes)) + allocate (this%angle3(nodes)) + + do i = 1, nodes + this%icelltype(i) = DZERO + this%k11(i) = DZERO + this%k22(i) = DZERO + this%k33(i) = DZERO + this%wetdry(i) = DZERO + this%angle1(i) = DZERO + this%angle2(i) = DZERO + this%angle3(i) = DZERO + end do + + end subroutine construct !> @brief clean up, deallocate, etc. !< -subroutine destroy(this) - class(GwfNpfGridDataType), intent(inout) :: this !< the data structure + subroutine destroy(this) + class(GwfNpfGridDataType), intent(inout) :: this !< the data structure - deallocate(this%icelltype) - deallocate(this%k11) - deallocate(this%k22) - deallocate(this%k33) - deallocate(this%wetdry) - deallocate(this%angle1) - deallocate(this%angle2) - deallocate(this%angle3) + deallocate (this%icelltype) + deallocate (this%k11) + deallocate (this%k22) + deallocate (this%k33) + deallocate (this%wetdry) + deallocate (this%angle1) + deallocate (this%angle2) + deallocate (this%angle3) -end subroutine destroy + end subroutine destroy -end module GwfNpfGridDataModule \ No newline at end of file +end module GwfNpfGridDataModule diff --git a/src/Model/ModelUtilities/GwfNpfOptions.f90 b/src/Model/ModelUtilities/GwfNpfOptions.f90 index 6567ea1b525..3f506655bbb 100644 --- a/src/Model/ModelUtilities/GwfNpfOptions.f90 +++ b/src/Model/ModelUtilities/GwfNpfOptions.f90 @@ -5,19 +5,19 @@ module GwfNpfOptionsModule implicit none private - !> Data structure and helper methods for passing NPF options + !> Data structure and helper methods for passing NPF options !! into npf_df, as an alternative to reading those from file !< type, public :: GwfNpfOptionsType - integer(I4B) :: icellavg !< same as npf variable - integer(I4B) :: ithickstrt !< same as npf variable - integer(I4B) :: iperched !< same as npf variable - integer(I4B) :: ivarcv !< same as npf variable - integer(I4B) :: idewatcv !< same as npf variable - integer(I4B) :: irewet !< same as npf variable - real(DP) :: wetfct !< same as npf variable - integer(I4B) :: iwetit !< same as npf variable - integer(I4B) :: ihdwet !< same as npf variable + integer(I4B) :: icellavg !< same as npf variable + integer(I4B) :: ithickstrt !< same as npf variable + integer(I4B) :: iperched !< same as npf variable + integer(I4B) :: ivarcv !< same as npf variable + integer(I4B) :: idewatcv !< same as npf variable + integer(I4B) :: irewet !< same as npf variable + real(DP) :: wetfct !< same as npf variable + integer(I4B) :: iwetit !< same as npf variable + integer(I4B) :: ihdwet !< same as npf variable contains procedure, pass(this) :: construct procedure, pass(this) :: destroy @@ -28,7 +28,7 @@ module GwfNpfOptionsModule !> @brief construct the input options, set variables to their defaults !< subroutine construct(this) - class(GwfNpfOptionsType), intent(inout) :: this !< the NPF options, as in the input OPTIONS block + class(GwfNpfOptionsType), intent(inout) :: this !< the NPF options, as in the input OPTIONS block this%icellavg = 0 this%ithickstrt = 0 @@ -45,10 +45,10 @@ end subroutine construct !> @brief cleans up !< subroutine destroy(this) - class(GwfNpfOptionsType), intent(inout) :: this !< the NPF options, as in the input OPTIONS block + class(GwfNpfOptionsType), intent(inout) :: this !< the NPF options, as in the input OPTIONS block ! nothing to be done here for now... end subroutine destroy -end module GwfNpfOptionsModule \ No newline at end of file +end module GwfNpfOptionsModule diff --git a/src/Model/ModelUtilities/GwfStorageUtils.f90 b/src/Model/ModelUtilities/GwfStorageUtils.f90 index d0cc034e90f..16a36cca0f3 100644 --- a/src/Model/ModelUtilities/GwfStorageUtils.f90 +++ b/src/Model/ModelUtilities/GwfStorageUtils.f90 @@ -24,7 +24,7 @@ module GwfStorageUtilsModule !> @brief Calculate the specific storage terms !! !! Subroutine to calculate the specific storage terms for a cell using - !! the cell geometry, current and previous specific storage capacity, + !! the cell geometry, current and previous specific storage capacity, !! current and previous cell saturation, and the current and previous head. !! Subroutine can optionally return the flow rate from specific storage. !! @@ -33,19 +33,19 @@ pure subroutine SsTerms(iconvert, iorig_ss, iconf_ss, top, bot, & rho1, rho1old, snnew, snold, hnew, hold, & aterm, rhsterm, rate) ! -- dummy variables - integer(I4B), intent(in) :: iconvert !< flag indicating if cell is convertible - integer(I4B), intent(in) :: iorig_ss !< flag indicating if the original MODFLOW 6 specific storage formulation is being used - integer(I4B), intent(in) :: iconf_ss !< flag indicating if specific storage only applies under confined conditions - real(DP), intent(in) :: top !< top of cell - real(DP), intent(in) :: bot !< bottom of cell - real(DP), intent(in) :: rho1 !< current specific storage capacity - real(DP), intent(in) :: rho1old !< previous specific storage capacity - real(DP), intent(in) :: snnew !< current cell saturation - real(DP), intent(in) :: snold !< previous cell saturation - real(DP), intent(in) :: hnew !< current head - real(DP), intent(in) :: hold !< previous head - real(DP), intent(inout) :: aterm !< coefficient matrix term - real(DP), intent(inout) :: rhsterm !< right-hand side term + integer(I4B), intent(in) :: iconvert !< flag indicating if cell is convertible + integer(I4B), intent(in) :: iorig_ss !< flag indicating if the original MODFLOW 6 specific storage formulation is being used + integer(I4B), intent(in) :: iconf_ss !< flag indicating if specific storage only applies under confined conditions + real(DP), intent(in) :: top !< top of cell + real(DP), intent(in) :: bot !< bottom of cell + real(DP), intent(in) :: rho1 !< current specific storage capacity + real(DP), intent(in) :: rho1old !< previous specific storage capacity + real(DP), intent(in) :: snnew !< current cell saturation + real(DP), intent(in) :: snold !< previous cell saturation + real(DP), intent(in) :: hnew !< current head + real(DP), intent(in) :: hold !< previous head + real(DP), intent(inout) :: aterm !< coefficient matrix term + real(DP), intent(inout) :: rhsterm !< right-hand side term real(DP), intent(inout), optional :: rate !< calculated specific storage rate ! -- local variables real(DP) :: tthk @@ -93,22 +93,22 @@ end subroutine SsTerms !> @brief Calculate the specific yield storage terms !! !! Subroutine to calculate the specific yield storage terms for a cell - !! using the cell geometry, current and previous specific yield storage - !! capacity, and the current and previous cell saturation. Subroutine + !! using the cell geometry, current and previous specific yield storage + !! capacity, and the current and previous cell saturation. Subroutine !! can optionally return the flow rate from specific yield. !! !< pure subroutine SyTerms(top, bot, rho2, rho2old, snnew, snold, & aterm, rhsterm, rate) ! -- dummy variables - real(DP), intent(in) :: top !< top of cell - real(DP), intent(in) :: bot !< bottom of cell - real(DP), intent(in) :: rho2 !< current specific yield storage capacity - real(DP), intent(in) :: rho2old !< previous specific yield storage capacity - real(DP), intent(in) :: snnew !< current cell saturation - real(DP), intent(in) :: snold !< previous cell saturation - real(DP), intent(inout) :: aterm !< coefficient matrix term - real(DP), intent(inout) :: rhsterm !< right-hand side term + real(DP), intent(in) :: top !< top of cell + real(DP), intent(in) :: bot !< bottom of cell + real(DP), intent(in) :: rho2 !< current specific yield storage capacity + real(DP), intent(in) :: rho2old !< previous specific yield storage capacity + real(DP), intent(in) :: snnew !< current cell saturation + real(DP), intent(in) :: snold !< previous cell saturation + real(DP), intent(inout) :: aterm !< coefficient matrix term + real(DP), intent(inout) :: rhsterm !< right-hand side term real(DP), intent(inout), optional :: rate !< calculated specific yield rate ! -- local variables real(DP) :: tthk @@ -125,7 +125,7 @@ pure subroutine SyTerms(top, bot, rho2, rho2old, snnew, snold, & else rhsterm = tthk * (DZERO - rho2old * snold) end if - ! -- known flow from specific yield + ! -- known flow from specific yield else rhsterm = tthk * (rho2 * snnew - rho2old * snold) end if @@ -148,11 +148,11 @@ end subroutine SyTerms !< pure function SsCapacity(istor_coef, top, bot, area, ss) result(sc1) ! -- dummy variables - integer(I4B), intent(in) :: istor_coef !< flag indicating if ss is the storage coefficient - real(DP), intent(in) :: top !< top of cell - real(DP), intent(in) :: bot !< bottom of cell - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: ss !< specific storage or storage coefficient + integer(I4B), intent(in) :: istor_coef !< flag indicating if ss is the storage coefficient + real(DP), intent(in) :: top !< top of cell + real(DP), intent(in) :: bot !< bottom of cell + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: ss !< specific storage or storage coefficient ! -- local variables real(DP) :: sc1 real(DP) :: thick @@ -162,7 +162,7 @@ pure function SsCapacity(istor_coef, top, bot, area, ss) result(sc1) else thick = DONE end if - sc1 = ss*thick*area + sc1 = ss * thick * area ! ! -- return return @@ -177,12 +177,12 @@ end function SsCapacity !< pure function SyCapacity(area, sy) result(sc2) ! -- dummy variables - real(DP), intent(in) :: area !< horizontal cell area - real(DP), intent(in) :: sy !< specific yield + real(DP), intent(in) :: area !< horizontal cell area + real(DP), intent(in) :: sy !< specific yield ! -- local variables real(DP) :: sc2 ! -- calculate specific yield capacity - sc2 = sy*area + sc2 = sy * area ! ! -- return return diff --git a/src/Model/ModelUtilities/GwtSpc.f90 b/src/Model/ModelUtilities/GwtSpc.f90 index 8c19ca55f60..8a3d4351c5e 100644 --- a/src/Model/ModelUtilities/GwtSpc.f90 +++ b/src/Model/ModelUtilities/GwtSpc.f90 @@ -5,28 +5,29 @@ !! !< module GwtSpcModule - - use KindModule, only: DP, LGP, I4B - use ConstantsModule, only: LENPACKAGENAME, LENMODELNAME, & - LENMEMPATH, DZERO, LENFTYPE, & - LINELENGTH, TABLEFT, TABCENTER - use SimVariablesModule, only: errmsg - use SimModule, only: store_error, count_errors - use MemoryHelperModule, only: create_mem_path - use BlockParserModule, only: BlockParserType - use BaseDisModule, only: DisBaseType - use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr - use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType, tasmanager_cr - use TableModule, only: TableType, table_cr + + use KindModule, only: DP, LGP, I4B + use ConstantsModule, only: LENPACKAGENAME, LENMODELNAME, & + LENMEMPATH, DZERO, LENFTYPE, & + LINELENGTH, TABLEFT, TABCENTER + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, count_errors + use MemoryHelperModule, only: create_mem_path + use BlockParserModule, only: BlockParserType + use BaseDisModule, only: DisBaseType + use TimeSeriesManagerModule, only: TimeSeriesManagerType, tsmanager_cr + use TimeArraySeriesManagerModule, only: TimeArraySeriesManagerType, & + tasmanager_cr + use TableModule, only: TableType, table_cr implicit none private public :: GwtSpcType - character(len=LENFTYPE) :: ftype = 'SPC' - character(len=LENPACKAGENAME) :: text = 'STRESS PACK CONC' + character(len=LENFTYPE) :: ftype = 'SPC' + character(len=LENPACKAGENAME) :: text = 'STRESS PACK CONC' - !> @brief Derived type for managing SPC input + !> @brief Derived type for managing SPC input !! !! This derived type will read and process an SPC input file, !! make time series interpolations, and provide concentrations to @@ -35,26 +36,26 @@ module GwtSpcModule !! !< type :: GwtSpcType - - character(len=LENMODELNAME) :: name_model = '' !< the name of the model that contains this package - character(len=LENPACKAGENAME) :: packName = '' !< name of the package - character(len=LENPACKAGENAME) :: packNameFlow = '' !< name of the corresponding flow package - character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored - integer(I4B), pointer :: id => null() !< id number for this spc package - integer(I4B), pointer :: inunit => null() !< unit number for input - integer(I4B), pointer :: iout => null() !< unit number for output - integer(I4B), pointer :: maxbound => null() !< length of dblvec - integer(I4B), pointer :: ionper => null() !< stress period for next data - integer(I4B), pointer :: lastonper => null() !< last value of ionper (for checking) - integer(I4B), pointer :: iprpak => null() !< flag for printing input - logical(LGP), pointer :: readasarrays => null() !< flag for reading concentrations as an array - real(DP), dimension(:), pointer, contiguous :: dblvec => null() !< vector of floats read from file - class(DisBaseType), pointer :: dis => null() !< model discretization object - type(BlockParserType) :: parser !< parser object for reading blocks of information - type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager - type(TimeArraySeriesManagerType), pointer :: TasManager => null() !< time array series manager - type(TableType), pointer :: inputtab => null() !< input table object - + + character(len=LENMODELNAME) :: name_model = '' !< the name of the model that contains this package + character(len=LENPACKAGENAME) :: packName = '' !< name of the package + character(len=LENPACKAGENAME) :: packNameFlow = '' !< name of the corresponding flow package + character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored + integer(I4B), pointer :: id => null() !< id number for this spc package + integer(I4B), pointer :: inunit => null() !< unit number for input + integer(I4B), pointer :: iout => null() !< unit number for output + integer(I4B), pointer :: maxbound => null() !< length of dblvec + integer(I4B), pointer :: ionper => null() !< stress period for next data + integer(I4B), pointer :: lastonper => null() !< last value of ionper (for checking) + integer(I4B), pointer :: iprpak => null() !< flag for printing input + logical(LGP), pointer :: readasarrays => null() !< flag for reading concentrations as an array + real(DP), dimension(:), pointer, contiguous :: dblvec => null() !< vector of floats read from file + class(DisBaseType), pointer :: dis => null() !< model discretization object + type(BlockParserType) :: parser !< parser object for reading blocks of information + type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager + type(TimeArraySeriesManagerType), pointer :: TasManager => null() !< time array series manager + type(TableType), pointer :: inputtab => null() !< input table object + contains procedure :: initialize @@ -71,11 +72,11 @@ module GwtSpcModule procedure :: spc_da procedure :: read_check_ionper procedure :: check_flow_package - + end type GwtSpcType - - contains - + +contains + !> @ brief Initialize the SPC type !! !! Initialize the SPC object by setting up the parser, @@ -85,17 +86,17 @@ module GwtSpcModule !< subroutine initialize(this, dis, id, inunit, iout, name_model, packNameFlow) ! -- dummy variables - class(GwtSpcType) :: this !< GwtSpcType - class(DisBaseType), pointer, intent(in) :: dis !< discretization package - integer(I4B), intent(in) :: id !< id number for this spc package - integer(I4B), intent(in) :: inunit !< unit number for input - integer(I4B), intent(in) :: iout !< unit number for output - character(len=*), intent(in) :: name_model !< character string containing model name - character(len=*), intent(in) :: packNameflow !< character string containing name of corresponding flow package + class(GwtSpcType) :: this !< GwtSpcType + class(DisBaseType), pointer, intent(in) :: dis !< discretization package + integer(I4B), intent(in) :: id !< id number for this spc package + integer(I4B), intent(in) :: inunit !< unit number for input + integer(I4B), intent(in) :: iout !< unit number for output + character(len=*), intent(in) :: name_model !< character string containing model name + character(len=*), intent(in) :: packNameflow !< character string containing name of corresponding flow package ! -- local ! ! -- construct the memory path - write(this%packName,'(a, i0)') 'SPC' // '-', id + write (this%packName, '(a, i0)') 'SPC'//'-', id this%name_model = name_model this%memoryPath = create_mem_path(this%name_model, this%packName) ! @@ -138,17 +139,17 @@ subroutine initialize(this, dis, id, inunit, iout, name_model, packNameFlow) ! -- return return end subroutine initialize - + !> @ brief Allocate package scalars !! - !! Allocate and initialize package scalars. + !! Allocate and initialize package scalars. !! !< subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy variables - class(GwtSpcType) :: this !< GwtSpcType object + class(GwtSpcType) :: this !< GwtSpcType object ! ! -- allocate scalars in memory manager call mem_allocate(this%id, 'ID', this%memoryPath) @@ -161,8 +162,8 @@ subroutine allocate_scalars(this) call mem_allocate(this%readasarrays, 'READASARRAYS', this%memoryPath) ! ! -- allocate special derived types - allocate(this%TsManager) - allocate(this%TasManager) + allocate (this%TsManager) + allocate (this%TasManager) ! ! -- initialize this%id = 0 @@ -180,7 +181,7 @@ end subroutine allocate_scalars !> @ brief Read options for package !! - !! Read options for this package. + !! Read options for this package. !! !< subroutine read_options(this) @@ -192,15 +193,15 @@ subroutine read_options(this) integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats - character(len=*), parameter :: fmtiprpak = & - "(4x,'SPC INFORMATION WILL BE PRINTED TO LISTING FILE.')" - character(len=*), parameter :: fmtreadasarrays = & + character(len=*), parameter :: fmtiprpak = & + &"(4x,'SPC INFORMATION WILL BE PRINTED TO LISTING FILE.')" + character(len=*), parameter :: fmtreadasarrays = & "(4x,'SPC INFORMATION WILL BE READ AS ARRAYS RATHER THAN IN LIST & &FORMAT.')" character(len=*), parameter :: fmtts = & - "(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" + &"(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)" character(len=*), parameter :: fmttas = & - "(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" + &"(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)" ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & @@ -208,46 +209,46 @@ subroutine read_options(this) ! ! -- parse options block if detected if (isfound) then - write(this%iout,'(1x,a)')'PROCESSING SPC OPTIONS' + write (this%iout, '(1x,a)') 'PROCESSING SPC OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('PRINT_INPUT') - this%iprpak = 1 - write(this%iout, fmtiprpak) - case ('READASARRAYS') - this%readasarrays = .true. - write(this%iout, fmtreadasarrays) - case ('TS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - endif - call this%parser%GetString(fname) - write(this%iout,fmtts)trim(fname) - call this%TsManager%add_tsfile(fname, this%inunit) - case ('TAS6') - call this%parser%GetStringCaps(keyword) - if(trim(adjustl(keyword)) /= 'FILEIN') then - errmsg = 'TAS6 keyword must be followed by "FILEIN" ' // & - 'then by filename.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - endif - call this%parser%GetString(fname) - write(this%iout,fmttas)trim(fname) - call this%TasManager%add_tasfile(fname) - case default - write(errmsg,'(4x,a,a)') 'UNKNOWN SPC OPTION: ', trim(keyword) + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, fmtiprpak) + case ('READASARRAYS') + this%readasarrays = .true. + write (this%iout, fmtreadasarrays) + case ('TS6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' + call store_error(errmsg) + end if + call this%parser%GetString(fname) + write (this%iout, fmtts) trim(fname) + call this%TsManager%add_tsfile(fname, this%inunit) + case ('TAS6') + call this%parser%GetStringCaps(keyword) + if (trim(adjustl(keyword)) /= 'FILEIN') then + errmsg = 'TAS6 keyword must be followed by "FILEIN" '// & + 'then by filename.' call store_error(errmsg) call this%parser%StoreErrorUnit() + end if + call this%parser%GetString(fname) + write (this%iout, fmttas) trim(fname) + call this%TasManager%add_tasfile(fname) + case default + write (errmsg, '(4x,a,a)') 'UNKNOWN SPC OPTION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() end select end do - write(this%iout,'(1x,a)')'END OF SPC OPTIONS' + write (this%iout, '(1x,a)') 'END OF SPC OPTIONS' end if ! ! -- Return @@ -256,12 +257,12 @@ end subroutine read_options !> @ brief Read dimensions for package !! - !! Read dimensions for this package. + !! Read dimensions for this package. !! !< subroutine read_dimensions(this) ! -- dummy variables - class(GwtSpcType), intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object ! -- local variables character(len=LINELENGTH) :: keyword logical(LGP) :: isfound @@ -274,32 +275,32 @@ subroutine read_dimensions(this) ! ! -- parse dimensions block if detected if (isfound) then - write(this%iout,'(/1x,a)')'PROCESSING '//trim(adjustl(text))// & + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(text))// & ' DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit call this%parser%GetStringCaps(keyword) select case (keyword) - case ('MAXBOUND') - this%maxbound = this%parser%GetInteger() - write(this%iout,'(4x,a,i7)') 'MAXBOUND = ', this%maxbound - case default - write(errmsg,'(a,3(1x,a))') & - 'UNKNOWN', trim(text), 'DIMENSION:', trim(keyword) - call store_error(errmsg) + case ('MAXBOUND') + this%maxbound = this%parser%GetInteger() + write (this%iout, '(4x,a,i7)') 'MAXBOUND = ', this%maxbound + case default + write (errmsg, '(a,3(1x,a))') & + 'UNKNOWN', trim(text), 'DIMENSION:', trim(keyword) + call store_error(errmsg) end select end do ! - write(this%iout,'(1x,a)')'END OF '//trim(adjustl(text))//' DIMENSIONS' + write (this%iout, '(1x,a)') 'END OF '//trim(adjustl(text))//' DIMENSIONS' else call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.') call this%parser%StoreErrorUnit() end if ! ! -- verify dimensions were set - if(this%maxbound <= 0) then - write(errmsg, '(a)') 'MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' + if (this%maxbound <= 0) then + write (errmsg, '(a)') 'MAXBOUND MUST BE AN INTEGER GREATER THAN ZERO.' call store_error(errmsg) end if ! @@ -314,14 +315,14 @@ end subroutine read_dimensions !> @ brief Allocate package arrays !! - !! Allocate and initialize package arrays. + !! Allocate and initialize package arrays. !! !< subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy variables - class(GwtSpcType) :: this !< GwtSpcType object + class(GwtSpcType) :: this !< GwtSpcType object ! -- local integer(I4B) :: i ! @@ -336,15 +337,15 @@ subroutine allocate_arrays(this) ! -- return return end subroutine allocate_arrays - + !> @ brief Get the data value from this package !! - !! Get the floating point value from the dblvec array. + !! Get the floating point value from the dblvec array. !! !< function get_value(this, ientry) result(value) - class(GwtSpcType) :: this !< GwtSpcType object - integer(I4B), intent(in) :: ientry !< index of the data to return + class(GwtSpcType) :: this !< GwtSpcType object + integer(I4B), intent(in) :: ientry !< index of the data to return real(DP) :: value value = this%dblvec(ientry) return @@ -353,27 +354,27 @@ end function get_value !> @ brief Read and prepare !! !! Read and prepare the period data block and fill dblvec - !! if the next period block corresponds to this time step. + !! if the next period block corresponds to this time step. !! !< subroutine spc_rp(this) ! -- modules use TdisModule, only: kper, nper ! -- dummy - class(GwtSpcType), intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object ! -- local character(len=LINELENGTH) :: line logical :: isfound integer(I4B) :: ierr ! -- formats - character(len=*),parameter :: fmtblkerr = & - "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - character(len=*),parameter :: fmtlsp = & - "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" + character(len=*), parameter :: fmtblkerr = & + &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" + character(len=*), parameter :: fmtlsp = & + &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')" ! ! -- Set ionper to the stress period number for which a new block of data ! will be read. - if(this%inunit == 0) return + if (this%inunit == 0) return ! ! -- get stress period data if (this%ionper < kper) then @@ -381,7 +382,7 @@ subroutine spc_rp(this) ! -- get period block call this%parser%GetBlock('PERIOD', isfound, ierr, & supportOpenClose=.true.) - if(isfound) then + if (isfound) then ! ! -- read ionper and check for increasing period numbers call this%read_check_ionper() @@ -394,14 +395,14 @@ subroutine spc_rp(this) else ! -- Found invalid block call this%parser%GetCurrentLine(line) - write(errmsg, fmtblkerr) adjustl(trim(line)) + write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg, terminate=.TRUE.) end if end if end if ! ! -- Read data if ionper == kper - if(this%ionper == kper) then + if (this%ionper == kper) then ! ! -- Remove all time-series and time-array-series links associated with ! this package. @@ -414,10 +415,10 @@ subroutine spc_rp(this) else call this%spc_rp_list() end if - ! - ! -- using data from the last stress period + ! + ! -- using data from the last stress period else - write(this%iout,fmtlsp) trim(ftype) + write (this%iout, fmtlsp) trim(ftype) end if ! ! -- write summary of maw well stress period error messages @@ -428,7 +429,7 @@ subroutine spc_rp(this) ! -- return return end subroutine spc_rp - + !> @ brief spc_rp_list !! !! Read the stress period data in list format @@ -438,7 +439,7 @@ subroutine spc_rp_list(this) ! -- modules use TdisModule, only: kper ! -- dummy - class(GwtSpcType), intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object ! -- local character(len=LINELENGTH) :: line character(len=LINELENGTH) :: title @@ -451,16 +452,16 @@ subroutine spc_rp_list(this) if (this%iprpak /= 0) then ! ! -- reset the input table object - title = trim(adjustl(text)) // ' PACKAGE (' // & - 'SPC' //') DATA FOR PERIOD' - write(title, '(a,1x,i6)') trim(adjustl(title)), kper + title = trim(adjustl(text))//' PACKAGE ('// & + 'SPC'//') DATA FOR PERIOD' + write (title, '(a,1x,i6)') trim(adjustl(title)), kper call table_cr(this%inputtab, ftype, title) call this%inputtab%table_df(1, 3, this%iout, finalize=.FALSE.) tabletext = 'NUMBER' call this%inputtab%initialize_column(tabletext, 10, alignment=TABCENTER) tabletext = 'DATA TYPE' call this%inputtab%initialize_column(tabletext, 20, alignment=TABLEFT) - write(tabletext, '(a,1x,i6)') 'VALUE' + write (tabletext, '(a,1x,i6)') 'VALUE' call this%inputtab%initialize_column(tabletext, 15, alignment=TABCENTER) end if ! @@ -471,8 +472,8 @@ subroutine spc_rp_list(this) ival = this%parser%GetInteger() if (ival < 1 .or. ival > this%maxbound) then - write(errmsg,'(2(a,1x),i0,a)') & - 'IVAL must be greater than 0 and', & + write (errmsg, '(2(a,1x),i0,a)') & + 'IVAL must be greater than 0 and', & 'less than or equal to ', this%maxbound, '.' call store_error(errmsg) cycle @@ -496,7 +497,7 @@ subroutine spc_rp_list(this) ! -- return return end subroutine spc_rp_list - + !> @ brief spc_rp_array !! !! Read the stress period data in array format @@ -507,7 +508,7 @@ subroutine spc_rp_array(this, line) use SimModule, only: store_error use ArrayHandlersModule, only: ifind ! -- dummy - class(GwtSpcType), intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object character(len=LINELENGTH), intent(inout) :: line ! -- local integer(I4B) :: n @@ -525,7 +526,7 @@ subroutine spc_rp_array(this, line) real(DP), dimension(:), pointer :: bndArrayPtr => null() ! -- formats ! -- data - data aname(1) /' CONCENTRATION'/ + data aname(1)/' CONCENTRATION'/ ! ! ------------------------------------------------------------------------------ ! @@ -533,7 +534,7 @@ subroutine spc_rp_array(this, line) jauxcol = 0 ivarsread = 0 ncolbnd = 1 - allocate(nodelist(this%maxbound)) + allocate (nodelist(this%maxbound)) do n = 1, size(nodelist) nodelist(n) = n end do @@ -541,7 +542,7 @@ subroutine spc_rp_array(this, line) ! -- Read CONCENTRATION variables as arrays call this%parser%GetNextLine(endOfBlock) if (endOfBlock) then - call store_error('LOOKING FOR CONCENTRATION. FOUND: ' // trim(line)) + call store_error('LOOKING FOR CONCENTRATION. FOUND: '//trim(line)) call this%parser%StoreErrorUnit() end if call this%parser%GetStringCaps(keyword) @@ -560,20 +561,20 @@ subroutine spc_rp_array(this, line) ! Make a time-array-series link and add it to the list of links ! contained in the TimeArraySeriesManagerType object. convertflux = .false. - call this%TasManager%MakeTasLink(this%packName, bndArrayPtr, & - this%iprpak, tasName, 'CONCENTRATION', & - convertFlux, nodelist, & - this%parser%iuactive) + call this%TasManager%MakeTasLink(this%packName, bndArrayPtr, & + this%iprpak, tasName, 'CONCENTRATION', & + convertFlux, nodelist, & + this%parser%iuactive) else ! ! -- Read the concentration array - call this%dis%read_layer_array(nodelist, this%dblvec, & - ncolbnd, this%maxbound, 1, aname(1), this%parser%iuactive, & - this%iout) - endif + call this%dis%read_layer_array(nodelist, this%dblvec, ncolbnd, & + this%maxbound, 1, aname(1), & + this%parser%iuactive, this%iout) + end if ! case default - call store_error('LOOKING FOR CONCENTRATION. FOUND: ' // trim(line)) + call store_error('LOOKING FOR CONCENTRATION. FOUND: '//trim(line)) call this%parser%StoreErrorUnit() end select ! @@ -589,7 +590,7 @@ end subroutine spc_rp_array subroutine spc_ad(this, nbound_flowpack, budtxt) ! -- modules ! -- dummy - class(GwtSpcType),intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object integer(I4B), intent(in) :: nbound_flowpack character(len=*), intent(in) :: budtxt ! -- local @@ -604,17 +605,17 @@ subroutine spc_ad(this, nbound_flowpack, budtxt) ! -- return return end subroutine spc_ad - + !> @ brief Deallocate variables !! - !! Deallocate and nullify package variables. + !! Deallocate and nullify package variables. !! !< subroutine spc_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy variables - class(GwtSpcType) :: this !< GwtSpcType object + class(GwtSpcType) :: this !< GwtSpcType object ! ! -- deallocate arrays in memory manager call mem_deallocate(this%dblvec) @@ -631,8 +632,8 @@ subroutine spc_da(this) ! ! -- deallocate derived types call this%TsManager%da() - deallocate(this%TsManager) - nullify(this%TsManager) + deallocate (this%TsManager) + nullify (this%TsManager) ! ! -- return return @@ -640,8 +641,8 @@ end subroutine spc_da !> @ brief Check ionper !! - !! Generic method to read and check ionperiod, which is used to determine - !! if new period data should be read from the input file. The check of + !! Generic method to read and check ionperiod, which is used to determine + !! if new period data should be read from the input file. The check of !! ionperiod also makes sure periods are increasing in subsequent period !! data blocks. Copied from NumericalPackage !! @@ -650,7 +651,7 @@ subroutine read_check_ionper(this) ! -- modules use TdisModule, only: kper ! -- dummy variables - class(GwtSpcType), intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object ! ! -- save last value and read period number this%lastonper = this%ionper @@ -658,22 +659,22 @@ subroutine read_check_ionper(this) ! ! -- make check if (this%ionper <= this%lastonper) then - write(errmsg, '(a, i0)') & + write (errmsg, '(a, i0)') & 'ERROR IN STRESS PERIOD ', kper call store_error(errmsg) - write(errmsg, '(a, i0)') & + write (errmsg, '(a, i0)') & 'PERIOD NUMBERS NOT INCREASING. FOUND ', this%ionper call store_error(errmsg) - write(errmsg, '(a, i0)') & + write (errmsg, '(a, i0)') & 'BUT LAST PERIOD BLOCK WAS ASSIGNED ', this%lastonper call store_error(errmsg) call this%parser%StoreErrorUnit() - endif + end if ! ! -- return return end subroutine read_check_ionper - + !> @ brief Set the data value from the input file !! !! Set the floating point value in the dblvec array using strings @@ -684,7 +685,7 @@ subroutine set_value(this, ival) ! -- modules use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtSpcType), intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object integer(I4B), intent(in) :: ival ! -- local character(len=LINELENGTH) :: keyword @@ -693,15 +694,15 @@ subroutine set_value(this, ival) ! ! -- read remainder of variables on the line call this%parser%GetStringCaps(keyword) - select case(keyword) - case('CONCENTRATION') + select case (keyword) + case ('CONCENTRATION') call this%parser%GetString(text) - jj = 1 ! For CONCENTRATION + jj = 1 ! For CONCENTRATION bndElem => this%dblvec(ival) - call read_value_or_time_series_adv(text, ival, jj, bndElem, this%packName, & - 'BND', this%tsManager, this%iprpak, & - 'CONCENTRATION') - + call read_value_or_time_series_adv(text, ival, jj, bndElem, this%packName, & + 'BND', this%tsManager, this%iprpak, & + 'CONCENTRATION') + end select return end subroutine set_value @@ -715,14 +716,14 @@ end subroutine set_value subroutine check_flow_package(this, nbound_flowpack, budtxt) ! -- modules ! -- dummy - class(GwtSpcType),intent(inout) :: this !< GwtSpcType object + class(GwtSpcType), intent(inout) :: this !< GwtSpcType object integer(I4B), intent(in) :: nbound_flowpack character(len=*), intent(in) :: budtxt ! -- local ! ! -- Check and make sure MAXBOUND is not less than nbound_flowpack if (this%maxbound < nbound_flowpack) then - write(errmsg, '(a, a, a, i0, a, i0, a)') & + write (errmsg, '(a, a, a, i0, a, i0, a)') & 'The SPC Package corresponding to flow package ', & trim(this%packNameFlow), & ' has MAXBOUND set less than the number of boundaries & @@ -737,19 +738,19 @@ subroutine check_flow_package(this, nbound_flowpack, budtxt) ! ! -- If budtxt is RCHA or EVTA, then readasarrays must be used, otherwise ! readasarrays cannot be used - select case(trim(adjustl(budtxt))) - case('RCHA') + select case (trim(adjustl(budtxt))) + case ('RCHA') if (.not. this%readasarrays) then - write(errmsg, '(a, a, a)') & + write (errmsg, '(a, a, a)') & 'Array-based recharge must be used with array-based stress package & &concentrations. GWF Package ', trim(this%packNameFlow), ' is being & &used with list-based SPC6 input. Use array-based SPC6 input instead.' call store_error(errmsg) call this%parser%StoreErrorUnit() end if - case('EVTA') + case ('EVTA') if (.not. this%readasarrays) then - write(errmsg, '(a, a, a)') & + write (errmsg, '(a, a, a)') & 'Array-based evapotranspiration must be used with array-based stress & &package concentrations. GWF Package ', trim(this%packNameFlow), & &' is being used with list-based SPC6 input. Use array-based SPC6 & @@ -759,7 +760,7 @@ subroutine check_flow_package(this, nbound_flowpack, budtxt) end if case default if (this%readasarrays) then - write(errmsg, '(a, a, a)') & + write (errmsg, '(a, a, a)') & 'List-based packages must be used with list-based stress & &package concentrations. GWF Package ', trim(this%packNameFlow), & &' is being used with array-based SPC6 input. Use list-based SPC6 & @@ -772,6 +773,5 @@ subroutine check_flow_package(this, nbound_flowpack, budtxt) ! -- return return end subroutine check_flow_package - - -end module GwtSpcModule \ No newline at end of file + +end module GwtSpcModule diff --git a/src/Model/ModelUtilities/Mover.f90 b/src/Model/ModelUtilities/Mover.f90 index 9e5c5b8555d..0ff698fde01 100644 --- a/src/Model/ModelUtilities/Mover.f90 +++ b/src/Model/ModelUtilities/Mover.f90 @@ -5,40 +5,40 @@ !! !< module MvrModule - + use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LINELENGTH, LENBUDTXT, & + use ConstantsModule, only: LENMODELNAME, LINELENGTH, LENBUDTXT, & LENAUXNAME, LENBOUNDNAME, DZERO, DONE, & LENMEMPATH use SimVariablesModule, only: errmsg use PackageMoverModule, only: PackageMoverType - + implicit none private public :: MvrType - character(len=12), dimension(4) :: mvrtypes = & - [character(len=12) :: 'FACTOR', 'EXCESS', 'THRESHOLD', 'UPTO'] - - !> @brief Derived type for MvrType + character(len=12), dimension(4) :: mvrtypes = & + &[character(len=12) :: 'FACTOR', 'EXCESS', 'THRESHOLD', 'UPTO'] + + !> @brief Derived type for MvrType !! !! This derived type contains information and methods for !! moving water between packages. !! !< type MvrType - character(len=LENMEMPATH) :: pckNameSrc = '' !< provider package name - character(len=LENMEMPATH) :: pckNameTgt = '' !< receiver package name - integer(I4B), pointer :: iRchNrSrc => null() !< provider reach number - integer(I4B), pointer :: iRchNrTgt => null() !< receiver reach number - integer(I4B), pointer :: imvrtype => null() !< mover type (1, 2, 3, 4) corresponds to mvrtypes - real(DP), pointer :: value => null() !< factor or rate depending on mvrtype - real(DP) :: qpactual = DZERO !< rate provided to the receiver - real(DP) :: qavailable = DZERO !< rate available at time of providing - real(DP), pointer :: qtformvr_ptr => null() !< pointer to total available flow (qtformvr) - real(DP), pointer :: qformvr_ptr => null() !< pointer to available flow after consumed (qformvr) - real(DP), pointer :: qtomvr_ptr => null() !< pointer to provider flow rate (qtomvr) - real(DP), pointer :: qfrommvr_ptr => null() !< pointer to receiver flow rate (qfrommvr) + character(len=LENMEMPATH) :: pckNameSrc = '' !< provider package name + character(len=LENMEMPATH) :: pckNameTgt = '' !< receiver package name + integer(I4B), pointer :: iRchNrSrc => null() !< provider reach number + integer(I4B), pointer :: iRchNrTgt => null() !< receiver reach number + integer(I4B), pointer :: imvrtype => null() !< mover type (1, 2, 3, 4) corresponds to mvrtypes + real(DP), pointer :: value => null() !< factor or rate depending on mvrtype + real(DP) :: qpactual = DZERO !< rate provided to the receiver + real(DP) :: qavailable = DZERO !< rate available at time of providing + real(DP), pointer :: qtformvr_ptr => null() !< pointer to total available flow (qtformvr) + real(DP), pointer :: qformvr_ptr => null() !< pointer to available flow after consumed (qformvr) + real(DP), pointer :: qtomvr_ptr => null() !< pointer to provider flow rate (qtomvr) + real(DP), pointer :: qfrommvr_ptr => null() !< pointer to receiver flow rate (qfrommvr) contains procedure :: set_values procedure :: prepare @@ -48,9 +48,9 @@ module MvrModule procedure :: qrcalc procedure :: writeflow end type MvrType - - contains - + +contains + !> @ brief Set values from input data !! !! Set values and pointers for mover object. @@ -68,33 +68,33 @@ subroutine set_values(this, mname1, pname1, id1, mname2, pname2, & integer(I4B), intent(in), target :: id2 integer(I4B), intent(in), target :: imvrtype real(DP), intent(in), target :: value - + this%pckNameSrc = create_mem_path(mname1, pname1) this%iRchNrSrc => id1 this%pckNameTgt = create_mem_path(mname2, pname2) this%iRchNrTgt => id2 this%imvrtype => imvrtype this%value => value - + return end subroutine set_values - + !> @ brief Prepare object !! !! Set values and pointers for mover object. - !! pckMemPaths is an array of strings which are the memory paths for those - !! packages. They are composed of model names and package names. The mover + !! pckMemPaths is an array of strings which are the memory paths for those + !! packages. They are composed of model names and package names. The mover !! entries must be in pckMemPaths, or this routine will terminate with an error. !< subroutine prepare(this, inunit, pckMemPaths, pakmovers) ! -- modules - use SimModule, only: store_error, store_error_unit, count_errors + use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(MvrType) :: this !< MvrType objec - integer(I4B), intent(in) :: inunit !< input file unit number - character(len=LENMEMPATH), & - dimension(:), pointer, contiguous :: pckMemPaths !< array of strings - type(PackageMoverType), dimension(:), pointer, contiguous :: pakmovers !< Array of package mover objects + class(MvrType) :: this !< MvrType objec + integer(I4B), intent(in) :: inunit !< input file unit number + character(len=LENMEMPATH), & + dimension(:), pointer, contiguous :: pckMemPaths !< array of strings + type(PackageMoverType), dimension(:), pointer, contiguous :: pakmovers !< Array of package mover objects ! -- local real(DP), dimension(:), pointer, contiguous :: temp_ptr => null() logical :: found @@ -102,11 +102,12 @@ subroutine prepare(this, inunit, pckMemPaths, pakmovers) integer(I4B) :: ipakloc1, ipakloc2 ! ! -- Check to make sure provider and receiver are not the same - if(this%pckNameSrc == this%pckNameTgt .and. this%iRchNrSrc == this%iRchNrTgt) then - call store_error('PROVIDER AND RECEIVER ARE THE SAME: '// & - trim(this%pckNameSrc) // ' : ' // trim(this%pckNameTgt)) + if (this%pckNameSrc == this%pckNameTgt .and. & + this%iRchNrSrc == this%iRchNrTgt) then + call store_error('PROVIDER AND RECEIVER ARE THE SAME: '// & + trim(this%pckNameSrc)//' : '//trim(this%pckNameTgt)) call store_error_unit(inunit) - endif + end if ! ! -- Check to make sure pname1 and pname2 are both listed in pckMemPaths ! pname1 is the provider package; pname2 is the receiver package @@ -117,7 +118,7 @@ subroutine prepare(this, inunit, pckMemPaths, pakmovers) found = .true. ipakloc1 = i exit - endif + end if end do if (.not. found) then call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//this%pckNameSrc) @@ -130,7 +131,7 @@ subroutine prepare(this, inunit, pckMemPaths, pakmovers) found = .true. ipakloc2 = i exit - endif + end if end do if (.not. found) then call store_error('MOVER CAPABILITY NOT ACTIVATED IN '//this%pckNameTgt) @@ -142,13 +143,13 @@ subroutine prepare(this, inunit, pckMemPaths, pakmovers) ! ! -- Set pointer to QTOMVR array in the provider boundary package temp_ptr => pakmovers(ipakloc1)%qtomvr - if(this%iRchNrSrc < 1 .or. this%iRchNrSrc > size(temp_ptr)) then + if (this%iRchNrSrc < 1 .or. this%iRchNrSrc > size(temp_ptr)) then call store_error('PROVIDER ID < 1 OR GREATER THAN PACKAGE SIZE ') - write(errmsg, '(4x,a,i0,a,i0)') 'PROVIDER ID = ', this%iRchNrSrc, & + write (errmsg, '(4x,a,i0,a,i0)') 'PROVIDER ID = ', this%iRchNrSrc, & '; PACKAGE SIZE = ', size(temp_ptr) call store_error(trim(errmsg)) call store_error_unit(inunit) - endif + end if this%qtomvr_ptr => temp_ptr(this%iRchNrSrc) ! ! -- Set pointer to QFORMVR array in the provider boundary package @@ -161,19 +162,19 @@ subroutine prepare(this, inunit, pckMemPaths, pakmovers) ! ! -- Set pointer to QFROMMVR array in the receiver boundary package temp_ptr => pakmovers(ipakloc2)%qfrommvr - if(this%iRchNrTgt < 1 .or. this%iRchNrTgt > size(temp_ptr)) then + if (this%iRchNrTgt < 1 .or. this%iRchNrTgt > size(temp_ptr)) then call store_error('RECEIVER ID < 1 OR GREATER THAN PACKAGE SIZE ') - write(errmsg, '(4x,a,i0,a,i0)') 'RECEIVER ID = ', this%iRchNrTgt, & + write (errmsg, '(4x,a,i0,a,i0)') 'RECEIVER ID = ', this%iRchNrTgt, & '; PACKAGE SIZE = ', size(temp_ptr) call store_error(trim(errmsg)) call store_error_unit(inunit) - endif + end if this%qfrommvr_ptr => temp_ptr(this%iRchNrTgt) ! ! -- return return end subroutine prepare - + !> @ brief Echo data to list file !! !! Write mover values to output file. @@ -182,21 +183,21 @@ end subroutine prepare subroutine echo(this, iout) ! -- modules ! -- dummy - class(MvrType) :: this !< MvrType - integer(I4B), intent(in) :: iout !< unit number for output file + class(MvrType) :: this !< MvrType + integer(I4B), intent(in) :: iout !< unit number for output file ! -- local ! - write(iout, '(4x, a, a, a, i0)') 'FROM PACKAGE: ', trim(this%pckNameSrc), & + write (iout, '(4x, a, a, a, i0)') 'FROM PACKAGE: ', trim(this%pckNameSrc), & ' FROM ID: ', this%iRchNrSrc - write(iout, '(4x, a, a, a, i0)') 'TO PACKAGE: ', trim(this%pckNameTgt), & + write (iout, '(4x, a, a, a, i0)') 'TO PACKAGE: ', trim(this%pckNameTgt), & ' TO ID: ', this%iRchNrTgt - write(iout, '(4x, a, a, a, 1pg15.6,/)') 'MOVER TYPE: ', & + write (iout, '(4x, a, a, a, 1pg15.6,/)') 'MOVER TYPE: ', & trim(mvrtypes(this%imvrtype)), ' ', this%value ! ! -- return return end subroutine echo - + !> @ brief Advance !! !! Advance mover object. Does nothing now. @@ -211,7 +212,7 @@ subroutine advance(this) ! -- return return end subroutine advance - + !> @ brief Formulate coefficients !! !! Make mover calculations. @@ -220,7 +221,7 @@ end subroutine advance subroutine fc(this) ! -- modules ! -- dummy - class(MvrType) :: this !< MvrType + class(MvrType) :: this !< MvrType ! -- local real(DP) :: qavailable, qtanew, qpactual ! @@ -237,10 +238,10 @@ subroutine fc(this) this%qpactual = qpactual ! ! -- Add the calculated qpactual term directly into the receiver package - ! qfrommvr array. + ! qfrommvr array. this%qfrommvr_ptr = this%qfrommvr_ptr + qpactual ! - ! -- Add the calculated qpactual term directly into the provider package + ! -- Add the calculated qpactual term directly into the provider package ! qtomvr array. this%qtomvr_ptr = this%qtomvr_ptr + qpactual ! @@ -262,8 +263,8 @@ function qrcalc(this, qa, qta) result(qr) ! -- return real(DP) :: qr ! -- dummy - class(MvrType) :: this !< MvrType - real(DP), intent(in) :: qa !< actual flow + class(MvrType) :: this !< MvrType + real(DP), intent(in) :: qa !< actual flow real(DP), intent(in) :: qta !< total available flow ! -- local ! -- Using the mover rules, calculate how much of the available water will @@ -271,32 +272,32 @@ function qrcalc(this, qa, qta) result(qr) qr = DZERO ! -- Calculate qr select case (this%imvrtype) - case(1) - ! -- FACTOR uses total available to make calculation, and then - ! limits qr by consumed available - if(qta > DZERO) qr = qta * this%value - qr = min(qr, qa) - case(2) - ! -- EXCESS - if(qa > this%value) then - qr = qa - this%value - else - qr = DZERO - endif - case(3) - ! -- THRESHOLD - if(this%value > qa) then - qr = DZERO - else - qr = this%value - endif - case(4) - ! -- UPTO - if(qa > this%value) then - qr = this%value - else - qr = qa - endif + case (1) + ! -- FACTOR uses total available to make calculation, and then + ! limits qr by consumed available + if (qta > DZERO) qr = qta * this%value + qr = min(qr, qa) + case (2) + ! -- EXCESS + if (qa > this%value) then + qr = qa - this%value + else + qr = DZERO + end if + case (3) + ! -- THRESHOLD + if (this%value > qa) then + qr = DZERO + else + qr = this%value + end if + case (4) + ! -- UPTO + if (qa > this%value) then + qr = this%value + else + qr = qa + end if end select ! ! -- return @@ -311,19 +312,19 @@ end function qrcalc subroutine writeflow(this, iout) ! -- modules ! -- dummy - class(MvrType) :: this !< MvrType - integer(I4B), intent(in) :: iout !< output file unit number + class(MvrType) :: this !< MvrType + integer(I4B), intent(in) :: iout !< output file unit number ! -- local character(len=*), parameter :: fmt = & - "(1x, a, ' ID ', i0, ' AVAILABLE ', 1(1pg15.6), " // & - "' PROVIDED ', 1(1pg15.6), ' TO ', a, ' ID ', i0)" + "(1x, a, ' ID ', i0, ' AVAILABLE ', 1(1pg15.6), & + &' PROVIDED ', 1(1pg15.6), ' TO ', a, ' ID ', i0)" ! - write(iout, fmt) trim(this%pckNameSrc), this%iRchNrSrc, this%qavailable, & + write (iout, fmt) trim(this%pckNameSrc), this%iRchNrSrc, this%qavailable, & this%qpactual, trim(this%pckNameTgt), this%iRchNrTgt ! ! -- return return end subroutine writeflow - + end module MvrModule - + diff --git a/src/Model/ModelUtilities/PackageMover.f90 b/src/Model/ModelUtilities/PackageMover.f90 index 5180a36d1be..b0c43187838 100644 --- a/src/Model/ModelUtilities/PackageMover.f90 +++ b/src/Model/ModelUtilities/PackageMover.f90 @@ -1,8 +1,8 @@ module PackageMoverModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: LENMEMPATH, DZERO - use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & + + use KindModule, only: DP, I4B + use ConstantsModule, only: LENMEMPATH, DZERO + use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & mem_deallocate implicit none @@ -10,17 +10,17 @@ module PackageMoverModule public :: PackageMoverType public :: set_packagemover_pointer public :: nulllify_packagemover_pointer - + type PackageMoverType - - character(len=LENMEMPATH) :: memoryPath !< the location in the memory manager where the variables are stored - integer(I4B), pointer :: nproviders - integer(I4B), pointer :: nreceivers - integer(I4B), dimension(:), pointer, contiguous :: iprmap => null() !< map between id1 and feature (needed for lake to map from outlet to lake number) - real(DP), dimension(:), pointer, contiguous :: qtformvr => null() - real(DP), dimension(:), pointer, contiguous :: qformvr => null() - real(DP), dimension(:), pointer, contiguous :: qtomvr => null() - real(DP), dimension(:), pointer, contiguous :: qfrommvr => null() + + character(len=LENMEMPATH) :: memoryPath !< the location in the memory manager where the variables are stored + integer(I4B), pointer :: nproviders + integer(I4B), pointer :: nreceivers + integer(I4B), dimension(:), pointer, contiguous :: iprmap => null() !< map between id1 and feature (needed for lake to map from outlet to lake number) + real(DP), dimension(:), pointer, contiguous :: qtformvr => null() + real(DP), dimension(:), pointer, contiguous :: qformvr => null() + real(DP), dimension(:), pointer, contiguous :: qtomvr => null() + real(DP), dimension(:), pointer, contiguous :: qfrommvr => null() contains procedure :: ar @@ -33,17 +33,19 @@ module PackageMoverModule procedure :: get_qfrommvr procedure :: get_qtomvr procedure :: accumulate_qformvr - + end type PackageMoverType - - contains - + +contains + subroutine set_packagemover_pointer(packagemover, memPath) type(PackageMoverType), intent(inout) :: packagemover character(len=*), intent(in) :: memPath packagemover%memoryPath = memPath - call mem_setptr(packagemover%nproviders, 'NPROVIDERS', packagemover%memoryPath) - call mem_setptr(packagemover%nreceivers, 'NRECEIVERS', packagemover%memoryPath) + call mem_setptr(packagemover%nproviders, 'NPROVIDERS', & + packagemover%memoryPath) + call mem_setptr(packagemover%nreceivers, 'NRECEIVERS', & + packagemover%memoryPath) call mem_setptr(packagemover%iprmap, 'IPRMAP', packagemover%memoryPath) call mem_setptr(packagemover%qtformvr, 'QTFORMVR', packagemover%memoryPath) call mem_setptr(packagemover%qformvr, 'QFORMVR', packagemover%memoryPath) @@ -78,8 +80,8 @@ subroutine ar(this, nproviders, nreceivers, memoryPath) ! ! -- return return - end subroutine ar - + end subroutine ar + subroutine ad(this) class(PackageMoverType) :: this integer :: i @@ -88,12 +90,12 @@ subroutine ad(this) do i = 1, this%nproviders this%qtomvr(i) = DZERO this%qformvr(i) = DZERO - enddo + end do ! ! -- return return end subroutine ad - + subroutine cf(this) class(PackageMoverType) :: this integer :: i @@ -101,16 +103,16 @@ subroutine cf(this) ! -- set frommvr and qtomvr to zero do i = 1, this%nreceivers this%qfrommvr(i) = DZERO - enddo + end do do i = 1, this%nproviders this%qtomvr(i) = DZERO this%qtformvr(i) = this%qformvr(i) - enddo + end do ! ! -- return return end subroutine cf - + subroutine fc(this) class(PackageMoverType) :: this integer :: i @@ -118,12 +120,12 @@ subroutine fc(this) ! -- set formvr to zero do i = 1, this%nproviders this%qformvr(i) = DZERO - enddo + end do ! ! -- return return end subroutine fc - + subroutine da(this) class(PackageMoverType) :: this ! @@ -139,12 +141,12 @@ subroutine da(this) call mem_deallocate(this%nreceivers) ! ! -- pointers - nullify(this%iprmap) + nullify (this%iprmap) ! ! -- return return end subroutine da - + subroutine allocate_scalars(this) class(PackageMoverType) :: this ! @@ -156,8 +158,8 @@ subroutine allocate_scalars(this) ! ! -- return return - end subroutine allocate_scalars - + end subroutine allocate_scalars + subroutine allocate_arrays(this) class(PackageMoverType) :: this integer(I4B) :: i @@ -174,22 +176,22 @@ subroutine allocate_arrays(this) this%qtformvr(i) = DZERO this%qformvr(i) = DZERO this%qtomvr(i) = DZERO - enddo + end do do i = 1, this%nreceivers this%qfrommvr(i) = DZERO - enddo + end do ! ! -- return return end subroutine allocate_arrays - + function get_qfrommvr(this, ireceiver) result(qfrommvr) class(PackageMoverType) :: this real(DP) :: qfrommvr integer, intent(in) :: ireceiver qfrommvr = this%qfrommvr(ireceiver) end function get_qfrommvr - + function get_qtomvr(this, iprovider) result(qtomvr) class(PackageMoverType) :: this real(DP) :: qtomvr @@ -204,4 +206,4 @@ subroutine accumulate_qformvr(this, iprovider, qformvr) this%qformvr(iprovider) = this%qformvr(iprovider) + qformvr end subroutine accumulate_qformvr -end module PackageMoverModule \ No newline at end of file +end module PackageMoverModule diff --git a/src/Model/ModelUtilities/SfrCrossSectionManager.f90 b/src/Model/ModelUtilities/SfrCrossSectionManager.f90 index 0f2afdf73c3..87fdfc940a0 100644 --- a/src/Model/ModelUtilities/SfrCrossSectionManager.f90 +++ b/src/Model/ModelUtilities/SfrCrossSectionManager.f90 @@ -2,13 +2,13 @@ module sfrCrossSectionManager use KindModule, only: DP, I4B, LGP use ConstantsModule, only: DZERO, DONE, & - LINELENGTH + LINELENGTH use SimVariablesModule, only: errmsg, warnmsg use TableModule, only: TableType, table_cr implicit none - + public :: SfrCrossSection public :: cross_section_cr @@ -27,12 +27,12 @@ module sfrCrossSectionManager integer(I4B), pointer :: invalid => null() character(len=LINELENGTH), dimension(:), allocatable :: filenames integer(I4B), pointer, dimension(:), contiguous :: npoints => null() - type(SfrCrossSectionType), pointer, dimension(:), contiguous :: cross_sections => null() + type(SfrCrossSectionType), & + pointer, dimension(:), contiguous :: cross_sections => null() type(TableType), pointer :: inputtab => null() - - contains - + contains + ! ! -- public procedures procedure, public :: initialize @@ -46,8 +46,8 @@ module sfrCrossSectionManager procedure, private :: validate end type SfrCrossSection - - contains + +contains !> @brief Create a cross-section object !! @@ -56,20 +56,20 @@ module sfrCrossSectionManager !< subroutine cross_section_cr(this, iout, iprpak, nreaches) ! -- dummy variables - type(SfrCrossSection), pointer :: this !< SfrCrossSection object - integer(I4B), pointer, intent(in) :: iout !< model listing file - integer(I4B), pointer, intent(in) :: iprpak !< flag for printing table input data - integer(I4B), pointer, intent(in) :: nreaches !< number of reaches + type(SfrCrossSection), pointer :: this !< SfrCrossSection object + integer(I4B), pointer, intent(in) :: iout !< model listing file + integer(I4B), pointer, intent(in) :: iprpak !< flag for printing table input data + integer(I4B), pointer, intent(in) :: nreaches !< number of reaches ! ! -- check if table already associated and reset if necessary if (associated(this)) then call this%destroy() - deallocate(this) - nullify(this) + deallocate (this) + nullify (this) end if ! ! -- Create the object - allocate(this) + allocate (this) ! ! -- initialize scalars this%iout => iout @@ -82,20 +82,20 @@ end subroutine cross_section_cr !> @brief Initialize a cross-section object !! - !! Subroutine to inititialize the cross-section object with the current + !! Subroutine to inititialize the cross-section object with the current !! data. !! !< subroutine initialize(this, ncrossptstot, ncrosspts, iacross, & station, height, roughfraction) ! -- dummy variables - class(SfrCrossSection) :: this !< SfrCrossSection object - integer(I4B), intent(in) :: ncrossptstot !< total number of cross-section points - integer(I4B), dimension(this%nreaches), intent(in) :: ncrosspts !< pointers to cross-section data in data vector - integer(I4B), dimension(this%nreaches+1), intent(in) :: iacross !< pointers to cross-section data in data vector - real(DP), dimension(ncrossptstot), intent(in) :: station !< cross-section station data - real(DP), dimension(ncrossptstot), intent(in) :: height !< cross-section height data - real(DP), dimension(ncrossptstot), intent(in) :: roughfraction !< cross-section roughness fraction data + class(SfrCrossSection) :: this !< SfrCrossSection object + integer(I4B), intent(in) :: ncrossptstot !< total number of cross-section points + integer(I4B), dimension(this%nreaches), intent(in) :: ncrosspts !< pointers to cross-section data in data vector + integer(I4B), dimension(this%nreaches + 1), intent(in) :: iacross !< pointers to cross-section data in data vector + real(DP), dimension(ncrossptstot), intent(in) :: station !< cross-section station data + real(DP), dimension(ncrossptstot), intent(in) :: height !< cross-section height data + real(DP), dimension(ncrossptstot), intent(in) :: roughfraction !< cross-section roughness fraction data ! -- local variables integer(I4B) :: i integer(I4B) :: n @@ -105,22 +105,22 @@ subroutine initialize(this, ncrossptstot, ncrosspts, iacross, & integer(I4B) :: ipos ! ! -- allocate scalars - allocate(this%invalid) + allocate (this%invalid) ! ! -- initialize scalars this%invalid = 0 ! ! -- create cross-section container - allocate(this%filenames(this%nreaches)) - allocate(this%npoints(this%nreaches)) - allocate(this%cross_sections(this%nreaches)) + allocate (this%filenames(this%nreaches)) + allocate (this%npoints(this%nreaches)) + allocate (this%cross_sections(this%nreaches)) do n = 1, this%nreaches npoints = ncrosspts(n) - allocate(this%cross_sections(n)%npoints) - allocate(this%cross_sections(n)%station(npoints)) - allocate(this%cross_sections(n)%height(npoints)) - allocate(this%cross_sections(n)%roughfraction(npoints)) - allocate(this%cross_sections(n)%valid(npoints)) + allocate (this%cross_sections(n)%npoints) + allocate (this%cross_sections(n)%station(npoints)) + allocate (this%cross_sections(n)%height(npoints)) + allocate (this%cross_sections(n)%roughfraction(npoints)) + allocate (this%cross_sections(n)%valid(npoints)) end do ! ! -- fill cross-section container with current values @@ -155,10 +155,10 @@ subroutine read_table(this, irch, width, filename) use SimModule, only: store_error use BlockParserModule, only: BlockParserType ! -- dummy variables - class(SfrCrossSection) :: this !< SfrCrossSection object - integer(I4B), intent(in) :: irch !< current reach - real(DP), intent(in) :: width !< reach width - character(len=*), intent(in) :: filename !< table file with station height data + class(SfrCrossSection) :: this !< SfrCrossSection object + integer(I4B), intent(in) :: irch !< current reach + real(DP), intent(in) :: width !< reach width + character(len=*), intent(in) :: filename !< table file with station height data ! -- local variables character(len=LINELENGTH) :: tag character(len=LINELENGTH) :: keyword @@ -178,8 +178,8 @@ subroutine read_table(this, irch, width, filename) jmin = 2 ! ! -- create a tag with the file name and reach number - write(tag, "('Reach',1x,i0,1x,'(',a, ')')") & - irch, trim(adjustl(filename)) + write (tag, "('Reach',1x,i0,1x,'(',a, ')')") & + irch, trim(adjustl(filename)) ! ! -- open the table file iu = IUOC @@ -194,36 +194,37 @@ subroutine read_table(this, irch, width, filename) ! ! -- process the table dimension data if (this%iprpak /= 0) then - write(this%iout,'(/1x,a)') & - 'PROCESSING ' // trim(adjustl(tag)) // ' DIMENSIONS' + write (this%iout, '(/1x,a)') & + 'PROCESSING '//trim(adjustl(tag))//' DIMENSIONS' end if readdims: do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit call parser%GetStringCaps(keyword) select case (keyword) - case ('NROW') - n = parser%GetInteger() - if (n < 1) then - write(errmsg,'(a)') 'TABLE NROW MUST BE > 0' - call store_error(errmsg) - end if - case ('NCOL') - j = parser%GetInteger() - jmin = 2 - if (j < jmin) then - write(errmsg,'(a,1x,i0)') 'TABLE NCOL MUST BE >= ', jmin - call store_error(errmsg) - end if - case default - write(errmsg,'(a,a)') & - 'UNKNOWN '//trim(adjustl(tag))//' DIMENSIONS KEYWORD: ', trim(keyword) + case ('NROW') + n = parser%GetInteger() + if (n < 1) then + write (errmsg, '(a)') 'TABLE NROW MUST BE > 0' + call store_error(errmsg) + end if + case ('NCOL') + j = parser%GetInteger() + jmin = 2 + if (j < jmin) then + write (errmsg, '(a,1x,i0)') 'TABLE NCOL MUST BE >= ', jmin call store_error(errmsg) + end if + case default + write (errmsg, '(a,a)') & + 'UNKNOWN '//trim(adjustl(tag))//' DIMENSIONS KEYWORD: ', & + trim(keyword) + call store_error(errmsg) end select end do readdims if (this%iprpak /= 0) then - write(this%iout,'(1x,a)') & - 'END OF ' // trim(adjustl(tag)) // ' DIMENSIONS' + write (this%iout, '(1x,a)') & + 'END OF '//trim(adjustl(tag))//' DIMENSIONS' end if else call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.') @@ -231,12 +232,12 @@ subroutine read_table(this, irch, width, filename) ! ! -- check that ncol and nrow have been specified if (n < 1) then - write(errmsg,'(a)') & + write (errmsg, '(a)') & 'NROW NOT SPECIFIED IN THE TABLE DIMENSIONS BLOCK' call store_error(errmsg) end if if (j < 1) then - write(errmsg,'(a)') & + write (errmsg, '(a)') & 'NCOL NOT SPECIFIED IN THE TABLE DIMENSIONS BLOCK' call store_error(errmsg) end if @@ -247,21 +248,21 @@ subroutine read_table(this, irch, width, filename) ! ! -- set the filename and reset the number of points this%filenames(irch) = filename - this%npoints(irch) = n + this%npoints(irch) = n ! ! -- deallocate - deallocate(this%cross_sections(irch)%npoints) - deallocate(this%cross_sections(irch)%station) - deallocate(this%cross_sections(irch)%height) - deallocate(this%cross_sections(irch)%roughfraction) - deallocate(this%cross_sections(irch)%valid) + deallocate (this%cross_sections(irch)%npoints) + deallocate (this%cross_sections(irch)%station) + deallocate (this%cross_sections(irch)%height) + deallocate (this%cross_sections(irch)%roughfraction) + deallocate (this%cross_sections(irch)%valid) ! ! -- reallocate - allocate(this%cross_sections(irch)%npoints) - allocate(this%cross_sections(irch)%station(n)) - allocate(this%cross_sections(irch)%height(n)) - allocate(this%cross_sections(irch)%roughfraction(n)) - allocate(this%cross_sections(irch)%valid(n)) + allocate (this%cross_sections(irch)%npoints) + allocate (this%cross_sections(irch)%station(n)) + allocate (this%cross_sections(irch)%height(n)) + allocate (this%cross_sections(irch)%roughfraction(n)) + allocate (this%cross_sections(irch)%valid(n)) ! ! -- initialize this%cross_sections(irch)%npoints = n @@ -274,7 +275,7 @@ subroutine read_table(this, irch, width, filename) ! -- process the table data if (this%iprpak /= 0) then - write(this%iout,'(/1x,a)') & + write (this%iout, '(/1x,a)') & 'PROCESSING '//trim(adjustl(tag))//' TABLE' end if ipos = 0 @@ -294,9 +295,9 @@ subroutine read_table(this, irch, width, filename) end if this%cross_sections(irch)%valid(ipos) = .TRUE. end do readtabledata - + if (this%iprpak /= 0) then - write(this%iout,'(1x,a)') & + write (this%iout, '(1x,a)') & 'END OF '//trim(adjustl(tag))//' TABLE' end if else @@ -305,15 +306,15 @@ subroutine read_table(this, irch, width, filename) ! ! -- error condition if number of rows read are not equal to nrow if (ipos /= this%npoints(irch)) then - write(errmsg,'(a,1x,i0,1x,a,1x,i0,1x,a)') & + write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & 'NROW SET TO', this%npoints(irch), 'BUT', ipos, 'ROWS WERE READ' call store_error(errmsg) - end if + end if end if ! ! -- close the open table file if (iu > 0) then - close(iu) + close (iu) end if ! ! -- validate the table @@ -322,7 +323,7 @@ subroutine read_table(this, irch, width, filename) ! -- return return end subroutine read_table - + !> @brief Validate cross-section tables !! !! Subroutine to validate a cross-section table. @@ -335,14 +336,14 @@ subroutine validate(this, irch) use GwfSfrCrossSectionUtilsModule, only: get_cross_section_area, & get_hydraulic_radius ! -- dummy variables - class(SfrCrossSection) :: this !< SfrCrossSection object - integer(I4B), intent(in) :: irch !< current reach + class(SfrCrossSection) :: this !< SfrCrossSection object + integer(I4B), intent(in) :: irch !< current reach ! -- local variables logical(LGP) :: station_error logical(LGP) :: height_error logical(LGP) :: height_zero_error logical(LGP) :: roughness_error - character(len=LINELENGTH) :: filename + character(len=LINELENGTH) :: filename integer(I4B) :: npts integer(I4B) :: n integer(I4B) :: i @@ -392,25 +393,25 @@ subroutine validate(this, irch) height_zero_error .or. roughness_error) then filename = this%filenames(irch) if (station_error) then - write(errmsg, '(3a,1x,i0,1x,a)') & + write (errmsg, '(3a,1x,i0,1x,a)') & "All xfraction data in '", trim(adjustl(filename)), & "' for reach", irch, 'must be greater than or equal to zero.' call store_error(errmsg) end if if (height_error) then - write(errmsg, '(3a,1x,i0,1x,a)') & + write (errmsg, '(3a,1x,i0,1x,a)') & "All height data in '", trim(adjustl(filename)), & "' for reach", irch, 'must be greater than or equal to zero.' call store_error(errmsg) end if if (height_zero_error) then - write(errmsg, '(3a,1x,i0,1x,a)') & + write (errmsg, '(3a,1x,i0,1x,a)') & "At least one height data value in '", trim(adjustl(filename)), & "' for reach", irch, 'must be equal to zero.' call store_error(errmsg) end if if (roughness_error) then - write(errmsg, '(3a,1x,i0,1x,a)') & + write (errmsg, '(3a,1x,i0,1x,a)') & "All manfraction data in '", trim(adjustl(filename)), & "' for reach", irch, 'must be greater than zero.' call store_error(errmsg) @@ -418,7 +419,7 @@ subroutine validate(this, irch) end if ! ! -- initialize and fill heights - allocate(heights(npts)) + allocate (heights(npts)) do n = 1, npts heights(n) = this%cross_sections(irch)%height(n) end do @@ -426,7 +427,7 @@ subroutine validate(this, irch) ! -- get unique heights call unique_values(heights, unique_heights) ! - ! -- calculate the product of the area and the hydraulic radius to + ! -- calculate the product of the area and the hydraulic radius to ! the 2/3 power do n = 1, size(unique_heights) if (unique_heights(n) <= DZERO) cycle @@ -458,8 +459,8 @@ subroutine validate(this, irch) end do ! ! -- deallocate local storage - deallocate(heights) - deallocate(unique_heights) + deallocate (heights) + deallocate (unique_heights) ! ! -- return return @@ -475,15 +476,15 @@ subroutine output(this, widths, roughs, kstp, kper) use ConstantsModule, only: TABLEFT use SimModule, only: store_warning ! -- dummy variables - class(SfrCrossSection) :: this !< SfrCrossSection object - real(DP), dimension(this%nreaches), intent(in) :: widths !< reach widths - real(DP), dimension(this%nreaches), intent(in) :: roughs !< reach Manning's roughness coefficients - integer(I4B), intent(in), optional :: kstp !< time step - integer(I4B), intent(in), optional :: kper !< stress period + class(SfrCrossSection) :: this !< SfrCrossSection object + real(DP), dimension(this%nreaches), intent(in) :: widths !< reach widths + real(DP), dimension(this%nreaches), intent(in) :: roughs !< reach Manning's roughness coefficients + integer(I4B), intent(in), optional :: kstp !< time step + integer(I4B), intent(in), optional :: kper !< stress period ! -- local variables character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text - character(len=LINELENGTH) :: filename + character(len=LINELENGTH) :: filename character(len=10) :: cvalid logical(LGP) :: transient integer(I4B) :: kkstp @@ -551,7 +552,7 @@ subroutine output(this, widths, roughs, kstp, kper) end if ! ! -- reset the input table object - write(title, '(a,1x,i0,1x,3a)') & + write (title, '(a,1x,i0,1x,3a)') & 'CROSS_SECTION DATA FOR REACH', irch, "FROM TAB6 FILE ('", & trim(adjustl(filename)), "')" call table_cr(this%inputtab, trim(adjustl(filename)), title) @@ -587,7 +588,8 @@ subroutine output(this, widths, roughs, kstp, kper) call this%inputtab%add_term(xfraction) call this%inputtab%add_term(this%cross_sections(irch)%station(n)) call this%inputtab%add_term(this%cross_sections(irch)%height(n)) - call this%inputtab%add_term(this%cross_sections(irch)%roughfraction(n)) + call this%inputtab%add_term(& + &this%cross_sections(irch)%roughfraction(n)) call this%inputtab%add_term(r) if (reach_fail(irch) > 0) then if (this%cross_sections(irch)%valid(n)) then @@ -596,7 +598,7 @@ subroutine output(this, widths, roughs, kstp, kper) cvalid = 'TRUE' end if call this%inputtab%add_term(cvalid) - end if + end if end do ! ! -- finalize the table @@ -613,10 +615,10 @@ subroutine output(this, widths, roughs, kstp, kper) ninvalid_reaches = ninvalid_reaches + 1 end if end do - write(warnmsg, '(a,1x,i0,7(1x,a))') & + write (warnmsg, '(a,1x,i0,7(1x,a))') & 'Cross-section data for', ninvalid_reaches, & 'reaches include one or more points that result in a', & - 'non-unique depth-conveyance relation. This occurs when', & + 'non-unique depth-conveyance relation. This occurs when', & 'there are horizontal sections at non-zero heights', & '(for example, flat overbank sections). This can usually', & 'be resolved by adding a small slope to these flat', & @@ -651,7 +653,7 @@ function get_ncrossptstot(this) result(nptstot) ! -- return return end function get_ncrossptstot - + !> @brief Pack the cross-section object !! !! Subroutine to pack the cross-section object into vectors. @@ -660,13 +662,13 @@ end function get_ncrossptstot subroutine pack(this, ncrossptstot, ncrosspts, iacross, & station, height, roughfraction) ! -- dummy variables - class(SfrCrossSection) :: this !< SfrCrossSection object - integer(I4B), intent(in) :: ncrossptstot !< total number of cross-section points - integer(I4B), dimension(this%nreaches), intent(inout) :: ncrosspts !< pointers to cross-section data in data vector - integer(I4B), dimension(this%nreaches+1), intent(inout) :: iacross !< pointers to cross-section data in data vector - real(DP), dimension(ncrossptstot), intent(inout) :: station !< cross-section station data - real(DP), dimension(ncrossptstot), intent(inout) :: height !< cross-section height data - real(DP), dimension(ncrossptstot), intent(inout) :: roughfraction !< cross-section roughness fraction data + class(SfrCrossSection) :: this !< SfrCrossSection object + integer(I4B), intent(in) :: ncrossptstot !< total number of cross-section points + integer(I4B), dimension(this%nreaches), intent(inout) :: ncrosspts !< pointers to cross-section data in data vector + integer(I4B), dimension(this%nreaches + 1), intent(inout) :: iacross !< pointers to cross-section data in data vector + real(DP), dimension(ncrossptstot), intent(inout) :: station !< cross-section station data + real(DP), dimension(ncrossptstot), intent(inout) :: height !< cross-section height data + real(DP), dimension(ncrossptstot), intent(inout) :: roughfraction !< cross-section roughness fraction data ! -- local variables integer(I4B) :: i integer(I4B) :: n @@ -685,7 +687,7 @@ subroutine pack(this, ncrossptstot, ncrosspts, iacross, & roughfraction(ipos) = this%cross_sections(n)%roughfraction(i) ipos = ipos + 1 end do - iacross(n+1) = ipos + iacross(n + 1) = ipos end do ! ! -- return @@ -699,48 +701,46 @@ end subroutine pack !< subroutine destroy(this) ! -- dummy variables - class(SfrCrossSection) :: this !< SfrCrossSection object + class(SfrCrossSection) :: this !< SfrCrossSection object ! -- local variables integer(I4B) :: n ! ! -- deallocate and nullify pointers - deallocate(this%npoints) - nullify(this%npoints) + deallocate (this%npoints) + nullify (this%npoints) do n = 1, this%nreaches - deallocate(this%cross_sections(n)%npoints) - nullify(this%cross_sections(n)%npoints) - deallocate(this%cross_sections(n)%station) - nullify(this%cross_sections(n)%station) - deallocate(this%cross_sections(n)%height) - nullify(this%cross_sections(n)%height) - deallocate(this%cross_sections(n)%roughfraction) - nullify(this%cross_sections(n)%roughfraction) - deallocate(this%cross_sections(n)%valid) - nullify(this%cross_sections(n)%valid) + deallocate (this%cross_sections(n)%npoints) + nullify (this%cross_sections(n)%npoints) + deallocate (this%cross_sections(n)%station) + nullify (this%cross_sections(n)%station) + deallocate (this%cross_sections(n)%height) + nullify (this%cross_sections(n)%height) + deallocate (this%cross_sections(n)%roughfraction) + nullify (this%cross_sections(n)%roughfraction) + deallocate (this%cross_sections(n)%valid) + nullify (this%cross_sections(n)%valid) end do - deallocate(this%cross_sections) - nullify(this%cross_sections) + deallocate (this%cross_sections) + nullify (this%cross_sections) ! ! -- input table if (associated(this%inputtab)) then call this%inputtab%table_da() - deallocate(this%inputtab) - nullify(this%inputtab) + deallocate (this%inputtab) + nullify (this%inputtab) end if ! ! -- deallocate and nullify class scalars - deallocate(this%invalid) - nullify(this%invalid) + deallocate (this%invalid) + nullify (this%invalid) ! ! -- nullify scalars that are pointers to external variables - nullify(this%iout) - nullify(this%iprpak) - nullify(this%nreaches) + nullify (this%iout) + nullify (this%iprpak) + nullify (this%nreaches) ! ! -- return return end subroutine destroy - - -end module sfrCrossSectionManager \ No newline at end of file +end module sfrCrossSectionManager diff --git a/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 b/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 index 1f04f2e13a5..d4bd43250ca 100644 --- a/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 +++ b/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 @@ -2,9 +2,9 @@ !! !! This module contains the functions to calculate the wetted perimeter !! and cross-sectional area for a reach cross-section that are used in -!! the streamflow routing (SFR) package. It also contains subroutines to +!! the streamflow routing (SFR) package. It also contains subroutines to !! calculate the wetted perimeter and cross-sectional area for each -!! line segment in the cross-section. This module does not depend on the +!! line segment in the cross-section. This module does not depend on the !! SFR package. !! !< @@ -33,8 +33,8 @@ module GwfSfrCrossSectionUtilsModule !< function get_saturated_topwidth(npts, stations) result(w) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) ! -- local variables real(DP) :: w ! @@ -58,14 +58,14 @@ end function get_saturated_topwidth !< function get_wetted_topwidth(npts, stations, heights, d) result(w) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section ! -- local variables integer(I4B) :: n real(DP) :: w - real(DP), dimension(npts-1) :: widths + real(DP), dimension(npts - 1) :: widths ! ! -- intitialize the wetted perimeter for the reach w = DZERO @@ -81,7 +81,7 @@ function get_wetted_topwidth(npts, stations, heights, d) result(w) ! -- return return end function get_wetted_topwidth - + !> @brief Calculate the wetted perimeter for a reach !! !! Function to calculate the wetted perimeter for a reach using the @@ -91,14 +91,14 @@ end function get_wetted_topwidth !< function get_wetted_perimeter(npts, stations, heights, d) result(p) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section ! -- local variables integer(I4B) :: n real(DP) :: p - real(DP), dimension(npts-1) :: perimeters + real(DP), dimension(npts - 1) :: perimeters ! ! -- intitialize the wetted perimeter for the reach p = DZERO @@ -117,21 +117,21 @@ end function get_wetted_perimeter !> @brief Calculate the cross-sectional area for a reach !! - !! Function to calculate the cross-sectional area for a reach using + !! Function to calculate the cross-sectional area for a reach using !! the cross-section station-height data given a passed depth. !! !! @return a cross-sectional area !< function get_cross_section_area(npts, stations, heights, d) result(a) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section ! -- local variables integer(I4B) :: n real(DP) :: a - real(DP), dimension(npts-1) :: areas + real(DP), dimension(npts - 1) :: areas ! ! -- intitialize the area a = DZERO @@ -150,24 +150,24 @@ end function get_cross_section_area !> @brief Calculate the hydraulic radius for a reach !! - !! Function to calculate the hydraulic radius for a reach using + !! Function to calculate the hydraulic radius for a reach using !! the cross-section station-height data given a passed depth. !! !! @return r hydraulic radius !< function get_hydraulic_radius(npts, stations, heights, d) result(r) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section ! -- local variables integer(I4B) :: n real(DP) :: r real(DP) :: p real(DP) :: a - real(DP), dimension(npts-1) :: areas - real(DP), dimension(npts-1) :: perimeters + real(DP), dimension(npts - 1) :: areas + real(DP), dimension(npts - 1) :: perimeters ! ! -- intitialize the hydraulic radius, perimeter, and area r = DZERO @@ -212,14 +212,14 @@ end function get_hydraulic_radius function get_mannings_section(npts, stations, heights, roughfracs, & roughness, conv_fact, slope, d) result(q) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), dimension(npts), intent(in) :: roughfracs !< cross-section Mannings roughness fraction data - real(DP), intent(in) :: roughness !< base reach roughness - real(DP), intent(in) :: conv_fact !< unit conversion factor - real(DP), intent(in) :: slope !< reach slope - real(DP), intent(in) :: d !< depth to evaluate cross-section + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), dimension(npts), intent(in) :: roughfracs !< cross-section Mannings roughness fraction data + real(DP), intent(in) :: roughness !< base reach roughness + real(DP), intent(in) :: conv_fact !< unit conversion factor + real(DP), intent(in) :: slope !< reach slope + real(DP), intent(in) :: d !< depth to evaluate cross-section ! -- local variables integer(I4B) :: n real(DP) :: q @@ -227,8 +227,8 @@ function get_mannings_section(npts, stations, heights, roughfracs, & real(DP) :: r real(DP) :: p real(DP) :: a - real(DP), dimension(npts-1) :: areas - real(DP), dimension(npts-1) :: perimeters + real(DP), dimension(npts - 1) :: areas + real(DP), dimension(npts - 1) :: perimeters ! ! -- intitialize the hydraulic radius, perimeter, and area q = DZERO @@ -272,17 +272,17 @@ end function get_mannings_section !> @brief Calculate the wetted perimeters for each line segment !! !! Subroutine to calculate the wetted perimeter for each line segment - !! that defines the reach using the cross-section station-height + !! that defines the reach using the cross-section station-height !! data given a passed depth. !! !< subroutine get_wetted_perimeters(npts, stations, heights, d, p) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section - real(DP), dimension(npts-1), intent(inout) :: p !< wetted perimeter for each line segment + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section + real(DP), dimension(npts - 1), intent(inout) :: p !< wetted perimeter for each line segment ! -- local variables integer(I4B) :: n real(DP) :: x0 @@ -302,9 +302,9 @@ subroutine get_wetted_perimeters(npts, stations, heights, d, p) ! ! -- initialize station-height data for segment x0 = stations(n) - x1 = stations(n+1) + x1 = stations(n + 1) d0 = heights(n) - d1 = heights(n+1) + d1 = heights(n + 1) ! ! -- get the start and end station position of the wetted segment call get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) @@ -335,17 +335,17 @@ end subroutine get_wetted_perimeters !> @brief Calculate the cross-sectional areas for each line segment !! !! Subroutine to calculate the cross-sectional area for each line segment - !! that defines the reach using the cross-section station-height + !! that defines the reach using the cross-section station-height !! data given a passed depth. !! !< subroutine get_cross_section_areas(npts, stations, heights, d, a) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section - real(DP), dimension(npts-1), intent(inout) :: a !< cross-sectional area for each line segment + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section + real(DP), dimension(npts - 1), intent(inout) :: a !< cross-sectional area for each line segment ! -- local variables integer(I4B) :: n real(DP) :: x0 @@ -364,9 +364,9 @@ subroutine get_cross_section_areas(npts, stations, heights, d, a) ! ! -- initialize station-height data for segment x0 = stations(n) - x1 = stations(n+1) + x1 = stations(n + 1) d0 = heights(n) - d1 = heights(n+1) + d1 = heights(n + 1) ! ! -- get the start and end station position of the wetted segment call get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) @@ -381,7 +381,7 @@ subroutine get_cross_section_areas(npts, stations, heights, d, a) end if ! ! -- add the area below dmax - if (dmax /= dmin .and. d > dmin) then + if (dmax /= dmin .and. d > dmin) then a(n) = a(n) + DHALF * (d - dmin) end if end if @@ -394,17 +394,17 @@ end subroutine get_cross_section_areas !> @brief Calculate the wetted top widths for each line segment !! !! Subroutine to calculate the wetted top width for each line segment - !! that defines the reach using the cross-section station-height + !! that defines the reach using the cross-section station-height !! data given a passed depth. !! !< subroutine get_wetted_topwidths(npts, stations, heights, d, w) ! -- dummy variables - integer(I4B), intent(in) :: npts !< number of station-height data for a reach - real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) - real(DP), dimension(npts), intent(in) :: heights !< cross-section height data - real(DP), intent(in) :: d !< depth to evaluate cross-section - real(DP), dimension(npts-1), intent(inout) :: w !< wetted top widths for each line segment + integer(I4B), intent(in) :: npts !< number of station-height data for a reach + real(DP), dimension(npts), intent(in) :: stations !< cross-section station distances (x-distance) + real(DP), dimension(npts), intent(in) :: heights !< cross-section height data + real(DP), intent(in) :: d !< depth to evaluate cross-section + real(DP), dimension(npts - 1), intent(inout) :: w !< wetted top widths for each line segment ! -- local variables integer(I4B) :: n real(DP) :: x0 @@ -419,9 +419,9 @@ subroutine get_wetted_topwidths(npts, stations, heights, d, w) ! ! -- initialize station-height data for segment x0 = stations(n) - x1 = stations(n+1) + x1 = stations(n + 1) d0 = heights(n) - d1 = heights(n+1) + d1 = heights(n + 1) ! ! -- get the start and end station position of the wetted segment call get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) @@ -434,27 +434,26 @@ subroutine get_wetted_topwidths(npts, stations, heights, d, w) return end subroutine get_wetted_topwidths - - !> @brief Calculate the station values for the wetted portion of the cross-section + !> @brief Calculate the station values for the wetted portion of the cross-section !! - !! Subroutine to calculate the station values that define the extent of the - !! wetted portion of the cross section for a line segment. The left (x0) and - !! right (x1) station positions are altered if the passed depth is less - !! than the maximum line segment depth. If the line segment is dry the left - !! and right station are equal. Otherwise the wetted station values are equal + !! Subroutine to calculate the station values that define the extent of the + !! wetted portion of the cross section for a line segment. The left (x0) and + !! right (x1) station positions are altered if the passed depth is less + !! than the maximum line segment depth. If the line segment is dry the left + !! and right station are equal. Otherwise the wetted station values are equal !! to the full line segment or smaller if the passed depth is less than - !! the maximum line segment depth. + !! the maximum line segment depth. !! !< pure subroutine get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) ! -- dummy variables - real(DP), intent(inout) :: x0 !< left station position - real(DP), intent(inout) :: x1 !< right station position - real(DP), intent(in) :: d0 !< depth at the left station - real(DP), intent(in) :: d1 !< depth at the right station - real(DP), intent(inout) :: dmax !< maximum depth - real(DP), intent(inout) :: dmin !< minimum depth - real(DP), intent(in) :: d !< depth to evaluate cross-section + real(DP), intent(inout) :: x0 !< left station position + real(DP), intent(inout) :: x1 !< right station position + real(DP), intent(in) :: d0 !< depth at the left station + real(DP), intent(in) :: d1 !< depth at the right station + real(DP), intent(inout) :: dmax !< maximum depth + real(DP), intent(inout) :: dmin !< minimum depth + real(DP), intent(in) :: d !< depth to evaluate cross-section ! -- local variables real(DP) :: xlen real(DP) :: dlen @@ -468,12 +467,12 @@ pure subroutine get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) dmin = min(d0, d1) dmax = max(d0, d1) ! - ! -- if d is less than or equal to the minimum value the + ! -- if d is less than or equal to the minimum value the ! station length (xlen) is zero if (d <= dmin) then x1 = x0 - ! -- if d is between dmin and dmax station length is less - ! than d1 - d0 + ! -- if d is between dmin and dmax station length is less + ! than d1 - d0 else if (d < dmax) then xlen = x1 - x0 dlen = d1 - d0 @@ -483,12 +482,12 @@ pure subroutine get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) slope = DZERO end if if (d0 > d1) then - dx = (d - d1) * slope + dx = (d - d1) * slope xt = x1 + dx xt0 = xt xt1 = x1 else - dx = (d - d0) * slope + dx = (d - d0) * slope xt = x0 + dx xt0 = x0 xt1 = xt @@ -501,5 +500,4 @@ pure subroutine get_wetted_station(x0, x1, d0, d1, dmax, dmin, d) return end subroutine get_wetted_station - -end module GwfSfrCrossSectionUtilsModule \ No newline at end of file +end module GwfSfrCrossSectionUtilsModule diff --git a/src/Model/ModelUtilities/GwtAdvOptions.f90 b/src/Model/ModelUtilities/TspAdvOptions.f90 similarity index 53% rename from src/Model/ModelUtilities/GwtAdvOptions.f90 rename to src/Model/ModelUtilities/TspAdvOptions.f90 index b4e612fd500..f10a4fb10e3 100644 --- a/src/Model/ModelUtilities/GwtAdvOptions.f90 +++ b/src/Model/ModelUtilities/TspAdvOptions.f90 @@ -1,10 +1,10 @@ -module GwtAdvOptionsModule +module TspAdvOptionsModule use KindModule, only: I4B implicit none private - type, public :: GwtAdvOptionsType + type, public :: TspAdvOptionsType integer(I4B) :: iAdvScheme !< the advection scheme: 0 = up, 1 = central, 2 = TVD - end type GwtAdvOptionsType + end type TspAdvOptionsType -end module GwtAdvOptionsModule \ No newline at end of file +end module TspAdvOptionsModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/GwtDspGridData.f90 b/src/Model/ModelUtilities/TspDspGridData.f90 similarity index 63% rename from src/Model/ModelUtilities/GwtDspGridData.f90 rename to src/Model/ModelUtilities/TspDspGridData.f90 index 8b463dbb7d9..9c9c9eec13d 100644 --- a/src/Model/ModelUtilities/GwtDspGridData.f90 +++ b/src/Model/ModelUtilities/TspDspGridData.f90 @@ -1,28 +1,32 @@ -module GwtDspGridDataModule +module TspDspGridDataModule use KindModule, only: DP, I4B implicit none private !> @brief data structure and helpers for passing dsp grid data !< into the package, as opposed to reading from file -type, public :: GwtDspGridDataType +type, public :: TspDspGridDataType real(DP), dimension(:), pointer, contiguous :: diffc => null() !< molecular diffusion coefficient for each cell real(DP), dimension(:), pointer, contiguous :: alh => null() !< longitudinal horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: alv => null() !< longitudinal vertical dispersivity real(DP), dimension(:), pointer, contiguous :: ath1 => null() !< transverse horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: ath2 => null() !< transverse horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: atv => null() !< transverse vertical dispersivity + real(DP), dimension(:), pointer, contiguous :: ktw => null() !< thermal conductivity of water + real(DP), dimension(:), pointer, contiguous :: kts => null() !< thermal conductivity of solids + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< heat capacity of water from mst + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< density of water from mst contains procedure, pass(this) :: construct procedure, pass(this) :: destroy -end type GwtDspGridDataType +end type TspDspGridDataType contains !> @brief allocate data structure !< subroutine construct(this, nodes) - class(GwtDspGridDataType) :: this + class(TspDspGridDataType) :: this integer(I4B) :: nodes allocate(this%diffc(nodes)) @@ -31,13 +35,17 @@ subroutine construct(this, nodes) allocate(this%ath1(nodes)) allocate(this%ath2(nodes)) allocate(this%atv(nodes)) + allocate(this%ktw(nodes)) + allocate(this%kts(nodes)) + allocate(this%cpw(nodes)) + allocate(this%rhow(nodes)) end subroutine construct !> @brief clean up !< subroutine destroy(this) - class(GwtDspGridDataType) :: this + class(TspDspGridDataType) :: this deallocate(this%diffc) deallocate(this%alh) @@ -45,7 +53,11 @@ subroutine destroy(this) deallocate(this%ath1) deallocate(this%ath2) deallocate(this%atv) - + deallocate(this%ktw) + deallocate(this%kts) + deallocate(this%cpw) + deallocate(this%rhow) + end subroutine destroy -end module GwtDspGridDataModule \ No newline at end of file +end module TspDspGridDataModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/GwtDspOptions.f90 b/src/Model/ModelUtilities/TspDspOptions.f90 similarity index 68% rename from src/Model/ModelUtilities/GwtDspOptions.f90 rename to src/Model/ModelUtilities/TspDspOptions.f90 index 164beff134f..4c3d6829ad3 100644 --- a/src/Model/ModelUtilities/GwtDspOptions.f90 +++ b/src/Model/ModelUtilities/TspDspOptions.f90 @@ -1,12 +1,12 @@ -module GwtDspOptionsModule +module TspDspOptionsModule use KindModule, only: I4B implicit none private !> @brief data structure (and helpers) for passing dsp option data !< into the package, as opposed to reading it from file - type, public :: GwtDspOptionsType + type, public :: TspDspOptionsType integer(I4B) :: ixt3d !< flag indicating xt3d is active: 1 = enabled, 2 = rhs - end type GwtDspOptionsType + end type TspDspOptionsType -end module GwtDspOptionsModule \ No newline at end of file +end module TspDspOptionsModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/TspLabels.f90 b/src/Model/ModelUtilities/TspLabels.f90 new file mode 100644 index 00000000000..64b9826887b --- /dev/null +++ b/src/Model/ModelUtilities/TspLabels.f90 @@ -0,0 +1,182 @@ +!> @brief This module contains the TspLabels Module +!! +!! A generic module containing the labels used by +!! the generalized TransportModel module that assigns +!! labeling based on which type of transport model an +!! instance of this module is associated with (GWT or +!! GWE) +!! +!! Labels that need to be transport model type specific: +!! +!! GWT | GWE | src files w/label +!! -----------------|-------------------|-------------- +!! "Concentration" |"Temperature" | gwt1.f90 +!! | | gwt1apt1.f90 +!! | | gwt1cnc1.f90 +!! | | gwt1ist1.f90 +!! | | gwt1lkt1.f90 +!! | | gwt1mst1.f90 +!! | | gwt1obs1.f90 +!! | | gwt1oc1.f90 +!! | | gwt1sft1.f90 (?) +!! | | gwt1ssm1.f90 +!! | | gwt1fmi1.f90 +!! | | tsp1ic1.f90 +!! | | GwtSpc.f90 +!! "Concentration" |"Temperature" | Gwe.f90 +!! "Cumulative Mass"|"Cumulative Energy"| Budget.f90 (_ot routine) +!! "MASS", "M" |"?", "?" | gwt1.f90 (gwt_df routine & _ot routine) +!! "M/T" |"Watts" (?) | +!! "M" |"Joules" or "E" | +!< +module TspLabelsModule + + use KindModule, only: DP, LGP, I4B + use ConstantsModule, only: LENVARNAME + + implicit none + private + public :: TspLabelsType + public :: tsplabels_cr + + !> @brief Define labels for use with generalized transport model + !! + !! Subroutine to store which type of units are in use since a + !! generalized transport model is the base clase for either a + !! solute transport (GWT) or heat transport (GWE) + !! + !< + type TspLabelsType + character(len=LENVARNAME), pointer :: modname => null() !< name of the model that module is associated with + character(len=LENVARNAME), pointer :: tsptype => null() !< "solute" or "heat" + character(len=LENVARNAME), pointer :: depvartype => null() !< "concentration" or "temperature" + character(len=LENVARNAME), pointer :: depvarunit => null() !< "mass" or "joules" + character(len=LENVARNAME), pointer :: depvarunitabbrev => null() !< "M/T" or "watts" (or "kilowatts") + + contains + procedure :: tsplabels_df + ! -- private + procedure :: allocate_label_names + + end type TspLabelsType + + contains + + !> @brief Create a new transport labels object + !! + !! Create a new labels object + !! + !< + subroutine tsplabels_cr(this, name_model) + ! -- modules + ! -- dummy variables + type(TspLabelsType), pointer :: this !< TspLabelsType object + character(len=*), intent(in) :: name_model !< name of the model + ! ------------------------------------------------------------------- + ! + ! -- Create the object + allocate(this) + ! -- local variables + ! + ! -- Allocate variable names + call this%allocate_label_names(name_model) + ! + ! -- Return + return + end subroutine tsplabels_cr + + !> @brief Define the labels corresponding to the flavor of + !! transport model + !! + !! Set variable names according to type of transport model + !! + !< + subroutine tsplabels_df(this, tsptype, depvartype, depvarunit, depvarunitabbrev) + class(TspLabelsType) :: this + character(len=*), optional :: tsptype !< type of model, default is GWT6 + character(len=*), optional :: depvartype !< dependent variable type, default is "CONCENTRATION" + character(len=*), optional :: depvarunit !< units of dependent variable for writing to list file + character(len=*), optional :: depvarunitabbrev !< abbreviation of associated units + ! + ! -- Set the model type + if(present(tsptype)) then + this%tsptype = tsptype + else + this%tsptype = 'GWT6' + endif + ! + ! -- Set the type of dependent variable being solved for + if(present(tsptype)) then + this%depvartype = depvartype + else + this%depvartype = 'CONCENTRATION' + endif + ! + ! -- Set the units associated with the dependent variable + if(present(depvarunit)) then + this%depvarunit = depvarunit + else + this%depvarunit = 'MASS' + endif + ! + ! -- Set the units abbreviation + if(present(depvarunitabbrev)) then + this%depvarunitabbrev = depvarunitabbrev + else + this%depvarunitabbrev = 'M/T' + endif + ! + ! -- Return + return + end subroutine tsplabels_df + + !> @brief Define the information this object holds + !! + !! Allocate strings for storing label names + !! Intended to be analogous to allocate_scalars() + !! + !< + subroutine allocate_label_names(this, name_model) + ! -- modules + ! -- dummy + class(TspLabelsType) :: this !< TspLabelsType object + character(len=*), intent(in) :: name_model !< name of the model + ! + allocate(this%modname) + allocate(this%tsptype) + allocate(this%depvartype) + allocate(this%depvarunit) + allocate(this%depvarunitabbrev) + ! + ! -- Initialize values + this%tsptype = '' + this%depvartype = '' + this%depvarunit = '' + this%depvarunitabbrev = '' + ! + ! -- Initialize model name that labels module is associated with + this%modname = name_model + ! + return + end subroutine allocate_label_names + + !> @ breif Deallocate memory + !! + !! Deallocate budget memory + !! + !< + subroutine tsplabels_da(this) + class(TspLabelsType) :: this !< TspLabelsType object + ! + ! -- Strings + deallocate(this%modname) + deallocate(this%tsptype) + deallocate(this%depvartype) + deallocate(this%depvarunit) + deallocate(this%depvarunitabbrev) + ! + ! -- Return + return + end subroutine tsplabels_da + +end module TspLabelsModule \ No newline at end of file diff --git a/src/Model/ModelUtilities/UzfCellGroup.f90 b/src/Model/ModelUtilities/UzfCellGroup.f90 index 34fd6aaea50..9ee7e236f2a 100644 --- a/src/Model/ModelUtilities/UzfCellGroup.f90 +++ b/src/Model/ModelUtilities/UzfCellGroup.f90 @@ -1,8 +1,8 @@ module UzfCellGroupModule - + use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DEM30, DEM20, DEM15, DEM14, DEM12, DEM10, & - DEM9, DEM7, DEM6, DEM5, DEM4, DEM3, DHALF, DONE, & + use ConstantsModule, only: DZERO, DEM30, DEM20, DEM15, DEM14, DEM12, DEM10, & + DEM9, DEM7, DEM6, DEM5, DEM4, DEM3, DHALF, DONE, & DTWO, DTHREE, DEP20 use SmoothingModule use TdisModule, only: ITMUNI, delt, kper @@ -10,7 +10,7 @@ module UzfCellGroupModule implicit none private public :: UzfCellGroupType - + type :: UzfCellGroupType integer(I4B) :: imem_manager real(DP), pointer, dimension(:), contiguous :: thtr => null() @@ -54,43 +54,43 @@ module UzfCellGroupModule integer(I4B), pointer, dimension(:), contiguous :: landflag => null() integer(I4B), pointer, dimension(:), contiguous :: ivertcon => null() contains - procedure :: init - procedure :: setdata - procedure :: sethead - procedure :: setdatauzfarea - procedure :: setdatafinf - procedure :: setdataet - procedure :: setdataetwc - procedure :: setdataetha - procedure :: setwaves - procedure :: wave_shift - procedure :: routewaves - procedure :: uzflow - procedure :: addrech - procedure :: trailwav - procedure :: leadwav - procedure :: advance - procedure :: solve - procedure :: unsat_stor - procedure :: update_wav - procedure :: simgwet - procedure :: caph - procedure :: rate_et_z - procedure :: uzet - procedure :: uz_rise - procedure :: rejfinf - procedure :: gwseep - procedure :: setbelowpet - procedure :: setgwpet - procedure :: dealloc - procedure :: get_water_content_at_depth - procedure :: get_wcnew - end type UzfCellGroupType -! - contains + procedure :: init + procedure :: setdata + procedure :: sethead + procedure :: setdatauzfarea + procedure :: setdatafinf + procedure :: setdataet + procedure :: setdataetwc + procedure :: setdataetha + procedure :: setwaves + procedure :: wave_shift + procedure :: routewaves + procedure :: uzflow + procedure :: addrech + procedure :: trailwav + procedure :: leadwav + procedure :: advance + procedure :: solve + procedure :: unsat_stor + procedure :: update_wav + procedure :: simgwet + procedure :: caph + procedure :: rate_et_z + procedure :: uzet + procedure :: uz_rise + procedure :: rejfinf + procedure :: gwseep + procedure :: setbelowpet + procedure :: setgwpet + procedure :: dealloc + procedure :: get_water_content_at_depth + procedure :: get_wcnew + end type UzfCellGroupType +! +contains ! ! ------------------------------------------------------------------------------ - + subroutine init(this, ncells, nwav, memory_path) ! ****************************************************************************** ! init -- allocate and set uzf object variables @@ -98,15 +98,15 @@ subroutine init(this, ncells, nwav, memory_path) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_allocate - ! -- dummy - class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: nwav - integer(I4B), intent(in) :: ncells - character(len=*), intent(in), optional :: memory_path - ! -- local - integer(I4B) :: icell + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(UzfCellGroupType) :: this + integer(I4B), intent(in) :: nwav + integer(I4B), intent(in) :: ncells + character(len=*), intent(in), optional :: memory_path + ! -- local + integer(I4B) :: icell ! ------------------------------------------------------------------------------ ! ! -- Use mem_allocate if memory path is passed in, otherwise it's a temp object @@ -150,50 +150,50 @@ subroutine init(this, ncells, nwav, memory_path) call mem_allocate(this%petmax, ncells, 'PETMAX', memory_path) call mem_allocate(this%extdp, ncells, 'EXTDP', memory_path) call mem_allocate(this%extdpuz, ncells, 'EXTDPUZ', memory_path) - call mem_allocate(this%landflag, ncells, 'LANDFLAG', memory_path) + call mem_allocate(this%landflag, ncells, 'LANDFLAG', memory_path) call mem_allocate(this%ivertcon, ncells, 'IVERTCON', memory_path) else this%imem_manager = 0 - allocate(this%uzdpst(nwav, ncells)) - allocate(this%uzthst(nwav, ncells)) - allocate(this%uzflst(nwav, ncells)) - allocate(this%uzspst(nwav, ncells)) - allocate(this%nwavst(ncells)) - allocate(this%thtr(ncells)) - allocate(this%thts(ncells)) - allocate(this%thti(ncells)) - allocate(this%eps(ncells)) - allocate(this%ha(ncells)) - allocate(this%hroot(ncells)) - allocate(this%rootact(ncells)) - allocate(this%extwc(ncells)) - allocate(this%etact(ncells)) - allocate(this%nwav(ncells)) - allocate(this%ntrail(ncells)) - allocate(this%totflux(ncells)) - allocate(this%sinf(ncells)) - allocate(this%finf(ncells)) - allocate(this%finf_rej(ncells)) - allocate(this%gwet(ncells)) - allocate(this%uzfarea(ncells)) - allocate(this%cellarea(ncells)) - allocate(this%celtop(ncells)) - allocate(this%celbot(ncells)) - allocate(this%landtop(ncells)) - allocate(this%watab(ncells)) - allocate(this%watabold(ncells)) - allocate(this%surfdep(ncells)) - allocate(this%vks(ncells)) - allocate(this%surflux(ncells)) - allocate(this%surfluxbelow(ncells)) - allocate(this%surfseep(ncells)) - allocate(this%gwpet(ncells)) - allocate(this%pet(ncells)) - allocate(this%petmax(ncells)) - allocate(this%extdp(ncells)) - allocate(this%extdpuz(ncells)) - allocate(this%landflag(ncells)) - allocate(this%ivertcon(ncells)) + allocate (this%uzdpst(nwav, ncells)) + allocate (this%uzthst(nwav, ncells)) + allocate (this%uzflst(nwav, ncells)) + allocate (this%uzspst(nwav, ncells)) + allocate (this%nwavst(ncells)) + allocate (this%thtr(ncells)) + allocate (this%thts(ncells)) + allocate (this%thti(ncells)) + allocate (this%eps(ncells)) + allocate (this%ha(ncells)) + allocate (this%hroot(ncells)) + allocate (this%rootact(ncells)) + allocate (this%extwc(ncells)) + allocate (this%etact(ncells)) + allocate (this%nwav(ncells)) + allocate (this%ntrail(ncells)) + allocate (this%totflux(ncells)) + allocate (this%sinf(ncells)) + allocate (this%finf(ncells)) + allocate (this%finf_rej(ncells)) + allocate (this%gwet(ncells)) + allocate (this%uzfarea(ncells)) + allocate (this%cellarea(ncells)) + allocate (this%celtop(ncells)) + allocate (this%celbot(ncells)) + allocate (this%landtop(ncells)) + allocate (this%watab(ncells)) + allocate (this%watabold(ncells)) + allocate (this%surfdep(ncells)) + allocate (this%vks(ncells)) + allocate (this%surflux(ncells)) + allocate (this%surfluxbelow(ncells)) + allocate (this%surfseep(ncells)) + allocate (this%gwpet(ncells)) + allocate (this%pet(ncells)) + allocate (this%petmax(ncells)) + allocate (this%extdp(ncells)) + allocate (this%extdpuz(ncells)) + allocate (this%landflag(ncells)) + allocate (this%ivertcon(ncells)) end if do icell = 1, ncells this%uzdpst(:, icell) = DZERO @@ -249,55 +249,55 @@ subroutine dealloc(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - ! -- modules - use MemoryManagerModule, only: mem_deallocate - ! -- dummy - class(UzfCellGroupType) :: this - ! -- local + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(UzfCellGroupType) :: this + ! -- local ! ------------------------------------------------------------------------------ ! ! -- deallocate based on whether or not memory manager was used if (this%imem_manager == 0) then - deallocate(this%uzdpst) - deallocate(this%uzthst) - deallocate(this%uzflst) - deallocate(this%uzspst) - deallocate(this%nwavst) - deallocate(this%thtr) - deallocate(this%thts) - deallocate(this%thti) - deallocate(this%eps) - deallocate(this%ha) - deallocate(this%hroot) - deallocate(this%rootact) - deallocate(this%extwc) - deallocate(this%etact) - deallocate(this%nwav) - deallocate(this%ntrail) - deallocate(this%totflux) - deallocate(this%sinf) - deallocate(this%finf) - deallocate(this%finf_rej) - deallocate(this%gwet) - deallocate(this%uzfarea) - deallocate(this%cellarea) - deallocate(this%celtop) - deallocate(this%celbot) - deallocate(this%landtop) - deallocate(this%watab) - deallocate(this%watabold) - deallocate(this%surfdep) - deallocate(this%vks) - deallocate(this%surflux) - deallocate(this%surfluxbelow) - deallocate(this%surfseep) - deallocate(this%gwpet) - deallocate(this%pet) - deallocate(this%petmax) - deallocate(this%extdp) - deallocate(this%extdpuz) - deallocate(this%landflag) - deallocate(this%ivertcon) + deallocate (this%uzdpst) + deallocate (this%uzthst) + deallocate (this%uzflst) + deallocate (this%uzspst) + deallocate (this%nwavst) + deallocate (this%thtr) + deallocate (this%thts) + deallocate (this%thti) + deallocate (this%eps) + deallocate (this%ha) + deallocate (this%hroot) + deallocate (this%rootact) + deallocate (this%extwc) + deallocate (this%etact) + deallocate (this%nwav) + deallocate (this%ntrail) + deallocate (this%totflux) + deallocate (this%sinf) + deallocate (this%finf) + deallocate (this%finf_rej) + deallocate (this%gwet) + deallocate (this%uzfarea) + deallocate (this%cellarea) + deallocate (this%celtop) + deallocate (this%celbot) + deallocate (this%landtop) + deallocate (this%watab) + deallocate (this%watabold) + deallocate (this%surfdep) + deallocate (this%vks) + deallocate (this%surflux) + deallocate (this%surfluxbelow) + deallocate (this%surfseep) + deallocate (this%gwpet) + deallocate (this%pet) + deallocate (this%petmax) + deallocate (this%extdp) + deallocate (this%extdpuz) + deallocate (this%landflag) + deallocate (this%ivertcon) else call mem_deallocate(this%uzdpst) call mem_deallocate(this%uzthst) @@ -337,15 +337,15 @@ subroutine dealloc(this) call mem_deallocate(this%petmax) call mem_deallocate(this%extdp) call mem_deallocate(this%extdpuz) - call mem_deallocate(this%landflag) - call mem_deallocate(this%ivertcon) + call mem_deallocate(this%landflag) + call mem_deallocate(this%ivertcon) end if ! ! -- return return end subroutine dealloc - subroutine setdata(this, icell, area, top, bot, surfdep, vks, thtr, thts, & + subroutine setdata(this, icell, area, top, bot, surfdep, vks, thtr, thts, & thti, eps, ntrail, landflag, ivertcon) ! ****************************************************************************** ! setdata -- set uzf object material properties @@ -395,7 +395,7 @@ subroutine setdata(this, icell, area, top, bot, surfdep, vks, thtr, thts, & this%ha(icell) = DZERO this%hroot(icell) = DZERO end subroutine setdata - + subroutine sethead(this, icell, hgwf) ! ****************************************************************************** ! sethead -- set uzf object material properties @@ -407,7 +407,7 @@ subroutine sethead(this, icell, hgwf) ! -- dummy class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell - real(DP), intent(in) :: hgwf + real(DP), intent(in) :: hgwf ! ------------------------------------------------------------------------------ ! ! -- set initial head @@ -417,7 +417,7 @@ subroutine sethead(this, icell, hgwf) this%watab(icell) = this%celtop(icell) this%watabold(icell) = this%watab(icell) end subroutine sethead - + subroutine setdatafinf(this, icell, finf) ! ****************************************************************************** ! setdatafinf -- set infiltration @@ -442,7 +442,7 @@ subroutine setdatafinf(this, icell, finf) this%finf_rej(icell) = DZERO this%surflux(icell) = DZERO this%surfluxbelow(icell) = DZERO - end subroutine setdatafinf + end subroutine setdatafinf subroutine setdatauzfarea(this, icell, areamult) ! ****************************************************************************** @@ -463,11 +463,11 @@ subroutine setdatauzfarea(this, icell, areamult) ! ! -- return return - end subroutine setdatauzfarea - + end subroutine setdatauzfarea + ! ------------------------------------------------------------------------------ -! - subroutine setdataet(this, icell, jbelow, pet, extdp) +! + subroutine setdataet(this, icell, jbelow, pet, extdp) ! ****************************************************************************** ! setdataet -- set unsat. et variables ! ****************************************************************************** @@ -494,8 +494,8 @@ subroutine setdataet(this, icell, jbelow, pet, extdp) thick = this%celtop(icell) - this%celbot(icell) this%extdp(icell) = extdp if (this%landflag(icell) > 0) then - this%landtop(icell) = this%celtop(icell) - this%petmax(icell) = this%pet(icell) + this%landtop(icell) = this%celtop(icell) + this%petmax(icell) = this%pet(icell) end if ! ! -- set uz extinction depth @@ -503,7 +503,7 @@ subroutine setdataet(this, icell, jbelow, pet, extdp) this%extdpuz(icell) = thick else this%extdpuz(icell) = this%celtop(icell) - & - (this%landtop(icell) - this%extdp(icell)) + (this%landtop(icell) - this%extdp(icell)) end if if (this%extdpuz(icell) < DZERO) this%extdpuz(icell) = DZERO if (this%extdpuz(icell) > DEM7 .and. this%extdp(icell) < DEM7) & @@ -517,12 +517,12 @@ subroutine setdataet(this, icell, jbelow, pet, extdp) ! ! -- return return - end subroutine setdataet - - subroutine setgwpet(this, icell) + end subroutine setdataet + + subroutine setgwpet(this, icell) ! ****************************************************************************** ! setgwpet -- subtract aet from pet to calculate residual et for gw -! +! ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -534,21 +534,21 @@ subroutine setgwpet(this, icell) integer(I4B), intent(in) :: icell ! -- dummy real(DP) :: pet -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ pet = DZERO ! ! -- reduce pet for gw by uzet pet = this%pet(icell) - this%etact(icell) / delt - if ( pet < DZERO ) pet = DZERO + if (pet < DZERO) pet = DZERO this%gwpet(icell) = pet ! ! -- return return - end subroutine setgwpet - + end subroutine setgwpet + subroutine setbelowpet(this, icell, jbelow) ! ****************************************************************************** -! setbelowpet -- subtract aet from pet to calculate residual et +! setbelowpet -- subtract aet from pet to calculate residual et ! for deeper cells ! ****************************************************************************** ! @@ -562,25 +562,25 @@ subroutine setbelowpet(this, icell, jbelow) integer(I4B), intent(in) :: jbelow ! -- dummy real(DP) :: pet -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ pet = DZERO ! ! -- transfer unmet pet to lower cell ! if (this%extdpuz(jbelow) > DEM3) then - pet = this%pet(icell) - this%etact(icell) / delt - & - this%gwet(icell)/this%uzfarea(icell) - if (pet < DZERO) pet = DZERO + pet = this%pet(icell) - this%etact(icell) / delt - & + this%gwet(icell) / this%uzfarea(icell) + if (pet < DZERO) pet = DZERO end if this%pet(jbelow) = pet ! ! -- return return - end subroutine setbelowpet - + end subroutine setbelowpet + subroutine setdataetwc(this, icell, jbelow, extwc) ! ****************************************************************************** -! setdataetwc -- set extinction water content +! setdataetwc -- set extinction water content ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -599,7 +599,7 @@ subroutine setdataetwc(this, icell, jbelow, extwc) ! -- return return end subroutine setdataetwc - + subroutine setdataetha(this, icell, jbelow, ha, hroot, rootact) ! ****************************************************************************** ! setdataetha -- set variables for head-based unsat. flow @@ -621,16 +621,16 @@ subroutine setdataetha(this, icell, jbelow, ha, hroot, rootact) this%hroot(icell) = hroot this%rootact(icell) = rootact if (jbelow > 0) then - this%ha(jbelow) = ha - this%hroot(jbelow) = hroot - this%rootact(jbelow) = rootact - end if + this%ha(jbelow) = ha + this%hroot(jbelow) = hroot + this%rootact(jbelow) = rootact + end if ! ! -- return return - end subroutine setdataetha - - subroutine advance(this, icell) + end subroutine setdataetha + + subroutine advance(this, icell) ! ****************************************************************************** ! advance -- set variables to advance to new time step. nothing yet. ! ****************************************************************************** @@ -649,12 +649,12 @@ subroutine advance(this, icell) return end subroutine advance - subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & - issflag, iseepflag, hgwf, qfrommvr, ierr, & + subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & + issflag, iseepflag, hgwf, qfrommvr, ierr, & reset_state, trhs, thcof, deriv, watercontent) ! ****************************************************************************** -! formulate -- formulate the unsaturated flow object, calculate terms for -! gwf equation +! formulate -- formulate the unsaturated flow object, calculate terms for +! gwf equation ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -663,18 +663,18 @@ subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & use TdisModule, only: delt ! -- dummy class(UzfCellGroupType) :: this - type(UzfCellGroupType) :: thiswork !< work object for resetting wave state - integer(I4B), intent(in) :: jbelow !< number of underlying uzf object or 0 if none - integer(I4B), intent(in) :: icell !< number of this uzf object - real(DP), intent(inout) :: totfluxtot !< - integer(I4B), intent(in) :: ietflag !< et is off (0) or based one water content (1) or pressure (2) - integer(I4B), intent(in) :: issflag !< steady state flag - integer(I4B), intent(in) :: iseepflag !< discharge to land is active (1) or not (0) - real(DP), intent(in) :: hgwf !< head for cell icell - real(DP), intent(in) :: qfrommvr !< water inflow from mover - integer(I4B), intent(inout) :: ierr !< flag indicating not enough waves - logical, intent(in) :: reset_state !< flag indicating that waves should be reset after solution - real(DP), intent(inout), optional :: trhs !< total uzf rhs contribution to GWF model + type(UzfCellGroupType) :: thiswork !< work object for resetting wave state + integer(I4B), intent(in) :: jbelow !< number of underlying uzf object or 0 if none + integer(I4B), intent(in) :: icell !< number of this uzf object + real(DP), intent(inout) :: totfluxtot !< + integer(I4B), intent(in) :: ietflag !< et is off (0) or based one water content (1) or pressure (2) + integer(I4B), intent(in) :: issflag !< steady state flag + integer(I4B), intent(in) :: iseepflag !< discharge to land is active (1) or not (0) + real(DP), intent(in) :: hgwf !< head for cell icell + real(DP), intent(in) :: qfrommvr !< water inflow from mover + integer(I4B), intent(inout) :: ierr !< flag indicating not enough waves + logical, intent(in) :: reset_state !< flag indicating that waves should be reset after solution + real(DP), intent(inout), optional :: trhs !< total uzf rhs contribution to GWF model real(DP), intent(inout), optional :: thcof !< total uzf hcof contribution to GWF model real(DP), intent(inout), optional :: deriv !< derivate term for contribution to GWF model real(DP), intent(inout), optional :: watercontent !< calculated water content @@ -699,7 +699,7 @@ subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & trhsseep = DZERO thcofseep = DZERO this%finf_rej(icell) = DZERO - this%surflux(icell) = this%finf(icell) + qfrommvr / this%uzfarea(icell) + this%surflux(icell) = this%finf(icell) + qfrommvr / this%uzfarea(icell) this%watab(icell) = hgwf this%surfseep(icell) = DZERO seep = DZERO @@ -721,7 +721,7 @@ subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & if (reset_state) then call thiswork%wave_shift(this, 1, icell, 0, 1, this%nwavst(icell), 1) end if - + if (this%watab(icell) > this%celtop(icell)) & this%watab(icell) = this%celtop(icell) ! @@ -730,20 +730,20 @@ subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & this%surflux(icell) = this%vks(icell) end if ! - ! -- saturation excess rejected infiltration + ! -- saturation excess rejected infiltration if (this%landflag(icell) == 1) then call this%rejfinf(icell, deriv1, hgwf, trhsfinf, thcoffinf, finfact) this%surflux(icell) = finfact end if ! ! -- calculate rejected infiltration - this%finf_rej(icell) = this%finf(icell) + & - (qfrommvr / this%uzfarea(icell)) - this%surflux(icell) + this%finf_rej(icell) = this%finf(icell) + & + (qfrommvr / this%uzfarea(icell)) - this%surflux(icell) ! ! -- calculate groundwater discharge if (iseepflag > 0 .and. this%landflag(icell) == 1) then call this%gwseep(icell, deriv2, scale, hgwf, trhsseep, thcofseep, seep) - this%surfseep(icell) = seep + this%surfseep(icell) = seep end if ! ! -- route water through unsat zone, calc. storage change and recharge @@ -751,13 +751,13 @@ subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & if (this%watabold(icell) - test < -DEM15) test = this%watabold(icell) if (this%celtop(icell) - test > DEM15) then if (issflag == 0) then - call this%routewaves(totfluxtot, delt, ietflag, icell, ierr) + call this%routewaves(totfluxtot, delt, ietflag, icell, ierr) if (ierr > 0) return call this%uz_rise(icell, totfluxtot) this%totflux(icell) = totfluxtot if (this%ivertcon(icell) > 0) then call this%addrech(icell, jbelow, hgwf, trhsfinf, thcoffinf, & - derivfinf, delt) + derivfinf, delt) end if else this%totflux(icell) = this%surflux(icell) * delt @@ -777,16 +777,16 @@ subroutine solve(this, thiswork, jbelow, icell, totfluxtot, ietflag, & end if ! ! -- If formulating, then these variables will be present - if (present(deriv)) deriv = deriv1 + deriv2 + derivfinf - if (present(trhs)) trhs = trhsfinf + trhsseep - if (present(thcof)) thcof = thcoffinf + thcofseep + if (present(deriv)) deriv = deriv1 + deriv2 + derivfinf + if (present(trhs)) trhs = trhsfinf + trhsseep + if (present(thcof)) thcof = thcoffinf + thcofseep ! ! -- Assign water content prior to resetting waves if (present(watercontent)) then watercontent = this%get_wcnew(icell) end if ! - ! -- reset waves to previous state for next iteration + ! -- reset waves to previous state for next iteration if (reset_state) then call this%wave_shift(thiswork, icell, 1, 0, 1, thiswork%nwavst(1), 1) end if @@ -814,7 +814,7 @@ subroutine addrech(this, icell, jbelow, hgwf, trhs, thcof, deriv, delt) ! -- local real(DP) :: fcheck real(DP) :: x, scale, range -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! ! -- initialize range = DEM5 @@ -824,11 +824,11 @@ subroutine addrech(this, icell, jbelow, hgwf, trhs, thcof, deriv, delt) if (this%totflux(icell) < DEM14) return scale = DONE ! - ! -- smoothly reduce flow between cells when head close to cell top - x = hgwf - (this%celbot(icell) - range) + ! -- smoothly reduce flow between cells when head close to cell top + x = hgwf - (this%celbot(icell) - range) call sSCurve(x, range, deriv, scale) deriv = this%uzfarea(icell) * deriv * this%totflux(icell) / delt - this%finf(jbelow) = (DONE - scale) * this%totflux(icell) / delt + this%finf(jbelow) = (DONE - scale) * this%totflux(icell) / delt fcheck = this%finf(jbelow) - this%vks(jbelow) ! ! -- reduce flow between cells when vks is too small @@ -859,7 +859,7 @@ subroutine rejfinf(this, icell, deriv, hgwf, trhs, thcof, finfact) real(DP), intent(inout) :: trhs real(DP), intent(in) :: hgwf ! -- local - real(DP) :: x, range, scale, q + real(DP) :: x, range, scale, q ! ------------------------------------------------------------------------------ range = this%surfdep(icell) q = this%surflux(icell) @@ -877,7 +877,7 @@ subroutine rejfinf(this, icell, deriv, hgwf, trhs, thcof, finfact) ! -- return return end subroutine rejfinf - + subroutine gwseep(this, icell, deriv, scale, hgwf, trhs, thcof, seep) ! ****************************************************************************** ! gwseep -- calc. groudwater discharge to land surface @@ -944,7 +944,7 @@ subroutine simgwet(this, igwetflag, icell, hgwf, trhs, thcof, det) real(DP), intent(inout) :: det ! -- local real(DP) :: s, x, c, b, et -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! this%gwet(icell) = DZERO trhs = DZERO @@ -954,18 +954,18 @@ subroutine simgwet(this, igwetflag, icell, hgwf, trhs, thcof, det) x = this%extdp(icell) c = this%gwpet(icell) b = this%celbot(icell) - if ( b > hgwf ) return + if (b > hgwf) return if (x < DEM6) return if (igwetflag == 1) then et = etfunc_lin(s, x, c, det, trhs, thcof, hgwf, & - this%celtop(icell), this%celbot(icell)) + this%celtop(icell), this%celbot(icell)) else if (igwetflag == 2) then et = etfunc_nlin(s, x, c, det, trhs, thcof, hgwf) end if ! this%gwet(icell) = et * this%uzfarea(icell) - trhs = trhs * this%uzfarea(icell) + trhs = trhs * this%uzfarea(icell) thcof = thcof * this%uzfarea(icell) - this%gwet(icell) = trhs - (thcof * hgwf) + this%gwet(icell) = trhs - (thcof * hgwf) ! write(99,*)'in group', icell, this%gwet(icell) ! ! -- return @@ -979,7 +979,7 @@ function etfunc_lin(s, x, c, det, trhs, thcof, hgwf, celtop, celbot) ! ****************************************************************************** ! ! SPECIFICATIONS: -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ ! -- modules ! -- return real(DP) :: etfunc_lin @@ -1000,7 +1000,7 @@ function etfunc_lin(s, x, c, det, trhs, thcof, hgwf, celtop, celbot) ! ------------------------------------------------------------------------------ ! ! -- Between ET surface and extinction depth - if (hgwf > (s-x) .and. hgwf < s) THEN + if (hgwf > (s - x) .and. hgwf < s) THEN etgw = (c * (hgwf - (s - x)) / x) if (etgw > c) then etgw = c @@ -1009,13 +1009,13 @@ function etfunc_lin(s, x, c, det, trhs, thcof, hgwf, celtop, celbot) thcof = -c / x etgw = trhs - (thcof * hgwf) end if - ! - ! -- Above land surface - else if (hgwf >= s) then + ! + ! -- Above land surface + else if (hgwf >= s) then trhs = c etgw = c - ! - ! Below extinction depth + ! + ! Below extinction depth else etgw = DZERO end if @@ -1030,13 +1030,12 @@ function etfunc_lin(s, x, c, det, trhs, thcof, hgwf, celtop, celbot) trhs = scale * trhs thcof = scale * thcof etgw = trhs - (thcof * hgwf) - det = -det * etgw + det = -det * etgw etfunc_lin = etgw ! ! -- return return end function etfunc_lin - function etfunc_nlin(s, x, c, det, trhs, thcof, hgwf) ! ****************************************************************************** @@ -1135,7 +1134,7 @@ subroutine setwaves(this, icell) if (top < DZERO) top = DZERO bottom = this%thts(icell) - this%thtr(icell) if (bottom < DZERO) bottom = DZERO - this%uzflst(1, icell) = this%vks(icell) * (top / bottom) ** this%eps(icell) + this%uzflst(1, icell) = this%vks(icell) * (top / bottom)**this%eps(icell) if (this%uzthst(1, icell) < this%thtr(icell)) & this%uzthst(1, icell) = this%thtr(icell) ! @@ -1158,7 +1157,7 @@ subroutine setwaves(this, icell) ! -- return return end subroutine - + subroutine routewaves(this, totfluxtot, delt, ietflag, icell, ierr) ! ****************************************************************************** ! routewaves -- prepare and route waves over time step @@ -1197,8 +1196,8 @@ subroutine routewaves(this, totfluxtot, delt, ietflag, icell, ierr) end if idelt = 1 do ik = 1, idelt - call this%uzflow(thick, thickold, delt, ietflag, icell, ierr) - if (ierr > 0) return + call this%uzflow(thick, thickold, delt, ietflag, icell, ierr) + if (ierr > 0) return totfluxtot = totfluxtot + this%totflux(icell) end do ! @@ -1214,8 +1213,8 @@ subroutine wave_shift(this, this2, icell, icell2, shft, strt, stp, cntr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class (UzfCellGroupType) :: this - type (UzfCellGroupType) :: this2 + class(UzfCellGroupType) :: this + type(UzfCellGroupType) :: this2 integer(I4B), intent(in) :: icell integer(I4B), intent(in) :: icell2 integer(I4B), intent(in) :: shft @@ -1238,7 +1237,7 @@ subroutine wave_shift(this, this2, icell, icell2, shft, strt, stp, cntr) ! -- return return end subroutine - + subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) ! ****************************************************************************** ! uzflow -- moc solution for kinematic wave equation @@ -1247,7 +1246,7 @@ subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this real(DP), intent(inout) :: thickold real(DP), intent(inout) :: thick real(DP), intent(in) :: delt @@ -1260,7 +1259,7 @@ subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) integer(I4B) :: itrailflg, itester ! ------------------------------------------------------------------------------ time = DZERO - this%totflux(icell) = DZERO + this%totflux(icell) = DZERO itrailflg = 0 oldsflx = this%uzflst(this%nwavst(icell), icell) call factors(feps1, feps2) @@ -1269,12 +1268,13 @@ subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) if ((thick - thickold) > feps1) then thetadif = abs(this%uzthst(1, icell) - this%thtr(icell)) if (thetadif > DEM6) then - call this%wave_shift(this, icell, icell, -1, this%nwavst(icell) + 1, 2, -1) + call this%wave_shift(this, icell, icell, -1, & + this%nwavst(icell) + 1, 2, -1) if (this%uzdpst(2, icell) < DEM30) & this%uzdpst(2, icell) = (this%ntrail(icell) + DTWO) * DEM6 if (this%uzthst(2, icell) > this%thtr(icell)) then this%uzspst(2, icell) = this%uzflst(2, icell) / & - (this%uzthst(2, icell) - this%thtr(icell)) + (this%uzthst(2, icell) - this%thtr(icell)) else this%uzspst(2, icell) = DZERO end if @@ -1296,7 +1296,7 @@ subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) fluxb = this%uzflst(1, icell) this%totflux(icell) = DZERO itester = 0 - ffcheck = (this%surflux(icell)-this%uzflst(this%nwavst(icell), icell)) + ffcheck = (this%surflux(icell) - this%uzflst(this%nwavst(icell), icell)) ! ! -- increase new waves in infiltration changes if (ffcheck > feps2 .OR. ffcheck < -feps2) then @@ -1316,12 +1316,12 @@ subroutine uzflow(this, thick, thickold, delt, ietflag, icell, ierr) if (ierr > 0) return itrailflg = 1 end if - call this%leadwav(time, itester, itrailflg, thetab, fluxb, ffcheck, & + call this%leadwav(time, itester, itrailflg, thetab, fluxb, ffcheck, & feps2, delt, icell) end if if (itester == 1) then this%totflux(icell) = this%totflux(icell) + & - (delt - time) * this%uzflst(1, icell) + (delt - time) * this%uzflst(1, icell) time = DZERO itester = 0 end if @@ -1359,10 +1359,10 @@ subroutine factors(feps1, feps2) else if (ITMUNI == 2) then factor1 = DONE / 1440.D0 else if (ITMUNI == 3) then - factor1 = DONE / 24.0D0 + factor1 = DONE / 24.0D0 else if (ITMUNI == 5) then factor1 = 365.0D0 - end if + end if factor2 = DONE / 0.3048 feps1 = feps1 * factor1 * factor2 feps2 = feps2 * factor1 * factor2 @@ -1380,7 +1380,7 @@ subroutine trailwav(this, icell, ierr) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell integer(I4B), intent(inout) :: ierr ! -- local @@ -1397,9 +1397,9 @@ subroutine trailwav(this, icell, ierr) nwavstm1 = this%nwavst(icell) - 1 ! ! -- initialize trailwaves - smoist = (((this%surflux(icell) / this%vks(icell)) ** & - (DONE / this%eps(icell))) * & - (this%thts(icell) - this%thtr(icell))) + this%thtr(icell) + smoist = (((this%surflux(icell) / this%vks(icell))** & + (DONE / this%eps(icell))) * & + (this%thts(icell) - this%thtr(icell))) + this%thtr(icell) if (this%uzthst(nwavstm1, icell) - smoist > DEM9) then fnuminc = DZERO do jk = 1, this%ntrail(icell) @@ -1415,27 +1415,28 @@ subroutine trailwav(this, icell, ierr) return end if if (j > this%nwavst(icell)) then - this%uzthst(j, icell) = this%uzthst(j - 1, icell) & - - ((ftrail - float(jj)) * smoistinc) + this%uzthst(j, icell) = this%uzthst(j - 1, icell) & + - ((ftrail - float(jj)) * smoistinc) else this%uzthst(j, icell) = this%uzthst(j - 1, icell) - DEM9 end if jj = jj - 1 if (this%uzthst(j, icell) <= this%thtr(icell) + DEM9) & this%uzthst(j, icell) = this%thtr(icell) + DEM9 - this%uzflst(j, icell) = this%vks(icell) * & - (((this%uzthst(j, icell) - this%thtr(icell)) * thtsrinv) ** & - this%eps(icell)) + this%uzflst(j, icell) = & + this%vks(icell) * (((this%uzthst(j, icell) - this%thtr(icell)) * & + thtsrinv)**this%eps(icell)) theta2 = this%uzthst(j - 1, icell) flux2 = this%uzflst(j - 1, icell) flux1 = this%uzflst(j, icell) theta1 = this%uzthst(j, icell) - this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, flux2, & + this%thts(icell), this%thtr(icell), & + this%eps(icell), this%vks(icell)) this%uzdpst(j, icell) = DZERO if (j == this%nwavst(icell)) then - this%uzdpst(j, icell) = this%uzdpst(j, icell) + (this%ntrail(icell) + 1) * DEM9 + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + (this%ntrail(icell) + 1) * DEM9 else this%uzdpst(j, icell) = this%uzdpst(j - 1, icell) - DEM9 end if @@ -1448,24 +1449,24 @@ subroutine trailwav(this, icell, ierr) end if else this%uzdpst(this%nwavst, icell) = DZERO - this%uzflst(this%nwavst, icell) = this%vks(icell) * & - (((this%uzthst(this%nwavst, icell) - this%thtr(icell)) * & - thtsrinv) ** this%eps(icell)) + this%uzflst(this%nwavst, icell) = & + this%vks(icell) * (((this%uzthst(this%nwavst, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell)) this%uzthst(this%nwavst, icell) = smoist theta2 = this%uzthst(this%nwavst(icell) - 1, icell) flux2 = this%uzflst(this%nwavst(icell) - 1, icell) flux1 = this%uzflst(this%nwavst(icell), icell) theta1 = this%uzthst(this%nwavst(icell), icell) - this%uzspst(this%nwavst(icell), icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(this%nwavst(icell), icell) = & + leadspeed(theta1, theta2, flux1, flux2, this%thts(icell), & + this%thtr(icell), this%eps(icell), this%vks(icell)) end if ! ! -- return return end subroutine trailwav - subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & + subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & ffcheck, feps2, delt, icell) ! ****************************************************************************** ! leadwav----create a lead wave and route over time step @@ -1475,7 +1476,7 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this real(DP), intent(inout) :: thetab real(DP), intent(inout) :: fluxb real(DP), intent(in) :: feps2 @@ -1495,8 +1496,8 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & integer(I4B) :: nwavp1, jshort integer(I4B), allocatable, dimension(:) :: more ! ------------------------------------------------------------------------------ - allocate(checktime(this%nwavst(icell))) - allocate(more(this%nwavst(icell))) + allocate (checktime(this%nwavst(icell))) + allocate (more(this%nwavst(icell))) ftest = DZERO eps_m1 = dble(this%eps(icell)) - DONE thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) @@ -1506,18 +1507,18 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & if (ffcheck > feps2) then this%uzflst(this%nwavst(icell), icell) = this%surflux(icell) if (this%uzflst(this%nwavst(icell), icell) < DEM30) & - this%uzflst(this%nwavst(icell), icell) = DZERO + this%uzflst(this%nwavst(icell), icell) = DZERO this%uzthst(this%nwavst(icell), icell) = & - (((this%uzflst(this%nwavst(icell), icell) / this%vks(icell)) ** & - (DONE / this%eps(icell))) * (this%thts(icell) - this%thtr(icell))) & - + this%thtr(icell) + (((this%uzflst(this%nwavst(icell), icell) / this%vks(icell))** & + (DONE / this%eps(icell))) * (this%thts(icell) - this%thtr(icell))) & + + this%thtr(icell) theta2 = this%uzthst(this%nwavst(icell), icell) flux2 = this%uzflst(this%nwavst(icell), icell) flux1 = this%uzflst(this%nwavst(icell) - 1, icell) theta1 = this%uzthst(this%nwavst(icell) - 1, icell) - this%uzspst(this%nwavst(icell), icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(this%nwavst(icell), icell) = & + leadspeed(theta1, theta2, flux1, flux2, this%thts(icell), & + this%thtr(icell), this%eps(icell), this%vks(icell)) this%uzdpst(this%nwavst(icell), icell) = DZERO end if end if @@ -1545,7 +1546,8 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & do while (j < nwavp1) ftest = this%uzspst(j - 1, icell) - this%uzspst(j, icell) if (abs(ftest) > DEM30) then - checktime(j) = (this%uzdpst(j, icell) - this%uzdpst(j - 1, icell)) / ftest + checktime(j) = (this%uzdpst(j, icell) - & + this%uzdpst(j - 1, icell)) / ftest if (checktime(j) < DEM30) checktime(j) = DEP20 end if j = j + 1 @@ -1574,7 +1576,7 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & end do do j = 3, this%nwavst(icell) if (shortest - checktime(j) < DEM9) then - if (j /= jshort) more(j) = 0 + if (j /= jshort) more(j) = 0 end if end do ! @@ -1588,14 +1590,15 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & do while (j < nwavp1) ! ! -- route waves - this%uzdpst(j, icell) = this%uzdpst(j, icell) + & - this%uzspst(j, icell) * bottomtime + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + this%uzspst(j, icell) * bottomtime j = j + 1 end do fluxb = this%uzflst(2, icell) thetab = this%uzthst(2, icell) iflx = 1 - call this%wave_shift(this, icell, icell, 1, 1, this%nwavst(icell) - 1, 1) + call this%wave_shift(this, icell, icell, 1, 1, & + this%nwavst(icell) - 1, 1) iremove = 1 timenew = time + bottomtime this%uzspst(1, icell) = DZERO @@ -1604,15 +1607,15 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & else if (fcheck < DZERO .AND. this%nwavst(icell) > 2) then j = 2 do while (j < nwavp1) - this%uzdpst(j, icell) = this%uzdpst(j, icell) + & - this%uzspst(j, icell) * shortest + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + this%uzspst(j, icell) * shortest j = j + 1 end do ! ! -- combine waves that intercept, remove a wave j = 3 l = j - do while (j < this%nwavst(icell) + 1) + do while (j < this%nwavst(icell) + 1) if (more(j) == 1) then l = j theta2 = this%uzthst(j, icell) @@ -1624,12 +1627,14 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & flux1 = this%uzflst(j - 2, icell) theta1 = this%uzthst(j - 2, icell) end if - this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(j, icell) = leadspeed(theta1, theta2, flux1, flux2, & + this%thts(icell), & + this%thtr(icell), & + this%eps(icell), this%vks(icell)) ! ! -- update waves - call this%wave_shift(this, icell, icell, 1, l - 1, this%nwavst(icell) - 1, 1) + call this%wave_shift(this, icell, icell, 1, l - 1, & + this%nwavst(icell) - 1, 1) l = this%nwavst(icell) + 1 iremove = iremove + 1 end if @@ -1641,8 +1646,8 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & else j = 2 do while (j < nwavp1) - this%uzdpst(j, icell) = this%uzdpst(j, icell) + & - this%uzspst(j, icell) * timedt + this%uzdpst(j, icell) = this%uzdpst(j, icell) + & + this%uzspst(j, icell) * timedt j = j + 1 end do timenew = delt @@ -1654,7 +1659,7 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & end if ! ! -- remove dead waves - this%nwavst(icell) = this%nwavst(icell) - iremove + this%nwavst(icell) = this%nwavst(icell) - iremove time = timenew diff = delt - Time if (this%nwavst(icell) == 1) then @@ -1663,8 +1668,8 @@ subroutine leadwav(this, time, itester, itrailflg, thetab, fluxb, & end if end do end if - deallocate(checktime) - deallocate(more) + deallocate (checktime) + deallocate (more) ! ! -- return return @@ -1702,11 +1707,11 @@ function leadspeed(theta1, theta2, flux1, flux2, thts, thtr, eps, vks) comp3 = theta1 - thtr if (comp2 < DEM15) flux2 = flux1 + DEM15 if (abs(comp1) < DEM30) then - if (comp3 > DEM30) fhold = (comp3 * thsrinv) ** eps + if (comp3 > DEM30) fhold = (comp3 * thsrinv)**eps if (fhold < DEM30) fhold = DEM30 - leadspeed = epsfksths * (fhold ** eps_m1) + leadspeed = epsfksths * (fhold**eps_m1) else - leadspeed = (flux2 - flux1) / (theta2 - theta1) + leadspeed = (flux2 - flux1) / (theta2 - theta1) end if if (leadspeed < DEM30) leadspeed = DEM30 ! @@ -1725,7 +1730,7 @@ function unsat_stor(this, icell, d1) ! -- return real(DP) :: unsat_stor ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell real(DP), intent(inout) :: d1 ! -- local @@ -1741,22 +1746,22 @@ function unsat_stor(this, icell, d1) ! -- find deepest wave above depth d1, counter held as j do while (k > 0) if (this%uzdpst(k, icell) - d1 < -DEM30) j = k - k = k - 1 + k = k - 1 end do if (j > this%nwavst(icell)) then fm = fm + (this%uzthst(this%nwavst(icell), icell) - this%thtr(icell)) * d1 elseif (this%nwavst(icell) > 1) then if (j > 1) then fm = fm + (this%uzthst(j - 1, icell) - this%thtr(icell)) & - * (d1 - this%uzdpst(j, icell)) + * (d1 - this%uzdpst(j, icell)) end if do jj = j, nwavm1 fm = fm + (this%uzthst(jj, icell) - this%thtr(icell)) & - * (this%uzdpst(jj, icell) & - - this%uzdpst(jj + 1, icell)) + * (this%uzdpst(jj, icell) & + - this%uzdpst(jj + 1, icell)) end do fm = fm + (this%uzthst(this%nwavst(icell), icell) - this%thtr(icell)) & - * (this%uzdpst(this%nwavst(icell), icell)) + * (this%uzdpst(this%nwavst(icell), icell)) else fm = fm + (this%uzthst(1, icell) - this%thtr(icell)) * d1 end if @@ -1772,7 +1777,7 @@ subroutine update_wav(this, icell, delt, iss, itest) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell integer(I4B), intent(in) :: itest integer(I4B), intent(in) :: iss @@ -1786,29 +1791,30 @@ subroutine update_wav(this, icell, delt, iss, itest) bot = this%watab(icell) top = this%celtop(icell) thick = top - bot - nwavhld = this%nwavst(icell) + nwavhld = this%nwavst(icell) if (itest == 1) then this%uzflst(1, icell) = DZERO this%uzthst(1, icell) = this%thtr(icell) return end if - if (iss == 1) then + if (iss == 1) then if (this%thts(icell) - this%thtr(icell) < DEM7) then thtsrinv = DONE / DEM7 else - thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) + thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) end if this%totflux(icell) = this%surflux(icell) * delt this%watabold(icell) = this%watab(icell) this%uzthst(1, icell) = this%thti(icell) - this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - this%thtr(icell)) & - * thtsrinv) ** this%eps(icell)) + this%uzflst(1, icell) = & + this%vks(icell) * (((this%uzthst(1, icell) - this%thtr(icell)) & + * thtsrinv)**this%eps(icell)) this%uzdpst(1, icell) = thick this%uzspst(1, icell) = thick this%nwavst(icell) = 1 else ! - ! -- water table rises through waves + ! -- water table rises through waves if (this%watab(icell) - this%watabold(icell) > DEM30) then depthsave = this%uzdpst(1, icell) j = 0 @@ -1818,21 +1824,22 @@ subroutine update_wav(this, icell, delt, iss, itest) k = k - 1 end do this%uzdpst(1, icell) = thick - if (j > 1) then + if (j > 1) then this%uzspst(1, icell) = DZERO this%nwavst(icell) = this%nwavst(icell) - j + 2 this%uzthst(1, icell) = this%uzthst(j - 1, icell) this%uzflst(1, icell) = this%uzflst(j - 1, icell) - if (j > 2) call this%wave_shift(this, icell, icell, j-2, 2, nwavhld - (j - 2), 1) + if (j > 2) call this%wave_shift(this, icell, icell, j - 2, 2, & + nwavhld - (j - 2), 1) elseif (j == 0) then this%uzspst(1, icell) = DZERO this%uzthst(1, icell) = this%uzthst(this%nwavst(icell), icell) - this%uzflst(1, icell) = this%uzflst(this%nwavst(icell), icell) + this%uzflst(1, icell) = this%uzflst(this%nwavst(icell), icell) this%nwavst(icell) = 1 end if - end if + end if ! - ! -- calculate new unsat. storage + ! -- calculate new unsat. storage if (thick <= DZERO) then this%uzspst(1, icell) = DZERO this%nwavst(icell) = 1 @@ -1842,7 +1849,7 @@ subroutine update_wav(this, icell, delt, iss, itest) this%watabold(icell) = this%watab(icell) end if end subroutine update_wav - + subroutine uzet(this, icell, delt, ietflag, ierr) ! ****************************************************************************** ! uzet -- remove water from uz due to et @@ -1852,7 +1859,7 @@ subroutine uzet(this, icell, delt, ietflag, ierr) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell real(DP), intent(in) :: delt integer(I4B), intent(in) :: ietflag @@ -1892,7 +1899,8 @@ subroutine uzet(this, icell, delt, ietflag, ierr) ! -- initialize this%etact(icell) = DZERO if (this%extdpuz(icell) < DEM7) return - petsub = this%rootact(icell) * this%pet(icell) * this%extdpuz(icell) / this%extdp(icell) + petsub = this%rootact(icell) * this%pet(icell) * & + this%extdpuz(icell) / this%extdp(icell) thetaout = delt * petsub / this%extdp(icell) if (ietflag == 1) thetaout = delt * this%pet(icell) / this%extdp(icell) if (thetaout < DEM10) return @@ -1912,7 +1920,7 @@ subroutine uzet(this, icell, delt, ietflag, ierr) if (this%thts(icell) - this%thtr(icell) < DEM7) then thtsrinv = 1.0 / DEM7 else - thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) + thtsrinv = DONE / (this%thts(icell) - this%thtr(icell)) end if epsfksthts = this%eps(icell) * this%vks(icell) * thtsrinv this%etact(icell) = DZERO @@ -1926,65 +1934,75 @@ subroutine uzet(this, icell, delt, ietflag, ierr) ! -- loop for reducing aet to pet when et is head dependent do while (itest == 0) k = k + 1 - if (k > 1 .AND. ABS(fmp - petsub) > DEM5 * petsub) factor = factor / (fm / petsub) + if (k > 1 .AND. ABS(fmp - petsub) > DEM5 * petsub) then + factor = factor / (fm / petsub) + end if ! ! -- one wave shallower than extdp - if (this%nwavst(icell) == 1 .AND. this%uzdpst(1, icell) <= this%extdpuz(icell)) then + if (this%nwavst(icell) == 1 .AND. & + this%uzdpst(1, icell) <= this%extdpuz(icell)) then if (ietflag == 2) then tho = this%uzthst(1, icell) fktho = this%uzflst(1, icell) hcap = this%caph(icell, tho) thetaout = this%rate_et_z(icell, factor, fktho, hcap) - end if + end if if ((this%uzthst(1, icell) - thetaout) > this%thtr(icell) + extwc1) then this%uzthst(1, icell) = this%uzthst(1, icell) - thetaout - this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + this%uzflst(1, icell) = & + this%vks(icell) * (((this%uzthst(1, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell)) else if (this%uzthst(1, icell) > this%thtr(icell) + extwc1) then this%uzthst(1, icell) = this%thtr(icell) + extwc1 - this%uzflst(1, icell) = this%vks(icell) * (((this%uzthst(1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + this%uzflst(1, icell) = & + this%vks(icell) * (((this%uzthst(1, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell)) end if ! ! -- all waves shallower than extinction depth - else if (this%nwavst(icell) > 1 .AND. this%uzdpst(this%nwavst(icell), icell) > this%extdpuz(icell)) then + else if (this%nwavst(icell) > 1 .AND. & + this%uzdpst(this%nwavst(icell), icell) > this%extdpuz(icell)) then if (ietflag == 2) then tho = this%uzthst(this%nwavst(icell), icell) fktho = this%uzflst(this%nwavst(icell), icell) hcap = this%caph(icell, tho) thetaout = this%rate_et_z(icell, factor, fktho, hcap) - end if - if (this%uzthst(this%nwavst(icell), icell) - thetaout > this%thtr(icell) + extwc1) then - this%uzthst(this%nwavst(icell) + 1, icell) = this%uzthst(this%nwavst(icell), icell) - thetaout + end if + if (this%uzthst(this%nwavst(icell), icell) - thetaout > & + this%thtr(icell) + extwc1) then + this%uzthst(this%nwavst(icell) + 1, icell) = & + this%uzthst(this%nwavst(icell), icell) - thetaout numadd = 1 - else if (this%uzthst(this%nwavst(icell), icell) > this%thtr(icell) + extwc1) then + else if (this%uzthst(this%nwavst(icell), icell) > & + this%thtr(icell) + extwc1) then this%uzthst(this%nwavst(icell) + 1, icell) = this%thtr(icell) + extwc1 numadd = 1 end if if (numadd == 1) then - this%uzflst(this%nwavst(icell) + 1, icell) = this%vks(icell) * & - (((this%uzthst(this%nwavst(icell) + 1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + this%uzflst(this%nwavst(icell) + 1, icell) = & + this%vks(icell) * & + (((this%uzthst(this%nwavst(icell) + 1, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell)) theta2 = this%uzthst(this%nwavst(icell) + 1, icell) flux2 = this%uzflst(this%nwavst(icell) + 1, icell) flux1 = this%uzflst(this%nwavst(icell), icell) theta1 = this%uzthst(this%nwavst(icell), icell) - this%uzspst(this%nwavst(icell) + 1, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(this%nwavst(icell) + 1, icell) = & + leadspeed(theta1, theta2, flux1, flux2, this%thts(icell), & + this%thtr(icell), this%eps(icell), this%vks(icell)) this%uzdpst(this%nwavst(icell) + 1, icell) = this%extdpuz(icell) this%nwavst(icell) = this%nwavst(icell) + 1 if (this%nwavst(icell) > this%nwav(icell)) then - ! - ! -- too many waves error, deallocate temp arrays and return + ! + ! -- too many waves error, deallocate temp arrays and return ierr = 1 goto 500 end if else numadd = 0 end if - ! - ! -- one wave below extinction depth + ! + ! -- one wave below extinction depth else if (this%nwavst(icell) == 1) then if (ietflag == 2) then tho = this%uzthst(1, icell) @@ -1995,16 +2013,17 @@ subroutine uzet(this, icell, delt, ietflag, ierr) if ((this%uzthst(1, icell) - thetaout) > this%thtr(icell) + extwc1) then if (thetaout > DEM30) then this%uzthst(2, icell) = this%uzthst(1, icell) - thetaout - this%uzflst(2, icell) = this%vks(icell) * (((this%uzthst(2, icell) - this%thtr(icell)) * & - thtsrinv) ** this%eps(icell)) + this%uzflst(2, icell) = & + this%vks(icell) * (((this%uzthst(2, icell) - this%thtr(icell)) * & + thtsrinv)**this%eps(icell)) this%uzdpst(2, icell) = this%extdpuz(icell) theta2 = this%uzthst(2, icell) flux2 = this%uzflst(2, icell) flux1 = this%uzflst(1, icell) theta1 = this%uzthst(1, icell) - this%uzspst(2, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(2, icell) = & + leadspeed(theta1, theta2, flux1, flux2, this%thts(icell), & + this%thtr(icell), this%eps(icell), this%vks(icell)) this%nwavst(icell) = this%nwavst(icell) + 1 if (this%nwavst(icell) > this%nwav(icell)) then ! @@ -2016,16 +2035,17 @@ subroutine uzet(this, icell, delt, ietflag, ierr) else if (this%uzthst(1, icell) > this%thtr(icell) + extwc1) then if (thetaout > DEM30) then this%uzthst(2, icell) = this%thtr(icell) + extwc1 - this%uzflst(2, icell) = this%vks(icell) * (((this%uzthst(2, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + this%uzflst(2, icell) = & + this%vks(icell) * (((this%uzthst(2, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell)) this%uzdpst(2, icell) = this%extdpuz(icell) theta2 = this%uzthst(2, icell) flux2 = this%uzflst(2, icell) flux1 = this%uzflst(1, icell) theta1 = this%uzthst(1, icell) - this%uzspst(2, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(2, icell) = & + leadspeed(theta1, theta2, flux1, flux2, this%thts(icell), & + this%thtr(icell), this%eps(icell), this%vks(icell)) this%nwavst(icell) = this%nwavst(icell) + 1 if (this%nwavst(icell) > this%nwav(icell)) then ! @@ -2056,7 +2076,8 @@ subroutine uzet(this, icell, delt, ietflag, ierr) ! ! -- create a wave at extinction depth if (abs(diff) > DEM5) then - call this%wave_shift(this, icell, icell, -1, this%nwavst(icell) + 1, j, -1) + call this%wave_shift(this, icell, icell, -1, & + this%nwavst(icell) + 1, j, -1) this%uzdpst(j, icell) = this%extdpuz(icell) this%nwavst(icell) = this%nwavst(icell) + 1 if (this%nwavst(icell) > this%nwav(icell)) then @@ -2064,7 +2085,7 @@ subroutine uzet(this, icell, delt, ietflag, ierr) ! -- too many waves error ierr = 1 goto 500 - end if + end if end if kk = j else @@ -2086,33 +2107,39 @@ subroutine uzet(this, icell, delt, ietflag, ierr) ! ! -- all waves above extinction depth do while (kk <= this%nwavst(icell)) - if (ietflag==2) then + if (ietflag == 2) then tho = this%uzthst(kk, icell) fktho = this%uzflst(kk, icell) hcap = this%caph(icell, tho) thetaout = this%rate_et_z(icell, factor, fktho, hcap) end if if (this%uzthst(kk, icell) > this%thtr(icell) + extwc1) then - if (this%uzthst(kk, icell) - thetaout > this%thtr(icell) + extwc1) then + if (this%uzthst(kk, icell) - thetaout > & + this%thtr(icell) + extwc1) then this%uzthst(kk, icell) = this%uzthst(kk, icell) - thetaout else if (this%uzthst(kk, icell) > this%thtr(icell) + extwc1) then this%uzthst(kk, icell) = this%thtr(icell) + extwc1 end if if (kk == 1) then - this%uzflst(kk, icell) = this%vks(icell) * (((this%uzthst(kk, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell)) + this%uzflst(kk, icell) = & + this%vks(icell) * & + (((this%uzthst(kk, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell)) end if if (kk > 1) then - flux1 = this%vks(icell) * ((this%uzthst(kk - 1, icell) - & - this%thtr(icell)) * thtsrinv) ** this%eps(icell) - flux2 = this%vks(icell) * ((this%uzthst(kk, icell) - this%thtr(icell)) * & - thtsrinv) ** this%eps(icell) + flux1 = & + this%vks(icell) * ((this%uzthst(kk - 1, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell) + flux2 = & + this%vks(icell) * ((this%uzthst(kk, icell) - & + this%thtr(icell)) * thtsrinv)**this%eps(icell) this%uzflst(kk, icell) = flux2 theta2 = this%uzthst(kk, icell) theta1 = this%uzthst(kk - 1, icell) - this%uzspst(kk, icell) = leadspeed(theta1, theta2, flux1, & - flux2, this%thts(icell), this%thtr(icell), this%eps(icell), & - this%vks(icell)) + this%uzspst(kk, icell) = leadspeed(theta1, theta2, flux1, flux2, & + this%thts(icell), & + this%thtr(icell), & + this%eps(icell), this%vks(icell)) end if end if kk = kk + 1 @@ -2123,7 +2150,8 @@ subroutine uzet(this, icell, delt, ietflag, ierr) kj = 1 do while (kj <= this%nwavst(icell) - 1) if (abs(this%uzthst(kj, icell) - this%uzthst(kj + 1, icell)) < DEM6) then - call this%wave_shift(this, icell, icell, 1, kj + 1, this%nwavst(icell) - 1, 1) + call this%wave_shift(this, icell, icell, 1, kj + 1, & + this%nwavst(icell) - 1, 1) kj = kj - 1 this%nwavst(icell) = this%nwavst(icell) - 1 end if @@ -2174,25 +2202,25 @@ function caph(this, icell, tho) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell real(DP), intent(in) :: tho ! -- local - real(DP) :: caph,lambda,star + real(DP) :: caph, lambda, star ! ------------------------------------------------------------------------------ caph = -DEM6 - star = (tho - this%thtr(icell)) / (this%thts(icell) - this%thtr(icell)) + star = (tho - this%thtr(icell)) / (this%thts(icell) - this%thtr(icell)) if (star < DEM15) star = DEM15 - lambda = DTWO / (this%eps(icell) - DTHREE) + lambda = DTWO / (this%eps(icell) - DTHREE) if (star > DEM15) then if (tho - this%thts(icell) < DEM15) then - caph = this%ha(icell) * star ** (-DONE / lambda) + caph = this%ha(icell) * star**(-DONE / lambda) else caph = DZERO end if end if end function caph - + function rate_et_z(this, icell, factor, fktho, h) ! ****************************************************************************** ! rate_et_z---- capillary pressure based uz et @@ -2204,7 +2232,7 @@ function rate_et_z(this, icell, factor, fktho, h) ! -- return real(DP) :: rate_et_z ! -- dummy - class (UzfCellGroupType) :: this + class(UzfCellGroupType) :: this integer(I4B), intent(in) :: icell real(DP), intent(in) :: factor, fktho, h ! -- local @@ -2215,8 +2243,8 @@ end function rate_et_z function get_water_content_at_depth(this, icell, depth) result(theta_at_depth) class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell !< uzf cell containing depth - real(DP), intent(in) :: depth !< depth within the cell + integer(I4B), intent(in) :: icell !< uzf cell containing depth + real(DP), intent(in) :: depth !< depth within the cell real(DP) :: theta_at_depth real(DP) :: d1 real(DP) :: d2 @@ -2229,7 +2257,7 @@ function get_water_content_at_depth(this, icell, depth) result(theta_at_depth) f1 = this%unsat_stor(icell, d1) f2 = this%unsat_stor(icell, d2) theta_at_depth = this%thtr(icell) + (f2 - f1) / (d2 - d1) - else + else theta_at_depth = this%thts(icell) end if else @@ -2237,10 +2265,10 @@ function get_water_content_at_depth(this, icell, depth) result(theta_at_depth) end if return end function get_water_content_at_depth - + function get_wcnew(this, icell) result(watercontent) class(UzfCellGroupType) :: this - integer(I4B), intent(in) :: icell !< uzf cell containing depth + integer(I4B), intent(in) :: icell !< uzf cell containing depth ! real(DP) :: watercontent real(DP) :: top @@ -2252,7 +2280,7 @@ function get_wcnew(this, icell) result(watercontent) real(DP) :: d ! hgwf = this%watab(icell) - top = this%celtop(icell) + top = this%celtop(icell) bot = this%celbot(icell) thk = top - max(bot, hgwf) if (thk > DZERO) then @@ -2266,5 +2294,5 @@ function get_wcnew(this, icell) result(watercontent) end if return end function get_wcnew - -end module UzfCellGroupModule \ No newline at end of file + +end module UzfCellGroupModule diff --git a/src/Model/ModelUtilities/Xt3dAlgorithm.f90 b/src/Model/ModelUtilities/Xt3dAlgorithm.f90 index d31a60ec689..19bbb70191e 100644 --- a/src/Model/ModelUtilities/Xt3dAlgorithm.f90 +++ b/src/Model/ModelUtilities/Xt3dAlgorithm.f90 @@ -7,11 +7,11 @@ module Xt3dAlgorithmModule use ConstantsModule, only: DPREC, DONE implicit none - contains - - subroutine qconds(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & - nnbr1,inbr1,il10,vc1,vn1,dl1,dl1n,ck1,ar01,ar10, & - vcthresh,allhc0,allhc1,chat01,chati0,chat1j) +contains + + subroutine qconds(nnbrmx, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, ck0, & + nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + vcthresh, allhc0, allhc1, chat01, chati0, chat1j) ! ****************************************************************************** ! !.....Compute the "conductances" in the normal-flux expression for an @@ -101,40 +101,40 @@ subroutine qconds(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & !.....If area ar01 is zero (in which case ar10 is also zero, since ! this can only happen here in the case of Newton), then the ! "conductances" are all zero. - if (ar01.eq.0d0) then + if (ar01 .eq. 0d0) then chat01 = 0d0 - do i=1,nnbrmx - chati0(i) = 0d0 - chat1j(i) = 0d0 - enddo + do i = 1, nnbrmx + chati0(i) = 0d0 + chat1j(i) = 0d0 + end do !.....Else compute "conductances." else !........Compute contributions from cell 0. - call abhats(nnbrmx,nnbr0,inbr0,il01,vc0,vn0,dl0,dl0n,ck0, & - vcthresh,allhc0,ar01,ahat0,bhat0) + call abhats(nnbrmx, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, ck0, & + vcthresh, allhc0, ar01, ahat0, bhat0) !........Compute contributions from cell 1. - call abhats(nnbrmx,nnbr1,inbr1,il10,vc1,vn1,dl1,dl1n,ck1, & - vcthresh,allhc1,ar10,ahat1,bhat1) + call abhats(nnbrmx, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, & + vcthresh, allhc1, ar10, ahat1, bhat1) !........Compute "conductances" based on the two flux estimates. denom = (ahat0 + ahat1) if (abs(denom) > DPREC) then - wght1 = ahat0/(ahat0 + ahat1) + wght1 = ahat0 / (ahat0 + ahat1) else wght1 = DONE end if wght0 = 1d0 - wght1 - chat01 = wght1*ahat1 - do i=1,nnbrmx - chati0(i) = wght0*bhat0(i) - chat1j(i) = wght1*bhat1(i) - enddo + chat01 = wght1 * ahat1 + do i = 1, nnbrmx + chati0(i) = wght0 * bhat0(i) + chat1j(i) = wght1 * bhat1(i) + end do end if ! return - end subroutine qconds + end subroutine qconds - subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & - vcthresh,allhc,ar01,ahat,bhat) + subroutine abhats(nnbrmx, nnbr, inbr, il01, vc, vn, dl0, dln, ck, & + vcthresh, allhc, ar01, ahat, bhat) ! ****************************************************************************** !.....Compute "ahat" and "bhat" coefficients for one side of an ! interface. @@ -151,7 +151,7 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & real(DP), dimension(nnbrmx, 3) :: vn real(DP), dimension(nnbrmx) :: dl0 real(DP), dimension(nnbrmx) :: dln - real(DP), dimension(3, 3) :: ck + real(DP), dimension(3, 3) :: ck real(DP) :: vcthresh logical :: allhc real(DP) :: ar01 @@ -160,9 +160,9 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & ! -- local logical :: iscomp real(DP), dimension(nnbrmx, 3) :: vccde - real(DP), dimension(3, 3) :: rmat - real(DP), dimension(3) :: sigma - real(DP), dimension(nnbrmx) :: bd + real(DP), dimension(3, 3) :: rmat + real(DP), dimension(3) :: sigma + real(DP), dimension(nnbrmx) :: bd real(DP), dimension(nnbrmx) :: be real(DP), dimension(nnbrmx) :: betad real(DP), dimension(nnbrmx) :: betae @@ -187,13 +187,13 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & ! coordinates to (c, d, e) coordinates. (If no active ! connection is found that has a non-negligible component ! perpendicular to the primary connection, ilmo=0 is returned.) - call getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) + call getrot(nnbrmx, nnbr, inbr, vc, il01, rmat, iml0) ! !.....If no active connection with a non-negligible perpendicular ! component, assume no perpendicular gradient and base gradient ! solely on the primary connection. Otherwise, proceed with ! basing weights on information from neighboring connections. - if (iml0.eq.0) then + if (iml0 .eq. 0) then ! !........Compute ahat and bhat coefficients assuming perpendicular ! components of gradient are zero. @@ -206,11 +206,11 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & !........Transform local connection unit-vectors from model coordinates ! to "(c, d, e)" coordinates associated with the connection ! between cells 0 and 1. - call tranvc(nnbrmx,nnbr,rmat,vc,vccde) + call tranvc(nnbrmx, nnbr, rmat, vc, vccde) ! !........Get "a" and "b" weights for first perpendicular direction. - call abwts(nnbrmx,nnbr,inbr,il01,2,vccde, & - vcthresh,dl0,dln,acd,add,aed,bd) + call abwts(nnbrmx, nnbr, inbr, il01, 2, vccde, & + vcthresh, dl0, dln, acd, add, aed, bd) ! !........If all neighboring connections are user-designated as ! horizontal, or if none have a non-negligible component in @@ -234,8 +234,8 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & end if end do if (iscomp) then - call abwts(nnbrmx,nnbr,inbr,il01,3,vccde, & - vcthresh,dl0,dln,ace,aee,ade,be) + call abwts(nnbrmx, nnbr, inbr, il01, 3, vccde, & + vcthresh, dl0, dln, ace, aee, ade, be) else ace = 0d0 aee = 1d0 @@ -245,36 +245,36 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & end if ! !........Compute alpha and beta coefficients. - determ = add * aee - ade * aed - oodet = 1d0 / determ - alphad = (acd * aee - ace * aed) * oodet - alphae = (ace * add - acd * ade) * oodet - betad = 0d0 - betae = 0d0 - do il = 1, nnbr + determ = add * aee - ade * aed + oodet = 1d0 / determ + alphad = (acd * aee - ace * aed) * oodet + alphae = (ace * add - acd * ade) * oodet + betad = 0d0 + betae = 0d0 + do il = 1, nnbr !...........If this is connection (0,1) or inactive, skip. - if ((il == il01) .or. (inbr(il) == 0)) cycle - betad(il) = (bd(il) * aee - be(il) * aed) * oodet - betae(il) = (be(il) * add - bd(il) * ade) * oodet - end do + if ((il == il01) .or. (inbr(il) == 0)) cycle + betad(il) = (bd(il) * aee - be(il) * aed) * oodet + betae(il) = (be(il) * add - bd(il) * ade) * oodet + end do ! !........Compute sigma coefficients. - sigma = matmul(vn(il01, :), matmul(ck, rmat)) + sigma = matmul(vn(il01, :), matmul(ck, rmat)) ! !........Compute ahat and bhat coefficients. - ahat = (sigma(1) - sigma(2) * alphad - sigma(3) * alphae) / dl0(il01) - bhat = 0d0 - do il = 1, nnbr + ahat = (sigma(1) - sigma(2) * alphad - sigma(3) * alphae) / dl0(il01) + bhat = 0d0 + do il = 1, nnbr !...........If this is connection (0,1) or inactive, skip. - if ((il == il01) .or. (inbr(il) == 0)) cycle - dl0il = dl0(il) + dln(il) - bhat(il) = (sigma(2) * betad(il) + sigma(3) * betae(il)) / dl0il - end do + if ((il == il01) .or. (inbr(il) == 0)) cycle + dl0il = dl0(il) + dln(il) + bhat(il) = (sigma(2) * betad(il) + sigma(3) * betae(il)) / dl0il + end do !........Set the bhat for connection (0,1) to zero here, since we have ! been skipping it in our do loops to avoiding explicitly ! computing it. This will carry through to the corresponding ! chati0 and chat1j value, so that they too are zero. - bhat(il01) = 0d0 + bhat(il01) = 0d0 ! end if ! @@ -285,7 +285,7 @@ subroutine abhats(nnbrmx,nnbr,inbr,il01,vc,vn,dl0,dln,ck, & return end subroutine abhats - subroutine getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) + subroutine getrot(nnbrmx, nnbr, inbr, vc, il01, rmat, iml0) ! ****************************************************************************** !.....Compute the matrix that rotates the model-coordinate axes to ! the "(c, d, e)-coordinate" axes associated with a connection. @@ -329,7 +329,7 @@ subroutine getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) ! ------------------------------------------------------------------------------ ! !.....set vcc. - vcc(:) = vc(il01,:) + vcc(:) = vc(il01, :) ! !.....Set vcmax. (If no connection has a perpendicular component ! greater than some tiny threshold, return with iml0=0 and @@ -338,23 +338,23 @@ subroutine getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) acmpmn = 1d0 - 1d-10 iml0 = 0 do il = 1, nnbr - if ((il.eq.il01).or.(inbr(il).eq.0)) then + if ((il .eq. il01) .or. (inbr(il) .eq. 0)) then cycle else - cmp = dot_product(vc(il,:), vcc) + cmp = dot_product(vc(il, :), vcc) acmp = dabs(cmp) - if (acmp.lt.acmpmn) then + if (acmp .lt. acmpmn) then cmpmn = cmp acmpmn = acmp iml0 = il end if end if - enddo + end do if (iml0 == 0) then - rmat(:,1) = vcc(:) - goto 999 + rmat(:, 1) = vcc(:) + goto 999 else - vcmax(:) = vc(iml0,:) + vcmax(:) = vc(iml0, :) end if ! !.....Set the first perpendicular direction as the direction that is @@ -364,20 +364,20 @@ subroutine getrot(nnbrmx,nnbr,inbr,vc,il01,rmat,iml0) ! !.....Set the second perpendicular direction as the cross product of ! the primary and first-perpendicular directions. - vce(1) = vcc(2)*vcd(3) - vcc(3)*vcd(2) - vce(2) = vcc(3)*vcd(1) - vcc(1)*vcd(3) - vce(3) = vcc(1)*vcd(2) - vcc(2)*vcd(1) + vce(1) = vcc(2) * vcd(3) - vcc(3) * vcd(2) + vce(2) = vcc(3) * vcd(1) - vcc(1) * vcd(3) + vce(3) = vcc(1) * vcd(2) - vcc(2) * vcd(1) ! !.....Set the rotation matrix as the matrix with vcc, vcd, and vce ! as its columns. - rmat(:,1) = vcc(:) - rmat(:,2) = vcd(:) - rmat(:,3) = vce(:) + rmat(:, 1) = vcc(:) + rmat(:, 2) = vcd(:) + rmat(:, 3) = vce(:) ! 999 return end subroutine getrot - subroutine tranvc(nnbrmx,nnbrs,rmat,vc,vccde) + subroutine tranvc(nnbrmx, nnbrs, rmat, vc, vccde) ! ****************************************************************************** !.....Transform local connection unit-vectors from model coordinates ! to "(c, d, e)" coordinates associated with a connection. @@ -408,14 +408,14 @@ subroutine tranvc(nnbrmx,nnbrs,rmat,vc,vccde) ! rotation matrix so that the transformation is from model ! to (c, d, e) coordinates. do il = 1, nnbrs - vccde(il,:) = matmul(transpose(rmat), vc(il,:)) - enddo + vccde(il, :) = matmul(transpose(rmat), vc(il, :)) + end do ! return end subroutine tranvc - subroutine abwts(nnbrmx,nnbr,inbr,il01,nde1,vccde, & - vcthresh,dl0,dln,acd,add,aed,bd) + subroutine abwts(nnbrmx, nnbr, inbr, il01, nde1, vccde, & + vcthresh, dl0, dln, acd, add, aed, bd) ! ****************************************************************************** !.....Compute "a" and "b" weights for the local connections with respect ! to the perpendicular direction of primary interest. @@ -463,76 +463,76 @@ subroutine abwts(nnbrmx,nnbr,inbr,il01,nde1,vccde, & ! ------------------------------------------------------------------------------ ! !.....Set the perpendicular direction of secondary interest. - nde2 = 5 - nde1 + nde2 = 5 - nde1 ! !.....Begin computing "omega" weights. - omwt = 0d0 - dsum = 0d0 - vcmx = 0d0 - do il = 1, nnbr + omwt = 0d0 + dsum = 0d0 + vcmx = 0d0 + do il = 1, nnbr !........if this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - vcmx = max(dabs(vccde(il,nde1)), vcmx) - dlm = 5d-1*(dl0(il) + dln(il)) + if ((il .eq. il01) .or. (inbr(il) .eq. 0)) cycle + vcmx = max(dabs(vccde(il, nde1)), vcmx) + dlm = 5d-1 * (dl0(il) + dln(il)) !...........Distance-based weighting. dl4wt is the distance between ! the point supplying the gradient information and the ! point at which the flux is being estimated. Could be ! coded as a special case of resistance-based weighting ! (by setting the conductivity matrix to be the identity ! matrix), but this is more efficient. - cosang = vccde(il,1) - dl4wt = dsqrt(dlm*dlm + dl0(il01)*dl0(il01) & - - 2d0*dlm*dl0(il01)*cosang) - omwt(il) = dabs(vccde(il,nde1))*dl4wt - dsum = dsum + omwt(il) - end do + cosang = vccde(il, 1) + dl4wt = dsqrt(dlm * dlm + dl0(il01) * dl0(il01) & + - 2d0 * dlm * dl0(il01) * cosang) + omwt(il) = dabs(vccde(il, nde1)) * dl4wt + dsum = dsum + omwt(il) + end do ! !.....Finish computing non-normalized "omega" weights. [Add a ! tiny bit to dsum so that the normalized omega weight later ! evaluates to (essentially) 1 in the case of a single relevant ! connection, avoiding 0/0.] - dsum = dsum + 1d-10*dsum - do il = 1, nnbr + dsum = dsum + 1d-10 * dsum + do il = 1, nnbr !........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - fact = dsum - omwt(il) - omwt(il) = fact*dabs(vccde(il,nde1)) - end do + if ((il .eq. il01) .or. (inbr(il) .eq. 0)) cycle + fact = dsum - omwt(il) + omwt(il) = fact * dabs(vccde(il, nde1)) + end do ! !.....Compute "b" weights. - bd = 0d0 - dsum = 0d0 - do il = 1, nnbr + bd = 0d0 + dsum = 0d0 + do il = 1, nnbr !........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - bd(il) = omwt(il)*sign(1d0,vccde(il,nde1)) - dsum = dsum + omwt(il)*dabs(vccde(il,nde1)) - end do - oodsum = 1d0/dsum - do il = 1, nnbr + if ((il .eq. il01) .or. (inbr(il) .eq. 0)) cycle + bd(il) = omwt(il) * sign(1d0, vccde(il, nde1)) + dsum = dsum + omwt(il) * dabs(vccde(il, nde1)) + end do + oodsum = 1d0 / dsum + do il = 1, nnbr !........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - bd(il) = bd(il)*oodsum - end do + if ((il .eq. il01) .or. (inbr(il) .eq. 0)) cycle + bd(il) = bd(il) * oodsum + end do ! !.....Compute "a" weights. - add = 1d0 - acd = 0d0 - aed = 0d0 - do il = 1, nnbr + add = 1d0 + acd = 0d0 + aed = 0d0 + do il = 1, nnbr !........If this is connection (0,1) or inactive, skip. - if ((il.eq.il01).or.(inbr(il).eq.0)) cycle - acd = acd + bd(il)*vccde(il,1) - aed = aed + bd(il)*vccde(il,nde2) - end do + if ((il .eq. il01) .or. (inbr(il) .eq. 0)) cycle + acd = acd + bd(il) * vccde(il, 1) + aed = aed + bd(il) * vccde(il, nde2) + end do ! !.....Apply attenuation function to acd, aed, and bd. - if (vcmx.lt.vcthresh) then - fatten = vcmx/vcthresh - acd = acd*fatten - aed = aed*fatten - bd = bd*fatten - end if + if (vcmx .lt. vcthresh) then + fatten = vcmx / vcthresh + acd = acd * fatten + aed = aed * fatten + bd = bd * fatten + end if ! end subroutine abwts ! diff --git a/src/Model/ModelUtilities/Xt3dInterface.f90 b/src/Model/ModelUtilities/Xt3dInterface.f90 index e4f3a830730..abfc35665d3 100644 --- a/src/Model/ModelUtilities/Xt3dInterface.f90 +++ b/src/Model/ModelUtilities/Xt3dInterface.f90 @@ -1,52 +1,52 @@ module Xt3dModule - - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, DHALF, DONE, LENMEMPATH - use BaseDisModule, only: DisBaseType - use MemoryHelperModule, only: create_mem_path + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DHALF, DONE, LENMEMPATH + use BaseDisModule, only: DisBaseType + use MemoryHelperModule, only: create_mem_path implicit none public Xt3dType public :: xt3d_cr - - type Xt3dType - character(len=LENMEMPATH) :: memoryPath !< location in memory manager for storing package variables - integer(I4B), pointer :: inunit => null() !< unit number from where xt3d was read - integer(I4B), pointer :: iout => null() !< unit number for output - integer(I4B), pointer :: inewton => null() !< Newton flag - integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - integer(I4B),dimension(:), pointer, contiguous :: iax => null() !< ia array for extended neighbors used by xt3d - integer(I4B),dimension(:), pointer, contiguous :: jax => null() !< ja array for extended neighbors used by xt3d - integer(I4B),dimension(:), pointer, contiguous :: idxglox => null() !< mapping array for extended neighbors used by xt3d - integer(I4B),dimension(:), pointer, contiguous :: ia_xt3d => null() !< ia array for local extended xt3d connections (no diagonal) - integer(I4B),dimension(:), pointer, contiguous :: ja_xt3d => null() !< ja array for local extended xt3d connections (no diagonal) - integer(I4B), pointer :: numextnbrs => null() !< dimension of jax array - integer(I4B), pointer :: ixt3d => null() !< xt3d flag (0 is off, 1 is lhs, 2 is rhs) - logical, pointer :: nozee => null() !< nozee flag - real(DP), pointer :: vcthresh => null() !< attenuation function threshold - real(DP), dimension(:,:), pointer, contiguous :: rmatck => null() !< rotation matrix for the conductivity tensor - real(DP), dimension(:), pointer, contiguous :: qsat => null() !< saturated flow saved for Newton - integer(I4B), pointer :: nbrmax => null() !< maximum number of neighbors for any cell - real(DP), dimension(:), pointer, contiguous :: amatpc => null() !< saved contributions to amat from permanently confined connections, direct neighbors - real(DP), dimension(:), pointer, contiguous :: amatpcx => null() !< saved contributions to amat from permanently confined connections, extended neighbors - integer(I4B), dimension(:), pointer, contiguous :: iallpc => null() !< indicates for each node whether all connections processed by xt3d are permanently confined (0 no, 1 yes) - logical, pointer :: lamatsaved => null() !< indicates whether amat has been saved for permanently confined connections - class(DisBaseType), pointer :: dis => null() !< discretization object + + type Xt3dType + character(len=LENMEMPATH) :: memoryPath !< location in memory manager for storing package variables + integer(I4B), pointer :: inunit => null() !< unit number from where xt3d was read + integer(I4B), pointer :: iout => null() !< unit number for output + integer(I4B), pointer :: inewton => null() !< Newton flag + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + integer(I4B), dimension(:), pointer, contiguous :: iax => null() !< ia array for extended neighbors used by xt3d + integer(I4B), dimension(:), pointer, contiguous :: jax => null() !< ja array for extended neighbors used by xt3d + integer(I4B), dimension(:), pointer, contiguous :: idxglox => null() !< mapping array for extended neighbors used by xt3d + integer(I4B), dimension(:), pointer, contiguous :: ia_xt3d => null() !< ia array for local extended xt3d connections (no diagonal) + integer(I4B), dimension(:), pointer, contiguous :: ja_xt3d => null() !< ja array for local extended xt3d connections (no diagonal) + integer(I4B), pointer :: numextnbrs => null() !< dimension of jax array + integer(I4B), pointer :: ixt3d => null() !< xt3d flag (0 is off, 1 is lhs, 2 is rhs) + logical, pointer :: nozee => null() !< nozee flag + real(DP), pointer :: vcthresh => null() !< attenuation function threshold + real(DP), dimension(:, :), pointer, contiguous :: rmatck => null() !< rotation matrix for the conductivity tensor + real(DP), dimension(:), pointer, contiguous :: qsat => null() !< saturated flow saved for Newton + integer(I4B), pointer :: nbrmax => null() !< maximum number of neighbors for any cell + real(DP), dimension(:), pointer, contiguous :: amatpc => null() !< saved contributions to amat from permanently confined connections, direct neighbors + real(DP), dimension(:), pointer, contiguous :: amatpcx => null() !< saved contributions to amat from permanently confined connections, extended neighbors + integer(I4B), dimension(:), pointer, contiguous :: iallpc => null() !< indicates for each node whether all connections processed by xt3d are permanently confined (0 no, 1 yes) + logical, pointer :: lamatsaved => null() !< indicates whether amat has been saved for permanently confined connections + class(DisBaseType), pointer :: dis => null() !< discretization object ! pointers to npf variables - real(DP), dimension(:), pointer, contiguous :: k11 => null() !< horizontal hydraulic conductivity - real(DP), dimension(:),pointer, contiguous :: k22 => null() !< minor axis of horizontal hydraulic conductivity ellipse - real(DP), dimension(:), pointer, contiguous :: k33 => null() !< vertical hydraulic conductivity - integer(I4B), pointer :: ik22 => null() !< flag indicates K22 was read - integer(I4B), pointer :: ik33 => null() !< flag indicates K33 was read - real(DP), dimension(:), pointer, contiguous :: sat => null() !< saturation (0. to 1.) for each cell - integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< cell type (confined or unconfined) - integer(I4B), pointer :: iangle1 => null() !< flag to indicate angle1 was read - integer(I4B), pointer :: iangle2 => null() !< flag to indicate angle2 was read - integer(I4B), pointer :: iangle3 => null() !< flag to indicate angle3 was read - real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< k ellipse rotation in xy plane around z axis (yaw) - real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< k ellipse rotation up from xy plane around y axis (pitch) - real(DP), dimension(:), pointer, contiguous :: angle3 => null() !< k tensor rotation around x axis (roll) - logical, pointer :: ldispersion => null() !< flag to indicate dispersion + real(DP), dimension(:), pointer, contiguous :: k11 => null() !< horizontal hydraulic conductivity + real(DP), dimension(:), pointer, contiguous :: k22 => null() !< minor axis of horizontal hydraulic conductivity ellipse + real(DP), dimension(:), pointer, contiguous :: k33 => null() !< vertical hydraulic conductivity + integer(I4B), pointer :: ik22 => null() !< flag indicates K22 was read + integer(I4B), pointer :: ik33 => null() !< flag indicates K33 was read + real(DP), dimension(:), pointer, contiguous :: sat => null() !< saturation (0. to 1.) for each cell + integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< cell type (confined or unconfined) + integer(I4B), pointer :: iangle1 => null() !< flag to indicate angle1 was read + integer(I4B), pointer :: iangle2 => null() !< flag to indicate angle2 was read + integer(I4B), pointer :: iangle3 => null() !< flag to indicate angle3 was read + real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< k ellipse rotation in xy plane around z axis (yaw) + real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< k ellipse rotation up from xy plane around y axis (pitch) + real(DP), dimension(:), pointer, contiguous :: angle3 => null() !< k tensor rotation around x axis (roll) + logical, pointer :: ldispersion => null() !< flag to indicate dispersion contains procedure :: xt3d_df procedure :: xt3d_ac @@ -76,8 +76,8 @@ module Xt3dModule procedure, private :: xt3d_fillrmatck procedure, private :: xt3d_qnbrs end type Xt3dType - - contains + +contains subroutine xt3d_cr(xt3dobj, name_model, inunit, iout, ldispopt) ! ****************************************************************************** @@ -95,9 +95,9 @@ subroutine xt3d_cr(xt3dobj, name_model, inunit, iout, ldispopt) ! ------------------------------------------------------------------------------ ! ! -- Create the object - allocate(xt3dobj) + allocate (xt3dobj) ! - + ! -- assign the memory path xt3dobj%memoryPath = create_mem_path(name_model, 'XT3D') ! @@ -106,7 +106,7 @@ subroutine xt3d_cr(xt3dobj, name_model, inunit, iout, ldispopt) ! ! -- Set variables xt3dobj%inunit = inunit - xt3dobj%iout = iout + xt3dobj%iout = iout if (present(ldispopt)) xt3dobj%ldispersion = ldispopt ! ! -- Return @@ -131,7 +131,7 @@ subroutine xt3d_df(this, dis) ! -- Return return end subroutine xt3d_df - + subroutine xt3d_ac(this, moffset, sparse) ! ****************************************************************************** ! xt3d_ac -- Add connections for extended neighbors to the sparse matrix @@ -156,56 +156,58 @@ subroutine xt3d_ac(this, moffset, sparse) ! -- If not rhs, add connections if (this%ixt3d == 1) then - ! -- assume nnz is 19, which is an approximate value - ! based on a 3d structured grid - nnz = 19 - call sparse_xt3d%init(this%dis%nodes, this%dis%nodes, nnz) - - ! -- loop over nodes and store extended xt3d neighbors - ! temporarily in sparse_xt3d; this will be converted to - ! ia_xt3d and ja_xt3d next - do i = 1, this%dis%nodes - iglo = i + moffset - ! -- loop over neighbors - do jj = this%dis%con%ia(i) + 1, this%dis%con%ia(i+1) - 1 - j = this%dis%con%ja(jj) - ! -- loop over neighbors of neighbors - do kk = this%dis%con%ia(j) + 1, this%dis%con%ia(j+1) - 1 - k = this%dis%con%ja(kk) - kglo = k + moffset - call sparse_xt3d%addconnection(i, k, 1) - enddo - enddo - enddo - - ! -- calculate ia_xt3d and ja_xt3d from sparse_xt3d and - ! then destroy sparse - call mem_allocate(this%ia_xt3d, this%dis%nodes+1, 'IA_XT3D', trim(this%memoryPath)) - call mem_allocate(this%ja_xt3d, sparse_xt3d%nnz, 'JA_XT3D', trim(this%memoryPath)) - call sparse_xt3d%filliaja(this%ia_xt3d, this%ja_xt3d, ierror) - call sparse_xt3d%destroy() - ! - ! -- add extended neighbors to sparse and count number of - ! extended neighbors - do i = 1, this%dis%nodes - iglo = i + moffset - do kk = this%ia_xt3d(i), this%ia_xt3d(i+1)-1 - k = this%ja_xt3d(kk) - kglo = k + moffset - call sparse%addconnection(iglo, kglo, 1, iadded) - this%numextnbrs = this%numextnbrs + 1 - end do - end do + ! -- assume nnz is 19, which is an approximate value + ! based on a 3d structured grid + nnz = 19 + call sparse_xt3d%init(this%dis%nodes, this%dis%nodes, nnz) + + ! -- loop over nodes and store extended xt3d neighbors + ! temporarily in sparse_xt3d; this will be converted to + ! ia_xt3d and ja_xt3d next + do i = 1, this%dis%nodes + iglo = i + moffset + ! -- loop over neighbors + do jj = this%dis%con%ia(i) + 1, this%dis%con%ia(i + 1) - 1 + j = this%dis%con%ja(jj) + ! -- loop over neighbors of neighbors + do kk = this%dis%con%ia(j) + 1, this%dis%con%ia(j + 1) - 1 + k = this%dis%con%ja(kk) + kglo = k + moffset + call sparse_xt3d%addconnection(i, k, 1) + end do + end do + end do + + ! -- calculate ia_xt3d and ja_xt3d from sparse_xt3d and + ! then destroy sparse + call mem_allocate(this%ia_xt3d, this%dis%nodes + 1, 'IA_XT3D', & + trim(this%memoryPath)) + call mem_allocate(this%ja_xt3d, sparse_xt3d%nnz, 'JA_XT3D', & + trim(this%memoryPath)) + call sparse_xt3d%filliaja(this%ia_xt3d, this%ja_xt3d, ierror) + call sparse_xt3d%destroy() + ! + ! -- add extended neighbors to sparse and count number of + ! extended neighbors + do i = 1, this%dis%nodes + iglo = i + moffset + do kk = this%ia_xt3d(i), this%ia_xt3d(i + 1) - 1 + k = this%ja_xt3d(kk) + kglo = k + moffset + call sparse%addconnection(iglo, kglo, 1, iadded) + this%numextnbrs = this%numextnbrs + 1 + end do + end do else - ! -- Arrays not needed; set to size zero - call mem_allocate(this%ia_xt3d, 0, 'IA_XT3D', trim(this%memoryPath)) - call mem_allocate(this%ja_xt3d, 0, 'JA_XT3D', trim(this%memoryPath)) - endif + ! -- Arrays not needed; set to size zero + call mem_allocate(this%ia_xt3d, 0, 'IA_XT3D', trim(this%memoryPath)) + call mem_allocate(this%ja_xt3d, 0, 'JA_XT3D', trim(this%memoryPath)) + end if ! ! -- Return return end subroutine xt3d_ac - + subroutine xt3d_mc(this, moffset, iasln, jasln) ! ****************************************************************************** ! xt3d_mc -- Map connections and construct iax, jax, and idxglox @@ -261,14 +263,14 @@ subroutine xt3d_mc(this, moffset, iasln, jasln) jglo = jasln(jjg) if (jglo < igfirstnod .or. jglo > iglastnod) then cycle - endif + end if ! ! -- Check to see if this local connection was added by ! xt3d. If not, then this connection was added by ! something else, such as an interface model. j = jglo - moffset isextnbr = .false. - do jj_xt3d = this%ia_xt3d(i), this%ia_xt3d(i+1) - 1 + do jj_xt3d = this%ia_xt3d(i), this%ia_xt3d(i + 1) - 1 if (j == this%ja_xt3d(jj_xt3d)) then isextnbr = .true. exit @@ -280,11 +282,11 @@ subroutine xt3d_mc(this, moffset, iasln, jasln) this%jax(ipos) = jasln(jjg) - moffset this%idxglox(ipos) = jjg ipos = ipos + 1 - endif - enddo + end if + end do ! -- load next iax entry - this%iax(i+1) = ipos - enddo + this%iax(i + 1) = ipos + end do ! else ! @@ -292,14 +294,14 @@ subroutine xt3d_mc(this, moffset, iasln, jasln) call mem_allocate(this%jax, 0, 'JAX', trim(this%memoryPath)) call mem_allocate(this%idxglox, 0, 'IDXGLOX', trim(this%memoryPath)) ! - endif + end if ! ! -- Return return end subroutine xt3d_mc - - subroutine xt3d_ar(this, ibound, k11, ik33, k33, sat, ik22, k22, & - iangle1, iangle2, iangle3, angle1, angle2, angle3, inewton, icelltype) + + subroutine xt3d_ar(this, ibound, k11, ik33, k33, sat, ik22, k22, iangle1, & + iangle2, iangle3, angle1, angle2, angle3, inewton, icelltype) ! ****************************************************************************** ! xt3d_ar -- Allocate and Read ! ****************************************************************************** @@ -329,18 +331,18 @@ subroutine xt3d_ar(this, ibound, k11, ik33, k33, sat, ik22, k22, & ! -- local integer(I4B) :: n, nnbrs ! -- formats - character(len=*), parameter :: fmtheader = & - "(1x, /1x, 'XT3D is active.'//)" + character(len=*), parameter :: fmtheader = & + "(1x, /1x, 'XT3D is active.'//)" ! -- data ! ------------------------------------------------------------------------------ ! ! -- Print a message identifying the xt3d module. if (this%iout > 0) then - write(this%iout, fmtheader) + write (this%iout, fmtheader) end if ! ! -- Store pointers to arguments that were passed in - this%ibound => ibound + this%ibound => ibound this%k11 => k11 this%ik33 => ik33 this%k33 => k33 @@ -359,44 +361,44 @@ subroutine xt3d_ar(this, ibound, k11, ik33, k33, sat, ik22, k22, & end if if (present(icelltype)) then ! -- icelltype is not needed for transport, so it's optional. - ! It is only needed to determine if cell connections are permanently + ! It is only needed to determine if cell connections are permanently ! confined, which means that some matrix terms can be precalculated this%icelltype => icelltype end if ! ! -- If angle1 and angle2 were not specified, then there is no z ! component in the xt3d formulation for horizontal connections. - if(this%iangle2 == 0) this%nozee = .true. + if (this%iangle2 == 0) this%nozee = .true. ! ! -- Determine the maximum number of neighbors for any cell. this%nbrmax = 0 do n = 1, this%dis%nodes - nnbrs = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbrs = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 this%nbrmax = max(nnbrs, this%nbrmax) end do ! ! -- Check to make sure dis package can calculate connection direction info if (this%dis%icondir == 0) then - call store_error('Vertices not specified for discretization ' // & - 'package, but XT3D is active: '// trim(adjustl(this%memoryPath)) // & - '. Vertices must be specified in discretization package in order ' // & - 'to use XT3D.', terminate=.TRUE.) - endif + call store_error('Vertices not specified for discretization package, '// & + 'but XT3D is active: '//trim(adjustl(this%memoryPath))// & + '. Vertices must be specified in discretization '// & + 'package in order to use XT3D.', terminate=.TRUE.) + end if ! ! -- Check to make sure ANGLEDEGX is available for interface normals if (this%dis%con%ianglex == 0) then - call store_error('ANGLDEGX is not specified in the DIS ' // & - 'package, but XT3D is active: '// trim(adjustl(this%memoryPath)) // & - '. ANGLDEGX must be provided in discretization package in order ' // & - 'to use XT3D.', terminate=.TRUE.) - endif + call store_error('ANGLDEGX is not specified in the DIS package, '// & + 'but XT3D is active: '//trim(adjustl(this%memoryPath))// & + '. ANGLDEGX must be provided in discretization '// & + 'package in order to use XT3D.', terminate=.TRUE.) + end if ! ! -- allocate arrays call this%allocate_arrays() ! - ! -- If not Newton and not rhs, precalculate amatpc and amatpcx for + ! -- If not Newton and not rhs, precalculate amatpc and amatpcx for ! -- permanently confined connections - if(this%lamatsaved .and. .not. this%ldispersion) & + if (this%lamatsaved .and. .not. this%ldispersion) & call this%xt3d_fcpc(this%dis%nodes, .true.) ! ! -- Return @@ -415,11 +417,11 @@ subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! -- dummy class(Xt3dType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(:) :: idxglo - real(DP),intent(inout),dimension(:) :: rhs - real(DP),intent(inout),dimension(:) :: hnew + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amat + integer(I4B), intent(in), dimension(:) :: idxglo + real(DP), intent(inout), dimension(:) :: rhs + real(DP), intent(inout), dimension(:) :: hnew ! -- local integer(I4B) :: nodes, nja integer(I4B) :: n, m, ipos @@ -428,13 +430,13 @@ subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) integer(I4B) :: nnbr0, nnbr1 integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 integer(I4B) :: i - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B), dimension(this%nbrmax) :: inbr0, inbr1 real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 + real(DP), dimension(this%nbrmax, 3) :: vc0, vn0, vc1, vn1 + real(DP), dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP), dimension(3, 3) :: ck0, ck1 real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP), dimension(this%nbrmax) :: chati0, chat1j real(DP) :: qnm, qnbrs ! ------------------------------------------------------------------------------ ! @@ -454,31 +456,31 @@ subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) ! do n = 1, nodes ! -- Skip if inactive. - if (this%ibound(n).eq.0) cycle + if (this%ibound(n) .eq. 0) cycle ! -- Skip if all connections are permanently confined if (this%lamatsaved) then if (this%iallpc(n) == 1) cycle end if - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) ! -- Loop over active neighbors of cell 0 that have a higher ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 + do il0 = 1, nnbr0 ipos = this%dis%con%ia(n) + il0 if (this%dis%con%mask(ipos) == 0) cycle - + m = inbr0(il0) ! -- Skip if neighbor is inactive or has lower cell number. - if ((m.eq.0).or.(m.lt.n)) cycle - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 - ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) + if ((m .eq. 0) .or. (m .lt. n)) cycle + nnbr1 = this%dis%con%ia(m + 1) - this%dis%con%ia(m) - 1 + ! -- Load conductivity and connection info for cell 1. + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! -- Compute areas. if (this%inewton /= 0) then ar01 = DONE @@ -488,15 +490,15 @@ subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) end if ! -- Compute "conductances" for interface between ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, ck0, & + nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) ! -- If Newton, compute and save saturated flow, then scale ! -- conductance-like coefficients by the actual area for ! -- subsequent amat and rhs assembly. if (this%inewton /= 0) then ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) + qnm = chat01 * (hnew(m) - hnew(n)) ! -- Contribution from immediate neighbors of node 0. call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) qnm = qnm + qnbrs @@ -505,12 +507,12 @@ subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) qnm = qnm - qnbrs ! -- Multiply by saturated area and save in qsat. call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) - this%qsat(ii01) = qnm*ar01 + this%qsat(ii01) = qnm * ar01 ! -- Scale coefficients by actual area. call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - chat01 = chat01*ar01 - chati0 = chati0*ar01 - chat1j = chat1j*ar01 + chat01 = chat01 * ar01 + chati0 = chati0 * ar01 + chat1j = chat1j * ar01 end if ! -- Contribute to rows for cells 0 and 1. amat(idxglo(ii00)) = amat(idxglo(ii00)) - chat01 @@ -518,21 +520,21 @@ subroutine xt3d_fc(this, kiter, njasln, amat, idxglo, rhs, hnew) amat(idxglo(ii11)) = amat(idxglo(ii11)) - chat01 amat(idxglo(ii10)) = amat(idxglo(ii10)) + chat01 if (this%ixt3d == 1) then - call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) - call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) + call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) + call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) else - call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) - call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) - endif + call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) + call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) + end if ! - enddo - enddo + end do + end do ! ! -- Return return @@ -551,29 +553,29 @@ subroutine xt3d_fcpc(this, nodes, lsat) ! -- dummy class(Xt3dType) :: this integer(I4B), intent(in) :: nodes - logical, intent(in) :: lsat !< if true, then calculations made with saturated areas (should be false for dispersion) + logical, intent(in) :: lsat !< if true, then calculations made with saturated areas (should be false for dispersion) ! -- local integer(I4B) :: n, m, ipos ! logical :: allhc0, allhc1 integer(I4B) :: nnbr0, nnbr1 integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B), dimension(this%nbrmax) :: inbr0, inbr1 real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 + real(DP), dimension(this%nbrmax, 3) :: vc0, vn0, vc1, vn1 + real(DP), dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP), dimension(3, 3) :: ck0, ck1 real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP), dimension(this%nbrmax) :: chati0, chat1j ! ------------------------------------------------------------------------------ ! ! -- Initialize amatpc and amatpcx to zero do n = 1, size(this%amatpc) this%amatpc(n) = DZERO - enddo + end do do n = 1, size(this%amatpcx) this%amatpcx(n) = DZERO - enddo + end do ! ! -- Calculate xt3d conductance-like coefficients for permanently confined ! -- connections and put into amatpc and amatpcx as appropriate @@ -581,33 +583,33 @@ subroutine xt3d_fcpc(this, nodes, lsat) ! -- Skip if not iallpc. if (this%iallpc(n) == 0) cycle if (this%ibound(n) == 0) cycle - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) ! -- Loop over active neighbors of cell 0 that have a higher ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 + do il0 = 1, nnbr0 ipos = this%dis%con%ia(n) + il0 if (this%dis%con%mask(ipos) == 0) cycle - + m = inbr0(il0) ! -- Skip if neighbor has lower cell number. - if (m.lt.n) cycle - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + if (m .lt. n) cycle + nnbr1 = this%dis%con%ia(m + 1) - this%dis%con%ia(m) - 1 ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! -- Compute confined areas. call this%xt3d_areas(nodes, n, m, jjs01, lsat, ar01, ar10) ! -- Compute "conductances" for interface between ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, ck0, & + nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) ! -- Contribute to rows for cells 0 and 1. this%amatpc(ii00) = this%amatpc(ii00) - chat01 this%amatpc(ii01) = this%amatpc(ii01) + chat01 @@ -617,15 +619,15 @@ subroutine xt3d_fcpc(this, nodes, lsat) call this%xt3d_amatpcx_nbrnbrs(nodes, n, m, ii01, nnbr1, inbr1, chat1j) call this%xt3d_amatpc_nbrs(nodes, m, ii11, nnbr1, inbr1, chat1j) call this%xt3d_amatpcx_nbrnbrs(nodes, m, n, ii10, nnbr0, inbr0, chati0) - enddo - enddo + end do + end do ! ! -- Return return end subroutine xt3d_fcpc subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & - n, m, condhfb) + n, m, condhfb) ! ****************************************************************************** ! xt3d_fhfb -- Formulate HFB correction ! ****************************************************************************** @@ -637,27 +639,27 @@ subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & ! -- dummy class(Xt3dType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - integer(I4B),intent(in) :: njasln + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: njasln integer(I4B) :: n, m - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),intent(inout),dimension(nodes) :: rhs - real(DP),intent(inout),dimension(nodes) :: hnew + real(DP), dimension(njasln), intent(inout) :: amat + integer(I4B), intent(in), dimension(nja) :: idxglo + real(DP), intent(inout), dimension(nodes) :: rhs + real(DP), intent(inout), dimension(nodes) :: hnew real(DP) :: condhfb ! -- local ! logical :: allhc0, allhc1 integer(I4B) :: nnbr0, nnbr1 integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10, il - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B), dimension(this%nbrmax) :: inbr0, inbr1 real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 + real(DP), dimension(this%nbrmax, 3) :: vc0, vn0, vc1, vn1 + real(DP), dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP), dimension(3, 3) :: ck0, ck1 real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP), dimension(this%nbrmax) :: chati0, chat1j real(DP) :: qnm, qnbrs real(DP) :: term ! ------------------------------------------------------------------------------ @@ -665,24 +667,24 @@ subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & ! -- Calculate hfb corrections to xt3d conductance-like coefficients and ! -- put into amat and rhs as appropriate ! - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) ! -- Find local neighbor number of cell 1. - do il = 1,nnbr0 - if (inbr0(il).eq.m) then + do il = 1, nnbr0 + if (inbr0(il) .eq. m) then il0 = il exit end if end do - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + nnbr1 = this%dis%con%ia(m + 1) - this%dis%con%ia(m) - 1 ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! -- Compute areas. if (this%inewton /= 0) then ar01 = DONE @@ -692,24 +694,24 @@ subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & end if ! -- Compute "conductances" for interface between ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) ! -- Apply scale factor to compute "conductances" for hfb correction - if(condhfb > DZERO) then - term = chat01/(chat01 + condhfb) + if (condhfb > DZERO) then + term = chat01 / (chat01 + condhfb) else term = -condhfb - endif - chat01 = -chat01*term - chati0 = -chati0*term - chat1j = -chat1j*term + end if + chat01 = -chat01 * term + chati0 = -chati0 * term + chat1j = -chat1j * term ! -- If Newton, compute and save saturated flow, then scale ! -- conductance-like coefficients by the actual area for ! -- subsequent amat and rhs assembly. if (this%inewton /= 0) then ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) + qnm = chat01 * (hnew(m) - hnew(n)) ! -- Contribution from immediate neighbors of node 0. call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) qnm = qnm + qnbrs @@ -718,12 +720,12 @@ subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & qnm = qnm - qnbrs ! -- Multiply by saturated area and add correction to qsat. call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) - this%qsat(ii01) = this%qsat(ii01) + qnm*ar01 + this%qsat(ii01) = this%qsat(ii01) + qnm * ar01 ! -- Scale coefficients by actual area. call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - chat01 = chat01*ar01 - chati0 = chati0*ar01 - chat1j = chat1j*ar01 + chat01 = chat01 * ar01 + chati0 = chati0 * ar01 + chat1j = chat1j * ar01 end if ! -- Contribute to rows for cells 0 and 1. amat(idxglo(ii00)) = amat(idxglo(ii00)) - chat01 @@ -731,18 +733,18 @@ subroutine xt3d_fhfb(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew, & amat(idxglo(ii11)) = amat(idxglo(ii11)) - chat01 amat(idxglo(ii10)) = amat(idxglo(ii10)) + chat01 if (this%ixt3d == 1) then - call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) - call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & - inbr1, amat, idxglo, chat1j) - call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & - inbr0, amat, idxglo, chati0) + call this%xt3d_amat_nbrs(nodes, n, ii00, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) + call this%xt3d_amat_nbrnbrs(nodes, n, m, ii01, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrs(nodes, m, ii11, nnbr1, nja, njasln, & + inbr1, amat, idxglo, chat1j) + call this%xt3d_amat_nbrnbrs(nodes, m, n, ii10, nnbr0, nja, njasln, & + inbr0, amat, idxglo, chati0) else - call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) - call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) - endif + call this%xt3d_rhs(nodes, n, m, nnbr0, inbr0, chati0, hnew, rhs) + call this%xt3d_rhs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, rhs) + end if ! ! -- Return return @@ -760,19 +762,19 @@ subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) ! -- dummy class(Xt3dType) :: this integer(I4B) :: kiter - integer(I4B),intent(in) :: nodes - integer(I4B),intent(in) :: nja - integer(I4B),intent(in) :: njasln - real(DP),dimension(njasln),intent(inout) :: amat - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),intent(inout),dimension(nodes) :: rhs - real(DP),intent(inout),dimension(nodes) :: hnew + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amat + integer(I4B), intent(in), dimension(nja) :: idxglo + real(DP), intent(inout), dimension(nodes) :: rhs + real(DP), intent(inout), dimension(nodes) :: hnew ! -- local integer(I4B) :: n, m, ipos ! integer(I4B) :: nnbr0 integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B),dimension(this%nbrmax) :: inbr0 + integer(I4B), dimension(this%nbrmax) :: inbr0 integer(I4B) :: iups, idn real(DP) :: topup, botup, derv, term ! ------------------------------------------------------------------------------ @@ -780,28 +782,28 @@ subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) ! -- Update amat and rhs with Newton terms do n = 1, nodes ! -- Skip if inactive. - if (this%ibound(n).eq.0) cycle + if (this%ibound(n) .eq. 0) cycle ! -- No Newton correction if amat saved (which implies no rhs option) ! -- and all connections for the cell are permanently confined. if (this%lamatsaved) then if (this%iallpc(n) == 1) cycle end if - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 ! -- Load neighbors of cell. Set cell numbers for inactive ! -- neighbors to zero. call this%xt3d_load_inbr(n, nnbr0, inbr0) ! -- Loop over active neighbors of cell 0 that have a higher ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 + do il0 = 1, nnbr0 ipos = this%dis%con%ia(n) + il0 if (this%dis%con%mask(ipos) == 0) cycle - + m = inbr0(il0) ! -- Skip if neighbor is inactive or has lower cell number. - if ((inbr0(il0).eq.0).or.(m.lt.n)) cycle + if ((inbr0(il0) .eq. 0) .or. (m .lt. n)) cycle ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! determine upstream node iups = m if (hnew(m) < hnew(n)) iups = n @@ -809,15 +811,15 @@ subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) if (iups == n) idn = m ! -- no Newton terms if upstream cell is confined ! -- and no rhs option - if ((this%icelltype(iups) == 0).and.(this%ixt3d.eq.1)) cycle + if ((this%icelltype(iups) == 0) .and. (this%ixt3d .eq. 1)) cycle ! -- Set the upstream top and bot, and then recalculate for a ! vertically staggered horizontal connection topup = this%dis%top(iups) botup = this%dis%bot(iups) - if(this%dis%con%ihc(jjs01) == 2) then + if (this%dis%con%ihc(jjs01) == 2) then topup = min(this%dis%top(n), this%dis%top(m)) botup = max(this%dis%bot(n), this%dis%bot(m)) - endif + end if ! derivative term derv = sQuadraticSaturationDerivative(topup, botup, hnew(iups)) term = this%qsat(ii01) * derv @@ -829,7 +831,7 @@ subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) ! fill in row of m amat(idxglo(ii10)) = amat(idxglo(ii10)) - term rhs(m) = rhs(m) - term * hnew(n) - ! fill Jacobian for m being the upstream node + ! fill Jacobian for m being the upstream node else ! fill in row of n amat(idxglo(ii01)) = amat(idxglo(ii01)) + term @@ -838,8 +840,8 @@ subroutine xt3d_fn(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew) amat(idxglo(ii11)) = amat(idxglo(ii11)) - term rhs(m) = rhs(m) - term * hnew(m) end if - enddo - enddo + end do + end do ! ! -- Return return @@ -855,56 +857,56 @@ subroutine xt3d_flowja(this, hnew, flowja) use Xt3dAlgorithmModule, only: qconds ! -- dummy class(Xt3dType) :: this - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja + real(DP), intent(inout), dimension(:) :: hnew + real(DP), intent(inout), dimension(:) :: flowja ! -- local integer(I4B) :: n, ipos, m, nodes real(DP) :: qnm, qnbrs logical :: allhc0, allhc1 integer(I4B) :: nnbr0, nnbr1 integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10 - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B), dimension(this%nbrmax) :: inbr0, inbr1 real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 + real(DP), dimension(this%nbrmax, 3) :: vc0, vn0, vc1, vn1 + real(DP), dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP), dimension(3, 3) :: ck0, ck1 real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP), dimension(this%nbrmax) :: chati0, chat1j ! ------------------------------------------------------------------------------ ! ! -- Calculate the flow across each cell face and store in flowja nodes = this%dis%nodes do n = 1, nodes ! -- Skip if inactive. - if (this%ibound(n).eq.0) cycle - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + if (this%ibound(n) .eq. 0) cycle + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) ! -- Loop over active neighbors of cell 0 that have a higher ! -- cell number (taking advantage of reciprocity). - do il0 = 1,nnbr0 + do il0 = 1, nnbr0 m = inbr0(il0) ! -- Skip if neighbor is inactive or has lower cell number. - if ((inbr0(il0).eq.0).or.(m.lt.n)) cycle - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + if ((inbr0(il0) .eq. 0) .or. (m .lt. n)) cycle + nnbr1 = this%dis%con%ia(m + 1) - this%dis%con%ia(m) - 1 ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! -- Compute areas. - if (this%inewton /= 0) & + if (this%inewton /= 0) & call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) ! -- Compute "conductances" for interface between ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, ck0, & + nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) + qnm = chat01 * (hnew(m) - hnew(n)) ! -- Contribution from immediate neighbors of node 0. call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) qnm = qnm + qnbrs @@ -913,9 +915,9 @@ subroutine xt3d_flowja(this, hnew, flowja) qnm = qnm - qnbrs ipos = ii01 flowja(ipos) = flowja(ipos) + qnm - flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - qnm - enddo - enddo + flowja(this%dis%con%isym(ipos)) = flowja(this%dis%con%isym(ipos)) - qnm + end do + end do ! ! -- Return return @@ -933,8 +935,8 @@ subroutine xt3d_flowjahfb(this, n, m, hnew, flowja, condhfb) ! -- dummy class(Xt3dType) :: this integer(I4B) :: n, m - real(DP),intent(inout),dimension(:) :: hnew - real(DP),intent(inout),dimension(:) :: flowja + real(DP), intent(inout), dimension(:) :: hnew + real(DP), intent(inout), dimension(:) :: flowja real(DP) :: condhfb ! -- local ! @@ -943,14 +945,14 @@ subroutine xt3d_flowjahfb(this, n, m, hnew, flowja, condhfb) !!! integer(I4B), parameter :: nbrmax = 10 integer(I4B) :: nnbr0, nnbr1 integer(I4B) :: il0, ii01, jjs01, il01, il10, ii00, ii11, ii10, il - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B), dimension(this%nbrmax) :: inbr0, inbr1 integer(I4B) :: ipos real(DP) :: ar01, ar10 - real(DP),dimension(this%nbrmax,3) :: vc0, vn0, vc1, vn1 - real(DP),dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n - real(DP),dimension(3,3) :: ck0, ck1 + real(DP), dimension(this%nbrmax, 3) :: vc0, vn0, vc1, vn1 + real(DP), dimension(this%nbrmax) :: dl0, dl0n, dl1, dl1n + real(DP), dimension(3, 3) :: ck0, ck1 real(DP) :: chat01 - real(DP),dimension(this%nbrmax) :: chati0, chat1j + real(DP), dimension(this%nbrmax) :: chati0, chat1j real(DP) :: qnm, qnbrs real(DP) :: term ! ------------------------------------------------------------------------------ @@ -959,24 +961,24 @@ subroutine xt3d_flowjahfb(this, n, m, hnew, flowja, condhfb) ! -- put into amat and rhs as appropriate ! nodes = this%dis%nodes - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 ! -- Load conductivity and connection info for cell 0. - call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & - ck0, allhc0) + call this%xt3d_load(nodes, n, nnbr0, inbr0, vc0, vn0, dl0, dl0n, & + ck0, allhc0) ! -- Find local neighbor number of cell 1. - do il = 1,nnbr0 - if (inbr0(il).eq.m) then + do il = 1, nnbr0 + if (inbr0(il) .eq. m) then il0 = il exit end if end do - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + nnbr1 = this%dis%con%ia(m + 1) - this%dis%con%ia(m) - 1 ! -- Load conductivity and connection info for cell 1. - call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & - ck1, allhc1) + call this%xt3d_load(nodes, m, nnbr1, inbr1, vc1, vn1, dl1, dl1n, & + ck1, allhc1) ! -- Set various indices. - call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + call this%xt3d_indices(n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! -- Compute areas. if (this%inewton /= 0) then ar01 = DONE @@ -986,32 +988,32 @@ subroutine xt3d_flowjahfb(this, n, m, hnew, flowja, condhfb) end if ! -- Compute "conductances" for interface between ! -- cells 0 and 1. - call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & - ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & - this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) + call qconds(this%nbrmax, nnbr0, inbr0, il01, vc0, vn0, dl0, dl0n, & + ck0, nnbr1, inbr1, il10, vc1, vn1, dl1, dl1n, ck1, ar01, ar10, & + this%vcthresh, allhc0, allhc1, chat01, chati0, chat1j) ! -- Apply scale factor to compute "conductances" for hfb correction - if(condhfb > DZERO) then - term = chat01/(chat01 + condhfb) + if (condhfb > DZERO) then + term = chat01 / (chat01 + condhfb) else term = -condhfb - endif - chat01 = -chat01*term - chati0 = -chati0*term - chat1j = -chat1j*term + end if + chat01 = -chat01 * term + chati0 = -chati0 * term + chat1j = -chat1j * term ! -- Contribution to flow from primary connection. - qnm = chat01*(hnew(m) - hnew(n)) + qnm = chat01 * (hnew(m) - hnew(n)) ! -- Contribution from immediate neighbors of node 0. call this%xt3d_qnbrs(nodes, n, m, nnbr0, inbr0, chati0, hnew, qnbrs) qnm = qnm + qnbrs ! -- Contribution from immediate neighbors of node 1. call this%xt3d_qnbrs(nodes, m, n, nnbr1, inbr1, chat1j, hnew, qnbrs) qnm = qnm - qnbrs - ! -- If Newton, scale conductance-like coefficients by the + ! -- If Newton, scale conductance-like coefficients by the ! -- actual area. if (this%inewton /= 0) then call this%xt3d_areas(nodes, n, m, jjs01, .true., ar01, ar10, hnew) call this%xt3d_areas(nodes, n, m, jjs01, .false., ar01, ar10, hnew) - qnm = qnm*ar01 + qnm = qnm * ar01 end if ipos = ii01 flowja(ipos) = flowja(ipos) + qnm @@ -1033,7 +1035,7 @@ subroutine xt3d_da(this) ! -- dummy class(Xt3dType) :: this ! ------------------------------------------------------------------------------ - ! + ! ! -- Deallocate arrays if (this%ixt3d /= 0) then call mem_deallocate(this%iax) @@ -1046,7 +1048,7 @@ subroutine xt3d_da(this) call mem_deallocate(this%amatpc) call mem_deallocate(this%amatpcx) call mem_deallocate(this%iallpc) - endif + end if ! ! -- Scalars call mem_deallocate(this%ixt3d) @@ -1088,7 +1090,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%vcthresh, 'VCTHRESH', this%memoryPath) call mem_allocate(this%lamatsaved, 'LAMATSAVED', this%memoryPath) call mem_allocate(this%ldispersion, 'LDISPERSION', this%memoryPath) - ! + ! ! -- Initialize value this%ixt3d = 0 this%nbrmax = 0 @@ -1146,7 +1148,7 @@ subroutine allocate_arrays(this) ! permanently confined and precalculate matrix terms case where ! conductances do not depend on head call this%xt3d_iallpc() - endif + end if ! ! -- Allocate space for precalculated matrix terms if (this%lamatsaved) then @@ -1188,10 +1190,10 @@ subroutine xt3d_iallpc(this) ! -- local integer(I4B) :: n, m, mm, il0, il1 integer(I4B) :: nnbr0, nnbr1 - integer(I4B),dimension(this%nbrmax) :: inbr0, inbr1 + integer(I4B), dimension(this%nbrmax) :: inbr0, inbr1 ! ------------------------------------------------------------------------------ ! - if(this%ixt3d == 2) then + if (this%ixt3d == 2) then this%lamatsaved = .false. call mem_allocate(this%iallpc, 0, 'IALLPC', this%memoryPath) else @@ -1209,28 +1211,28 @@ subroutine xt3d_iallpc(this) this%iallpc(n) = 0 cycle end if - nnbr0 = this%dis%con%ia(n+1) - this%dis%con%ia(n) - 1 + nnbr0 = this%dis%con%ia(n + 1) - this%dis%con%ia(n) - 1 call this%xt3d_load_inbr(n, nnbr0, inbr0) - do il0 = 1,nnbr0 + do il0 = 1, nnbr0 m = inbr0(il0) - if (m.lt.n) cycle + if (m .lt. n) cycle if (this%icelltype(m) /= 0) then this%iallpc(n) = 0 this%iallpc(m) = 0 cycle end if - nnbr1 = this%dis%con%ia(m+1) - this%dis%con%ia(m) - 1 + nnbr1 = this%dis%con%ia(m + 1) - this%dis%con%ia(m) - 1 call this%xt3d_load_inbr(m, nnbr1, inbr1) - do il1 = 1,nnbr1 + do il1 = 1, nnbr1 mm = inbr1(il1) if (this%icelltype(mm) /= 0) then this%iallpc(n) = 0 this%iallpc(m) = 0 this%iallpc(mm) = 0 end if - enddo - enddo - enddo + end do + end do + end do ! ! -- If any cells have all permanently confined connections then ! performance can be improved by precalculating coefficients @@ -1241,10 +1243,10 @@ subroutine xt3d_iallpc(this) this%lamatsaved = .true. exit end if - enddo + end do end if ! - if (.not.this%lamatsaved) then + if (.not. this%lamatsaved) then call mem_deallocate(this%iallpc) call mem_allocate(this%iallpc, 0, 'IALLPC', this%memoryPath) end if @@ -1252,9 +1254,9 @@ subroutine xt3d_iallpc(this) ! -- Return return end subroutine xt3d_iallpc - - subroutine xt3d_indices(this, n, m, il0, ii01, jjs01, il01, il10, & - ii00, ii11, ii10) + + subroutine xt3d_indices(this, n, m, il0, ii01, jjs01, il01, il10, & + ii00, ii11, ii10) ! ****************************************************************************** ! xt3d_indices -- Set various indices for XT3D. ! ****************************************************************************** @@ -1303,12 +1305,12 @@ subroutine xt3d_load(this, nodes, n, nnbr, inbr, vc, vn, dl, dln, ck, allhc) ! -- dummy class(Xt3dType) :: this logical :: allhc - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax,3) :: vc, vn - real(DP),dimension(this%nbrmax) :: dl, dln - real(DP),dimension(3,3) :: ck + integer(I4B), dimension(this%nbrmax) :: inbr + real(DP), dimension(this%nbrmax, 3) :: vc, vn + real(DP), dimension(this%nbrmax) :: dl, dln + real(DP), dimension(3, 3) :: ck ! -- local integer(I4B) :: il, ii, jj, jjs integer(I4B) :: ihcnjj @@ -1318,17 +1320,17 @@ subroutine xt3d_load(this, nodes, n, nnbr, inbr, vc, vn, dl, dln, ck, allhc) ! ! -- Set conductivity tensor for cell. ck = DZERO - ck(1,1) = this%k11(n) - if(this%ik22 == 0) then - ck(2,2) = ck(1,1) + ck(1, 1) = this%k11(n) + if (this%ik22 == 0) then + ck(2, 2) = ck(1, 1) else - ck(2,2) = this%k22(n) + ck(2, 2) = this%k22(n) end if - if(this%ik33 == 0) then - ck(3,3) = ck(1,1) + if (this%ik33 == 0) then + ck(3, 3) = ck(1, 1) else - ck(3,3) = this%k33(n) - endif + ck(3, 3) = this%k33(n) + end if call this%xt3d_fillrmatck(n) ck = matmul(this%rmatck, ck) ck = matmul(ck, transpose(this%rmatck)) @@ -1339,31 +1341,31 @@ subroutine xt3d_load(this, nodes, n, nnbr, inbr, vc, vn, dl, dln, ck, allhc) ! -- lengths. Also determine if all active connections are ! -- horizontal. allhc = .true. - do il = 1,nnbr + do il = 1, nnbr ii = il + this%dis%con%ia(n) jj = this%dis%con%ja(ii) jjs = this%dis%con%jas(ii) - if (this%ibound(jj).ne.0) then + if (this%ibound(jj) .ne. 0) then inbr(il) = jj satn = this%sat(n) satjj = this%sat(jj) ! -- DISV and DIS ihcnjj = this%dis%con%ihc(jjs) - call this%dis%connection_normal(n, jj, ihcnjj, & - vn(il, 1), vn(il, 2), vn(il, 3), ii) - call this%dis%connection_vector(n, jj, this%nozee, satn, satjj, & - ihcnjj, vc(il, 1), vc(il, 2), vc(il, 3), dltot) - if(jj > n) then + call this%dis%connection_normal(n, jj, ihcnjj, vn(il, 1), vn(il, 2), & + vn(il, 3), ii) + call this%dis%connection_vector(n, jj, this%nozee, satn, satjj, ihcnjj, & + vc(il, 1), vc(il, 2), vc(il, 3), dltot) + if (jj > n) then cl1njj = this%dis%con%cl1(jjs) cl2njj = this%dis%con%cl2(jjs) else cl1njj = this%dis%con%cl2(jjs) cl2njj = this%dis%con%cl1(jjs) - endif - ooclsum = 1d0/(cl1njj + cl2njj) - dl(il) = dltot*cl1njj*ooclsum - dln(il) = dltot*cl2njj*ooclsum - if (this%dis%con%ihc(jjs).eq.0) allhc = .false. + end if + ooclsum = 1d0 / (cl1njj + cl2njj) + dl(il) = dltot * cl1njj * ooclsum + dln(il) = dltot * cl2njj * ooclsum + if (this%dis%con%ihc(jjs) .eq. 0) allhc = .false. else inbr(il) = 0 end if @@ -1371,7 +1373,7 @@ subroutine xt3d_load(this, nodes, n, nnbr, inbr, vc, vn, dl, dln, ck, allhc) ! return end subroutine xt3d_load - + subroutine xt3d_load_inbr(this, n, nnbr, inbr) ! ****************************************************************************** ! xt3d_load_inbr -- Load neighbor list for a cell. @@ -1383,17 +1385,17 @@ subroutine xt3d_load_inbr(this, n, nnbr, inbr) ! -- dummy class(Xt3dType) :: this integer(I4B) :: n, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr + integer(I4B), dimension(this%nbrmax) :: inbr ! -- local integer(I4B) :: il, ii, jj ! ------------------------------------------------------------------------------ ! ! -- Load neighbors of cell. Set cell numbers for inactive ! -- neighbors to zero so xt3d knows to ignore them. - do il = 1,nnbr + do il = 1, nnbr ii = il + this%dis%con%ia(n) jj = this%dis%con%ja(ii) - if (this%ibound(jj).ne.0) then + if (this%ibound(jj) .ne. 0) then inbr(il) = jj else inbr(il) = 0 @@ -1441,7 +1443,7 @@ subroutine xt3d_areas(this, nodes, n, m, jjs01, lsat, ar01, ar10, hnew) botm = this%dis%bot(m) thksatn = topn - botn thksatm = topm - botm - if (this%dis%con%ihc(jjs01).eq.2) then + if (this%dis%con%ihc(jjs01) .eq. 2) then ! -- vertically staggered sill_top = min(topn, topm) sill_bot = max(botn, botm) @@ -1461,7 +1463,7 @@ subroutine xt3d_areas(this, nodes, n, m, jjs01, lsat, ar01, ar10, hnew) else satups = this%sat(m) end if - ar01 = ar01*satups + ar01 = ar01 * satups end if ar10 = ar01 else @@ -1488,13 +1490,13 @@ subroutine xt3d_areas(this, nodes, n, m, jjs01, lsat, ar01, ar10, hnew) end if ar01 = this%dis%con%hwva(jjs01) * thksatn ar10 = this%dis%con%hwva(jjs01) * thksatm - endif + end if ! return end subroutine xt3d_areas - subroutine xt3d_amat_nbrs(this, nodes, n, idiag, nnbr, nja, & - njasln, inbr, amat, idxglo, chat) + subroutine xt3d_amat_nbrs(this, nodes, n, idiag, nnbr, nja, & + njasln, inbr, amat, idxglo, chat) ! ****************************************************************************** ! xt3d_amat_nbrs -- Add contributions from neighbors to amat. ! ****************************************************************************** @@ -1504,29 +1506,29 @@ subroutine xt3d_amat_nbrs(this, nodes, n, idiag, nnbr, nja, & ! -- module ! -- dummy class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, idiag, nnbr, nja, njasln - integer(I4B),dimension(this%nbrmax) :: inbr - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),dimension(njasln),intent(inout) :: amat - real(DP),dimension(this%nbrmax) :: chat + integer(I4B), dimension(this%nbrmax) :: inbr + integer(I4B), intent(in), dimension(nja) :: idxglo + real(DP), dimension(njasln), intent(inout) :: amat + real(DP), dimension(this%nbrmax) :: chat ! -- local integer(I4B) :: iil, iii ! ------------------------------------------------------------------------------ ! - do iil = 1,nnbr - if (inbr(iil).ne.0) then + do iil = 1, nnbr + if (inbr(iil) .ne. 0) then iii = this%dis%con%ia(n) + iil amat(idxglo(idiag)) = amat(idxglo(idiag)) - chat(iil) - amat(idxglo(iii)) = amat(idxglo(iii)) + chat(iil) - endif - enddo + amat(idxglo(iii)) = amat(idxglo(iii)) + chat(iil) + end if + end do ! return end subroutine xt3d_amat_nbrs - subroutine xt3d_amat_nbrnbrs(this, nodes, n, m, ii01, nnbr, nja, & - njasln, inbr, amat, idxglo, chat) + subroutine xt3d_amat_nbrnbrs(this, nodes, n, m, ii01, nnbr, nja, & + njasln, inbr, amat, idxglo, chat) ! ****************************************************************************** ! xt3d_amat_nbrnbrs -- Add contributions from neighbors of neighbor to amat. ! ****************************************************************************** @@ -1536,30 +1538,30 @@ subroutine xt3d_amat_nbrnbrs(this, nodes, n, m, ii01, nnbr, nja, & ! -- module ! -- dummy class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, m, ii01, nnbr, nja, njasln - integer(I4B),dimension(this%nbrmax) :: inbr - integer(I4B),intent(in),dimension(nja) :: idxglo - real(DP),dimension(njasln),intent(inout) :: amat - real(DP),dimension(this%nbrmax) :: chat + integer(I4B), dimension(this%nbrmax) :: inbr + integer(I4B), intent(in), dimension(nja) :: idxglo + real(DP), dimension(njasln), intent(inout) :: amat + real(DP), dimension(this%nbrmax) :: chat ! -- local integer(I4B) :: iil, iii, jjj, iixjjj, iijjj ! ------------------------------------------------------------------------------ ! - do iil = 1,nnbr - if (inbr(iil).ne.0) then + do iil = 1, nnbr + if (inbr(iil) .ne. 0) then amat(idxglo(ii01)) = amat(idxglo(ii01)) + chat(iil) iii = this%dis%con%ia(m) + iil jjj = this%dis%con%ja(iii) call this%xt3d_get_iinmx(n, jjj, iixjjj) - if (iixjjj.ne.0) then + if (iixjjj .ne. 0) then amat(this%idxglox(iixjjj)) = amat(this%idxglox(iixjjj)) - chat(iil) else call this%xt3d_get_iinm(n, jjj, iijjj) amat(idxglo(iijjj)) = amat(idxglo(iijjj)) - chat(iil) - endif - endif - enddo + end if + end if + end do ! return end subroutine xt3d_amat_nbrnbrs @@ -1574,19 +1576,19 @@ subroutine xt3d_amatpc_nbrs(this, nodes, n, idiag, nnbr, inbr, chat) ! -- module ! -- dummy class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, idiag, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax) :: chat + integer(I4B), dimension(this%nbrmax) :: inbr + real(DP), dimension(this%nbrmax) :: chat ! -- local integer(I4B) :: iil, iii ! ------------------------------------------------------------------------------ ! - do iil = 1,nnbr + do iil = 1, nnbr iii = this%dis%con%ia(n) + iil this%amatpc(idiag) = this%amatpc(idiag) - chat(iil) - this%amatpc(iii) = this%amatpc(iii) + chat(iil) - enddo + this%amatpc(iii) = this%amatpc(iii) + chat(iil) + end do ! return end subroutine xt3d_amatpc_nbrs @@ -1602,26 +1604,26 @@ subroutine xt3d_amatpcx_nbrnbrs(this, nodes, n, m, ii01, nnbr, inbr, chat) ! -- module ! -- dummy class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, m, ii01, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax) :: chat + integer(I4B), dimension(this%nbrmax) :: inbr + real(DP), dimension(this%nbrmax) :: chat ! -- local integer(I4B) :: iil, iii, jjj, iixjjj, iijjj ! ------------------------------------------------------------------------------ ! - do iil = 1,nnbr + do iil = 1, nnbr this%amatpc(ii01) = this%amatpc(ii01) + chat(iil) iii = this%dis%con%ia(m) + iil jjj = this%dis%con%ja(iii) call this%xt3d_get_iinmx(n, jjj, iixjjj) - if (iixjjj.ne.0) then + if (iixjjj .ne. 0) then this%amatpcx(iixjjj) = this%amatpcx(iixjjj) - chat(iil) else call this%xt3d_get_iinm(n, jjj, iijjj) this%amatpc(iijjj) = this%amatpc(iijjj) - chat(iil) - endif - enddo + end if + end do ! return end subroutine xt3d_amatpcx_nbrnbrs @@ -1643,13 +1645,13 @@ subroutine xt3d_get_iinm(this, n, m, iinm) ! ------------------------------------------------------------------------------ ! iinm = 0 - do ii = this%dis%con%ia(n), this%dis%con%ia(n+1)-1 + do ii = this%dis%con%ia(n), this%dis%con%ia(n + 1) - 1 jj = this%dis%con%ja(ii) - if (jj.eq.m) then + if (jj .eq. m) then iinm = ii exit - endif - enddo + end if + end do ! return end subroutine xt3d_get_iinm @@ -1671,19 +1673,19 @@ subroutine xt3d_get_iinmx(this, n, m, iinmx) ! ------------------------------------------------------------------------------ ! iinmx = 0 - do iix = this%iax(n), this%iax(n+1)-1 + do iix = this%iax(n), this%iax(n + 1) - 1 jjx = this%jax(iix) - if (jjx.eq.m) then + if (jjx .eq. m) then iinmx = iix exit - endif - enddo + end if + end do ! return end subroutine xt3d_get_iinmx - subroutine xt3d_rhs(this, nodes, n, m, nnbr, inbr, chat, hnew, & - rhs) + subroutine xt3d_rhs(this, nodes, n, m, nnbr, inbr, chat, hnew, & + rhs) ! ****************************************************************************** ! xt3d_rhs -- Add contributions to rhs. ! ****************************************************************************** @@ -1693,31 +1695,31 @@ subroutine xt3d_rhs(this, nodes, n, m, nnbr, inbr, chat, hnew, & ! -- module ! -- dummy class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, m, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr - real(DP),dimension(this%nbrmax) :: chat - real(DP),intent(inout),dimension(nodes) :: hnew, rhs + integer(I4B), dimension(this%nbrmax) :: inbr + real(DP), dimension(this%nbrmax) :: chat + real(DP), intent(inout), dimension(nodes) :: hnew, rhs ! -- local integer(I4B) :: iil, iii, jjj real(DP) :: term ! ------------------------------------------------------------------------------ ! - do iil = 1,nnbr - if (inbr(iil).ne.0) then + do iil = 1, nnbr + if (inbr(iil) .ne. 0) then iii = iil + this%dis%con%ia(n) jjj = this%dis%con%ja(iii) - term = chat(iil)*(hnew(jjj)-hnew(n)) + term = chat(iil) * (hnew(jjj) - hnew(n)) rhs(n) = rhs(n) - term rhs(m) = rhs(m) + term - endif - enddo + end if + end do ! return end subroutine xt3d_rhs - subroutine xt3d_qnbrs(this, nodes, n, m, nnbr, inbr, chat, hnew, & - qnbrs) + subroutine xt3d_qnbrs(this, nodes, n, m, nnbr, inbr, chat, hnew, & + qnbrs) ! ****************************************************************************** ! xt3d_qnbrs -- Add contributions to flow from neighbors. ! ****************************************************************************** @@ -1727,26 +1729,26 @@ subroutine xt3d_qnbrs(this, nodes, n, m, nnbr, inbr, chat, hnew, & ! -- module ! -- dummy class(Xt3dType) :: this - integer(I4B),intent(in) :: nodes + integer(I4B), intent(in) :: nodes integer(I4B) :: n, m, nnbr - integer(I4B),dimension(this%nbrmax) :: inbr + integer(I4B), dimension(this%nbrmax) :: inbr real(DP) :: qnbrs - real(DP),dimension(this%nbrmax) :: chat - real(DP),intent(inout),dimension(nodes) :: hnew + real(DP), dimension(this%nbrmax) :: chat + real(DP), intent(inout), dimension(nodes) :: hnew ! -- local integer(I4B) :: iil, iii, jjj real(DP) :: term ! ------------------------------------------------------------------------------ ! qnbrs = 0d0 - do iil = 1,nnbr - if (inbr(iil).ne.0) then + do iil = 1, nnbr + if (inbr(iil) .ne. 0) then iii = iil + this%dis%con%ia(n) jjj = this%dis%con%ja(iii) - term = chat(iil)*(hnew(jjj)-hnew(n)) + term = chat(iil) * (hnew(jjj) - hnew(n)) qnbrs = qnbrs + term - endif - enddo + end if + end do ! return end subroutine xt3d_qnbrs @@ -1778,24 +1780,24 @@ subroutine xt3d_fillrmatck(this, n) ang1 = this%angle1(n) ang2 = this%angle2(n) ang3 = this%angle3(n) - endif + end if s1 = sin(ang1) c1 = cos(ang1) s2 = sin(ang2) c2 = cos(ang2) s3 = sin(ang3) c3 = cos(ang3) - this%rmatck(1,1) = c1*c2 - this%rmatck(1,2) = c1*s2*s3 - s1*c3 - this%rmatck(1,3) = -c1*s2*c3 - s1*s3 - this%rmatck(2,1) = s1*c2 - this%rmatck(2,2) = s1*s2*s3 + c1*c3 - this%rmatck(2,3) = -s1*s2*c3 + c1*s3 - this%rmatck(3,1) = s2 - this%rmatck(3,2) = -c2*s3 - this%rmatck(3,3) = c2*c3 + this%rmatck(1, 1) = c1 * c2 + this%rmatck(1, 2) = c1 * s2 * s3 - s1 * c3 + this%rmatck(1, 3) = -c1 * s2 * c3 - s1 * s3 + this%rmatck(2, 1) = s1 * c2 + this%rmatck(2, 2) = s1 * s2 * s3 + c1 * c3 + this%rmatck(2, 3) = -s1 * s2 * c3 + c1 * s3 + this%rmatck(3, 1) = s2 + this%rmatck(3, 2) = -c2 * s3 + this%rmatck(3, 3) = c2 * c3 ! return end subroutine xt3d_fillrmatck - + end module Xt3dModule From 833d0727ba5d3bd32892983d18db20ec6abb81bb Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 14 Jul 2022 08:56:55 -0700 Subject: [PATCH 013/212] Checking in some minor items I missed in the previous commits --- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1apt1.f90 | 4 ++-- src/Model/GroundWaterTransport/gwt1dsp.f90 | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 17eaccda6b9..b8ec6d1d306 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -12,7 +12,7 @@ module GwtModule use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType + use TransportModelModule, only: TransportModelType, cunit, niunit use BaseModelModule, only: BaseModelType use BndModule, only: BndType, AddBndToList, GetBndFromList use TspIcModule, only: TspIcType diff --git a/src/Model/GroundWaterTransport/gwt1apt1.f90 b/src/Model/GroundWaterTransport/gwt1apt1.f90 index 98a4431abf9..b2115db2bbb 100644 --- a/src/Model/GroundWaterTransport/gwt1apt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1apt1.f90 @@ -44,7 +44,7 @@ module GwtAptModule use SimModule, only: store_error, store_error_unit, count_errors use SimVariablesModule, only: errmsg use BndModule, only: BndType - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr use TableModule, only: TableType, table_cr use ObserveModule, only: ObserveType @@ -89,7 +89,7 @@ module GwtAptModule dimension(:), pointer, contiguous :: featname => null() real(DP), dimension(:), pointer, contiguous :: concfeat => null() !< concentration of the feature real(DP), dimension(:, :), pointer, contiguous :: lauxvar => null() !< auxiliary variable - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object real(DP), dimension(:), pointer, contiguous :: qsto => null() !< mass flux due to storage change real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass flux required to maintain constant concentration integer(I4B), pointer :: idxbudfjf => null() !< index of flow ja face in flowbudptr diff --git a/src/Model/GroundWaterTransport/gwt1dsp.f90 b/src/Model/GroundWaterTransport/gwt1dsp.f90 index 08d68b06d86..1eaeaf96b37 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp.f90 @@ -206,7 +206,7 @@ subroutine dsp_ar(this, ibound, porosity, grid_data) class(GwtDspType) :: this integer(I4B), dimension(:), pointer, contiguous :: ibound real(DP), dimension(:), pointer, contiguous :: porosity - type(GwtDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, + type(TspDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, !! to create the package without input file ! -- local ! -- formats @@ -715,7 +715,7 @@ end subroutine read_data subroutine set_data(this, grid_data) use MemoryManagerModule, only: mem_reallocate class(GwtDspType) :: this !< this DSP package - type(GwtDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data + type(TspDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data ! local integer(I4B) :: i From 6553c4eed19b80ec061dc0c1318f8ba505dd89a3 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 14 Jul 2022 09:35:31 -0700 Subject: [PATCH 014/212] Applied fprettify to new GWE src files. gwt1dsp name was slightly off (probably something I did) --- src/Model/GroundWaterEnergy/gwe.f90 | 1268 ++++++++++++++++- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 1057 ++++++++++++++ src/Model/GroundWaterEnergy/gwe1mst1.f90 | 872 ++++++++++++ .../{gwt1dsp.f90 => gwt1dsp1.f90} | 0 4 files changed, 3180 insertions(+), 17 deletions(-) create mode 100644 src/Model/GroundWaterEnergy/gwe1dsp1.f90 create mode 100644 src/Model/GroundWaterEnergy/gwe1mst1.f90 rename src/Model/GroundWaterTransport/{gwt1dsp.f90 => gwt1dsp1.f90} (100%) diff --git a/src/Model/GroundWaterEnergy/gwe.f90 b/src/Model/GroundWaterEnergy/gwe.f90 index 31eb5e96957..df74ccef078 100644 --- a/src/Model/GroundWaterEnergy/gwe.f90 +++ b/src/Model/GroundWaterEnergy/gwe.f90 @@ -2,28 +2,1262 @@ module GweModule - use KindModule, only: DP, I4B - use InputOutputModule, only: ParseLine, upcase - use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC - use VersionModule, only: write_listfile_header - use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType - use BaseModelModule, only: BaseModelType + use KindModule, only: DP, I4B + use InputOutputModule, only: ParseLine, upcase + use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC + use VersionModule, only: write_listfile_header + use NumericalModelModule, only: NumericalModelType + use TransportModelModule, only: TransportModelType, cunit, niunit + use BaseModelModule, only: BaseModelType + use BndModule, only: BndType, AddBndToList, GetBndFromList + use TspIcModule, only: TspIcType + use TspFmiModule, only: TspFmiType + use TspOcModule, only: TspOcType + use TspAdvModule, only: TspAdvType + use TspSsmModule, only: TspSsmType + use TspMvtModule, only: TspMvtType + use TspObsModule, only: TspObsType + use GweDspModule, only: GweDspType + use GweMstModule, only: GweMstType + use BudgetModule, only: BudgetType + use TspLabelsModule, only: TspLabelsType implicit none - - private + private + public :: gwe_cr public :: GweModelType - + public :: CastAsGweModel + type, extends(TransportModelType) :: GweModelType - + + type(TspLabelsType), pointer :: tsplabel => null() + type(TspIcType), pointer :: ic => null() ! initial conditions package + type(TspFmiType), pointer :: fmi => null() ! flow model interface + type(TspAdvType), pointer :: adv => null() ! advection package + type(TspSsmType), pointer :: ssm => null() ! source sink mixing package + type(TspMvtType), pointer :: mvt => null() ! mover transport package + type(TspOcType), pointer :: oc => null() ! output control package + type(TspObsType), pointer :: obs => null() ! observation package + type(GweMstType), pointer :: mst => null() ! mass storage and transfer package + type(GweDspType), pointer :: dsp => null() ! dispersion package + type(BudgetType), pointer :: budget => null() ! budget object + type(TspLabelsType), pointer :: tsplab => null() + integer(I4B), pointer :: inic => null() ! unit number IC + integer(I4B), pointer :: infmi => null() ! unit number FMI + integer(I4B), pointer :: inmvt => null() ! unit number MVT + integer(I4B), pointer :: inmst => null() ! unit number MST + integer(I4B), pointer :: inadv => null() ! unit number ADV + integer(I4B), pointer :: indsp => null() ! unit number DSP + integer(I4B), pointer :: inssm => null() ! unit number SSM + integer(I4B), pointer :: inoc => null() ! unit number OC + integer(I4B), pointer :: inobs => null() ! unit number OBS + contains - - + + procedure :: model_df => gwe_df + procedure :: model_ac => gwe_ac + procedure :: model_mc => gwe_mc + procedure :: model_ar => gwe_ar + procedure :: model_rp => gwe_rp + procedure :: model_ad => gwe_ad + procedure :: model_cf => gwe_cf + procedure :: model_fc => gwe_fc + procedure :: model_cc => gwe_cc + procedure :: model_cq => gwe_cq + procedure :: model_bd => gwe_bd + procedure :: model_ot => gwe_ot + procedure :: model_da => gwe_da + procedure :: model_bdentry => gwe_bdentry + + procedure :: allocate_scalars => allocate_scalars_gwe + procedure, private :: package_create + procedure, private :: ftype_check + procedure :: get_iasym => gwe_get_iasym + procedure, private :: gwe_ot_flow + procedure, private :: gwe_ot_flowja + procedure, private :: gwe_ot_dv + procedure, private :: gwe_ot_bdsummary + procedure, private :: gwe_ot_obs + end type GweModelType - + ! -- Module variables constant for simulation - integer(I4B), parameter :: NIUNIT=100 - -end module GweModule \ No newline at end of file + !integer(I4B), parameter :: NIUNIT=100 + !character(len=LENFTYPE), dimension(NIUNIT) :: cunit + !data cunit/ 'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 + ! 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 + ! 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 + ! 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 + ! 'API6 ', ' ', ' ', ' ', ' ', & ! 25 + ! 75 * ' '/ + +contains + + subroutine gwe_cr(filename, id, modelname) +! ****************************************************************************** +! gwe_cr -- Create a new groundwater energy transport model object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ListsModule, only: basemodellist + use BaseModelModule, only: AddBaseModelToList + use SimModule, only: store_error, count_errors + use ConstantsModule, only: LINELENGTH + use MemoryHelperModule, only: create_mem_path + use NameFileModule, only: NameFileType + use GwfDisModule, only: dis_cr + use GwfDisvModule, only: disv_cr + use GwfDisuModule, only: disu_cr + use TspIcModule, only: ic_cr + use TspFmiModule, only: fmi_cr + use TspAdvModule, only: adv_cr + use TspSsmModule, only: ssm_cr + use TspMvtModule, only: mvt_cr + use TspOcModule, only: oc_cr + use TspObsModule, only: tsp_obs_cr + use GweMstModule, only: mst_cr + use GweDspModule, only: dsp_cr + use BudgetModule, only: budget_cr + use TspLabelsModule, only: tsplabels_cr + + ! -- dummy + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: id + character(len=*), intent(in) :: modelname + ! -- local + integer(I4B) :: indis, indis6, indisu6, indisv6 + integer(I4B) :: i + integer(I4B) :: nwords + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH), allocatable, dimension(:) :: words + type(NameFileType) :: namefile_obj + type(GweModelType), pointer :: this + class(BaseModelType), pointer :: model + cunit(10) = 'TMP6 ' +! ------------------------------------------------------------------------------ + ! + ! -- Allocate a new GWT Model (this) and add it to basemodellist + allocate (this) + ! + ! -- Set this before any allocs in the memory manager can be done + this%memoryPath = create_mem_path(modelname) + ! + call this%allocate_scalars(modelname) + model => this + call AddBaseModelToList(basemodellist, model) + ! + ! -- Assign values + this%filename = filename + this%name = modelname + this%macronym = 'GWE' + this%id = id + ! + ! -- Instantiate generalized labels for later assignment + call tsplabels_cr(this%tsplab, this%name) + ! + ! -- Open namefile and set iout + call namefile_obj%init(this%filename, 0) + call namefile_obj%add_cunit(niunit, cunit) + call namefile_obj%openlistfile(this%iout) + ! + ! -- Write header to model list file + call write_listfile_header(this%iout, 'GROUNDWATER ENERGY TRANSPORT '// & + 'MODEL (GWE)') + ! + ! -- Open files + call namefile_obj%openfiles(this%iout) + ! + ! -- Process OPTIONS block + if (size(namefile_obj%opts) > 0) then + write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + end if + ! + ! -- parse options in the gwe name file + do i = 1, size(namefile_obj%opts) + call ParseLine(namefile_obj%opts(i), nwords, words) + call upcase(words(1)) + select case (words(1)) + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + 'FOR ALL MODEL STRESS PACKAGES' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + 'FOR ALL MODEL PACKAGES' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, '(4x,a)') & + 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + case default + write (errmsg, '(4x,a,a,a,a)') & + 'UNKNOWN GWE NAMEFILE (', & + trim(adjustl(this%filename)), ') OPTION: ', & + trim(adjustl(namefile_obj%opts(i))) + call store_error(errmsg, terminate=.TRUE.) + end select + end do + ! + ! -- Assign unit numbers to attached modules, and remove + ! -- from unitnumber (by specifying 1 for iremove) + ! + indis = 0 + indis6 = 0 + indisu6 = 0 + indisv6 = 0 + call namefile_obj%get_unitnumber('DIS6', indis6, 1) + if (indis6 > 0) indis = indis6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) + if (indisu6 > 0) indis = indisu6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) + if (indisv6 > 0) indis = indisv6 + call namefile_obj%get_unitnumber('IC6', this%inic, 1) + call namefile_obj%get_unitnumber('FMI6', this%infmi, 1) + call namefile_obj%get_unitnumber('MVT6', this%inmvt, 1) + call namefile_obj%get_unitnumber('ADV6', this%inadv, 1) + call namefile_obj%get_unitnumber('MST6', this%inmst, 1) + call namefile_obj%get_unitnumber('DSP6', this%indsp, 1) + call namefile_obj%get_unitnumber('SSM6', this%inssm, 1) + call namefile_obj%get_unitnumber('OC6', this%inoc, 1) + call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) + ! + ! -- Check to make sure that required ftype's have been specified + call this%ftype_check(namefile_obj, indis) + ! + ! -- Create discretization object + if (indis6 > 0) then + call dis_cr(this%dis, this%name, indis, this%iout) + elseif (indisu6 > 0) then + call disu_cr(this%dis, this%name, indis, this%iout) + elseif (indisv6 > 0) then + call disv_cr(this%dis, this%name, indis, this%iout) + end if + ! + ! -- Create utility objects + call budget_cr(this%budget, this%name) + ! + ! -- Create packages that are tied directly to model + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout) + call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call oc_cr(this%oc, this%name, this%inoc, this%iout) + call tsp_obs_cr(this%obs, this%inobs) + ! + ! -- return + return + end subroutine gwe_cr + + subroutine gwe_df(this) +! ****************************************************************************** +! gwe_df -- Define packages of the model +! Subroutine: (1) call df routines for each package +! (2) set variables and pointers +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweModelType) :: this + ! -- local + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Define packages and utility objects + call this%dis%dis_df() + call this%fmi%fmi_df(this%dis, this%inssm) + if (this%inmvt > 0) call this%mvt%mvt_df(this%dis) + if (this%inadv > 0) call this%adv%adv_df() + if (this%indsp > 0) call this%dsp%dsp_df(this%dis) + if (this%inssm > 0) call this%ssm%ssm_df() + call this%oc%oc_df() + call this%budget%budget_df(niunit, 'MASS', 'M') + ! + ! -- Assign or point model members to dis members + this%neq = this%dis%nodes + this%nja = this%dis%nja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja + ! + ! -- Allocate model arrays, now that neq and nja are assigned + call this%allocate_arrays() + ! + ! -- Define packages and assign iout for time series managers + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_df(this%neq, this%dis) + packobj%TsManager%iout = this%iout + packobj%TasManager%iout = this%iout + end do + ! + ! -- Store information needed for observations + call this%obs%obs_df(this%iout, this%name, 'GWE', this%dis) + ! + ! -- return + return + + end subroutine gwe_df + + subroutine gwe_ac(this, sparse) +! ****************************************************************************** +! gwe_ac -- Add the internal connections of this model to the sparse matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy + class(GweModelType) :: this + type(sparsematrix), intent(inout) :: sparse + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Add the internal connections of this model to sparse + call this%dis%dis_ac(this%moffset, sparse) + if (this%indsp > 0) & + call this%dsp%dsp_ac(this%moffset, sparse) + ! + ! -- Add any package connections + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ac(this%moffset, sparse) + end do + ! + ! -- return + return + end subroutine gwe_ac + + subroutine gwe_mc(this, iasln, jasln) +! ****************************************************************************** +! gwe_mc -- Map the positions of this models connections in the +! numerical solution coefficient matrix. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweModelType) :: this + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Find the position of each connection in the global ia, ja structure + ! and store them in idxglo. + call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln) + if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, iasln, jasln) + ! + ! -- Map any package connections + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_mc(this%moffset, iasln, jasln) + end do + ! + ! -- return + return + end subroutine gwe_mc + + subroutine gwe_ar(this) +! ****************************************************************************** +! gwe_ar -- GroundWater Energy Transport Model Allocate and Read +! Subroutine: (1) allocates and reads packages part of this model, +! (2) allocates memory for arrays part of this model object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DHNOFLO + ! -- dummy + class(GweModelType) :: this + ! -- locals + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Allocate and read modules attached to model + call this%fmi%fmi_ar(this%ibound) + if (this%inmvt > 0) call this%mvt%mvt_ar() + if (this%inic > 0) call this%ic%ic_ar(this%x) + if (this%inmst > 0) call this%mst%mst_ar(this%dis, this%ibound) + if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound) + if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity, & + this%mst%cpw, this%mst%rhow) + if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) + if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) + ! + ! -- Call dis_ar to write binary grid file + !call this%dis%dis_ar(this%npf%icelltype) + ! + ! -- set up output control + call this%oc%oc_ar(this%x, this%dis, DHNOFLO) + call this%budget%set_ibudcsv(this%oc%ibudcsv) + ! + ! -- Package input files now open, so allocate and read + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & + this%xold, this%flowja) + ! -- Read and allocate package + call packobj%bnd_ar() + end do + ! + ! -- return + return + end subroutine gwe_ar + + subroutine gwe_rp(this) +! ****************************************************************************** +! gwe_rp -- GroundWater Energy Transport Model Read and Prepare +! Subroutine: (1) calls package read and prepare routines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: readnewdata + ! -- dummy + class(GweModelType) :: this + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- In fmi, check for mvt and mvrbudobj consistency + call this%fmi%fmi_rp(this%inmvt) + if (this%inmvt > 0) call this%mvt%mvt_rp() + ! + ! -- Check with TDIS on whether or not it is time to RP + if (.not. readnewdata) return + ! + ! -- Read and prepare + if (this%inoc > 0) call this%oc%oc_rp() + if (this%inssm > 0) call this%ssm%ssm_rp() + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_rp() + call packobj%bnd_rp_obs() + end do + ! + ! -- Return + return + end subroutine gwe_rp + + subroutine gwe_ad(this) +! ****************************************************************************** +! gwe_ad -- GroundWater Energy Transport Model Time Step Advance +! Subroutine: (1) calls package advance subroutines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SimVariablesModule, only: isimcheck, iFailedStepRetry + ! -- dummy + class(GweModelType) :: this + class(BndType), pointer :: packobj + ! -- local + integer(I4B) :: irestore + integer(I4B) :: ip, n +! ------------------------------------------------------------------------------ + ! + ! -- Reset state variable + irestore = 0 + if (iFailedStepRetry > 0) irestore = 1 + if (irestore == 0) then + ! + ! -- copy x into xold + do n = 1, this%dis%nodes + if (this%ibound(n) == 0) then + this%xold(n) = DZERO + else + this%xold(n) = this%x(n) + end if + end do + else + ! + ! -- copy xold into x if this time step is a redo + do n = 1, this%dis%nodes + this%x(n) = this%xold(n) + end do + end if + ! + ! -- Advance fmi + call this%fmi%fmi_ad(this%x) + ! + ! -- Advance + if (this%indsp > 0) call this%dsp%dsp_ad() + if (this%inssm > 0) call this%ssm%ssm_ad() + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ad() + if (isimcheck > 0) then + call packobj%bnd_ck() + end if + end do + ! + ! -- Push simulated values to preceding time/subtime step + call this%obs%obs_ad() + ! + ! -- return + return + end subroutine gwe_ad + + subroutine gwe_cf(this, kiter) +! ****************************************************************************** +! gwe_cf -- GroundWater Energy Transport Model calculate coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweModelType) :: this + integer(I4B), intent(in) :: kiter + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- Call package cf routines + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_cf() + end do + ! + ! -- return + return + end subroutine gwe_cf + + subroutine gwe_fc(this, kiter, amatsln, njasln, inwtflag) +! ****************************************************************************** +! gwe_fc -- GroundWater Energy Transport Model fill coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweModelType) :: this + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amatsln + integer(I4B), intent(in) :: inwtflag + ! -- local + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- call fc routines + call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, njasln, & + amatsln, this%idxglo, this%rhs) + if (this%inmvt > 0) then + call this%mvt%mvt_fc(this%x, this%x) + end if + if (this%inmst > 0) then + call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, njasln, & + amatsln, this%idxglo, this%x, this%rhs, kiter) + end if + if (this%inadv > 0) then + call this%adv%adv_fc(this%dis%nodes, amatsln, this%idxglo, this%x, & + this%rhs) + end if + if (this%indsp > 0) then + call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, njasln, amatsln, & + this%idxglo, this%rhs, this%x) + end if + if (this%inssm > 0) then + call this%ssm%ssm_fc(amatsln, this%idxglo, this%rhs) + end if + ! + ! -- packages + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) + end do + ! + ! -- return + return + end subroutine gwe_fc + + subroutine gwe_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) +! ****************************************************************************** +! gwe_cc -- GroundWater Energy Transport Model Final Convergence Check +! Subroutine: (1) calls package cc routines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweModelType) :: this + integer(I4B), intent(in) :: innertot + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + integer(I4B), intent(inout) :: ipak + real(DP), intent(inout) :: dpak + ! -- local + !class(BndType), pointer :: packobj + !integer(I4B) :: ip + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- If mover is on, then at least 2 outers required + if (this%inmvt > 0) call this%mvt%mvt_cc(kiter, iend, icnvgmod, cpak, dpak) + ! + ! -- Call package cc routines + !do ip = 1, this%bndlist%Count() + ! packobj => GetBndFromList(this%bndlist, ip) + ! call packobj%bnd_cc(iend, icnvg, hclose, rclose) + !enddo + ! + ! -- return + return + end subroutine gwe_cc + + subroutine gwe_cq(this, icnvg, isuppress_output) +! ****************************************************************************** +! gwe_cq --Groundwater energy transport model calculate flow +! Subroutine: (1) Calculate intercell flows (flowja) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: csr_diagsum + ! -- dummy + class(GweModelType) :: this + integer(I4B), intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + ! -- local + integer(I4B) :: i + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Construct the flowja array. Flowja is calculated each time, even if + ! output is suppressed. (flowja is positive into a cell.) The diagonal + ! position of the flowja array will contain the flow residual after + ! these routines are called, so each package is responsible for adding + ! its flow to this diagonal position. + do i = 1, this%nja + this%flowja(i) = DZERO + end do + if (this%inadv > 0) call this%adv%adv_cq(this%x, this%flowja) + if (this%indsp > 0) call this%dsp%dsp_cq(this%x, this%flowja) + if (this%inmst > 0) call this%mst%mst_cq(this%dis%nodes, this%x, this%xold, & + this%flowja) + if (this%inssm > 0) call this%ssm%ssm_cq(this%flowja) + if (this%infmi > 0) call this%fmi%fmi_cq(this%x, this%flowja) + ! + ! -- Go through packages and call cq routines. cf() routines are called + ! first to regenerate non-linear terms to be consistent with the final + ! conc solution. + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_cf(reset_mover=.false.) + call packobj%bnd_cq(this%x, this%flowja) + end do + ! + ! -- Finalize calculation of flowja by adding face flows to the diagonal. + ! This results in the flow residual being stored in the diagonal + ! position for each cell. + call csr_diagsum(this%dis%con%ia, this%flowja) + ! + ! -- Return + return + end subroutine gwe_cq + + subroutine gwe_bd(this, icnvg, isuppress_output) +! ****************************************************************************** +! gwe_bd --GroundWater Energy Transport Model Budget +! Subroutine: (1) Calculate intercell flows (flowja) +! (2) Calculate package contributions to model budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: DZERO + ! -- dummy + class(GweModelType) :: this + integer(I4B), intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + ! -- local + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Save the solution convergence flag + this%icnvg = icnvg + ! + ! -- Budget routines (start by resetting). Sole purpose of this section + ! is to add in and outs to model budget. All ins and out for a model + ! should be added here to this%budget. In a subsequent exchange call, + ! exchange flows might also be added. + call this%budget%reset() + if (this%inmst > 0) call this%mst%mst_bd(isuppress_output, this%budget) + if (this%inssm > 0) call this%ssm%ssm_bd(isuppress_output, this%budget) + if (this%infmi > 0) call this%fmi%fmi_bd(isuppress_output, this%budget) + if (this%inmvt > 0) call this%mvt%mvt_bd(this%x, this%x) + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_bd(this%budget) + end do + ! + ! -- Return + return + end subroutine gwe_bd + + subroutine gwe_ot(this) +! ****************************************************************************** +! gwe_ot -- GroundWater Energy Transport Model Output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, tdis_ot, endofperiod + ! -- dummy + class(GweModelType) :: this + ! -- local + integer(I4B) :: idvsave + integer(I4B) :: idvprint + integer(I4B) :: icbcfl + integer(I4B) :: icbcun + integer(I4B) :: ibudfl + integer(I4B) :: ipflag + ! -- formats + character(len=*), parameter :: fmtnocnvg = & + "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & + &I0,' OF STRESS PERIOD ',I0,'****')" +! ------------------------------------------------------------------------------ + ! + ! -- Set write and print flags + idvsave = 0 + idvprint = 0 + icbcfl = 0 + ibudfl = 0 + if (this%oc%oc_save('CONCENTRATION')) idvsave = 1 + if (this%oc%oc_print('CONCENTRATION')) idvprint = 1 + if (this%oc%oc_save('BUDGET')) icbcfl = 1 + if (this%oc%oc_print('BUDGET')) ibudfl = 1 + icbcun = this%oc%oc_save_unit('BUDGET') + ! + ! -- Override ibudfl and idvprint flags for nonconvergence + ! and end of period + ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag('CONCENTRATION', this%icnvg, endofperiod) + ! + ! Calculate and save observations + call this%gwe_ot_obs() + ! + ! Save and print flows + call this%gwe_ot_flow(icbcfl, ibudfl, icbcun) + ! + ! Save and print dependent variables + call this%gwe_ot_dv(idvsave, idvprint, ipflag) + ! + ! Print budget summaries + call this%gwe_ot_bdsummary(ibudfl, ipflag) + ! + ! -- Timing Output; if any dependendent variables or budgets + ! are printed, then ipflag is set to 1. + if (ipflag == 1) call tdis_ot(this%iout) + ! + ! -- Write non-convergence message + if (this%icnvg == 0) then + write (this%iout, fmtnocnvg) kstp, kper + end if + ! + ! -- Return + return + end subroutine gwe_ot + + subroutine gwe_ot_obs(this) + class(GweModelType) :: this + class(BndType), pointer :: packobj + integer(I4B) :: ip + + ! -- Calculate and save observations + call this%obs%obs_bd() + call this%obs%obs_ot() + + ! -- Calculate and save package obserations + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_bd_obs() + call packobj%bnd_ot_obs() + end do + + end subroutine gwe_ot_obs + + subroutine gwe_ot_flow(this, icbcfl, ibudfl, icbcun) + class(GweModelType) :: this + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + class(BndType), pointer :: packobj + integer(I4B) :: ip + + ! -- Save GWE flows + call this%gwe_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) + if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) + if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) + if (this%inssm > 0) call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, & + icbcun=icbcun) + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) + end do + + ! -- Save advanced package flows + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) + end do + if (this%inmvt > 0) then + call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) + end if + + ! -- Print GWF flows + ! no need to print flowja + ! no need to print mst + ! no need to print fmi + if (this%inssm > 0) call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, & + icbcun=0) + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) + end do + + ! -- Print advanced package flows + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) + end do + if (this%inmvt > 0) then + call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) + end if + + end subroutine gwe_ot_flow + + subroutine gwe_ot_flowja(this, nja, flowja, icbcfl, icbcun) +! ****************************************************************************** +! gwe_ot_flowja -- Write intercell flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweModelType) :: this + integer(I4B), intent(in) :: nja + real(DP), dimension(nja), intent(in) :: flowja + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: icbcun + ! -- local + integer(I4B) :: ibinun + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Set unit number for binary output + if (this%ipakcb < 0) then + ibinun = icbcun + elseif (this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + end if + if (icbcfl == 0) ibinun = 0 + ! + ! -- Write the face flows if requested + if (ibinun /= 0) then + call this%dis%record_connection_array(flowja, ibinun, this%iout) + end if + ! + ! -- Return + return + end subroutine gwe_ot_flowja + + subroutine gwe_ot_dv(this, idvsave, idvprint, ipflag) + class(GweModelType) :: this + integer(I4B), intent(in) :: idvsave + integer(I4B), intent(in) :: idvprint + integer(I4B), intent(inout) :: ipflag + class(BndType), pointer :: packobj + integer(I4B) :: ip + + ! -- Print advanced package dependent variables + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_dv(idvsave, idvprint) + end do + + ! -- save head and print head + call this%oc%oc_ot(ipflag) + + end subroutine gwe_ot_dv + + subroutine gwe_ot_bdsummary(this, ibudfl, ipflag) + use TdisModule, only: kstp, kper, totim + class(GweModelType) :: this + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(inout) :: ipflag + class(BndType), pointer :: packobj + integer(I4B) :: ip + + ! + ! -- Package budget summary + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) + end do + + ! -- mover budget summary + if (this%inmvt > 0) then + call this%mvt%mvt_ot_bdsummary(ibudfl) + end if + + ! -- model budget summary + if (ibudfl /= 0) then + ipflag = 1 + call this%budget%budget_ot(kstp, kper, this%iout) + end if + + ! -- Write to budget csv + call this%budget%writecsv(totim) + + end subroutine gwe_ot_bdsummary + + subroutine gwe_da(this) +! ****************************************************************************** +! gwt_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweModelType) :: this + ! -- local + integer(I4B) :: ip + class(BndType), pointer :: packobj +! ------------------------------------------------------------------------------ + ! + ! -- Internal flow packages deallocate + call this%dis%dis_da() + call this%ic%ic_da() + call this%fmi%fmi_da() + call this%adv%adv_da() + call this%dsp%dsp_da() + call this%ssm%ssm_da() + call this%mst%mst_da() + call this%mvt%mvt_da() + call this%budget%budget_da() + call this%oc%oc_da() + call this%obs%obs_da() + ! + ! -- Internal package objects + deallocate (this%dis) + deallocate (this%ic) + deallocate (this%fmi) + deallocate (this%adv) + deallocate (this%dsp) + deallocate (this%ssm) + deallocate (this%mst) + deallocate (this%mvt) + deallocate (this%budget) + deallocate (this%oc) + deallocate (this%obs) + ! + ! -- Boundary packages + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_da() + deallocate (packobj) + end do + ! + ! -- Scalars + call mem_deallocate(this%inic) + call mem_deallocate(this%infmi) + call mem_deallocate(this%inadv) + call mem_deallocate(this%indsp) + call mem_deallocate(this%inssm) + call mem_deallocate(this%inmst) + call mem_deallocate(this%inmvt) + call mem_deallocate(this%inoc) + call mem_deallocate(this%inobs) + ! + ! -- NumericalModelType + call this%NumericalModelType%model_da() + ! + ! -- return + return + end subroutine gwe_da + + !> @brief GroundWater Energy Transport Model Budget Entry + !! + !! This subroutine adds a budget entry to the flow budget. It was added as + !! a method for the gwe model object so that the exchange object could add its + !! contributions. + !! + !! (1) adds the entry to the budget object + !< + subroutine gwe_bdentry(this, budterm, budtxt, rowlabel) + ! -- modules + use ConstantsModule, only: LENBUDTXT + use TdisModule, only: delt + ! -- dummy + class(GweModelType) :: this + real(DP), dimension(:, :), intent(in) :: budterm + character(len=LENBUDTXT), dimension(:), intent(in) :: budtxt + character(len=*), intent(in) :: rowlabel +! ------------------------------------------------------------------------------ + ! + call this%budget%addentry(budterm, delt, budtxt, rowlabel=rowlabel) + ! + ! -- return + return + end subroutine gwe_bdentry + + function gwe_get_iasym(this) result(iasym) +! ****************************************************************************** +! gwe_get_iasym -- return 1 if any package causes the matrix to be asymmetric. +! Otherwise return 0. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GweModelType) :: this + ! -- local + integer(I4B) :: iasym +! ------------------------------------------------------------------------------ + ! + ! -- Start by setting iasym to zero + iasym = 0 + ! + ! -- ADV + if (this%inadv > 0) then + if (this%adv%iasym /= 0) iasym = 1 + end if + ! + ! -- return + return + end function gwe_get_iasym + + subroutine allocate_scalars_gwe(this, modelname) +! ****************************************************************************** +! allocate_scalars -- Allocate memory for non-allocatable members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweModelType) :: this + character(len=*), intent(in) :: modelname +! ------------------------------------------------------------------------------ + ! + ! -- allocate members from parent class + call this%TransportModelType%allocate_scalars(modelname) + ! + ! -- allocate members that are part of model class + call mem_allocate(this%inic, 'INIC', this%memoryPath) + call mem_allocate(this%infmi, 'INFMI', this%memoryPath) + call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) + call mem_allocate(this%inadv, 'INADV', this%memoryPath) + call mem_allocate(this%inssm, 'INSSM', this%memoryPath) + call mem_allocate(this%inoc, 'INOC ', this%memoryPath) + call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + call mem_allocate(this%inmst, 'INMST', this%memoryPath) + call mem_allocate(this%indsp, 'INDSP', this%memoryPath) + !! + this%inic = 0 + this%infmi = 0 + this%inmvt = 0 + this%inadv = 0 + this%inssm = 0 + this%inoc = 0 + this%inobs = 0 + this%inmst = 0 + this%indsp = 0 + ! + ! -- return + return + end subroutine + + subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & + iout) +! ****************************************************************************** +! package_create -- Create boundary condition packages for this model +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error + use TspCncModule, only: cnc_create +! use GweSrcModule, only: src_create +! use GweLktModule, only: lkt_create +! use GweSftModule, only: sft_create +! use GweMwtModule, only: mwt_create +! use GweUztModule, only: uzt_create +! use ApiModule, only: api_create + ! -- dummy + class(GweModelType) :: this + character(len=*), intent(in) :: filtyp + character(len=LINELENGTH) :: errmsg + integer(I4B), intent(in) :: ipakid + integer(I4B), intent(in) :: ipaknum + character(len=*), intent(in) :: pakname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + ! -- local + class(BndType), pointer :: packobj + class(BndType), pointer :: packobj2 + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! + ! -- This part creates the package object + select case (filtyp) + case ('CNC6') + call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + !case('SRC6') + ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + !case('LKT6') + ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('SFT6') + ! call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('MWT6') + ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('UZT6') + ! call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('IST6') + ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi, this%mst) + !case('API6') + ! call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + case default + write (errmsg, *) 'Invalid package type: ', filtyp + call store_error(errmsg, terminate=.TRUE.) + end select + ! + ! -- Packages is the bndlist that is associated with the parent model + ! -- The following statement puts a pointer to this package in the ipakid + ! -- position of packages. + do ip = 1, this%bndlist%Count() + packobj2 => GetBndFromList(this%bndlist, ip) + if (packobj2%packName == pakname) then + write (errmsg, '(a,a)') 'Cannot create package. Package name '// & + 'already exists: ', trim(pakname) + call store_error(errmsg, terminate=.TRUE.) + end if + end do + call AddBndToList(this%bndlist, packobj) + ! + ! -- return + return + end subroutine package_create + + subroutine ftype_check(this, namefile_obj, indis) +! ****************************************************************************** +! ftype_check -- Check to make sure required input files have been specified +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors + use NameFileModule, only: NameFileType + ! -- dummy + class(GweModelType) :: this + type(NameFileType), intent(in) :: namefile_obj + integer(I4B), intent(in) :: indis + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i, iu + character(len=LENFTYPE), dimension(10) :: nodupftype = & + (/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', & + 'DSP6 ', 'SSM6 ', 'OC6 ', 'OBS6 '/) +! ------------------------------------------------------------------------------ + ! + ! -- Check for IC6, DIS(u), and MST. Stop if not present. + if (this%inic == 0) then + write (errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT '// & + 'SPECIFIED.' + call store_error(errmsg) + end if + if (indis == 0) then + write (errmsg, '(1x,a)') & + 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + end if + if (this%inmst == 0) then + write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & + &PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + end if + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' + call store_error(errmsg) + end if + ! + ! -- Check to make sure that some GWE packages are not specified more + ! than once + do i = 1, size(nodupftype) + call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) + if (iu > 0) then + write (errmsg, '(1x, a, a, a)') & + 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & + ' NOT ALLOWED FOR GWE MODEL.' + call store_error(errmsg) + end if + end do + ! + ! -- Stop if errors + if (count_errors() > 0) then + write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & + trim(namefile_obj%filename) + call store_error(errmsg, terminate=.TRUE.) + end if + ! + ! -- return + return + end subroutine ftype_check + + !> @brief Cast to GweModelType + function CastAsGweModel(model) result(gwemodel) + class(*), pointer :: model !< The object to be cast + class(GweModelType), pointer :: gwemodel !< The GWE model + + gwemodel => null() + if (.not. associated(model)) return + select type (model) + type is (GweModelType) + gwemodel => model + end select + + end function CastAsGweModel + +end module GweModule diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 new file mode 100644 index 00000000000..4d2f397cf48 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -0,0 +1,1057 @@ +module GweDspModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, DHALF, DPI + use NumericalPackageModule, only: NumericalPackageType + use BaseDisModule, only: DisBaseType + use TspFmiModule, only: TspFmiType + use Xt3dModule, only: Xt3dType, xt3d_cr + use TspDspOptionsModule, only: TspDspOptionsType + use TspDspGridDataModule, only: TspDspGridDataType + + implicit none + private + public :: GweDspType + public :: dsp_cr + + type, extends(NumericalPackageType) :: GweDspType + + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWE model ibound + type(TspFmiType), pointer :: fmi => null() ! pointer to GWE fmi object + real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWE storage porosity + ! TODO: I don't think diffc is necessary for GWE + real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell + real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water + real(DP), dimension(:), pointer, contiguous :: ktw => null() ! thermal conductivity of water + real(DP), dimension(:), pointer, contiguous :: kts => null() ! thermal conductivity of aquifer material + real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water + real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: alv => null() ! longitudinal vertical dispersivity + real(DP), dimension(:), pointer, contiguous :: ath1 => null() ! transverse horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: ath2 => null() ! transverse horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity + integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active + integer(I4B), pointer :: iktw => null() ! flag indicating ktw was input + integer(I4B), pointer :: ikts => null() ! flag indicating kts was input + integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active + integer(I4B), pointer :: ixt3d => null() ! flag indicating xt3d is active + type(Xt3dType), pointer :: xt3d => null() ! xt3d object + real(DP), dimension(:), pointer, contiguous :: dispcoef => null() ! disp coefficient (only if xt3d not active) + integer(I4B), pointer :: id22 => null() ! flag indicating d22 is available + integer(I4B), pointer :: id33 => null() ! flag indicating d33 is available + real(DP), dimension(:), pointer, contiguous :: d11 => null() ! dispersion coefficient + real(DP), dimension(:), pointer, contiguous :: d22 => null() ! dispersion coefficient + real(DP), dimension(:), pointer, contiguous :: d33 => null() ! dispersion coefficient + real(DP), dimension(:), pointer, contiguous :: angle1 => null() ! rotation angle 1 + real(DP), dimension(:), pointer, contiguous :: angle2 => null() ! rotation angle 2 + real(DP), dimension(:), pointer, contiguous :: angle3 => null() ! rotation angle 3 + integer(I4B), pointer :: iangle1 => null() ! flag indicating angle1 is available + integer(I4B), pointer :: iangle2 => null() ! flag indicating angle2 is available + integer(I4B), pointer :: iangle3 => null() ! flag indicating angle3 is available + + contains + + procedure :: dsp_df + procedure :: dsp_ac + procedure :: dsp_mc + procedure :: dsp_ar + procedure :: dsp_ad + procedure :: dsp_fc + procedure :: dsp_cq + procedure :: dsp_da + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure, private :: read_options + procedure, private :: read_data + procedure, private :: set_data + procedure, private :: calcdispellipse + procedure, private :: calcdispcoef + + end type GweDspType + +contains + + subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) +! ****************************************************************************** +! dsp_cr -- Create a new DSP object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GweDspType), pointer :: dspobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + type(TspFmiType), intent(in), target :: fmi +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate (dspobj) + ! + ! -- create name and memory path + call dspobj%set_names(1, name_model, 'DSP', 'DSP') + ! + ! -- Allocate scalars + call dspobj%allocate_scalars() + ! + ! -- Set variables + dspobj%inunit = inunit + dspobj%iout = iout + dspobj%fmi => fmi + ! + ! -- Return + return + end subroutine dsp_cr + + subroutine dsp_df(this, dis, dspOptions) +! ****************************************************************************** +! dsp_df -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweDspType) :: this + class(DisBaseType), pointer :: dis + type(TspDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not + !! creating DSP from file + ! -- local + ! -- formats + character(len=*), parameter :: fmtdsp = & + "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & + &' INPUT READ FROM UNIT ', i0, //)" +! ------------------------------------------------------------------------------ + ! + ! -- Store pointer to dis + this%dis => dis + ! + ! + ! -- set default xt3d representation to on and lhs + this%ixt3d = 1 + ! + ! -- Read dispersion options + if (present(dspOptions)) then + this%ixt3d = dspOptions%ixt3d + else + ! + ! -- Initialize block parser + call this%parser%Initialize(this%inunit, this%iout) + call this%read_options() + end if + ! + ! -- xt3d create + if (this%ixt3d > 0) then + call xt3d_cr(this%xt3d, this%name_model, this%inunit, this%iout, & + ldispopt=.true.) + this%xt3d%ixt3d = this%ixt3d + call this%xt3d%xt3d_df(dis) + end if + ! + ! -- Return + return + end subroutine dsp_df + + subroutine dsp_ac(this, moffset, sparse) +! ****************************************************************************** +! dsp_ac -- Add connections for extended neighbors to the sparse matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweDspType) :: this + integer(I4B), intent(in) :: moffset + type(sparsematrix), intent(inout) :: sparse + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Add extended neighbors (neighbors of neighbors) + if (this%ixt3d > 0) call this%xt3d%xt3d_ac(moffset, sparse) + ! + ! -- Return + return + end subroutine dsp_ac + + subroutine dsp_mc(this, moffset, iasln, jasln) +! ****************************************************************************** +! dsp_mc -- Map connections and construct iax, jax, and idxglox +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweDspType) :: this + integer(I4B), intent(in) :: moffset + integer(I4B), dimension(:), intent(in) :: iasln + integer(I4B), dimension(:), intent(in) :: jasln + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Call xt3d map connections + if (this%ixt3d > 0) call this%xt3d%xt3d_mc(moffset, iasln, jasln) + ! + ! -- Return + return + end subroutine dsp_mc + + subroutine dsp_ar(this, ibound, porosity, cpw, rhow, grid_data) +! ****************************************************************************** +! dsp_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweDspType) :: this + integer(I4B), dimension(:), pointer, contiguous :: ibound + real(DP), dimension(:), pointer, contiguous :: porosity + real(DP), dimension(:), pointer, contiguous :: cpw + real(DP), dimension(:), pointer, contiguous :: rhow + type(TspDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, + !! to create the package without input file + ! -- local + ! -- formats + character(len=*), parameter :: fmtdsp = & + "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & + &' INPUT READ FROM UNIT ', i0, //)" +! ------------------------------------------------------------------------------ + ! + ! -- dsp pointers to arguments that were passed in + this%ibound => ibound + this%porosity => porosity + this%cpw => cpw + this%rhow => rhow + ! + ! -- Print a message identifying the dispersion package. + if (this%iout > 0) then + write (this%iout, fmtdsp) this%inunit + end if + ! + ! -- Allocate arrays + call this%allocate_arrays(this%dis%nodes) + ! + if (present(grid_data)) then + ! -- Set dispersion data + call this%set_data(grid_data) + else + ! -- Read dispersion data + call this%read_data() + end if + ! + ! -- Return + return + end subroutine dsp_ar + + subroutine dsp_ad(this) +! ****************************************************************************** +! dsp_ad -- Advance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper + ! -- dummy + class(GweDspType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- xt3d + ! TODO: might consider adding a new mf6 level set pointers method, and + ! doing this stuff there instead of in the time step loop. + if (kstp * kper == 1) then + if (this%ixt3d > 0) + call this%xt3d%xt3d_ar(this%fmi%ibdgwfsat0, this%d11, this%id33, & + this%d33, this%fmi%gwfsat, this%id22, & + this%d22, this%iangle1, this%iangle2, & + this%iangle3, this%angle1, this%angle2, this%angle3) + end if + ! + ! -- Fill d11, d22, d33, angle1, angle2, angle3 using specific discharge + call this%calcdispellipse() + ! + ! -- Recalculate dispersion coefficients if the flows were updated + if (this%fmi%iflowsupdated == 1) then + if (this%ixt3d == 0) then + call this%calcdispcoef() + else if (this%ixt3d > 0) then + call this%xt3d%xt3d_fcpc(this%dis%nodes, .false.) + end if + end if + ! + ! -- Return + return + end subroutine dsp_ad + + subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) +! ****************************************************************************** +! dsp_fc -- Calculate coefficients and fill amat and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweDspType) :: this + integer(I4B) :: kiter + integer(I4B), intent(in) :: nodes + integer(I4B), intent(in) :: nja + integer(I4B), intent(in) :: njasln + real(DP), dimension(njasln), intent(inout) :: amatsln + integer(I4B), intent(in), dimension(nja) :: idxglo + real(DP), intent(inout), dimension(nodes) :: rhs + real(DP), intent(inout), dimension(nodes) :: cnew + ! -- local + integer(I4B) :: n, m, idiag, idiagm, ipos, isympos, isymcon + real(DP) :: dnm +! ------------------------------------------------------------------------------ + ! + if (this%ixt3d > 0) then + call this%xt3d%xt3d_fc(kiter, njasln, amatsln, idxglo, rhs, cnew) + else + do n = 1, nodes + if (this%fmi%ibdgwfsat0(n) == 0) cycle + idiag = this%dis%con%ia(n) + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + if (this%dis%con%mask(ipos) == 0) cycle + m = this%dis%con%ja(ipos) + if (m < n) cycle + if (this%fmi%ibdgwfsat0(m) == 0) cycle + isympos = this%dis%con%jas(ipos) + dnm = this%dispcoef(isympos) + ! + ! -- Contribution to row n + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + dnm + amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) - dnm + ! + ! -- Contribution to row m + idiagm = this%dis%con%ia(m) + isymcon = this%dis%con%isym(ipos) + amatsln(idxglo(isymcon)) = amatsln(idxglo(isymcon)) + dnm + amatsln(idxglo(idiagm)) = amatsln(idxglo(idiagm)) - dnm + end do + end do + end if + ! + ! -- Return + return + end subroutine dsp_fc + + subroutine dsp_cq(this, cnew, flowja) +! ****************************************************************************** +! dsp_cq -- Calculate dispersion contribution to flowja +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweDspType) :: this + real(DP), intent(inout), dimension(:) :: cnew + real(DP), intent(inout), dimension(:) :: flowja + ! -- local + integer(I4B) :: n, m, ipos, isympos + real(DP) :: dnm +! ------------------------------------------------------------------------------ + ! + ! -- Calculate dispersion and add to flowja + if (this%ixt3d > 0) then + call this%xt3d%xt3d_flowja(cnew, flowja) + else + do n = 1, this%dis%nodes + if (this%fmi%ibdgwfsat0(n) == 0) cycle + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ipos) + if (this%fmi%ibdgwfsat0(m) == 0) cycle + isympos = this%dis%con%jas(ipos) + dnm = this%dispcoef(isympos) + flowja(ipos) = flowja(ipos) + dnm * (cnew(m) - cnew(n)) + end do + end do + end if + ! + ! -- Return + return + end subroutine dsp_cq + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: DZERO + ! -- dummy + class(GweDspType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%idiffc, 'IDIFFC', this%memoryPath) + call mem_allocate(this%iktw, 'IKTW', this%memoryPath) + call mem_allocate(this%ikts, 'IKTS', this%memoryPath) + call mem_allocate(this%idisp, 'IDISP', this%memoryPath) + call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%id22, 'ID22', this%memoryPath) + call mem_allocate(this%id33, 'ID33', this%memoryPath) + call mem_allocate(this%iangle1, 'IANGLE1', this%memoryPath) + call mem_allocate(this%iangle2, 'IANGLE2', this%memoryPath) + call mem_allocate(this%iangle3, 'IANGLE3', this%memoryPath) + ! + ! -- Initialize + this%idiffc = 0 + this%iktw = 0 + this%ikts = 0 + this%idisp = 0 + this%ixt3d = 0 + this%id22 = 1 + this%id33 = 1 + this%iangle1 = 1 + this%iangle2 = 1 + this%iangle3 = 1 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this, nodes) +! ****************************************************************************** +! allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: DZERO + ! -- dummy + class(GweDspType) :: this + integer(I4B), intent(in) :: nodes + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Allocate + call mem_allocate(this%alh, 0, 'ALH', trim(this%memoryPath)) + call mem_allocate(this%alv, 0, 'ALV', trim(this%memoryPath)) + call mem_allocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) + call mem_allocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) + call mem_allocate(this%atv, 0, 'ATV', trim(this%memoryPath)) + call mem_allocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) + call mem_allocate(this%KTW, 0, 'KTW', trim(this%memoryPath)) + call mem_allocate(this%KTS, 0, 'KTS', trim(this%memoryPath)) + call mem_allocate(this%d11, nodes, 'D11', trim(this%memoryPath)) + call mem_allocate(this%d22, nodes, 'D22', trim(this%memoryPath)) + call mem_allocate(this%d33, nodes, 'D33', trim(this%memoryPath)) + call mem_allocate(this%angle1, nodes, 'ANGLE1', trim(this%memoryPath)) + call mem_allocate(this%angle2, nodes, 'ANGLE2', trim(this%memoryPath)) + call mem_allocate(this%angle3, nodes, 'ANGLE3', trim(this%memoryPath)) + ! + ! -- Allocate dispersion coefficient array if xt3d not in use + if (this%ixt3d == 0) then + call mem_allocate(this%dispcoef, this%dis%njas, 'DISPCOEF', & + trim(this%memoryPath)) + else + call mem_allocate(this%dispcoef, 0, 'DISPCOEF', trim(this%memoryPath)) + end if + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine dsp_da(this) +! ****************************************************************************** +! dsp_da +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweDspType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- deallocate arrays + if (this%inunit /= 0) then + call mem_deallocate(this%alh) + call mem_deallocate(this%alv, 'ALV', trim(this%memoryPath)) + call mem_deallocate(this%ath1) + call mem_deallocate(this%ath2, 'ATH2', trim(this%memoryPath)) + call mem_deallocate(this%atv, 'ATV', trim(this%memoryPath)) + call mem_deallocate(this%diffc) + call mem_deallocate(this%ktw) + call mem_deallocate(this%kts) + call mem_deallocate(this%d11) + call mem_deallocate(this%d22) + call mem_deallocate(this%d33) + call mem_deallocate(this%angle1) + call mem_deallocate(this%angle2) + call mem_deallocate(this%angle3) + call mem_deallocate(this%dispcoef) + if (this%ixt3d > 0) call this%xt3d%xt3d_da() + end if + ! + ! -- deallocate objects + if (this%ixt3d > 0) deallocate (this%xt3d) + ! + ! -- deallocate scalars + call mem_deallocate(this%idiffc) + call mem_deallocate(this%iktw) + call mem_deallocate(this%ikts) + call mem_deallocate(this%idisp) + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%id22) + call mem_deallocate(this%id33) + call mem_deallocate(this%iangle1) + call mem_deallocate(this%iangle2) + call mem_deallocate(this%iangle3) + ! + ! -- deallocate variables in NumericalPackageType + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine dsp_da + + subroutine read_options(this) +! ****************************************************************************** +! read_options -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error + ! -- dummy + class(GweDspType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & + supportOpenClose=.true.) + ! + ! -- parse options block if detected + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING DISPERSION OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('XT3D_OFF') + this%ixt3d = 0 + write (this%iout, '(4x,a)') & + 'XT3D FORMULATION HAS BEEN SHUT OFF.' + case ('XT3D_RHS') + this%ixt3d = 2 + write (this%iout, '(4x,a)') & + 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' + case default + write (errmsg, '(4x,a,a)') 'UNKNOWN DISPERSION OPTION: ', & + trim(keyword) + call store_error(errmsg, terminate=.TRUE.) + end select + end do + write (this%iout, '(1x,a)') 'END OF DISPERSION OPTIONS' + end if + ! + ! -- Return + return + end subroutine read_options + + subroutine read_data(this) +! ****************************************************************************** +! read_data -- read the dispersion data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors + use MemoryManagerModule, only: mem_reallocate, mem_copyptr, mem_reassignptr + ! -- dummy + class(GweDspType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + character(len=:), allocatable :: line + integer(I4B) :: istart, istop, lloc, ierr + logical :: isfound, endOfBlock + logical, dimension(8) :: lname + character(len=24), dimension(8) :: aname + ! -- formats + ! -- data + data aname(1)/' DIFFUSION COEFFICIENT'/ + data aname(2)/' ALH'/ + data aname(3)/' ALV'/ + data aname(4)/' ATH1'/ + data aname(5)/' ATH2'/ + data aname(6)/' ATV'/ + data aname(6)/' KTW'/ + data aname(6)/' KTS'/ +! ------------------------------------------------------------------------------ + ! + ! -- initialize + lname(:) = .false. + isfound = .false. + ! + ! -- get griddata block + call this%parser%GetBlock('GRIDDATA', isfound, ierr) + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + call this%parser%GetRemainingLine(line) + lloc = 1 + select case (keyword) +! case ('DIFFC') +! call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & +! trim(this%memoryPath)) +! call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& +! this%parser%iuactive, this%diffc, & +! aname(1)) +! lname(1) = .true. + case ('ALH') + call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%alh, & + aname(2)) + lname(2) = .true. + case ('ALV') + call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%alv, & + aname(3)) + lname(3) = .true. + case ('ATH1') + call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%ath1, & + aname(4)) + lname(4) = .true. + case ('ATH2') + call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%ath2, & + aname(5)) + lname(5) = .true. + case ('ATV') + call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%atv, & + aname(6)) + lname(6) = .true. + case ('KTW') + call mem_reallocate(this%ktw, this%dis%nodes, 'KTW', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%ktw, & + aname(7)) + lname(7) = .true. + case ('KTS') + call mem_reallocate(this%kts, this%dis%nodes, 'KTS', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%kts, & + aname(8)) + lname(8) = .true. + + case default + write (errmsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + end do + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' + else + write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + ! + if (lname(1)) this%idiffc = 1 + if (lname(2)) this%idisp = this%idisp + 1 + if (lname(3)) this%idisp = this%idisp + 1 + if (lname(4)) this%idisp = this%idisp + 1 + if (lname(5)) this%idisp = this%idisp + 1 + if (lname(7)) this%iktw = 1 + if (lname(8)) this%ikts = 1 + ! + ! -- if dispersivities are specified, then both alh and ath1 must be included + if (this%idisp > 0) then + ! + ! -- make sure alh was specified + if (.not. lname(2)) then + write (errmsg, '(1x,a)') 'IF DISPERSIVITIES ARE SPECIFIED THEN ALH '// & + 'IS REQUIRED.' + call store_error(errmsg) + end if + ! + ! -- make sure ath1 was specified + if (.not. lname(4)) then + write (errmsg, '(1x,a)') 'IF DISPERSIVITIES ARE SPECIFIED THEN ATH1 '// & + 'IS REQUIRED.' + call store_error(errmsg) + end if + ! + ! -- If alv not specified then point it to alh + if (.not. lname(3)) then + call mem_reassignptr(this%alv, 'ALV', trim(this%memoryPath), & + 'ALH', trim(this%memoryPath)) + end if + ! + ! -- If ath2 not specified then assign it to ath1 + if (.not. lname(5)) then + call mem_reassignptr(this%ath2, 'ATH2', trim(this%memoryPath), & + 'ATH1', trim(this%memoryPath)) + end if + ! + ! -- If atv not specified then assign it to ath2 + if (.not. lname(6)) then + call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & + 'ATH2', trim(this%memoryPath)) + end if + end if + ! + ! -- terminate if errors + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- Return + return + end subroutine read_data + + !< @brief Set the grid data to the package + !< + subroutine set_data(this, grid_data) + use MemoryManagerModule, only: mem_reallocate + class(GweDspType) :: this !< this DSP package + type(TspDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data + ! local + integer(I4B) :: i + + call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & + trim(this%memoryPath)) + call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & + trim(this%memoryPath)) + call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & + trim(this%memoryPath)) + call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & + trim(this%memoryPath)) + call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & + trim(this%memoryPath)) + call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & + trim(this%memoryPath)) + call mem_reallocate(this%ktw, this%dis%nodes, 'KTW', & + trim(this%memoryPath)) + call mem_reallocate(this%kts, this%dis%nodes, 'KTS', & + trim(this%memoryPath)) + + do i = 1, this%dis%nodes + this%diffc(i) = grid_data%diffc(i) + this%alh(i) = grid_data%alh(i) + this%alv(i) = grid_data%alv(i) + this%ath1(i) = grid_data%ath1(i) + this%ath2(i) = grid_data%ath2(i) + this%atv(i) = grid_data%atv(i) + this%ktw(i) = grid_data%ktw(i) + this%kts(i) = grid_data%kts(i) + this%cpw(i) = grid_data%cpw(i) ! TODO: May need to check that mst is active + this%rhow(i) = grid_data%rhow(i) + end do + + end subroutine + + subroutine calcdispellipse(this) +! ****************************************************************************** +! calcdispellipse -- Calculate dispersion coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweDspType) :: this + ! -- local + integer(I4B) :: nodes, n + real(DP) :: q, qx, qy, qz + real(DP) :: alh, alv, ath1, ath2, atv, a + real(DP) :: al, at1, at2 + real(DP) :: qzoqsquared + real(DP) :: dstar + real(DP) :: ktbulk ! TODO: Implement additional options for characterizing ktbulk (see Markle refs) +! ------------------------------------------------------------------------------ + ! + ! -- loop through and calculate dispersion coefficients and angles + nodes = size(this%d11) + do n = 1, nodes + ! + ! -- initialize + this%d11(n) = DZERO + this%d22(n) = DZERO + this%d33(n) = DZERO + this%angle1(n) = DZERO + this%angle2(n) = DZERO + this%angle3(n) = DZERO + if (this%fmi%ibdgwfsat0(n) == 0) cycle + ! + ! -- specific discharge + qx = DZERO + qy = DZERO + qz = DZERO + q = DZERO + qx = this%fmi%gwfspdis(1, n) + qy = this%fmi%gwfspdis(2, n) + qz = this%fmi%gwfspdis(3, n) + q = qx**2 + qy**2 + qz**2 + if (q > DZERO) q = sqrt(q) + ! + ! -- dispersion coefficients + alh = DZERO + alv = DZERO + ath1 = DZERO + ath2 = DZERO + atv = DZERO + if (this%idisp > 0) then + alh = this%alh(n) + alv = this%alv(n) + ath1 = this%ath1(n) + ath2 = this%ath2(n) + atv = this%atv(n) + end if + ! + ! -- calculate + dstar = DZERO +! if (this%idiffc > 0) then +! dstar = this%diffc(n) * this%porosity(n) +! endif + ktbulk = DZERO + if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) + if (this%ikts > 0) ktbulk = ktbulk + (DONE - this%porosity(n)) * this%kts(n) + dstar = ktbulk / (this%cpw(n) * this%rhow(n)) + ! + ! -- Calculate the longitudal and transverse dispersivities + al = DZERO + at1 = DZERO + at2 = DZERO + if (q > DZERO) then + qzoqsquared = (qz / q)**2 + al = alh * (DONE - qzoqsquared) + alv * qzoqsquared + at1 = ath1 * (DONE - qzoqsquared) + atv * qzoqsquared + at2 = ath2 * (DONE - qzoqsquared) + atv * qzoqsquared + end if + ! + ! -- Calculate and save the diagonal components of the dispersion tensor + this%d11(n) = al * q + dstar + this%d22(n) = at1 * q + dstar + this%d33(n) = at2 * q + dstar + ! + ! -- Angles of rotation if velocity based dispersion tensor + if (this%idisp > 0) then + ! + ! -- angles of rotation from model coordinates to direction of velocity + ! qx / q = cos(a1) * cos(a2) + ! qy / q = sin(a1) * cos(a2) + ! qz / q = sin(a2) + ! + ! -- angle3 is zero + this%angle3(n) = DZERO + ! + ! -- angle2 + a = DZERO + if (q > DZERO) a = qz / q + this%angle2(n) = asin(a) + ! + ! -- angle1 + a = q * cos(this%angle2(n)) + if (a /= DZERO) then + a = qx / a + else + a = DZERO + end if + ! + ! -- acos(1) not defined, so set to zero if necessary + if (a <= -DONE) then + this%angle1(n) = DPI + elseif (a >= DONE) then + this%angle1(n) = DZERO + else + this%angle1(n) = acos(a) + end if + ! + end if + end do + ! + ! -- Return + return + end subroutine calcdispellipse + + subroutine calcdispcoef(this) +! ****************************************************************************** +! calcdispcoef -- Calculate dispersion coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use GwfNpfModule, only: hyeff_calc + ! -- dummy + class(GweDspType) :: this + ! -- local + integer(I4B) :: nodes, n, m, idiag, ipos + real(DP) :: clnm, clmn, dn, dm + real(DP) :: vg1, vg2, vg3 + integer(I4B) :: ihc, isympos + integer(I4B) :: iavgmeth + real(DP) :: satn, satm, topn, topm, botn, botm + real(DP) :: hwva, cond, cn, cm, denom + real(DP) :: anm, amn, thksatn, thksatm, sill_top, sill_bot, tpn, tpm +! ------------------------------------------------------------------------------ + ! + ! -- set iavgmeth = 1 to use arithmetic averaging for effective dispersion + iavgmeth = 1 + ! + ! -- Proces connections + nodes = size(this%d11) + do n = 1, nodes + if (this%fmi%ibdgwfsat0(n) == 0) cycle + idiag = this%dis%con%ia(n) + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + ! + ! -- Set m to connected cell + m = this%dis%con%ja(ipos) + ! + ! -- skip for lower triangle + if (m < n) cycle + isympos = this%dis%con%jas(ipos) + this%dispcoef(isympos) = DZERO + if (this%fmi%ibdgwfsat0(m) == 0) cycle + ! + ! -- cell dimensions + hwva = this%dis%con%hwva(isympos) + clnm = this%dis%con%cl1(isympos) + clmn = this%dis%con%cl2(isympos) + ihc = this%dis%con%ihc(isympos) + topn = this%dis%top(n) + topm = this%dis%top(m) + botn = this%dis%bot(n) + botm = this%dis%bot(m) + ! + ! -- flow model information + satn = this%fmi%gwfsat(n) + satm = this%fmi%gwfsat(m) + ! + ! -- Calculate dispersion coefficient for cell n in the direction + ! normal to the shared n-m face and for cell m in the direction + ! normal to the shared n-m face. + call this%dis%connection_normal(n, m, ihc, vg1, vg2, vg3, ipos) + dn = hyeff_calc(this%d11(n), this%d22(n), this%d33(n), & + this%angle1(n), this%angle2(n), this%angle3(n), & + vg1, vg2, vg3, iavgmeth) + dm = hyeff_calc(this%d11(m), this%d22(m), this%d33(m), & + this%angle1(m), this%angle2(m), this%angle3(m), & + vg1, vg2, vg3, iavgmeth) + ! + ! -- Calculate dispersion conductance based on NPF subroutines and the + ! effective dispersion coefficients dn and dm. + if (ihc == 0) then + clnm = satn * (topn - botn) * DHALF + clmn = satm * (topm - botm) * DHALF + anm = hwva + ! + ! -- n is convertible and unsaturated + if (satn == DZERO) then + anm = DZERO + else if (n > m .and. satn < DONE) then + anm = DZERO + end if + ! + ! -- m is convertible and unsaturated + if (satm == DZERO) then + anm = DZERO + else if (m > n .and. satm < DONE) then + anm = DZERO + end if + ! + ! -- amn is the same as anm for vertical flow + amn = anm + ! + else + ! + ! -- horizontal conductance + thksatn = (topn - botn) * satn + thksatm = (topm - botm) * satm + ! + ! -- handle vertically staggered case + if (ihc == 2) then + sill_top = min(topn, topm) + sill_bot = max(botn, botm) + tpn = botn + thksatn + tpm = botm + thksatm + thksatn = max(min(tpn, sill_top) - sill_bot, DZERO) + thksatm = max(min(tpm, sill_top) - sill_bot, DZERO) + end if + ! + ! -- calculate the saturated area term + anm = thksatn * hwva + amn = thksatm * hwva + ! + ! -- n or m is unsaturated, so no dispersion + if (satn == DZERO .or. satm == DZERO) then + anm = DZERO + amn = DZERO + end if + ! + end if + ! + ! -- calculate conductance using the two half cell conductances + cn = DZERO + if (clnm > DZERO) cn = dn * anm / clnm + cm = DZERO + if (clmn > DZERO) cm = dm * amn / clmn + denom = cn + cm + if (denom > DZERO) then + cond = cn * cm / denom + else + cond = DZERO + end if + ! + ! -- Assign the calculated dispersion conductance + this%dispcoef(isympos) = cond + ! + end do + end do + ! + ! -- Return + return + end subroutine calcdispcoef + +end module GweDspModule diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 new file mode 100644 index 00000000000..0d2e9d2eb89 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -0,0 +1,872 @@ +!> -- @ brief Mobile Storage and Transfer (MST) Module +!! +!! The GweMstModule contains the GweMstType, which is related +!! to GwtMstModule; however, there are some important differences +!! owing to the fact that a sorbed phase is not considered. +!! Instead, a single temperature is simulated for each grid +!! cell and is represenative of both the aqueous and solid +!! phases (i.e., instantaneous thermal equilibrium is +!! assumed). Also, "thermal bleeding" is accomodated, where +!! conductive processes can transport into, through, or +!! out of dry cells that are part of the active domain. +!< +module GweMstModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DONE, DZERO, DTWO, DHALF, LENBUDTXT + use SimVariablesModule, only: errmsg, warnmsg + use SimModule, only: store_error, count_errors, & + store_warning + use NumericalPackageModule, only: NumericalPackageType + use BaseDisModule, only: DisBaseType + use TspFmiModule, only: TspFmiType + + implicit none + public :: GweMstType + public :: mst_cr + ! + integer(I4B), parameter :: NBDITEMS = 2 + character(len=LENBUDTXT), dimension(NBDITEMS) :: budtxt + data budtxt/' STORAGE-CELLBLK', ' DECAY-AQUEOUS'/ + + !> @ brief Mobile storage and transfer + !! + !! Data and methods for handling changes in temperature + !< + type, extends(NumericalPackageType) :: GweMstType + ! + ! -- storage + real(DP), dimension(:), pointer, contiguous :: porosity => null() !< porosity + real(DP), dimension(:), pointer, contiguous :: ratesto => null() !< rate of mobile storage + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< heat capacity of water + real(DP), dimension(:), pointer, contiguous :: cps => null() !< heat capacity of solid + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< density of water + real(DP), dimension(:), pointer, contiguous :: rhos => null() !< density of solid + ! + ! -- decay + integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) + real(DP), dimension(:), pointer, contiguous :: decay => null() !< first or zero order decay rate (aqueous) + real(DP), dimension(:), pointer, contiguous :: ratedcy => null() !< rate of decay + real(DP), dimension(:), pointer, contiguous :: decaylast => null() !< decay rate used for last iteration (needed for zero order decay) + ! + ! -- misc + integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + + contains + + procedure :: mst_ar + procedure :: mst_fc + procedure :: mst_fc_sto + procedure :: mst_fc_dcy + procedure :: mst_cq + procedure :: mst_cq_sto + procedure :: mst_cq_dcy + procedure :: mst_bd + procedure :: mst_ot_flow + procedure :: mst_da + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: read_data + + end type GweMstType + +contains + + !> @ brief Create a new package object + !! + !! Create a new MST object + !! + !< + subroutine mst_cr(mstobj, name_model, inunit, iout, fmi) + ! -- dummy + type(GweMstType), pointer :: mstobj !< unallocated new mst object to create + character(len=*), intent(in) :: name_model !< name of the model + integer(I4B), intent(in) :: inunit !< unit number of WEL package input file + integer(I4B), intent(in) :: iout !< unit number of model listing file + type(TspFmiType), intent(in), target :: fmi !< fmi package for this GWE model + ! + ! -- Create the object + allocate (mstobj) + ! + ! -- create name and memory path + call mstobj%set_names(1, name_model, 'MST', 'MST') + ! + ! -- Allocate scalars + call mstobj%allocate_scalars() + ! + ! -- Set variables + mstobj%inunit = inunit + mstobj%iout = iout + mstobj%fmi => fmi + ! + ! -- Initialize block parser + call mstobj%parser%Initialize(mstobj%inunit, mstobj%iout) + ! + ! -- Return + return + end subroutine mst_cr + + !> @ brief Allocate and read method for package + !! + !! Method to allocate and read static data for the package. + !! + !< + subroutine mst_ar(this, dis, ibound) + ! -- modules + ! -- dummy + class(GweMstType), intent(inout) :: this !< GweMstType object + class(DisBaseType), pointer, intent(in) :: dis !< pointer to dis package + integer(I4B), dimension(:), pointer, contiguous :: ibound !< pointer to GWE ibound array + ! -- local + ! -- formats + character(len=*), parameter :: fmtmst = & + "(1x,/1x,'MST -- MOBILE STORAGE AND TRANSFER PACKAGE, VERSION 1, & + &7/29/2020 INPUT READ FROM UNIT ', i0, //)" + ! + ! --print a message identifying the immobile domain package. + write (this%iout, fmtmst) this%inunit + ! + ! -- Read options + call this%read_options() + ! + ! -- store pointers to arguments that were passed in + this%dis => dis + this%ibound => ibound + ! + ! -- Allocate arrays + call this%allocate_arrays(dis%nodes) + ! + ! -- read the data block + call this%read_data() + ! + ! -- Return + return + end subroutine mst_ar + + !> @ brief Fill coefficient method for package + !! + !! Method to calculate and fill coefficients for the package. + !! + !< + subroutine mst_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, cnew, & + rhs, kiter) + ! -- modules + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step + integer(I4B), intent(in) :: nja !< number of GWE connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step + integer(I4B), intent(in) :: kiter !< solution outer iteration number + ! -- local + ! + ! -- storage contribution + call this%mst_fc_sto(nodes, cold, nja, njasln, amatsln, idxglo, rhs) + ! + ! -- decay contribution + if (this%idcy /= 0) then + call this%mst_fc_dcy(nodes, cold, cnew, nja, njasln, amatsln, idxglo, & + rhs, kiter) + end if + ! + ! -- Return + return + end subroutine mst_fc + + !> @ brief Fill storage coefficient method for package + !! + !! Method to calculate and fill storage coefficients for the package. + !! + !< + subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step + integer(I4B), intent(in) :: nja !< number of GWE connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + ! -- local + integer(I4B) :: n, idiag + real(DP) :: tled + real(DP) :: hhcof, rrhs + real(DP) :: vnew, vold, vcell, vsolid, term + ! + ! -- set variables + tled = DONE / delt + ! + ! -- loop through and calculate storage contribution to hcof and rhs + do n = 1, this%dis%nodes + ! + ! -- skip if transport inactive + if (this%ibound(n) <= 0) cycle + ! + ! -- calculate new and old water volumes and solid volume + vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) + vnew = vcell * this%fmi%gwfsat(n) * this%porosity(n) + vold = vnew + if (this%fmi%igwfstrgss /= 0) vold = vold + this%fmi%gwfstrgss(n) * delt + if (this%fmi%igwfstrgsy /= 0) vold = vold + this%fmi%gwfstrgsy(n) * delt + vsolid = vcell * (DONE - this%porosity(n)) + ! + ! -- add terms to diagonal and rhs accumulators + term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow(n) * this%cpw(n)) + hhcof = -(vnew + term) * tled + rrhs = -(vold + term) * tled * cold(n) + idiag = this%dis%con%ia(n) + amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof + rhs(n) = rhs(n) + rrhs + end do + ! + ! -- Return + return + end subroutine mst_fc_sto + + !> @ brief Fill decay coefficient method for package + !! + !! Method to calculate and fill decay coefficients for the package. + !! + !< + subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & + idxglo, rhs, kiter) + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer, intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step + real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step + integer(I4B), intent(in) :: nja !< number of GWE connections + integer(I4B), intent(in) :: njasln !< number of connections in solution + real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) + real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model + integer(I4B), intent(in) :: kiter !< solution outer iteration number + ! -- local + integer(I4B) :: n, idiag + real(DP) :: hhcof, rrhs + real(DP) :: swtpdt + real(DP) :: vcell + real(DP) :: decay_rate + ! + ! -- loop through and calculate decay contribution to hcof and rhs + do n = 1, this%dis%nodes + ! + ! -- skip if transport inactive + if (this%ibound(n) <= 0) cycle + ! + ! -- calculate new and old water volumes + vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) + swtpdt = this%fmi%gwfsat(n) + ! + ! -- add decay rate terms to accumulators + idiag = this%dis%con%ia(n) + if (this%idcy == 1) then + ! + ! -- first order decay rate is a function of temperature, so add + ! to left hand side + hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) + amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof + elseif (this%idcy == 2) then + ! + ! -- Call function to get zero-order decay rate, which may be changed + ! from the user-specified rate to prevent negative temperatures ! kluge note: think through negative temps + decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & + kiter, cold(n), cnew(n), delt) + this%decaylast(n) = decay_rate + rrhs = decay_rate * vcell * swtpdt * this%porosity(n) + rhs(n) = rhs(n) + rrhs + end if + ! + end do + ! + ! -- Return + return + end subroutine mst_fc_dcy + + !> @ brief Calculate flows for package + !! + !! Method to calculate flows for the package. + !! + !< + subroutine mst_cq(this, nodes, cnew, cold, flowja) + ! -- modules + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + ! -- local + ! + ! - storage + call this%mst_cq_sto(nodes, cnew, cold, flowja) + ! + ! -- decay + if (this%idcy /= 0) then + call this%mst_cq_dcy(nodes, cnew, cold, flowja) + end if + ! + ! -- Return + return + end subroutine mst_cq + + !> @ brief Calculate storage terms for package + !! + !! Method to calculate storage terms for the package. + !! + !< + subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + ! -- local + integer(I4B) :: n + integer(I4B) :: idiag + real(DP) :: rate + real(DP) :: tled + real(DP) :: vnew, vold, vcell, vsolid, term + real(DP) :: hhcof, rrhs + ! + ! -- initialize + tled = DONE / delt + ! + ! -- Calculate storage change + do n = 1, nodes + this%ratesto(n) = DZERO + ! + ! -- skip if transport inactive + if (this%ibound(n) <= 0) cycle + ! + ! -- calculate new and old water volumes and solid volume + vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) + vnew = vcell * this%fmi%gwfsat(n) * this%porosity(n) + vold = vnew + if (this%fmi%igwfstrgss /= 0) vold = vold + this%fmi%gwfstrgss(n) * delt + if (this%fmi%igwfstrgsy /= 0) vold = vold + this%fmi%gwfstrgsy(n) * delt + vsolid = vcell * (DONE - this%porosity(n)) + ! + ! -- calculate rate + term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow(n) * this%cpw(n)) + hhcof = -(vnew + term) * tled + rrhs = -(vold + term) * tled * cold(n) + rate = hhcof * cnew(n) - rrhs + this%ratesto(n) = rate + idiag = this%dis%con%ia(n) + flowja(idiag) = flowja(idiag) + rate + end do + ! + ! -- Return + return + end subroutine mst_cq_sto + + !> @ brief Calculate decay terms for package + !! + !! Method to calculate decay terms for the package. + !! + !< + subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) + ! -- modules + use TdisModule, only: delt + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step + real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step + real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow between two connected control volumes + ! -- local + integer(I4B) :: n + integer(I4B) :: idiag + real(DP) :: rate + real(DP) :: swtpdt + real(DP) :: hhcof, rrhs + real(DP) :: vcell + real(DP) :: decay_rate + ! + ! -- initialize + ! + ! -- Calculate decay change + do n = 1, nodes + ! + ! -- skip if transport inactive + this%ratedcy(n) = DZERO + if (this%ibound(n) <= 0) cycle + ! + ! -- calculate new and old water volumes + vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) + swtpdt = this%fmi%gwfsat(n) + ! + ! -- calculate decay gains and losses + rate = DZERO + hhcof = DZERO + rrhs = DZERO + if (this%idcy == 1) then + hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) + elseif (this%idcy == 2) then + decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & + 0, cold(n), cnew(n), delt) + rrhs = decay_rate * vcell * swtpdt * this%porosity(n) + end if + rate = hhcof * cnew(n) - rrhs + this%ratedcy(n) = rate + idiag = this%dis%con%ia(n) + flowja(idiag) = flowja(idiag) + rate + ! + end do + ! + ! -- Return + return + end subroutine mst_cq_dcy + + !> @ brief Calculate budget terms for package + !! + !! Method to calculate budget terms for the package. + !! + !< + subroutine mst_bd(this, isuppress_output, model_budget) + ! -- modules + use TdisModule, only: delt + use BudgetModule, only: BudgetType, rate_accumulator + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer(I4B), intent(in) :: isuppress_output !< flag to supress output + type(BudgetType), intent(inout) :: model_budget !< model budget object + ! -- local + real(DP) :: rin + real(DP) :: rout + ! + ! -- sto + call rate_accumulator(this%ratesto, rin, rout) + call model_budget%addentry(rin, rout, delt, budtxt(1), & + isuppress_output, rowlabel=this%packName) + ! + ! -- dcy + if (this%idcy /= 0) then + call rate_accumulator(this%ratedcy, rin, rout) + call model_budget%addentry(rin, rout, delt, budtxt(2), & + isuppress_output, rowlabel=this%packName) + end if + ! + ! -- Return + return + end subroutine mst_bd + + !> @ brief Output flow terms for package + !! + !! Method to output terms for the package. + !! + !< + subroutine mst_ot_flow(this, icbcfl, icbcun) + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer(I4B), intent(in) :: icbcfl !< flag and unit number for cell-by-cell output + integer(I4B), intent(in) :: icbcun !< flag indication if cell-by-cell data should be saved + ! -- local + integer(I4B) :: ibinun + !character(len=16), dimension(2) :: aname + integer(I4B) :: iprint, nvaluesp, nwidthp + character(len=1) :: cdatafmp = ' ', editdesc = ' ' + real(DP) :: dinact + ! + ! -- Set unit number for binary output + if (this%ipakcb < 0) then + ibinun = icbcun + elseif (this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + end if + if (icbcfl == 0) ibinun = 0 + ! + ! -- Record the storage rate if requested + if (ibinun /= 0) then + iprint = 0 + dinact = DZERO + ! + ! -- sto + call this%dis%record_array(this%ratesto, this%iout, iprint, -ibinun, & + budtxt(1), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + ! + ! -- dcy + if (this%idcy /= 0) & + call this%dis%record_array(this%ratedcy, this%iout, iprint, -ibinun, & + budtxt(2), cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + ! + ! -- Return + return + end subroutine mst_ot_flow + + !> @ brief Deallocate + !! + !! Method to deallocate memory for the package. + !! + !< + subroutine mst_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweMstType) :: this !< GweMstType object + ! + ! -- Deallocate arrays if package was active + if (this%inunit > 0) then + call mem_deallocate(this%porosity) + call mem_deallocate(this%ratesto) + call mem_deallocate(this%idcy) + call mem_deallocate(this%decay) + call mem_deallocate(this%ratedcy) + call mem_deallocate(this%decaylast) + call mem_deallocate(this%cpw) + call mem_deallocate(this%cps) + call mem_deallocate(this%rhow) + call mem_deallocate(this%rhos) + this%ibound => null() + this%fmi => null() + end if + ! + ! -- Scalars + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine mst_da + + !> @ brief Allocate scalar variables for package + !! + !! Method to allocate scalar variables for the package. + !! + !< + subroutine allocate_scalars(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate, mem_setptr + ! -- dummy + class(GweMstType) :: this !< GweMstType object + ! -- local + ! + ! -- Allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%idcy, 'IDCY', this%memoryPath) + ! + ! -- Initialize + this%idcy = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + !> @ brief Allocate arrays for package + !! + !! Method to allocate arrays for the package. + !! + !< + subroutine allocate_arrays(this, nodes) + ! -- modules + use MemoryManagerModule, only: mem_allocate + use ConstantsModule, only: DZERO + ! -- dummy + class(GweMstType) :: this !< GweMstType object + integer(I4B), intent(in) :: nodes !< number of nodes + ! -- local + integer(I4B) :: n + ! + ! -- Allocate + ! -- sto + call mem_allocate(this%porosity, nodes, 'POROSITY', this%memoryPath) + call mem_allocate(this%ratesto, nodes, 'RATESTO', this%memoryPath) + call mem_allocate(this%cpw, nodes, 'CPW', this%memoryPath) + call mem_allocate(this%cps, nodes, 'CPS', this%memoryPath) + call mem_allocate(this%rhow, nodes, 'RHOW', this%memoryPath) + call mem_allocate(this%rhos, nodes, 'RHOS', this%memoryPath) + ! + ! -- dcy + if (this%idcy == 0) then + call mem_allocate(this%ratedcy, 1, 'RATEDCY', this%memoryPath) + call mem_allocate(this%decay, 1, 'DECAY', this%memoryPath) + call mem_allocate(this%decaylast, 1, 'DECAYLAST', this%memoryPath) + else + call mem_allocate(this%ratedcy, this%dis%nodes, 'RATEDCY', this%memoryPath) + call mem_allocate(this%decay, nodes, 'DECAY', this%memoryPath) + call mem_allocate(this%decaylast, nodes, 'DECAYLAST', this%memoryPath) + end if + ! + ! -- Initialize + do n = 1, nodes + this%porosity(n) = DZERO + this%ratesto(n) = DZERO + this%cpw(n) = DZERO + this%cps(n) = DZERO + this%rhow(n) = DZERO + this%rhos(n) = DZERO + end do + do n = 1, size(this%decay) + this%decay(n) = DZERO + this%ratedcy(n) = DZERO + this%decaylast(n) = DZERO + end do + ! + ! -- Return + return + end subroutine allocate_arrays + + !> @ brief Read options for package + !! + !! Method to read options for the package. + !! + !< + subroutine read_options(this) + ! -- modules + use ConstantsModule, only: LINELENGTH + ! -- dummy + class(GweMstType) :: this !< GweMstType object + ! -- local + character(len=LINELENGTH) :: keyword, keyword2 + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats + character(len=*), parameter :: fmtisvflow = & + "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY "// & + "FILE WHENEVER ICBCFL IS NOT ZERO.')" + character(len=*), parameter :: fmtidcy1 = & + "(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" + character(len=*), parameter :: fmtidcy2 = & + "(4x,'ZERO-ORDER DECAY IS ACTIVE. ')" + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & + supportOpenClose=.true.) + ! + ! -- parse options block if detected + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING MOBILE STORAGE AND TRANSFER OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, fmtisvflow) + case ('FIRST_ORDER_DECAY') + this%idcy = 1 + write (this%iout, fmtidcy1) + case ('ZERO_ORDER_DECAY') + this%idcy = 2 + write (this%iout, fmtidcy2) + case default + write (errmsg, '(a,a)') 'UNKNOWN MST OPTION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + end do + write (this%iout, '(1x,a)') 'END OF MOBILE STORAGE AND TRANSFER OPTIONS' + end if + ! + ! -- Return + return + end subroutine read_options + + !> @ brief Read data for package + !! + !! Method to read data for the package. + !! + !< + subroutine read_data(this) + ! -- modules + use ConstantsModule, only: LINELENGTH + use MemoryManagerModule, only: mem_reallocate, mem_reassignptr + ! -- dummy + class(GweMstType) :: this !< GweMstType object + ! -- local + character(len=LINELENGTH) :: keyword + character(len=:), allocatable :: line + integer(I4B) :: istart, istop, lloc, ierr + logical :: isfound, endOfBlock + logical, dimension(10) :: lname + character(len=24), dimension(6) :: aname + ! -- formats + ! -- data + data aname(1)/' MOBILE DOMAIN POROSITY'/ + data aname(2)/' DECAY RATE'/ + data aname(3)/' HEAT CAPACITY OF WATER'/ + data aname(4)/' HEAT CAPACITY OF SOLIDS'/ + data aname(5)/' DENSITY OF WATER'/ + data aname(6)/' DENSITY OF SOLIDS'/ + ! + ! -- initialize + isfound = .false. + lname(:) = .false. + ! + ! -- get griddata block + call this%parser%GetBlock('GRIDDATA', isfound, ierr) + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + call this%parser%GetRemainingLine(line) + lloc = 1 + select case (keyword) + case ('POROSITY') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%porosity, & + aname(1)) + lname(1) = .true. + case ('DECAY') + if (this%idcy == 0) & + call mem_reallocate(this%decay, this%dis%nodes, 'DECAY', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%decay, & + aname(2)) + lname(2) = .true. + case ('CPW') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%cpw, & + aname(3)) + lname(3) = .true. + case ('CPS') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%cps, & + aname(4)) + lname(4) = .true. + case ('RHOW') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%rhow, & + aname(5)) + lname(5) = .true. + case ('RHOS') + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%rhos, & + aname(6)) + lname(6) = .true. + case default + write (errmsg, '(a,a)') 'UNKNOWN GRIDDATA TAG: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + end do + write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' + else + write (errmsg, '(a)') 'REQUIRED GRIDDATA BLOCK NOT FOUND.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + ! + ! -- Check for required porosity + if (.not. lname(1)) then + write (errmsg, '(a)') 'POROSITY NOT SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + if (.not. lname(3)) then + write (errmsg, '(a)') 'CPW NOT SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + if (.not. lname(4)) then + write (errmsg, '(a)') 'CPS NOT SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + if (.not. lname(5)) then + write (errmsg, '(a)') 'RHOW NOT SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + if (.not. lname(6)) then + write (errmsg, '(a)') 'RHOS NOT SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + ! + ! -- Check for required decay/production rate coefficients + if (this%idcy > 0) then + if (.not. lname(2)) then + write (errmsg, '(a)') 'FIRST OR ZERO ORDER DECAY IS & + &ACTIVE BUT THE FIRST RATE COEFFICIENT IS NOT SPECIFIED. DECAY & + &MUST BE SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + else + if (lname(2)) then + write (warnmsg, '(a)') 'FIRST OR ZERO ORER DECAY & + &IS NOT ACTIVE BUT DECAY WAS SPECIFIED. DECAY WILL & + &HAVE NO AFFECT ON SIMULATION RESULTS.' + call store_warning(warnmsg) + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if + end if + ! + ! -- terminate if errors + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- Return + return + end subroutine read_data + + !> @ brief Calculate zero-order decay rate and constrain if necessary + !! + !! Function to calculate the zero-order decay rate from the user specified + !! decay rate. If the decay rate is positive, then the decay rate must + !! be constrained so that more energy is not removed than is available. + !! Without this constraint, negative temperatures could result from ! kluge note: modified wording from mass/conc but need to think this through (no freezing) + !! zero-order decay. + !< + function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & + cold, cnew, delt) result(decay_rate) + ! -- dummy + real(DP), intent(in) :: decay_rate_usr !< user-entered decay rate + real(DP), intent(in) :: decay_rate_last !< decay rate used for last iteration + integer(I4B), intent(in) :: kiter !< Picard iteration counter + real(DP), intent(in) :: cold !< temperature at end of last time step + real(DP), intent(in) :: cnew !< temperature at end of this time step + real(DP), intent(in) :: delt !< length of time step + ! -- return + real(DP) :: decay_rate !< returned value for decay rate + ! + ! -- Return user rate if production, otherwise constrain, if necessary + if (decay_rate_usr < DZERO) then + ! + ! -- Production, no need to limit rate + decay_rate = decay_rate_usr + else + ! + ! -- Need to ensure decay does not result in negative + ! temperature, so reduce the rate if it would result in + ! removing more energy than is in the cell. ! kluge note: think through + if (kiter == 1) then + decay_rate = min(decay_rate_usr, cold / delt) + else + decay_rate = decay_rate_last + if (cnew < DZERO) then + decay_rate = decay_rate_last + cnew / delt + else if (cnew > cold) then + decay_rate = decay_rate_last + cnew / delt + end if + decay_rate = min(decay_rate_usr, decay_rate) + end if + decay_rate = max(decay_rate, DZERO) + end if + return + end function get_zero_order_decay + +end module GweMstModule diff --git a/src/Model/GroundWaterTransport/gwt1dsp.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/gwt1dsp.f90 rename to src/Model/GroundWaterTransport/gwt1dsp1.f90 From e94c7767341adfce2884031dac4b626889cd9784 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 14 Jul 2022 10:07:53 -0700 Subject: [PATCH 015/212] Applied fprettify to a few files I modified --- src/Exchange/GweGweExchange.f90 | 607 +++++++------ src/Exchange/GwfGweExchange.f90 | 209 ++--- src/Model/Connection/GweGweConnection.f90 | 956 ++++++++++---------- src/Model/Connection/GweInterfaceModel.f90 | 378 ++++---- src/Model/ModelUtilities/TspAdvOptions.f90 | 2 +- src/Model/ModelUtilities/TspDspGridData.f90 | 102 +-- src/Model/ModelUtilities/TspDspOptions.f90 | 2 +- src/Model/ModelUtilities/TspLabels.f90 | 108 +-- src/Model/TransportModel.f90 | 81 +- 9 files changed, 1250 insertions(+), 1195 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index 180b5fb6de5..1938822905a 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -9,26 +9,26 @@ !< module GweGweExchangeModule - use KindModule, only: DP, I4B, LGP - use SimVariablesModule, only: errmsg - use SimModule, only: store_error - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & - TABCENTER, TABLEFT, LENAUXNAME, DNODATA, & - LENMODELNAME - use ListModule, only: ListType - use ListsModule, only: basemodellist - use DisConnExchangeModule, only: DisConnExchangeType - use GweModule, only: GweModelType - use TspMvtModule, only: TspMvtType - use ObserveModule, only: ObserveType - use ObsModule, only: ObsType - use SimModule, only: count_errors, store_error, & - store_error_unit, ustop - use SimVariablesModule, only: errmsg - use BlockParserModule, only: BlockParserType - use TableModule, only: TableType, table_cr + use KindModule, only: DP, I4B, LGP + use SimVariablesModule, only: errmsg + use SimModule, only: store_error + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use ConstantsModule, only: LENBOUNDNAME, NAMEDBOUNDFLAG, LINELENGTH, & + TABCENTER, TABLEFT, LENAUXNAME, DNODATA, & + LENMODELNAME + use ListModule, only: ListType + use ListsModule, only: basemodellist + use DisConnExchangeModule, only: DisConnExchangeType + use GweModule, only: GweModelType + use TspMvtModule, only: TspMvtType + use ObserveModule, only: ObserveType + use ObsModule, only: ObsType + use SimModule, only: count_errors, store_error, & + store_error_unit, ustop + use SimVariablesModule, only: errmsg + use BlockParserModule, only: BlockParserType + use TableModule, only: TableType, table_cr implicit none @@ -38,7 +38,7 @@ module GweGweExchangeModule public :: GetGweExchangeFromList public :: CastAsGweExchange - !> @brief Derived type for GwtExchangeType + !> @brief Derived type for GwtExchangeType !! !! This derived type contains information and methods for !! connecting two GWT models. @@ -47,58 +47,58 @@ module GweGweExchangeModule type, extends(DisConnExchangeType) :: GweExchangeType ! ! -- names of the GWF models that are connected by this exchange - character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of gwfmodel that corresponds to gwtmodel1 - character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of gwfmodel that corresponds to gwtmodel2 + character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of gwfmodel that corresponds to gwtmodel1 + character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of gwfmodel that corresponds to gwtmodel2 ! ! -- pointers to gwt models - type(GweModelType), pointer :: gwemodel1 => null() !< pointer to GWT Model 1 - type(GweModelType), pointer :: gwemodel2 => null() !< pointer to GWT Model 2 - ! - ! -- GWT specific option block: - integer(I4B), pointer :: inewton => null() !< unneeded newton flag allows for mvt to be used here - integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows - integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows - integer(I4B), pointer :: iAdvScheme !< the advection scheme at the interface: - !! 0 = upstream, 1 = central, 2 = TVD + type(GweModelType), pointer :: gwemodel1 => null() !< pointer to GWT Model 1 + type(GweModelType), pointer :: gwemodel2 => null() !< pointer to GWT Model 2 + ! + ! -- GWT specific option block: + integer(I4B), pointer :: inewton => null() !< unneeded newton flag allows for mvt to be used here + integer(I4B), pointer :: iprflow => null() !< print flag for cell by cell flows + integer(I4B), pointer :: ipakcb => null() !< save flag for cell by cell flows + integer(I4B), pointer :: iAdvScheme !< the advection scheme at the interface: + !! 0 = upstream, 1 = central, 2 = TVD ! ! -- Mover transport package - integer(I4B), pointer :: inmvt => null() !< unit number for mover transport (0 if off) - type(TspMvtType), pointer :: mvt => null() !< water mover object + integer(I4B), pointer :: inmvt => null() !< unit number for mover transport (0 if off) + type(TspMvtType), pointer :: mvt => null() !< water mover object ! ! -- Observation package - integer(I4B), pointer :: inobs => null() !< unit number for GWT-GWT observations - type(ObsType), pointer :: obs => null() !< observation object + integer(I4B), pointer :: inobs => null() !< unit number for GWT-GWT observations + type(ObsType), pointer :: obs => null() !< observation object ! ! -- internal data - real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance - real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange + real(DP), dimension(:), pointer, contiguous :: cond => null() !< conductance + real(DP), dimension(:), pointer, contiguous :: simvals => null() !< simulated flow rate for each exchange ! ! -- table objects type(TableType), pointer :: outputtab1 => null() - type(TableType), pointer :: outputtab2 => null() + type(TableType), pointer :: outputtab2 => null() contains - procedure :: exg_df => gwe_gwe_df - procedure :: exg_ar => gwe_gwe_ar - procedure :: exg_rp => gwe_gwe_rp - procedure :: exg_ad => gwe_gwe_ad - procedure :: exg_fc => gwe_gwe_fc - procedure :: exg_bd => gwe_gwe_bd - procedure :: exg_ot => gwe_gwe_ot - procedure :: exg_da => gwe_gwe_da - procedure :: exg_fp => gwe_gwe_fp - procedure :: connects_model => gwe_gwe_connects_model - procedure :: use_interface_model - procedure :: allocate_scalars - procedure :: allocate_arrays - procedure :: read_options - procedure :: parse_option - procedure :: read_mvt - procedure :: gwe_gwe_bdsav + procedure :: exg_df => gwe_gwe_df + procedure :: exg_ar => gwe_gwe_ar + procedure :: exg_rp => gwe_gwe_rp + procedure :: exg_ad => gwe_gwe_ad + procedure :: exg_fc => gwe_gwe_fc + procedure :: exg_bd => gwe_gwe_bd + procedure :: exg_ot => gwe_gwe_ot + procedure :: exg_da => gwe_gwe_da + procedure :: exg_fp => gwe_gwe_fp + procedure :: connects_model => gwe_gwe_connects_model + procedure :: use_interface_model + procedure :: allocate_scalars + procedure :: allocate_arrays + procedure :: read_options + procedure :: parse_option + procedure :: read_mvt + procedure :: gwe_gwe_bdsav procedure, private :: gwe_gwe_df_obs procedure, private :: gwe_gwe_rp_obs - procedure, public :: gwe_gwe_save_simvals + procedure, public :: gwe_gwe_save_simvals procedure, private :: validate_exchange end type GweExchangeType @@ -117,10 +117,10 @@ subroutine gweexchange_create(filename, id, m1id, m2id) use ObsModule, only: obs_cr use MemoryHelperModule, only: create_mem_path ! -- dummy - character(len=*),intent(in) :: filename !< filename for reading - integer(I4B), intent(in) :: id !< id for the exchange - integer(I4B), intent(in) :: m1id !< id for model 1 - integer(I4B), intent(in) :: m2id !< id for model 2 + character(len=*), intent(in) :: filename !< filename for reading + integer(I4B), intent(in) :: id !< id for the exchange + integer(I4B), intent(in) :: m1id !< id for model 1 + integer(I4B), intent(in) :: m2id !< id for model 2 ! -- local type(GweExchangeType), pointer :: exchange class(BaseModelType), pointer :: mb @@ -128,14 +128,14 @@ subroutine gweexchange_create(filename, id, m1id, m2id) character(len=20) :: cint ! ! -- Create a new exchange and add it to the baseexchangelist container - allocate(exchange) + allocate (exchange) baseexchange => exchange call AddBaseExchangeToList(baseexchangelist, baseexchange) ! ! -- Assign id and name exchange%id = id - write(cint, '(i0)') id - exchange%name = 'GWE-GWE_' // trim(adjustl(cint)) + write (cint, '(i0)') id + exchange%name = 'GWE-GWE_'//trim(adjustl(cint)) exchange%memoryPath = create_mem_path(exchange%name) ! ! -- allocate scalars and set defaults @@ -146,7 +146,7 @@ subroutine gweexchange_create(filename, id, m1id, m2id) exchange%ixt3d = 1 ! ! -- set gwtmodel1 - mb => GetBaseModelFromList(basemodellist, m1id) + mb => GetBaseModelFromList(basemodellist, m1id) select type (mb) type is (GweModelType) exchange%model1 => mb @@ -163,7 +163,7 @@ subroutine gweexchange_create(filename, id, m1id, m2id) ! ! -- Verify that gwt model1 is of the correct type if (.not. associated(exchange%gwemodel1)) then - write(errmsg, '(3a)') 'Problem with GWE-GWE exchange ', & + write (errmsg, '(3a)') 'Problem with GWE-GWE exchange ', & trim(exchange%name), & '. First specified GWE Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) @@ -171,7 +171,7 @@ subroutine gweexchange_create(filename, id, m1id, m2id) ! ! -- Verify that gwf model2 is of the correct type if (.not. associated(exchange%gwemodel2)) then - write(errmsg, '(3a)') 'Problem with GWE-GWE exchange ', & + write (errmsg, '(3a)') 'Problem with GWE-GWE exchange ', & trim(exchange%name), & '. Second specified GWE Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) @@ -195,25 +195,25 @@ subroutine gwe_gwe_df(this) use InputOutputModule, only: getunit, openfile use GhostNodeModule, only: gnc_cr ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! -- local integer(I4B) :: inunit ! ! -- open the file inunit = getunit() - write(iout,'(/a,a)') ' Creating exchange: ', this%name + write (iout, '(/a,a)') ' Creating exchange: ', this%name call openfile(inunit, iout, this%filename, 'GWE-GWE') ! call this%parser%Initialize(inunit, iout) ! ! -- Ensure models are in same solution - if(this%gwemodel1%idsoln /= this%gwemodel2%idsoln) then - call store_error('ERROR. TWO MODELS ARE CONNECTED ' // & - 'IN A GWE EXCHANGE BUT THEY ARE IN DIFFERENT SOLUTIONS. ' // & - 'GWE MODELS MUST BE IN SAME SOLUTION: ' // & - trim(this%gwemodel1%name) // ' ' // trim(this%gwemodel2%name) ) + if (this%gwemodel1%idsoln /= this%gwemodel2%idsoln) then + call store_error('ERROR. TWO MODELS ARE CONNECTED '// & + 'IN A GWE EXCHANGE BUT THEY ARE IN DIFFERENT '// & + 'SOLUTIONS. GWE MODELS MUST BE IN SAME SOLUTION: '// & + trim(this%gwemodel1%name)//' '//trim(this%gwemodel2%name)) call this%parser%StoreErrorUnit() - endif + end if ! ! -- read options call this%read_options(iout) @@ -228,17 +228,17 @@ subroutine gwe_gwe_df(this) call this%read_data(iout) ! ! -- Read mover information - if(this%inmvt > 0) then + if (this%inmvt > 0) then call this%read_mvt(iout) call this%mvt%mvt_df(this%gwemodel1%dis) - endif + end if ! ! -- close the file - close(inunit) + close (inunit) ! ! -- Store obs call this%gwe_gwe_df_obs() - call this%obs%obs_df(iout, this%name, 'GWE-GWE', this%gwemodel1%dis) + call this%obs%obs_df(iout, this%name, 'GWE-GWE', this%gwemodel1%dis) ! ! -- validate call this%validate_exchange() @@ -250,29 +250,29 @@ end subroutine gwe_gwe_df !> @brief validate exchange data after reading !< subroutine validate_exchange(this) - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType ! local - + ! Ensure gwfmodel names were entered if (this%gwfmodelname1 == '') then - write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + write (errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & ' requires that GWFMODELNAME1 be entered in the & &OPTIONS block.' call store_error(errmsg) end if if (this%gwfmodelname2 == '') then - write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + write (errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & ' requires that GWFMODELNAME2 be entered in the & &OPTIONS block.' call store_error(errmsg) end if - + ! Periodic boundary condition in exchange don't allow XT3D (=interface model) if (associated(this%model1, this%model2)) then if (this%ixt3d > 0) then - write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & - ' is a periodic boundary condition which cannot'// & - ' be configured with XT3D' + write (errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' is a periodic boundary condition which cannot'// & + ' be configured with XT3D' call store_error(errmsg) end if end if @@ -280,23 +280,23 @@ subroutine validate_exchange(this) ! Check to see if dispersion is on in either model1 or model2. ! If so, then ANGLDEGX must be provided as an auxiliary variable for this ! GWE-GWE exchange (this%ianglex > 0). - if(this%gwemodel1%indsp /= 0 .or. this%gwemodel2%indsp /= 0) then - if(this%ianglex == 0) then - write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because dispersion was '// & - 'specified in one or both transport models.' + if (this%gwemodel1%indsp /= 0 .or. this%gwemodel2%indsp /= 0) then + if (this%ianglex == 0) then + write (errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because dispersion was '// & + 'specified in one or both transport models.' call store_error(errmsg) - endif - endif + end if + end if if (this%ixt3d > 0 .and. this%ianglex == 0) then - write(errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & - ' requires that ANGLDEGX be specified as an'// & - ' auxiliary variable because XT3D is enabled' + write (errmsg, '(3a)') 'GWE-GWE exchange ', trim(this%name), & + ' requires that ANGLDEGX be specified as an'// & + ' auxiliary variable because XT3D is enabled' call store_error(errmsg) end if - + if (count_errors() > 0) then call ustop() end if @@ -311,19 +311,18 @@ end subroutine validate_exchange subroutine gwe_gwe_ar(this) ! -- modules ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! -- local ! ! -- If mover is active, then call ar routine - if(this%inmvt > 0) call this%mvt%mvt_ar() + if (this%inmvt > 0) call this%mvt%mvt_ar() ! ! -- Observation AR call this%obs%obs_ar() ! ! -- Return return - end subroutine gwe_gwe_ar - + end subroutine gwe_gwe_ar !> @ brief Read and prepare !! @@ -334,13 +333,13 @@ subroutine gwe_gwe_rp(this) ! -- modules use TdisModule, only: readnewdata ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType ! ! -- Check with TDIS on whether or not it is time to RP if (.not. readnewdata) return ! ! -- Read and prepare for mover - if(this%inmvt > 0) call this%mvt%mvt_rp() + if (this%inmvt > 0) call this%mvt%mvt_rp() ! ! -- Read and prepare for observations call this%gwe_gwe_rp_obs() @@ -357,7 +356,7 @@ end subroutine gwe_gwe_rp subroutine gwe_gwe_ad(this) ! -- modules ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType ! -- local ! ! -- Advance mover @@ -378,16 +377,16 @@ end subroutine gwe_gwe_ad subroutine gwe_gwe_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) ! -- modules ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: kiter integer(I4B), dimension(:), intent(in) :: iasln real(DP), dimension(:), intent(inout) :: amatsln - real(DP), dimension(:), intent(inout) ::rhssln + real(DP), dimension(:), intent(inout) :: rhssln integer(I4B), optional, intent(in) :: inwtflag ! -- local ! ! -- Call mvt fc routine - if(this%inmvt > 0) call this%mvt%mvt_fc(this%gwemodel1%x, this%gwemodel2%x) + if (this%inmvt > 0) call this%mvt%mvt_fc(this%gwemodel1%x, this%gwemodel2%x) ! ! -- Return return @@ -403,7 +402,7 @@ subroutine gwe_gwe_bd(this, icnvg, isuppress_output, isolnid) use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME use BudgetModule, only: rate_accumulator ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType integer(I4B), intent(inout) :: icnvg integer(I4B), intent(in) :: isuppress_output integer(I4B), intent(in) :: isolnid @@ -430,12 +429,12 @@ subroutine gwe_gwe_bd(this, icnvg, isuppress_output, isolnid) call this%gwemodel2%model_bdentry(budterm, budtxt, this%name) ! ! -- Call mvt bd routine - if(this%inmvt > 0) call this%mvt%mvt_bd(this%gwemodel1%x, this%gwemodel2%x) + if (this%inmvt > 0) call this%mvt%mvt_bd(this%gwemodel1%x, this%gwemodel2%x) ! ! -- return return end subroutine gwe_gwe_bd - + !> @ brief Budget save !! !! Output individual flows to listing file and binary budget files @@ -446,11 +445,11 @@ subroutine gwe_gwe_bdsav(this) use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME use TdisModule, only: kstp, kper ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! -- local character(len=LENBOUNDNAME) :: bname - character(len=LENPACKAGENAME+4) :: packname1 - character(len=LENPACKAGENAME+4) :: packname2 + character(len=LENPACKAGENAME + 4) :: packname1 + character(len=LENPACKAGENAME + 4) :: packname2 character(len=LENBUDTXT), dimension(1) :: budtxt character(len=20) :: nodestr integer(I4B) :: ntabrows @@ -477,7 +476,7 @@ subroutine gwe_gwe_bdsav(this) if (this%gwemodel1%oc%oc_save('BUDGET')) then call this%outputtab1%set_title(packname1) end if - if (this%gwemodel2%oc%oc_save('BUDGET')) then + if (this%gwemodel2%oc%oc_save('BUDGET')) then call this%outputtab2%set_title(packname2) end if ! @@ -492,7 +491,7 @@ subroutine gwe_gwe_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if (this%gwemodel1%ibound(n1) /= 0 .and. & + if (this%gwemodel1%ibound(n1) /= 0 .and. & this%gwemodel2%ibound(n2) /= 0) then ntabrows = ntabrows + 1 end if @@ -506,27 +505,26 @@ subroutine gwe_gwe_bdsav(this) ! -- Print and write budget terms for model 1 ! ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then + if (this%ipakcb /= 0) then ibinun1 = this%gwemodel1%oc%oc_save_unit('BUDGET') else ibinun1 = 0 - endif + end if ! ! -- If save budget flag is zero for this stress period, then ! shut off saving - if(.not. this%gwemodel1%oc%oc_save('BUDGET')) ibinun1 = 0 - if(isuppress_output /= 0) then + if (.not. this%gwemodel1%oc%oc_save('BUDGET')) ibinun1 = 0 + if (isuppress_output /= 0) then ibinun1 = 0 - endif + end if ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun1 /= 0) then - call this%gwemodel1%dis%record_srcdst_list_header(budtxt(1), & - this%gwemodel1%name, this%name, & - this%gwemodel2%name, this%name, & - this%naux, this%auxname, & - ibinun1, this%nexg, this%gwemodel1%iout) - endif + if (ibinun1 /= 0) then + call this%gwemodel1%dis%record_srcdst_list_header( & + budtxt(1), this%gwemodel1%name, this%name, & + this%gwemodel2%name, this%name, this%naux, this%auxname, & + ibinun1, this%nexg, this%gwemodel1%iout) + end if ! ! Initialize accumulators ratin = DZERO @@ -536,11 +534,11 @@ subroutine gwe_gwe_bdsav(this) do i = 1, this%nexg ! ! -- Assign boundary name - if (this%inamedbound>0) then + if (this%inamedbound > 0) then bname = this%boundname(i) else bname = '' - endif + end if ! ! -- Calculate the flow rate between n1 and n2 rrate = DZERO @@ -548,62 +546,61 @@ subroutine gwe_gwe_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if(this%gwemodel1%ibound(n1) /= 0 .and. & + if (this%gwemodel1%ibound(n1) /= 0 .and. & this%gwemodel2%ibound(n2) /= 0) then rrate = this%simvals(i) ! ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwemodel1%oc%oc_save('BUDGET')) then + if (this%iprflow /= 0) then + if (this%gwemodel1%oc%oc_save('BUDGET')) then ! ! -- set nodestr and write outputtab table nodeu = this%gwemodel1%dis%get_nodeuser(n1) call this%gwemodel1%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & + call this%outputtab1%print_list_entry(i, trim(adjustl(nodestr)), & rrate, bname) end if - endif - if(rrate < DZERO) then + end if + if (rrate < DZERO) then ratout = ratout - rrate else ratin = ratin + rrate - endif - endif + end if + end if ! ! -- If saving cell-by-cell flows in list, write flow n1u = this%gwemodel1%dis%get_nodeuser(n1) n2u = this%gwemodel2%dis%get_nodeuser(n2) - if(ibinun1 /= 0) & - call this%gwemodel1%dis%record_mf6_list_entry( & - ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & - .false., .false.) + if (ibinun1 /= 0) & + call this%gwemodel1%dis%record_mf6_list_entry( & + ibinun1, n1u, n2u, rrate, this%naux, this%auxvar(:, i), & + .false., .false.) ! - enddo + end do ! ! -- Print and write budget terms for model 2 ! ! -- Set binary unit numbers for saving flows - if(this%ipakcb /= 0) then + if (this%ipakcb /= 0) then ibinun2 = this%gwemodel2%oc%oc_save_unit('BUDGET') else ibinun2 = 0 - endif + end if ! ! -- If save budget flag is zero for this stress period, then ! shut off saving - if(.not. this%gwemodel2%oc%oc_save('BUDGET')) ibinun2 = 0 - if(isuppress_output /= 0) then + if (.not. this%gwemodel2%oc%oc_save('BUDGET')) ibinun2 = 0 + if (isuppress_output /= 0) then ibinun2 = 0 - endif + end if ! ! -- If cell-by-cell flows will be saved as a list, write header. - if(ibinun2 /= 0) then - call this%gwemodel2%dis%record_srcdst_list_header(budtxt(1), & - this%gwemodel2%name, this%name, & - this%gwemodel1%name, this%name, & - this%naux, this%auxname, & - ibinun2, this%nexg, this%gwemodel2%iout) - endif + if (ibinun2 /= 0) then + call this%gwemodel2%dis%record_srcdst_list_header( & + budtxt(1), this%gwemodel2%name, this%name, this%gwemodel1%name, & + this%name, this%naux, this%auxname, ibinun2, this%nexg, & + this%gwemodel2%iout) + end if ! ! Initialize accumulators ratin = DZERO @@ -613,11 +610,11 @@ subroutine gwe_gwe_bdsav(this) do i = 1, this%nexg ! ! -- Assign boundary name - if (this%inamedbound>0) then + if (this%inamedbound > 0) then bname = this%boundname(i) else bname = '' - endif + end if ! ! -- Calculate the flow rate between n1 and n2 rrate = DZERO @@ -625,37 +622,37 @@ subroutine gwe_gwe_bdsav(this) n2 = this%nodem2(i) ! ! -- If both cells are active then calculate flow rate - if(this%gwemodel1%ibound(n1) /= 0 .and. & + if (this%gwemodel1%ibound(n1) /= 0 .and. & this%gwemodel2%ibound(n2) /= 0) then rrate = this%simvals(i) ! ! -- Print the individual rates to model list files if requested - if(this%iprflow /= 0) then - if(this%gwemodel2%oc%oc_save('BUDGET')) then + if (this%iprflow /= 0) then + if (this%gwemodel2%oc%oc_save('BUDGET')) then ! ! -- set nodestr and write outputtab table nodeu = this%gwemodel2%dis%get_nodeuser(n2) call this%gwemodel2%dis%nodeu_to_string(nodeu, nodestr) - call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & + call this%outputtab2%print_list_entry(i, trim(adjustl(nodestr)), & -rrate, bname) end if - endif - if(rrate < DZERO) then + end if + if (rrate < DZERO) then ratout = ratout - rrate else ratin = ratin + rrate - endif - endif + end if + end if ! ! -- If saving cell-by-cell flows in list, write flow n1u = this%gwemodel1%dis%get_nodeuser(n1) n2u = this%gwemodel2%dis%get_nodeuser(n2) - if(ibinun2 /= 0) & - call this%gwemodel2%dis%record_mf6_list_entry( & - ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & - .false., .false.) + if (ibinun2 /= 0) & + call this%gwemodel2%dis%record_mf6_list_entry( & + ibinun2, n2u, n1u, -rrate, this%naux, this%auxvar(:, i), & + .false., .false.) ! - enddo + end do ! ! -- Set icbcfl, ibudfl to zero so that flows will be printed and ! saved, if the options were set in the MVT package @@ -666,14 +663,14 @@ subroutine gwe_gwe_bdsav(this) !cdl todo: if(this%inmvt > 0) call this%mvt%mvt_bdsav(icbcfl, ibudfl, isuppress_output) ! ! -- Calculate and write simulated values for observations - if(this%inobs /= 0) then + if (this%inobs /= 0) then call this%gwe_gwe_save_simvals() - endif + end if ! ! -- return return end subroutine gwe_gwe_bdsav - + !> @ brief Output !! !! Write output @@ -684,46 +681,46 @@ subroutine gwe_gwe_ot(this) use SimVariablesModule, only: iout use ConstantsModule, only: DZERO, LINELENGTH ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType ! -- local integer(I4B) :: iexg, n1, n2 integer(I4B) :: ibudfl real(DP) :: flow character(len=LINELENGTH) :: node1str, node2str ! -- format - character(len=*), parameter :: fmtheader = & + character(len=*), parameter :: fmtheader = & "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & &2a16, 5a16, /, 112('-'))" - character(len=*), parameter :: fmtheader2 = & + character(len=*), parameter :: fmtheader2 = & "(/1x, 'SUMMARY OF EXCHANGE RATES FOR EXCHANGE ', a, ' WITH ID ', i0, /, & &2a16, 4a16, /, 96('-'))" - character(len=*), parameter :: fmtdata = & - "(2a16, 5(1pg16.6))" + character(len=*), parameter :: fmtdata = & + "(2a16, 5(1pg16.6))" ! ! -- Call bdsave call this%gwe_gwe_bdsav() ! ! -- Write a table of exchanges - if(this%iprflow /= 0) then - write(iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & - 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' + if (this%iprflow /= 0) then + write (iout, fmtheader2) trim(adjustl(this%name)), this%id, 'NODEM1', & + 'NODEM2', 'COND', 'X_M1', 'X_M2', 'FLOW' do iexg = 1, this%nexg n1 = this%nodem1(iexg) n2 = this%nodem2(iexg) flow = this%simvals(iexg) call this%gwemodel1%dis%noder_to_string(n1, node1str) call this%gwemodel2%dis%noder_to_string(n2, node2str) - write(iout, fmtdata) trim(adjustl(node1str)), & - trim(adjustl(node2str)), & - this%cond(iexg), this%gwemodel1%x(n1), & - this%gwemodel2%x(n2), flow - enddo - endif + write (iout, fmtdata) trim(adjustl(node1str)), & + trim(adjustl(node2str)), & + this%cond(iexg), this%gwemodel1%x(n1), & + this%gwemodel2%x(n2), flow + end do + end if ! !cdl Implement when MVT is ready ! -- Mover budget output ibudfl = 1 - if(this%inmvt > 0) call this%mvt%mvt_ot_bdsummary(ibudfl) + if (this%inmvt > 0) call this%mvt%mvt_ot_bdsummary(ibudfl) ! ! -- OBS output call this%obs%obs_ot() @@ -740,24 +737,24 @@ end subroutine gwe_gwe_ot subroutine read_options(this, iout) ! -- modules use ConstantsModule, only: LINELENGTH, LENAUXNAME, DEM6 - use MemoryManagerModule, only: mem_allocate + use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, store_error_unit ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType integer(I4B), intent(in) :: iout ! -- local character(len=LINELENGTH) :: keyword logical :: isfound - logical :: endOfBlock + logical :: endOfBlock integer(I4B) :: ierr ! ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, & - supportOpenClose=.true., blockRequired=.false.) + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING GWE-GWE EXCHANGE OPTIONS' + write (iout, '(1x,a)') 'PROCESSING GWE-GWE EXCHANGE OPTIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) then @@ -776,12 +773,12 @@ subroutine read_options(this, iout) end if ! unknown option - errmsg = "Unknown GWE-GWE exchange option '" // trim(keyword) // "'." + errmsg = "Unknown GWE-GWE exchange option '"//trim(keyword)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end do - write(iout,'(1x,a)') 'END OF GWE-GWE EXCHANGE OPTIONS' + write (iout, '(1x,a)') 'END OF GWE-GWE EXCHANGE OPTIONS' end if ! ! -- return @@ -792,11 +789,11 @@ end subroutine read_options !< function parse_option(this, keyword, iout) result(parsed) use InputOutputModule, only: getunit, openfile - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType character(len=LINELENGTH), intent(in) :: keyword !< the option name - integer(I4B), intent(in) :: iout !< for logging - logical(LGP) :: parsed !< true when parsed - ! local + integer(I4B), intent(in) :: iout !< for logging + logical(LGP) :: parsed !< true when parsed + ! local character(len=LINELENGTH) :: fname integer(I4B) :: inobs, ilen character(len=LINELENGTH) :: subkey @@ -808,67 +805,69 @@ function parse_option(this, keyword, iout) result(parsed) call this%parser%GetStringCaps(subkey) ilen = len_trim(subkey) if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'INVALID MODEL NAME: ', trim(subkey) + write (errmsg, '(4x,a,a)') & + 'INVALID MODEL NAME: ', trim(subkey) call store_error(errmsg) call this%parser%StoreErrorUnit() end if if (this%gwfmodelname1 /= '') then call store_error('GWFMODELNAME1 has already been set to ' & - // trim(this%gwfmodelname1) // '. Cannot set more than once.') + //trim(this%gwfmodelname1)// & + '. Cannot set more than once.') call this%parser%StoreErrorUnit() end if this%gwfmodelname1 = subkey(1:LENMODELNAME) - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'GWFMODELNAME1 IS SET TO: ', trim(this%gwfmodelname1) case ('GWFMODELNAME2') call this%parser%GetStringCaps(subkey) ilen = len_trim(subkey) if (ilen > LENMODELNAME) then - write(errmsg, '(4x,a,a)') & - 'INVALID MODEL NAME: ', trim(subkey) + write (errmsg, '(4x,a,a)') & + 'INVALID MODEL NAME: ', trim(subkey) call store_error(errmsg) call this%parser%StoreErrorUnit() end if if (this%gwfmodelname2 /= '') then call store_error('GWFMODELNAME2 has already been set to ' & - // trim(this%gwfmodelname2) // '. Cannot set more than once.') + //trim(this%gwfmodelname2)// & + s'. Cannot set more than once.') call this%parser%StoreErrorUnit() end if this%gwfmodelname2 = subkey(1:LENMODELNAME) - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'GWFMODELNAME2 IS SET TO: ', trim(this%gwfmodelname2) case ('PRINT_FLOWS') this%iprflow = 1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' case ('SAVE_FLOWS') this%ipakcb = -1 - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'EXCHANGE FLOWS WILL BE SAVED TO BINARY BUDGET FILES.' case ('MVT6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('MVT6 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('MVT6 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if call this%parser%GetString(fname) - if(fname == '') then + if (fname == '') then call store_error('NO MVT6 FILE SPECIFIED.') call this%parser%StoreErrorUnit() - endif + end if this%inmvt = getunit() call openfile(this%inmvt, iout, fname, 'MVT') - write(iout,'(4x,a)') & + write (iout, '(4x,a)') & 'WATER MOVER TRANSPORT INFORMATION WILL BE READ FROM ', trim(fname) case ('OBS6') call this%parser%GetStringCaps(subkey) - if(subkey /= 'FILEIN') then - call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY ' // & - '"FILEIN" then by filename.') + if (subkey /= 'FILEIN') then + call store_error('OBS8 KEYWORD MUST BE FOLLOWED BY '// & + '"FILEIN" then by filename.') call this%parser%StoreErrorUnit() - endif + end if this%obs%active = .true. call this%parser%GetString(this%obs%inputFilename) inobs = GetUnit() @@ -877,34 +876,34 @@ function parse_option(this, keyword, iout) result(parsed) case ('ADVSCHEME') !cdl todo: change to ADV_SCHEME? call this%parser%GetStringCaps(subkey) - select case(subkey) - case('UPSTREAM') + select case (subkey) + case ('UPSTREAM') this%iAdvScheme = 0 - case('CENTRAL') + case ('CENTRAL') this%iAdvScheme = 1 - case('TVD') + case ('TVD') this%iAdvScheme = 2 case default - errmsg = "Unknown weighting method for advection: '" // trim(subkey) // "'." + errmsg = "Unknown weighting method for advection: '"//trim(subkey)//"'." call store_error(errmsg) call this%parser%StoreErrorUnit() end select - write(iout,'(4x,a,a)') & + write (iout, '(4x,a,a)') & 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(subkey) case ('XT3D_OFF') !cdl todo: change to DSP_XT3D_OFF? this%ixt3d = 0 - write(iout, '(4x,a)') 'XT3D FORMULATION HAS BEEN SHUT OFF.' + write (iout, '(4x,a)') 'XT3D FORMULATION HAS BEEN SHUT OFF.' case ('XT3D_RHS') !cdl todo: change to DSP_XT3D_RHS? this%ixt3d = 2 - write(iout, '(4x,a)') 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' + write (iout, '(4x,a)') 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' case default parsed = .false. end select end function parse_option - + !> @ brief Read mover !! !! Read and process movers @@ -914,13 +913,13 @@ subroutine read_mvt(this, iout) ! -- modules use TspMvtModule, only: mvt_cr ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: iout ! -- local ! ! -- Create and initialize the mover object Here, fmi is set to the one ! for gwtmodel1 so that a call to save flows has an associated dis - ! object. + ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwemodel1%fmi, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & @@ -929,7 +928,7 @@ subroutine read_mvt(this, iout) ! -- Return return end subroutine read_mvt - + !> @ brief Allocate scalars !! !! Allocate scalar variables @@ -940,12 +939,12 @@ subroutine allocate_scalars(this) use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! -- local ! call this%DisConnExchangeType%allocate_scalars() ! - call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) + call mem_allocate(this%inewton, 'INEWTON', this%memoryPath) call mem_allocate(this%iprflow, 'IPRFLOW', this%memoryPath) call mem_allocate(this%ipakcb, 'IPAKCB', this%memoryPath) call mem_allocate(this%inobs, 'INOBS', this%memoryPath) @@ -973,35 +972,35 @@ subroutine gwe_gwe_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! -- local ! ! -- objects if (this%inmvt > 0) then call this%mvt%mvt_da() - deallocate(this%mvt) - endif + deallocate (this%mvt) + end if call this%obs%obs_da() - deallocate(this%obs) + deallocate (this%obs) ! ! -- arrays - call mem_deallocate(this%cond) + call mem_deallocate(this%cond) call mem_deallocate(this%simvals) ! ! -- output table objects if (associated(this%outputtab1)) then call this%outputtab1%table_da() - deallocate(this%outputtab1) - nullify(this%outputtab1) + deallocate (this%outputtab1) + nullify (this%outputtab1) end if if (associated(this%outputtab2)) then call this%outputtab2%table_da() - deallocate(this%outputtab2) - nullify(this%outputtab2) + deallocate (this%outputtab2) + nullify (this%outputtab2) end if ! - ! -- scalars - deallocate(this%filename) + ! -- scalars + deallocate (this%filename) call mem_deallocate(this%inewton) call mem_deallocate(this%iprflow) call mem_deallocate(this%ipakcb) @@ -1015,7 +1014,7 @@ subroutine gwe_gwe_da(this) ! -- return return end subroutine gwe_gwe_da - + !> @ brief Allocate arrays !! !! Allocate arrays @@ -1025,13 +1024,13 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType ! -- local character(len=LINELENGTH) :: text integer(I4B) :: ntabcol, i ! call this%DisConnExchangeType%allocate_arrays() - ! + ! call mem_allocate(this%cond, this%nexg, 'COND', this%memoryPath) call mem_allocate(this%simvals, this%nexg, 'SIMVALS', this%memoryPath) ! @@ -1052,7 +1051,7 @@ subroutine allocate_arrays(this) ! -- initialize the output table objects ! outouttab1 call table_cr(this%outputtab1, this%name, ' ') - call this%outputtab1%table_df(this%nexg, ntabcol, this%gwemodel1%iout, & + call this%outputtab1%table_df(this%nexg, ntabcol, this%gwemodel1%iout, & transient=.TRUE.) text = 'NUMBER' call this%outputtab1%initialize_column(text, 10, alignment=TABCENTER) @@ -1066,7 +1065,7 @@ subroutine allocate_arrays(this) end if ! outouttab2 call table_cr(this%outputtab2, this%name, ' ') - call this%outputtab2%table_df(this%nexg, ntabcol, this%gwemodel2%iout, & + call this%outputtab2%table_df(this%nexg, ntabcol, this%gwemodel2%iout, & transient=.TRUE.) text = 'NUMBER' call this%outputtab2%initialize_column(text, 10, alignment=TABCENTER) @@ -1091,7 +1090,7 @@ end subroutine allocate_arrays !< subroutine gwe_gwe_df_obs(this) ! -- dummy - class(GweExchangeType) :: this !< GweExchangeType + class(GweExchangeType) :: this !< GweExchangeType ! -- local integer(I4B) :: indx ! @@ -1103,7 +1102,7 @@ subroutine gwe_gwe_df_obs(this) ! -- return return end subroutine gwe_gwe_df_obs - + !> @ brief Read and prepare observations !! !! Handle observation exchanges exchange-boundary names. @@ -1113,7 +1112,7 @@ subroutine gwe_gwe_rp_obs(this) ! -- modules use ConstantsModule, only: DZERO ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! -- local integer(I4B) :: i integer(I4B) :: j @@ -1121,15 +1120,15 @@ subroutine gwe_gwe_rp_obs(this) character(len=LENBOUNDNAME) :: bname logical :: jfound ! -- formats -10 format('Exchange "',a,'" for observation "',a, & - '" is invalid in package "',a,'"') -20 format('Exchange id "',i0,'" for observation "',a, & - '" is invalid in package "',a,'"') +10 format('Exchange "', a, '" for observation "', a, & + '" is invalid in package "', a, '"') +20 format('Exchange id "', i0, '" for observation "', a, & + '" is invalid in package "', a, '"') ! do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv ! - ! -- indxbnds needs to be reset each stress period because + ! -- indxbnds needs to be reset each stress period because ! list of boundaries can change each stress period. ! -- Not true for exchanges, but leave this in for now anyway. call obsrv%ResetObsIndex() @@ -1141,18 +1140,18 @@ subroutine gwe_gwe_rp_obs(this) ! Iterate through all boundaries to identify and store ! corresponding index(indices) in bound array. jfound = .false. - do j=1,this%nexg + do j = 1, this%nexg if (this%boundname(j) == bname) then jfound = .true. obsrv%BndFound = .true. obsrv%CurrentTimeStepEndValue = DZERO call obsrv%AddObsIndex(j) - endif - enddo + end if + end do if (.not. jfound) then - write(errmsg, 10) trim(bname), trim(obsrv%ObsTypeId) , trim(this%name) + write (errmsg, 10) trim(bname), trim(obsrv%ObsTypeId), trim(this%name) call store_error(errmsg) - endif + end if else ! -- Observation location is a single exchange number if (obsrv%intPak1 <= this%nexg .and. obsrv%intPak1 > 0) then @@ -1162,23 +1161,23 @@ subroutine gwe_gwe_rp_obs(this) call obsrv%AddObsIndex(obsrv%intPak1) else jfound = .false. - endif + end if if (.not. jfound) then - write(errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId) , trim(this%name) + write (errmsg, 20) obsrv%intPak1, trim(obsrv%ObsTypeId), trim(this%name) call store_error(errmsg) - endif - endif - enddo + end if + end if + end do ! ! -- write summary of error messages if (count_errors() > 0) then call store_error_unit(this%inobs) - endif + end if ! ! -- Return return end subroutine gwe_gwe_rp_obs - + !> @ brief Final processing !! !! Conduct any final processing @@ -1186,28 +1185,28 @@ end subroutine gwe_gwe_rp_obs !< subroutine gwe_gwe_fp(this) ! -- dummy - class(GweExchangeType) :: this !< GwtExchangeType + class(GweExchangeType) :: this !< GwtExchangeType ! return end subroutine gwe_gwe_fp - - !> @brief Return true when this exchange provides matrix + + !> @brief Return true when this exchange provides matrix !! coefficients for solving @param model !< function gwe_gwe_connects_model(this, model) result(is_connected) - class(GweExchangeType) :: this !< GweExchangeType - class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection - logical(LGP) :: is_connected !< true, when connected + class(GweExchangeType) :: this !< GweExchangeType + class(BaseModelType), pointer, intent(in) :: model !< the model to which the exchange might hold a connection + logical(LGP) :: is_connected !< true, when connected is_connected = .false. ! only connected when model is GwtModelType of course - select type(model) - class is (GweModelType) - if (associated(this%gwemodel1, model)) then - is_connected = .true. - else if (associated(this%gwemodel2, model)) then - is_connected = .true. - end if + select type (model) + class is (GweModelType) + if (associated(this%gwemodel1, model)) then + is_connected = .true. + else if (associated(this%gwemodel2, model)) then + is_connected = .true. + end if end select end function gwe_gwe_connects_model @@ -1216,10 +1215,10 @@ end function gwe_gwe_connects_model !< function use_interface_model(this) result(useIM) class(GweExchangeType) :: this !< GwtExchangeType - logical(LGP) :: useIM !< true when interface model should be used - + logical(LGP) :: useIM !< true when interface model should be used + useIM = (this%ixt3d > 0) - + end function !> @ brief Save simulated flow observations @@ -1248,7 +1247,7 @@ subroutine gwe_gwe_save_simvals(this) call this%obs%obs_bd_clear() do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv - do j = 1, obsrv%indxbnds_count + do j = 1, obsrv%indxbnds_count iexg = obsrv%indxbnds(j) v = DZERO select case (obsrv%ObsTypeId) @@ -1257,15 +1256,15 @@ subroutine gwe_gwe_save_simvals(this) n2 = this%nodem2(iexg) v = this%simvals(iexg) case default - msg = 'Error: Unrecognized observation type: ' // & + msg = 'Error: Unrecognized observation type: '// & trim(obsrv%ObsTypeId) call store_error(msg) call store_error_unit(this%inobs) end select call this%obs%SaveOneSimval(obsrv, v) - enddo - enddo - endif + end do + end do + end if ! return end subroutine gwe_gwe_save_simvals @@ -1282,10 +1281,10 @@ subroutine gwe_gwe_process_obsID(obsrv, dis, inunitobs, iout) use ObserveModule, only: ObserveType use BaseDisModule, only: DisBaseType ! -- dummy - type(ObserveType), intent(inout) :: obsrv - class(DisBaseType), intent(in) :: dis - integer(I4B), intent(in) :: inunitobs - integer(I4B), intent(in) :: iout + type(ObserveType), intent(inout) :: obsrv + class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: inunitobs + integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: n, iexg, istat integer(I4B) :: icol, istart, istop @@ -1307,7 +1306,7 @@ subroutine gwe_gwe_process_obsID(obsrv, dis, inunitobs, iout) ! boundaries, so assign intPak1 as a value that indicates observation ! is for a named exchange boundary or group of exchange boundaries. obsrv%intPak1 = NAMEDBOUNDFLAG - endif + end if ! return end subroutine gwe_gwe_process_obsID @@ -1317,7 +1316,7 @@ end subroutine gwe_gwe_process_obsID !! Cast polymorphic object as exchange !! !< - function CastAsGweExchange(obj) result (res) + function CastAsGweExchange(obj) result(res) implicit none class(*), pointer, intent(inout) :: obj class(GweExchangeType), pointer :: res @@ -1337,12 +1336,12 @@ end function CastAsGweExchange !! Return an exchange from the list for specified index !! !< - function GetGweExchangeFromList(list, idx) result (res) + function GetGweExchangeFromList(list, idx) result(res) implicit none ! -- dummy - type(ListType), intent(inout) :: list - integer(I4B), intent(in) :: idx - class(GweExchangeType), pointer :: res + type(ListType), intent(inout) :: list + integer(I4B), intent(in) :: idx + class(GweExchangeType), pointer :: res ! -- local class(*), pointer :: obj ! @@ -1352,7 +1351,5 @@ function GetGweExchangeFromList(list, idx) result (res) return end function GetGweExchangeFromList - - end module GweGweExchangeModule diff --git a/src/Exchange/GwfGweExchange.f90 b/src/Exchange/GwfGweExchange.f90 index baa196b323e..e16655b8b61 100644 --- a/src/Exchange/GwfGweExchange.f90 +++ b/src/Exchange/GwfGweExchange.f90 @@ -1,34 +1,33 @@ module GwfGweExchangeModule - use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: LENPACKAGENAME - use ListsModule, only: basemodellist, baseexchangelist, & - baseconnectionlist - use SimModule, only: store_error - use SimVariablesModule, only: errmsg - use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use SpatialModelConnectionModule, only: SpatialModelConnectionType, & + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: LENPACKAGENAME + use ListsModule, only: basemodellist, baseexchangelist, & + baseconnectionlist + use SimModule, only: store_error + use SimVariablesModule, only: errmsg + use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList + use SpatialModelConnectionModule, only: SpatialModelConnectionType, & GetSpatialModelConnectionFromList - use GweGweConnectionModule, only: GweGweConnectionType, CastAsGweGweConnection - use GwfGwfConnectionModule, only: GwfGwfConnectionType, CastAsGwfGwfConnection - use GwfGwfExchangeModule, only: GwfExchangeType, & - GetGwfExchangeFromList - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use GwfModule, only: GwfModelType - use GweModule, only: GweModelType - use BndModule, only: BndType, GetBndFromList - - + use GweGweConnectionModule, only: GweGweConnectionType, CastAsGweGweConnection + use GwfGwfConnectionModule, only: GwfGwfConnectionType, CastAsGwfGwfConnection + use GwfGwfExchangeModule, only: GwfExchangeType, & + GetGwfExchangeFromList + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use GwfModule, only: GwfModelType + use GweModule, only: GweModelType + use BndModule, only: BndType, GetBndFromList + implicit none public :: GwfGweExchangeType public :: gwfgwe_cr - + type, extends(BaseExchangeType) :: GwfGweExchangeType integer(I4B), pointer :: m1id => null() integer(I4B), pointer :: m2id => null() contains - + procedure :: exg_df procedure :: exg_ar procedure :: exg_da @@ -37,11 +36,11 @@ module GwfGweExchangeModule procedure, private :: gwfbnd2gwefmi procedure, private :: gwfconn2gweconn procedure, private :: link_connections - + end type GwfGweExchangeType - - contains - + +contains + subroutine gwfgwe_cr(filename, id, m1id, m2id) ! ****************************************************************************** ! gwfgwe_cr -- Create a new GWF to GWE exchange object @@ -62,14 +61,14 @@ subroutine gwfgwe_cr(filename, id, m1id, m2id) ! ------------------------------------------------------------------------------ ! ! -- Create a new exchange and add it to the baseexchangelist container - allocate(exchange) + allocate (exchange) baseexchange => exchange call AddBaseExchangeToList(baseexchangelist, baseexchange) ! ! -- Assign id and name exchange%id = id - write(cint, '(i0)') id - exchange%name = 'GWF-GWE_' // trim(adjustl(cint)) + write (cint, '(i0)') id + exchange%name = 'GWF-GWE_'//trim(adjustl(cint)) exchange%memoryPath = exchange%name ! ! -- allocate scalars @@ -83,7 +82,7 @@ subroutine gwfgwe_cr(filename, id, m1id, m2id) ! -- return return end subroutine gwfgwe_cr - + subroutine set_model_pointers(this) ! ****************************************************************************** ! set_model_pointers -- allocate and read @@ -118,14 +117,14 @@ subroutine set_model_pointers(this) ! ! -- Verify that gwf model is of the correct type if (.not. associated(gwfmodel)) then - write(errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & + write (errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & '. Specified GWF Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) end if ! ! -- Verify that gwe model is of the correct type if (.not. associated(gwemodel)) then - write(errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & + write (errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & '. Specified GWF Model does not appear to be of the correct type.' call store_error(errmsg, terminate=.true.) end if @@ -140,7 +139,7 @@ subroutine set_model_pointers(this) ! -- return return end subroutine set_model_pointers - + subroutine exg_df(this) ! ****************************************************************************** ! exg_df -- define @@ -175,7 +174,7 @@ subroutine exg_df(this) ! -- Set pointer to flowja gwemodel%fmi%gwfflowja => gwfmodel%flowja ! - ! -- Set the npf flag so that specific discharge is available for + ! -- Set the npf flag so that specific discharge is available for ! transport calculations if dispersion is active if (gwemodel%indsp > 0) then gwfmodel%npf%icalcspdis = 1 @@ -184,10 +183,10 @@ subroutine exg_df(this) ! -- return return end subroutine exg_df - + subroutine exg_ar(this) ! ****************************************************************************** -! exg_ar -- +! exg_ar -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -200,7 +199,7 @@ subroutine exg_ar(this) type(GwfModelType), pointer :: gwfmodel => null() type(GweModelType), pointer :: gwemodel => null() ! -- formats - character(len=*),parameter :: fmtdiserr = & + character(len=*), parameter :: fmtdiserr = & "('GWF and GWE Models do not have the same discretization for exchange& & ',a,'.& & GWF Model has ', i0, ' user nodes and ', i0, ' reduced nodes.& @@ -223,39 +222,39 @@ subroutine exg_ar(this) end select ! ! -- Check to make sure sizes are identical - if (gwemodel%dis%nodes /= gwfmodel%dis%nodes .or.& + if (gwemodel%dis%nodes /= gwfmodel%dis%nodes .or. & gwemodel%dis%nodesuser /= gwfmodel%dis%nodesuser) then - write(errmsg, fmtdiserr) trim(this%name), & - gwfmodel%dis%nodesuser, & - gwfmodel%dis%nodes, & - gwemodel%dis%nodesuser, & - gwemodel%dis%nodes + write (errmsg, fmtdiserr) trim(this%name), & + gwfmodel%dis%nodesuser, & + gwfmodel%dis%nodes, & + gwemodel%dis%nodesuser, & + gwemodel%dis%nodes call store_error(errmsg, terminate=.TRUE.) end if ! ! -- setup pointers to gwf variables allocated in gwf_ar - gwemodel%fmi%gwfhead => gwfmodel%x - gwemodel%fmi%gwfsat => gwfmodel%npf%sat - gwemodel%fmi%gwfspdis => gwfmodel%npf%spdis + gwemodel%fmi%gwfhead => gwfmodel%x + gwemodel%fmi%gwfsat => gwfmodel%npf%sat + gwemodel%fmi%gwfspdis => gwfmodel%npf%spdis ! ! -- setup pointers to the flow storage rates. GWF strg arrays are ! available after the gwf_ar routine is called. - if(gwemodel%inmst > 0) then + if (gwemodel%inmst > 0) then if (gwfmodel%insto > 0) then gwemodel%fmi%gwfstrgss => gwfmodel%sto%strgss gwemodel%fmi%igwfstrgss = 1 if (gwfmodel%sto%iusesy == 1) then gwemodel%fmi%gwfstrgsy => gwfmodel%sto%strgsy gwemodel%fmi%igwfstrgsy = 1 - endif - endif - endif + end if + end if + end if ! ! -- Set a pointer to conc if (gwfmodel%inbuy > 0) then call gwfmodel%buy%set_concentration_pointer(gwemodel%name, gwemodel%x, & gwemodel%ibound) - endif + end if ! ! -- transfer the boundary package information from gwf to gwe call this%gwfbnd2gwefmi() @@ -271,17 +270,17 @@ subroutine exg_ar(this) ! -- return return end subroutine exg_ar - + !> @brief Link GWE connections to GWF connections or exchanges !< subroutine gwfconn2gweconn(this, gwfModel, gweModel) use SimModule, only: store_error use SimVariablesModule, only: iout - class(GwfGweExchangeType) :: this !< this exchange + class(GwfGweExchangeType) :: this !< this exchange type(GwfModelType), pointer :: gwfModel !< the flow model type(GweModelType), pointer :: gweModel !< the transport model - ! local - class(SpatialModelConnectionType), pointer :: conn => null() + ! local + class(SpatialModelConnectionType), pointer :: conn => null() class(*), pointer :: objPtr => null() class(GweGweConnectionType), pointer :: gweConn => null() class(GwfGwfConnectionType), pointer :: gwfConn => null() @@ -293,7 +292,7 @@ subroutine gwfconn2gweconn(this, gwfModel, gweModel) ! loop over all connections gweloop: do ic1 = 1, baseconnectionlist%Count() - conn => GetSpatialModelConnectionFromList(baseconnectionlist,ic1) + conn => GetSpatialModelConnectionFromList(baseconnectionlist, ic1) if (.not. associated(conn%owner, gweModel)) cycle gweloop ! start with a GWE conn. @@ -304,25 +303,25 @@ subroutine gwfconn2gweconn(this, gwfModel, gweModel) ! find matching GWF conn. in same list gwfloop: do ic2 = 1, baseconnectionlist%Count() - conn => GetSpatialModelConnectionFromList(baseconnectionlist,ic2) - + conn => GetSpatialModelConnectionFromList(baseconnectionlist, ic2) + if (associated(conn%owner, gwfModel)) then objPtr => conn - gwfConn => CastAsGwfGwfConnection(objPtr) + gwfConn => CastAsGwfGwfConnection(objPtr) - ! for now, connecting the same nodes nrs will be + ! for now, connecting the same nodes nrs will be ! sufficient evidence of equality - areEqual = all(gwfConn%primaryExchange%nodem1 == & - gweConn%primaryExchange%nodem1) - areEqual = areEqual .and. all(gwfConn%primaryExchange%nodem2 == & - gweConn%primaryExchange%nodem2) + areEqual = all(gwfConn%primaryExchange%nodem1 == & + gweConn%primaryExchange%nodem1) + areEqual = areEqual .and. all(gwfConn%primaryExchange%nodem2 == & + gweConn%primaryExchange%nodem2) if (areEqual) then ! same DIS, same exchange: link and go to next GWE conn. - write(iout,'(/6a)') 'Linking exchange ', & - trim(gweConn%primaryExchange%name), & - ' to ', trim(gwfConn%primaryExchange%name), & - ' (using interface model) for GWE model ', & - trim(gweModel%name) + write (iout, '(/6a)') 'Linking exchange ', & + trim(gweConn%primaryExchange%name), & + ' to ', trim(gwfConn%primaryExchange%name), & + ' (using interface model) for GWE model ', & + trim(gweModel%name) gwfConnIdx = ic2 call this%link_connections(gweConn, gwfConn) exit gwfloop @@ -335,35 +334,36 @@ subroutine gwfconn2gweconn(this, gwfModel, gweModel) if (gwfConnIdx == -1) then gwfloopexg: do iex = 1, baseexchangelist%Count() gwfEx => GetGwfExchangeFromList(baseexchangelist, iex) - + ! -- There is no guarantee that iex is a gwfExg, in which case ! it will return as null. cycle if so. if (.not. associated(gwfEx)) cycle gwfloopexg - if (associated(gwfEx%model1, gwfModel) .or. & + if (associated(gwfEx%model1, gwfModel) .or. & associated(gwfEx%model2, gwfModel)) then - ! again, connecting the same nodes nrs will be + ! again, connecting the same nodes nrs will be ! sufficient evidence of equality areEqual = all(gwfEx%nodem1 == gweConn%primaryExchange%nodem1) - areEqual = areEqual .and. & - all(gwfEx%nodem2 == gweConn%primaryExchange%nodem2) - if (areEqual) then + areEqual = areEqual .and. & + all(gwfEx%nodem2 == gweConn%primaryExchange%nodem2) + if (areEqual) then ! link exchange to connection - write(iout,'(/6a)') 'Linking exchange ', & - trim(gweConn%primaryExchange%name), & - ' to ', trim(gwfEx%name), ' for GWE model ', & - trim(gweModel%name) + write (iout, '(/6a)') 'Linking exchange ', & + trim(gweConn%primaryExchange%name), & + ' to ', trim(gwfEx%name), ' for GWE model ', & + trim(gweModel%name) gwfExIdx = iex gweConn%exgflowja => gwfEx%simvals - + !cdl link up mvt to mvr if (gwfEx%inmvr > 0) then if (gweConn%exchangeIsOwned) then !cdl todo: check and make sure gweEx has mvt active - call gweConn%gweExchange%mvt%set_pointer_mvrbudobj(gwfEx%mvr%budobj) + call gweConn%gweExchange%mvt%set_pointer_mvrbudobj( & + gwfEx%mvr%budobj) end if end if - + if (associated(gwfEx%model2, gwfModel)) gweConn%exgflowSign = -1 gweConn%gweInterfaceModel%fmi%flows_from_file = .false. @@ -371,55 +371,56 @@ subroutine gwfconn2gweconn(this, gwfModel, gweModel) end if end if - end do gwfloopexg end if if (gwfConnIdx == -1 .and. gwfExIdx == -1) then ! none found, report - write(errmsg, '(/6a)') 'Missing GWF-GWF exchange when connecting GWE'// & - ' model ', trim(gweModel%name), ' with exchange ', & - trim(gweConn%primaryExchange%name), ' to GWF model ', & - trim(gwfModel%name) + write (errmsg, '(/6a)') 'Missing GWF-GWF exchange when connecting GWE'// & + ' model ', trim(gweModel%name), ' with exchange ', & + trim(gweConn%primaryExchange%name), ' to GWF model ', & + trim(gwfModel%name) call store_error(errmsg, terminate=.true.) end if end do gweloop - end subroutine gwfconn2gweconn - + end subroutine gwfconn2gweconn !> @brief Links a GWE connection to its GWF counterpart !< subroutine link_connections(this, gweConn, gwfConn) - class(GwfGweExchangeType) :: this !< this exchange + class(GwfGweExchangeType) :: this !< this exchange class(GweGweConnectionType), pointer :: gweConn !< GWE connection class(GwfGwfConnectionType), pointer :: gwfConn !< GWF connection !gweConn%exgflowja => gwfConn%exgflowja gweConn%exgflowja => gwfConn%gwfExchange%simvals - + !cdl link up mvt to mvr if (gwfConn%gwfExchange%inmvr > 0) then if (gweConn%exchangeIsOwned) then !cdl todo: check and make sure gweEx has mvt active - call gweConn%gweExchange%mvt%set_pointer_mvrbudobj(gwfConn%gwfExchange%mvr%budobj) + call gweConn%gweExchange%mvt%set_pointer_mvrbudobj( & + gwfConn%gwfExchange%mvr%budobj) end if end if - - if (associated(gwfConn%gwfExchange%model2, gwfConn%owner)) gweConn%exgflowSign = -1 + + if (associated(gwfConn%gwfExchange%model2, gwfConn%owner)) then + gweConn%exgflowSign = -1 + end if ! fmi flows are not read from file gweConn%gweInterfaceModel%fmi%flows_from_file = .false. ! set concentration pointer for buoyancy - call gwfConn%gwfInterfaceModel%buy%set_concentration_pointer( & - gweConn%gweModel%name, & - gweConn%conc, & - gweConn%icbound) + call gwfConn%gwfInterfaceModel%buy%set_concentration_pointer( & + gweConn%gweModel%name, & + gweConn%conc, & + gweConn%icbound) end subroutine link_connections - + subroutine exg_da(this) ! ****************************************************************************** ! allocate_scalars @@ -502,9 +503,9 @@ subroutine gwfbnd2gwefmi(this) iterm = 1 do ip = 1, ngwfpack packobj => GetBndFromList(gwfmodel%bndlist, ip) - call gwemodel%fmi%gwfpackages(iterm)%set_pointers( & - 'SIMVALS', & - packobj%memoryPath) + call gwemodel%fmi%gwfpackages(iterm)%set_pointers( & + 'SIMVALS', & + packobj%memoryPath) iterm = iterm + 1 ! ! -- If a mover is active for this package, then establish a separate @@ -512,9 +513,9 @@ subroutine gwfbnd2gwefmi(this) imover = packobj%imover if (packobj%isadvpak /= 0) imover = 0 if (imover /= 0) then - call gwemodel%fmi%gwfpackages(iterm)%set_pointers( & - 'SIMTOMVR', & - packobj%memoryPath) + call gwemodel%fmi%gwfpackages(iterm)%set_pointers( & + 'SIMTOMVR', & + packobj%memoryPath) iterm = iterm + 1 end if end do @@ -523,4 +524,4 @@ subroutine gwfbnd2gwefmi(this) return end subroutine gwfbnd2gwefmi -end module GwfGweExchangeModule \ No newline at end of file +end module GwfGweExchangeModule diff --git a/src/Model/Connection/GweGweConnection.f90 b/src/Model/Connection/GweGweConnection.f90 index 711a791b105..55a559f34bc 100644 --- a/src/Model/Connection/GweGweConnection.f90 +++ b/src/Model/Connection/GweGweConnection.f90 @@ -1,6 +1,6 @@ module GweGweConnectionModule use KindModule, only: I4B, DP, LGP - use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, DZERO, LENBUDTXT + use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, DZERO, LENBUDTXT use CsrUtilsModule, only: getCSRIndex use SimModule, only: ustop use MemoryManagerModule, only: mem_allocate, mem_deallocate @@ -25,28 +25,28 @@ module GweGweConnectionModule !< type, public, extends(SpatialModelConnectionType) :: GweGweConnectionType - type(GweModelType), pointer :: gweModel => null() !< the model for which this connection exists - type(GweExchangeType), pointer :: gweExchange => null() !< the primary exchange, cast to GWE-GWE - logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, + type(GweModelType), pointer :: gweModel => null() !< the model for which this connection exists + type(GweExchangeType), pointer :: gweExchange => null() !< the primary exchange, cast to GWE-GWE + logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, !! one of them needs to manage/own the exchange (e.g. clean up) - type(GweInterfaceModelType), pointer :: gweInterfaceModel => null() !< the interface model - integer(I4B), pointer :: iIfaceAdvScheme => null() !< the advection scheme at the interface: + type(GweInterfaceModelType), pointer :: gweInterfaceModel => null() !< the interface model + integer(I4B), pointer :: iIfaceAdvScheme => null() !< the advection scheme at the interface: !! 0 = upstream, 1 = central, 2 = TVD - integer(I4B), pointer :: iIfaceXt3d => null() !< XT3D in the interface DSP package: 0 = no, 1 = lhs, 2 = rhs - real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< intercell flows at the interface, coming from GWF interface model - integer(I4B), pointer :: exgflowSign => null() !< indicates the flow direction of exgflowja + integer(I4B), pointer :: iIfaceXt3d => null() !< XT3D in the interface DSP package: 0 = no, 1 = lhs, 2 = rhs + real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< intercell flows at the interface, coming from GWF interface model + integer(I4B), pointer :: exgflowSign => null() !< indicates the flow direction of exgflowja real(DP), dimension(:), pointer, contiguous :: exgflowjaGwt => null() !< gwe-flowja at the interface (this is a subset of the GWE !! interface model flowja's) - - real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< gwfflowja for the interface model - real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< gwfsat for the interface model - real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< gwfhead for the interface model - real(DP), dimension(:,:), pointer, contiguous :: gwfspdis => null() !< gwfspdis for the interface model - real(DP), dimension(:), pointer, contiguous :: conc => null() !< pointer to concentration array - integer(I4B), dimension(:), pointer, contiguous :: icbound => null() !< store pointer to gwe ibound array - - integer(I4B) :: iout = 0 !< the list file for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< gwfflowja for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< gwfsat for the interface model + real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< gwfhead for the interface model + real(DP), dimension(:, :), pointer, contiguous :: gwfspdis => null() !< gwfspdis for the interface model + + real(DP), dimension(:), pointer, contiguous :: conc => null() !< pointer to concentration array + integer(I4B), dimension(:), pointer, contiguous :: icbound => null() !< store pointer to gwe ibound array + + integer(I4B) :: iout = 0 !< the list file for the interface model contains @@ -81,444 +81,449 @@ module GweGweConnectionModule !> @brief Basic construction of the connection !< -subroutine gweGweConnection_ctor(this, model, gweEx) - use InputOutputModule, only: openfile - class(GweGweConnectionType) :: this !< the connection - class(NumericalModelType), pointer :: model !< the model owning this connection, + subroutine gweGweConnection_ctor(this, model, gweEx) + use InputOutputModule, only: openfile + class(GweGweConnectionType) :: this !< the connection + class(NumericalModelType), pointer :: model !< the model owning this connection, !! this must be a GweModelType - class(DisConnExchangeType), pointer :: gweEx !< the GWE-GWE exchange the interface model is created for - ! local - character(len=LINELENGTH) :: fname - character(len=LENCOMPONENTNAME) :: name - class(*), pointer :: objPtr - logical(LGP) :: write_ifmodel_listfile = .false. - - objPtr => model - this%gweModel => CastAsGweModel(objPtr) - objPtr => gweEx - this%gweExchange => CastAsGweExchange(objPtr) - - this%exchangeIsOwned = associated(model, gweEx%model1) - - if (this%exchangeIsOwned) then - write(name,'(a,i0)') 'GWECON1_', gweEx%id - else - write(name,'(a,i0)') 'GWECON2_', gweEx%id - end if - - ! .lst file for interface model - if (write_ifmodel_listfile) then - fname = trim(name)//'.im.lst' - call openfile(this%iout, 0, fname, 'LIST', filstat_opt='REPLACE') - write(this%iout, '(4a)') 'Creating GWE-GWE connection for model ', & - trim(this%gweModel%name), 'from exchange ', & - trim(gweEx%name) - end if - - ! first call base constructor - call this%SpatialModelConnectionType%spatialConnection_ctor(model, gweEx, name) - - call this%allocate_scalars() - this%typename = 'GWE-GWE' - this%iIfaceAdvScheme = 0 - this%iIfaceXt3d = 1 - this%exgflowSign = 1 - - allocate(this%gweInterfaceModel) - this%interfaceModel => this%gweInterfaceModel - -end subroutine gweGweConnection_ctor + class(DisConnExchangeType), pointer :: gweEx !< the GWE-GWE exchange the interface model is created for + ! local + character(len=LINELENGTH) :: fname + character(len=LENCOMPONENTNAME) :: name + class(*), pointer :: objPtr + logical(LGP) :: write_ifmodel_listfile = .false. + + objPtr => model + this%gweModel => CastAsGweModel(objPtr) + objPtr => gweEx + this%gweExchange => CastAsGweExchange(objPtr) + + this%exchangeIsOwned = associated(model, gweEx%model1) + + if (this%exchangeIsOwned) then + write (name, '(a,i0)') 'GWECON1_', gweEx%id + else + write (name, '(a,i0)') 'GWECON2_', gweEx%id + end if + + ! .lst file for interface model + if (write_ifmodel_listfile) then + fname = trim(name)//'.im.lst' + call openfile(this%iout, 0, fname, 'LIST', filstat_opt='REPLACE') + write (this%iout, '(4a)') 'Creating GWE-GWE connection for model ', & + trim(this%gweModel%name), 'from exchange ', & + trim(gweEx%name) + end if + + ! first call base constructor + call this%SpatialModelConnectionType%spatialConnection_ctor(model, gweEx, & + name) + + call this%allocate_scalars() + this%typename = 'GWE-GWE' + this%iIfaceAdvScheme = 0 + this%iIfaceXt3d = 1 + this%exgflowSign = 1 + + allocate (this%gweInterfaceModel) + this%interfaceModel => this%gweInterfaceModel + + end subroutine gweGweConnection_ctor !> @brief Allocate scalar variables for this connection !< -subroutine allocate_scalars(this) - class(GweGweConnectionType) :: this !< the connection + subroutine allocate_scalars(this) + class(GweGweConnectionType) :: this !< the connection - call mem_allocate(this%iIfaceAdvScheme, 'IADVSCHEME', this%memoryPath) - call mem_allocate(this%iIfaceXt3d, 'IXT3D', this%memoryPath) - call mem_allocate(this%exgflowSign, 'EXGFLOWSIGN', this%memoryPath) + call mem_allocate(this%iIfaceAdvScheme, 'IADVSCHEME', this%memoryPath) + call mem_allocate(this%iIfaceXt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%exgflowSign, 'EXGFLOWSIGN', this%memoryPath) -end subroutine allocate_scalars + end subroutine allocate_scalars !> @brief Allocate array variables for this connection !< -subroutine allocate_arrays(this) - class(GweGweConnectionType) :: this !< the connection - ! local - integer(I4B) :: i + subroutine allocate_arrays(this) + class(GweGweConnectionType) :: this !< the connection + ! local + integer(I4B) :: i - call mem_allocate(this%gwfflowja, this%interfaceModel%nja, 'GWFFLOWJA', & - this%memoryPath) - call mem_allocate(this%gwfsat, this%neq, 'GWFSAT', this%memoryPath) - call mem_allocate(this%gwfhead, this%neq, 'GWFHEAD', this%memoryPath) - call mem_allocate(this%gwfspdis, 3, this%neq, 'GWFSPDIS', this%memoryPath) + call mem_allocate(this%gwfflowja, this%interfaceModel%nja, 'GWFFLOWJA', & + this%memoryPath) + call mem_allocate(this%gwfsat, this%neq, 'GWFSAT', this%memoryPath) + call mem_allocate(this%gwfhead, this%neq, 'GWFHEAD', this%memoryPath) + call mem_allocate(this%gwfspdis, 3, this%neq, 'GWFSPDIS', this%memoryPath) - call mem_allocate(this%exgflowjaGwt, this%gridConnection%nrOfBoundaryCells, & - 'EXGFLOWJAGWE', this%memoryPath) + call mem_allocate(this%exgflowjaGwt, this%gridConnection%nrOfBoundaryCells, & + 'EXGFLOWJAGWE', this%memoryPath) - do i = 1, size(this%gwfflowja) - this%gwfflowja = 0.0_DP - end do + do i = 1, size(this%gwfflowja) + this%gwfflowja = 0.0_DP + end do - do i = 1, this%neq - this%gwfsat = 0.0_DP - end do + do i = 1, this%neq + this%gwfsat = 0.0_DP + end do -end subroutine allocate_arrays + end subroutine allocate_arrays !> @brief define the GWE-GWE connection !< -subroutine gwegwecon_df(this) - class(GweGweConnectionType) :: this !< the connection - ! local - character(len=LENCOMPONENTNAME) :: imName - - ! determine advection scheme (the GWE-GWE exchange - ! has been read at this point) - this%iIfaceAdvScheme = this%gweExchange%iAdvScheme - - ! determine xt3d setting on interface - this%iIfaceXt3d = this%gweExchange%ixt3d - - ! determine the required size of the interface model grid - call this%setGridExtent() - - ! now set up the GridConnection - call this%spatialcon_df() - - ! we have to 'catch up' and create the interface model - ! here, then the remainder of this routine will be define - if (this%exchangeIsOwned) then - write(imName,'(a,i0)') 'GWEIM1_', this%gweExchange%id - else - write(imName,'(a,i0)') 'GWEIM2_', this%gweExchange%id - end if - call this%gweInterfaceModel%gweifmod_cr(imName, this%iout, this%gridConnection) - this%gweInterfaceModel%iAdvScheme = this%iIfaceAdvScheme - this%gweInterfaceModel%ixt3d = this%iIfaceXt3d - call this%gweInterfaceModel%model_df() - - call this%allocate_arrays() - - ! connect X, RHS, IBOUND, and flowja - call this%spatialcon_setmodelptrs() - - this%gweInterfaceModel%fmi%gwfflowja => this%gwfflowja - this%gweInterfaceModel%fmi%gwfsat => this%gwfsat - this%gweInterfaceModel%fmi%gwfhead => this%gwfhead - this%gweInterfaceModel%fmi%gwfspdis => this%gwfspdis - - ! connect pointers (used by BUY) - this%conc => this%gweInterfaceModel%x - this%icbound => this%gweInterfaceModel%ibound - - ! add connections from the interface model to solution matrix - call this%spatialcon_connect() - -end subroutine gwegwecon_df + subroutine gwegwecon_df(this) + class(GweGweConnectionType) :: this !< the connection + ! local + character(len=LENCOMPONENTNAME) :: imName + + ! determine advection scheme (the GWE-GWE exchange + ! has been read at this point) + this%iIfaceAdvScheme = this%gweExchange%iAdvScheme + + ! determine xt3d setting on interface + this%iIfaceXt3d = this%gweExchange%ixt3d + + ! determine the required size of the interface model grid + call this%setGridExtent() + + ! now set up the GridConnection + call this%spatialcon_df() + + ! we have to 'catch up' and create the interface model + ! here, then the remainder of this routine will be define + if (this%exchangeIsOwned) then + write (imName, '(a,i0)') 'GWEIM1_', this%gweExchange%id + else + write (imName, '(a,i0)') 'GWEIM2_', this%gweExchange%id + end if + call this%gweInterfaceModel%gweifmod_cr(imName, this%iout, & + this%gridConnection) + this%gweInterfaceModel%iAdvScheme = this%iIfaceAdvScheme + this%gweInterfaceModel%ixt3d = this%iIfaceXt3d + call this%gweInterfaceModel%model_df() + + call this%allocate_arrays() + + ! connect X, RHS, IBOUND, and flowja + call this%spatialcon_setmodelptrs() + + this%gweInterfaceModel%fmi%gwfflowja => this%gwfflowja + this%gweInterfaceModel%fmi%gwfsat => this%gwfsat + this%gweInterfaceModel%fmi%gwfhead => this%gwfhead + this%gweInterfaceModel%fmi%gwfspdis => this%gwfspdis + + ! connect pointers (used by BUY) + this%conc => this%gweInterfaceModel%x + this%icbound => this%gweInterfaceModel%ibound + + ! add connections from the interface model to solution matrix + call this%spatialcon_connect() + + end subroutine gwegwecon_df !> @brief Set required extent of the interface grid from !< the configuration -subroutine setGridExtent(this) - class(GweGweConnectionType) :: this !< the connection - ! local - logical(LGP) :: hasAdv, hasDsp - - hasAdv = this%gweModel%inadv > 0 - hasDsp = this%gweModel%indsp > 0 - - if (hasAdv) then - if (this%iIfaceAdvScheme == 2) then - this%exchangeStencilDepth = 2 - if (this%gweModel%adv%iadvwt == 2) then - this%internalStencilDepth = 2 + subroutine setGridExtent(this) + class(GweGweConnectionType) :: this !< the connection + ! local + logical(LGP) :: hasAdv, hasDsp + + hasAdv = this%gweModel%inadv > 0 + hasDsp = this%gweModel%indsp > 0 + + if (hasAdv) then + if (this%iIfaceAdvScheme == 2) then + this%exchangeStencilDepth = 2 + if (this%gweModel%adv%iadvwt == 2) then + this%internalStencilDepth = 2 + end if end if end if - end if - if (hasDsp) then - if (this%iIfaceXt3d > 0) then - this%exchangeStencilDepth = 2 - if (this%gweModel%dsp%ixt3d > 0) then - this%internalStencilDepth = 2 + if (hasDsp) then + if (this%iIfaceXt3d > 0) then + this%exchangeStencilDepth = 2 + if (this%gweModel%dsp%ixt3d > 0) then + this%internalStencilDepth = 2 + end if end if end if - end if -end subroutine setGridExtent + end subroutine setGridExtent !> @brief allocate and read/set the connection's data structures !< -subroutine gwegwecon_ar(this) - class(GweGweConnectionType) :: this !< the connection - ! local - integer(I4B) :: i, idx - class(GweModelType), pointer :: gweModel - class(*), pointer :: modelPtr - - ! check if we can construct an interface model - ! NB: only makes sense after the models' allocate&read have been - ! called, which is why we do it here - call this%validateConnection() - - ! fill porosity from mst packages, needed for dsp - if (this%gweModel%inmst > 0) then - do i = 1, this%neq - modelPtr => this%gridConnection%idxToGlobal(i)%model - gweModel => CastAsGweModel(modelPtr) - idx = this%gridConnection%idxToGlobal(i)%index - this%gweInterfaceModel%porosity(i) = gweModel%mst%porosity(idx) - end do - end if - - ! allocate and read base - call this%spatialcon_ar() - - ! ... and now the interface model - call this%gweInterfaceModel%model_ar() - - ! AR the movers and obs through the exchange - if (this%exchangeIsOwned) then - !cdl implement this when MVT is ready - !cdl if (this%gweExchange%inmvt > 0) then - !cdl call this%gweExchange%mvt%mvt_ar() - !cdl end if - if (this%gweExchange%inobs > 0) then - call this%gweExchange%obs%obs_ar() + subroutine gwegwecon_ar(this) + class(GweGweConnectionType) :: this !< the connection + ! local + integer(I4B) :: i, idx + class(GweModelType), pointer :: gweModel + class(*), pointer :: modelPtr + + ! check if we can construct an interface model + ! NB: only makes sense after the models' allocate&read have been + ! called, which is why we do it here + call this%validateConnection() + + ! fill porosity from mst packages, needed for dsp + if (this%gweModel%inmst > 0) then + do i = 1, this%neq + modelPtr => this%gridConnection%idxToGlobal(i)%model + gweModel => CastAsGweModel(modelPtr) + idx = this%gridConnection%idxToGlobal(i)%index + this%gweInterfaceModel%porosity(i) = gweModel%mst%porosity(idx) + end do end if - end if -end subroutine gwegwecon_ar + ! allocate and read base + call this%spatialcon_ar() + + ! ... and now the interface model + call this%gweInterfaceModel%model_ar() -!> @brief validate this connection prior to constructing + ! AR the movers and obs through the exchange + if (this%exchangeIsOwned) then + !cdl implement this when MVT is ready + !cdl if (this%gweExchange%inmvt > 0) then + !cdl call this%gweExchange%mvt%mvt_ar() + !cdl end if + if (this%gweExchange%inobs > 0) then + call this%gweExchange%obs%obs_ar() + end if + end if + + end subroutine gwegwecon_ar + +!> @brief validate this connection prior to constructing !< the interface model -subroutine validateConnection(this) - use SimVariablesModule, only: errmsg - use SimModule, only: count_errors, store_error - class(GweGweConnectionType) :: this !< this connection - - ! base validation, the spatial/geometry part - call this%SpatialModelConnectionType%validateConnection() - - ! GWE related matters - if ((this%gweExchange%gwemodel1%inadv > 0 .and. this%gweExchange%gwemodel2%inadv == 0) .or. & - (this%gweExchange%gwemodel2%inadv > 0 .and. this%gweExchange%gwemodel1%inadv == 0)) then - write(errmsg, '(1x,a,a,a)') 'Cannot connect GWE models in exchange ', & - trim(this%gweExchange%name), ' because one model is configured with ADV & - &and the other one is not' - call store_error(errmsg) - end if - - if ((this%gweExchange%gwemodel1%indsp > 0 .and. this%gweExchange%gwemodel2%indsp == 0) .or. & - (this%gweExchange%gwemodel2%indsp > 0 .and. this%gweExchange%gwemodel1%indsp == 0)) then - write(errmsg, '(1x,a,a,a)') 'Cannot connect GWE models in exchange ', & - trim(this%gweExchange%name), ' because one model is configured with DSP & - &and the other one is not' - call store_error(errmsg) - end if - - ! abort on errors - if(count_errors() > 0) then - write(errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' - call ustop() - end if - -end subroutine validateConnection + subroutine validateConnection(this) + use SimVariablesModule, only: errmsg + use SimModule, only: count_errors, store_error + class(GweGweConnectionType) :: this !< this connection + ! base validation, the spatial/geometry part + call this%SpatialModelConnectionType%validateConnection() + + ! GWE related matters + if ((this%gweExchange%gwemodel1%inadv > 0 .and. & + this%gweExchange%gwemodel2%inadv == 0) .or. & + (this%gweExchange%gwemodel2%inadv > 0 .and. & + this%gweExchange%gwemodel1%inadv == 0)) then + write (errmsg, '(1x,a,a,a)') 'Cannot connect GWE models in exchange ', & + trim(this%gweExchange%name), ' because one model is configured with ADV & + &and the other one is not' + call store_error(errmsg) + end if + + if ((this%gweExchange%gwemodel1%indsp > 0 .and. & + this%gweExchange%gwemodel2%indsp == 0) .or. & + (this%gweExchange%gwemodel2%indsp > 0 .and. & + this%gweExchange%gwemodel1%indsp == 0)) then + write (errmsg, '(1x,a,a,a)') 'Cannot connect GWE models in exchange ', & + trim(this%gweExchange%name), ' because one model is configured with DSP & + &and the other one is not' + call store_error(errmsg) + end if + + ! abort on errors + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'Errors occurred while processing exchange(s)' + call ustop() + end if + + end subroutine validateConnection !> @brief add connections to the global system for !< this connection -subroutine gwegwecon_ac(this, sparse) - class(GweGweConnectionType) :: this !< this connection - type(sparsematrix), intent(inout) :: sparse !< sparse matrix to store the connections - ! local - integer(I4B) :: ic, iglo, jglo - type(GlobalCellType) :: boundaryCell, connectedCell - - ! connections to other models - do ic = 1, this%gridConnection%nrOfBoundaryCells - boundaryCell = this%gridConnection%boundaryCells(ic)%cell - connectedCell = this%gridConnection%connectedCells(ic)%cell - iglo = boundaryCell%index + boundaryCell%model%moffset - jglo = connectedCell%index + connectedCell%model%moffset - call sparse%addconnection(iglo, jglo, 1) - call sparse%addconnection(jglo, iglo, 1) - end do - - ! and internal connections - call this%spatialcon_ac(sparse) - -end subroutine gwegwecon_ac - -subroutine gwegwecon_rp(this) - class(GweGweConnectionType) :: this !< the connection - - ! Call exchange rp routines - if (this%exchangeIsOwned) then - call this%gweExchange%exg_rp() - end if - -end subroutine gwegwecon_rp + subroutine gwegwecon_ac(this, sparse) + class(GweGweConnectionType) :: this !< this connection + type(sparsematrix), intent(inout) :: sparse !< sparse matrix to store the connections + ! local + integer(I4B) :: ic, iglo, jglo + type(GlobalCellType) :: boundaryCell, connectedCell + + ! connections to other models + do ic = 1, this%gridConnection%nrOfBoundaryCells + boundaryCell = this%gridConnection%boundaryCells(ic)%cell + connectedCell = this%gridConnection%connectedCells(ic)%cell + iglo = boundaryCell%index + boundaryCell%model%moffset + jglo = connectedCell%index + connectedCell%model%moffset + call sparse%addconnection(iglo, jglo, 1) + call sparse%addconnection(jglo, iglo, 1) + end do + ! and internal connections + call this%spatialcon_ac(sparse) + + end subroutine gwegwecon_ac + + subroutine gwegwecon_rp(this) + class(GweGweConnectionType) :: this !< the connection + + ! Call exchange rp routines + if (this%exchangeIsOwned) then + call this%gweExchange%exg_rp() + end if + + end subroutine gwegwecon_rp !> @brief Advance this connection !< -subroutine gwegwecon_ad(this) - class(GweGweConnectionType) :: this !< this connection - - ! copy model data into interface model - call this%syncInterfaceModel() + subroutine gwegwecon_ad(this) + class(GweGweConnectionType) :: this !< this connection - ! recalculate dispersion ellipse - if (this%gweInterfaceModel%indsp > 0) call this%gweInterfaceModel%dsp%dsp_ad() + ! copy model data into interface model + call this%syncInterfaceModel() - if (this%exchangeIsOwned) then - call this%gweExchange%exg_ad() - end if + ! recalculate dispersion ellipse + if (this%gweInterfaceModel%indsp > 0) call this%gweInterfaceModel%dsp%dsp_ad() -end subroutine gwegwecon_ad + if (this%exchangeIsOwned) then + call this%gweExchange%exg_ad() + end if + end subroutine gwegwecon_ad -subroutine gwegwecon_cf(this, kiter) - class(GweGweConnectionType) :: this !< the connection - integer(I4B), intent(in) :: kiter !< the iteration counter - ! local - integer(I4B) :: i + subroutine gwegwecon_cf(this, kiter) + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(in) :: kiter !< the iteration counter + ! local + integer(I4B) :: i - ! copy model data into interface model - ! (when kiter == 1, this is already done in _ad) - if (kiter > 1) call this%syncInterfaceModel() + ! copy model data into interface model + ! (when kiter == 1, this is already done in _ad) + if (kiter > 1) call this%syncInterfaceModel() - ! reset interface system - do i = 1, this%nja - this%amat(i) = 0.0_DP - end do - do i = 1, this%neq - this%rhs(i) = 0.0_DP - end do + ! reset interface system + do i = 1, this%nja + this%amat(i) = 0.0_DP + end do + do i = 1, this%neq + this%rhs(i) = 0.0_DP + end do - call this%gweInterfaceModel%model_cf(kiter) - -end subroutine gwegwecon_cf + call this%gweInterfaceModel%model_cf(kiter) + end subroutine gwegwecon_cf !> @brief called during advance (*_ad), to copy the data !! from the models into the connection's placeholder arrays !< -subroutine syncInterfaceModel(this) - class(GweGweConnectionType) :: this !< the connection - ! local - integer(I4B) :: i, n, m, ipos, iposLoc, idx - type(ConnectionsType), pointer :: imCon !< interface model connections - type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell - type(GlobalCellType), pointer :: boundaryCell, connectedCell - class(GweModelType), pointer :: gweModel - class(*), pointer :: modelPtr - - ! for readability - imCon => this%gweInterfaceModel%dis%con - toGlobal => this%gridConnection%idxToGlobal - - ! loop over connections in interface - do n = 1, this%neq - do ipos = imCon%ia(n) + 1, imCon%ia(n+1) - 1 - m = imCon%ja(ipos) - if (associated(toGlobal(n)%model, toGlobal(m)%model)) then - ! internal connection for a model, copy from its flowja - iposLoc = getCSRIndex(toGlobal(n)%index, toGlobal(m)%index, & - toGlobal(n)%model%ia, toGlobal(n)%model%ja) - modelPtr => toGlobal(n)%model - gweModel => CastAsGweModel(modelPtr) - this%gwfflowja(ipos) = gweModel%fmi%gwfflowja(iposLoc) - end if + subroutine syncInterfaceModel(this) + class(GweGweConnectionType) :: this !< the connection + ! local + integer(I4B) :: i, n, m, ipos, iposLoc, idx + type(ConnectionsType), pointer :: imCon !< interface model connections + type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell + type(GlobalCellType), pointer :: boundaryCell, connectedCell + class(GweModelType), pointer :: gweModel + class(*), pointer :: modelPtr + + ! for readability + imCon => this%gweInterfaceModel%dis%con + toGlobal => this%gridConnection%idxToGlobal + + ! loop over connections in interface + do n = 1, this%neq + do ipos = imCon%ia(n) + 1, imCon%ia(n + 1) - 1 + m = imCon%ja(ipos) + if (associated(toGlobal(n)%model, toGlobal(m)%model)) then + ! internal connection for a model, copy from its flowja + iposLoc = getCSRIndex(toGlobal(n)%index, toGlobal(m)%index, & + toGlobal(n)%model%ia, toGlobal(n)%model%ja) + modelPtr => toGlobal(n)%model + gweModel => CastAsGweModel(modelPtr) + this%gwfflowja(ipos) = gweModel%fmi%gwfflowja(iposLoc) + end if + end do end do - end do - - ! the flowja for exchange cells - do i = 1, this%gridConnection%nrOfBoundaryCells - boundaryCell => this%gridConnection%boundaryCells(i)%cell - connectedCell => this%gridConnection%connectedCells(i)%cell - n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & - boundaryCell%model) - m = this%gridConnection%getInterfaceIndex(connectedCell%index, & - connectedCell%model) - ipos = getCSRIndex(n, m, imCon%ia, imCon%ja) - this%gwfflowja(ipos) = this%exgflowja(i) * this%exgflowSign - ipos = getCSRIndex(m, n, imCon%ia, imCon%ja) - this%gwfflowja(ipos) = -this%exgflowja(i) * this%exgflowSign - end do - - ! copy concentrations - do i = 1, this%gridConnection%nrOfCells - idx = this%gridConnection%idxToGlobal(i)%index - this%x(i) = this%gridConnection%idxToGlobal(i)%model%x(idx) - this%gweInterfaceModel%xold(i) = this%gridConnection%idxToGlobal(i)%model%xold(idx) - end do - - ! copy fmi - do i = 1, this%gridConnection%nrOfCells - idx = this%gridConnection%idxToGlobal(i)%index - modelPtr => this%gridConnection%idxToGlobal(i)%model - gweModel => CastAsGweModel(modelPtr) - - this%gwfsat(i) = gweModel%fmi%gwfsat(idx) - this%gwfhead(i) = gweModel%fmi%gwfhead(idx) - this%gwfspdis(1, i) = gweModel%fmi%gwfspdis(1, idx) - this%gwfspdis(2, i) = gweModel%fmi%gwfspdis(2, idx) - this%gwfspdis(3, i) = gweModel%fmi%gwfspdis(3, idx) - end do - -end subroutine syncInterfaceModel - - -subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) - class(GweGweConnectionType) :: this !< the connection - integer(I4B), intent(in) :: kiter !< the iteration counter - integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array - real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients - real(DP), dimension(:), intent(inout) ::rhssln !< global right-hand-side - integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag - ! local - integer(I4B) :: n, nglo, ipos - - call this%gweInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) - - ! map back to solution matrix - do n = 1, this%neq - ! We only need the coefficients for our own model - ! (i.e. rows in the matrix that belong to this%owner): - if (.not. associated(this%gridConnection%idxToGlobal(n)%model, this%owner)) then - cycle - end if - - nglo = this%gridConnection%idxToGlobal(n)%index + this%gridConnection%idxToGlobal(n)%model%moffset - rhssln(nglo) = rhssln(nglo) + this%rhs(n) - - do ipos = this%ia(n), this%ia(n+1) - 1 - amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + this%amat(ipos) + + ! the flowja for exchange cells + do i = 1, this%gridConnection%nrOfBoundaryCells + boundaryCell => this%gridConnection%boundaryCells(i)%cell + connectedCell => this%gridConnection%connectedCells(i)%cell + n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & + boundaryCell%model) + m = this%gridConnection%getInterfaceIndex(connectedCell%index, & + connectedCell%model) + ipos = getCSRIndex(n, m, imCon%ia, imCon%ja) + this%gwfflowja(ipos) = this%exgflowja(i) * this%exgflowSign + ipos = getCSRIndex(m, n, imCon%ia, imCon%ja) + this%gwfflowja(ipos) = -this%exgflowja(i) * this%exgflowSign + end do + + ! copy concentrations + do i = 1, this%gridConnection%nrOfCells + idx = this%gridConnection%idxToGlobal(i)%index + this%x(i) = this%gridConnection%idxToGlobal(i)%model%x(idx) + this%gweInterfaceModel%xold(i) = & + this%gridConnection%idxToGlobal(i)%model%xold(idx) end do - end do - ! FC the movers through the exchange; we can call - ! exg_fc() directly because it only handles mover terms (unlike in GwfExchange%exg_fc) - if (this%exchangeIsOwned) then - call this%gweExchange%exg_fc(kiter, iasln, amatsln, rhssln, inwtflag) - end if + ! copy fmi + do i = 1, this%gridConnection%nrOfCells + idx = this%gridConnection%idxToGlobal(i)%index + modelPtr => this%gridConnection%idxToGlobal(i)%model + gweModel => CastAsGweModel(modelPtr) -end subroutine gwegwecon_fc + this%gwfsat(i) = gweModel%fmi%gwfsat(idx) + this%gwfhead(i) = gweModel%fmi%gwfhead(idx) + this%gwfspdis(1, i) = gweModel%fmi%gwfspdis(1, idx) + this%gwfspdis(2, i) = gweModel%fmi%gwfspdis(2, idx) + this%gwfspdis(3, i) = gweModel%fmi%gwfspdis(3, idx) + end do -subroutine gwegwecon_cq(this, icnvg, isuppress_output, isolnid) - class(GweGweConnectionType) :: this !< the connection - integer(I4B), intent(inout) :: icnvg !< convergence flag - integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 - integer(I4B), intent(in) :: isolnid !< solution id + end subroutine syncInterfaceModel - call this%gweInterfaceModel%model_cq(icnvg, isuppress_output) - call this%setFlowToExchange() + subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(in) :: kiter !< the iteration counter + integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array + real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients + real(DP), dimension(:), intent(inout) :: rhssln !< global right-hand-side + integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag + ! local + integer(I4B) :: n, nglo, ipos + + call this%gweInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) -end subroutine gwegwecon_cq + ! map back to solution matrix + do n = 1, this%neq + ! We only need the coefficients for our own model + ! (i.e. rows in the matrix that belong to this%owner): + if (.not. associated(this%gridConnection%idxToGlobal(n)%model, & + this%owner)) then + cycle + end if - !> @brief Set the flows (flowja from interface model) to the + nglo = this%gridConnection%idxToGlobal(n)%index + & + this%gridConnection%idxToGlobal(n)%model%moffset + rhssln(nglo) = rhssln(nglo) + this%rhs(n) + + do ipos = this%ia(n), this%ia(n + 1) - 1 + amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + & + this%amat(ipos) + end do + end do + + ! FC the movers through the exchange; we can call + ! exg_fc() directly because it only handles mover terms (unlike in GwfExchange%exg_fc) + if (this%exchangeIsOwned) then + call this%gweExchange%exg_fc(kiter, iasln, amatsln, rhssln, inwtflag) + end if + + end subroutine gwegwecon_fc + + subroutine gwegwecon_cq(this, icnvg, isuppress_output, isolnid) + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id + + call this%gweInterfaceModel%model_cq(icnvg, isuppress_output) + call this%setFlowToExchange() + + end subroutine gwegwecon_cq + + !> @brief Set the flows (flowja from interface model) to the !< simvals in the exchange, leaving the budget calcution in there subroutine setFlowToExchange(this) class(GweGweConnectionType) :: this !< this connection @@ -528,102 +533,103 @@ subroutine setFlowToExchange(this) class(GweExchangeType), pointer :: gweEx gweEx => this%gweExchange - if (this%exchangeIsOwned) then + if (this%exchangeIsOwned) then do i = 1, gweEx%nexg gweEx%simvals(i) = DZERO - if (gweEx%gwemodel1%ibound(gweEx%nodem1(i)) /= 0 .and. & + if (gweEx%gwemodel1%ibound(gweEx%nodem1(i)) /= 0 .and. & gweEx%gwemodel2%ibound(gweEx%nodem2(i)) /= 0) then - - nIface = this%gridConnection%getInterfaceIndex(gweEx%nodem1(i), gweEx%model1) - mIface = this%gridConnection%getInterfaceIndex(gweEx%nodem2(i), gweEx%model2) - ipos = getCSRIndex(nIface, mIface, this%gweInterfaceModel%ia, this%gweInterfaceModel%ja) + nIface = this%gridConnection%getInterfaceIndex(gweEx%nodem1(i), & + gweEx%model1) + mIface = this%gridConnection%getInterfaceIndex(gweEx%nodem2(i), & + gweEx%model2) + ipos = getCSRIndex(nIface, mIface, this%gweInterfaceModel%ia, & + this%gweInterfaceModel%ja) gweEx%simvals(i) = this%gweInterfaceModel%flowja(ipos) - end if end do end if end subroutine setFlowToExchange -subroutine gwegwecon_bd(this, icnvg, isuppress_output, isolnid) - use BudgetModule, only: rate_accumulator - class(GweGweConnectionType) :: this !< the connection - integer(I4B), intent(inout) :: icnvg !< convergence flag - integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 - integer(I4B), intent(in) :: isolnid !< solution id - - ! call exchange budget routine, also calls bd - ! for movers. - if (this%exchangeIsOwned) then - call this%gweExchange%exg_bd(icnvg, isuppress_output, isolnid) - end if - -end subroutine gwegwecon_bd - -subroutine gwegwecon_ot(this) - class(GweGweConnectionType) :: this !< the connection - - ! Call exg_ot() here as it handles all output processing - ! based on gweExchange%simvals(:), which was correctly - ! filled from gwegwecon - if (this%exchangeIsOwned) then - call this%gweExchange%exg_ot() - end if - -end subroutine gwegwecon_ot - -subroutine gwegwecon_da(this) - class(GweGweConnectionType) :: this !< the connection - ! local - logical(LGP) :: isOpen - - ! scalars - call mem_deallocate(this%iIfaceAdvScheme) - call mem_deallocate(this%iIfaceXt3d) - call mem_deallocate(this%exgflowSign) - - ! arrays - call mem_deallocate(this%gwfflowja) - call mem_deallocate(this%gwfsat) - call mem_deallocate(this%gwfhead) - call mem_deallocate(this%gwfspdis) - call mem_deallocate(this%exgflowjaGwt) - - ! interface model - call this%gweInterfaceModel%model_da() - deallocate(this%gweInterfaceModel) - - ! dealloc base - call this%spatialcon_da() - - inquire(this%iout, opened=isOpen) + subroutine gwegwecon_bd(this, icnvg, isuppress_output, isolnid) + use BudgetModule, only: rate_accumulator + class(GweGweConnectionType) :: this !< the connection + integer(I4B), intent(inout) :: icnvg !< convergence flag + integer(I4B), intent(in) :: isuppress_output !< suppress output when =1 + integer(I4B), intent(in) :: isolnid !< solution id + + ! call exchange budget routine, also calls bd + ! for movers. + if (this%exchangeIsOwned) then + call this%gweExchange%exg_bd(icnvg, isuppress_output, isolnid) + end if + + end subroutine gwegwecon_bd + + subroutine gwegwecon_ot(this) + class(GweGweConnectionType) :: this !< the connection + + ! Call exg_ot() here as it handles all output processing + ! based on gweExchange%simvals(:), which was correctly + ! filled from gwegwecon + if (this%exchangeIsOwned) then + call this%gweExchange%exg_ot() + end if + + end subroutine gwegwecon_ot + + subroutine gwegwecon_da(this) + class(GweGweConnectionType) :: this !< the connection + ! local + logical(LGP) :: isOpen + + ! scalars + call mem_deallocate(this%iIfaceAdvScheme) + call mem_deallocate(this%iIfaceXt3d) + call mem_deallocate(this%exgflowSign) + + ! arrays + call mem_deallocate(this%gwfflowja) + call mem_deallocate(this%gwfsat) + call mem_deallocate(this%gwfhead) + call mem_deallocate(this%gwfspdis) + call mem_deallocate(this%exgflowjaGwt) + + ! interface model + call this%gweInterfaceModel%model_da() + deallocate (this%gweInterfaceModel) + + ! dealloc base + call this%spatialcon_da() + + inquire (this%iout, opened=isOpen) if (isOpen) then - close(this%iout) + close (this%iout) end if - ! we need to deallocate the exchange we own: - if (this%exchangeIsOwned) then - call this%gweExchange%exg_da() - end if + ! we need to deallocate the exchange we own: + if (this%exchangeIsOwned) then + call this%gweExchange%exg_da() + end if -end subroutine gwegwecon_da + end subroutine gwegwecon_da !> @brief Cast to GweGweConnectionType !< -function CastAsGweGweConnection(obj) result (res) - implicit none - class(*), pointer, intent(inout) :: obj !< object to be cast - class(GweGweConnectionType), pointer :: res !< the GweGweConnection - - res => null() - if (.not. associated(obj)) return - - select type (obj) - class is (GweGweConnectionType) - res => obj - end select - return -end function CastAsGweGweConnection - -end module \ No newline at end of file + function CastAsGweGweConnection(obj) result(res) + implicit none + class(*), pointer, intent(inout) :: obj !< object to be cast + class(GweGweConnectionType), pointer :: res !< the GweGweConnection + + res => null() + if (.not. associated(obj)) return + + select type (obj) + class is (GweGweConnectionType) + res => obj + end select + return + end function CastAsGweGweConnection + +end module diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 729312993e2..a24c484e3a7 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -1,5 +1,5 @@ module GweInterfaceModelModule - use KindModule, only: I4B, DP + use KindModule, only: I4B, DP use MemoryManagerModule, only: mem_allocate, mem_deallocate use MemoryHelperModule, only: create_mem_path use NumericalModelModule, only: NumericalModelType @@ -18,16 +18,16 @@ module GweInterfaceModelModule private !> The GWE Interface Model is a utility to calculate the solution's - !! exchange coefficients from the interface between a GWE model and - !! its GWE neighbors. The interface model itself will not be part - !! of the solution, it is not being solved. + !! exchange coefficients from the interface between a GWE model and + !! its GWE neighbors. The interface model itself will not be part + !! of the solution, it is not being solved. type, public, extends(GweModelType) :: GweInterfaceModelType - integer(i4B), pointer :: iAdvScheme => null() !< the advection scheme: 0 = up, 1 = central, 2 = tvd - integer(i4B), pointer :: ixt3d => null() !< xt3d setting: 0 = off, 1 = lhs, 2 = rhs + integer(i4B), pointer :: iAdvScheme => null() !< the advection scheme: 0 = up, 1 = central, 2 = tvd + integer(i4B), pointer :: ixt3d => null() !< xt3d setting: 0 = off, 1 = lhs, 2 = rhs - class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid - class(GweModelType), private, pointer :: owner => null() !< the real GWE model for which the exchange coefficients + class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid + class(GweModelType), private, pointer :: owner => null() !< the real GWE model for which the exchange coefficients !! are calculated with this interface model real(DP), dimension(:), pointer, contiguous :: porosity => null() !< to be filled with MST porosity @@ -43,197 +43,195 @@ module GweInterfaceModelModule contains -!> @brief Create the interface model, analogously to what +!> @brief Create the interface model, analogously to what !< happens in gwe_cr -subroutine gweifmod_cr(this, name, iout, gridConn) - class(GweInterfaceModelType) :: this !< the GWE interface model - character(len=*), intent(in) :: name !< the interface model's name - integer(I4B), intent(in) :: iout !< the output unit - class(GridConnectionType), pointer, intent(in) :: gridConn !< the grid connection data for creating a DISU - ! local - class(*), pointer :: modelPtr - integer(I4B), target :: inobs - integer(I4B) :: adv_unit, dsp_unit - - this%memoryPath = create_mem_path(name) - call this%allocate_scalars(name) - - ! defaults - this%iAdvScheme = 0 - this%ixt3d = 0 - - this%iout = iout - this%gridConnection => gridConn - modelPtr => gridConn%model - this%owner => CastAsGweModel(modelPtr) - - inobs = 0 - adv_unit = 0 - dsp_unit = 0 - if (this%owner%inadv > 0) then - this%inadv = huge(1_I4B) - adv_unit = huge(1_I4B) - end if - if (this%owner%indsp > 0) then - this%indsp = huge(1_I4B) - dsp_unit = huge(1_I4B) - end if - - ! create dis and packages - call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout) - call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) - call tsp_obs_cr(this%obs, inobs) - -end subroutine gweifmod_cr - -subroutine allocate_scalars(this, modelname) - class(GweInterfaceModelType) :: this !< the GWE interface model - character(len=*), intent(in) :: modelname !< the model name - - call this%GweModelType%allocate_scalars(modelname) - - call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) - call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) - -end subroutine allocate_scalars + subroutine gweifmod_cr(this, name, iout, gridConn) + class(GweInterfaceModelType) :: this !< the GWE interface model + character(len=*), intent(in) :: name !< the interface model's name + integer(I4B), intent(in) :: iout !< the output unit + class(GridConnectionType), pointer, intent(in) :: gridConn !< the grid connection data for creating a DISU + ! local + class(*), pointer :: modelPtr + integer(I4B), target :: inobs + integer(I4B) :: adv_unit, dsp_unit + + this%memoryPath = create_mem_path(name) + call this%allocate_scalars(name) + + ! defaults + this%iAdvScheme = 0 + this%ixt3d = 0 + + this%iout = iout + this%gridConnection => gridConn + modelPtr => gridConn%model + this%owner => CastAsGweModel(modelPtr) + + inobs = 0 + adv_unit = 0 + dsp_unit = 0 + if (this%owner%inadv > 0) then + this%inadv = huge(1_I4B) + adv_unit = huge(1_I4B) + end if + if (this%owner%indsp > 0) then + this%indsp = huge(1_I4B) + dsp_unit = huge(1_I4B) + end if -!> @brief Define the GWE interface model -!< -subroutine gweifmod_df(this) - class(GweInterfaceModelType) :: this !< the GWE interface model - ! local - class(*), pointer :: disPtr - type(TspAdvOptionsType) :: adv_options - type(TspDspOptionsType) :: dsp_options - integer(I4B) :: i - - this%moffset = 0 - adv_options%iAdvScheme = this%iAdvScheme - dsp_options%ixt3d = this%ixt3d - - ! define DISU - disPtr => this%dis - call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) - call this%fmi%fmi_df(this%dis, 0) - - if (this%inadv > 0) then - call this%adv%adv_df(adv_options) - end if - if (this%indsp > 0) then - call this%dsp%dsp_df(this%dis, dsp_options) - end if - - ! assign or point model members to dis members - this%neq = this%dis%nodes - this%nja = this%dis%nja - this%ia => this%dis%con%ia - this%ja => this%dis%con%ja - ! - ! allocate model arrays, now that neq and nja are assigned - call this%allocate_arrays() - call mem_allocate(this%porosity, this%neq, 'POROSITY', this%memoryPath) - - do i = 1, size(this%flowja) - this%flowja = 0.0_DP - end do - do i = 1, this%neq - this%porosity = 0.0_DP - end do - -end subroutine gweifmod_df - - -!> @brief Override allocate and read the GWE interface model and its -!! packages so that we can create stuff from memory instead of input -!< files -subroutine gweifmod_ar(this) - class(GweInterfaceModelType) :: this !< the GWE interface model - ! local - type(TspDspGridDataType) :: dspGridData - - call this%fmi%fmi_ar(this%ibound) - if (this%inadv > 0) then - call this%adv%adv_ar(this%dis, this%ibound) - end if - if (this%indsp > 0) then - this%dsp%idiffc = this%owner%dsp%idiffc - this%dsp%idisp = this%owner%dsp%idisp - call dspGridData%construct(this%neq) - call this%setDspGridData(dspGridData) - call this%dsp%dsp_ar(this%ibound, this%porosity, this%dsp%cpw, this%dsp%rhow, dspGridData) - end if - -end subroutine gweifmod_ar + ! create dis and packages + call disu_cr(this%dis, this%name, -1, this%iout) + call fmi_cr(this%fmi, this%name, 0, this%iout) + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) + call tsp_obs_cr(this%obs, inobs) + end subroutine gweifmod_cr -!> @brief set dsp grid data from models + subroutine allocate_scalars(this, modelname) + class(GweInterfaceModelType) :: this !< the GWE interface model + character(len=*), intent(in) :: modelname !< the model name + + call this%GweModelType%allocate_scalars(modelname) + + call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) + call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + + end subroutine allocate_scalars + +!> @brief Define the GWE interface model !< -subroutine setDspGridData(this, gridData) - class(GweInterfaceModelType) :: this !< the GWE interface model - type(TspDspGridDataType) :: gridData !< the dsp grid data to be set - ! local - integer(I4B) :: i, idx - class(GweModelType), pointer :: gweModel - class(*), pointer :: modelPtr - - do i = 1, this%neq - modelPtr => this%gridConnection%idxToGlobal(i)%model - gweModel => CastAsGweModel(modelPtr) - idx = this%gridConnection%idxToGlobal(i)%index - - if (this%dsp%idiffc > 0) then - gridData%diffc(i) = gweModel%dsp%diffc(idx) + subroutine gweifmod_df(this) + class(GweInterfaceModelType) :: this !< the GWE interface model + ! local + class(*), pointer :: disPtr + type(TspAdvOptionsType) :: adv_options + type(TspDspOptionsType) :: dsp_options + integer(I4B) :: i + + this%moffset = 0 + adv_options%iAdvScheme = this%iAdvScheme + dsp_options%ixt3d = this%ixt3d + + ! define DISU + disPtr => this%dis + call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) + call this%fmi%fmi_df(this%dis, 0) + + if (this%inadv > 0) then + call this%adv%adv_df(adv_options) + end if + if (this%indsp > 0) then + call this%dsp%dsp_df(this%dis, dsp_options) + end if + + ! assign or point model members to dis members + this%neq = this%dis%nodes + this%nja = this%dis%nja + this%ia => this%dis%con%ia + this%ja => this%dis%con%ja + ! + ! allocate model arrays, now that neq and nja are assigned + call this%allocate_arrays() + call mem_allocate(this%porosity, this%neq, 'POROSITY', this%memoryPath) + + do i = 1, size(this%flowja) + this%flowja = 0.0_DP + end do + do i = 1, this%neq + this%porosity = 0.0_DP + end do + + end subroutine gweifmod_df + +!> @brief Override allocate and read the GWE interface model and its +!! packages so that we can create stuff from memory instead of input +!< files + subroutine gweifmod_ar(this) + class(GweInterfaceModelType) :: this !< the GWE interface model + ! local + type(TspDspGridDataType) :: dspGridData + + call this%fmi%fmi_ar(this%ibound) + if (this%inadv > 0) then + call this%adv%adv_ar(this%dis, this%ibound) end if - if (this%dsp%idisp > 0) then - gridData%alh(i) = gweModel%dsp%alh(idx) - gridData%alv(i) = gweModel%dsp%alv(idx) - gridData%ath1(i) = gweModel%dsp%ath1(idx) - gridData%ath2(i) = gweModel%dsp%ath2(idx) - gridData%atv(i) = gweModel%dsp%atv(idx) + if (this%indsp > 0) then + this%dsp%idiffc = this%owner%dsp%idiffc + this%dsp%idisp = this%owner%dsp%idisp + call dspGridData%construct(this%neq) + call this%setDspGridData(dspGridData) + call this%dsp%dsp_ar(this%ibound, this%porosity, this%dsp%cpw, & + this%dsp%rhow, dspGridData) end if - end do + end subroutine gweifmod_ar -end subroutine setDspGridData +!> @brief set dsp grid data from models +!< + subroutine setDspGridData(this, gridData) + class(GweInterfaceModelType) :: this !< the GWE interface model + type(TspDspGridDataType) :: gridData !< the dsp grid data to be set + ! local + integer(I4B) :: i, idx + class(GweModelType), pointer :: gweModel + class(*), pointer :: modelPtr + + do i = 1, this%neq + modelPtr => this%gridConnection%idxToGlobal(i)%model + gweModel => CastAsGweModel(modelPtr) + idx = this%gridConnection%idxToGlobal(i)%index + + if (this%dsp%idiffc > 0) then + gridData%diffc(i) = gweModel%dsp%diffc(idx) + end if + if (this%dsp%idisp > 0) then + gridData%alh(i) = gweModel%dsp%alh(idx) + gridData%alv(i) = gweModel%dsp%alv(idx) + gridData%ath1(i) = gweModel%dsp%ath1(idx) + gridData%ath2(i) = gweModel%dsp%ath2(idx) + gridData%atv(i) = gweModel%dsp%atv(idx) + end if + + end do + + end subroutine setDspGridData !> @brief Clean up resources !< -subroutine gweifmod_da(this) - class(GweInterfaceModelType) :: this !< the GWE interface model - - ! this - call mem_deallocate(this%iAdvScheme) - call mem_deallocate(this%ixt3d) - call mem_deallocate(this%porosity) - - ! gwe packages - call this%dis%dis_da() - call this%fmi%fmi_da() - call this%adv%adv_da() - call this%dsp%dsp_da() - - deallocate(this%dis) - deallocate(this%fmi) - deallocate(this%adv) - deallocate(this%dsp) - - ! gwe scalars - call mem_deallocate(this%inic) - call mem_deallocate(this%infmi) - call mem_deallocate(this%inadv) - call mem_deallocate(this%indsp) - call mem_deallocate(this%inssm) - call mem_deallocate(this%inmst) - call mem_deallocate(this%inmvt) - call mem_deallocate(this%inoc) - call mem_deallocate(this%inobs) - - ! base - call this%NumericalModelType%model_da() - -end subroutine gweifmod_da - - -end module GweInterfaceModelModule \ No newline at end of file + subroutine gweifmod_da(this) + class(GweInterfaceModelType) :: this !< the GWE interface model + + ! this + call mem_deallocate(this%iAdvScheme) + call mem_deallocate(this%ixt3d) + call mem_deallocate(this%porosity) + + ! gwe packages + call this%dis%dis_da() + call this%fmi%fmi_da() + call this%adv%adv_da() + call this%dsp%dsp_da() + + deallocate (this%dis) + deallocate (this%fmi) + deallocate (this%adv) + deallocate (this%dsp) + + ! gwe scalars + call mem_deallocate(this%inic) + call mem_deallocate(this%infmi) + call mem_deallocate(this%inadv) + call mem_deallocate(this%indsp) + call mem_deallocate(this%inssm) + call mem_deallocate(this%inmst) + call mem_deallocate(this%inmvt) + call mem_deallocate(this%inoc) + call mem_deallocate(this%inobs) + + ! base + call this%NumericalModelType%model_da() + + end subroutine gweifmod_da + +end module GweInterfaceModelModule diff --git a/src/Model/ModelUtilities/TspAdvOptions.f90 b/src/Model/ModelUtilities/TspAdvOptions.f90 index f10a4fb10e3..08beb0e0d80 100644 --- a/src/Model/ModelUtilities/TspAdvOptions.f90 +++ b/src/Model/ModelUtilities/TspAdvOptions.f90 @@ -7,4 +7,4 @@ module TspAdvOptionsModule integer(I4B) :: iAdvScheme !< the advection scheme: 0 = up, 1 = central, 2 = TVD end type TspAdvOptionsType -end module TspAdvOptionsModule \ No newline at end of file +end module TspAdvOptionsModule diff --git a/src/Model/ModelUtilities/TspDspGridData.f90 b/src/Model/ModelUtilities/TspDspGridData.f90 index 9c9c9eec13d..c54a0a8cb7e 100644 --- a/src/Model/ModelUtilities/TspDspGridData.f90 +++ b/src/Model/ModelUtilities/TspDspGridData.f90 @@ -1,63 +1,63 @@ module TspDspGridDataModule -use KindModule, only: DP, I4B -implicit none -private + use KindModule, only: DP, I4B + implicit none + private !> @brief data structure and helpers for passing dsp grid data !< into the package, as opposed to reading from file -type, public :: TspDspGridDataType - real(DP), dimension(:), pointer, contiguous :: diffc => null() !< molecular diffusion coefficient for each cell - real(DP), dimension(:), pointer, contiguous :: alh => null() !< longitudinal horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: alv => null() !< longitudinal vertical dispersivity - real(DP), dimension(:), pointer, contiguous :: ath1 => null() !< transverse horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: ath2 => null() !< transverse horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: atv => null() !< transverse vertical dispersivity - real(DP), dimension(:), pointer, contiguous :: ktw => null() !< thermal conductivity of water - real(DP), dimension(:), pointer, contiguous :: kts => null() !< thermal conductivity of solids - real(DP), dimension(:), pointer, contiguous :: cpw => null() !< heat capacity of water from mst - real(DP), dimension(:), pointer, contiguous :: rhow => null() !< density of water from mst -contains - procedure, pass(this) :: construct - procedure, pass(this) :: destroy -end type TspDspGridDataType + type, public :: TspDspGridDataType + real(DP), dimension(:), pointer, contiguous :: diffc => null() !< molecular diffusion coefficient for each cell + real(DP), dimension(:), pointer, contiguous :: alh => null() !< longitudinal horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: alv => null() !< longitudinal vertical dispersivity + real(DP), dimension(:), pointer, contiguous :: ath1 => null() !< transverse horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: ath2 => null() !< transverse horizontal dispersivity + real(DP), dimension(:), pointer, contiguous :: atv => null() !< transverse vertical dispersivity + real(DP), dimension(:), pointer, contiguous :: ktw => null() !< thermal conductivity of water + real(DP), dimension(:), pointer, contiguous :: kts => null() !< thermal conductivity of solids + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< heat capacity of water from mst + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< density of water from mst + contains + procedure, pass(this) :: construct + procedure, pass(this) :: destroy + end type TspDspGridDataType contains !> @brief allocate data structure !< -subroutine construct(this, nodes) - class(TspDspGridDataType) :: this - integer(I4B) :: nodes - - allocate(this%diffc(nodes)) - allocate(this%alh(nodes)) - allocate(this%alv(nodes)) - allocate(this%ath1(nodes)) - allocate(this%ath2(nodes)) - allocate(this%atv(nodes)) - allocate(this%ktw(nodes)) - allocate(this%kts(nodes)) - allocate(this%cpw(nodes)) - allocate(this%rhow(nodes)) - -end subroutine construct + subroutine construct(this, nodes) + class(TspDspGridDataType) :: this + integer(I4B) :: nodes + + allocate (this%diffc(nodes)) + allocate (this%alh(nodes)) + allocate (this%alv(nodes)) + allocate (this%ath1(nodes)) + allocate (this%ath2(nodes)) + allocate (this%atv(nodes)) + allocate (this%ktw(nodes)) + allocate (this%kts(nodes)) + allocate (this%cpw(nodes)) + allocate (this%rhow(nodes)) + + end subroutine construct !> @brief clean up !< -subroutine destroy(this) - class(TspDspGridDataType) :: this - - deallocate(this%diffc) - deallocate(this%alh) - deallocate(this%alv) - deallocate(this%ath1) - deallocate(this%ath2) - deallocate(this%atv) - deallocate(this%ktw) - deallocate(this%kts) - deallocate(this%cpw) - deallocate(this%rhow) - -end subroutine destroy - -end module TspDspGridDataModule \ No newline at end of file + subroutine destroy(this) + class(TspDspGridDataType) :: this + + deallocate (this%diffc) + deallocate (this%alh) + deallocate (this%alv) + deallocate (this%ath1) + deallocate (this%ath2) + deallocate (this%atv) + deallocate (this%ktw) + deallocate (this%kts) + deallocate (this%cpw) + deallocate (this%rhow) + + end subroutine destroy + +end module TspDspGridDataModule diff --git a/src/Model/ModelUtilities/TspDspOptions.f90 b/src/Model/ModelUtilities/TspDspOptions.f90 index 4c3d6829ad3..03a267556d3 100644 --- a/src/Model/ModelUtilities/TspDspOptions.f90 +++ b/src/Model/ModelUtilities/TspDspOptions.f90 @@ -9,4 +9,4 @@ module TspDspOptionsModule integer(I4B) :: ixt3d !< flag indicating xt3d is active: 1 = enabled, 2 = rhs end type TspDspOptionsType -end module TspDspOptionsModule \ No newline at end of file +end module TspDspOptionsModule diff --git a/src/Model/ModelUtilities/TspLabels.f90 b/src/Model/ModelUtilities/TspLabels.f90 index 64b9826887b..b96f1ec2de4 100644 --- a/src/Model/ModelUtilities/TspLabels.f90 +++ b/src/Model/ModelUtilities/TspLabels.f90 @@ -1,13 +1,13 @@ !> @brief This module contains the TspLabels Module !! -!! A generic module containing the labels used by -!! the generalized TransportModel module that assigns -!! labeling based on which type of transport model an -!! instance of this module is associated with (GWT or +!! A generic module containing the labels used by +!! the generalized TransportModel module that assigns +!! labeling based on which type of transport model an +!! instance of this module is associated with (GWT or !! GWE) -!! +!! !! Labels that need to be transport model type specific: -!! +!! !! GWT | GWE | src files w/label !! -----------------|-------------------|-------------- !! "Concentration" |"Temperature" | gwt1.f90 @@ -26,56 +26,56 @@ !! "Concentration" |"Temperature" | Gwe.f90 !! "Cumulative Mass"|"Cumulative Energy"| Budget.f90 (_ot routine) !! "MASS", "M" |"?", "?" | gwt1.f90 (gwt_df routine & _ot routine) -!! "M/T" |"Watts" (?) | +!! "M/T" |"Watts" (?) | !! "M" |"Joules" or "E" | !< module TspLabelsModule - - use KindModule, only: DP, LGP, I4B - use ConstantsModule, only: LENVARNAME - + + use KindModule, only: DP, LGP, I4B + use ConstantsModule, only: LENVARNAME + implicit none private public :: TspLabelsType public :: tsplabels_cr - + !> @brief Define labels for use with generalized transport model - !! + !! !! Subroutine to store which type of units are in use since a !! generalized transport model is the base clase for either a !! solute transport (GWT) or heat transport (GWE) !! !< type TspLabelsType - character(len=LENVARNAME), pointer :: modname => null() !< name of the model that module is associated with - character(len=LENVARNAME), pointer :: tsptype => null() !< "solute" or "heat" - character(len=LENVARNAME), pointer :: depvartype => null() !< "concentration" or "temperature" - character(len=LENVARNAME), pointer :: depvarunit => null() !< "mass" or "joules" + character(len=LENVARNAME), pointer :: modname => null() !< name of the model that module is associated with + character(len=LENVARNAME), pointer :: tsptype => null() !< "solute" or "heat" + character(len=LENVARNAME), pointer :: depvartype => null() !< "concentration" or "temperature" + character(len=LENVARNAME), pointer :: depvarunit => null() !< "mass" or "joules" character(len=LENVARNAME), pointer :: depvarunitabbrev => null() !< "M/T" or "watts" (or "kilowatts") - + contains - procedure :: tsplabels_df + procedure :: tsplabels_df ! -- private - procedure :: allocate_label_names + procedure :: allocate_label_names end type TspLabelsType - - contains + +contains !> @brief Create a new transport labels object !! !! Create a new labels object - !! + !! !< subroutine tsplabels_cr(this, name_model) ! -- modules ! -- dummy variables - type(TspLabelsType), pointer :: this !< TspLabelsType object - character(len=*), intent(in) :: name_model !< name of the model + type(TspLabelsType), pointer :: this !< TspLabelsType object + character(len=*), intent(in) :: name_model !< name of the model ! ------------------------------------------------------------------- ! ! -- Create the object - allocate(this) + allocate (this) ! -- local variables ! ! -- Allocate variable names @@ -84,7 +84,7 @@ subroutine tsplabels_cr(this, name_model) ! -- Return return end subroutine tsplabels_cr - + !> @brief Define the labels corresponding to the flavor of !! transport model !! @@ -93,38 +93,38 @@ end subroutine tsplabels_cr !< subroutine tsplabels_df(this, tsptype, depvartype, depvarunit, depvarunitabbrev) class(TspLabelsType) :: this - character(len=*), optional :: tsptype !< type of model, default is GWT6 - character(len=*), optional :: depvartype !< dependent variable type, default is "CONCENTRATION" - character(len=*), optional :: depvarunit !< units of dependent variable for writing to list file + character(len=*), optional :: tsptype !< type of model, default is GWT6 + character(len=*), optional :: depvartype !< dependent variable type, default is "CONCENTRATION" + character(len=*), optional :: depvarunit !< units of dependent variable for writing to list file character(len=*), optional :: depvarunitabbrev !< abbreviation of associated units ! ! -- Set the model type - if(present(tsptype)) then + if (present(tsptype)) then this%tsptype = tsptype else this%tsptype = 'GWT6' - endif + end if ! ! -- Set the type of dependent variable being solved for - if(present(tsptype)) then + if (present(tsptype)) then this%depvartype = depvartype else this%depvartype = 'CONCENTRATION' - endif + end if ! ! -- Set the units associated with the dependent variable - if(present(depvarunit)) then + if (present(depvarunit)) then this%depvarunit = depvarunit else this%depvarunit = 'MASS' - endif + end if ! ! -- Set the units abbreviation - if(present(depvarunitabbrev)) then + if (present(depvarunitabbrev)) then this%depvarunitabbrev = depvarunitabbrev else this%depvarunitabbrev = 'M/T' - endif + end if ! ! -- Return return @@ -139,14 +139,14 @@ end subroutine tsplabels_df subroutine allocate_label_names(this, name_model) ! -- modules ! -- dummy - class(TspLabelsType) :: this !< TspLabelsType object - character(len=*), intent(in) :: name_model !< name of the model + class(TspLabelsType) :: this !< TspLabelsType object + character(len=*), intent(in) :: name_model !< name of the model ! - allocate(this%modname) - allocate(this%tsptype) - allocate(this%depvartype) - allocate(this%depvarunit) - allocate(this%depvarunitabbrev) + allocate (this%modname) + allocate (this%tsptype) + allocate (this%depvartype) + allocate (this%depvarunit) + allocate (this%depvarunitabbrev) ! ! -- Initialize values this%tsptype = '' @@ -159,24 +159,24 @@ subroutine allocate_label_names(this, name_model) ! return end subroutine allocate_label_names - + !> @ breif Deallocate memory !! !! Deallocate budget memory !! !< subroutine tsplabels_da(this) - class(TspLabelsType) :: this !< TspLabelsType object + class(TspLabelsType) :: this !< TspLabelsType object ! ! -- Strings - deallocate(this%modname) - deallocate(this%tsptype) - deallocate(this%depvartype) - deallocate(this%depvarunit) - deallocate(this%depvarunitabbrev) + deallocate (this%modname) + deallocate (this%tsptype) + deallocate (this%depvartype) + deallocate (this%depvarunit) + deallocate (this%depvarunitabbrev) ! ! -- Return return end subroutine tsplabels_da - -end module TspLabelsModule \ No newline at end of file + +end module TspLabelsModule diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index f2a0058c734..ac592cac15f 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -1,31 +1,84 @@ ! Generalized Transport Base Class ! Base class for solute (mass) and energy (thermal) transport ! (The following copied from gwt1.f90) -! * Add check that discretization is the same between both models +! * Add check that discretization is the same between both models ! * Program GWT-GWT exchange transport (awaiting implementation of interface model) ! * Consider implementation of steady-state transport (affects MST, IST) ! * Check and handle pore space discrepancy between flow and transport (porosity vs specific yield) ! * UZT may not have the required porosity term module TransportModelModule - use KindModule, only: DP, I4B - use ConstantsModule, only: LENFTYPE - use SimVariablesModule, only: errmsg - use NumericalModelModule, only: NumericalModelType - + use KindModule, only: DP, I4B + use ConstantsModule, only: LENFTYPE + use SimVariablesModule, only: errmsg + use NumericalModelModule, only: NumericalModelType + use TspLabelsModule, only: TspLabelsType + implicit none - + private - + public :: TransportModelType - + public :: niunit, cunit + type, extends(NumericalModelType) :: TransportModelType contains - + end type TransportModelType - - -end module TransportModelModule - \ No newline at end of file + ! -- Module variables constant for simulation + integer(I4B), parameter :: NIUNIT = 100 + character(len=LENFTYPE), dimension(NIUNIT) :: cunit + data cunit/'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 + 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', ' ', & ! 10 + 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 + 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 + 'API6 ', ' ', ' ', ' ', ' ', & ! 25 + 75*' '/ + +contains + + subroutine allocate_scalars(this, modelname) +! ****************************************************************************** +! allocate_scalars -- Allocate memory for non-allocatable members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(TransportModelType) :: this + character(len=*), intent(in) :: modelname +! ------------------------------------------------------------------------------ + ! + ! -- allocate members from parent class + call this%NumericalModelType%allocate_scalars(modelname) + ! + ! -- allocate members that are part of model class + !call mem_allocate(this%inic , 'INIC', this%memoryPath) + !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) + !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) + !call mem_allocate(this%inmst, 'INMST', this%memoryPath) + !call mem_allocate(this%inadv, 'INADV', this%memoryPath) + !call mem_allocate(this%indsp, 'INDSP', this%memoryPath) + !call mem_allocate(this%inssm, 'INSSM', this%memoryPath) + !call mem_allocate(this%inoc, 'INOC ', this%memoryPath) + !call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + ! + !this%inic = 0 + !this%infmi = 0 + !this%inmvt = 0 + !this%inmst = 0 + !this%inadv = 0 + !this%indsp = 0 + !this%inssm = 0 + !this%inoc = 0 + !this%inobs = 0 + ! + ! -- return + return + end subroutine allocate_scalars + +end module TransportModelModule From 159d2bf973d4b3ee37bc05d229358ad3389a433f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 14 Jul 2022 10:24:07 -0700 Subject: [PATCH 016/212] More minor clean-up --- src/Exchange/GweGweExchange.f90 | 2 +- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 12 +++++++----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index 1938822905a..ec2b78fa617 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -831,7 +831,7 @@ function parse_option(this, keyword, iout) result(parsed) if (this%gwfmodelname2 /= '') then call store_error('GWFMODELNAME2 has already been set to ' & //trim(this%gwfmodelname2)// & - s'. Cannot set more than once.') + '. Cannot set more than once.') call this%parser%StoreErrorUnit() end if this%gwfmodelname2 = subkey(1:LENMODELNAME) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 4d2f397cf48..fdaae59ce31 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -268,11 +268,13 @@ subroutine dsp_ad(this) ! TODO: might consider adding a new mf6 level set pointers method, and ! doing this stuff there instead of in the time step loop. if (kstp * kper == 1) then - if (this%ixt3d > 0) - call this%xt3d%xt3d_ar(this%fmi%ibdgwfsat0, this%d11, this%id33, & - this%d33, this%fmi%gwfsat, this%id22, & - this%d22, this%iangle1, this%iangle2, & - this%iangle3, this%angle1, this%angle2, this%angle3) + if (this%ixt3d > 0) then + call this%xt3d%xt3d_ar(this%fmi%ibdgwfsat0, this%d11, this%id33, & + this%d33, this%fmi%gwfsat, this%id22, & + this%d22, this%iangle1, this%iangle2, & + this%iangle3, this%angle1, this%angle2, & + this%angle3) + end if end if ! ! -- Fill d11, d22, d33, angle1, angle2, angle3 using specific discharge From ffebddc7caa722366c5a29f4da9d0f7f29f9429c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 14 Jul 2022 11:59:54 -0700 Subject: [PATCH 017/212] Forgot to push .vfproj file ealier --- msvs/mf6core.vfproj | 44 ++++++++++++++++++++++++++------------------ 1 file changed, 26 insertions(+), 18 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 14e89b4289d..219e9917232 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -48,6 +48,8 @@ + + @@ -59,6 +61,8 @@ + + @@ -69,6 +73,10 @@ + + + + @@ -100,23 +108,23 @@ - - - - - + - - - - - + + + + + + + + + @@ -127,28 +135,28 @@ - - - + + + + - - - - - + + + + From 998e0929917329bce4666cf41c2719d3227601fc Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 15 Jul 2022 10:17:06 -0700 Subject: [PATCH 018/212] Per Alden recommendation, undoing renaming of the two Dsp src/model/ModelUtilities source files. Making appropriate changes in two other source files that use these modules. --- msvs/mf6core.vfproj | 4 ++-- src/Model/Connection/GweInterfaceModel.f90 | 10 +++++----- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 10 +++++----- .../{TspDspGridData.f90 => GweDspGridData.f90} | 12 ++++++------ .../{TspDspOptions.f90 => GweDspOptions.f90} | 8 ++++---- 5 files changed, 22 insertions(+), 22 deletions(-) rename src/Model/ModelUtilities/{TspDspGridData.f90 => GweDspGridData.f90} (91%) rename src/Model/ModelUtilities/{TspDspOptions.f90 => GweDspOptions.f90} (68%) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 219e9917232..e93c208cc2e 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -141,8 +141,8 @@ - - + + diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index a24c484e3a7..3523c6fe767 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -9,8 +9,8 @@ module GweInterfaceModelModule use TspAdvModule, only: adv_cr, TspAdvType use TspAdvOptionsModule, only: TspAdvOptionsType use GweDspModule, only: dsp_cr, GweDspType - use TspDspOptionsModule, only: TspDspOptionsType - use TspDspGridDataModule, only: TspDspGridDataType + use GweDspOptionsModule, only: GweDspOptionsType + use GweDspGridDataModule, only: GweDspGridDataType use TspObsModule, only: tsp_obs_cr use GridConnectionModule @@ -106,7 +106,7 @@ subroutine gweifmod_df(this) ! local class(*), pointer :: disPtr type(TspAdvOptionsType) :: adv_options - type(TspDspOptionsType) :: dsp_options + type(GweDspOptionsType) :: dsp_options integer(I4B) :: i this%moffset = 0 @@ -150,7 +150,7 @@ end subroutine gweifmod_df subroutine gweifmod_ar(this) class(GweInterfaceModelType) :: this !< the GWE interface model ! local - type(TspDspGridDataType) :: dspGridData + type(GweDspGridDataType) :: dspGridData call this%fmi%fmi_ar(this%ibound) if (this%inadv > 0) then @@ -171,7 +171,7 @@ end subroutine gweifmod_ar !< subroutine setDspGridData(this, gridData) class(GweInterfaceModelType) :: this !< the GWE interface model - type(TspDspGridDataType) :: gridData !< the dsp grid data to be set + type(GweDspGridDataType) :: gridData !< the dsp grid data to be set ! local integer(I4B) :: i, idx class(GweModelType), pointer :: gweModel diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index fdaae59ce31..4d351559e2d 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -6,8 +6,8 @@ module GweDspModule use BaseDisModule, only: DisBaseType use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr - use TspDspOptionsModule, only: TspDspOptionsType - use TspDspGridDataModule, only: TspDspGridDataType + use GweDspOptionsModule, only: GweDspOptionsType + use GweDspGridDataModule, only: GweDspGridDataType implicit none private @@ -115,7 +115,7 @@ subroutine dsp_df(this, dis, dspOptions) ! -- dummy class(GweDspType) :: this class(DisBaseType), pointer :: dis - type(TspDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not + type(GweDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not !! creating DSP from file ! -- local ! -- formats @@ -215,7 +215,7 @@ subroutine dsp_ar(this, ibound, porosity, cpw, rhow, grid_data) real(DP), dimension(:), pointer, contiguous :: porosity real(DP), dimension(:), pointer, contiguous :: cpw real(DP), dimension(:), pointer, contiguous :: rhow - type(TspDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, + type(GweDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, !! to create the package without input file ! -- local ! -- formats @@ -756,7 +756,7 @@ end subroutine read_data subroutine set_data(this, grid_data) use MemoryManagerModule, only: mem_reallocate class(GweDspType) :: this !< this DSP package - type(TspDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data + type(GweDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data ! local integer(I4B) :: i diff --git a/src/Model/ModelUtilities/TspDspGridData.f90 b/src/Model/ModelUtilities/GweDspGridData.f90 similarity index 91% rename from src/Model/ModelUtilities/TspDspGridData.f90 rename to src/Model/ModelUtilities/GweDspGridData.f90 index c54a0a8cb7e..a8ae4a5bcaf 100644 --- a/src/Model/ModelUtilities/TspDspGridData.f90 +++ b/src/Model/ModelUtilities/GweDspGridData.f90 @@ -1,11 +1,11 @@ -module TspDspGridDataModule +module GweDspGridDataModule use KindModule, only: DP, I4B implicit none private !> @brief data structure and helpers for passing dsp grid data !< into the package, as opposed to reading from file - type, public :: TspDspGridDataType + type, public :: GweDspGridDataType real(DP), dimension(:), pointer, contiguous :: diffc => null() !< molecular diffusion coefficient for each cell real(DP), dimension(:), pointer, contiguous :: alh => null() !< longitudinal horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: alv => null() !< longitudinal vertical dispersivity @@ -19,14 +19,14 @@ module TspDspGridDataModule contains procedure, pass(this) :: construct procedure, pass(this) :: destroy - end type TspDspGridDataType + end type GweDspGridDataType contains !> @brief allocate data structure !< subroutine construct(this, nodes) - class(TspDspGridDataType) :: this + class(GweDspGridDataType) :: this integer(I4B) :: nodes allocate (this%diffc(nodes)) @@ -45,7 +45,7 @@ end subroutine construct !> @brief clean up !< subroutine destroy(this) - class(TspDspGridDataType) :: this + class(GweDspGridDataType) :: this deallocate (this%diffc) deallocate (this%alh) @@ -60,4 +60,4 @@ subroutine destroy(this) end subroutine destroy -end module TspDspGridDataModule +end module GweDspGridDataModule diff --git a/src/Model/ModelUtilities/TspDspOptions.f90 b/src/Model/ModelUtilities/GweDspOptions.f90 similarity index 68% rename from src/Model/ModelUtilities/TspDspOptions.f90 rename to src/Model/ModelUtilities/GweDspOptions.f90 index 03a267556d3..85e8d52cbc9 100644 --- a/src/Model/ModelUtilities/TspDspOptions.f90 +++ b/src/Model/ModelUtilities/GweDspOptions.f90 @@ -1,12 +1,12 @@ -module TspDspOptionsModule +module GweDspOptionsModule use KindModule, only: I4B implicit none private !> @brief data structure (and helpers) for passing dsp option data !< into the package, as opposed to reading it from file - type, public :: TspDspOptionsType + type, public :: GweDspOptionsType integer(I4B) :: ixt3d !< flag indicating xt3d is active: 1 = enabled, 2 = rhs - end type TspDspOptionsType + end type GweDspOptionsType -end module TspDspOptionsModule +end module GweDspOptionsModule From 778f7aeabbe3d6bbc049c37c6d42cf21de30d32c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 15 Jul 2022 11:31:57 -0700 Subject: [PATCH 019/212] Some clean-up after merge. Hopefully I can do more simple 'update merges' hereafter (anytime an official commit is made on the develop branch) --- msvs/mf6core.vfproj | 5 +++-- src/Model/Connection/GwtInterfaceModel.f90 | 10 +++++----- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 10 +++++----- src/Model/ModelUtilities/GwtDspOptions.f90 | 12 ++++++++++++ 4 files changed, 25 insertions(+), 12 deletions(-) create mode 100644 src/Model/ModelUtilities/GwtDspOptions.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index e93c208cc2e..7ceecf91fd0 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -130,19 +130,20 @@ + + + - - diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index e23f6117273..faf787b7552 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -9,8 +9,8 @@ module GwtInterfaceModelModule use TspAdvModule, only: adv_cr, TspAdvType use TspAdvOptionsModule, only: TspAdvOptionsType use GwtDspModule, only: dsp_cr, GwtDspType - use TspDspOptionsModule, only: TspDspOptionsType - use TspDspGridDataModule, only: TspDspGridDataType + use GwtDspOptionsModule, only: GwtDspOptionsType + use GwtDspGridDataModule, only: GwtDspGridDataType use TspObsModule, only: tsp_obs_cr use GridConnectionModule @@ -106,7 +106,7 @@ subroutine gwtifmod_df(this) ! local class(*), pointer :: disPtr type(TspAdvOptionsType) :: adv_options - type(TspDspOptionsType) :: dsp_options + type(GwtDspOptionsType) :: dsp_options integer(I4B) :: i this%moffset = 0 @@ -150,7 +150,7 @@ end subroutine gwtifmod_df subroutine gwtifmod_ar(this) class(GwtInterfaceModelType) :: this !< the GWT interface model ! local - type(TspDspGridDataType) :: dspGridData + type(GwtDspGridDataType) :: dspGridData call this%fmi%fmi_ar(this%ibound) if (this%inadv > 0) then @@ -170,7 +170,7 @@ end subroutine gwtifmod_ar !< subroutine setDspGridData(this, gridData) class(GwtInterfaceModelType) :: this !< the GWT interface model - type(TspDspGridDataType) :: gridData !< the dsp grid data to be set + type(GwtDspGridDataType) :: gridData !< the dsp grid data to be set ! local integer(I4B) :: i, idx class(GwtModelType), pointer :: gwtModel diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index 1eaeaf96b37..791fc0d0559 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -6,8 +6,8 @@ module GwtDspModule use BaseDisModule, only: DisBaseType use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr - use TspDspOptionsModule, only: TspDspOptionsType - use TspDspGridDataModule, only: TspDspGridDataType + use GwtDspOptionsModule, only: GwtDspOptionsType + use GwtDspGridDataModule, only: GwtDspGridDataType implicit none private @@ -108,7 +108,7 @@ subroutine dsp_df(this, dis, dspOptions) ! -- dummy class(GwtDspType) :: this class(DisBaseType), pointer :: dis - type(TspDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not + type(GwtDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not !! creating DSP from file ! -- local ! -- formats @@ -206,7 +206,7 @@ subroutine dsp_ar(this, ibound, porosity, grid_data) class(GwtDspType) :: this integer(I4B), dimension(:), pointer, contiguous :: ibound real(DP), dimension(:), pointer, contiguous :: porosity - type(TspDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, + type(GwtDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, !! to create the package without input file ! -- local ! -- formats @@ -715,7 +715,7 @@ end subroutine read_data subroutine set_data(this, grid_data) use MemoryManagerModule, only: mem_reallocate class(GwtDspType) :: this !< this DSP package - type(TspDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data + type(GwtDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data ! local integer(I4B) :: i diff --git a/src/Model/ModelUtilities/GwtDspOptions.f90 b/src/Model/ModelUtilities/GwtDspOptions.f90 new file mode 100644 index 00000000000..e4c25450244 --- /dev/null +++ b/src/Model/ModelUtilities/GwtDspOptions.f90 @@ -0,0 +1,12 @@ +module GwtDspOptionsModule + use KindModule, only: I4B + implicit none + private + + !> @brief data structure (and helpers) for passing dsp option data + !< into the package, as opposed to reading it from file + type, public :: GwtDspOptionsType + integer(I4B) :: ixt3d !< flag indicating xt3d is active: 1 = enabled, 2 = rhs + end type GwtDspOptionsType + +end module GwtDspOptionsModule From e75f3bb82ec7460a001eaa1fa8ea9e03f4c37603 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 15 Jul 2022 18:11:38 -0700 Subject: [PATCH 020/212] More work on the TspLabels module --- msvs/mf6core.vfproj | 2 +- src/Model/BaseModel.f90 | 2 +- .../GroundWaterEnergy/{gwe.f90 => gwe1.f90} | 8 +-- src/Model/GroundWaterTransport/gwt1.f90 | 10 ++-- src/Model/ModelUtilities/TspLabels.f90 | 50 +++++++------------ 5 files changed, 30 insertions(+), 42 deletions(-) rename src/Model/GroundWaterEnergy/{gwe.f90 => gwe1.f90} (99%) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 7ceecf91fd0..fd25b77f44e 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -74,7 +74,7 @@ - + diff --git a/src/Model/BaseModel.f90 b/src/Model/BaseModel.f90 index b1c87e68607..8974ef023f1 100644 --- a/src/Model/BaseModel.f90 +++ b/src/Model/BaseModel.f90 @@ -15,7 +15,7 @@ module BaseModelModule character(len=LENMEMPATH) :: memoryPath !< the location in the memory manager where the variables are stored character(len=LENMODELNAME), pointer :: name => null() !< name of the model - character(len=3), pointer :: macronym => null() !< 3 letter model acronym (GWF, GWT, ...) + character(len=3), pointer :: macronym => null() !< 3 letter model acronym (GWF, GWT, GWE, ...) integer(I4B), pointer :: idsoln => null() !< id of the solution model is in integer(I4B), pointer :: id => null() !< model id integer(I4B), pointer :: iout => null() !< output unit number diff --git a/src/Model/GroundWaterEnergy/gwe.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 similarity index 99% rename from src/Model/GroundWaterEnergy/gwe.f90 rename to src/Model/GroundWaterEnergy/gwe1.f90 index df74ccef078..a96444f2b4b 100644 --- a/src/Model/GroundWaterEnergy/gwe.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -31,7 +31,7 @@ module GweModule type, extends(TransportModelType) :: GweModelType - type(TspLabelsType), pointer :: tsplabel => null() + type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels type(TspIcType), pointer :: ic => null() ! initial conditions package type(TspFmiType), pointer :: fmi => null() ! flow model interface type(TspAdvType), pointer :: adv => null() ! advection package @@ -42,7 +42,6 @@ module GweModule type(GweMstType), pointer :: mst => null() ! mass storage and transfer package type(GweDspType), pointer :: dsp => null() ! dispersion package type(BudgetType), pointer :: budget => null() ! budget object - type(TspLabelsType), pointer :: tsplab => null() integer(I4B), pointer :: inic => null() ! unit number IC integer(I4B), pointer :: infmi => null() ! unit number FMI integer(I4B), pointer :: inmvt => null() ! unit number MVT @@ -121,7 +120,7 @@ subroutine gwe_cr(filename, id, modelname) use GweMstModule, only: mst_cr use GweDspModule, only: dsp_cr use BudgetModule, only: budget_cr - use TspLabelsModule, only: tsplabels_cr + use TspLabelsModule, only: tsplabels_cr, setTspLabels ! -- dummy character(len=*), intent(in) :: filename @@ -239,6 +238,9 @@ subroutine gwe_cr(filename, id, modelname) ! -- Create utility objects call budget_cr(this%budget, this%name) ! + ! -- Set labels to be used with transport model + call this%tsplab%setTspLabels(this%macronym, 'TEMPERATURE', 'ENERGY', 'E') + ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) call fmi_cr(this%fmi, this%name, this%infmi, this%iout) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index b8ec6d1d306..57a3c23bc6d 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -36,7 +36,7 @@ module GwtModule type, extends(TransportModelType) :: GwtModelType - type(TspLabelsType), pointer :: tsplabel => null() ! object defining the appropriate labels + type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels type(TspIcType), pointer :: ic => null() ! initial conditions package type(TspFmiType), pointer :: fmi => null() ! flow model interface type(TspAdvType), pointer :: adv => null() ! advection package @@ -126,7 +126,7 @@ subroutine gwt_cr(filename, id, modelname) use GwtMstModule, only: mst_cr use GwtDspModule, only: dsp_cr use BudgetModule, only: budget_cr - use TspLabelsModule, only: tsplabels_cr + use TspLabelsModule, only: tsplabels_cr, setTspLabels use NameFileModule, only: NameFileType ! -- dummy character(len=*), intent(in) :: filename @@ -229,9 +229,6 @@ subroutine gwt_cr(filename, id, modelname) ! -- Check to make sure that required ftype's have been specified call this%ftype_check(namefile_obj, indis) ! - ! -- Prior to instantiating packages, assign appropriate labels (GWT or GWE) - !call tsplabels_cr(this%tsplabel - ! ! -- Create discretization object if (indis6 > 0) then call dis_cr(this%dis, this%name, indis, this%iout) @@ -244,6 +241,9 @@ subroutine gwt_cr(filename, id, modelname) ! -- Create utility objects call budget_cr(this%budget, this%name) ! + ! -- Set labels to be used with transport model + call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') + ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) call fmi_cr(this%fmi, this%name, this%infmi, this%iout) diff --git a/src/Model/ModelUtilities/TspLabels.f90 b/src/Model/ModelUtilities/TspLabels.f90 index b96f1ec2de4..b39b01da450 100644 --- a/src/Model/ModelUtilities/TspLabels.f90 +++ b/src/Model/ModelUtilities/TspLabels.f90 @@ -10,7 +10,7 @@ !! !! GWT | GWE | src files w/label !! -----------------|-------------------|-------------- -!! "Concentration" |"Temperature" | gwt1.f90 +!! "Concentration" |"Temperature" | gwt1.f90/gwe1.f90 !! | | gwt1apt1.f90 !! | | gwt1cnc1.f90 !! | | gwt1ist1.f90 @@ -23,9 +23,8 @@ !! | | gwt1fmi1.f90 !! | | tsp1ic1.f90 !! | | GwtSpc.f90 -!! "Concentration" |"Temperature" | Gwe.f90 !! "Cumulative Mass"|"Cumulative Energy"| Budget.f90 (_ot routine) -!! "MASS", "M" |"?", "?" | gwt1.f90 (gwt_df routine & _ot routine) +!! "MASS", "M" |"ENERGY", "E" | gwt1.f90 (gwt_df routine & _ot routine) !! "M/T" |"Watts" (?) | !! "M" |"Joules" or "E" | !< @@ -38,6 +37,7 @@ module TspLabelsModule private public :: TspLabelsType public :: tsplabels_cr + public :: setTspLabels !> @brief Define labels for use with generalized transport model !! @@ -47,14 +47,16 @@ module TspLabelsModule !! !< type TspLabelsType + character(len=LENVARNAME), pointer :: modname => null() !< name of the model that module is associated with character(len=LENVARNAME), pointer :: tsptype => null() !< "solute" or "heat" character(len=LENVARNAME), pointer :: depvartype => null() !< "concentration" or "temperature" - character(len=LENVARNAME), pointer :: depvarunit => null() !< "mass" or "joules" - character(len=LENVARNAME), pointer :: depvarunitabbrev => null() !< "M/T" or "watts" (or "kilowatts") + character(len=LENVARNAME), pointer :: depvarunit => null() !< "mass" or "energy" + character(len=LENVARNAME), pointer :: depvarunitabbrev => null() !< "M" or "J" contains - procedure :: tsplabels_df + !-- public + procedure, public :: setTspLabels ! -- private procedure :: allocate_label_names @@ -91,44 +93,28 @@ end subroutine tsplabels_cr !! Set variable names according to type of transport model !! !< - subroutine tsplabels_df(this, tsptype, depvartype, depvarunit, depvarunitabbrev) + subroutine setTspLabels(this, tsptype, depvartype, depvarunit, depvarunitabbrev) class(TspLabelsType) :: this - character(len=*), optional :: tsptype !< type of model, default is GWT6 - character(len=*), optional :: depvartype !< dependent variable type, default is "CONCENTRATION" - character(len=*), optional :: depvarunit !< units of dependent variable for writing to list file - character(len=*), optional :: depvarunitabbrev !< abbreviation of associated units + character(len=*), intent(in) :: tsptype !< type of model, default is GWT6 + character(len=*), intent(in) :: depvartype !< dependent variable type, default is "CONCENTRATION" + character(len=*), intent(in) :: depvarunit !< units of dependent variable for writing to list file + character(len=*), intent(in) :: depvarunitabbrev !< abbreviation of associated units ! ! -- Set the model type - if (present(tsptype)) then - this%tsptype = tsptype - else - this%tsptype = 'GWT6' - end if + this%tsptype = tsptype ! ! -- Set the type of dependent variable being solved for - if (present(tsptype)) then - this%depvartype = depvartype - else - this%depvartype = 'CONCENTRATION' - end if + this%depvartype = depvartype ! ! -- Set the units associated with the dependent variable - if (present(depvarunit)) then - this%depvarunit = depvarunit - else - this%depvarunit = 'MASS' - end if + this%depvarunit = depvarunit ! ! -- Set the units abbreviation - if (present(depvarunitabbrev)) then - this%depvarunitabbrev = depvarunitabbrev - else - this%depvarunitabbrev = 'M/T' - end if + this%depvarunitabbrev = depvarunitabbrev ! ! -- Return return - end subroutine tsplabels_df + end subroutine setTspLabels !> @brief Define the information this object holds !! From f634805776a7ac85c38312f5184043d7dac607c1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 18 Jul 2022 10:27:48 -0700 Subject: [PATCH 021/212] Installing the tspLabels deallocate calls --- src/Model/GroundWaterEnergy/gwe1.f90 | 2 ++ src/Model/GroundWaterTransport/gwt1.f90 | 1 + src/Model/ModelUtilities/TspLabels.f90 | 1 + 3 files changed, 4 insertions(+) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index a96444f2b4b..bac6be191d7 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -972,6 +972,7 @@ subroutine gwe_da(this) call this%budget%budget_da() call this%oc%oc_da() call this%obs%obs_da() + call this%tsplab%tsplabels_da() ! ! -- Internal package objects deallocate (this%dis) @@ -985,6 +986,7 @@ subroutine gwe_da(this) deallocate (this%budget) deallocate (this%oc) deallocate (this%obs) + deallocate (this%tsplab) ! ! -- Boundary packages do ip = 1, this%bndlist%Count() diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 57a3c23bc6d..cab1f0777db 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -991,6 +991,7 @@ subroutine gwt_da(this) call this%budget%budget_da() call this%oc%oc_da() call this%obs%obs_da() + call this%tsplab%tsplabels_da() ! ! -- Internal package objects deallocate (this%dis) diff --git a/src/Model/ModelUtilities/TspLabels.f90 b/src/Model/ModelUtilities/TspLabels.f90 index b39b01da450..36919c7a429 100644 --- a/src/Model/ModelUtilities/TspLabels.f90 +++ b/src/Model/ModelUtilities/TspLabels.f90 @@ -57,6 +57,7 @@ module TspLabelsModule contains !-- public procedure, public :: setTspLabels + procedure, public :: tsplabels_da ! -- private procedure :: allocate_label_names From 278a12b3cfb6be96cb33f0ef63c374e415f65787 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 20 Jul 2022 07:43:52 -0700 Subject: [PATCH 022/212] More development on GWE primarily related to getting all hard-coded instances of 'concentration' out of TSP. --- msvs/mf6core.vfproj | 1 + src/Model/GroundWaterEnergy/gwe1.f90 | 79 ++++++++++++-------- src/Model/GroundWaterTransport/gwt1.f90 | 29 ++++--- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 26 +++++-- src/Model/GroundWaterTransport/tsp1oc1.f90 | 10 ++- src/Model/ModelUtilities/BoundaryPackage.f90 | 4 + src/Utilities/InputOutput.f90 | 2 +- 7 files changed, 98 insertions(+), 53 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index fd25b77f44e..779c9a815a2 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -138,6 +138,7 @@ + diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index bac6be191d7..aa73c6f779e 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -104,7 +104,7 @@ subroutine gwe_cr(filename, id, modelname) use ListsModule, only: basemodellist use BaseModelModule, only: AddBaseModelToList use SimModule, only: store_error, count_errors - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use MemoryHelperModule, only: create_mem_path use NameFileModule, only: NameFileType use GwfDisModule, only: dis_cr @@ -120,7 +120,7 @@ subroutine gwe_cr(filename, id, modelname) use GweMstModule, only: mst_cr use GweDspModule, only: dsp_cr use BudgetModule, only: budget_cr - use TspLabelsModule, only: tsplabels_cr, setTspLabels + use TspLabelsModule, only: tsplabels_cr ! -- dummy character(len=*), intent(in) :: filename @@ -128,9 +128,10 @@ subroutine gwe_cr(filename, id, modelname) character(len=*), intent(in) :: modelname ! -- local integer(I4B) :: indis, indis6, indisu6, indisv6 - integer(I4B) :: i + integer(I4B) :: ipakid, i, j, iu, ipaknum integer(I4B) :: nwords character(len=LINELENGTH) :: errmsg + character(len=LENPACKAGENAME) :: pakname character(len=LINELENGTH), allocatable, dimension(:) :: words type(NameFileType) :: namefile_obj type(GweModelType), pointer :: this @@ -238,9 +239,6 @@ subroutine gwe_cr(filename, id, modelname) ! -- Create utility objects call budget_cr(this%budget, this%name) ! - ! -- Set labels to be used with transport model - call this%tsplab%setTspLabels(this%macronym, 'TEMPERATURE', 'ENERGY', 'E') - ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) call fmi_cr(this%fmi, this%name, this%infmi, this%iout) @@ -252,6 +250,20 @@ subroutine gwe_cr(filename, id, modelname) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! + ! -- Create stress packages + ipakid = 1 + do i = 1, niunit + ipaknum = 1 + do j = 1, namefile_obj%get_nval_for_row(i) + iu = namefile_obj%get_unitnumber_rowcol(i, j) + call namefile_obj%get_pakname(i, j, pakname) + call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu, & + this%iout) + ipaknum = ipaknum + 1 + ipakid = ipakid + 1 + end do + end do + ! ! -- return return end subroutine gwe_cr @@ -266,12 +278,16 @@ subroutine gwe_df(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use TspLabelsModule, only: setTspLabels ! -- dummy class(GweModelType) :: this ! -- local integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Set labels to be used with transport model + call this%tsplab%setTspLabels(this%macronym, 'TEMPERATURE', 'ENERGY', 'E') ! ! -- Define packages and utility objects call this%dis%dis_df() @@ -405,7 +421,7 @@ subroutine gwe_ar(this) !call this%dis%dis_ar(this%npf%icelltype) ! ! -- set up output control - call this%oc%oc_ar(this%x, this%dis, DHNOFLO) + call this%oc%oc_ar(this%x, this%dis, DHNOFLO, this%tsplab%depvartype) call this%budget%set_ibudcsv(this%oc%ibudcsv) ! ! -- Package input files now open, so allocate and read @@ -753,8 +769,8 @@ subroutine gwe_ot(this) idvprint = 0 icbcfl = 0 ibudfl = 0 - if (this%oc%oc_save('CONCENTRATION')) idvsave = 1 - if (this%oc%oc_print('CONCENTRATION')) idvprint = 1 + if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 + if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 if (this%oc%oc_save('BUDGET')) icbcfl = 1 if (this%oc%oc_print('BUDGET')) ibudfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') @@ -762,7 +778,7 @@ subroutine gwe_ot(this) ! -- Override ibudfl and idvprint flags for nonconvergence ! and end of period ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag('CONCENTRATION', this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) ! ! Calculate and save observations call this%gwe_ot_obs() @@ -1141,26 +1157,29 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- This part creates the package object select case (filtyp) case ('CNC6') - call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - !case('SRC6') - ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) - !case('LKT6') - ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('SFT6') - ! call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('MWT6') - ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('UZT6') - ! call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('IST6') - ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi, this%mst) - !case('API6') - ! call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab) + !case('SRC6') + ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname) + !case('LKT6') + ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('SFT6') + ! call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('MWT6') + ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('UZT6') + ! call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('IST6') + ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi, this%mst) + !case('API6') + ! call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname) case default write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index cab1f0777db..8486bcaf544 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -126,7 +126,7 @@ subroutine gwt_cr(filename, id, modelname) use GwtMstModule, only: mst_cr use GwtDspModule, only: dsp_cr use BudgetModule, only: budget_cr - use TspLabelsModule, only: tsplabels_cr, setTspLabels + use TspLabelsModule, only: tsplabels_cr use NameFileModule, only: NameFileType ! -- dummy character(len=*), intent(in) :: filename @@ -161,6 +161,9 @@ subroutine gwt_cr(filename, id, modelname) this%macronym = 'GWT' this%id = id ! + ! -- Instantiate generalized labels for later assignment + call tsplabels_cr(this%tsplab, this%name) + ! ! -- Open namefile and set iout call namefile_obj%init(this%filename, 0) call namefile_obj%add_cunit(niunit, cunit) @@ -241,9 +244,6 @@ subroutine gwt_cr(filename, id, modelname) ! -- Create utility objects call budget_cr(this%budget, this%name) ! - ! -- Set labels to be used with transport model - call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') - ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) call fmi_cr(this%fmi, this%name, this%infmi, this%iout) @@ -283,12 +283,16 @@ subroutine gwt_df(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use TspLabelsModule, only: setTspLabels ! -- dummy class(GwtModelType) :: this ! -- local integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Set labels to be used with transport model + call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') ! ! -- Define packages and utility objects call this%dis%dis_df() @@ -420,7 +424,7 @@ subroutine gwt_ar(this) !call this%dis%dis_ar(this%npf%icelltype) ! ! -- set up output control - call this%oc%oc_ar(this%x, this%dis, DHNOFLO) + call this%oc%oc_ar(this%x, this%dis, DHNOFLO, this%tsplab%depvartype) call this%budget%set_ibudcsv(this%oc%ibudcsv) ! ! -- Package input files now open, so allocate and read @@ -770,8 +774,8 @@ subroutine gwt_ot(this) idvprint = 0 icbcfl = 0 ibudfl = 0 - if (this%oc%oc_save('CONCENTRATION')) idvsave = 1 - if (this%oc%oc_print('CONCENTRATION')) idvprint = 1 + if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 + if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 if (this%oc%oc_save('BUDGET')) icbcfl = 1 if (this%oc%oc_print('BUDGET')) ibudfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') @@ -779,7 +783,7 @@ subroutine gwt_ot(this) ! -- Override ibudfl and idvprint flags for nonconvergence ! and end of period ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag('CONCENTRATION', this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) ! ! Calculate and save observations call this%gwt_ot_obs() @@ -1160,9 +1164,11 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- This part creates the package object select case (filtyp) case ('CNC6') - call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab) case ('SRC6') - call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname) case ('LKT6') call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) @@ -1179,7 +1185,8 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%mst) case ('API6') - call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname) case default write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 601acb93243..221a3dc7f73 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -2,9 +2,10 @@ module TspCncModule ! use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, DONE, NAMEDBOUNDFLAG, LENFTYPE, & - LENPACKAGENAME + LENPACKAGENAME, LENVARNAME use ObsModule, only: DefaultObsIdProcessor use BndModule, only: BndType + use TspLabelsModule, only: TspLabelsType use ObserveModule, only: ObserveType use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList @@ -39,7 +40,8 @@ module TspCncModule contains - subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) + subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + tsplab) ! ****************************************************************************** ! cnc_create -- Create a New Constant Concentration Package ! Subroutine: (1) create new-style package @@ -56,6 +58,7 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname + type(TspLabelsType), pointer :: tsplab ! -- local type(TspCncType), pointer :: cncobj ! ------------------------------------------------------------------------------ @@ -82,6 +85,10 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%ncolbnd = 1 packobj%iscloc = 1 ! + ! -- Store pointer to labels associated with the current model so that the + ! package has access to the assigned labels + packobj%tsplab => tsplab + ! ! -- return return end subroutine cnc_create @@ -127,10 +134,12 @@ subroutine cnc_rp(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ use SimModule, only: store_error + use InputOutputModule, only: lowcase implicit none class(TspCncType), intent(inout) :: this integer(I4B) :: i, node, ibd, ierr character(len=30) :: nodestr + character(len=LENVARNAME) :: dvtype ! ------------------------------------------------------------------------------ ! ! -- Reset previous CNCs to active cell @@ -142,15 +151,17 @@ subroutine cnc_rp(this) ! -- Call the parent class read and prepare call this%BndType%bnd_rp() ! - ! -- Set ibound to -(ibcnum + 1) for constant concentration cells + ! -- Set ibound to -(ibcnum + 1) for constant concentration/temperature cells ierr = 0 do i = 1, this%nbound node = this%nodelist(i) ibd = this%ibound(node) if (ibd < 0) then call this%dis%noder_to_string(node, nodestr) - call store_error('Error. Cell is already a constant concentration: ' & - //trim(adjustl(nodestr))) + dvtype = trim(this%tsplab%depvartype) + call lowcase(dvtype) + call store_error('Error. Cell is already a constant ' & + // dvtype // ': ' //trim(adjustl(nodestr))) ierr = ierr + 1 else this%ibound(node) = -this%ibcnum @@ -399,7 +410,8 @@ subroutine define_listlabel(this) else write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' end if - write (this%listlabel, '(a, a16)') trim(this%listlabel), 'CONCENTRATION' + write (this%listlabel, '(a, a16)') trim(this%listlabel), & + trim(this%tsplab%depvartype) if (this%inamedbound == 1) then write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' end if @@ -476,7 +488,7 @@ subroutine cnc_rp_ts(this) if (associated(tslink)) then select case (tslink%JCol) case (1) - tslink%Text = 'CONCENTRATION' + tslink%Text = trim(this%tsplab%depvartype) end select end if end do diff --git a/src/Model/GroundWaterTransport/tsp1oc1.f90 b/src/Model/GroundWaterTransport/tsp1oc1.f90 index 53b24880f0e..e548b2ae77d 100644 --- a/src/Model/GroundWaterTransport/tsp1oc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1oc1.f90 @@ -54,13 +54,15 @@ end subroutine oc_cr !> @ brief Allocate and read TspOcType !! - !! Setup concentration and budget as output control variables. + !! Setup dependent variable (e.g., concentration or temperature) + !! and budget as output control variables. !! !< - subroutine oc_ar(this, conc, dis, dnodata) + subroutine oc_ar(this, depvar, dis, dnodata, dvname) ! -- dummy class(TspOcType) :: this !< TspOcType object - real(DP), dimension(:), pointer, contiguous, intent(in) :: conc !< model concentration + real(DP), dimension(:), pointer, contiguous, intent(in) :: depvar !< model concentration + character(len=*), intent(in) :: dvname !< name of dependent variable solved by generalized transport model (concentration, temperature) class(DisBaseType), pointer, intent(in) :: dis !< model discretization package real(DP), intent(in) :: dnodata !< no data value ! -- local @@ -80,7 +82,7 @@ subroutine oc_ar(this, conc, dis, dnodata) 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & this%iout, dnodata) case (2) - call ocdobjptr%init_dbl('CONCENTRATION', conc, dis, 'PRINT LAST ', & + call ocdobjptr%init_dbl(trim(dvname), depvar, dis, 'PRINT LAST ', & 'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', & this%iout, dnodata) end select diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 27f83471224..19506d46b25 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -30,6 +30,7 @@ module BndModule use BaseDisModule, only: DisBaseType use BlockParserModule, only: BlockParserType use TableModule, only: TableType, table_cr + use TspLabelsModule, only: TspLabelsType implicit none @@ -101,6 +102,9 @@ module BndModule type(TableType), pointer :: inputtab => null() !< input table object type(TableType), pointer :: outputtab => null() !< output table object for package flows writtent to the model listing file type(TableType), pointer :: errortab => null() !< package error table + ! + ! -- labels + type(TspLabelsType), pointer :: tsplab => null() contains procedure :: bnd_df diff --git a/src/Utilities/InputOutput.f90 b/src/Utilities/InputOutput.f90 index df94a16aac7..a1504e57249 100644 --- a/src/Utilities/InputOutput.f90 +++ b/src/Utilities/InputOutput.f90 @@ -580,7 +580,7 @@ end subroutine upcase subroutine lowcase(word) implicit none ! -- dummy variables - character(len=*) :: word !< + character(len=*), intent(inout) :: word !< word to convert to lower case ! -- local variables integer(I4B) :: idiff, k, l ! From 8a15927fc48a99df630822398fa879c16e88fe90 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 20 Jul 2022 13:15:57 -0700 Subject: [PATCH 023/212] Updating some comments in cnc --- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 221a3dc7f73..d0bea6f5ad3 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -43,7 +43,7 @@ module TspCncModule subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & tsplab) ! ****************************************************************************** -! cnc_create -- Create a New Constant Concentration Package +! cnc_create -- Create a New Constant Concentration/Temperature Package ! Subroutine: (1) create new-style package ! (2) point packobj to the new package ! ****************************************************************************** @@ -196,7 +196,7 @@ subroutine cnc_ad(this) ! -- Advance the time series call this%TsManager%ad() ! - ! -- Process each entry in the constant concentration cell list + ! -- Process each entry in the constant concentration/temperature cell list do i = 1, this%nbound node = this%nodelist(i) cb = this%bound(1, i) @@ -467,10 +467,9 @@ end subroutine cnc_df_obs subroutine cnc_rp_ts(this) ! ****************************************************************************** -! -- Assign tsLink%Text appropriately for -! all time series in use by package. -! In CNC package variable CONCENTRATION -! can be controlled by time series. +! -- Assign tsLink%Text appropriately for all time series in use by package. +! In CNC package variable CONCENTRATION or TEMPERATURE can be controlled +! by time series. ! ****************************************************************************** ! ! SPECIFICATIONS: From a838b8f465c5a1c9cbde6fbccd52a214572c51ae Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 25 Jul 2022 05:52:59 -0700 Subject: [PATCH 024/212] More work with TspLabels module --- src/Model/GroundWaterEnergy/gwe1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1src1.f90 | 9 ++++++++- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 1 + 4 files changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index aa73c6f779e..a7aaa77df89 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1156,7 +1156,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! ! -- This part creates the package object select case (filtyp) - case ('CNC6') + case ('TMP6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab) !case('SRC6') diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 8486bcaf544..6765e5d1f2e 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -1168,7 +1168,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & pakname, this%tsplab) case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname) + pakname, this%tsplab) 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 137a931dd15..4a60a547928 100644 --- a/src/Model/GroundWaterTransport/gwt1src1.f90 +++ b/src/Model/GroundWaterTransport/gwt1src1.f90 @@ -3,6 +3,7 @@ module GwtSrcModule use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE use BndModule, only: BndType + use TspLabelsModule, only: TspLabelsType use ObsModule, only: DefaultObsIdProcessor use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList @@ -32,7 +33,8 @@ module GwtSrcModule contains - subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) + subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + tsplab) ! ****************************************************************************** ! src_create -- Create a New Src Package ! Subroutine: (1) create new-style package @@ -49,6 +51,7 @@ 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 + type(TspLabelsType), pointer :: tsplab ! -- local type(GwtSrcType), pointer :: srcobj ! ------------------------------------------------------------------------------ @@ -74,6 +77,10 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%ncolbnd = 1 packobj%iscloc = 1 ! + ! -- Store pointer to labels associated with the current model so that the + ! package has access to the assigned labels + packobj%tsplab => tsplab + ! ! -- return return end subroutine src_create diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 15d28dfd32e..464fbfcb2b7 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -16,6 +16,7 @@ module TspSsmModule use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType use TspFmiModule, only: TspFmiType + use TspLabelsModule, only: TspLabelsType use TableModule, only: TableType, table_cr use GwtSpcModule, only: GwtSpcType From 71b79d62b8736975c88851d79b0072e66ed737a2 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 27 Jul 2022 11:25:34 -0700 Subject: [PATCH 025/212] Some minor clean-up in SSM --- src/Model/GroundWaterEnergy/gwe1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 14 ++++++++++---- src/Model/ModelUtilities/BoundaryPackage.f90 | 4 ---- src/Model/NumericalPackage.f90 | 4 ++++ 5 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index a7aaa77df89..507de256f44 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -245,7 +245,7 @@ subroutine gwe_cr(filename, id, modelname) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 6765e5d1f2e..f8de5eb11d3 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -250,7 +250,7 @@ subroutine gwt_cr(filename, id, modelname) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 464fbfcb2b7..84f42b9c901 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -78,13 +78,14 @@ module TspSsmModule !! and initializing the parser. !! !< - subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) + subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab) ! -- dummy type(TspSsmType), pointer :: ssmobj !< TspSsmType object character(len=*), intent(in) :: name_model !< name of the model integer(I4B), intent(in) :: inunit !< fortran unit for input integer(I4B), intent(in) :: iout !< fortran unit for output - type(TspFmiType), intent(in), target :: fmi !< GWT FMI package + type(TspFmiType), intent(in), target :: fmi !< Transport FMI package + type(TspLabelsType), intent(in), pointer :: tsplab !< TspLabelsType object ! ! -- Create the object allocate (ssmobj) @@ -103,6 +104,10 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) ! -- Initialize block parser call ssmobj%parser%Initialize(ssmobj%inunit, ssmobj%iout) ! + ! -- Store pointer to labels associated with the current model so that the + ! package has access to the assigned labels + ssmobj%tsplab => tsplab + ! ! -- Return return end subroutine ssm_cr @@ -1143,8 +1148,9 @@ subroutine set_ssmivec(this, ip, packname) call ssmiptr%initialize(this%dis, ip, inunit, this%iout, this%name_model, & trim(packname)) - write (this%iout, '(4x, a, a, a, a)') 'USING SPC INPUT FILE ', & - trim(filename), ' TO SET CONCENTRATIONS FOR PACKAGE ', trim(packname) + write (this%iout, '(4x, a, a, a, a, a)') 'USING SPC INPUT FILE ', & + trim(filename), ' TO SET ',trim(this%tsplab%depvartype),'S FOR PACKAGE ', & + trim(packname) ! ! -- return return diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 19506d46b25..27f83471224 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -30,7 +30,6 @@ module BndModule use BaseDisModule, only: DisBaseType use BlockParserModule, only: BlockParserType use TableModule, only: TableType, table_cr - use TspLabelsModule, only: TspLabelsType implicit none @@ -102,9 +101,6 @@ module BndModule type(TableType), pointer :: inputtab => null() !< input table object type(TableType), pointer :: outputtab => null() !< output table object for package flows writtent to the model listing file type(TableType), pointer :: errortab => null() !< package error table - ! - ! -- labels - type(TspLabelsType), pointer :: tsplab => null() contains procedure :: bnd_df diff --git a/src/Model/NumericalPackage.f90 b/src/Model/NumericalPackage.f90 index 76772d7b052..adef871e5a1 100644 --- a/src/Model/NumericalPackage.f90 +++ b/src/Model/NumericalPackage.f90 @@ -15,6 +15,7 @@ module NumericalPackageModule use BlockParserModule, only: BlockParserType use BaseDisModule, only: DisBaseType use MemoryHelperModule, only: create_mem_path + use TspLabelsModule, only: TspLabelsType implicit none private @@ -45,6 +46,9 @@ module NumericalPackageModule ! -- derived types type(BlockParserType) :: parser !< parser object for reading blocks of information class(DisBaseType), pointer :: dis => null() !< model discretization object + ! + ! -- labels + type(TspLabelsType), pointer :: tsplab => null() contains procedure :: set_names From 1eeb0023968ead123fad3d93bee600b4e135a8c6 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Thu, 28 Jul 2022 08:11:11 -0400 Subject: [PATCH 026/212] Drafted new modules GwfVscModule and GwfVscInputDataModule --- msvs/mf6core.vfproj | 2 + src/Model/GroundWaterFlow/gwf3vsc8.f90 | 796 +++++++++++++++++++ src/Model/ModelUtilities/GwfVscInputData.f90 | 55 ++ 3 files changed, 853 insertions(+) create mode 100644 src/Model/GroundWaterFlow/gwf3vsc8.f90 create mode 100644 src/Model/ModelUtilities/GwfVscInputData.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 779c9a815a2..02bcb6c6260 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -105,6 +105,7 @@ + @@ -137,6 +138,7 @@ + diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 new file mode 100644 index 00000000000..54ecaecf51d --- /dev/null +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -0,0 +1,796 @@ +! Viscosity Package for representing variable-viscosity groundwater flow + +module GwfVscModule + + use KindModule, only: DP, I4B + use SimModule, only: store_error, count_errors + use MemoryManagerModule, only: mem_allocate, mem_reallocate, & + mem_deallocate + use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, & + LENAUXNAME, DHNOFLO, MAXCHARLEN, LINELENGTH + use NumericalPackageModule, only: NumericalPackageType + use BaseDisModule, only: DisBaseType + use GwfNpfModule, only: GwfNpfType + use GwfVscInputDataModule, only: GwfVscInputDataType + + implicit none + + private + public :: GwfVscType + public :: vsc_cr + + type :: ConcentrationPointer + real(DP), dimension(:), pointer :: conc => null() ! pointer to concentration array + integer(I4B), dimension(:), pointer :: icbund => null() ! store pointer to gwt ibound array + end type ConcentrationPointer + + type, extends(NumericalPackageType) :: GwfVscType + type(GwfNpfType), pointer :: npf => null() ! npf object + integer(I4B), pointer :: ioutvisc => null() ! unit number for saving viscosity + integer(I4B), pointer :: ireadconcvsc => null() ! if 1 then visc has been read from this vsc input file ! kluge note: is this ever really used? + integer(I4B), pointer :: iconcset => null() ! if 1 then conc is pointed to a gwt model%x + real(DP), pointer :: viscref => null() ! reference fluid viscosity + real(DP), dimension(:), pointer, contiguous :: visc => null() ! viscosity + real(DP), dimension(:), pointer, contiguous :: concvsc => null() ! concentration array if specified in vsc package ! kluge note: is this ever really used? + integer(I4B), dimension(:), pointer :: ibound => null() ! store pointer to ibound + + integer(I4B), pointer :: nviscspecies => null() ! number of species used in viscosity equation + real(DP), dimension(:), pointer, contiguous :: dviscdc => null() ! change in viscosity with change in concentration ! kluge note: parameters will depend on formula; linear for now + real(DP), dimension(:), pointer, contiguous :: cviscref => null() ! reference concentration used in viscosity equation + real(DP), dimension(:), pointer, contiguous :: ctemp => null() ! temporary array of size (nviscspec) to pass to calcvisc + character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname ! names of gwt models used in viscosity equation + character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname ! names of aux columns used in viscosity equation + + type(ConcentrationPointer), allocatable, dimension(:) :: modelconc ! concentration pointer for each transport model + + contains + procedure :: vsc_df + procedure :: vsc_ar + procedure :: vsc_rp + procedure :: vsc_ad + procedure :: vsc_ot_dv + procedure :: vsc_da + procedure, private :: vsc_calcvisc + procedure :: allocate_scalars + procedure, private :: allocate_arrays + procedure, private :: read_options + procedure, private :: set_options + procedure, private :: read_dimensions + procedure, private :: read_packagedata + procedure, private :: set_packagedata + procedure :: set_concentration_pointer + end type GwfVscType + +contains + + function calcvisc(viscref, dviscdc, cviscref, conc) result(visc) +! ****************************************************************************** +! calcvisc -- generic function to calculate fluid viscosity from concentration +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + real(DP), intent(in) :: viscref + real(DP), dimension(:), intent(in) :: dviscdc + real(DP), dimension(:), intent(in) :: cviscref + real(DP), dimension(:), intent(in) :: conc + ! -- return + real(DP) :: visc + ! -- local + integer(I4B) :: nviscspec + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + nviscspec = size(dviscdc) + visc = viscref + do i = 1, nviscspec + visc = visc + dviscdc(i) * (conc(i) - cviscref(i)) ! kluge note: linear for now + end do + ! + ! -- return + return + end function calcvisc + + subroutine vsc_cr(vscobj, name_model, inunit, iout) +! ****************************************************************************** +! vsc_cr -- Create a new VSC object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + type(GwfVscType), pointer :: vscobj + character(len=*), intent(in) :: name_model + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout +! ------------------------------------------------------------------------------ + ! + ! -- Create the object + allocate (vscobj) + ! + ! -- create name and memory path + call vscobj%set_names(1, name_model, 'VSC', 'VSC') + ! + ! -- Allocate scalars + call vscobj%allocate_scalars() + ! + ! -- Set variables + vscobj%inunit = inunit + vscobj%iout = iout + ! + ! -- Initialize block parser + call vscobj%parser%Initialize(vscobj%inunit, vscobj%iout) + ! + ! -- Return + return + end subroutine vsc_cr + + !> @brief Read options and package data, or set from argument + !< + subroutine vsc_df(this, dis, vsc_input) +! ****************************************************************************** +! vsc_df -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this !< this viscosity package + class(DisBaseType), pointer, intent(in) :: dis !< pointer to discretization + type(GwfVscInputDataType), optional, intent(in) :: vsc_input !< optional vsc input data, otherwise read from file + ! -- local + ! -- formats + character(len=*), parameter :: fmtvsc = & + "(1x,/1x,'VSC -- VISCOSITY PACKAGE, VERSION 1, 5/16/2018', & + &' INPUT READ FROM UNIT ', i0, //)" +! ------------------------------------------------------------------------------ + ! + ! --print a message identifying the viscosity package + write (this%iout, fmtvsc) this%inunit + ! + ! -- store pointers to arguments that were passed in + this%dis => dis + + if (.not. present(vsc_input)) then + ! + ! -- Read viscosity options + call this%read_options() + ! + ! -- Read viscosity dimensions + call this%read_dimensions() + else + ! set from input data instead + call this%set_options(vsc_input) + this%nviscspecies = vsc_input%nviscspecies + end if + ! + ! -- Allocate arrays + call this%allocate_arrays(dis%nodes) + + if (.not. present(vsc_input)) then + ! + ! -- Read viscosity packagedata + call this%read_packagedata() + else + ! set from input data instead + call this%set_packagedata(vsc_input) + end if + ! + ! -- Return + return + end subroutine vsc_df + + subroutine vsc_ar(this, npf, ibound) +! ****************************************************************************** +! vsc_ar -- Allocate and Read +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this + type(GwfNpfType), pointer, intent(in) :: npf + integer(I4B), dimension(:), pointer :: ibound + ! -- local + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- store pointers to arguments that were passed in + this%npf => npf + this%ibound => ibound + ! + ! -- Return + return + end subroutine vsc_ar + + subroutine vsc_rp(this) +! ****************************************************************************** +! vsc_rp -- Check for new vsc period data +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper + ! -- dummy + class(GwfVscType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i + ! -- formats + character(len=*), parameter :: fmtc = & + "('VISCOSITY PACKAGE DOES NOT HAVE HAVE A CONCENTRATION SET & + &FOR SPECIES ',i0,'. ONE OR MORE MODEL NAMES MAY BE SPECIFIED & + &INCORRECTLY IN THE PACKAGEDATA BLOCK OR A GWF-GWT EXCHANGE MAY NEED & + &TO BE ACTIVATED.')" +! ------------------------------------------------------------------------------ + ! + ! -- Check to make sure all concentration pointers have been set + if (kstp * kper == 1) then + do i = 1, this%nviscspecies + if (.not. associated(this%modelconc(i)%conc)) then + write (errmsg, fmtc) i + call store_error(errmsg) + end if + end do + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + end if + ! + ! -- return + return + end subroutine vsc_rp + + subroutine vsc_ad(this) +! ****************************************************************************** +! vsc_ad -- Advance +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfVscType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- update viscosity using the last concentration + call this%vsc_calcvisc() + ! + ! -- update kfactor ! kluge note: need this, and also a vsc_ad_bnd subroutine to update kfactors for boundary packages + ! + ! -- Return + return + end subroutine vsc_ad + + function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & + ctemp, auxvar) result(viscbnd) +! ****************************************************************************** +! get_bnd_viscosity -- Return the viscosity of the boundary package using one of +! several different options in the following order of priority: +! 1. Assign as aux variable in column with name 'VISCOSITY' +! 2. Calculate using viscosity equation and nviscspecies aux columns +! 3. If neither of those, then assign as viscref +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + integer(I4B), intent(in) :: n + integer(I4B), intent(in) :: locvisc + integer(I4B), dimension(:), intent(in) :: locconc + real(DP), intent(in) :: viscref + real(DP), dimension(:), intent(in) :: dviscdc + real(DP), dimension(:), intent(in) :: cviscref + real(DP), dimension(:), intent(inout) :: ctemp + real(DP), dimension(:, :), intent(in) :: auxvar + ! -- return + real(DP) :: viscbnd + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- assign boundary viscosity based on one of three options + if (locvisc > 0) then + ! -- assign viscosity to an aux column named 'VISCOSITY' + viscbnd = auxvar(locvisc, n) + else if (locconc(1) > 0) then + ! -- calculate viscosity using one or more concentration auxcolumns + do i = 1, size(locconc) + ctemp(i) = DZERO + if (locconc(i) > 0) then + ctemp(i) = auxvar(locconc(i), n) + end if + end do + viscbnd = calcvisc(viscref, dviscdc, cviscref, ctemp) + else + ! -- neither of the above, so assign as viscref + viscbnd = viscref + end if + ! + ! -- return + return + end function get_bnd_viscosity + + subroutine vsc_ot_dv(this, idvfl) ! kluge note: rename to _vv ? +! ****************************************************************************** +! vsc_ot_dv -- Save viscosity array to binary file +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfVscType) :: this + integer(I4B), intent(in) :: idvfl + ! -- local + character(len=1) :: cdatafmp = ' ', editdesc = ' ' + integer(I4B) :: ibinun + integer(I4B) :: iprint + integer(I4B) :: nvaluesp + integer(I4B) :: nwidthp + real(DP) :: dinact +! ------------------------------------------------------------------------------ + ! + ! -- Set unit number for viscosity output + if (this%ioutvisc /= 0) then + ibinun = 1 + else + ibinun = 0 + end if + if (idvfl == 0) ibinun = 0 + ! + ! -- save viscosity array + if (ibinun /= 0) then + iprint = 0 + dinact = DHNOFLO + ! + ! -- write viscosity to binary file + if (this%ioutvisc /= 0) then + ibinun = this%ioutvisc + call this%dis%record_array(this%visc, this%iout, iprint, ibinun, & + ' VISCOSITY', cdatafmp, nvaluesp, & + nwidthp, editdesc, dinact) + end if + end if + + ! + ! -- Return + return + end subroutine vsc_ot_dv + + subroutine vsc_da(this) +! ****************************************************************************** +! vsc_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate arrays if package was active + if (this%inunit > 0) then + call mem_deallocate(this%visc) + call mem_deallocate(this%concvsc) + call mem_deallocate(this%dviscdc) + call mem_deallocate(this%cviscref) + call mem_deallocate(this%ctemp) + deallocate (this%cmodelname) + deallocate (this%cauxspeciesname) + deallocate (this%modelconc) + end if + ! + ! -- Scalars + call mem_deallocate(this%ioutvisc) + call mem_deallocate(this%ireadconcvsc) + call mem_deallocate(this%iconcset) + call mem_deallocate(this%viscref) + + call mem_deallocate(this%nviscspecies) + ! + ! -- deallocate parent + call this%NumericalPackageType%da() + ! + ! -- Return + return + end subroutine vsc_da + + subroutine read_dimensions(this) +! ****************************************************************************** +! read_dimensions -- Read the dimensions for this package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType), intent(inout) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- get dimensions block + call this%parser%GetBlock('DIMENSIONS', isfound, ierr, & + supportOpenClose=.true.) + ! + ! -- parse dimensions block if detected + if (isfound) then + write (this%iout, '(/1x,a)') 'PROCESSING VSC DIMENSIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('NVISCSPECIES') + this%nviscspecies = this%parser%GetInteger() + write (this%iout, '(4x,a,i0)') 'NVISCSPECIES = ', this%nviscspecies + case default + write (errmsg, '(4x,a,a)') & + 'UNKNOWN VSC DIMENSION: ', trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + end do + write (this%iout, '(1x,a)') 'END OF VSC DIMENSIONS' + else + call store_error('REQUIRED VSC DIMENSIONS BLOCK NOT FOUND.') + call this%parser%StoreErrorUnit() + end if + ! + ! -- check dimension + if (this%nviscspecies < 1) then + call store_error('NVISCSPECIES MUST BE GREATER THAN ZERO.') + call this%parser%StoreErrorUnit() + end if + ! + ! -- return + return + end subroutine read_dimensions + + subroutine read_packagedata(this) +! ****************************************************************************** +! read_packagedata -- Read PACKAGEDATA block +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + character(len=LINELENGTH) :: line + integer(I4B) :: ierr + integer(I4B) :: iviscspec + logical :: isfound, endOfBlock + logical :: blockrequired + integer(I4B), dimension(:), allocatable :: itemp + character(len=10) :: c10 + character(len=16) :: c16 + ! -- format + character(len=*), parameter :: fmterr = & + "('INVALID VALUE FOR IRHOSPEC (',i0,') DETECTED IN VSC PACKAGE. & + &IRHOSPEC MUST BE > 0 AND <= NVISCSPECIES, AND DUPLICATE VALUES & + &ARE NOT ALLOWED.')" +! ------------------------------------------------------------------------------ + ! + ! -- initialize + allocate (itemp(this%nviscspecies)) + itemp(:) = 0 + ! + ! -- get packagedata block + blockrequired = .true. + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + blockRequired=blockRequired, & + supportOpenClose=.true.) + ! + ! -- parse packagedata block + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING VSC PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + iviscspec = this%parser%GetInteger() + if (iviscspec < 1 .or. iviscspec > this%nviscspecies) then + write (errmsg, fmterr) iviscspec + call store_error(errmsg) + end if + if (itemp(iviscspec) /= 0) then + write (errmsg, fmterr) iviscspec + call store_error(errmsg) + end if + itemp(iviscspec) = 1 + this%dviscdc(iviscspec) = this%parser%GetDouble() + this%cviscref(iviscspec) = this%parser%GetDouble() + call this%parser%GetStringCaps(this%cmodelname(iviscspec)) + call this%parser%GetStringCaps(this%cauxspeciesname(iviscspec)) + end do + write (this%iout, '(1x,a)') 'END OF VSC PACKAGEDATA' + end if + ! + ! -- Check for errors. + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! + ! -- write packagedata information + write (this%iout, '(/,a)') 'SUMMARY OF SPECIES INFORMATION IN VSC PACKAGE' + write (this%iout, '(1a11, 4a17)') & + 'SPECIES', 'DRHODC', 'CRHOREF', 'MODEL', & + 'AUXSPECIESNAME' + do iviscspec = 1, this%nviscspecies + write (c10, '(i0)') iviscspec + line = ' '//adjustr(c10) + write (c16, '(g15.6)') this%dviscdc(iviscspec) + line = trim(line)//' '//adjustr(c16) + write (c16, '(g15.6)') this%cviscref(iviscspec) + line = trim(line)//' '//adjustr(c16) + write (c16, '(a)') this%cmodelname(iviscspec) + line = trim(line)//' '//adjustr(c16) + write (c16, '(a)') this%cauxspeciesname(iviscspec) + line = trim(line)//' '//adjustr(c16) + write (this%iout, '(a)') trim(line) + end do + ! + ! -- deallocate + deallocate (itemp) + ! + ! -- return + return + end subroutine read_packagedata + + !> @brief Sets package data instead of reading from file + !< + subroutine set_packagedata(this, input_data) + class(GwfVscType) :: this !< this vscoancy pkg + type(GwfVscInputDataType), intent(in) :: input_data !< the input data to be set + ! local + integer(I4B) :: ispec + + do ispec = 1, this%nviscspecies + this%dviscdc(ispec) = input_data%dviscdc(ispec) + this%cviscref(ispec) = input_data%cviscref(ispec) + this%cmodelname(ispec) = input_data%cmodelname(ispec) + this%cauxspeciesname(ispec) = input_data%cauxspeciesname(ispec) + end do + + end subroutine set_packagedata + + subroutine vsc_calcvisc(this) +! ****************************************************************************** +! vsc_calcvisc -- calculate fluid viscosity from concentration +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GwfVscType) :: this + + ! -- local + integer(I4B) :: n + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- Calculate the viscosity using the specified concentration array + do n = 1, this%dis%nodes + do i = 1, this%nviscspecies + if (this%modelconc(i)%icbund(n) == 0) then + this%ctemp = DZERO + else + this%ctemp(i) = this%modelconc(i)%conc(n) + end if + end do + this%visc(n) = calcvisc(this%viscref, this%dviscdc, this%cviscref, & + this%ctemp) + end do + ! + ! -- Return + return + end subroutine vsc_calcvisc + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: DZERO + ! -- dummy + class(GwfVscType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in NumericalPackageType + call this%NumericalPackageType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%ioutvisc, 'IOUTVISC', this%memoryPath) + call mem_allocate(this%ireadconcvsc, 'IREADCONCVSC', this%memoryPath) + call mem_allocate(this%iconcset, 'ICONCSET', this%memoryPath) + call mem_allocate(this%viscref, 'VISCREF', this%memoryPath) + + call mem_allocate(this%nviscspecies, 'NVISCSPECIES', this%memoryPath) + + ! + ! -- Initialize + this%ioutvisc = 0 + this%iconcset = 0 + this%ireadconcvsc = 0 + this%viscref = 1000.d0 + + this%nviscspecies = 0 + + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine allocate_arrays(this, nodes) +! ****************************************************************************** +! allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this + integer(I4B), intent(in) :: nodes + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- Allocate + call mem_allocate(this%visc, nodes, 'VISC', this%memoryPath) + call mem_allocate(this%concvsc, 0, 'CONCVSC', this%memoryPath) + call mem_allocate(this%dviscdc, this%nviscspecies, 'DRHODC', this%memoryPath) + call mem_allocate(this%cviscref, this%nviscspecies, 'CRHOREF', this%memoryPath) + call mem_allocate(this%ctemp, this%nviscspecies, 'CTEMP', this%memoryPath) + allocate (this%cmodelname(this%nviscspecies)) + allocate (this%cauxspeciesname(this%nviscspecies)) + allocate (this%modelconc(this%nviscspecies)) + ! + ! -- Initialize + do i = 1, nodes + this%visc(i) = this%viscref + end do + ! + ! -- Initialize nviscspecies arrays + do i = 1, this%nviscspecies + this%dviscdc(i) = DZERO + this%cviscref(i) = DZERO + this%ctemp(i) = DZERO + this%cmodelname(i) = '' + this%cauxspeciesname(i) = '' + end do + ! + ! -- Return + return + end subroutine allocate_arrays + + subroutine read_options(this) +! ****************************************************************************** +! read_options +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use OpenSpecModule, only: access, form + use InputOutputModule, only: urword, getunit, urdaux, openfile + ! -- dummy + class(GwfVscType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg, keyword + character(len=MAXCHARLEN) :: fname + integer(I4B) :: ierr + logical :: isfound, endOfBlock + ! -- formats + character(len=*), parameter :: fmtfileout = & + "(4x, 'VSC ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & + &a, /4x, 'OPENED ON UNIT: ', I7)" +! ------------------------------------------------------------------------------ + ! + ! -- get options block + call this%parser%GetBlock('OPTIONS', isfound, ierr, & + supportOpenClose=.true., blockRequired=.false.) + ! + ! -- parse options block if detected + if (isfound) then + write (this%iout, '(1x,a)') 'PROCESSING VSC OPTIONS' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) exit + call this%parser%GetStringCaps(keyword) + select case (keyword) + case ('VISCREF') + this%viscref = this%parser%GetDouble() + write (this%iout, '(4x,a,1pg15.6)') & + 'REFERENCE VISCOSITY HAS BEEN SET TO: ', & + this%viscref + case ('VISCOSITY') + call this%parser%GetStringCaps(keyword) + if (keyword == 'FILEOUT') then + call this%parser%GetString(fname) + this%ioutvisc = getunit() + call openfile(this%ioutvisc, this%iout, fname, 'DATA(BINARY)', & + form, access, 'REPLACE') + write (this%iout, fmtfileout) & + 'VISCOSITY', fname, this%ioutvisc + else + errmsg = 'OPTIONAL VISCOSITY KEYWORD MUST BE '// & + 'FOLLOWED BY FILEOUT' + call store_error(errmsg) + end if + case default + write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN VSC OPTION: ', & + trim(keyword) + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end select + end do + write (this%iout, '(1x,a)') 'END OF VSC OPTIONS' + end if + ! + ! -- Return + return + end subroutine read_options + + !> @brief Sets options as opposed to reading them from a file + !< + subroutine set_options(this, input_data) + class(GwfVscType) :: this + type(GwfVscInputDataType), intent(in) :: input_data !< the input data to be set + + this%viscref = input_data%viscref + + end subroutine set_options + + subroutine set_concentration_pointer(this, modelname, conc, icbund) +! ****************************************************************************** +! set_concentration_pointer -- pass in a gwt model name, concentration array +! and ibound, and store a pointer to these in the VSC package so that +! viscosity can be calculated from them. +! This routine is called from the gwfgwt exchange in the exg_ar() method. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this + character(len=LENMODELNAME), intent(in) :: modelname + real(DP), dimension(:), pointer :: conc + integer(I4B), dimension(:), pointer :: icbund + ! -- local + integer(I4B) :: i + logical :: found +! ------------------------------------------------------------------------------ + ! + this%iconcset = 1 + found = .false. + do i = 1, this%nviscspecies + if (this%cmodelname(i) == modelname) then + this%modelconc(i)%conc => conc + this%modelconc(i)%icbund => icbund + found = .true. + exit + end if + end do + ! + ! -- Return + return + end subroutine set_concentration_pointer + +end module GwfVscModule diff --git a/src/Model/ModelUtilities/GwfVscInputData.f90 b/src/Model/ModelUtilities/GwfVscInputData.f90 new file mode 100644 index 00000000000..1be5272892f --- /dev/null +++ b/src/Model/ModelUtilities/GwfVscInputData.f90 @@ -0,0 +1,55 @@ +module GwfVscInputDataModule + use KindModule, only: I4B, DP + use ConstantsModule, only: LENMODELNAME, LENAUXNAME, DZERO + + implicit none + private + + !> Data structure to transfer input configuration to the + !< VSC package, as opposed to reading from file + type, public :: GwfVscInputDataType + + ! options + real(DP) :: viscref !< see VSC for description + ! dim + integer(I4B) :: nviscspecies !< see VSC for description + + ! pkg data + real(DP), dimension(:), pointer, contiguous :: dviscdc => null() !< see VSC for description + real(DP), dimension(:), pointer, contiguous :: cviscref => null() !< see VSC for description + character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname !< see VSC for description + character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname !< see VSC for description + + contains + procedure, pass(this) :: construct + procedure, pass(this) :: destruct + end type GwfVscInputDataType + +contains + +!> @brief Allocate the input data +!< + subroutine construct(this, nviscspecies) + class(GwfVscInputDataType) :: this !< the input data block + integer(I4B) :: nviscspecies !< the number of species + + allocate (this%dviscdc(nviscspecies)) + allocate (this%cviscref(nviscspecies)) + allocate (this%cmodelname(nviscspecies)) + allocate (this%cauxspeciesname(nviscspecies)) + + end subroutine construct + + !> @brief clean up + !< + subroutine destruct(this) + class(GwfVscInputDataType) :: this !< the input data block + + deallocate (this%dviscdc) + deallocate (this%cviscref) + deallocate (this%cmodelname) + deallocate (this%cauxspeciesname) + + end subroutine destruct + +end module GwfVscInputDataModule From 7978763c44b617e4ba620a7a01a645ab6c53341e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 28 Jul 2022 07:37:42 -0700 Subject: [PATCH 027/212] Adding some options to VSC OPTIONS block; minor tweaks to some of the docstrings --- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 66 ++++++++++++++++++-------- 1 file changed, 45 insertions(+), 21 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 54ecaecf51d..61c7afcde8c 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -20,28 +20,30 @@ module GwfVscModule public :: vsc_cr type :: ConcentrationPointer - real(DP), dimension(:), pointer :: conc => null() ! pointer to concentration array - integer(I4B), dimension(:), pointer :: icbund => null() ! store pointer to gwt ibound array + real(DP), dimension(:), pointer :: conc => null() !< pointer to concentration array + integer(I4B), dimension(:), pointer :: icbund => null() !< store pointer to gwt ibound array + integer(I4B), dimension(:), pointer :: istmpr => null() !< integer flag for identifying whether the "species" array is temperature end type ConcentrationPointer type, extends(NumericalPackageType) :: GwfVscType - type(GwfNpfType), pointer :: npf => null() ! npf object - integer(I4B), pointer :: ioutvisc => null() ! unit number for saving viscosity - integer(I4B), pointer :: ireadconcvsc => null() ! if 1 then visc has been read from this vsc input file ! kluge note: is this ever really used? - integer(I4B), pointer :: iconcset => null() ! if 1 then conc is pointed to a gwt model%x - real(DP), pointer :: viscref => null() ! reference fluid viscosity - real(DP), dimension(:), pointer, contiguous :: visc => null() ! viscosity - real(DP), dimension(:), pointer, contiguous :: concvsc => null() ! concentration array if specified in vsc package ! kluge note: is this ever really used? - integer(I4B), dimension(:), pointer :: ibound => null() ! store pointer to ibound - - integer(I4B), pointer :: nviscspecies => null() ! number of species used in viscosity equation - real(DP), dimension(:), pointer, contiguous :: dviscdc => null() ! change in viscosity with change in concentration ! kluge note: parameters will depend on formula; linear for now - real(DP), dimension(:), pointer, contiguous :: cviscref => null() ! reference concentration used in viscosity equation - real(DP), dimension(:), pointer, contiguous :: ctemp => null() ! temporary array of size (nviscspec) to pass to calcvisc - character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname ! names of gwt models used in viscosity equation - character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname ! names of aux columns used in viscosity equation - - type(ConcentrationPointer), allocatable, dimension(:) :: modelconc ! concentration pointer for each transport model + type(GwfNpfType), pointer :: npf => null() !< npf object + integer(I4B), pointer :: ivisc => null() !< viscosity formulation flag (1:Voss (1984), 2:Pawlowski (1991), 3:Guo and Zhou (2005)) + integer(I4B), pointer :: ioutvisc => null() !< unit number for saving viscosity + integer(I4B), pointer :: ireadconcvsc => null() !< if 1 then visc has been read from this vsc input file ! kluge note: is this ever really used? + integer(I4B), pointer :: iconcset => null() !< if 1 then conc points to a gwt (or gwe) model%x array + real(DP), pointer :: viscref => null() !< reference fluid viscosity + real(DP), dimension(:), pointer, contiguous :: visc => null() !< viscosity + real(DP), dimension(:), pointer, contiguous :: concvsc => null() !< concentration (or temperature) array if specified in vsc package ! kluge note: is this ever really used? + integer(I4B), dimension(:), pointer :: ibound => null() !< store pointer to ibound + + integer(I4B), pointer :: nviscspecies => null() !< number of concentration species used in viscosity equation + real(DP), dimension(:), pointer, contiguous :: dviscdc => null() !< change in viscosity with change in concentration ! kluge note: parameters will depend on formula; linear for now + real(DP), dimension(:), pointer, contiguous :: cviscref => null() !< reference concentration used in viscosity equation + real(DP), dimension(:), pointer, contiguous :: ctemp => null() !< temporary array of size (nviscspec) to pass to calcvisc + character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname !< names of gwt (or gwe) models used in viscosity equation + character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname !< names of aux columns used in viscosity equation + + type(ConcentrationPointer), allocatable, dimension(:) :: modelconc !< concentration (or temperature) pointer for each solute (or heat) transport model contains procedure :: vsc_df @@ -356,7 +358,6 @@ subroutine vsc_ot_dv(this, idvfl) ! kluge note: rename to _vv ? nwidthp, editdesc, dinact) end if end if - ! ! -- Return return @@ -692,7 +693,7 @@ subroutine read_options(this) ! -- dummy class(GwfVscType) :: this ! -- local - character(len=LINELENGTH) :: errmsg, keyword + character(len=LINELENGTH) :: errmsg, keyword, keyword2 character(len=MAXCHARLEN) :: fname integer(I4B) :: ierr logical :: isfound, endOfBlock @@ -700,6 +701,15 @@ subroutine read_options(this) character(len=*), parameter :: fmtfileout = & "(4x, 'VSC ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & &a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtvoss = & + "(4x, 'VISCOSITY CALCULATION ADOPTS FORMULA OFFERED IN VOSS (1984). ')" + character(len=*), parameter :: fmtpawlowski = & + "(4x, 'VISCOSITY CALCULATION ADOPTS FORMULA OFFERED IN PAWLOWSKI (1991).')" + character(len=*), parameter :: fmtguo = & + "(4x, 'VISCOSITY CALCULATION ADOPTS FORMULA OFFERED IN GUO AND & + &ZHOU (2005). THIS RELATIONSHIP IS FOR OIL VISCOSITY AS A FUNCTION & + &OF TEMPERATURE (BETWEEN 5 AND 170 DECREES CELSIUS). RELATION IS & + &NOT APPLICABLE TO WATER.')" ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -733,6 +743,19 @@ subroutine read_options(this) 'FOLLOWED BY FILEOUT' call store_error(errmsg) end if + case ('VISCOSITY_FUNC') + call this%parser%GetStringCaps(keyword2) + if (trim(adjustl(keyword2)) == 'VOSS') this%ivisc = 1 + if (trim(adjustl(keyword2)) == 'PAWLOWSKI') this%ivisc = 2 + if (trim(adjustl(keyword2)) == 'GUO') this%ivisc = 3 + select case (this%ivisc) + case (1) + write (this%iout, fmtvoss) + case (2) + write (this%iout, fmtpawlowski) + case (3) + write (this%iout, fmtguo) + end select case default write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN VSC OPTION: ', & trim(keyword) @@ -757,6 +780,7 @@ subroutine set_options(this, input_data) end subroutine set_options + subroutine set_concentration_pointer(this, modelname, conc, icbund) ! ****************************************************************************** ! set_concentration_pointer -- pass in a gwt model name, concentration array From 0e58924559bb9b9b0d100ab23fe89fccbf118043 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Fri, 29 Jul 2022 13:38:50 -0400 Subject: [PATCH 028/212] * Added ikmod flag to npf to indicate whether Ks get modified from their input values (e.g., by vsc) * Added invsc unit number for vsc in gwf * Added calls to vsc routine (e.g., vsc_ad) from gwf routines --- msvs/mf6.vfproj | 6 ++--- msvs/mf6core.vfproj | 2 +- src/Model/Connection/GwfInterfaceModel.f90 | 3 ++- src/Model/GroundWaterFlow/gwf3.f90 | 30 ++++++++++++++++++++-- src/Model/GroundWaterFlow/gwf3npf8.f90 | 10 +++++++- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 2 +- 6 files changed, 44 insertions(+), 9 deletions(-) diff --git a/msvs/mf6.vfproj b/msvs/mf6.vfproj index 3d8eb21730e..cfad99a21e5 100644 --- a/msvs/mf6.vfproj +++ b/msvs/mf6.vfproj @@ -26,7 +26,7 @@ - + @@ -36,7 +36,7 @@ - + @@ -56,7 +56,7 @@ - + diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 02bcb6c6260..2c380ff3a9a 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -14,7 +14,7 @@ - + diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index a0361c4b0f4..fd7e5bd12bd 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -122,10 +122,11 @@ subroutine gwfifm_ar(this) class(GwfInterfaceModelType) :: this !< the GWF interface model ! local type(GwfNpfGridDataType) :: npfGridData + integer(I4B), target :: ikmod = 0 ! kluge call npfGridData%construct(this%dis%nodes) call this%setNpfGridData(npfGridData) - call this%npf%npf_ar(this%ic, this%ibound, this%x, npfGridData) + call this%npf%npf_ar(this%ic, this%ibound, this%x, ikmod, npfGridData) ! kluge note: added local "ikmod" as a placeholder; speak to Martijn about integrating VSC call npfGridData%destroy() if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index 00b6c39a468..ce5e9d46c0d 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -11,6 +11,7 @@ module GwfModule use GwfNpfModule, only: GwfNpfType use Xt3dModule, only: Xt3dType use GwfBuyModule, only: GwfBuyType + use GwfVscModule, only: GwfVscType use GwfHfbModule, only: GwfHfbType use GwfStoModule, only: GwfStoType use GwfCsubModule, only: GwfCsubType @@ -35,6 +36,7 @@ module GwfModule type(GwfNpfType), pointer :: npf => null() ! node property flow package type(Xt3dType), pointer :: xt3d => null() ! xt3d option for npf type(GwfBuyType), pointer :: buy => null() ! buoyancy package + type(GwfVscType), pointer :: vsc => null() ! viscosity package type(GwfStoType), pointer :: sto => null() ! storage package type(GwfCsubType), pointer :: csub => null() ! subsidence package type(GwfOcType), pointer :: oc => null() ! output control package @@ -47,6 +49,7 @@ module GwfModule integer(I4B), pointer :: inoc => null() ! unit number OC integer(I4B), pointer :: innpf => null() ! unit number NPF integer(I4B), pointer :: inbuy => null() ! unit number BUY + integer(I4B), pointer :: invsc => null() ! unit number VSC integer(I4B), pointer :: insto => null() ! unit number STO integer(I4B), pointer :: incsub => null() ! unit number CSUB integer(I4B), pointer :: inmvr => null() ! unit number MVR @@ -122,6 +125,7 @@ subroutine gwf_cr(filename, id, modelname, smr) use GwfNpfModule, only: npf_cr use Xt3dModule, only: xt3d_cr use GwfBuyModule, only: buy_cr + use GwfVscModule, only: vsc_cr use GwfStoModule, only: sto_cr use GwfCsubModule, only: csub_cr use GwfMvrModule, only: mvr_cr @@ -237,6 +241,7 @@ subroutine gwf_cr(filename, id, modelname, smr) call namefile_obj%get_unitnumber('OC6', this%inoc, 1) call namefile_obj%get_unitnumber('NPF6', this%innpf, 1) call namefile_obj%get_unitnumber('BUY6', this%inbuy, 1) + call namefile_obj%get_unitnumber('VSC6', this%invsc, 1) call namefile_obj%get_unitnumber('STO6', this%insto, 1) call namefile_obj%get_unitnumber('CSUB6', this%incsub, 1) call namefile_obj%get_unitnumber('MVR6', this%inmvr, 1) @@ -263,6 +268,7 @@ subroutine gwf_cr(filename, id, modelname, smr) call npf_cr(this%npf, this%name, this%innpf, this%iout) call xt3d_cr(this%xt3d, this%name, this%innpf, this%iout) call buy_cr(this%buy, this%name, this%inbuy, this%iout) + call vsc_cr(this%vsc, this%name, this%invsc, this%iout) call gnc_cr(this%gnc, this%name, this%ingnc, this%iout) call hfb_cr(this%hfb, this%name, this%inhfb, this%iout) call sto_cr(this%sto, this%name, this%insto, this%iout) @@ -312,6 +318,7 @@ subroutine gwf_df(this) call this%oc%oc_df() call this%budget%budget_df(niunit, 'VOLUME', 'L**3') if (this%inbuy > 0) call this%buy%buy_df(this%dis) + if (this%invsc > 0) call this%vsc%vsc_df(this%dis) if (this%ingnc > 0) call this%gnc%gnc_df(this) ! ! -- Assign or point model members to dis members @@ -414,12 +421,23 @@ subroutine gwf_ar(this) ! -- locals integer(I4B) :: ip class(BndType), pointer :: packobj + integer(I4B) :: ikmodgwf ! ------------------------------------------------------------------------------ + ! + ! -- Set flag that indicates whether hydraulic conductivities get modified + ! from their user-input values (e.g., via npf or tvk input) internally + ! by another package (e.g., vsc). + ikmodgwf = 0 + if (this%invsc) then + ikmodgwf = 1 + end if ! ! -- Allocate and read modules attached to model if (this%inic > 0) call this%ic%ic_ar(this%x) - if (this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x) + if (this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x, & + ikmodgwf) if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) + if (this%invsc > 0) call this%vsc%vsc_ar(this%npf, this%ibound) if (this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) if (this%insto > 0) call this%sto%sto_ar(this%dis, this%ibound) if (this%incsub > 0) call this%csub%csub_ar(this%dis, this%ibound) @@ -441,6 +459,7 @@ subroutine gwf_ar(this) ! -- Read and allocate package call packobj%bnd_ar() if (this%inbuy > 0) call this%buy%buy_ar_bnd(packobj, this%x) +! if (this%invsc > 0) call this%buy%vsc_ar_bnd(packobj, this%x) ! kluge ! end do ! ! -- return @@ -468,6 +487,7 @@ subroutine gwf_rp(this) ! -- Read and prepare if (this%innpf > 0) call this%npf%npf_rp() if (this%inbuy > 0) call this%buy%buy_rp() + if (this%invsc > 0) call this%vsc%vsc_rp() if (this%inhfb > 0) call this%hfb%hfb_rp() if (this%inoc > 0) call this%oc%oc_rp() if (this%insto > 0) call this%sto%sto_rp() @@ -522,6 +542,7 @@ subroutine gwf_ad(this) if (this%insto > 0) call this%sto%sto_ad() if (this%incsub > 0) call this%csub%csub_ad(this%dis%nodes, this%x) if (this%inbuy > 0) call this%buy%buy_ad() + if (this%invsc > 0) call this%vsc%vsc_ad() if (this%inmvr > 0) call this%mvr%mvr_ad() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) @@ -1131,7 +1152,7 @@ subroutine gwf_ot_dv(this, idvsave, idvprint, ipflag) ! -- save density to binary file if (this%inbuy > 0) then - call this%buy%buy_ot_dv(idvsave) + call this%buy%buy_ot_dv(idvsave) ! kluge note: do similar for viscosity (or viscosity ratio)? end if ! -- Print advanced package dependent variables @@ -1209,6 +1230,7 @@ subroutine gwf_da(this) call this%npf%npf_da() call this%xt3d%xt3d_da() call this%buy%buy_da() + call this%vsc%vsc_da() call this%gnc%gnc_da() call this%sto%sto_da() call this%csub%csub_da() @@ -1224,6 +1246,7 @@ subroutine gwf_da(this) deallocate (this%npf) deallocate (this%xt3d) deallocate (this%buy) + deallocate (this%vsc) deallocate (this%gnc) deallocate (this%sto) deallocate (this%csub) @@ -1246,6 +1269,7 @@ subroutine gwf_da(this) call mem_deallocate(this%inobs) call mem_deallocate(this%innpf) call mem_deallocate(this%inbuy) + call mem_deallocate(this%invsc) call mem_deallocate(this%insto) call mem_deallocate(this%incsub) call mem_deallocate(this%inmvr) @@ -1338,6 +1362,7 @@ subroutine allocate_scalars(this, modelname) call mem_allocate(this%inoc, 'INOC', this%memoryPath) call mem_allocate(this%innpf, 'INNPF', this%memoryPath) call mem_allocate(this%inbuy, 'INBUY', this%memoryPath) + call mem_allocate(this%invsc, 'INVSC', this%memoryPath) call mem_allocate(this%insto, 'INSTO', this%memoryPath) call mem_allocate(this%incsub, 'INCSUB', this%memoryPath) call mem_allocate(this%inmvr, 'INMVR', this%memoryPath) @@ -1351,6 +1376,7 @@ subroutine allocate_scalars(this, modelname) this%inoc = 0 this%innpf = 0 this%inbuy = 0 + this%invsc = 0 this%insto = 0 this%incsub = 0 this%inmvr = 0 diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index b7ad00283d8..799a2a6a84a 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -52,6 +52,7 @@ module GwfNpfModule integer(I4B), pointer :: iwetit => null() !< wetting interval (default is 1) integer(I4B), pointer :: ihdwet => null() !< (0 or not 0) integer(I4B), pointer :: icellavg => null() !< harmonic(0), logarithmic(1), or arithmetic thick-log K (2) + integer(I4B), pointer :: ikmod => null() !< if 1, conductivities get modified from their input values to account for effects such as varying viscosity real(DP), pointer :: wetfct => null() !< wetting factor real(DP), pointer :: hdry => null() !< default is -1.d30 integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< confined (0) or convertible (1) @@ -285,7 +286,7 @@ end subroutine npf_mc !! from the input argument (when the optional @param grid_data is passed), !! preprocess the input data and call *_ar on xt3d, when active. !< - subroutine npf_ar(this, ic, ibound, hnew, grid_data) + subroutine npf_ar(this, ic, ibound, hnew, ikmodgwf, grid_data) ! ****************************************************************************** ! npf_ar -- Allocate and Read ! ****************************************************************************** @@ -297,6 +298,7 @@ subroutine npf_ar(this, ic, ibound, hnew, grid_data) type(GwfIcType), pointer, intent(in) :: ic !< initial conditions integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array + integer(I4B), intent(in) :: ikmodgwf !< flag to indicate whether conductivities get modified from their input values by a gwf package type(GwfNpfGridDataType), optional, intent(in) :: grid_data !< (optional) data structure with NPF grid data ! -- local ! -- formats @@ -308,6 +310,9 @@ subroutine npf_ar(this, ic, ibound, hnew, grid_data) this%ibound => ibound this%hnew => hnew ! + ! -- Set flag to indicate whether conductivities get modified from their input values + this%ikmod = ikmodgwf + ! ! -- allocate arrays call this%allocate_arrays(this%dis%nodes, this%dis%njas) ! @@ -1042,6 +1047,7 @@ subroutine npf_da(this) call mem_deallocate(this%hnoflo) call mem_deallocate(this%hdry) call mem_deallocate(this%icellavg) + call mem_deallocate(this%ikmod) call mem_deallocate(this%iavgkeff) call mem_deallocate(this%ik22) call mem_deallocate(this%ik33) @@ -1122,6 +1128,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%hnoflo, 'HNOFLO', this%memoryPath) call mem_allocate(this%hdry, 'HDRY', this%memoryPath) call mem_allocate(this%icellavg, 'ICELLAVG', this%memoryPath) + call mem_allocate(this%ikmod, 'IKMOD', this%memoryPath) call mem_allocate(this%iavgkeff, 'IAVGKEFF', this%memoryPath) call mem_allocate(this%ik22, 'IK22', this%memoryPath) call mem_allocate(this%ik33, 'IK33', this%memoryPath) @@ -1162,6 +1169,7 @@ subroutine allocate_scalars(this) this%hnoflo = DHNOFLO !1.d30 this%hdry = DHDRY !-1.d30 this%icellavg = 0 + this%ikmod = 0 this%iavgkeff = 0 this%ik22 = 0 this%ik33 = 0 diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 61c7afcde8c..b1a2f9849d9 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -318,7 +318,7 @@ function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & return end function get_bnd_viscosity - subroutine vsc_ot_dv(this, idvfl) ! kluge note: rename to _vv ? + subroutine vsc_ot_dv(this, idvfl) ! kluge note: rename to _vv ? save viscosity ratio? do we want this at all? ! ****************************************************************************** ! vsc_ot_dv -- Save viscosity array to binary file ! ****************************************************************************** From 4bc36fa498649bd27019748cd28ea70c7e7886d0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 29 Jul 2022 10:47:30 -0700 Subject: [PATCH 029/212] About to rectify my local changes with what Alden just pushed, committing to see if git will figure out the conflicts on its own --- src/Model/GroundWaterFlow/gwf3buy8.f90 | 2 +- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 149 ++++++++++++++++++++++--- 2 files changed, 132 insertions(+), 19 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3buy8.f90 b/src/Model/GroundWaterFlow/gwf3buy8.f90 index e5029e404a5..781b40cdb80 100644 --- a/src/Model/GroundWaterFlow/gwf3buy8.f90 +++ b/src/Model/GroundWaterFlow/gwf3buy8.f90 @@ -142,7 +142,7 @@ end subroutine buy_cr !< subroutine buy_df(this, dis, buy_input) ! ****************************************************************************** -! buy_df -- Allocate and Read +! buy_df -- Define ! ****************************************************************************** ! ! SPECIFICATIONS: diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 61c7afcde8c..476d3a59ca2 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -12,6 +12,10 @@ module GwfVscModule use BaseDisModule, only: DisBaseType use GwfNpfModule, only: GwfNpfType use GwfVscInputDataModule, only: GwfVscInputDataType + use BaseModelModule, only: BaseModelType, GetBaseModelFromList + use GwfModule, only: GwfModelType + use GwtModule, only: GwtModelType + use GweModule, only: GweModelType implicit none @@ -42,6 +46,12 @@ module GwfVscModule real(DP), dimension(:), pointer, contiguous :: ctemp => null() !< temporary array of size (nviscspec) to pass to calcvisc character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname !< names of gwt (or gwe) models used in viscosity equation character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname !< names of aux columns used in viscosity equation + ! + ! -- Viscosity constants + real(DP), dimension(:), pointer, contiguous :: a2 => null() !< an empirical parameter specified by the user for calculating viscosity + real(DP), dimension(:), pointer, contiguous :: a3 => null() !< an empirical parameter specified by the user for calculating viscosity + real(DP), dimension(:), pointer, contiguous :: a4 => null() !< an empirical parameter specified by the user for calculating viscosity + real(DP), dimension(:), pointer, contiguous :: a5 => null() !< an empirical parameter specified by the user for calculating viscosity type(ConcentrationPointer), allocatable, dimension(:) :: modelconc !< concentration (or temperature) pointer for each solute (or heat) transport model @@ -382,12 +392,17 @@ subroutine vsc_da(this) call mem_deallocate(this%dviscdc) call mem_deallocate(this%cviscref) call mem_deallocate(this%ctemp) + call mem_deallocate(this%a2) + call mem_deallocate(this%a3) + call mem_deallocate(this%a4) + call mem_deallocate(this%a5) deallocate (this%cmodelname) deallocate (this%cauxspeciesname) deallocate (this%modelconc) end if ! ! -- Scalars + call mem_deallocate(this%ivisc) call mem_deallocate(this%ioutvisc) call mem_deallocate(this%ireadconcvsc) call mem_deallocate(this%iconcset) @@ -457,19 +472,23 @@ subroutine read_dimensions(this) return end subroutine read_dimensions + !> @ brief Read data for package + !! + !! Method to read data for the package. + !! + !< subroutine read_packagedata(this) -! ****************************************************************************** -! read_packagedata -- Read PACKAGEDATA block -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwfVscType) :: this ! -- local - character(len=LINELENGTH) :: errmsg + class(BaseModelType), pointer :: mb => null() + type(GwfModelType), pointer :: gwfmodel => null() + type(GwtModelType), pointer :: gwtmodel => null() + type(GweModelType), pointer :: gwemodel => null() + character(len=LINELENGTH) :: warnmsg, errmsg character(len=LINELENGTH) :: line + character(len=LENMODELNAME) :: mname integer(I4B) :: ierr integer(I4B) :: iviscspec logical :: isfound, endOfBlock @@ -510,13 +529,90 @@ subroutine read_packagedata(this) call store_error(errmsg) end if itemp(iviscspec) = 1 - this%dviscdc(iviscspec) = this%parser%GetDouble() + this%a2(iviscspec) = this%parser%GetDouble() + if (this%ivisc == 1) then + this%dviscdc(iviscspec) = this%a2(iviscspec) + end if + this%a3(iviscspec) = this%parser%GetDouble() + this%a4(iviscspec) = this%parser%GetDouble() + this%a5(iviscspec) = this%parser%GetDouble() + ! this%cviscref(iviscspec) = this%parser%GetDouble() call this%parser%GetStringCaps(this%cmodelname(iviscspec)) call this%parser%GetStringCaps(this%cauxspeciesname(iviscspec)) + ! + ! -- check if modelname corresponds to a GWE model, and, if so + ! set istmpr ("is temperature") equal to 1 to signify species is GWE + mname = this%cmodelname(iviscspec) + + ! + ! -- Check for errors, and when helpful issue warnings + !if (this%modelconc(iviscspec)%istmpr == 1) then + if (this%ivisc == 1) then + if (this%a2(iviscspec) == 0.0) then + write(errmsg, '(a)') 'LINEAR OPTION SELECTED FOR VARYING & + &VISCOSITY, BUT A1, A SURROGATE FOR dVISC/dT, SET EQUAL TO 0.0' + call store_error(errmsg) + end if + end if + if (this%ivisc > 1) then + if(this%a2(iviscspec) == 0) then + write (warnmsg, '(a)') 'A1 SET EQUAL TO ZERO WHICH MAY LEAD TO & + &UNINTENDED VALUES FOR VISCOSITY' + call store_warning(errmsg) + end if + end if + if (this%ivisc == 2 .or. this%ivisc == 3) then + if (this%a3(iviscspec) == 0) then + write (warnmsg, '(a)') 'A3 WILL BE USED IN THE SELECTED VISCOSITY & + &CALCULATION BUT HAS BEEN SET EQUAL TO ZERO. CAREFULLY CONSIDER & + &WHETHER THE SPECIFIED VALUE OF 0.0 WAS INTENDED.' + call store_warning(warnmsg) + end if + if (this%a4(iviscspec) == 0) then + write (warnmsg, '(a)') 'A4 WILL BE USED IN THE SELECTED VISCOSITY & + &CALCULATION BUT HAS BEEN SET EQUAL TO ZERO. CAREFULLY CONSIDER & + &WHETHER THE SPECIFIED VALUE OF 0.0 WAS INTENDED.' + call store_warning(warnmsg) + end if + end if + if (this%ivisc == 3) then + if (this%a5(iviscspec) == 0) then + write (warnmsg, '(a)') 'A5 WILL BE USED IN THE SELECTED VISCOSITY & + &CALCULATION BUT HAS BEEN SET EQUAL TO ZERO. CAREFULLY CONSIDER & + &WHETHER THE SPECIFIED VALUE OF 0.0 WAS INTENDED.' + call store_warning(errmsg) + end if + end if + if (this%ivisc == 2 .or. this%ivisc == 4) then + if (this%a5(iviscspec) /= 0) then + write (warnmsg, '(a)') 'VISCOSITY_FUNC SETTING DOES NOT REQUIRE & + &A5,BUT A5 WAS SPECIFIED. A5 WILL HAVE NO AFFECT ON SIMULATION & + &RESULTS.' + end if + end if + if (this%ivisc == 4) then + if (this%a3(iviscspec) /= 0) then + write (warnmsg, '(a)') 'VISCOSITY_FUNC SETTING DOES NOT REQUIRE & + &A3, BUT A3 WAS SPECIFIED. A3 WILL HAVE NO AFFECT ON SIMULATION & + &RESULTS.' + end if + if (this%a4(iviscspec) /= 0) then + write (warnmsg, '(a)') 'VISCOSITY_FUNC SETTING DOES NOT REQUIRE & + &A4, BUT A4 WAS SPECIFIED. A4 WILL HAVE NO AFFECT ON SIMULATION & + &RESULTS.' + end if + end if + !end if end do write (this%iout, '(1x,a)') 'END OF VSC PACKAGEDATA' end if + ! + ! -- terminate if errors + if (count_errors() > 0) then + call this%parser%StoreErrorUnit() + end if + ! ! -- Check for errors. if (count_errors() > 0) then @@ -616,6 +712,7 @@ subroutine allocate_scalars(this) call this%NumericalPackageType%allocate_scalars() ! ! -- Allocate + call mem_allocate(this%ivisc, 'IVISC', this%memoryPath) call mem_allocate(this%ioutvisc, 'IOUTVISC', this%memoryPath) call mem_allocate(this%ireadconcvsc, 'IREADCONCVSC', this%memoryPath) call mem_allocate(this%iconcset, 'ICONCSET', this%memoryPath) @@ -625,13 +722,13 @@ subroutine allocate_scalars(this) ! ! -- Initialize + this%ivisc = 0 this%ioutvisc = 0 this%iconcset = 0 this%ireadconcvsc = 0 this%viscref = 1000.d0 this%nviscspecies = 0 - ! ! -- Return return @@ -657,6 +754,10 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%concvsc, 0, 'CONCVSC', this%memoryPath) call mem_allocate(this%dviscdc, this%nviscspecies, 'DRHODC', this%memoryPath) call mem_allocate(this%cviscref, this%nviscspecies, 'CRHOREF', this%memoryPath) + call mem_allocate(this%a2, this%nviscspecies, 'A2', this%memoryPath) + call mem_allocate(this%a3, this%nviscspecies, 'A3', this%memoryPath) + call mem_allocate(this%a4, this%nviscspecies, 'A4', this%memoryPath) + call mem_allocate(this%a5, this%nviscspecies, 'A5', this%memoryPath) call mem_allocate(this%ctemp, this%nviscspecies, 'CTEMP', this%memoryPath) allocate (this%cmodelname(this%nviscspecies)) allocate (this%cauxspeciesname(this%nviscspecies)) @@ -671,9 +772,14 @@ subroutine allocate_arrays(this, nodes) do i = 1, this%nviscspecies this%dviscdc(i) = DZERO this%cviscref(i) = DZERO + this%A2(i) = DZERO + this%A3(i) = DZERO + this%A4(i) = DZERO + this%A5(i) = DZERO this%ctemp(i) = DZERO this%cmodelname(i) = '' this%cauxspeciesname(i) = '' + this%modelconc(i)%istmpr = 0 end do ! ! -- Return @@ -701,12 +807,16 @@ subroutine read_options(this) character(len=*), parameter :: fmtfileout = & "(4x, 'VSC ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & &a, /4x, 'OPENED ON UNIT: ', I7)" + character(len=*), parameter :: fmtlinear = & + "(4x, 'VISCOSITY WILL VARY LINEARLY WITH TEMPERATURE CHANGE. ')" character(len=*), parameter :: fmtvoss = & - "(4x, 'VISCOSITY CALCULATION ADOPTS FORMULA OFFERED IN VOSS (1984). ')" + "(4x, 'VISCOSITY WILL VARY NON-LINEARLY USING FORMULA OFFERED & + &IN VOSS (1984). ')" character(len=*), parameter :: fmtpawlowski = & - "(4x, 'VISCOSITY CALCULATION ADOPTS FORMULA OFFERED IN PAWLOWSKI (1991).')" + "(4x, 'VISCOSITY WILL VARY NON-LINEARLY USING FORMULA OFFERED & + &IN PAWLOWSKI (1991).')" character(len=*), parameter :: fmtguo = & - "(4x, 'VISCOSITY CALCULATION ADOPTS FORMULA OFFERED IN GUO AND & + "(4x, 'VISCOSITY WILL VARY NON-LINEARLY USING FORMULA OFFERED IN GUO AND & &ZHOU (2005). THIS RELATIONSHIP IS FOR OIL VISCOSITY AS A FUNCTION & &OF TEMPERATURE (BETWEEN 5 AND 170 DECREES CELSIUS). RELATION IS & &NOT APPLICABLE TO WATER.')" @@ -745,15 +855,18 @@ subroutine read_options(this) end if case ('VISCOSITY_FUNC') call this%parser%GetStringCaps(keyword2) - if (trim(adjustl(keyword2)) == 'VOSS') this%ivisc = 1 - if (trim(adjustl(keyword2)) == 'PAWLOWSKI') this%ivisc = 2 - if (trim(adjustl(keyword2)) == 'GUO') this%ivisc = 3 + if (trim(adjustl(keyword2)) == 'LINEAR') this%ivisc = 1 + if (trim(adjustl(keyword2)) == 'VOSS') this%ivisc = 2 + if (trim(adjustl(keyword2)) == 'PAWLOWSKI') this%ivisc = 3 + if (trim(adjustl(keyword2)) == 'GUO') this%ivisc = 4 select case (this%ivisc) case (1) - write (this%iout, fmtvoss) + write (this%iout, fmtlinear) case (2) - write (this%iout, fmtpawlowski) + write (this%iout, fmtvoss) case (3) + write (this%iout, fmtpawlowski) + case (4) write (this%iout, fmtguo) end select case default @@ -769,7 +882,7 @@ subroutine read_options(this) ! -- Return return end subroutine read_options - + !> @brief Sets options as opposed to reading them from a file !< subroutine set_options(this, input_data) From 1d61697d04e80304efb28b8a0f93691c4aeb92b7 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Fri, 29 Jul 2022 15:54:08 -0400 Subject: [PATCH 030/212] In GwfVscModule: * Added store_warning to the list of SimModule procedures used * Pending another approach to identifying a temperature "species", commented out the two lines that refer to GwfModelType to avoid circular dependency --- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 77fa80ae92d..2664b6511ed 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -3,7 +3,7 @@ module GwfVscModule use KindModule, only: DP, I4B - use SimModule, only: store_error, count_errors + use SimModule, only: store_error, count_errors, store_warning use MemoryManagerModule, only: mem_allocate, mem_reallocate, & mem_deallocate use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, & @@ -13,7 +13,7 @@ module GwfVscModule use GwfNpfModule, only: GwfNpfType use GwfVscInputDataModule, only: GwfVscInputDataType use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use GwfModule, only: GwfModelType +! use GwfModule, only: GwfModelType ! kluge note: circular dependency use GwtModule, only: GwtModelType use GweModule, only: GweModelType @@ -483,7 +483,7 @@ subroutine read_packagedata(this) class(GwfVscType) :: this ! -- local class(BaseModelType), pointer :: mb => null() - type(GwfModelType), pointer :: gwfmodel => null() +! type(GwfModelType), pointer :: gwfmodel => null() ! kluge note: circular dependency type(GwtModelType), pointer :: gwtmodel => null() type(GweModelType), pointer :: gwemodel => null() character(len=LINELENGTH) :: warnmsg, errmsg From 71c6681819bda5a9c8da22bbdc6343de575c2147 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 29 Jul 2022 21:10:13 -0700 Subject: [PATCH 031/212] Fixed issue that was preventing solution from building (basically the same fixes as what Alden came up with), plus a work around for how to set istmpr (short for "is temperature"; a way to flag that the species being pointed to is infact a temperature species. --- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 30 ++++++++++++++------ src/Model/ModelUtilities/GwfVscInputData.f90 | 1 - 2 files changed, 22 insertions(+), 9 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 77fa80ae92d..74a7c8059ec 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -3,7 +3,7 @@ module GwfVscModule use KindModule, only: DP, I4B - use SimModule, only: store_error, count_errors + use SimModule, only: store_error, store_warning, count_errors use MemoryManagerModule, only: mem_allocate, mem_reallocate, & mem_deallocate use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, & @@ -13,9 +13,9 @@ module GwfVscModule use GwfNpfModule, only: GwfNpfType use GwfVscInputDataModule, only: GwfVscInputDataType use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use GwfModule, only: GwfModelType use GwtModule, only: GwtModelType use GweModule, only: GweModelType + use ListsModule, only: basemodellist implicit none @@ -155,7 +155,7 @@ subroutine vsc_df(this, dis, vsc_input) ! -- local ! -- formats character(len=*), parameter :: fmtvsc = & - "(1x,/1x,'VSC -- VISCOSITY PACKAGE, VERSION 1, 5/16/2018', & + "(1x,/1x,'VSC -- VISCOSITY PACKAGE, VERSION 1, 9/30/2023', & &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! @@ -483,13 +483,13 @@ subroutine read_packagedata(this) class(GwfVscType) :: this ! -- local class(BaseModelType), pointer :: mb => null() - type(GwfModelType), pointer :: gwfmodel => null() type(GwtModelType), pointer :: gwtmodel => null() type(GweModelType), pointer :: gwemodel => null() character(len=LINELENGTH) :: warnmsg, errmsg character(len=LINELENGTH) :: line character(len=LENMODELNAME) :: mname integer(I4B) :: ierr + integer(I4B) :: im integer(I4B) :: iviscspec logical :: isfound, endOfBlock logical :: blockrequired @@ -541,12 +541,27 @@ subroutine read_packagedata(this) call this%parser%GetStringCaps(this%cmodelname(iviscspec)) call this%parser%GetStringCaps(this%cauxspeciesname(iviscspec)) ! - ! -- check if modelname corresponds to a GWE model, and, if so + ! -- Check if modelname corresponds to a GWE model, and, if so ! set istmpr ("is temperature") equal to 1 to signify species is GWE mname = this%cmodelname(iviscspec) - + do im = 1, basemodellist%Count() + mb => GetBaseModelFromList(basemodellist, im) + ! -- Check if GWE model type in list and flag + if (mb%macronym == 'GWE') then + !-- Ensure user-specified modelname corresponds to the GWE model name + ! in mb (There can be only one GWE model per GWF model) + if (mb%name == mname) then + this%modelconc(iviscspec)%istmpr = 1 + else + write (errmsg, '(a,a,a)') 'MODEL NAME PROVIDED IN VSC & + &PACKAGEDATA BLOCK, ', trim(mname), ', DOES NOT MATCH KNOWN & + &GWE MODEL TYPE.' + call store_error(errmsg) + end if + end if + end do ! - ! -- Check for errors, and when helpful issue warnings + ! -- Check for errors or issue warnings if appropriate !if (this%modelconc(iviscspec)%istmpr == 1) then if (this%ivisc == 1) then if (this%a2(iviscspec) == 0.0) then @@ -612,7 +627,6 @@ subroutine read_packagedata(this) if (count_errors() > 0) then call this%parser%StoreErrorUnit() end if - ! ! -- Check for errors. if (count_errors() > 0) then diff --git a/src/Model/ModelUtilities/GwfVscInputData.f90 b/src/Model/ModelUtilities/GwfVscInputData.f90 index 1be5272892f..9786d78bea5 100644 --- a/src/Model/ModelUtilities/GwfVscInputData.f90 +++ b/src/Model/ModelUtilities/GwfVscInputData.f90 @@ -13,7 +13,6 @@ module GwfVscInputDataModule real(DP) :: viscref !< see VSC for description ! dim integer(I4B) :: nviscspecies !< see VSC for description - ! pkg data real(DP), dimension(:), pointer, contiguous :: dviscdc => null() !< see VSC for description real(DP), dimension(:), pointer, contiguous :: cviscref => null() !< see VSC for description From 84b9e9dd7eac372020d50e2dd05aaad0ced6fb98 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 3 Aug 2022 10:40:16 -0700 Subject: [PATCH 032/212] Some relatively minor alterations and clean-ups in VSC based on consult with Chris & Alden --- src/Exchange/GwfGweExchange.f90 | 4 + src/Model/GroundWaterFlow/gwf3.f90 | 2 +- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 246 ++++++++++--------------- 3 files changed, 106 insertions(+), 146 deletions(-) diff --git a/src/Exchange/GwfGweExchange.f90 b/src/Exchange/GwfGweExchange.f90 index e16655b8b61..1df74b3abf0 100644 --- a/src/Exchange/GwfGweExchange.f90 +++ b/src/Exchange/GwfGweExchange.f90 @@ -255,6 +255,10 @@ subroutine exg_ar(this) call gwfmodel%buy%set_concentration_pointer(gwemodel%name, gwemodel%x, & gwemodel%ibound) end if + if (gwfmodel%invsc > 0) then + call gwfmodel%vsc%set_concentration_pointer(gwemodel%name, gwemodel%x, & + gwemodel%ibound, 1) + end if ! ! -- transfer the boundary package information from gwf to gwe call this%gwfbnd2gwefmi() diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index ce5e9d46c0d..ffa4957d714 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -99,7 +99,7 @@ module GwfModule &'GHB6 ', 'RCH6 ', 'EVT6 ', 'OBS6 ', 'GNC6 ', & ! 15 &'API6 ', 'CHD6 ', ' ', ' ', ' ', & ! 20 &' ', 'MAW6 ', 'SFR6 ', 'LAK6 ', 'UZF6 ', & ! 25 - &'DISV6', 'MVR6 ', 'CSUB6', 'BUY6 ', ' ', & ! 30 + &'DISV6', 'MVR6 ', 'CSUB6', 'BUY6 ', 'VSC6 ', & ! 30 &70*' '/ contains diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 74a7c8059ec..af4ccc88804 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -12,9 +12,6 @@ module GwfVscModule use BaseDisModule, only: DisBaseType use GwfNpfModule, only: GwfNpfType use GwfVscInputDataModule, only: GwfVscInputDataType - use BaseModelModule, only: BaseModelType, GetBaseModelFromList - use GwtModule, only: GwtModelType - use GweModule, only: GweModelType use ListsModule, only: basemodellist implicit none @@ -26,12 +23,12 @@ module GwfVscModule type :: ConcentrationPointer real(DP), dimension(:), pointer :: conc => null() !< pointer to concentration array integer(I4B), dimension(:), pointer :: icbund => null() !< store pointer to gwt ibound array - integer(I4B), dimension(:), pointer :: istmpr => null() !< integer flag for identifying whether the "species" array is temperature end type ConcentrationPointer type, extends(NumericalPackageType) :: GwfVscType type(GwfNpfType), pointer :: npf => null() !< npf object integer(I4B), pointer :: ivisc => null() !< viscosity formulation flag (1:Voss (1984), 2:Pawlowski (1991), 3:Guo and Zhou (2005)) + integer(I4B), pointer :: idxtmpr => null() !< if greater than 0 then an index for identifying whether the "species" array is temperature integer(I4B), pointer :: ioutvisc => null() !< unit number for saving viscosity integer(I4B), pointer :: ireadconcvsc => null() !< if 1 then visc has been read from this vsc input file ! kluge note: is this ever really used? integer(I4B), pointer :: iconcset => null() !< if 1 then conc points to a gwt (or gwe) model%x array @@ -48,10 +45,9 @@ module GwfVscModule character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname !< names of aux columns used in viscosity equation ! ! -- Viscosity constants - real(DP), dimension(:), pointer, contiguous :: a2 => null() !< an empirical parameter specified by the user for calculating viscosity - real(DP), dimension(:), pointer, contiguous :: a3 => null() !< an empirical parameter specified by the user for calculating viscosity - real(DP), dimension(:), pointer, contiguous :: a4 => null() !< an empirical parameter specified by the user for calculating viscosity - real(DP), dimension(:), pointer, contiguous :: a5 => null() !< an empirical parameter specified by the user for calculating viscosity + real(DP), pointer :: a2 => null() !< an empirical parameter specified by the user for calculating viscosity + real(DP), pointer :: a3 => null() !< an empirical parameter specified by the user for calculating viscosity + real(DP), pointer :: a4 => null() !< an empirical parameter specified by the user for calculating viscosity type(ConcentrationPointer), allocatable, dimension(:) :: modelconc !< concentration (or temperature) pointer for each solute (or heat) transport model @@ -96,9 +92,22 @@ function calcvisc(viscref, dviscdc, cviscref, conc) result(visc) ! nviscspec = size(dviscdc) visc = viscref + do i = 1, nviscspec + ! if (i \= this%idxtmpr) then visc = visc + dviscdc(i) * (conc(i) - cviscref(i)) ! kluge note: linear for now + ! end if end do + + ! Order matters!! (This assumes we apply the temperature correction after + ! accounting for solute concentrations) + ! REMEMBER: idxtmpr + ! For the case i == idxtmpr + ! special multiplicative eqn here that leverages idxtmpr + ! - check to make sure that idxtmpr is not zero b/c that means there + ! is no temperature (remember to initialize idxtmpr to 0) + + ! ! -- return return @@ -234,7 +243,7 @@ subroutine vsc_rp(this) integer(I4B) :: i ! -- formats character(len=*), parameter :: fmtc = & - "('VISCOSITY PACKAGE DOES NOT HAVE HAVE A CONCENTRATION SET & + "('VISCOSITY PACKAGE DOES NOT HAVE A CONCENTRATION SET & &FOR SPECIES ',i0,'. ONE OR MORE MODEL NAMES MAY BE SPECIFIED & &INCORRECTLY IN THE PACKAGEDATA BLOCK OR A GWF-GWT EXCHANGE MAY NEED & &TO BE ACTIVATED.')" @@ -395,7 +404,6 @@ subroutine vsc_da(this) call mem_deallocate(this%a2) call mem_deallocate(this%a3) call mem_deallocate(this%a4) - call mem_deallocate(this%a5) deallocate (this%cmodelname) deallocate (this%cauxspeciesname) deallocate (this%modelconc) @@ -403,6 +411,7 @@ subroutine vsc_da(this) ! ! -- Scalars call mem_deallocate(this%ivisc) + call mem_deallocate(this%idxtmpr) call mem_deallocate(this%ioutvisc) call mem_deallocate(this%ireadconcvsc) call mem_deallocate(this%iconcset) @@ -482,9 +491,6 @@ subroutine read_packagedata(this) ! -- dummy class(GwfVscType) :: this ! -- local - class(BaseModelType), pointer :: mb => null() - type(GwtModelType), pointer :: gwtmodel => null() - type(GweModelType), pointer :: gwemodel => null() character(len=LINELENGTH) :: warnmsg, errmsg character(len=LINELENGTH) :: line character(len=LENMODELNAME) :: mname @@ -529,103 +535,22 @@ subroutine read_packagedata(this) call store_error(errmsg) end if itemp(iviscspec) = 1 - this%a2(iviscspec) = this%parser%GetDouble() - if (this%ivisc == 1) then - this%dviscdc(iviscspec) = this%a2(iviscspec) - end if - this%a3(iviscspec) = this%parser%GetDouble() - this%a4(iviscspec) = this%parser%GetDouble() - this%a5(iviscspec) = this%parser%GetDouble() ! this%cviscref(iviscspec) = this%parser%GetDouble() call this%parser%GetStringCaps(this%cmodelname(iviscspec)) call this%parser%GetStringCaps(this%cauxspeciesname(iviscspec)) ! - ! -- Check if modelname corresponds to a GWE model, and, if so - ! set istmpr ("is temperature") equal to 1 to signify species is GWE - mname = this%cmodelname(iviscspec) - do im = 1, basemodellist%Count() - mb => GetBaseModelFromList(basemodellist, im) - ! -- Check if GWE model type in list and flag - if (mb%macronym == 'GWE') then - !-- Ensure user-specified modelname corresponds to the GWE model name - ! in mb (There can be only one GWE model per GWF model) - if (mb%name == mname) then - this%modelconc(iviscspec)%istmpr = 1 - else - write (errmsg, '(a,a,a)') 'MODEL NAME PROVIDED IN VSC & - &PACKAGEDATA BLOCK, ', trim(mname), ', DOES NOT MATCH KNOWN & - &GWE MODEL TYPE.' - call store_error(errmsg) - end if - end if - end do - ! - ! -- Check for errors or issue warnings if appropriate - !if (this%modelconc(iviscspec)%istmpr == 1) then - if (this%ivisc == 1) then - if (this%a2(iviscspec) == 0.0) then - write(errmsg, '(a)') 'LINEAR OPTION SELECTED FOR VARYING & - &VISCOSITY, BUT A1, A SURROGATE FOR dVISC/dT, SET EQUAL TO 0.0' - call store_error(errmsg) - end if - end if - if (this%ivisc > 1) then - if(this%a2(iviscspec) == 0) then - write (warnmsg, '(a)') 'A1 SET EQUAL TO ZERO WHICH MAY LEAD TO & - &UNINTENDED VALUES FOR VISCOSITY' - call store_warning(errmsg) - end if - end if - if (this%ivisc == 2 .or. this%ivisc == 3) then - if (this%a3(iviscspec) == 0) then - write (warnmsg, '(a)') 'A3 WILL BE USED IN THE SELECTED VISCOSITY & - &CALCULATION BUT HAS BEEN SET EQUAL TO ZERO. CAREFULLY CONSIDER & - &WHETHER THE SPECIFIED VALUE OF 0.0 WAS INTENDED.' - call store_warning(warnmsg) - end if - if (this%a4(iviscspec) == 0) then - write (warnmsg, '(a)') 'A4 WILL BE USED IN THE SELECTED VISCOSITY & - &CALCULATION BUT HAS BEEN SET EQUAL TO ZERO. CAREFULLY CONSIDER & - &WHETHER THE SPECIFIED VALUE OF 0.0 WAS INTENDED.' - call store_warning(warnmsg) - end if - end if - if (this%ivisc == 3) then - if (this%a5(iviscspec) == 0) then - write (warnmsg, '(a)') 'A5 WILL BE USED IN THE SELECTED VISCOSITY & - &CALCULATION BUT HAS BEEN SET EQUAL TO ZERO. CAREFULLY CONSIDER & - &WHETHER THE SPECIFIED VALUE OF 0.0 WAS INTENDED.' - call store_warning(errmsg) - end if - end if - if (this%ivisc == 2 .or. this%ivisc == 4) then - if (this%a5(iviscspec) /= 0) then - write (warnmsg, '(a)') 'VISCOSITY_FUNC SETTING DOES NOT REQUIRE & - &A5,BUT A5 WAS SPECIFIED. A5 WILL HAVE NO AFFECT ON SIMULATION & - &RESULTS.' - end if - end if - if (this%ivisc == 4) then - if (this%a3(iviscspec) /= 0) then - write (warnmsg, '(a)') 'VISCOSITY_FUNC SETTING DOES NOT REQUIRE & - &A3, BUT A3 WAS SPECIFIED. A3 WILL HAVE NO AFFECT ON SIMULATION & - &RESULTS.' - end if - if (this%a4(iviscspec) /= 0) then - write (warnmsg, '(a)') 'VISCOSITY_FUNC SETTING DOES NOT REQUIRE & - &A4, BUT A4 WAS SPECIFIED. A4 WILL HAVE NO AFFECT ON SIMULATION & - &RESULTS.' - end if - end if - !end if + if (this%cauxspeciesname(iviscspec) == 'TEMPERATURE') then + if (this%idxtmpr > 0) then + write(errmsg, '(a)') 'MORE THAN ONE SPECIES IN VSC INPUT IDENTIFIED & + &AS "TEMPERATURE". ONLY ONE SPECIES MAY BE DESIGNATED AS & + &TEMPERATURE.' + call store_error(errmsg) + else + this%idxtmpr = iviscspec + endif + end if end do - write (this%iout, '(1x,a)') 'END OF VSC PACKAGEDATA' - end if - ! - ! -- terminate if errors - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() end if ! ! -- Check for errors. @@ -636,13 +561,11 @@ subroutine read_packagedata(this) ! -- write packagedata information write (this%iout, '(/,a)') 'SUMMARY OF SPECIES INFORMATION IN VSC PACKAGE' write (this%iout, '(1a11, 4a17)') & - 'SPECIES', 'DRHODC', 'CRHOREF', 'MODEL', & - 'AUXSPECIESNAME' + 'SPECIES', 'CVISCREF', 'MODEL', 'AUXSPECIESNAME' do iviscspec = 1, this%nviscspecies write (c10, '(i0)') iviscspec line = ' '//adjustr(c10) - write (c16, '(g15.6)') this%dviscdc(iviscspec) - line = trim(line)//' '//adjustr(c16) + write (c16, '(g15.6)') this%cviscref(iviscspec) line = trim(line)//' '//adjustr(c16) write (c16, '(a)') this%cmodelname(iviscspec) @@ -655,6 +578,8 @@ subroutine read_packagedata(this) ! -- deallocate deallocate (itemp) ! + write (this%iout, '(1x,a)') 'END OF VSC PACKAGEDATA' + ! ! -- return return end subroutine read_packagedata @@ -727,21 +652,28 @@ subroutine allocate_scalars(this) ! ! -- Allocate call mem_allocate(this%ivisc, 'IVISC', this%memoryPath) + call mem_allocate(this%idxtmpr, 'IDXTMPR', this%memoryPath) call mem_allocate(this%ioutvisc, 'IOUTVISC', this%memoryPath) call mem_allocate(this%ireadconcvsc, 'IREADCONCVSC', this%memoryPath) call mem_allocate(this%iconcset, 'ICONCSET', this%memoryPath) call mem_allocate(this%viscref, 'VISCREF', this%memoryPath) - + call mem_allocate(this%a2, 'A2', this%memoryPath) + call mem_allocate(this%a3, 'A3', this%memoryPath) + call mem_allocate(this%a4, 'A4', this%memoryPath) + ! call mem_allocate(this%nviscspecies, 'NVISCSPECIES', this%memoryPath) - ! ! -- Initialize this%ivisc = 0 + this%idxtmpr = 0 this%ioutvisc = 0 this%iconcset = 0 this%ireadconcvsc = 0 this%viscref = 1000.d0 - + this%A2 = DZERO + this%A3 = DZERO + this%A4 = DZERO + ! this%nviscspecies = 0 ! ! -- Return @@ -768,10 +700,6 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%concvsc, 0, 'CONCVSC', this%memoryPath) call mem_allocate(this%dviscdc, this%nviscspecies, 'DRHODC', this%memoryPath) call mem_allocate(this%cviscref, this%nviscspecies, 'CRHOREF', this%memoryPath) - call mem_allocate(this%a2, this%nviscspecies, 'A2', this%memoryPath) - call mem_allocate(this%a3, this%nviscspecies, 'A3', this%memoryPath) - call mem_allocate(this%a4, this%nviscspecies, 'A4', this%memoryPath) - call mem_allocate(this%a5, this%nviscspecies, 'A5', this%memoryPath) call mem_allocate(this%ctemp, this%nviscspecies, 'CTEMP', this%memoryPath) allocate (this%cmodelname(this%nviscspecies)) allocate (this%cauxspeciesname(this%nviscspecies)) @@ -786,14 +714,9 @@ subroutine allocate_arrays(this, nodes) do i = 1, this%nviscspecies this%dviscdc(i) = DZERO this%cviscref(i) = DZERO - this%A2(i) = DZERO - this%A3(i) = DZERO - this%A4(i) = DZERO - this%A5(i) = DZERO this%ctemp(i) = DZERO this%cmodelname(i) = '' this%cauxspeciesname(i) = '' - this%modelconc(i)%istmpr = 0 end do ! ! -- Return @@ -813,27 +736,21 @@ subroutine read_options(this) ! -- dummy class(GwfVscType) :: this ! -- local - character(len=LINELENGTH) :: errmsg, keyword, keyword2 + character(len=LINELENGTH) :: warnmsg, errmsg, keyword, keyword2 character(len=MAXCHARLEN) :: fname + character(len=LINELENGTH) :: line + character(len=10) :: c10 + character(len=16) :: c16 integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtfileout = & - "(4x, 'VSC ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', & + "(x, 'VSC', 1x, a, 1x, 'WILL BE SAVED TO FILE: ', & &a, /4x, 'OPENED ON UNIT: ', I7)" character(len=*), parameter :: fmtlinear = & - "(4x, 'VISCOSITY WILL VARY LINEARLY WITH TEMPERATURE CHANGE. ')" - character(len=*), parameter :: fmtvoss = & - "(4x, 'VISCOSITY WILL VARY NON-LINEARLY USING FORMULA OFFERED & - &IN VOSS (1984). ')" - character(len=*), parameter :: fmtpawlowski = & - "(4x, 'VISCOSITY WILL VARY NON-LINEARLY USING FORMULA OFFERED & - &IN PAWLOWSKI (1991).')" - character(len=*), parameter :: fmtguo = & - "(4x, 'VISCOSITY WILL VARY NON-LINEARLY USING FORMULA OFFERED IN GUO AND & - &ZHOU (2005). THIS RELATIONSHIP IS FOR OIL VISCOSITY AS A FUNCTION & - &OF TEMPERATURE (BETWEEN 5 AND 170 DECREES CELSIUS). RELATION IS & - &NOT APPLICABLE TO WATER.')" + "(/,x,'VISCOSITY WILL VARY LINEARLY WITH TEMPERATURE CHANGE ')" + character(len=*), parameter :: fmtnonlinear = & + "(/,x,'VISCOSITY WILL VARY NON-LINEARLY WITH TEMPERATURE CHANGE ')" ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -870,29 +787,67 @@ subroutine read_options(this) case ('VISCOSITY_FUNC') call this%parser%GetStringCaps(keyword2) if (trim(adjustl(keyword2)) == 'LINEAR') this%ivisc = 1 - if (trim(adjustl(keyword2)) == 'VOSS') this%ivisc = 2 - if (trim(adjustl(keyword2)) == 'PAWLOWSKI') this%ivisc = 3 - if (trim(adjustl(keyword2)) == 'GUO') this%ivisc = 4 + if (trim(adjustl(keyword2)) == 'NONLINEAR') this%ivisc = 2 select case (this%ivisc) case (1) write (this%iout, fmtlinear) case (2) - write (this%iout, fmtvoss) - case (3) - write (this%iout, fmtpawlowski) - case (4) - write (this%iout, fmtguo) + write (this%iout, fmtnonlinear) + this%a2 = this%parser%GetDouble() + this%a3 = this%parser%GetDouble() + this%a4 = this%parser%GetDouble() + ! + ! -- Write viscosity function selection to lst file + write (this%iout, '(/,x,a,a,a)') 'CONSTANTS USED IN ', & + trim(keyword2), ' VISCOSITY FORMULATION ARE ' + write(this%iout, '(x,a)') & + ' A2, A3, A4' + line = ' ' + write (c16, '(g15.6)') this%a2 + line = trim(line)//' '//adjustr(c16) + write (c16, '(g15.6)') this%a3 + line = trim(line)//' '//adjustr(c16) + write (c16, '(g15.6)') this%a4 + line = trim(line)//' '//adjustr(c16) + write (this%iout, '(a)') trim(line) + end select case default - write (errmsg, '(4x,a,a)') '****ERROR. UNKNOWN VSC OPTION: ', & + write (errmsg, '(4x,a,a)') '**ERROR. UNKNOWN VSC OPTION: ', & trim(keyword) call store_error(errmsg) call this%parser%StoreErrorUnit() end select end do - write (this%iout, '(1x,a)') 'END OF VSC OPTIONS' + ! + if (this%ivisc == 1) then + if (this%a2 == 0.0) then + write(errmsg, '(a)') 'LINEAR OPTION SELECTED FOR VARYING & + &VISCOSITY, BUT A1, A SURROGATE FOR dVISC/dT, SET EQUAL TO 0.0' + call store_error(errmsg) + end if + end if + if (this%ivisc > 1) then + if(this%a2 == 0) then + write (warnmsg, '(a)') 'A2 SET EQUAL TO ZERO WHICH MAY LEAD TO & + &UNINTENDED VALUES FOR VISCOSITY' + call store_warning(errmsg) + end if + if (this%a3 == 0) then + write (warnmsg, '(a)') 'A3 SET EQUAL TO ZERO WHICH MAY LEAD TO & + &UNINTENDED VALUES FOR VISCOSITY' + call store_warning(warnmsg) + end if + if (this%a4 == 0) then + write (warnmsg, '(a)') 'A4 SET EQUAL TO ZERO WHICH MAY LEAD TO & + &UNINTENDED VALUES FOR VISCOSITY' + call store_warning(warnmsg) + end if + end if end if ! + write (this%iout, '(/,x,a)') 'END OF VSC OPTIONS' + ! ! -- Return return end subroutine read_options @@ -908,7 +863,7 @@ subroutine set_options(this, input_data) end subroutine set_options - subroutine set_concentration_pointer(this, modelname, conc, icbund) + subroutine set_concentration_pointer(this, modelname, conc, icbund, istmpr) ! ****************************************************************************** ! set_concentration_pointer -- pass in a gwt model name, concentration array ! and ibound, and store a pointer to these in the VSC package so that @@ -924,6 +879,7 @@ subroutine set_concentration_pointer(this, modelname, conc, icbund) character(len=LENMODELNAME), intent(in) :: modelname real(DP), dimension(:), pointer :: conc integer(I4B), dimension(:), pointer :: icbund + integer(I4B), intent(in) :: istmpr ! -- local integer(I4B) :: i logical :: found From d02d57c3889c6694a5128fab12d8fbb98b9c97e4 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 10 Aug 2022 12:28:53 -0700 Subject: [PATCH 033/212] More work on VSC package, including a .dfn file and start of a single species test problem. --- autotest/ex-gwt-vsc01.py | 349 +++++++++++++++++++++++++ doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn | 185 +++++++++++++ doc/mf6io/mf6ivar/mf6ivar.py | 1 + src/Exchange/GwfGwtExchange.f90 | 8 +- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 59 ++++- 5 files changed, 587 insertions(+), 15 deletions(-) create mode 100644 autotest/ex-gwt-vsc01.py create mode 100644 doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn diff --git a/autotest/ex-gwt-vsc01.py b/autotest/ex-gwt-vsc01.py new file mode 100644 index 00000000000..c7b17087e43 --- /dev/null +++ b/autotest/ex-gwt-vsc01.py @@ -0,0 +1,349 @@ +# ## Test problem for VSC +# +# Model domain is lifted from the Henry Problem +# + +# ### VSC Problem Setup + +# Imports + +import os +import sys +import matplotlib.pyplot as plt +import flopy +import numpy as np + +# Append to system path to include the common subdirectory + +sys.path.append(os.path.join("..", "common")) + +# Import common functionality + +import config +from figspecs import USGSFigure + +mf6exe = os.path.abspath(config.mf6_exe) + + +# Set figure properties specific to this problem + +figure_size = (6, 4) + +# Base simulation and model name and workspace + +ws = os.path.join('temp', 'examples', 'vsc-henry') + +# Scenario parameters - make sure there is at least one blank line before next item + +parameters = { + "ex-gwt-vsc-a": {"vsc_on": False,}, + "ex-gwt-vsc-b": {"vsc_on": True,}, +} + +# Model units + +length_units = "cm" +time_units = "seconds" + +# Table of model parameters + +nper = 1 # Number of periods +nstp = 500 # Number of time steps +perlen = 0.5 # Simulation time length ($d$) +nlay = 1 # Number of layers +nrow = 40 # Number of rows +ncol = 80 # Number of columns +system_length = 2.0 # Length of system ($m$) +delr = 0.025 # Column width ($m$) +delc = 1.0 # Row width ($m$) +delv = 0.025 # Layer thickness +top = 1.0 # Top of the model ($m$) +hydraulic_conductivity = 864.0 # Hydraulic conductivity ($m d^{-1}$) +initial_temperature = 35.0 # Initial temperature (unitless) +porosity = 0.26 # porosity (unitless) +K_therm = 2.0 # Thermal conductivity # ($W/m/C$) +rho_water = 1000 # Density of water ($kg/m^3$) +rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) +C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) +C_s = 880 # Heat capacity of the solids ($J/kg/C$) +D_m = K_therm / (porosity * rho_water * C_p_w) +rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) +K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) +inflow = 5.7024 # ($m^3/d$) + +botm = [top - k * delv for k in range(1, nlay + 1)] + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-10, 1e-6, 0.97 + + +# ### Functions to build, write, run, and plot models +# +# MODFLOW 6 flopy GWF simulation object (sim) is returned +# + + +def build_model(sim_folder, vsc_on): + print("Building model...{}".format(sim_folder)) + + # generate names for each model + name = "vsc01" + gwfname = "gwf_" + name + gwtname = "gwt_" + name + + sim_ws = os.path.join(ws, sim_folder) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe + ) + tdis_ds = ((perlen, nstp, 1.0),) + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=tdis_ds, time_units=time_units + ) + gwf = flopy.mf6.ModflowGwf(sim, modelname=gwfname, save_flows=True) + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(ims, [gwfname]) + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=0, + k=hydraulic_conductivity, + ) + flopy.mf6.ModflowGwfic(gwf, strt=0.0) + + # Attempting to instantiate VSC after creating a definition file + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, 20.0, gwtname, "temperature")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=8.904e-4, + viscosity_filerecord=vsc_filerecord, + viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname='vsc', + filename="{}.vsc".format(gwfname) + ) + + # Instantiating GHB + ghbcond = hydraulic_conductivity * delv * delc / (0.5 * delr) + ghbspd = [[(k, 0, ncol - 1), top, ghbcond, 35.0] for k in range(nlay)] + flopy.mf6.ModflowGwfghb( + gwf, + stress_period_data=ghbspd, + pname="GHB-1", + auxiliary="temperature", + ) + + # Instantiating WEL + welspd = [[(k, 0, 0), inflow / nlay, 0.0] for k in range(nlay)] + flopy.mf6.ModflowGwfwel( + gwf, + stress_period_data=welspd, + pname="WEL-1", + auxiliary="temperature", + ) + head_filerecord = "{}.hds".format(name) + budget_filerecord = "{}.bud".format(name) + + # Instatiatingi OC + flopy.mf6.ModflowGwfoc( + gwf, + head_filerecord=head_filerecord, + budget_filerecord=budget_filerecord, + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # Setup the GWT model for simulating heat transport + gwt = flopy.mf6.ModflowGwt(sim, modelname=gwtname) + imsgwt = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwtname), + ) + sim.register_ims_package(imsgwt, [gwtname]) + flopy.mf6.ModflowGwtdis( + gwt, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + + flopy.mf6.ModflowGwtmst( + gwt, + porosity=porosity, + sorption='linear', + bulk_density=rhob, + distcoef=K_d, + pname="MST-1", + filename="{}.mst".format(gwtname), + ) + + flopy.mf6.ModflowGwtic(gwt, strt=initial_temperature) + flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") + flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) + sourcerecarray = [ + ("GHB-1", "AUX", "TEMPERATURE"), + ("WEL-1", "AUX", "TEMPERATURE"), + ] + flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) + flopy.mf6.ModflowGwtoc( + gwt, + concentration_filerecord="{}.ucn".format(gwtname), + saverecord=[("CONCENTRATION", "ALL")], + printrecord=[("CONCENTRATION", "LAST"), ("BUDGET", "LAST")], + ) + flopy.mf6.ModflowGwfgwt( + sim, + exgtype="GWF6-GWT6", + exgmnamea=gwfname, + exgmnameb=gwtname + ) + return sim + + +# Function to write model files + + +def write_model(sim, silent=True): + if config.writeModel: + sim.write_simulation(silent=silent) + return + + +# Function to run the model +# True is returned if the model runs successfully + + +@config.timeit +def run_model(sim, silent=True): + success = True + if config.runModel: + success = False + success, buff = sim.run_simulation(silent=silent) + if not success: + print(buff) + return success + + +# Function to plot the model results + + +def plot_conc(sim, idx): + fs = USGSFigure(figure_type="map", verbose=False) + sim_name = list(parameters.keys())[idx] + sim_ws = os.path.join(ws, sim_name) + gwf = sim.get_model("flow") + gwt = sim.get_model("trans") + + fig = plt.figure(figsize=figure_size) + fig.tight_layout() + + # get MODFLOW 6 temperature + conc = gwt.output.temperature().get_data() + + ax = fig.add_subplot(1, 1, 1, aspect="equal") + pxs = flopy.plot.PlotCrossSection(model=gwf, ax=ax, line={"row": 0}) + pxs.plot_array(conc, cmap="jet") + levels = [35 * f for f in [0.01, 0.1, 0.5, 0.9, 0.99]] + cs = pxs.contour_array( + conc, levels=levels, colors="w", linewidths=1.0, linestyles="-" + ) + ax.set_xlabel("x position (m)") + ax.set_ylabel("z position (m)") + plt.clabel(cs, fmt="%4.2f", fontsize=5) + + # save figure + if config.plotSave: + fpth = os.path.join( + "..", "figures", "{}-conc{}".format(sim_name, config.figure_ext) + ) + fig.savefig(fpth) + return + + +def plot_results(sim, idx): + if config.plotModel: + plot_conc(sim, idx) + return + + +# Function that wraps all of the steps for each scenario +# +# 1. build_model, +# 2. write_model, +# 3. run_model, and +# 4. plot_results. +# + + +def scenario(idx, silent=True): + key = list(parameters.keys())[idx] + parameter_dict = parameters[key] + sim = build_model(key, **parameter_dict) + write_model(sim, silent=silent) + success = run_model(sim, silent=silent) + if success: + plot_results(sim, idx) + + +# nosetest - exclude block from this nosetest to the next nosetest +def test_01(): + scenario(0, silent=False) + + +def test_02(): + scenario(1, silent=False) + + +# nosetest end + +if __name__ == "__main__": + # ### Henry Problem + + # Scenario 1 - Classic henry problem + + scenario(0) + + # Scenario 2 - Modified Henry problem with half the inflow rate + + scenario(1) diff --git a/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn b/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn new file mode 100644 index 00000000000..e239528b912 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn @@ -0,0 +1,185 @@ +# --------------------- gwf vsc options --------------------- + +block options +name viscref +type double +reader urword +optional true +longname reference viscosity +description fluid reference viscosity used in the equation of state. This value is set to 1.0 if not specified as an option. +default_value 1.0 + +block options +name viscosity_filerecord +type record viscosity fileout viscosityfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name viscosity +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname viscosity keyword +description keyword to specify that record corresponds to viscosity. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name viscosityfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write viscosity information. The viscosity file has the same format as the head file. Viscosity values will be written to the viscosity file whenever heads are written to the binary head file. The settings for controlling head output are contained in the Output Control option. + +block options +name viscosityfuncrecord +type record viscosity_func formulation a2 a3 a4 +reader urword +optional true +longname +description + +block options +name viscosity_func +type keyword +shape +in_record true +tagged true +reader urword +optional false +longname keyword to specify viscosity formulation +description may be used for specifying which viscosity formulation to use. The linear viscosity formulation is the default. + +block options +name formulation +type string +reader urword +optional false +valid linear nonlinear +longname keyword to specify viscosity formulation +description may be used for specifying which viscosity formulation to use. The linear viscosity formulation is the default. + + +block options +name a2 +type double precision +in_record true +reader urword +optional true +longname coefficient used in nonlinear viscosity function +description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned based on Voss (1984). + +block options +name a3 +type double precision +in_record true +reader urword +optional true +longname coefficient used in nonlinear viscosity function +description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned based on Voss (1984). + +block options +name a4 +type double precision +in_record true +reader urword +optional true +longname coefficient used in nonlinear viscosity function +description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned based on Voss (1984). + + + +# --------------------- gwf vsc dimensions --------------------- + +block dimensions +name nviscspecies +type integer +reader urword +optional false +longname number of species used in viscosity equation of state +description number of species used in the viscosity equation of state. If either concentrations or temperature (or both) are used to update viscosity then then nrhospecies needs to be at least one. + + +# --------------------- gwf vsc packagedata --------------------- + +block packagedata +name packagedata +type recarray iviscspec dviscdc cviscref modelname auxspeciesname +shape (nrhospecies) +reader urword +longname +description + +block packagedata +name iviscspec +type integer +shape +tagged false +in_record true +reader urword +longname species number for this entry +description integer value that defines the species number associated with the specified PACKAGEDATA data entered on each line. IVISCSPECIES must be greater than zero and less than or equal to NVISCSPECIES. Information must be specified for each of the NVISCSPECIES species or the program will terminate with an error. The program will also terminate with an error if information for a species is specified more than once. +numeric_index true + +block packagedata +name dviscdc +type double precision +shape +tagged false +in_record true +reader urword +longname slope of the line that defines the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. +description real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. + +block packagedata +name cviscref +type double precision +shape +tagged false +in_record true +reader urword +longname reference temperature value or reference concentration value +description real value that defines the reference temperature or reference concentration value used for this species in the viscosity equation of state. If AUXSPECIESNAME entered on a line is TEMPERATURE, then CVISCREF refers to a reference temperature, otherwise it refers to a reference concentration. + +block packagedata +name modelname +type string +in_record true +tagged false +shape +reader urword +longname modelname +description name of a GWT (or eventuallky a GWE) model used to simulate a species that will be used in the viscosity equation of state. This name will have no effect if the simulation does not include a GWT model that corresponds to this GWF model. + +block packagedata +name auxspeciesname +type string +in_record true +tagged false +shape +reader urword +longname auxspeciesname +description name of an auxiliary variable in a GWF stress package that will be used for this species to calculate the viscosity values. If a viscosity value is needed by the Viscosity Package then it will use the temperature or concentration values associated with this AUXSPECIESNAME in the viscosity equation of state. For advanced stress packages (LAK, SFR, MAW, and UZF) that have an associated advanced transport package (LKT, SFT, MWT, and UZT), the FLOW\_PACKAGE\_AUXILIARY\_NAME option in the advanced transport package can be used to transfer simulated temperature or concentration(s) into the flow package auxiliary variable. In this manner, the Viscosity Package can calculate viscosity values for lakes, streams, multi-aquifer wells, and unsaturated zone flow cells using simulated concentrations. + diff --git a/doc/mf6io/mf6ivar/mf6ivar.py b/doc/mf6io/mf6ivar/mf6ivar.py index ed674d84f1a..6e8b1c8d1ac 100644 --- a/doc/mf6io/mf6ivar/mf6ivar.py +++ b/doc/mf6io/mf6ivar/mf6ivar.py @@ -665,6 +665,7 @@ def write_appendix(texdir, allblocks): 'gwf-mvr', # dfn completed tex updated 'gwf-gnc', # dfn completed tex updated 'gwf-oc', # dfn completed tex updated + 'gwf-vsc', 'gwf-api', 'gwt-adv', 'gwt-dsp', diff --git a/src/Exchange/GwfGwtExchange.f90 b/src/Exchange/GwfGwtExchange.f90 index 494a9afa229..deae8da3cc0 100644 --- a/src/Exchange/GwfGwtExchange.f90 +++ b/src/Exchange/GwfGwtExchange.f90 @@ -260,12 +260,18 @@ subroutine exg_ar(this) end if end if ! - ! -- Set a pointer to conc + ! -- Set a pointer to conc in buy if (gwfmodel%inbuy > 0) then call gwfmodel%buy%set_concentration_pointer(gwtmodel%name, gwtmodel%x, & gwtmodel%ibound) end if ! + ! -- Set a pointer to conc (which could be a temperature) in vsc + if (gwfmodel%invsc > 0) then + call gwfmodel%vsc%set_concentration_pointer(gwtmodel%name, gwtmodel%x, & + gwtmodel%ibound) + end if + ! ! -- transfer the boundary package information from gwf to gwt call this%gwfbnd2gwtfmi() ! diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index af4ccc88804..bfe154e06cf 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -40,7 +40,7 @@ module GwfVscModule integer(I4B), pointer :: nviscspecies => null() !< number of concentration species used in viscosity equation real(DP), dimension(:), pointer, contiguous :: dviscdc => null() !< change in viscosity with change in concentration ! kluge note: parameters will depend on formula; linear for now real(DP), dimension(:), pointer, contiguous :: cviscref => null() !< reference concentration used in viscosity equation - real(DP), dimension(:), pointer, contiguous :: ctemp => null() !< temporary array of size (nviscspec) to pass to calcvisc + real(DP), dimension(:), pointer, contiguous :: ctemp => null() !< temporary array of size (nviscspec) to pass to calc_visc_x character(len=LENMODELNAME), dimension(:), allocatable :: cmodelname !< names of gwt (or gwe) models used in viscosity equation character(len=LENAUXNAME), dimension(:), allocatable :: cauxspeciesname !< names of aux columns used in viscosity equation ! @@ -71,34 +71,51 @@ module GwfVscModule contains - function calcvisc(viscref, dviscdc, cviscref, conc) result(visc) + function calc_visc(ivisc, viscref, dviscdc, cviscref, conc, & + a2, a3, a4) result(visc) ! ****************************************************************************** -! calcvisc -- generic function to calculate fluid viscosity from concentration +! calc_visc -- generic function to calculate changes in fluid viscosity +! using a linear formulation ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- dummy + integer(I4B), intent(in) :: ivisc real(DP), intent(in) :: viscref real(DP), dimension(:), intent(in) :: dviscdc real(DP), dimension(:), intent(in) :: cviscref real(DP), dimension(:), intent(in) :: conc + real(DP), intent(in) :: a2, a3, a4 ! -- return real(DP) :: visc ! -- local integer(I4B) :: nviscspec integer(I4B) :: i + real(DP) :: mu_t + real(DP) :: expon ! ------------------------------------------------------------------------------ ! nviscspec = size(dviscdc) visc = viscref do i = 1, nviscspec - ! if (i \= this%idxtmpr) then - visc = visc + dviscdc(i) * (conc(i) - cviscref(i)) ! kluge note: linear for now + if (ivisc == 1) then + visc = visc + dviscdc(i) * (conc(i) - cviscref(i)) ! kluge note: linear for now + else + expon = -1 * ((conc(i) - cviscref(i)) / & + ((conc(i) + a4) * (cviscref(i) + a4))) + mu_t = viscref * a2 ** expon + ! If a nonlinear correction is applied, then b/c it takes into account + ! viscref, need to subtract it in this case + ! At most, there will only ever be 1 nonlinear correction + visc = (visc - viscref) + mu_t + end if ! end if end do + ! NOTES (from in-person meeting with Alden) ! Order matters!! (This assumes we apply the temperature correction after ! accounting for solute concentrations) ! REMEMBER: idxtmpr @@ -111,7 +128,7 @@ function calcvisc(viscref, dviscdc, cviscref, conc) result(visc) ! ! -- return return - end function calcvisc + end function calc_visc subroutine vsc_cr(vscobj, name_model, inunit, iout) ! ****************************************************************************** @@ -327,7 +344,7 @@ function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & ctemp(i) = auxvar(locconc(i), n) end if end do - viscbnd = calcvisc(viscref, dviscdc, cviscref, ctemp) + ! viscbnd = calc_visc_lin(viscref, dviscdc, cviscref, ctemp) else ! -- neither of the above, so assign as viscref viscbnd = viscref @@ -536,6 +553,7 @@ subroutine read_packagedata(this) end if itemp(iviscspec) = 1 ! + this%dviscdc(iviscspec) = this%parser%GetDouble() this%cviscref(iviscspec) = this%parser%GetDouble() call this%parser%GetStringCaps(this%cmodelname(iviscspec)) call this%parser%GetStringCaps(this%cauxspeciesname(iviscspec)) @@ -559,13 +577,15 @@ subroutine read_packagedata(this) end if ! ! -- write packagedata information - write (this%iout, '(/,a)') 'SUMMARY OF SPECIES INFORMATION IN VSC PACKAGE' - write (this%iout, '(1a11, 4a17)') & - 'SPECIES', 'CVISCREF', 'MODEL', 'AUXSPECIESNAME' + write (this%iout, '(/,1x,a)') 'SUMMARY OF SPECIES INFORMATION IN VSC PACKAGE' + write (this%iout, '(1a11,5a17)') & + 'SPECIES', 'DVISCDC', 'CVISCREF', 'MODEL', 'AUXSPECIESNAME' do iviscspec = 1, this%nviscspecies write (c10, '(i0)') iviscspec line = ' '//adjustr(c10) + write (c16, '(g15.6)') this%dviscdc(iviscspec) + line = trim(line)//' '//adjustr(c16) write (c16, '(g15.6)') this%cviscref(iviscspec) line = trim(line)//' '//adjustr(c16) write (c16, '(a)') this%cmodelname(iviscspec) @@ -578,7 +598,7 @@ subroutine read_packagedata(this) ! -- deallocate deallocate (itemp) ! - write (this%iout, '(1x,a)') 'END OF VSC PACKAGEDATA' + write (this%iout, '(/,1x,a)') 'END OF VSC PACKAGEDATA' ! ! -- return return @@ -625,8 +645,19 @@ subroutine vsc_calcvisc(this) this%ctemp(i) = this%modelconc(i)%conc(n) end if end do - this%visc(n) = calcvisc(this%viscref, this%dviscdc, this%cviscref, & - this%ctemp) + ! + ! -- Call function corresponding to (1) temperature or (2) concentration + !if (i == this%idxtmpr) then + ! Temperature + !this%visc(n) = this%visc(n) + calc_visc_t(this%viscref, this%dviscdc, & + ! this%cviscref, this%ctemp, & + ! this% + !else + ! Concentration + this%visc(n) = calc_visc(this%ivisc, this%viscref, this%dviscdc, & + this%cviscref, this%ctemp, this%a2, & + this%a3, this%a4) + !end if end do ! ! -- Return @@ -879,7 +910,7 @@ subroutine set_concentration_pointer(this, modelname, conc, icbund, istmpr) character(len=LENMODELNAME), intent(in) :: modelname real(DP), dimension(:), pointer :: conc integer(I4B), dimension(:), pointer :: icbund - integer(I4B), intent(in) :: istmpr + integer(I4B), optional, intent(in) :: istmpr ! -- local integer(I4B) :: i logical :: found From 19e3d3b381e370fa6997213f7a48870b337dd81e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 7 Sep 2022 13:52:50 -0700 Subject: [PATCH 034/212] updating work on vsc package --- autotest/ex-gwt-vsc01.py | 102 +++--- autotest/ex-gwt-vsc02-bndtype.py | 364 +++++++++++++++++++ doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn | 8 +- src/Model/Connection/GwfInterfaceModel.f90 | 4 +- src/Model/GroundWaterFlow/gwf3.f90 | 28 +- src/Model/GroundWaterFlow/gwf3buy8.f90 | 2 +- src/Model/GroundWaterFlow/gwf3drn8.f90 | 32 ++ src/Model/GroundWaterFlow/gwf3npf8.f90 | 76 +++- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 384 +++++++++++++++++--- src/Model/ModelUtilities/GwfNpfGridData.f90 | 12 + 10 files changed, 904 insertions(+), 108 deletions(-) create mode 100644 autotest/ex-gwt-vsc02-bndtype.py diff --git a/autotest/ex-gwt-vsc01.py b/autotest/ex-gwt-vsc01.py index c7b17087e43..eb8e0f50513 100644 --- a/autotest/ex-gwt-vsc01.py +++ b/autotest/ex-gwt-vsc01.py @@ -31,13 +31,15 @@ # Base simulation and model name and workspace -ws = os.path.join('temp', 'examples', 'vsc-henry') +ws = os.path.join('temp', 'examples', 'vsc-chd-ghb') # Scenario parameters - make sure there is at least one blank line before next item +hyd_cond = [1205.49396942506, 864.0] # Hydraulic conductivity ($m d^{-1}$) parameters = { - "ex-gwt-vsc-a": {"vsc_on": False,}, - "ex-gwt-vsc-b": {"vsc_on": True,}, + "ex-gwt-no-vsc": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[0]}, + "ex-gwt-vsc": {"vsc_on": True, "hydraulic_conductivity": hyd_cond[1]}, + "ex-gwt-no-vsc-low-k": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[1]} } # Model units @@ -51,14 +53,13 @@ nstp = 500 # Number of time steps perlen = 0.5 # Simulation time length ($d$) nlay = 1 # Number of layers -nrow = 40 # Number of rows +nrow = 10 # Number of rows ncol = 80 # Number of columns system_length = 2.0 # Length of system ($m$) -delr = 0.025 # Column width ($m$) +delr = 1.0 # Column width ($m$) delc = 1.0 # Row width ($m$) -delv = 0.025 # Layer thickness +delv = 1.0 # Layer thickness top = 1.0 # Top of the model ($m$) -hydraulic_conductivity = 864.0 # Hydraulic conductivity ($m d^{-1}$) initial_temperature = 35.0 # Initial temperature (unitless) porosity = 0.26 # porosity (unitless) K_therm = 2.0 # Thermal conductivity # ($W/m/C$) @@ -83,13 +84,13 @@ # -def build_model(sim_folder, vsc_on): +def build_model(idx, sim_folder, vsc_on, hydraulic_conductivity): print("Building model...{}".format(sim_folder)) # generate names for each model - name = "vsc01" - gwfname = "gwf_" + name - gwtname = "gwt_" + name + name = "vsc" + gwfname = "gwf-" + name + "-" + str(idx) + gwtname = "gwt-" + name + "-" + str(idx) sim_ws = os.path.join(ws, sim_folder) sim = flopy.mf6.MFSimulation( @@ -135,23 +136,24 @@ def build_model(sim_folder, vsc_on): ) flopy.mf6.ModflowGwfic(gwf, strt=0.0) - # Attempting to instantiate VSC after creating a definition file - vsc_filerecord = "{}.vsc.bin".format(gwfname) - vsc_pd = [(0, 0.0, 20.0, gwtname, "temperature")] - flopy.mf6.ModflowGwfvsc( - gwf, - viscref=8.904e-4, - viscosity_filerecord=vsc_filerecord, - viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], - nviscspecies=len(vsc_pd), - packagedata=vsc_pd, - pname='vsc', - filename="{}.vsc".format(gwfname) - ) + if vsc_on: + # Instantiate viscosity (VSC) package + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, 20.0, gwtname, "temperature")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=8.904e-4, + viscosity_filerecord=vsc_filerecord, + viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname='vsc', + filename="{}.vsc".format(gwfname) + ) # Instantiating GHB ghbcond = hydraulic_conductivity * delv * delc / (0.5 * delr) - ghbspd = [[(k, 0, ncol - 1), top, ghbcond, 35.0] for k in range(nlay)] + ghbspd = [[(0, i, ncol - 1), top, ghbcond, initial_temperature] for i in range(nrow)] flopy.mf6.ModflowGwfghb( gwf, stress_period_data=ghbspd, @@ -160,11 +162,11 @@ def build_model(sim_folder, vsc_on): ) # Instantiating WEL - welspd = [[(k, 0, 0), inflow / nlay, 0.0] for k in range(nlay)] - flopy.mf6.ModflowGwfwel( + chdspd = [[(0, i, 0), 2.0, initial_temperature] for i in range(nrow)] + flopy.mf6.ModflowGwfchd( gwf, - stress_period_data=welspd, - pname="WEL-1", + stress_period_data=chdspd, + pname="CHD-1", auxiliary="temperature", ) head_filerecord = "{}.hds".format(name) @@ -222,8 +224,8 @@ def build_model(sim_folder, vsc_on): flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) sourcerecarray = [ + ("CHD-1", "AUX", "TEMPERATURE"), ("GHB-1", "AUX", "TEMPERATURE"), - ("WEL-1", "AUX", "TEMPERATURE"), ] flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) flopy.mf6.ModflowGwtoc( @@ -317,13 +319,37 @@ def plot_results(sim, idx): def scenario(idx, silent=True): + # Three model runs that are all part of the same scenario + + # Model Run 1 (Do not account for the effects of viscosity) + # --------------------------------------------------------- key = list(parameters.keys())[idx] parameter_dict = parameters[key] - sim = build_model(key, **parameter_dict) + sim = build_model(idx + 1, key, **parameter_dict) + write_model(sim, silent=silent) + #success = run_model(sim, silent=silent) + #if success: + # plot_results(sim, idx) + + # Model Run 2 (Activate viscosity package) + # ---------------------------------------- + idx += 1 + key = list(parameters.keys())[idx] + parameter_dict = parameters[key] + sim = build_model(idx + 1, key, **parameter_dict) + write_model(sim, silent=silent) + #success = run_model(sim, silent=silent) + #if success: + # plot_results(sim, idx) + + # Model Run 3 (No VSC package; use same K as when VSC package active; + # should get a different solution) + # ------------------------------------------------------------------ + idx += 1 + key = list(parameters.keys())[idx] + parameter_dict = parameters[key] + sim = build_model(idx + 1, key, **parameter_dict) write_model(sim, silent=silent) - success = run_model(sim, silent=silent) - if success: - plot_results(sim, idx) # nosetest - exclude block from this nosetest to the next nosetest @@ -331,19 +357,13 @@ def test_01(): scenario(0, silent=False) -def test_02(): - scenario(1, silent=False) - # nosetest end if __name__ == "__main__": # ### Henry Problem - # Scenario 1 - Classic henry problem + # Scenario 1 - Compare model runs with and without viscosity package active scenario(0) - # Scenario 2 - Modified Henry problem with half the inflow rate - - scenario(1) diff --git a/autotest/ex-gwt-vsc02-bndtype.py b/autotest/ex-gwt-vsc02-bndtype.py new file mode 100644 index 00000000000..497dcf8d5d5 --- /dev/null +++ b/autotest/ex-gwt-vsc02-bndtype.py @@ -0,0 +1,364 @@ +# ## Test problem for VSC +# +# Model domain is lifted from the Henry Problem +# + +# ### VSC Problem Setup + +# Imports + +import os +import sys +import matplotlib.pyplot as plt +import flopy +import numpy as np + +# Append to system path to include the common subdirectory + +sys.path.append(os.path.join("..", "common")) + +# Import common functionality + +import config +from figspecs import USGSFigure + +mf6exe = os.path.abspath(config.mf6_exe) + + +# Set figure properties specific to this problem + +figure_size = (6, 4) + +# Base simulation and model name and workspace + +ws = os.path.join('temp', 'examples', 'vsc-ghb-drn') + +# Scenario parameters - make sure there is at least one blank line before next item + +hyd_cond = [1205.49396942506, 864.0] # Hydraulic conductivity ($m d^{-1}$) +parameters = { + "ex-gwt-no-vsc": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[0]}, + "ex-gwt-vsc": {"vsc_on": True, "hydraulic_conductivity": hyd_cond[1]}, + "ex-gwt-no-vsc-low-k": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[1]} +} + +# Model units + +length_units = "cm" +time_units = "seconds" + +# Table of model parameters + +nper = 1 # Number of periods +nstp = 500 # Number of time steps +perlen = 0.5 # Simulation time length ($d$) +nlay = 1 # Number of layers +nrow = 10 # Number of rows +ncol = 80 # Number of columns +system_length = 2.0 # Length of system ($m$) +delr = 1.0 # Column width ($m$) +delc = 1.0 # Row width ($m$) +delv = 1.0 # Layer thickness +top = 1.0 # Top of the model ($m$) +initial_temperature = 35.0 # Initial temperature (unitless) +porosity = 0.26 # porosity (unitless) +K_therm = 2.0 # Thermal conductivity # ($W/m/C$) +rho_water = 1000 # Density of water ($kg/m^3$) +rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) +C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) +C_s = 880 # Heat capacity of the solids ($J/kg/C$) +D_m = K_therm / (porosity * rho_water * C_p_w) +rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) +K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) +inflow = 5.7024 # ($m^3/d$) + +botm = [top - k * delv for k in range(1, nlay + 1)] + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-10, 1e-6, 0.97 + + +# ### Functions to build, write, run, and plot models +# +# MODFLOW 6 flopy GWF simulation object (sim) is returned +# + + +def build_model(idx, sim_folder, vsc_on, hydraulic_conductivity): + print("Building model...{}".format(sim_folder)) + + # generate names for each model + name = "vsc02" + gwfname = "gwf-" + name + "-" + str(idx) + gwtname = "gwt-" + name + "-" + str(idx) + + sim_ws = os.path.join(ws, sim_folder) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe + ) + tdis_ds = ((perlen, nstp, 1.0),) + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=tdis_ds, time_units=time_units + ) + gwf = flopy.mf6.ModflowGwf(sim, modelname=gwfname, save_flows=True) + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(ims, [gwfname]) + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=0, + k=hydraulic_conductivity, + ) + flopy.mf6.ModflowGwfic(gwf, strt=0.0) + + if vsc_on: + # Instantiate viscosity (VSC) package + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, 20.0, gwtname, "temperature")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=8.904e-4, + viscosity_filerecord=vsc_filerecord, + viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname='vsc', + filename="{}.vsc".format(gwfname) + ) + + # Instantiating GHB + ghbcond = hydraulic_conductivity * delv * delc / (0.5 * delr) + ghbspd = [[(0, i, 0), top+3, ghbcond, initial_temperature] for i in range(nrow)] + flopy.mf6.ModflowGwfghb( + gwf, + stress_period_data=ghbspd, + pname="GHB-1", + auxiliary="temperature", + ) + + # Instantiating DRN + drnspd = [[(0, i, ncol - 1), top, 1.2 * ghbcond, initial_temperature] for i in range(nrow)] + flopy.mf6.ModflowGwfdrn( + gwf, + stress_period_data=drnspd, + pname="DRN-1", + auxiliary="temperature", + ) + head_filerecord = "{}.hds".format(name) + budget_filerecord = "{}.bud".format(name) + + # Instatiatingi OC + flopy.mf6.ModflowGwfoc( + gwf, + head_filerecord=head_filerecord, + budget_filerecord=budget_filerecord, + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # Setup the GWT model for simulating heat transport + gwt = flopy.mf6.ModflowGwt(sim, modelname=gwtname) + imsgwt = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwtname), + ) + sim.register_ims_package(imsgwt, [gwtname]) + flopy.mf6.ModflowGwtdis( + gwt, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + + flopy.mf6.ModflowGwtmst( + gwt, + porosity=porosity, + sorption='linear', + bulk_density=rhob, + distcoef=K_d, + pname="MST-1", + filename="{}.mst".format(gwtname), + ) + + flopy.mf6.ModflowGwtic(gwt, strt=initial_temperature) + flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") + flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) + sourcerecarray = [ + ("GHB-1", "AUX", "TEMPERATURE"), + ("DRN-1", "AUX", "TEMPERATURE"), + ] + flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) + flopy.mf6.ModflowGwtoc( + gwt, + concentration_filerecord="{}.ucn".format(gwtname), + saverecord=[("CONCENTRATION", "ALL")], + printrecord=[("CONCENTRATION", "LAST"), ("BUDGET", "LAST")], + ) + flopy.mf6.ModflowGwfgwt( + sim, + exgtype="GWF6-GWT6", + exgmnamea=gwfname, + exgmnameb=gwtname + ) + return sim + + +# Function to write model files + + +def write_model(sim, silent=True): + if config.writeModel: + sim.write_simulation(silent=silent) + return + + +# Function to run the model +# True is returned if the model runs successfully + + +@config.timeit +def run_model(sim, silent=True): + success = True + if config.runModel: + success = False + success, buff = sim.run_simulation(silent=silent) + if not success: + print(buff) + return success + + +# Function to plot the model results + + +def plot_conc(sim, idx): + fs = USGSFigure(figure_type="map", verbose=False) + sim_name = list(parameters.keys())[idx] + sim_ws = os.path.join(ws, sim_name) + gwf = sim.get_model("flow") + gwt = sim.get_model("trans") + + fig = plt.figure(figsize=figure_size) + fig.tight_layout() + + # get MODFLOW 6 temperature + conc = gwt.output.temperature().get_data() + + ax = fig.add_subplot(1, 1, 1, aspect="equal") + pxs = flopy.plot.PlotCrossSection(model=gwf, ax=ax, line={"row": 0}) + pxs.plot_array(conc, cmap="jet") + levels = [35 * f for f in [0.01, 0.1, 0.5, 0.9, 0.99]] + cs = pxs.contour_array( + conc, levels=levels, colors="w", linewidths=1.0, linestyles="-" + ) + ax.set_xlabel("x position (m)") + ax.set_ylabel("z position (m)") + plt.clabel(cs, fmt="%4.2f", fontsize=5) + + # save figure + if config.plotSave: + fpth = os.path.join( + "..", "figures", "{}-conc{}".format(sim_name, config.figure_ext) + ) + fig.savefig(fpth) + return + + + +# Function that wraps all of the steps for each scenario +# +# 1. build_model, +# 2. write_model, +# 3. run_model, and +# 4. plot_results. +# + + +def scenario(idx, silent=True): + # Three model runs that are all part of the same scenario + + # Model Run 1 (Do not account for the effects of viscosity) + # --------------------------------------------------------- + key = list(parameters.keys())[idx] + parameter_dict = parameters[key] + sim = build_model(idx + 1, key, **parameter_dict) + write_model(sim, silent=silent) + #success = run_model(sim, silent=silent) + #if success: + # plot_results(sim, idx) + + # Model Run 2 (Activate viscosity package) + # ---------------------------------------- + idx += 1 + key = list(parameters.keys())[idx] + parameter_dict = parameters[key] + sim = build_model(idx + 1, key, **parameter_dict) + write_model(sim, silent=silent) + #success = run_model(sim, silent=silent) + #if success: + # plot_results(sim, idx) + + # Model Run 3 (No VSC package; use same K as when VSC package active; + # should get a different solution) + # ------------------------------------------------------------------ + idx += 1 + key = list(parameters.keys())[idx] + parameter_dict = parameters[key] + sim = build_model(idx + 1, key, **parameter_dict) + write_model(sim, silent=silent) + + +# nosetest - exclude block from this nosetest to the next nosetest +def test_01(): + scenario(0, silent=False) + + + +# nosetest end + +if __name__ == "__main__": + # ### Henry Problem + + # Scenario 1 - Compare model runs with and without viscosity package active + + scenario(0) + diff --git a/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn b/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn index e239528b912..06ca797ebbb 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn @@ -55,22 +55,22 @@ description name of the binary output file to write viscosity information. The block options name viscosityfuncrecord -type record viscosity_func formulation a2 a3 a4 +type record thermal_viscosity_func formulation a2 a3 a4 reader urword optional true longname description block options -name viscosity_func +name thermal_viscosity_func type keyword shape in_record true tagged true reader urword optional false -longname keyword to specify viscosity formulation -description may be used for specifying which viscosity formulation to use. The linear viscosity formulation is the default. +longname keyword to specify viscosity formulation for the temperature species +description may be used for specifying which viscosity formulation to use for a species identified by the auxilary name TEMPERATURE. Can be either LINEAR or NONLINEAR. The LINEAR viscosity formulation is the default. block options name formulation diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index fd7e5bd12bd..91a260df73a 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -96,7 +96,7 @@ subroutine gwfifm_df(this) ! define NPF package call npfOptions%construct() call this%setNpfOptions(npfOptions) - call this%npf%npf_df(this%dis, this%xt3d, 0, npfOptions) + call this%npf%npf_df(this%dis, this%xt3d, 0, 0, npfOptions) call npfOptions%destroy() ! define BUY package @@ -126,7 +126,7 @@ subroutine gwfifm_ar(this) call npfGridData%construct(this%dis%nodes) call this%setNpfGridData(npfGridData) - call this%npf%npf_ar(this%ic, this%ibound, this%x, ikmod, npfGridData) ! kluge note: added local "ikmod" as a placeholder; speak to Martijn about integrating VSC + call this%npf%npf_ar(this%ic, this%vsc, this%ibound, this%x, ikmod, npfGridData) ! kluge note: added local "ikmod" as a placeholder; speak to Martijn about integrating VSC call npfGridData%destroy() if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index ffa4957d714..f20b1fcb0b3 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -314,7 +314,7 @@ subroutine gwf_df(this) ! ! -- Define packages and utility objects call this%dis%dis_df() - call this%npf%npf_df(this%dis, this%xt3d, this%ingnc) + call this%npf%npf_df(this%dis, this%xt3d, this%ingnc, this%invsc) call this%oc%oc_df() call this%budget%budget_df(niunit, 'VOLUME', 'L**3') if (this%inbuy > 0) call this%buy%buy_df(this%dis) @@ -434,10 +434,10 @@ subroutine gwf_ar(this) ! ! -- Allocate and read modules attached to model if (this%inic > 0) call this%ic%ic_ar(this%x) - if (this%innpf > 0) call this%npf%npf_ar(this%ic, this%ibound, this%x, & - ikmodgwf) + if (this%innpf > 0) call this%npf%npf_ar(this%ic, this%vsc, this%ibound, & + this%x, ikmodgwf) + if (this%invsc > 0) call this%vsc%vsc_ar(this%ibound) if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) - if (this%invsc > 0) call this%vsc%vsc_ar(this%npf, this%ibound) if (this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) if (this%insto > 0) call this%sto%sto_ar(this%dis, this%ibound) if (this%incsub > 0) call this%csub%csub_ar(this%dis, this%ibound) @@ -537,16 +537,17 @@ subroutine gwf_ad(this) end if ! ! -- Advance + if (this%invsc > 0) call this%vsc%vsc_ad() if (this%innpf > 0) call this%npf%npf_ad(this%dis%nodes, this%xold, & this%x, irestore) if (this%insto > 0) call this%sto%sto_ad() if (this%incsub > 0) call this%csub%csub_ad(this%dis%nodes, this%x) if (this%inbuy > 0) call this%buy%buy_ad() - if (this%invsc > 0) call this%vsc%vsc_ad() if (this%inmvr > 0) call this%mvr%mvr_ad() do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ad() + if (this%invsc > 0) call this%vsc%vsc_ad_bnd(packobj, this%x) if (isimcheck > 0) then call packobj%bnd_ck() end if @@ -1146,24 +1147,31 @@ subroutine gwf_ot_dv(this, idvsave, idvprint, ipflag) integer(I4B), intent(inout) :: ipflag class(BndType), pointer :: packobj integer(I4B) :: ip - + ! ! -- Save compaction to binary file if (this%incsub > 0) call this%csub%csub_ot_dv(idvsave, idvprint) - + ! ! -- save density to binary file if (this%inbuy > 0) then call this%buy%buy_ot_dv(idvsave) ! kluge note: do similar for viscosity (or viscosity ratio)? end if - + ! + ! -- save density to binary file + if (this%invsc > 0) then + call this%vsc%vsc_ot_dv(idvsave) ! kluge note: do similar for viscosity (or viscosity ratio)? + end if + ! ! -- Print advanced package dependent variables do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_dv(idvsave, idvprint) end do - + ! ! -- save head and print head call this%oc%oc_ot(ipflag) - + ! + ! -- Return + return end subroutine gwf_ot_dv subroutine gwf_ot_bdsummary(this, ibudfl, ipflag) diff --git a/src/Model/GroundWaterFlow/gwf3buy8.f90 b/src/Model/GroundWaterFlow/gwf3buy8.f90 index 781b40cdb80..162e4112dec 100644 --- a/src/Model/GroundWaterFlow/gwf3buy8.f90 +++ b/src/Model/GroundWaterFlow/gwf3buy8.f90 @@ -35,7 +35,7 @@ module GwfBuyModule real(DP), pointer :: denseref => null() ! reference fluid density real(DP), dimension(:), pointer, contiguous :: dense => null() ! density real(DP), dimension(:), pointer, contiguous :: concbuy => null() ! concentration array if specified in buy package - real(DP), dimension(:), pointer, contiguous :: elev => null() ! cell center elevation (optional; if not specified, hten use (top+bot)/2) + real(DP), dimension(:), pointer, contiguous :: elev => null() ! cell center elevation (optional; if not specified, then use (top+bot)/2) integer(I4B), dimension(:), pointer :: ibound => null() ! store pointer to ibound integer(I4B), pointer :: nrhospecies => null() ! number of species used in equation of state to calculate density diff --git a/src/Model/GroundWaterFlow/gwf3drn8.f90 b/src/Model/GroundWaterFlow/gwf3drn8.f90 index 45a329f9faa..b5cf8d10893 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -7,6 +7,7 @@ module DrnModule sQuadraticSaturation use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor + use TdisModule, only: delt, totimc use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList ! @@ -27,6 +28,7 @@ module DrnModule contains procedure :: allocate_scalars => drn_allocate_scalars procedure :: bnd_options => drn_options + procedure :: bnd_ad => drn_ad procedure :: bnd_ck => drn_ck procedure :: bnd_cf => drn_cf procedure :: bnd_fc => drn_fc @@ -91,6 +93,36 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! -- return return end subroutine drn_create + + !> @ brief Advance the drain boundary package + !! + !! Advance data in the drain boundary package. Overides the bnd_ad() + !! routine in the bndType parent class. The method advances time + !! series and observation data as well as updates the user-specified + !! conductance based on changes in viscosity when water enters from + !! the boundary + !< + subroutine drn_ad(this) + ! -- dummy variables + class(DrnType) :: this !< DrnType object + ! -- local variables + real(DP) :: begintime, endtime + ! + ! -- Initialize time variables + begintime = totimc + endtime = begintime + delt + ! + ! -- Advance the time series managers + call this%TsManager%ad() + call this%TasManager%ad() + ! + ! -- For each observation, push simulated value and corresponding + ! simulation time from "current" to "preceding" and reset + ! "current" value. + call this%obs%obs_ad() + ! + return + end subroutine drn_ad subroutine drn_da(this) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 799a2a6a84a..b132d2fc4d7 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -11,6 +11,7 @@ module GwfNpfModule use GwfNpfOptionsModule, only: GwfNpfOptionsType use BaseDisModule, only: DisBaseType use GwfIcModule, only: GwfIcType + use GwfVscModule, only: GwfVscType use Xt3dModule, only: Xt3dType use BlockParserModule, only: BlockParserType use InputOutputModule, only: GetUnit, openfile @@ -30,6 +31,7 @@ module GwfNpfModule type, extends(NumericalPackageType) :: GwfNpfType type(GwfIcType), pointer :: ic => null() !< initial conditions object + type(GwfVscType), pointer :: vsc => null() !< viscosity object type(Xt3dType), pointer :: xt3d => null() !< xt3d pointer integer(I4B), pointer :: iname => null() !< length of variable names character(len=24), dimension(:), pointer :: aname => null() !< variable names @@ -62,6 +64,9 @@ module GwfNpfModule real(DP), dimension(:), pointer, contiguous :: k11 => null() !< hydraulic conductivity; if anisotropic, then this is Kx prior to rotation real(DP), dimension(:), pointer, contiguous :: k22 => null() !< hydraulic conductivity; if specified then this is Ky prior to rotation real(DP), dimension(:), pointer, contiguous :: k33 => null() !< hydraulic conductivity; if specified then this is Kz prior to rotation + real(DP), dimension(:), pointer, contiguous :: k11_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification + real(DP), dimension(:), pointer, contiguous :: k22_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification + real(DP), dimension(:), pointer, contiguous :: k33_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification integer(I4B), pointer :: iavgkeff => null() !< effective conductivity averaging (0: harmonic, 1: arithmetic) integer(I4B), pointer :: ik22 => null() !< flag that k22 is specified integer(I4B), pointer :: ik33 => null() !< flag that k33 is specified @@ -89,7 +94,9 @@ module GwfNpfModule real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() !< edge properties (Q, area, nx, ny, distance) ! integer(I4B), pointer :: intvk => null() ! TVK (time-varying K) unit number (0 if unused) + integer(I4B), pointer :: invsc => null() ! VSC (viscosity) unit number (0 if unused); viscosity leads to time-varying K's type(TvkType), pointer :: tvk => null() ! TVK object + !type(GwfVscType), pointer :: vsc => null() ! VSC object integer(I4B), pointer :: kchangeper => null() ! last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), pointer :: kchangestp => null() ! last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() ! grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) @@ -114,6 +121,7 @@ module GwfNpfModule procedure, private :: wd => sgwf_npf_wetdry procedure, private :: wdmsg => sgwf_npf_wdmsg procedure :: allocate_scalars + procedure, private :: store_original_k_arrays procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: set_options @@ -147,7 +155,7 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - type(GwfNpftype), pointer :: npfobj + type(GwfNpfType), pointer :: npfobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout @@ -177,7 +185,7 @@ end subroutine npf_cr !! should be passed. A consistency check is performed, and finally !! xt3d_df is called, when enabled. !< - subroutine npf_df(this, dis, xt3d, ingnc, npf_options) + subroutine npf_df(this, dis, xt3d, ingnc, invsc, npf_options) ! ****************************************************************************** ! npf_df -- Define ! ****************************************************************************** @@ -192,6 +200,7 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) class(DisBaseType), pointer, intent(inout) :: dis !< the pointer to the discretization type(Xt3dType), pointer :: xt3d !< the pointer to the XT3D 'package' integer(I4B), intent(in) :: ingnc !< ghostnodes enabled? (>0 means yes) + integer(I4B), intent(in) :: invsc !< viscosity enabled? (>0 means yes) type(GwfNpfOptionsType), optional, intent(in) :: npf_options !< the optional options, for when not constructing from file ! -- local ! -- formats @@ -204,6 +213,9 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) ! -- Set a pointer to dis this%dis => dis ! + ! -- Set flag signifying whether vsc is active + if (invsc > 0) this%invsc = invsc + ! if (.not. present(npf_options)) then ! -- Print a message identifying the node property flow package. write (this%iout, fmtheader) this%inunit @@ -286,7 +298,7 @@ end subroutine npf_mc !! from the input argument (when the optional @param grid_data is passed), !! preprocess the input data and call *_ar on xt3d, when active. !< - subroutine npf_ar(this, ic, ibound, hnew, ikmodgwf, grid_data) + subroutine npf_ar(this, ic, vsc, ibound, hnew, ikmodgwf, grid_data) ! ****************************************************************************** ! npf_ar -- Allocate and Read ! ****************************************************************************** @@ -296,6 +308,7 @@ subroutine npf_ar(this, ic, ibound, hnew, ikmodgwf, grid_data) ! -- dummy class(GwfNpftype) :: this !< instance of the NPF package type(GwfIcType), pointer, intent(in) :: ic !< initial conditions + type(GwfVscType), pointer, intent(in) :: vsc !< viscosity package integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array integer(I4B), intent(in) :: ikmodgwf !< flag to indicate whether conductivities get modified from their input values by a gwf package @@ -310,6 +323,11 @@ subroutine npf_ar(this, ic, ibound, hnew, ikmodgwf, grid_data) this%ibound => ibound this%hnew => hnew ! + ! -- Store pointer to VSC if active + if (this%invsc /= 0) then + this%vsc => vsc + end if + ! ! -- Set flag to indicate whether conductivities get modified from their input values this%ikmod = ikmodgwf ! @@ -325,7 +343,15 @@ subroutine npf_ar(this, ic, ibound, hnew, ikmodgwf, grid_data) call this%set_grid_data(grid_data) end if ! + ! -- allocate arrays to store original user input in case TVK/VSC modify them + if (this%invsc > 0) then + ! Need to allocate arrays that will store the original K values so + ! that the current K11 etc. carry the "real" K's that are updated + call this%store_original_k_arrays(this%dis%nodes, this%dis%njas) + end if + ! ! -- preprocess data + ! Hereafter working with the "real" K values call this%preprocess_input() ! ! -- xt3d @@ -404,6 +430,12 @@ subroutine npf_ad(this, nodes, hold, hnew, irestore) call this%tvk%ad() end if ! + ! -- VSC + ! -- Hit the TVK-updated K's with VSC correction before calling/updating condsat + if (this%invsc /= 0) then + call this%vsc%update_k_with_vsc() + end if + ! ! -- If any K values have changed, we need to update CONDSAT or XT3D arrays if (this%kchangeper == kper .and. this%kchangestp == kstp) then if (this%ixt3d == 0) then @@ -1075,6 +1107,7 @@ subroutine npf_da(this) call mem_deallocate(this%ik22overk) call mem_deallocate(this%ik33overk) call mem_deallocate(this%intvk) + call mem_deallocate(this%invsc) call mem_deallocate(this%kchangeper) call mem_deallocate(this%kchangestp) ! @@ -1085,6 +1118,9 @@ subroutine npf_da(this) call mem_deallocate(this%k11) call mem_deallocate(this%k22, 'K22', trim(this%memoryPath)) call mem_deallocate(this%k33, 'K33', trim(this%memoryPath)) + call mem_deallocate(this%k11_input, 'K11_INPUT', trim(this%memoryPath)) + call mem_deallocate(this%k22_input, 'K22_INPUT', trim(this%memoryPath)) + call mem_deallocate(this%k33_input, 'K33_INPUT', trim(this%memoryPath)) call mem_deallocate(this%sat) call mem_deallocate(this%condsat) call mem_deallocate(this%wetdry) @@ -1155,6 +1191,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%nedges, 'NEDGES', this%memoryPath) call mem_allocate(this%lastedge, 'LASTEDGE', this%memoryPath) call mem_allocate(this%intvk, 'INTVK', this%memoryPath) + call mem_allocate(this%invsc, 'INVSC', this%memoryPath) call mem_allocate(this%kchangeper, 'KCHANGEPER', this%memoryPath) call mem_allocate(this%kchangestp, 'KCHANGESTP', this%memoryPath) ! @@ -1196,6 +1233,7 @@ subroutine allocate_scalars(this) this%nedges = 0 this%lastedge = 0 this%intvk = 0 + this%invsc = 0 this%kchangeper = 0 this%kchangestp = 0 ! @@ -1206,6 +1244,35 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + subroutine store_original_k_arrays(this, ncells, njas) +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfNpftype) :: this + integer(I4B), intent(in) :: ncells + integer(I4B), intent(in) :: njas + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Retain copy of user-specified K arrays + do n = 1, ncells + this%k11_input(n) = this%k11(n) + if (this%ik22 /= 0) then + this%k22_input(n) = this%k22(n) + end if + if (this%ik33 /= 0) then + this%k33_input(n) = this%k33(n) + end if + end do + ! + ! -- Return + return + end subroutine store_original_k_arrays + subroutine allocate_arrays(this, ncells, njas) ! ****************************************************************************** ! allocate_arrays -- Allocate npf arrays @@ -1233,6 +1300,9 @@ subroutine allocate_arrays(this, ncells, njas) ! -- Optional arrays dimensioned to full size initially call mem_allocate(this%k22, ncells, 'K22', this%memoryPath) call mem_allocate(this%k33, ncells, 'K33', this%memoryPath) + call mem_allocate(this%k11_input, ncells, 'K11_INPUT', this%memoryPath) + call mem_allocate(this%k22_input, ncells, 'K22_INPUT', this%memoryPath) + call mem_allocate(this%k33_input, ncells, 'K33_INPUT', this%memoryPath) call mem_allocate(this%wetdry, ncells, 'WETDRY', this%memoryPath) call mem_allocate(this%angle1, ncells, 'ANGLE1', this%memoryPath) call mem_allocate(this%angle2, ncells, 'ANGLE2', this%memoryPath) diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index bfe154e06cf..2c5297ea7c9 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -5,12 +5,13 @@ module GwfVscModule use KindModule, only: DP, I4B use SimModule, only: store_error, store_warning, count_errors use MemoryManagerModule, only: mem_allocate, mem_reallocate, & - mem_deallocate - use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, & - LENAUXNAME, DHNOFLO, MAXCHARLEN, LINELENGTH + mem_deallocate, mem_setptr + use MemoryHelperModule, only: create_mem_path + use ConstantsModule, only: DHALF, DZERO, DONE, LENMODELNAME, LENAUXNAME, & + DHNOFLO, MAXCHARLEN, LINELENGTH, LENMEMPATH + use TdisModule, only: kper, kstp use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType - use GwfNpfModule, only: GwfNpfType use GwfVscInputDataModule, only: GwfVscInputDataType use ListsModule, only: basemodellist @@ -26,15 +27,17 @@ module GwfVscModule end type ConcentrationPointer type, extends(NumericalPackageType) :: GwfVscType - type(GwfNpfType), pointer :: npf => null() !< npf object - integer(I4B), pointer :: ivisc => null() !< viscosity formulation flag (1:Voss (1984), 2:Pawlowski (1991), 3:Guo and Zhou (2005)) + integer(I4B), pointer :: thermivisc => null() !< viscosity formulation flag (1:Linear, 2:Nonlinear) integer(I4B), pointer :: idxtmpr => null() !< if greater than 0 then an index for identifying whether the "species" array is temperature integer(I4B), pointer :: ioutvisc => null() !< unit number for saving viscosity integer(I4B), pointer :: ireadconcvsc => null() !< if 1 then visc has been read from this vsc input file ! kluge note: is this ever really used? integer(I4B), pointer :: iconcset => null() !< if 1 then conc points to a gwt (or gwe) model%x array + integer(I4B), pointer :: ireadelev => null () !< if 1 then elev has been allocated and filled + integer(I4B), dimension(:), pointer :: ivisc => null() !< viscosity formulation flag for each species (1:Linear, 2:Nonlinear) real(DP), pointer :: viscref => null() !< reference fluid viscosity real(DP), dimension(:), pointer, contiguous :: visc => null() !< viscosity real(DP), dimension(:), pointer, contiguous :: concvsc => null() !< concentration (or temperature) array if specified in vsc package ! kluge note: is this ever really used? + real(DP), dimension(:), pointer, contiguous :: elev => null() !< cell center elevation (optional; if not specified, then use (top+bot)/2) integer(I4B), dimension(:), pointer :: ibound => null() !< store pointer to ibound integer(I4B), pointer :: nviscspecies => null() !< number of concentration species used in viscosity equation @@ -51,11 +54,26 @@ module GwfVscModule type(ConcentrationPointer), allocatable, dimension(:) :: modelconc !< concentration (or temperature) pointer for each solute (or heat) transport model + integer(I4B), pointer :: ik22overk => null() !< NPF flag that k22 is specified as anisotropy ratio + integer(I4B), pointer :: ik33overk => null() !< NPF flag that k33 is specified as anisotropy ratio + real(DP), dimension(:), pointer, contiguous :: k11 => null() !< NPF hydraulic conductivity; if anisotropic, then this is Kx prior to rotation + real(DP), dimension(:), pointer, contiguous :: k22 => null() !< NPF hydraulic conductivity; if specified then this is Ky prior to rotation + real(DP), dimension(:), pointer, contiguous :: k33 => null() !< NPF hydraulic conductivity; if specified then this is Kz prior to rotation + real(DP), dimension(:), pointer, contiguous :: k11_input => null() !< NPF hydraulic conductivity as originally specified by the user + real(DP), dimension(:), pointer, contiguous :: k22_input => null() !< NPF hydraulic conductivity as originally specified by the user + real(DP), dimension(:), pointer, contiguous :: k33_input => null() !< NPF hydraulic conductivity as originally specified by the user + integer(I4B), pointer :: ik22 => null() !< NPF flag that k22 is specified + integer(I4B), pointer :: ik33 => null() !< NPF flag that k33 is specified + integer(I4B), pointer :: kchangeper => null() ! last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) + integer(I4B), pointer :: kchangestp => null() ! last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) + integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() ! grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) + contains procedure :: vsc_df procedure :: vsc_ar procedure :: vsc_rp procedure :: vsc_ad + procedure, public :: vsc_ad_bnd procedure :: vsc_ot_dv procedure :: vsc_da procedure, private :: vsc_calcvisc @@ -66,6 +84,9 @@ module GwfVscModule procedure, private :: read_dimensions procedure, private :: read_packagedata procedure, private :: set_packagedata + procedure, private :: set_npf_pointers + procedure, public :: update_k_with_vsc + procedure, private :: vsc_set_changed_at procedure :: set_concentration_pointer end type GwfVscType @@ -82,7 +103,7 @@ function calc_visc(ivisc, viscref, dviscdc, cviscref, conc, & ! ------------------------------------------------------------------------------ ! -- dummy - integer(I4B), intent(in) :: ivisc + integer(I4B), dimension(:), intent(in) :: ivisc real(DP), intent(in) :: viscref real(DP), dimension(:), intent(in) :: dviscdc real(DP), dimension(:), intent(in) :: cviscref @@ -101,10 +122,10 @@ function calc_visc(ivisc, viscref, dviscdc, cviscref, conc, & visc = viscref do i = 1, nviscspec - if (ivisc == 1) then + if (ivisc(i) == 1) then visc = visc + dviscdc(i) * (conc(i) - cviscref(i)) ! kluge note: linear for now else - expon = -1 * ((conc(i) - cviscref(i)) / & + expon = -1 * a3 * ((conc(i) - cviscref(i)) / & ((conc(i) + a4) * (cviscref(i) + a4))) mu_t = viscref * a2 ** expon ! If a nonlinear correction is applied, then b/c it takes into account @@ -168,7 +189,7 @@ end subroutine vsc_cr !< subroutine vsc_df(this, dis, vsc_input) ! ****************************************************************************** -! vsc_df -- Allocate and Read +! vsc_df -- Define ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -220,7 +241,7 @@ subroutine vsc_df(this, dis, vsc_input) return end subroutine vsc_df - subroutine vsc_ar(this, npf, ibound) + subroutine vsc_ar(this, ibound) ! ****************************************************************************** ! vsc_ar -- Allocate and Read ! ****************************************************************************** @@ -230,19 +251,52 @@ subroutine vsc_ar(this, npf, ibound) ! -- modules ! -- dummy class(GwfVscType) :: this - type(GwfNpfType), pointer, intent(in) :: npf integer(I4B), dimension(:), pointer :: ibound ! -- local ! -- formats ! ------------------------------------------------------------------------------ ! ! -- store pointers to arguments that were passed in - this%npf => npf this%ibound => ibound ! + ! -- Set pointers to npf variables + call this%set_npf_pointers() + ! ! -- Return return end subroutine vsc_ar + + !> @brief Set pointers to NPF variables + !! + !! Set array and variable pointers from the NPF + !! package for access by VSC. + !! + !< + subroutine set_npf_pointers(this) + ! -- dummy variables + class(GwfVscType) :: this + ! -- local variables + character(len=LENMEMPATH) :: npfMemoryPath + ! + ! -- Set pointers to other package variables + ! -- NPF + npfMemoryPath = create_mem_path(this%name_model, 'NPF') + call mem_setptr(this%ik22overk, 'IK22OVERK', npfMemoryPath) + call mem_setptr(this%ik33overk, 'IK33OVERK', npfMemoryPath) + call mem_setptr(this%k11, 'K11', npfMemoryPath) + call mem_setptr(this%k22, 'K22', npfMemoryPath) + call mem_setptr(this%k33, 'K33', npfMemoryPath) + call mem_setptr(this%k11_input, 'K11_INPUT', npfMemoryPath) + call mem_setptr(this%k22_input, 'K22_INPUT', npfMemoryPath) + call mem_setptr(this%k33_input, 'K33_INPUT', npfMemoryPath) + call mem_setptr(this%ik22, 'IK22', npfMemoryPath) + call mem_setptr(this%ik33, 'IK33', npfMemoryPath) + call mem_setptr(this%kchangeper, 'KCHANGEPER', npfMemoryPath) + call mem_setptr(this%kchangestp, 'KCHANGESTP', npfMemoryPath) + call mem_setptr(this%nodekchange, 'NODEKCHANGE', npfMemoryPath) + ! + return + end subroutine set_npf_pointers subroutine vsc_rp(this) ! ****************************************************************************** @@ -295,17 +349,164 @@ subroutine vsc_ad(this) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- update viscosity using the last concentration + ! -- update viscosity using the latest concentration/temperature call this%vsc_calcvisc() ! - ! -- update kfactor ! kluge note: need this, and also a vsc_ad_bnd subroutine to update kfactors for boundary packages - ! ! -- Return return end subroutine vsc_ad + + !> @brief advance the boundary packages when viscosity is active + !! + !! Update the conductance values associate with inflow from a boundary + !! when VSC package is active. + !< + subroutine vsc_ad_bnd(this, packobj, hnew) + ! -- modules + use BndModule, only: BndType + ! -- dummy + class(GwfVscType) :: this + class(BndType), pointer :: packobj + real(DP), intent(in), dimension(:) :: hnew + ! -- local + integer(I4B) :: i, j + integer(I4B) :: n, locvisc, locelev + integer(I4B), dimension(:), allocatable :: locconc + ! + ! -- initialize + locvisc = 0 + locelev = 0 + allocate (locconc(this%nviscspecies)) + locconc(:) = 0 + ! + ! -- Add viscosity terms for conductance-dependent boundaries + do n = 1, packobj%naux + if (packobj%auxname(n) == 'VISCOSITY') then + locvisc = n + else if (packobj%auxname(n) == 'ELEVATION') then + locelev = n + end if + end do + ! + ! -- find aux columns for concentrations that affect density + do i = 1, this%nviscspecies + locconc(i) = 0 + do j = 1, packobj%naux + if (this%cauxspeciesname(i) == packobj%auxname(j)) then + locconc(i) = j + exit + end if + end do + if (locconc(i) == 0) then + ! -- one not found, so don't use and mark all as 0 + locconc(:) = 0 + exit + end if + end do + ! + ! -- apply viscosity terms to inflow from boundary based on package type + select case (packobj%filtyp) + case ('GHB') + ! + ! -- general head boundary + call vsc_ad_ghb(packobj, hnew, this%visc, this%viscref, locelev, & + locvisc, locconc, this%dviscdc, this%cviscref, & + this%ivisc, this%a2, this%a3, this%a4, this%ctemp) + !case ('DRN') + ! ! + ! ! -- drain boundary + ! call vsc_ad_drn(packobj, hnew, this%viscref) + case default + ! + ! -- nothing + end select + ! + ! -- deallocate + deallocate (locconc) + ! + ! -- Return + return + end subroutine vsc_ad_bnd + + !> @brief advance ghb while accounting for viscosity + !! + !! When flow enters from ghb boundary type, take into account the effects + !! of viscosity on the user-specified conductance terms + !< + subroutine vsc_ad_ghb(packobj, hnew, visc, viscref, locelev, locvisc, & + locconc, dviscdc, cviscref, ivisc, a2, a3, a4, ctemp) + ! -- modules + use BndModule, only: BndType + class(BndType), pointer :: packobj + ! -- dummy + real(DP), intent(in), dimension(:) :: hnew + real(DP), intent(in), dimension(:) :: visc + real(DP), intent(in) :: a2, a3, a4 + real(DP), intent(in) :: viscref + integer(I4B), intent(in) :: locelev + integer(I4B), intent(in) :: locvisc + integer(I4B), dimension(:), intent(in) :: locconc + integer(I4B), dimension(:), intent(in) :: ivisc + real(DP), dimension(:), intent(in) :: dviscdc + real(DP), dimension(:), intent(in) :: cviscref + real(DP), dimension(:), intent(inout) :: ctemp + ! -- local + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: viscghb + real(DP) :: viscratio + real(DP) :: hd +! ------------------------------------------------------------------------------- + ! + ! -- Process density terms for each GHB + do n = 1, packobj%nbound + node = packobj%nodelist(n) + ! + ! -- Check if boundary cell is active, cycle if not + if (packobj%ibound(node) <= 0) cycle + ! + ! -- calculate the viscosity associcated with the boundary + viscghb = calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, & + cviscref, ctemp, ivisc, a2, a3, a4, & + packobj%auxvar) + ! cviscref, ctemp, ivisc, packobj%auxvar) + ! + ! -- get the viscosity ratio + viscratio = update_bnd_cond(viscghb, viscref) + ! + ! -- + + ! + ! -- viscosity + end do + ! + ! -- Return + return + end subroutine vsc_ad_ghb - function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & - ctemp, auxvar) result(viscbnd) + !> @brief apply bnd viscosity to the conductance term + !! + !! When the viscosity package is active apply the viscosity ratio to the + !! active boundary package's conductance term. + !< + function update_bnd_cond(bndvisc, viscref) result(vsc_ratio) + ! -- modules + ! -- dummy + real(DP), intent(in) :: viscref + real(DP), intent(in) :: bndvisc + ! -- local + real(DP) :: vsc_ratio +! ------------------------------------------------------------------------------- + ! + vsc_ratio = viscref / bndvisc + ! + ! -- Return + return + end function update_bnd_cond + + function calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & +! ctemp, ivisc, auxvar) result(viscbnd) + ctemp, ivisc, a2, a3, a4, auxvar) result(viscbnd) ! ****************************************************************************** ! get_bnd_viscosity -- Return the viscosity of the boundary package using one of ! several different options in the following order of priority: @@ -320,6 +521,8 @@ function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & ! -- dummy integer(I4B), intent(in) :: n integer(I4B), intent(in) :: locvisc + real(DP), intent(in) :: a2, a3, a4 + integer(I4B), dimension(:), intent(in) :: ivisc integer(I4B), dimension(:), intent(in) :: locconc real(DP), intent(in) :: viscref real(DP), dimension(:), intent(in) :: dviscdc @@ -344,7 +547,7 @@ function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & ctemp(i) = auxvar(locconc(i), n) end if end do - ! viscbnd = calc_visc_lin(viscref, dviscdc, cviscref, ctemp) + viscbnd = calc_visc(ivisc, viscref, dviscdc, cviscref, ctemp, a2, a3, a4) else ! -- neither of the above, so assign as viscref viscbnd = viscref @@ -352,11 +555,67 @@ function get_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & ! ! -- return return - end function get_bnd_viscosity + end function calc_bnd_viscosity - subroutine vsc_ot_dv(this, idvfl) ! kluge note: rename to _vv ? save viscosity ratio? do we want this at all? + !> @brief hit the hydraulic conductivity values with the ratio mu_o/mu + !! + !! This routine called after updating the viscosity values using the latest + !! concentration and/or temperature values. The ratio mu_o/mu, reference + !! viscosity divided by the updated viscosity value, is multiplied by K + !! for each cell. + !< + subroutine update_k_with_vsc(this) +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GwfVscType) :: this + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- For viscosity-based K's, apply change of K to K11 by starting with + ! user-specified K values and not the K's leftover from the last viscosity + ! update. + do n = 1, this%dis%nodes + this%k11(n) = this%k11_input(n) * (this%viscref / this%visc(n)) + if (this%ik22 /= 0) then + this%k22(n) = this%k22_input(n) * (this%viscref / this%visc(n)) + end if + if (this%ik33 /= 0) then + this%k33(n) = this%k33_input(n) * (this%viscref / this%visc(n)) + end if + this%nodekchange(n) = 1 + end do + ! + ! -- Flag kchange + call this%vsc_set_changed_at(kper, kstp) + ! + ! -- return + return + end subroutine update_k_with_vsc + + !> @brief Mark K changes as having occurred at (kper, kstp) + !! + !! Procedure called by VSC code when K updated due to viscosity changes. + !! K values changed at (kper, kstp). + !! + !< + subroutine vsc_set_changed_at(this, kper, kstp) + ! -- dummy variables + class(GwfVscType) :: this + integer(I4B), intent(in) :: kper + integer(I4B), intent(in) :: kstp + ! + this%kchangeper = kper + this%kchangestp = kstp + ! + return + end subroutine vsc_set_changed_at + + subroutine vsc_ot_dv(this, idvfl) ! ****************************************************************************** -! vsc_ot_dv -- Save viscosity array to binary file +! vsc_ot_dv -- Save calculated viscosity array to binary file ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -414,27 +673,43 @@ subroutine vsc_da(this) ! -- Deallocate arrays if package was active if (this%inunit > 0) then call mem_deallocate(this%visc) + call mem_deallocate(this%ivisc) call mem_deallocate(this%concvsc) call mem_deallocate(this%dviscdc) call mem_deallocate(this%cviscref) call mem_deallocate(this%ctemp) - call mem_deallocate(this%a2) - call mem_deallocate(this%a3) - call mem_deallocate(this%a4) deallocate (this%cmodelname) deallocate (this%cauxspeciesname) deallocate (this%modelconc) end if ! ! -- Scalars - call mem_deallocate(this%ivisc) + call mem_deallocate(this%thermivisc) call mem_deallocate(this%idxtmpr) call mem_deallocate(this%ioutvisc) + call mem_deallocate(this%ireadelev) call mem_deallocate(this%ireadconcvsc) call mem_deallocate(this%iconcset) call mem_deallocate(this%viscref) - call mem_deallocate(this%nviscspecies) + call mem_deallocate(this%a2) + call mem_deallocate(this%a3) + call mem_deallocate(this%a4) + ! + ! -- Nullify pointers to other package variables + nullify (this%ik22overk) + nullify (this%ik33overk) + nullify (this%k11) + nullify (this%k22) + nullify (this%k33) + nullify (this%k11_input) + nullify (this%k22_input) + nullify (this%k33_input) + nullify (this%ik22) + nullify (this%ik33) + nullify (this%kchangeper) + nullify (this%kchangestp) + nullify (this%nodekchange) ! ! -- deallocate parent call this%NumericalPackageType%da() @@ -566,6 +841,9 @@ subroutine read_packagedata(this) call store_error(errmsg) else this%idxtmpr = iviscspec + if (this%thermivisc == 2) then + this%ivisc(iviscspec) = 2 + end if endif end if end do @@ -636,7 +914,8 @@ subroutine vsc_calcvisc(this) integer(I4B) :: i ! ------------------------------------------------------------------------------ ! - ! -- Calculate the viscosity using the specified concentration array + ! -- Calculate the viscosity using the specified concentration and/or + ! temperature arrays do n = 1, this%dis%nodes do i = 1, this%nviscspecies if (this%modelconc(i)%icbund(n) == 0) then @@ -654,10 +933,11 @@ subroutine vsc_calcvisc(this) ! this% !else ! Concentration - this%visc(n) = calc_visc(this%ivisc, this%viscref, this%dviscdc, & - this%cviscref, this%ctemp, this%a2, & - this%a3, this%a4) + this%visc(n) = calc_visc(this%ivisc, this%viscref, this%dviscdc, & + this%cviscref, this%ctemp, this%a2, & + this%a3, this%a4) !end if + end do ! ! -- Return @@ -682,9 +962,10 @@ subroutine allocate_scalars(this) call this%NumericalPackageType%allocate_scalars() ! ! -- Allocate - call mem_allocate(this%ivisc, 'IVISC', this%memoryPath) + call mem_allocate(this%thermivisc, 'THERMIVISC', this%memoryPath) call mem_allocate(this%idxtmpr, 'IDXTMPR', this%memoryPath) call mem_allocate(this%ioutvisc, 'IOUTVISC', this%memoryPath) + call mem_allocate(this%ireadelev, 'IREADELEV', this%memoryPath) call mem_allocate(this%ireadconcvsc, 'IREADCONCVSC', this%memoryPath) call mem_allocate(this%iconcset, 'ICONCSET', this%memoryPath) call mem_allocate(this%viscref, 'VISCREF', this%memoryPath) @@ -695,9 +976,10 @@ subroutine allocate_scalars(this) call mem_allocate(this%nviscspecies, 'NVISCSPECIES', this%memoryPath) ! ! -- Initialize - this%ivisc = 0 + this%thermivisc = 0 this%idxtmpr = 0 this%ioutvisc = 0 + this%ireadelev = 0 this%iconcset = 0 this%ireadconcvsc = 0 this%viscref = 1000.d0 @@ -729,6 +1011,7 @@ subroutine allocate_arrays(this, nodes) ! -- Allocate call mem_allocate(this%visc, nodes, 'VISC', this%memoryPath) call mem_allocate(this%concvsc, 0, 'CONCVSC', this%memoryPath) + call mem_allocate(this%ivisc, this%nviscspecies, 'IVISC', this%memoryPath) call mem_allocate(this%dviscdc, this%nviscspecies, 'DRHODC', this%memoryPath) call mem_allocate(this%cviscref, this%nviscspecies, 'CRHOREF', this%memoryPath) call mem_allocate(this%ctemp, this%nviscspecies, 'CTEMP', this%memoryPath) @@ -743,6 +1026,7 @@ subroutine allocate_arrays(this, nodes) ! ! -- Initialize nviscspecies arrays do i = 1, this%nviscspecies + this%ivisc(i) = 1 this%dviscdc(i) = DZERO this%cviscref(i) = DZERO this%ctemp(i) = DZERO @@ -815,11 +1099,11 @@ subroutine read_options(this) 'FOLLOWED BY FILEOUT' call store_error(errmsg) end if - case ('VISCOSITY_FUNC') + case ('THERMAL_VISCOSITY_FUNC') call this%parser%GetStringCaps(keyword2) - if (trim(adjustl(keyword2)) == 'LINEAR') this%ivisc = 1 - if (trim(adjustl(keyword2)) == 'NONLINEAR') this%ivisc = 2 - select case (this%ivisc) + if (trim(adjustl(keyword2)) == 'LINEAR') this%thermivisc = 1 + if (trim(adjustl(keyword2)) == 'NONLINEAR') this%thermivisc = 2 + select case (this%thermivisc) case (1) write (this%iout, fmtlinear) case (2) @@ -851,27 +1135,31 @@ subroutine read_options(this) end select end do ! - if (this%ivisc == 1) then + if (this%thermivisc == 1) then if (this%a2 == 0.0) then write(errmsg, '(a)') 'LINEAR OPTION SELECTED FOR VARYING & - &VISCOSITY, BUT A1, A SURROGATE FOR dVISC/dT, SET EQUAL TO 0.0' + &VISCOSITY WITH TEMPERTURE, BUT A1, A SURROGATE FOR & + &dVISC/dT, SET EQUAL TO 0.0' call store_error(errmsg) end if end if - if (this%ivisc > 1) then + if (this%thermivisc > 1) then if(this%a2 == 0) then - write (warnmsg, '(a)') 'A2 SET EQUAL TO ZERO WHICH MAY LEAD TO & - &UNINTENDED VALUES FOR VISCOSITY' + write (warnmsg, '(a)') 'NONLINEAR OPTION SELECTED FOR & + &VARYING VISCOSITY WITH TEMPERATURE, BUT A2 SET EQUAL TO & + &ZERO WHICH MAY LEAD TO UNINTENDED VALUES FOR VISCOSITY' call store_warning(errmsg) end if if (this%a3 == 0) then - write (warnmsg, '(a)') 'A3 SET EQUAL TO ZERO WHICH MAY LEAD TO & - &UNINTENDED VALUES FOR VISCOSITY' + write (warnmsg, '(a)') 'NONLINEAR OPTION SELECTED FOR & + &VARYING VISCOSITY WITH TEMPERATURE, BUT A3 SET EQUAL TO & + &ZERO WHICH MAY LEAD TO UNINTENDED VALUES FOR VISCOSITY' call store_warning(warnmsg) end if if (this%a4 == 0) then - write (warnmsg, '(a)') 'A4 SET EQUAL TO ZERO WHICH MAY LEAD TO & - &UNINTENDED VALUES FOR VISCOSITY' + write (warnmsg, '(a)') 'NONLINEAR OPTION SELECTED FOR & + &VARYING VISCOSITY WITH TEMPERATURE, BUT A4 SET EQUAL TO & + &ZERO WHICH MAY LEAD TO UNINTENDED VALUES FOR VISCOSITY' call store_warning(warnmsg) end if end if @@ -890,7 +1178,9 @@ subroutine set_options(this, input_data) type(GwfVscInputDataType), intent(in) :: input_data !< the input data to be set this%viscref = input_data%viscref - + ! + ! -- Return + return end subroutine set_options diff --git a/src/Model/ModelUtilities/GwfNpfGridData.f90 b/src/Model/ModelUtilities/GwfNpfGridData.f90 index eaafea9a08a..f93c8ce6b2c 100644 --- a/src/Model/ModelUtilities/GwfNpfGridData.f90 +++ b/src/Model/ModelUtilities/GwfNpfGridData.f90 @@ -21,6 +21,9 @@ module GwfNpfGridDataModule real(DP), dimension(:), pointer, contiguous :: k11 => null() !< same as npf variable real(DP), dimension(:), pointer, contiguous :: k22 => null() !< same as npf variable real(DP), dimension(:), pointer, contiguous :: k33 => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: k11_input => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: k22_input => null() !< same as npf variable + real(DP), dimension(:), pointer, contiguous :: k33_input => null() !< same as npf variable real(DP), dimension(:), pointer, contiguous :: wetdry => null() !< same as npf variable real(DP), dimension(:), pointer, contiguous :: angle1 => null() !< same as npf variable real(DP), dimension(:), pointer, contiguous :: angle2 => null() !< same as npf variable @@ -53,6 +56,9 @@ subroutine construct(this, nodes) allocate (this%k11(nodes)) allocate (this%k22(nodes)) allocate (this%k33(nodes)) + allocate (this%k11_input(nodes)) + allocate (this%k22_input(nodes)) + allocate (this%k33_input(nodes)) allocate (this%wetdry(nodes)) allocate (this%angle1(nodes)) allocate (this%angle2(nodes)) @@ -63,6 +69,9 @@ subroutine construct(this, nodes) this%k11(i) = DZERO this%k22(i) = DZERO this%k33(i) = DZERO + this%k11_input(i) = DZERO + this%k22_input(i) = DZERO + this%k33_input(i) = DZERO this%wetdry(i) = DZERO this%angle1(i) = DZERO this%angle2(i) = DZERO @@ -80,6 +89,9 @@ subroutine destroy(this) deallocate (this%k11) deallocate (this%k22) deallocate (this%k33) + deallocate (this%k11_input) + deallocate (this%k22_input) + deallocate (this%k33_input) deallocate (this%wetdry) deallocate (this%angle1) deallocate (this%angle2) From 1ac491460aefb834d0bd59b2c80671724505f48c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 13 Sep 2022 11:21:23 -0700 Subject: [PATCH 035/212] A couple of relatively minor changes to go along with changes made on the current 'develop' branch --- src/Model/Connection/GwfInterfaceModel.f90 | 2 +- src/Model/GroundWaterFlow/gwf3.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index 91a260df73a..26d0b2eaeb9 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -126,7 +126,7 @@ subroutine gwfifm_ar(this) call npfGridData%construct(this%dis%nodes) call this%setNpfGridData(npfGridData) - call this%npf%npf_ar(this%ic, this%vsc, this%ibound, this%x, ikmod, npfGridData) ! kluge note: added local "ikmod" as a placeholder; speak to Martijn about integrating VSC + call this%npf%npf_ar(this%ic, this%vsc, this%ibound, this%x, npfGridData) ! kluge note: added local "ikmod" as a placeholder; speak to Martijn about integrating VSC call npfGridData%destroy() if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index 6841087bced..78bbb92047d 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -433,7 +433,7 @@ subroutine gwf_ar(this) ! -- Allocate and read modules attached to model if (this%inic > 0) call this%ic%ic_ar(this%x) if (this%innpf > 0) call this%npf%npf_ar(this%ic, this%vsc, this%ibound, & - this%x, ikmodgwf) + this%x) if (this%invsc > 0) call this%vsc%vsc_ar(this%ibound) if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) if (this%inhfb > 0) call this%hfb%hfb_ar(this%ibound, this%xt3d, this%dis) From ced1b3d79c7a45558c580f3b81c37a8128a12921 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 13 Sep 2022 11:23:10 -0700 Subject: [PATCH 036/212] Some relatively minor changes to go along with changes made on the mf6 'develop' branch (stuff in this commit should have been included in the previous commit) --- src/Model/GroundWaterFlow/gwf3npf8.f90 | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 3183b0d24d3..58e02c40606 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -54,7 +54,6 @@ module GwfNpfModule integer(I4B), pointer :: iwetit => null() !< wetting interval (default is 1) integer(I4B), pointer :: ihdwet => null() !< (0 or not 0) integer(I4B), pointer :: icellavg => null() !< harmonic(0), logarithmic(1), or arithmetic thick-log K (2) - integer(I4B), pointer :: icellavg => null() !< harmonic(0), logarithmic(1), or arithmetic thick-log K (2) real(DP), pointer :: wetfct => null() !< wetting factor real(DP), pointer :: hdry => null() !< default is -1.d30 integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< confined (0) or convertible (1) @@ -298,7 +297,7 @@ end subroutine npf_mc !! from the input argument (when the optional @param grid_data is passed), !! preprocess the input data and call *_ar on xt3d, when active. !< - subroutine npf_ar(this, ic, vsc, ibound, hnew, ikmodgwf, grid_data) + subroutine npf_ar(this, ic, vsc, ibound, hnew, grid_data) ! ****************************************************************************** ! npf_ar -- Allocate and Read ! ****************************************************************************** @@ -311,7 +310,6 @@ subroutine npf_ar(this, ic, vsc, ibound, hnew, ikmodgwf, grid_data) type(GwfVscType), pointer, intent(in) :: vsc !< viscosity package integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array - real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array type(GwfNpfGridDataType), optional, intent(in) :: grid_data !< (optional) data structure with NPF grid data ! -- local ! -- formats @@ -328,9 +326,6 @@ subroutine npf_ar(this, ic, vsc, ibound, hnew, ikmodgwf, grid_data) this%vsc => vsc end if ! - ! -- Set flag to indicate whether conductivities get modified from their input values - this%ikmod = ikmodgwf - ! ! -- allocate arrays call this%allocate_arrays(this%dis%nodes, this%dis%njas) ! From 678c2ae7e8138cd3eb6bded5e08c12dd34c31c6d Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 13 Sep 2022 11:24:00 -0700 Subject: [PATCH 037/212] Accounting for viscosity in the basic boundary packages (DRN, RIV, GHB) --- src/Model/GroundWaterFlow/gwf3drn8.f90 | 19 ++++- src/Model/GroundWaterFlow/gwf3ghb8.f90 | 20 +++++- src/Model/GroundWaterFlow/gwf3riv8.f90 | 19 ++++- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 60 +++++++++------- src/Model/ModelUtilities/BoundaryPackage.f90 | 73 +++++++++++++++++++- 5 files changed, 157 insertions(+), 34 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3drn8.f90 b/src/Model/GroundWaterFlow/gwf3drn8.f90 index b5cf8d10893..1472969f26a 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -1,8 +1,9 @@ module DrnModule - use KindModule, only: DP, I4B + use KindModule, only: DP, I4B, LGP use ConstantsModule, only: DZERO, DONE, DTWO, & - LENFTYPE, LENPACKAGENAME, LENAUXNAME, LINELENGTH - use MemoryHelperModule, only: create_mem_path + LENFTYPE, LENPACKAGENAME, LENAUXNAME, LINELENGTH, & + LENMEMPATH, LENVARNAME, LENMEMSEPARATOR + use MemoryHelperModule, only: create_mem_path, split_mem_address use SmoothingModule, only: sQSaturation, sQSaturationDerivative, & sQuadraticSaturation use BndModule, only: BndType @@ -19,6 +20,7 @@ module DrnModule ! character(len=LENFTYPE) :: ftype = 'DRN' character(len=LENPACKAGENAME) :: text = ' DRN' + character(len=LENMEMSEPARATOR), parameter :: memPathSeparator = '/' ! type, extends(BndType) :: DrnType @@ -65,6 +67,10 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) character(len=*), intent(in) :: pakname ! -- local type(DrnType), pointer :: drnobj + character(len=LENMEMPATH) :: vscpath !< if vsc exist, this is path name + character(len=LENMEMPATH) :: locmempath !< the memory path for the model + character(len=LENVARNAME) :: locvarname !< the package name to check on + logical(LGP) :: vscexists !< flag will be true if vsc is active ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables @@ -90,6 +96,13 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%iscloc = 2 !sfac applies to conductance packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! + ! -- check if vsc package exists and set flag if so + vscpath = trim(namemodel)//memPathSeparator//'VSC' + call split_mem_address(vscpath, locmempath, locvarname, vscexists) + if (vscexists) then + packobj%ivsc = 1 + end if + ! ! -- return return end subroutine drn_create diff --git a/src/Model/GroundWaterFlow/gwf3ghb8.f90 b/src/Model/GroundWaterFlow/gwf3ghb8.f90 index 9757b1a16c4..15cc177d587 100644 --- a/src/Model/GroundWaterFlow/gwf3ghb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ghb8.f90 @@ -1,7 +1,8 @@ module ghbmodule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME - use MemoryHelperModule, only: create_mem_path + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME, LENMEMPATH, & + LENVARNAME, LENMEMSEPARATOR + use MemoryHelperModule, only: create_mem_path, split_mem_address use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor use TimeSeriesLinkModule, only: TimeSeriesLinkType, & @@ -15,8 +16,10 @@ module ghbmodule ! character(len=LENFTYPE) :: ftype = 'GHB' character(len=LENPACKAGENAME) :: text = ' GHB' + character(len=LENMEMSEPARATOR), parameter :: memPathSeparator = '/' ! type, extends(BndType) :: GhbType + contains procedure :: bnd_options => ghb_options procedure :: bnd_ck => ghb_ck @@ -51,6 +54,10 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) character(len=*), intent(in) :: pakname ! -- local type(GhbType), pointer :: ghbobj + character(len=LENMEMPATH) :: vscpath !< if vsc exist, this is path name + character(len=LENMEMPATH) :: locmempath !< the memory path for the model + character(len=LENVARNAME) :: locvarname !< the package name to check on + logical(LGP) :: vscexists !< flag will be true if vsc is active ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables @@ -75,6 +82,13 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%iscloc = 2 packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! + ! -- check if vsc package exists and set flag if so + vscpath = trim(namemodel)//memPathSeparator//'VSC' + call split_mem_address(vscpath, locmempath, locvarname, vscexists) + if (vscexists) then + packobj%ivsc = 1 + end if + ! ! -- return return end subroutine ghb_create diff --git a/src/Model/GroundWaterFlow/gwf3riv8.f90 b/src/Model/GroundWaterFlow/gwf3riv8.f90 index f14e93fa2f7..31357fb05b4 100644 --- a/src/Model/GroundWaterFlow/gwf3riv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3riv8.f90 @@ -1,7 +1,8 @@ module rivmodule - use KindModule, only: DP, I4B - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME - use MemoryHelperModule, only: create_mem_path + use KindModule, only: DP, I4B, LGP + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME, LENMEMPATH, & + LENVARNAME, LENMEMSEPARATOR + use MemoryHelperModule, only: create_mem_path, split_mem_address use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor use TimeSeriesLinkModule, only: TimeSeriesLinkType, & @@ -15,6 +16,7 @@ module rivmodule ! character(len=LENFTYPE) :: ftype = 'RIV' character(len=LENPACKAGENAME) :: text = ' RIV' + character(len=LENMEMSEPARATOR), parameter :: memPathSeparator = '/' ! type, extends(BndType) :: RivType contains @@ -51,6 +53,10 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) character(len=*), intent(in) :: pakname ! -- local type(RivType), pointer :: rivobj + character(len=LENMEMPATH) :: vscpath !< if vsc exist, this is path name + character(len=LENMEMPATH) :: locmempath !< the memory path for the model + character(len=LENVARNAME) :: locvarname !< the package name to check on + logical(LGP) :: vscexists !< flag will be true if vsc is active ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables @@ -75,6 +81,13 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%iscloc = 2 !sfac applies to conductance packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! + ! -- check if vsc package exists and set flag if so + vscpath = trim(namemodel)//memPathSeparator//'VSC' + call split_mem_address(vscpath, locmempath, locvarname, vscexists) + if (vscexists) then + packobj%ivsc = 1 + end if + ! ! -- return return end subroutine riv_create diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 2c5297ea7c9..4aa15d1c8f7 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -388,7 +388,7 @@ subroutine vsc_ad_bnd(this, packobj, hnew) end if end do ! - ! -- find aux columns for concentrations that affect density + ! -- find aux columns for conc (or temp.) that affect viscosity do i = 1, this%nviscspecies locconc(i) = 0 do j = 1, packobj%naux @@ -406,16 +406,25 @@ subroutine vsc_ad_bnd(this, packobj, hnew) ! ! -- apply viscosity terms to inflow from boundary based on package type select case (packobj%filtyp) - case ('GHB') + case ('GHB', 'DRN', 'RIV') ! ! -- general head boundary - call vsc_ad_ghb(packobj, hnew, this%visc, this%viscref, locelev, & - locvisc, locconc, this%dviscdc, this%cviscref, & - this%ivisc, this%a2, this%a3, this%a4, this%ctemp) - !case ('DRN') - ! ! - ! ! -- drain boundary - ! call vsc_ad_drn(packobj, hnew, this%viscref) + call vsc_ad_standard_bnd(packobj, hnew, this%visc, this%viscref, & + locelev, locvisc, locconc, this%dviscdc, & + this%cviscref, this%ivisc, this%a2, this%a3, & + this%a4, this%ctemp) + case ('LAK') + ! + ! -- lake + case ('SFR') + ! + ! -- streamflow routing + case ('MAW') + ! + ! -- multi-aquifer well + case ('UZF') + ! + ! -- unsaturated-zone flow case default ! ! -- nothing @@ -433,8 +442,9 @@ end subroutine vsc_ad_bnd !! When flow enters from ghb boundary type, take into account the effects !! of viscosity on the user-specified conductance terms !< - subroutine vsc_ad_ghb(packobj, hnew, visc, viscref, locelev, locvisc, & - locconc, dviscdc, cviscref, ivisc, a2, a3, a4, ctemp) + subroutine vsc_ad_standard_bnd(packobj, hnew, visc, viscref, locelev, & + locvisc, locconc, dviscdc, cviscref, & + ivisc, a2, a3, a4, ctemp) ! -- modules use BndModule, only: BndType class(BndType), pointer :: packobj @@ -467,38 +477,40 @@ subroutine vsc_ad_ghb(packobj, hnew, visc, viscref, locelev, locvisc, & ! ! -- calculate the viscosity associcated with the boundary viscghb = calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, & - cviscref, ctemp, ivisc, a2, a3, a4, & - packobj%auxvar) - ! cviscref, ctemp, ivisc, packobj%auxvar) + cviscref, ctemp, ivisc, a2, a3, a4, & + packobj%auxvar) ! - ! -- get the viscosity ratio - viscratio = update_bnd_cond(viscghb, viscref) + ! -- update boundary conductance based on viscosity effects + packobj%bound(2,n) = update_bnd_cond(viscghb, viscref, & + packobj%condinput(n)) ! - ! -- - - ! - ! -- viscosity end do ! ! -- Return return - end subroutine vsc_ad_ghb + end subroutine vsc_ad_standard_bnd !> @brief apply bnd viscosity to the conductance term !! !! When the viscosity package is active apply the viscosity ratio to the !! active boundary package's conductance term. !< - function update_bnd_cond(bndvisc, viscref) result(vsc_ratio) + function update_bnd_cond(bndvisc, viscref, spcfdcond) result(updatedcond) ! -- modules ! -- dummy real(DP), intent(in) :: viscref real(DP), intent(in) :: bndvisc + real(DP), intent(in) :: spcfdcond ! -- local - real(DP) :: vsc_ratio + real(DP) :: vscratio + real(DP) :: updatedcond + integer(I4B) :: n ! ------------------------------------------------------------------------------- ! - vsc_ratio = viscref / bndvisc + vscratio = viscref / bndvisc + ! + ! -- calculate new conductance here!! + updatedcond = vscratio * spcfdcond ! ! -- Return return diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 6d42c17b35e..4b51cbdaacc 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -80,9 +80,13 @@ module BndModule real(DP), dimension(:), pointer, contiguous :: simtomvr => null() !< simulated to mover values ! ! -- water mover flag and object - integer(I4B), pointer :: imover => null() !< flag indicating of the mover is active in the package + integer(I4B), pointer :: imover => null() !< flag indicating if the mover is active in the package type(PackageMoverType), pointer :: pakmvrobj => null() !< mover object for package ! + ! -- viscosity flag and safe-copy of conductance array + integer(I4B), pointer :: ivsc => null() !< flag indicating if viscosity is active in the model + real(DP), dimension(:), pointer, contiguous :: condinput => null() !< stores user-specified conductance values + ! ! -- timeseries type(TimeSeriesManagerType), pointer :: TsManager => null() !< time series manager type(TimeArraySeriesManagerType), pointer :: TasManager => null() !< time array series manager @@ -152,6 +156,9 @@ module BndModule ! -- procedure to support time series procedure, public :: bnd_rp_ts ! + ! -- procedure to backup user-specified conductance + procedure, private :: bnd_store_user_cond + ! end type BndType contains @@ -361,6 +368,12 @@ subroutine bnd_rp(this) this%packName, this%tsManager, this%iscloc) this%nbound = nlist ! + ! -- save user-specified conductance if vsc package is active + if (this%ivsc == 1) then + call this%bnd_store_user_cond(nlist, this%nodelist, this%bound, & + this%condinput) + end if + ! ! Define the tsLink%Text value(s) appropriately. ! E.g. for WEL package, entry 1, assign tsLink%Text = 'Q' ! For RIV package, entry 1 text = 'STAGE', entry 2 text = 'COND', @@ -901,6 +914,7 @@ subroutine bnd_da(this) call mem_deallocate(this%nodelist, 'NODELIST', this%memoryPath) call mem_deallocate(this%noupdateauxvar, 'NOUPDATEAUXVAR', this%memoryPath) call mem_deallocate(this%bound, 'BOUND', this%memoryPath) + call mem_deallocate(this%condinput, 'CONDINPUT', this%memoryPath) call mem_deallocate(this%hcof, 'HCOF', this%memoryPath) call mem_deallocate(this%rhs, 'RHS', this%memoryPath) call mem_deallocate(this%simvals, 'SIMVALS', this%memoryPath) @@ -957,6 +971,7 @@ subroutine bnd_da(this) call mem_deallocate(this%imover) call mem_deallocate(this%npakeq) call mem_deallocate(this%ioffset) + call mem_deallocate(this%ivsc) ! ! -- deallocate methods on objects call this%obs%obs_da() @@ -1015,6 +1030,9 @@ subroutine allocate_scalars(this) ! -- allocate the object and assign values to object variables call mem_allocate(this%imover, 'IMOVER', this%memoryPath) ! + ! -- allocate flag for determining if vsc active + call mem_allocate(this%ivsc, 'IVSC', this%memoryPath) + ! ! -- allocate scalars for packages that add rows to the matrix (e.g. MAW) call mem_allocate(this%npakeq, 'NPAKEQ', this%memoryPath) call mem_allocate(this%ioffset, 'IOFFSET', this%memoryPath) @@ -1042,6 +1060,7 @@ subroutine allocate_scalars(this) this%imover = 0 this%npakeq = 0 this%ioffset = 0 + this%ivsc = 0 ! ! -- Set pointer to model inewton variable call mem_setptr(imodelnewton, 'INEWTON', create_mem_path(this%name_model)) @@ -1091,6 +1110,17 @@ subroutine allocate_arrays(this, nodelist, auxvar) call mem_allocate(this%bound, this%ncolbnd, this%maxbound, 'BOUND', & this%memoryPath) ! + !-- Allocate array for storing user-specified conductances if vsc active + if (this%ivsc == 1) then + call mem_allocate(this%condinput, this%maxbound, 'CONDINPUT', & + this%memoryPath) + do i = 1, this%maxbound + this%condinput(i) = DZERO + end do + else + call mem_allocate(this%condinput, 0, 'CONDINPUT', this%memoryPath) + end if + ! ! -- Allocate hcof and rhs call mem_allocate(this%hcof, this%maxbound, 'HCOF', this%memoryPath) call mem_allocate(this%rhs, this%maxbound, 'RHS', this%memoryPath) @@ -1470,6 +1500,47 @@ subroutine bnd_read_dimensions(this) ! -- return return end subroutine bnd_read_dimensions + + !> @ brief Store user-specified conductances when vsc is active + !! + !! VSC will update boundary package conductance values. Because + !! viscosity can change every stress period, but user-specified + !! conductances may not, the base user-input should be stored in + !! backup array so that viscosity-updated conductances may be + !! recalculated every stress period/time step + !! + !< + subroutine bnd_store_user_cond(this, nlist, nodelist, rlist, condinput) + ! -- modules + use SimModule, only: store_error + ! -- dummy variables + class(BndType), intent(inout) :: this !< BndType object + integer(I4B), intent(in) :: nlist + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: nodelist + real(DP), dimension(:, :), pointer, contiguous, intent(in) :: rlist + real(DP), dimension(:), pointer, contiguous, intent(inout) :: condinput + ! -- local variables + integer(I4B) :: l + integer(I4B) :: nodeu, noder + character(len=LINELENGTH) :: nodestr + ! + ! -- store backup copy of conductance values + do l = 1, nlist + nodeu = nodelist(l) + noder = this%dis%get_nodenumber(nodeu, 0) + if (noder <= 0) then + call this%dis%nodeu_to_string(nodeu, nodestr) + write (errmsg, *) & + ' Cell is outside active grid domain: '// & + trim(adjustl(nodestr)) + call store_error(errmsg) + end if + condinput(l) = rlist(2,l) + end do + ! + ! -- return + return + end subroutine !> @ brief Read initial parameters for package !! From 352f035fb33f813fb10b168d145b5925809c5b03 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 21 Sep 2022 16:51:31 -0700 Subject: [PATCH 038/212] commit LAK for resolving conflicts --- src/Model/GroundWaterFlow/gwf3lak8.f90 | 42 +++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index 4efbc26159e..096d4b9c1cb 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -190,6 +190,9 @@ module LakModule integer(I4B), pointer :: idense real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() ! + ! -- viscosity variables + real(DP), dimension(:, :), pointer, contiguous :: viscratios => null() !< viscosity ratios (1: lak vsc ratio; 2: gwf vsc ratio) + ! ! -- type bound procedures contains procedure :: lak_allocate_scalars @@ -267,7 +270,9 @@ module LakModule ! -- density procedure :: lak_activate_density procedure, private :: lak_calculate_density_exchange - end type LakType + ! -- viscosity + procedure :: lak_activate_viscosity +end type LakType contains @@ -445,6 +450,9 @@ subroutine lak_allocate_arrays(this) ! -- allocate denseterms to size 0 call mem_allocate(this%denseterms, 3, 0, 'DENSETERMS', this%memoryPath) ! + ! -- allocate viscratios to size 0 + call mem_allocate(this%viscratios, 3, 0, 'VISCRATIOS', this%memoryPath) + ! ! -- return return end subroutine lak_allocate_arrays @@ -4447,6 +4455,7 @@ subroutine lak_da(this) call mem_deallocate(this%qleak) call mem_deallocate(this%qsto) call mem_deallocate(this%denseterms) + call mem_deallocate(this%viscratios) ! ! -- tables if (this%ntables > 0) then @@ -4511,6 +4520,7 @@ subroutine lak_da(this) call mem_deallocate(this%bditems) call mem_deallocate(this%cbcauxitems) call mem_deallocate(this%idense) + call mem_deallocate(this%ivsc) ! call mem_deallocate(this%nlakeconn) call mem_deallocate(this%idxlakeconn) @@ -6357,6 +6367,36 @@ subroutine lak_activate_density(this) return end subroutine lak_activate_density + !> @brief Activate viscosity terms + !! + !! Method to activate addition of viscosity terms for a LAK package reach. + !! + !< + subroutine lak_activate_viscosity(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + ! -- dummy variables + class(LakType), intent(inout) :: this !< LakType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + ! + ! -- Set ivsc and reallocate viscratios to be of size MAXBOUND + this%ivsc = 1 + call mem_reallocate(this%viscratios, 3, this%MAXBOUND, 'VISCRATIOS', & + this%memoryPath) + do i = 1, this%maxbound + do j = 1, 3 + this%viscratios(j, i) = DZERO + end do + end do + write (this%iout, '(/1x,a)') 'VISCOSITY HAS BEEN ACTIVATED FOR LAK & + &PACKAGE: '//trim(adjustl(this%packName)) + ! + ! -- return + return + end subroutine lak_activate_viscosity + subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & botl, flow, gwfhcof, gwfrhs) ! ****************************************************************************** From 79027b82beb2ec7cd78550f415313695cda6d1e0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 22 Sep 2022 15:32:53 -0700 Subject: [PATCH 039/212] work on advanced packages w/ viscosity. Adding another example problem w/ SFR --- autotest/ex-gwf-vsc03_sfr.py | 470 +++++++++++++++++++++++++ src/Model/GroundWaterFlow/gwf3.f90 | 2 +- src/Model/GroundWaterFlow/gwf3maw8.f90 | 40 +++ src/Model/GroundWaterFlow/gwf3npf8.f90 | 3 - src/Model/GroundWaterFlow/gwf3sfr8.f90 | 44 ++- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 146 +++++++- 6 files changed, 697 insertions(+), 8 deletions(-) create mode 100644 autotest/ex-gwf-vsc03_sfr.py diff --git a/autotest/ex-gwf-vsc03_sfr.py b/autotest/ex-gwf-vsc03_sfr.py new file mode 100644 index 00000000000..d1bac18c3bb --- /dev/null +++ b/autotest/ex-gwf-vsc03_sfr.py @@ -0,0 +1,470 @@ +import sys +import math +from io import StringIO +import os +import shutil +import numpy as np +from subprocess import check_output +import flopy + +# Append to system path to include the common subdirectory + +sys.path.append(os.path.join("..", "common")) + +# Import common functionality + +import config +from figspecs import USGSFigure + +mf6exe = os.path.abspath(config.mf6_exe) + +# Base simulation and model name and workspace + +ws = os.path.join('temp', 'examples', 'vsc-sfr01') + + +# Equation for determining land surface elevation with a stream running down the middle +def topElev_sfrCentered(x, y): + return ((-0.003 * x) + 260.) + (((-2E-9 * (x - 5000.)) + 1E-5) * (y + 1500.)**2) + +# Model units +length_units = "m" +time_units = "days" + +# model domain and grid definition +Lx = 10000. +Ly = 3000. +nrow = 60 +ncol = 200 +nlay = 1 +delr = Lx / ncol +delc = Ly / nrow +xmax = ncol * delr +ymax = nrow * delc +X, Y = np.meshgrid(np.linspace(delr / 2, xmax - delr / 2, ncol), + np.linspace(ymax - delc / 2, 0 + delc / 2, nrow)) +ibound = np.ones((nlay, nrow, ncol)) +# Because eqn uses negative values in the Y direction, need to do a little manipulation +Y_m = -1 * np.flipud(Y) +top = topElev_sfrCentered(X, Y_m) +botm = np.zeros(top.shape) +strthd = top - 10. + +# NPF parameters +k11 = 1 +ss = 0.00001 +sy = 0.20 +hani = 1 +laytyp = 1 + +# Package boundary conditions +viscref = 8.904e-4 + +# time params +steady = {0: True, 1: False} +transient = {0: False, 1: True} +nstp = [10, 20] +tsmult = [1, 1] +perlen = [1, 20] + +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-3, 1e-4, 0.97 + +# Transport related parameters +initial_temperature = 35.0 # Initial temperature (unitless) +porosity = 0.20 # porosity (unitless) +K_therm = 2.0 # Thermal conductivity # ($W/m/C$) +rho_water = 1000 # Density of water ($kg/m^3$) +rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) +C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) +C_s = 880 # Heat capacity of the solids ($J/kg/C$) +D_m = K_therm / (porosity * rho_water * C_p_w) +rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) +K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) + + +# MODFLOW 6 flopy GWF & GWT simulation object (sim) is returned +# +def build_model(idx, sim_folder='vsc_wSFR'): + print("Building model...{}".format(sim_folder)) + + # generate names for each model + name = "vsc" + gwfname = "gwf-" + name + str(idx) + "-sfr" + gwtname = "gwt-" + name + str(idx) + "-sfr" + + sim_ws = os.path.join(ws, sim_folder) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe + ) + + tdis_rc = [] + for i in range(len(nstp)): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + flopy.mf6.ModflowTdis( + sim, nper=len(nstp), perioddata=tdis_rc, time_units=time_units + ) + + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + newtonoptions="newton" + ) + + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="cooley", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(ims, [gwfname]) + + # Instantiate discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + + # Instantiate node property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=1, # >0 means saturated thickness varies with computed head + k=k11 + ) + + # Instantiate storage package + flopy.mf6.ModflowGwfsto( + gwf, + save_flows=False, + iconvert=laytyp, + ss=ss, + sy=sy, + steady_state=steady, + transient=transient, + ) + + # Instantiate initial conditions package + flopy.mf6.ModflowGwfic(gwf, strt=strthd) + + # Instantiate viscosity package + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, 20.0, gwtname, "TEMPERATURE")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=viscref, + viscosity_filerecord=vsc_filerecord, + viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname='vsc', + filename="{}.vsc".format(gwfname) + ) + + # Instantiate output control package + flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{gwfname}.cbc", + head_filerecord=f"{gwfname}.hds", + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "LAST")], + ) + + # Instantiate recharge package + # total inflow 2000.0 on each side (4,000 total) + rech = np.zeros_like(top) + rech_rate_lo = 0.001 + rech_rate_hi = 0.015 + for i in np.arange(ncol): + rech[0, i] = rech_rate_lo + \ + (rech_rate_hi - rech_rate_lo) / ncol*i + + rech[-1, :] = rech[0, :] + irch = np.zeros_like(rech) + irch = irch.astype(int) + temperature_array = np.ones_like(irch) * 15.0 + aux = {0: [temperature_array]} + flopy.mf6.ModflowGwfrcha( + gwf, + print_flows=True, + recharge=rech, + irch=irch, + auxiliary=["TEMPERATURE"], + aux=aux, + pname='RCHA-1', + filename="{}.rcha".format(gwfname) + ) + + # Instantiate evapotranspiration package + # ET rate is 0.003 everywhere in the model + evtr_lo = 0.0001 + evtr_hi = 0.012 + extdp_hi = 30 + extdp_lo = 10 + evtspd = [] + for i in np.arange(nrow): + for j in np.arange(ncol): + evtr = evtr_hi - (evtr_hi - evtr_lo) / ncol * j + extdp = extdp_hi - (extdp_hi - extdp_lo) / ncol * j + # cellid, surface, rate, depth, [pxdp], [petm], [petm0], [aux] + evtspd.append([(0, i, j), top[i, j], evtr, extdp, 1.0, 0.0]) + surf_rate_specified = True + flopy.mf6.ModflowGwfevt( + gwf, + print_flows=False, + surf_rate_specified=surf_rate_specified, + maxbound=nrow*ncol, + nseg=1, + stress_period_data=evtspd, + auxiliary='TEMPERATURE', + pname='EVT-1', + filename="{}.evt".format(gwfname) + ) + + # Instantiate streamflow routing package + + # Determine the middle row and store in rMid (account for 0-base) + rMid = nrow // 2 - 1 + # sfr data + nreaches = ncol + rlen = delr + rwid = 7.0 + roughness = 0.035 + rbth = 1.0 + rhk = 1.0 + strm_up = 254.899750 + strm_dn = 225.150250 + slope = (strm_up - strm_dn) / ((ncol - 1) * delr) + ustrf = 1.0 + ndv = 0 + strm_incision = 10 + viscaux = 1.111111111 + temperatureaux = 8.0 + + + packagedata = [] + for irch in range(nreaches): + nconn = 1 + if 0 < irch < nreaches - 1: + nconn += 1 + rp = [ + irch, + (0, rMid, irch), + rlen, + rwid, + slope, + top[rMid, irch] - strm_incision, + rbth, + rhk, + roughness, + nconn, + ustrf, + ndv, + viscaux, + temperatureaux + ] + packagedata.append(rp) + + connectiondata = [] + for irch in range(nreaches): + rc = [irch] + if irch > 0: + rc.append(irch - 1) + if irch < nreaches - 1: + rc.append(-(irch + 1)) + connectiondata.append(rc) + + inflow_loc = 0 + sfr_perioddata = [ + [inflow_loc, "inflow", 25000.0], + ] + sfr_perioddata = {0: sfr_perioddata} + + budpth = f"{gwfname}.sfr.cbc" + flopy.mf6.ModflowGwfsfr( + gwf, + print_stage=True, + print_flows=True, + print_input=False, + auxiliary=["VDUMMY", "TEMPERATURE"], + unit_conversion=1.486 * 86400, + budget_filerecord=budpth, + mover=False, + nreaches=nreaches, + packagedata=packagedata, + connectiondata=connectiondata, + perioddata=sfr_perioddata, + pname="SFR-1", + filename="{}.sfr".format(gwfname) + ) + + # Setup the GWT model for simulating heat transport + gwt = flopy.mf6.ModflowGwt(sim, modelname=gwtname) + imsgwt = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwtname), + ) + sim.register_ims_package(imsgwt, [gwtname]) + flopy.mf6.ModflowGwtdis( + gwt, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + + # Instantiate Mobile Storage and Transfer package + flopy.mf6.ModflowGwtmst( + gwt, + porosity=porosity, + sorption='linear', + bulk_density=rhob, + distcoef=K_d, + pname="MST-1", + filename="{}.mst".format(gwtname), + ) + + # Instantiate Transport Initial Conditions package + flopy.mf6.ModflowGwtic(gwt, strt=initial_temperature) + + # Instantiate Advection package + flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") + + # Instantiate Dispersion package (also handles conduction) + flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) + + # Instantiate Source/Sink Mixing package + sourcerecarray = [ + ("RCHA-1", "AUX", "TEMPERATURE"), + ("EVT-1", "AUX", "TEMPERATURE") + ] + flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) + + # Instantiate Streamflow Transport package + sftpackagedata = [] + for irno in range(ncol): + t = (irno, 0.0) + sftpackagedata.append(t) + + sftperioddata = [(0, "STATUS", "CONSTANT"), (0, "CONCENTRATION", 8.0)] + + flopy.mf6.modflow.ModflowGwtsft( + gwt, + boundnames=False, + save_flows=True, + print_input=False, + print_flows=True, + print_concentration=True, + concentration_filerecord=gwtname + ".sft.bin", + budget_filerecord=gwtname + ".sft.bud", + packagedata=sftpackagedata, + reachperioddata=sftperioddata, + flow_package_auxiliary_name="TEMPERATURE", + flow_package_name='SFR-1', + pname="SFT-1", + filename="{}.sft".format(gwtname), + ) + + # Instantiate Output Control package for transport + flopy.mf6.ModflowGwtoc( + gwt, + concentration_filerecord="{}.ucn".format(gwtname), + saverecord=[("CONCENTRATION", "ALL")], + printrecord=[("CONCENTRATION", "LAST"), ("BUDGET", "LAST")], + filename="{}.oc".format(gwtname), + ) + + # Instantiate Gwf-Gwt Exchange package + flopy.mf6.ModflowGwfgwt( + sim, + exgtype="GWF6-GWT6", + exgmnamea=gwfname, + exgmnameb=gwtname, + filename="{}.gwfgwt".format(gwtname), + ) + + return sim + + +# Function to write model files + + +def write_model(sim, silent=True): + if config.writeModel: + sim.write_simulation(silent=silent) + return + +# Function to run the model +# True is returned if the model runs successfully + + +@config.timeit +def run_model(sim, silent=True): + success = True + if config.runModel: + success = False + success, buff = sim.run_simulation(silent=silent) + if not success: + print(buff) + return success + + +def scenario(idx, silent=True): + # Three model runs that are all part of the same scenario + + # Model Run 1 (Do not account for the effects of viscosity) + # --------------------------------------------------------- + #key = list(parameters.keys())[idx] + #parameter_dict = parameters[key] + sim = build_model(idx + 1) + write_model(sim, silent=silent) + + +def test_01(): + scenario(0, silent=False) + + +# nosetest end + +if __name__ == "__main__": + # ### Henry Problem + + # Scenario 1 - Compare model runs with and without viscosity package active + + scenario(0) + + diff --git a/src/Model/GroundWaterFlow/gwf3.f90 b/src/Model/GroundWaterFlow/gwf3.f90 index 78bbb92047d..86171818618 100644 --- a/src/Model/GroundWaterFlow/gwf3.f90 +++ b/src/Model/GroundWaterFlow/gwf3.f90 @@ -457,7 +457,7 @@ subroutine gwf_ar(this) ! -- Read and allocate package call packobj%bnd_ar() if (this%inbuy > 0) call this%buy%buy_ar_bnd(packobj, this%x) -! if (this%invsc > 0) call this%buy%vsc_ar_bnd(packobj, this%x) ! kluge ! + if (this%invsc > 0) call this%vsc%vsc_ar_bnd(packobj) end do ! ! -- return diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index a4ece614807..8cc6a6c1bb3 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -158,6 +158,9 @@ module MawModule integer(I4B), pointer :: idense real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() ! + ! -- viscosity variables + real(DP), dimension(:, :), pointer, contiguous :: viscratios => null() !< viscosity ratios (1: maw vsc ratio; 2: gwf vsc ratio) + ! ! -- type bound procedures contains procedure :: maw_allocate_scalars @@ -213,6 +216,8 @@ module MawModule ! -- MAW reduced flow outputs procedure, private :: maw_redflow_csv_init procedure, private :: maw_redflow_csv_write + ! -- viscosity + procedure :: maw_activate_viscosity end type MawType contains @@ -521,6 +526,9 @@ subroutine maw_allocate_well_conn_arrays(this) ! -- allocate denseterms to size 0 call mem_allocate(this%denseterms, 3, 0, 'DENSETERMS', this%memoryPath) ! + ! -- allocate viscratios to size 0 + call mem_allocate(this%viscratios, 3, 0, 'VISCRATIOS', this%memoryPath) + ! ! -- return return end subroutine maw_allocate_well_conn_arrays @@ -3002,6 +3010,7 @@ subroutine maw_da(this) call mem_deallocate(this%qsto) call mem_deallocate(this%qconst) call mem_deallocate(this%denseterms) + call mem_deallocate(this%viscratios) call mem_deallocate(this%idxlocnode) call mem_deallocate(this%idxdglo) call mem_deallocate(this%idxoffdglo) @@ -3032,6 +3041,7 @@ subroutine maw_da(this) call mem_deallocate(this%kappa) call mem_deallocate(this%cbcauxitems) call mem_deallocate(this%idense) + call mem_deallocate(this%viscratios) ! ! -- pointers to gwf variables nullify (this%gwfiss) @@ -4842,6 +4852,36 @@ subroutine maw_activate_density(this) return end subroutine maw_activate_density + !> @brief Activate viscosity terms + !! + !! Method to activate addition of viscosity terms for a MAW package reach. + !! + !< + subroutine maw_activate_viscosity(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + ! -- dummy variables + class(MawType), intent(inout) :: this !< MawType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + ! + ! -- Set ivsc and reallocate viscratios to be of size MAXBOUND + this%ivsc = 1 + call mem_reallocate(this%viscratios, 3, this%MAXBOUND, 'VISCRATIOS', & + this%memoryPath) + do i = 1, this%maxbound + do j = 1, 3 + this%viscratios(j, i) = DZERO + end do + end do + write (this%iout, '(/1x,a)') 'VISCOSITY HAS BEEN ACTIVATED FOR MAW & + &PACKAGE: '//trim(adjustl(this%packName)) + ! + ! -- return + return + end subroutine maw_activate_viscosity + subroutine maw_calculate_density_exchange(this, iconn, hmaw, hgwf, cond, & bmaw, flow, hcofterm, rhsterm) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 58e02c40606..bf04562d509 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1074,7 +1074,6 @@ subroutine npf_da(this) call mem_deallocate(this%hnoflo) call mem_deallocate(this%hdry) call mem_deallocate(this%icellavg) - call mem_deallocate(this%icellavg) call mem_deallocate(this%iavgkeff) call mem_deallocate(this%ik22) call mem_deallocate(this%ik33) @@ -1159,7 +1158,6 @@ subroutine allocate_scalars(this) call mem_allocate(this%hnoflo, 'HNOFLO', this%memoryPath) call mem_allocate(this%hdry, 'HDRY', this%memoryPath) call mem_allocate(this%icellavg, 'ICELLAVG', this%memoryPath) - call mem_allocate(this%icellavg, 'ICELLAVG', this%memoryPath) call mem_allocate(this%iavgkeff, 'IAVGKEFF', this%memoryPath) call mem_allocate(this%ik22, 'IK22', this%memoryPath) call mem_allocate(this%ik33, 'IK33', this%memoryPath) @@ -1201,7 +1199,6 @@ subroutine allocate_scalars(this) this%hnoflo = DHNOFLO !1.d30 this%hdry = DHDRY !-1.d30 this%icellavg = 0 - this%icellavg = 0 this%iavgkeff = 0 this%ik22 = 0 this%ik33 = 0 diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index 4ead818e08b..70287640526 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -146,6 +146,9 @@ module SfrModule integer(I4B), pointer :: idense !< flag indicating if density corrections are active real(DP), dimension(:, :), pointer, contiguous :: denseterms => null() !< density terms ! + ! -- viscosity variables + real(DP), dimension(:, :), pointer, contiguous :: viscratios => null() !< viscosity ratios (1: sfr vsc ratio; 2: gwf vsc ratio) + ! ! -- type bound procedures contains procedure :: sfr_allocate_scalars @@ -208,6 +211,8 @@ module SfrModule ! -- density procedure :: sfr_activate_density procedure, private :: sfr_calculate_density_exchange + ! -- viscosity + procedure :: sfr_activate_viscosity end type SfrType contains @@ -292,6 +297,7 @@ subroutine sfr_allocate_scalars(this) call mem_allocate(this%icheck, 'ICHECK', this%memoryPath) call mem_allocate(this%iconvchk, 'ICONVCHK', this%memoryPath) call mem_allocate(this%idense, 'IDENSE', this%memoryPath) + call mem_allocate(this%ivsc, 'IVSC', this%memoryPath) call mem_allocate(this%ianynone, 'IANYNONE', this%memoryPath) call mem_allocate(this%ncrossptstot, 'NCROSSPTSTOT', this%memoryPath) ! @@ -316,6 +322,7 @@ subroutine sfr_allocate_scalars(this) this%icheck = 1 this%iconvchk = 1 this%idense = 0 + this%ivsc = 0 this%ianynone = 0 this%ncrossptstot = 0 ! @@ -499,12 +506,15 @@ subroutine sfr_allocate_arrays(this) this%qauxcbc(i) = DZERO end do ! - !-- fill cauxcbc + ! -- fill cauxcbc this%cauxcbc(1) = 'FLOW-AREA ' ! ! -- allocate denseterms to size 0 call mem_allocate(this%denseterms, 3, 0, 'DENSETERMS', this%memoryPath) ! + ! -- allocate viscratios to size 0 + call mem_allocate(this%viscratios, 3, 0, 'VISCRATIOS', this%memoryPath) + ! ! -- return return end subroutine sfr_allocate_arrays @@ -2556,6 +2566,7 @@ subroutine sfr_da(this) call mem_deallocate(this%stage0) call mem_deallocate(this%usflow0) call mem_deallocate(this%denseterms) + call mem_deallocate(this%viscratios) ! ! -- deallocate reach order and connection data call mem_deallocate(this%isfrorder) @@ -2630,6 +2641,7 @@ subroutine sfr_da(this) call mem_deallocate(this%icheck) call mem_deallocate(this%iconvchk) call mem_deallocate(this%idense) + call mem_deallocate(this%ivsc) call mem_deallocate(this%ianynone) call mem_deallocate(this%ncrossptstot) nullify (this%gwfiss) @@ -5562,6 +5574,36 @@ subroutine sfr_activate_density(this) return end subroutine sfr_activate_density + !> @brief Activate viscosity terms + !! + !! Method to activate addition of viscosity terms for a SFR package reach. + !! + !< + subroutine sfr_activate_viscosity(this) + ! -- modules + use MemoryManagerModule, only: mem_reallocate + ! -- dummy variables + class(SfrType), intent(inout) :: this !< SfrType object + ! -- local variables + integer(I4B) :: i + integer(I4B) :: j + ! + ! -- Set ivsc and reallocate viscratios to be of size MAXBOUND + this%ivsc = 1 + call mem_reallocate(this%viscratios, 3, this%MAXBOUND, 'VISCRATIOS', & + this%memoryPath) + do i = 1, this%maxbound + do j = 1, 3 + this%viscratios(j, i) = DZERO + end do + end do + write (this%iout, '(/1x,a)') 'VISCOSITY HAS BEEN ACTIVATED FOR SFR & + &PACKAGE: '//trim(adjustl(this%packName)) + ! + ! -- return + return + end subroutine sfr_activate_viscosity + !> @brief Calculate density terms !! !! Method to galculate groundwater-reach density exchange terms for a diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index 4aa15d1c8f7..c78b13b29c3 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -71,6 +71,7 @@ module GwfVscModule contains procedure :: vsc_df procedure :: vsc_ar + procedure, public :: vsc_ar_bnd procedure :: vsc_rp procedure :: vsc_ad procedure, public :: vsc_ad_bnd @@ -266,6 +267,63 @@ subroutine vsc_ar(this, ibound) return end subroutine vsc_ar + !> @brief Activate viscosity in advanced packages + !! + !! Viscosity ar_bnd rountine to activate viscosity in the advanced + !! packages. This routine is called from gwf_ar() as it moves through each + !! package + !! + !< + subroutine vsc_ar_bnd(this, packobj) + ! + ! SPECIFICATIONS: + ! ---------------------------------------------------------------------------- + ! -- modules + use BndModule, only: BndType + use LakModule, only: LakType + use SfrModule, only: SfrType + use MawModule, only: MawType + ! -- dummy + class(GwfVscType) :: this + class(BndType), pointer :: packobj + ! -- local + ! ---------------------------------------------------------------------------- + ! + ! -- Add density terms based on boundary package type + select case (packobj%filtyp) + case ('LAK') + ! + ! -- activate viscosity for lake package + select type (packobj) + type is (LakType) + call packobj%lak_activate_viscosity() + end select + + case ('SFR') + ! + ! -- activate viscosity for sfr package + select type (packobj) + type is (SfrType) + call packobj%sfr_activate_viscosity() + end select + + case ('MAW') + ! + ! -- activate viscosity for maw package + select type (packobj) + type is (MawType) + call packobj%maw_activate_viscosity() + end select + + case default + ! + ! -- nothing + end select + ! + ! -- Return + return + end subroutine vsc_ar_bnd + !> @brief Set pointers to NPF variables !! !! Set array and variable pointers from the NPF @@ -408,7 +466,7 @@ subroutine vsc_ad_bnd(this, packobj, hnew) select case (packobj%filtyp) case ('GHB', 'DRN', 'RIV') ! - ! -- general head boundary + ! -- general head, drain, and river boundary call vsc_ad_standard_bnd(packobj, hnew, this%visc, this%viscref, & locelev, locvisc, locconc, this%dviscdc, & this%cviscref, this%ivisc, this%a2, this%a3, & @@ -419,6 +477,11 @@ subroutine vsc_ad_bnd(this, packobj, hnew) case ('SFR') ! ! -- streamflow routing + ! Update 'viscratios' internal to sfr such that they are + ! automatically applied in the SFR calc_cond() routine + call vsc_ad_sfr(packobj, this%visc, this%viscref, this%elev, locvisc, & + locconc, this%dviscdc, this%cviscref, this%ivisc, & + this%a2, this%a3, this%a4, this%ctemp) case ('MAW') ! ! -- multi-aquifer well @@ -465,7 +528,6 @@ subroutine vsc_ad_standard_bnd(packobj, hnew, visc, viscref, locelev, & integer(I4B) :: node real(DP) :: viscghb real(DP) :: viscratio - real(DP) :: hd ! ------------------------------------------------------------------------------- ! ! -- Process density terms for each GHB @@ -489,6 +551,68 @@ subroutine vsc_ad_standard_bnd(packobj, hnew, visc, viscref, locelev, & ! -- Return return end subroutine vsc_ad_standard_bnd + + !> @brief Update sfr-related viscosity ratios + !! + !! When the viscosity package is active, update the viscosity ratio that is + !! applied to the hydraulic conductivity specified in the SFR package + !< + subroutine vsc_ad_sfr(packobj, visc, viscref, elev, locvisc, locconc, & + dviscdc, cviscref, ivisc, a2, a3, a4, ctemp) + ! -- modules + use BndModule, only: BndType + use SfrModule, only: SfrType + class(BndType), pointer :: packobj + ! -- dummy + real(DP), intent(in) :: viscref + real(DP), intent(in) :: a2, a3, a4 + integer(I4B), intent(in) :: locvisc + integer(I4B), dimension(:), intent(in) :: locconc + integer(I4B), dimension(:), intent(in) :: ivisc + real(DP), dimension(:), intent(in) :: visc + real(DP), dimension(:), intent(in) :: elev + real(DP), dimension(:), intent(in) :: dviscdc + real(DP), dimension(:), intent(in) :: cviscref + real(DP), dimension(:), intent(inout) :: ctemp + ! -- local + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: viscsfr +! ------------------------------------------------------------------------------- + ! + ! -- update viscosity ratios for updating hyd. cond (and conductance) + select type (packobj) + type is (SfrType) + do n = 1, packobj%nbound + ! + ! -- get gwf node number + node = packobj%nodelist(n) + ! + ! -- Check if boundary cell is active, cycle if not + if (packobj%ibound(node) <= 0) cycle + ! + ! -- + ! + ! -- calculate the viscosity associcated with the boundary + viscsfr = calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, & + cviscref, ctemp, ivisc, a2, a3, a4, & + packobj%auxvar) + ! + ! -- fill sfr relative viscosity into column 1 of viscratios + packobj%viscratios(1, n) = calc_vsc_ratio(viscref, viscsfr) + ! + ! -- fill gwf relative viscosity into column 2 of viscratios + packobj%viscratios(2, n) = calc_vsc_ratio(viscref, visc(node)) + ! + ! -- fill gwf elevation into column 3 of viscratios + !packobj%viscratios(3, n) = elev(node) + ! + end do + end select + ! + ! -- Return + return + end subroutine vsc_ad_sfr !> @brief apply bnd viscosity to the conductance term !! @@ -507,7 +631,7 @@ function update_bnd_cond(bndvisc, viscref, spcfdcond) result(updatedcond) integer(I4B) :: n ! ------------------------------------------------------------------------------- ! - vscratio = viscref / bndvisc + vscratio = calc_vsc_ratio(viscref, bndvisc) ! ! -- calculate new conductance here!! updatedcond = vscratio * spcfdcond @@ -516,6 +640,22 @@ function update_bnd_cond(bndvisc, viscref, spcfdcond) result(updatedcond) return end function update_bnd_cond + !> @brief calculate and return the viscosity ratio + !< + function calc_vsc_ratio(viscref, bndvisc) result(viscratio) + ! -- dummy + real(DP), intent(in) :: viscref + real(DP), intent(in) :: bndvisc + ! -- local + real(DP) :: viscratio +! ------------------------------------------------------------------------------- + ! + viscratio = viscref / bndvisc + ! + ! -- Return + return + end function calc_vsc_ratio + function calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, cviscref, & ! ctemp, ivisc, auxvar) result(viscbnd) ctemp, ivisc, a2, a3, a4, auxvar) result(viscbnd) From d6a184d6b06c5fb52b5cb9931d643dad4a6cf167 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 26 Sep 2022 08:49:50 -0700 Subject: [PATCH 040/212] Work on mf6io.tex documentation related to VSC package input --- doc/mf6io/gwf/vsc.tex | 59 +++++++++++++++++++ doc/mf6io/mf6ivar/md/mf6ivar.md | 15 +++++ doc/mf6io/mf6ivar/tex/appendixA.tex | 4 ++ doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex | 45 ++++++++++++++ doc/mf6io/mf6ivar/tex/gwf-vsc-dimensions.dat | 3 + doc/mf6io/mf6ivar/tex/gwf-vsc-options.dat | 6 ++ doc/mf6io/mf6ivar/tex/gwf-vsc-packagedata.dat | 5 ++ 7 files changed, 137 insertions(+) create mode 100644 doc/mf6io/gwf/vsc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwf-vsc-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwf-vsc-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwf-vsc-packagedata.dat diff --git a/doc/mf6io/gwf/vsc.tex b/doc/mf6io/gwf/vsc.tex new file mode 100644 index 00000000000..640343ddc96 --- /dev/null +++ b/doc/mf6io/gwf/vsc.tex @@ -0,0 +1,59 @@ +Input to the Viscosity (VSC) Package is read from the file that has type ``VSC6'' in the Name File. If the VSC Package is active within a groundwater flow model, then the model will account for variations in viscosity on groundwater flow. Viscosity may be calculated as a function of one or more groundwater solute transport (GWT) species using an approach described in the Supplemental Technical Information document distributed with MODFLOW 6 (Chapter 8). Only one VSC Package may be active within a GWF model. The VSC Package may be coupled with one or more GWT Models so that the fluid viscosity is updated dynamically with one or more simulated concentration fields. + +The VSC Package calculates fluid viscosity using the following equation of state from \cite{langevin2008seawat}: + +\begin{equation} +\label{eqn:volumeconservationdiscrete} +\mu = VISCREF + \sum_{i=1}^{NVISCSPECIES} DVISCDC_i \left ( CONCENTRATION_i - CVISCREF_i \right ) +\end{equation} + +\noindent where $\mu$ is the calculated viscosity, $VISCREF$ is the viscosity of a reference fluid, typically taken to be freshwater at a temperature of 20 $^{\circ}$C, $NVISCSPECIES$ is the number of chemical species that contribute to the viscosity calculation, $DVISCDC_i$ is the parameter that describes how viscosity changes linearly as a function of concentration for chemical species $i$ (i.e. the slope of a line that relates viscosity to concentration), $CONCENTRATION_i$ is the concentration of species $i$ and will commonly be set equal to the concentration calculated by one or more GWT models, and $CVISCREF_i$ is the reference concentration for species $i$ corresponding to when the viscosity of the reference fluid is equal to $VISCREF$ (typically set to zero when accounting for the effects of dissolved solute on viscosity). + +\subsubsection{Stress Packages} +For head-dependent stress packages, the BUY Package may require fluid density and elevation for each head-dependent boundary so that the model can use a variable-density form of Darcy's Law to calculate flow between the boundary and the aquifer. By default, the boundary elevation is set equal to the cell elevation. For water-table conditions, the cell elevation is calculated as bottom elevation plus half of saturation multiplied by the cell thickness. If desired, the user can more precisely locate the boundary elevation by specifying an auxiliary variable with the name ``ELEVATION''. The program will use the values in this column as the boundary elevation. A situation where this may be required is for river or general-head boundaries that are conceptualized as being on top of a model cell. In those cases, an ELEVATION column should be specified and the values set to the top of the cell or some other appropriate elevation that corresponds to where the boundary stage applies. + +By default, the boundary density is set equal to DENSEREF, commonly specified as the density of freshwater; however, there are two other options for setting the density of a boundary package. The first is to assign an auxiliary variable with the name ``DENSITY''. If this auxiliary variable is detected, then the density value in this column will be assigned to the density for the boundary. Alternatively, a density value can be calculated for each boundary using the density equation of state and one or more concentrations provided as auxiliary variables. In this case, the user must assign one auxiliary variable for each AUXSPECIESNAME listed in the PACKAGEDATA block below. Thus, there must be NRHOSPECIES auxiliary variables, each with the identical name as those specified in PACKAGEDATA. The BUY Package will calculate the density for each boundary using these concentrations and the values specified for DENSEREF, DRHODC, and CRHOREF. If the boundary package contains an auxiliary variable named DENSITY and also contains AUXSPECIESNAME auxiliary variables, then the boundary density value will be assigned to the one in the DENSITY auxiliary variable. + +A GWT Model can be used to calculate concentrations for the advanced stress packages (LAK, SFR, MAW, and UZF) if corresponding advanced transport packages are specified (LKT, SFT, MWT, and UZT). The advanced stress packages have an input option called FLOW\_PACKAGE\_AUXILIARY\_NAME. When activated, this option will result in the simulated concentration for a lake or other feature being copied from the advanced transport package into the auxiliary variable for the corresponding GWF stress package. This means that the density for a lake or stream, for example, can be dynamically updated during the simulation using concentrations from advanced transport packages that are fed into auxiliary variables in the advanced stress packages, and ultimately used by the BUY Package to calculate a fluid density using the equation of state. This concept also applies when multiple GWT Models are used simultaneously to simulate multiple species. In this case, multiple auxiliary variables are required for an advanced stress package, with each one representing a concentration from a different GWT Model. + +\begin{longtable}{p{3cm} p{12cm}} +\caption{Description of density terms for stress packages} +\tabularnewline +\hline +\hline +\textbf{Stress Package} & \textbf{Note} \\ +\hline +\endhead +\hline +\endfoot +GHB & ELEVATION can be specified as an auxiliary variable. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ +RIV & ELEVATION can be specified as an auxiliary variable. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ +DRN & The drain formulation assumes that the drain boundary contains water of the same density as the discharging water; auxiliary variables have no effect on the drain calculation \\ +LAK & Elevation for each lake-aquifer connection is determined based on lake bottom and adjacent cell elevations. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ +SFR & Elevation for each sfr-aquifer connection is determined based on stream bottom and adjacent cell elevations. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ +MAW & Elevation for each maw-aquifer connection is determined based on cell elevation. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ +UZF & No density terms implemented \\ +\end{longtable} + +\vspace{5mm} +\subsubsection{Structure of Blocks} + +\vspace{5mm} +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-dimensions.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-packagedata.dat} +%\vspace{5mm} +%\noindent \textit{FOR ANY STRESS PERIOD} +%\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwf-buy-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwf-buy-example.dat} + diff --git a/doc/mf6io/mf6ivar/md/mf6ivar.md b/doc/mf6io/mf6ivar/md/mf6ivar.md index 0efa3140384..08651df4cb3 100644 --- a/doc/mf6io/mf6ivar/md/mf6ivar.md +++ b/doc/mf6io/mf6ivar/md/mf6ivar.md @@ -785,6 +785,21 @@ | GWF | OC | PERIOD | LAST | KEYWORD | keyword to indicate save for last step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | | GWF | OC | PERIOD | FREQUENCY | INTEGER | save at the specified time step frequency. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | | GWF | OC | PERIOD | STEPS | INTEGER ( +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwf-vsc-options.dat b/doc/mf6io/mf6ivar/tex/gwf-vsc-options.dat new file mode 100644 index 00000000000..09bf3a99fd9 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwf-vsc-options.dat @@ -0,0 +1,6 @@ +BEGIN OPTIONS + [VISCREF ] + [VISCOSITY FILEOUT ] + [THERMAL_VISCOSITY_FUNC FORMULATION [A2 ] [A3 ] [A4 ]] + FORMULATION +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwf-vsc-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwf-vsc-packagedata.dat new file mode 100644 index 00000000000..ff3d65886f9 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwf-vsc-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + + + ... +END PACKAGEDATA From fc3b64274a7ff23173451d411f422e08c45f4b15 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 4 Oct 2022 15:07:49 -0700 Subject: [PATCH 041/212] Significant work on the mf6io latex docs. Builds out with VSC included as of this commit --- doc/MODFLOW6References.bib | 55 +++++++++++++++++- doc/mf6io/gwf/gwf.tex | 4 ++ doc/mf6io/gwf/namefile.tex | 1 + doc/mf6io/gwf/vsc.tex | 57 ++++++++++++------- doc/mf6io/mf6io.bbl | 8 ++- doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn | 8 +-- .../mf6ivar/examples/gwf-vsc-example.dat | 15 +++++ doc/mf6io/mf6ivar/md/mf6ivar.md | 35 ++++++++---- doc/mf6io/mf6ivar/mf6ivar.py | 1 + doc/mf6io/mf6ivar/tex/appendixA.tex | 4 ++ doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex | 8 +-- 11 files changed, 155 insertions(+), 41 deletions(-) create mode 100644 doc/mf6io/mf6ivar/examples/gwf-vsc-example.dat diff --git a/doc/MODFLOW6References.bib b/doc/MODFLOW6References.bib index db6303c1e6e..15ed2c4a54d 100644 --- a/doc/MODFLOW6References.bib +++ b/doc/MODFLOW6References.bib @@ -494,7 +494,7 @@ @book{Voss1984sutra Date-Added = {2019-08-29 15:00:00 -0600}, Date-Modified = {2019-08-29 15:00:00 -0600}, Series = {{U.S. Geological Survey Water-Resources Investigations Report 84--4369, 409 p.}}, - Title = {SUTRA---a finite-element simulation model for saturated-unsaturated fluid-density-dependent ground-water flow with energy transport or chemically-reactive single-species solute transport}, + Title = {SUTRA---A finite-element simulation model for saturated-unsaturated fluid-density-dependent ground-water flow with energy transport or chemically-reactive single-species solute transport}, Year = {1984}} @article{VossSouza1987, @@ -597,6 +597,34 @@ @book{langevin2002seawat Year = {2002}, Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/tm6A22}} +@article{diersch2002viscosity, + Author = {Diersch, Hans-Jorg G and Kolditz, Olaf}, + Date-Added = {2022-09-27 11:58:19 -0500}, + Date-Modified = {2022-09-27 12:00:01 -0500}, + Journal = {Advances in Water Resources}, + Pages = {899--944}, + Title = {Variable-density flow and transport in porous media: Approaches and challenges}, + Url = {https://www.sciencedirect.com/science/article/pii/S0309170802000635}, + doi = {https://doi.org/10.1016/S0309-1708(02)00063-5}, + Urldate = {September 27, 2022}, + Volume = {25}, + number = {8}, + Year = {2002}, + issn = {0309-1708}, + Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/tm6A22}} + +@book{kipp1987, + Author = {Kipp, Kenneth L}, + Date-Added = {2022-09-27 11:58:19 -0500}, + Date-Modified = {2022-09-27 12:00:01 -0500}, + Institution = {U.S. Geological Survey}, + Series = {{U.S. Geological Survey Water-Resources Investigation Report 86-4095, 517 p.}}, + Title = {HST3D: A Computer Code for Simulation of Heat and Solute Transport in Three-Dimensional Ground-Water Flow Systems}, + Url = {https://pubs.usgs.gov/wri/1986/4095/report.pdf}, + Urldate = {September 27, 2022}, + Year = {1987}, + Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/wri864095}} + @book{langevin2008seawat, Author = {Langevin, Christian D and Thorne Jr, Daniel T and Dausman, Alyssa M and Sukop, Michael C and Guo, Weixing}, Date-Added = {2019-07-25 11:53:50 -0500}, @@ -2855,3 +2883,28 @@ @book{vs2d Urldate = {June 27, 2017}, Year = {1987}, Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/wri834099}} + +@book{healy1996, + Author = {Healy, Richard W and Ronan, Ann D}, + Date-Added = {2022-09-27 11:58:19 -0500}, + Date-Modified = {2022-09-27 12:00:01 -0500}, + Institution = {U.S. Geological Survey}, + Series = {{U.S. Geological Survey Water-Resources Investigation Report 96-4230, 36 p.}}, + Title = {Documentation of Computer Program VS2DH for Simulation of Energy Transport in Variably Saturated Porous Media: Modification of the U.S. Geological Survey's Computer Program VS2DT}, + Doi = {10.3133/wri964230}, + Url = {https://pubs.usgs.gov/wri/1996/4230/report.pdf}, + Urldate = {September 27, 2022}, + Year = {1996}, + Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/wri964230}} + +@book{hughes2004, + Author = {Hughes, Joseph D and Sanford, Ward E}, + Date-Added = {2019-10-11 15:42:15 -0400}, + Date-Modified = {2019-10-11 15:46:29 -0400}, + Doi = {10.3133/ofr20041207}, + Url = {https://water.usgs.gov/nrp/gwsoftware/SutraMS/OFR2004-1207.pdf}, + Series = {{U.S. Geological Survey Open File Report 2004--1207, 141 p.}}, + Title = {SUTRA-MS: A version of SUTRA modified to simulate heat and multiple-solute transport}, + Urldate = {September 27, 2022}, + Year = {2004}, + Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/ofr20041207}} diff --git a/doc/mf6io/gwf/gwf.tex b/doc/mf6io/gwf/gwf.tex index 98cd9b37554..452122446ef 100644 --- a/doc/mf6io/gwf/gwf.tex +++ b/doc/mf6io/gwf/gwf.tex @@ -109,6 +109,10 @@ \subsection{Skeletal Storage, Compaction, and Subsidence (CSUB) Package} \subsection{Buoyancy (BUY) Package} \input{gwf/buy} +\newpage +\subsection{Viscosity (VSC) Package} +\input{gwf/vsc} + \newpage \subsection{Constant-Head (CHD) Package} \input{gwf/chd} diff --git a/doc/mf6io/gwf/namefile.tex b/doc/mf6io/gwf/namefile.tex index 4d8724801ca..f54f1ee1e5f 100644 --- a/doc/mf6io/gwf/namefile.tex +++ b/doc/mf6io/gwf/namefile.tex @@ -31,6 +31,7 @@ \subsubsection{Explanation of Variables} STO6 & Storage Package \\ CSUB6 & Compaction and Subsidence Package \\ BUY6 & Buoyancy Package \\ +VSC6 & Viscosity Package \\ HFB6 & Horizontal Flow Barrier Package\\ CHD6 & Time-Variant Specified Head Option & * \\ WEL6 & Well Package & * \\ diff --git a/doc/mf6io/gwf/vsc.tex b/doc/mf6io/gwf/vsc.tex index 640343ddc96..e8f6f9c2efc 100644 --- a/doc/mf6io/gwf/vsc.tex +++ b/doc/mf6io/gwf/vsc.tex @@ -3,21 +3,40 @@ The VSC Package calculates fluid viscosity using the following equation of state from \cite{langevin2008seawat}: \begin{equation} -\label{eqn:volumeconservationdiscrete} +\label{eqn:visclinear} \mu = VISCREF + \sum_{i=1}^{NVISCSPECIES} DVISCDC_i \left ( CONCENTRATION_i - CVISCREF_i \right ) \end{equation} \noindent where $\mu$ is the calculated viscosity, $VISCREF$ is the viscosity of a reference fluid, typically taken to be freshwater at a temperature of 20 $^{\circ}$C, $NVISCSPECIES$ is the number of chemical species that contribute to the viscosity calculation, $DVISCDC_i$ is the parameter that describes how viscosity changes linearly as a function of concentration for chemical species $i$ (i.e. the slope of a line that relates viscosity to concentration), $CONCENTRATION_i$ is the concentration of species $i$ and will commonly be set equal to the concentration calculated by one or more GWT models, and $CVISCREF_i$ is the reference concentration for species $i$ corresponding to when the viscosity of the reference fluid is equal to $VISCREF$ (typically set to zero when accounting for the effects of dissolved solute on viscosity). +In many cases, fluid viscosity is generally considered to be more sensitive to variations in temperature than to variations in concentration. When simulating temperature as a species \citep{zheng2010supplemental}, the simulated fluid viscosity may vary linearly with changes in temperature using equation~\ref{eqn:visclinear}. For example, $DVISCDC_i$, the paramter that describes how viscosity changes linearly as a function of concentration, can effectively serve as a surrogate for $DVISCDT_i$ (note that $DC_i$ changed to $DT_i$), a term representing changes in viscosity as a function of temperature. Analogously, $CONCENTRATION_i$ and $CVISCREF_i$ serve as surrogates for $TEMPERATURE_i$ and $TVISCREF_i$, representing the dynamically simulated (or specified at the boundary) temperature and reference temperature for species $i$, respectively. + +In addition to supporting a linear relationship between viscosity and temperature, the VSC package also supports a nonlinear relationship as well. For the nonlinear case, the VSC package may be directed to solve the following equation of state: + +\begin{equation} +\label{eqn:viscnonlinear} +\mu = \mu_T(T) + \sum_{i=1}^{NVISCSPECIES} DVISCDC_i \left ( CONCENTRATION_i - CVISCREF_i \right ) +\end{equation} + +\noindent where the second term on the right-hand side of the equation adjusts the viscosity based on one or more solute concentrations and $\mu_T(T)$ calculates the viscosity adjustment based on the simulated temperature using, + +\begin{equation} +\label{eqn:munonlinear} +\mu_T(T) = CVISCREF_i \cdot A_2^{\left [ \frac {-A_3 \left ( CONCENTRATION_i - CVISCREF_i \right ) } {\left ( CONCENTRATION_i + A_4 \right ) \left ( CVISCREF_i + A_4 \right )} \right ]} +\end{equation} + +\noindent where the coefficients $A_2$, $A_3$, and $A_4$ are specified by the user. Values for $A_2$, $A_3$, and $A_4$ are commonly 10, 248.7, and 133.15, respectively \citep{langevin2008seawat, Voss1984sutra}. + \subsubsection{Stress Packages} -For head-dependent stress packages, the BUY Package may require fluid density and elevation for each head-dependent boundary so that the model can use a variable-density form of Darcy's Law to calculate flow between the boundary and the aquifer. By default, the boundary elevation is set equal to the cell elevation. For water-table conditions, the cell elevation is calculated as bottom elevation plus half of saturation multiplied by the cell thickness. If desired, the user can more precisely locate the boundary elevation by specifying an auxiliary variable with the name ``ELEVATION''. The program will use the values in this column as the boundary elevation. A situation where this may be required is for river or general-head boundaries that are conceptualized as being on top of a model cell. In those cases, an ELEVATION column should be specified and the values set to the top of the cell or some other appropriate elevation that corresponds to where the boundary stage applies. +For head-dependent stress packages, the VSC Package may require fluid viscosity and elevation for each head-dependent boundary so that the model can use the appropriate viscosity to calculate flow between the boundary and the aquifer. By default, the boundary elevation is set equal to the cell elevation. For water-table conditions, the cell elevation is calculated as bottom elevation plus half of saturation multiplied by the cell thickness. If desired, the user can more precisely locate the boundary elevation by specifying an auxiliary variable with the name ``ELEVATION''. The program will use the values in this column as the boundary elevation. A situation where this may be required is for river or general-head boundaries that are conceptualized as being on top of a model cell. In those cases, an ELEVATION column should be specified and the values set to the top of the cell or some other appropriate elevation that corresponds to where the boundary stage applies. -By default, the boundary density is set equal to DENSEREF, commonly specified as the density of freshwater; however, there are two other options for setting the density of a boundary package. The first is to assign an auxiliary variable with the name ``DENSITY''. If this auxiliary variable is detected, then the density value in this column will be assigned to the density for the boundary. Alternatively, a density value can be calculated for each boundary using the density equation of state and one or more concentrations provided as auxiliary variables. In this case, the user must assign one auxiliary variable for each AUXSPECIESNAME listed in the PACKAGEDATA block below. Thus, there must be NRHOSPECIES auxiliary variables, each with the identical name as those specified in PACKAGEDATA. The BUY Package will calculate the density for each boundary using these concentrations and the values specified for DENSEREF, DRHODC, and CRHOREF. If the boundary package contains an auxiliary variable named DENSITY and also contains AUXSPECIESNAME auxiliary variables, then the boundary density value will be assigned to the one in the DENSITY auxiliary variable. +By default, the boundary viscosity is set equal to VISCREF, which, for freshwater, is typically set equal to 1.0. However, there are two additional options for setting the viscosity of a boundary package. The first is to assign an auxiliary variable with the name ``VISCOSITY''. If an auxiliary variable named ``VISCOSITY'' is detected, then it will be assigned as the viscosity of the fluid entering from the boundary. Alternatively, a viscosity value can be calculated for each boundary using the viscosity equation of state (described above) and one or more concentrations provided as auxiliary variables. In this case, the user must assign one auxiliary variable for each AUXSPECIESNAME listed in the PACKAGEDATA block below. Thus, there must be NVISCSPECIES auxiliary variables, each with the identical name as those specified in PACKAGEDATA. The VSC Package will calculate the viscosity for each boundary using these concentrations and the values specified for VISCREF, DVISCDC, and CVISCREF. If the boundary package contains an auxiliary variable named VISCOSITY and also contains AUXSPECIESNAME auxiliary variables, then the specified - not the internally calculated - boundary viscosity value will be assigned to the one in the VISCOSITY auxiliary variable. + +A GWT Model can be used to calculate concentration of features associated with one of the advanced stress packages (LAK, SFR, MAW, and UZF) if corresponding advanced transport packages are specified (LKT, SFT, MWT, and UZT). The advanced stress packages have an input option called FLOW\_PACKAGE\_AUXILIARY\_NAME. When activated, this option will result in the simulated concentration for a lake or other feature being copied from the advanced transport package into the auxiliary variable for the corresponding GWF stress package. This means that the viscosity for a lake or stream, for example, can be dynamically updated during the simulation using concentrations from advanced transport packages that are fed into auxiliary variables in the advanced stress packages, and ultimately used by the VSC Package to calculate a fluid viscosity using the equation of state. This concept also applies when multiple GWT Models are used simultaneously to simulate multiple species. In this case, multiple auxiliary variables are required for an advanced stress package, with each one representing a concentration from a different GWT Model. -A GWT Model can be used to calculate concentrations for the advanced stress packages (LAK, SFR, MAW, and UZF) if corresponding advanced transport packages are specified (LKT, SFT, MWT, and UZT). The advanced stress packages have an input option called FLOW\_PACKAGE\_AUXILIARY\_NAME. When activated, this option will result in the simulated concentration for a lake or other feature being copied from the advanced transport package into the auxiliary variable for the corresponding GWF stress package. This means that the density for a lake or stream, for example, can be dynamically updated during the simulation using concentrations from advanced transport packages that are fed into auxiliary variables in the advanced stress packages, and ultimately used by the BUY Package to calculate a fluid density using the equation of state. This concept also applies when multiple GWT Models are used simultaneously to simulate multiple species. In this case, multiple auxiliary variables are required for an advanced stress package, with each one representing a concentration from a different GWT Model. \begin{longtable}{p{3cm} p{12cm}} -\caption{Description of density terms for stress packages} +\caption{Description of viscosity terms for stress packages} \tabularnewline \hline \hline @@ -26,13 +45,13 @@ \subsubsection{Stress Packages} \endhead \hline \endfoot -GHB & ELEVATION can be specified as an auxiliary variable. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ -RIV & ELEVATION can be specified as an auxiliary variable. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ -DRN & The drain formulation assumes that the drain boundary contains water of the same density as the discharging water; auxiliary variables have no effect on the drain calculation \\ -LAK & Elevation for each lake-aquifer connection is determined based on lake bottom and adjacent cell elevations. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ -SFR & Elevation for each sfr-aquifer connection is determined based on stream bottom and adjacent cell elevations. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ -MAW & Elevation for each maw-aquifer connection is determined based on cell elevation. A DENSITY auxiliary variable or one or more auxiliary variables for calculating density in the equation of state can be specified \\ -UZF & No density terms implemented \\ +GHB & ELEVATION can be specified as an auxiliary variable. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +RIV & ELEVATION can be specified as an auxiliary variable. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +DRN & The drain formulation assumes that the drain boundary contains water of the same viscosity as the discharging water; auxiliary variables have no effect on the drain calculation \\ +LAK & Elevation for each lake-aquifer connection is determined based on lake bottom and adjacent cell elevations. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +SFR & Elevation for each sfr-aquifer connection is determined based on stream bottom and adjacent cell elevations. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +MAW & Elevation for each maw-aquifer connection is determined based on cell elevation. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +UZF & Pending ... \\ \end{longtable} \vspace{5mm} @@ -40,20 +59,16 @@ \subsubsection{Structure of Blocks} \vspace{5mm} \noindent \textit{FOR EACH SIMULATION} -\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-options.dat} -\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-dimensions.dat} -\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-packagedata.dat} -%\vspace{5mm} -%\noindent \textit{FOR ANY STRESS PERIOD} -%\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-buy-period.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-vsc-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-vsc-dimensions.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwf-vsc-packagedata.dat} \vspace{5mm} \subsubsection{Explanation of Variables} \begin{description} -\input{./mf6ivar/tex/gwf-buy-desc.tex} +\input{./mf6ivar/tex/gwf-vsc-desc.tex} \end{description} \vspace{5mm} \subsubsection{Example Input File} -\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwf-buy-example.dat} - +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwf-vsc-example.dat} diff --git a/doc/mf6io/mf6io.bbl b/doc/mf6io/mf6io.bbl index 05fffcda052..c4d7f4a09b6 100644 --- a/doc/mf6io/mf6io.bbl +++ b/doc/mf6io/mf6io.bbl @@ -1,4 +1,4 @@ -\begin{thebibliography}{34} +\begin{thebibliography}{35} \providecommand{\natexlab}[1]{#1} \expandafter\ifx\csname urlstyle\endcsname\relax \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else @@ -228,6 +228,12 @@ Prudic, D.E., Konikow, L.F., and Banta, E.R., 2004, A New Streamflow-Routing {U.S. Geological Survey Open File Report 2004--1042, 104 p.}, accessed June 27, 2017, at \url{https://pubs.er.usgs.gov/publication/ofr20041042}. +\bibitem[{Voss(1984)}]{Voss1984sutra} +Voss, C.I., 1984, SUTRA---A finite-element simulation model for + saturated-unsaturated fluid-density-dependent ground-water flow with energy + transport or chemically-reactive single-species solute transport: {U.S. + Geological Survey Water-Resources Investigations Report 84--4369, 409 p.} + \bibitem[{Zheng(2010)}]{zheng2010supplemental} Zheng, Chunmiao, 2010, MT3DMS v5.3, Supplemental User's Guide: {Technical Report Prepared for the U.S. Army Corps of Engineers, 51 p.} diff --git a/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn b/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn index 06ca797ebbb..4633076b027 100644 --- a/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwf-vsc.dfn @@ -89,7 +89,7 @@ in_record true reader urword optional true longname coefficient used in nonlinear viscosity function -description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned based on Voss (1984). +description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned (Voss, 1984). block options name a3 @@ -98,7 +98,7 @@ in_record true reader urword optional true longname coefficient used in nonlinear viscosity function -description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned based on Voss (1984). +description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned (Voss, 1984). block options name a4 @@ -107,7 +107,7 @@ in_record true reader urword optional true longname coefficient used in nonlinear viscosity function -description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned based on Voss (1984). +description is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned (Voss, 1984). @@ -151,7 +151,7 @@ tagged false in_record true reader urword longname slope of the line that defines the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. -description real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. +description real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY\_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY\_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. block packagedata name cviscref diff --git a/doc/mf6io/mf6ivar/examples/gwf-vsc-example.dat b/doc/mf6io/mf6ivar/examples/gwf-vsc-example.dat new file mode 100644 index 00000000000..ace2f4cb7c3 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwf-vsc-example.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS + VISCREF 8.904E-04 + VISCOSITY FILEOUT GWF-VSC.vsc.bin + THERMAL_VISCOSITY_FUNC NONLINEAR 10.0 248.37 133.15 +END OPTIONS + +BEGIN DIMENSIONS + NVISCSPECIES 2 +END DIMENSIONS + +BEGIN PACKAGEDATA +# ISPEC DVISCDC CVISCREF MODELNAME AUXSPECIESNAME + 1 1.92e-6 0.0 GWT-SALT SALINITY + 2 0.00 25.0 GWT-TEMP TEMPERATURE +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/md/mf6ivar.md b/doc/mf6io/mf6ivar/md/mf6ivar.md index 08651df4cb3..573d80ffb34 100644 --- a/doc/mf6io/mf6ivar/md/mf6ivar.md +++ b/doc/mf6io/mf6ivar/md/mf6ivar.md @@ -62,9 +62,9 @@ | EXG | GWTGWT | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of exchange entries will be echoed to the listing file immediately after it is read. | | EXG | GWTGWT | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of exchange flow rates will be printed to the listing file for every stress period in which ``SAVE BUDGET'' is specified in Output Control. | | EXG | GWTGWT | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that cell-by-cell flow terms will be written to the budget file for each model provided that the Output Control for the models are set up with the ``BUDGET SAVE FILE'' option. | -| EXG | GWTGWT | OPTIONS | ADVSCHEME | STRING | scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. | -| EXG | GWTGWT | OPTIONS | XT3D_OFF | KEYWORD | deactivate the xt3d method and use the faster and less accurate approximation for this exchange. | -| EXG | GWTGWT | OPTIONS | XT3D_RHS | KEYWORD | add xt3d terms to right-hand side, when possible, for this exchange. | +| EXG | GWTGWT | OPTIONS | ADV_SCHEME | STRING | scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. | +| EXG | GWTGWT | OPTIONS | DSP_XT3D_OFF | KEYWORD | deactivate the xt3d method for the dispersive flux and use the faster and less accurate approximation for this exchange. | +| EXG | GWTGWT | OPTIONS | DSP_XT3D_RHS | KEYWORD | add xt3d dispersion terms to right-hand side, when possible, for this exchange. | | EXG | GWTGWT | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | EXG | GWTGWT | OPTIONS | MVT6 | KEYWORD | keyword to specify that record corresponds to a transport mover file. | | EXG | GWTGWT | OPTIONS | MVT6_FILENAME | STRING | is the file name of the transport mover input file to apply to this exchange. Information for the transport mover are provided in the file provided with these keywords. | @@ -219,15 +219,30 @@ | GWF | BUY | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | | GWF | BUY | OPTIONS | DENSITYFILE | STRING | name of the binary output file to write density information. The density file has the same format as the head file. Density values will be written to the density file whenever heads are written to the binary head file. The settings for controlling head output are contained in the Output Control option. | | GWF | BUY | OPTIONS | DEV_EFH_FORMULATION | KEYWORD | use the variable-density equivalent freshwater head formulation instead of the hydraulic head head formulation. This dev option has only been implemented for confined aquifer conditions and should generally not be used. | -| GWF | BUY | DIMENSIONS | NRHOSPECIES | INTEGER | number of species used in density equation of state. This value must be one or greater. The value must be one if concentrations are specified using the CONCENTRATION keyword in the PERIOD block below. | +| GWF | BUY | DIMENSIONS | NRHOSPECIES | INTEGER | number of species used in density equation of state. This value must be one or greater if the BUY package is activated. | | GWF | BUY | PACKAGEDATA | IRHOSPEC | INTEGER | integer value that defines the species number associated with the specified PACKAGEDATA data on the line. IRHOSPECIES must be greater than zero and less than or equal to NRHOSPECIES. Information must be specified for each of the NRHOSPECIES species or the program will terminate with an error. The program will also terminate with an error if information for a species is specified more than once. | | GWF | BUY | PACKAGEDATA | DRHODC | DOUBLE PRECISION | real value that defines the slope of the density-concentration line for this species used in the density equation of state. | | GWF | BUY | PACKAGEDATA | CRHOREF | DOUBLE PRECISION | real value that defines the reference concentration value used for this species in the density equation of state. | | GWF | BUY | PACKAGEDATA | MODELNAME | STRING | name of GWT model used to simulate a species that will be used in the density equation of state. This name will have no effect if the simulation does not include a GWT model that corresponds to this GWF model. | | GWF | BUY | PACKAGEDATA | AUXSPECIESNAME | STRING | name of an auxiliary variable in a GWF stress package that will be used for this species to calculate a density value. If a density value is needed by the Buoyancy Package then it will use the concentration values in this AUXSPECIESNAME column in the density equation of state. For advanced stress packages (LAK, SFR, MAW, and UZF) that have an associated advanced transport package (LKT, SFT, MWT, and UZT), the FLOW\_PACKAGE\_AUXILIARY\_NAME option in the advanced transport package can be used to transfer simulated concentrations into the flow package auxiliary variable. In this manner, the Buoyancy Package can calculate density values for lakes, streams, multi-aquifer wells, and unsaturated zone flow cells using simulated concentrations. | +| GWF | VSC | OPTIONS | VISCREF | DOUBLE | fluid reference viscosity used in the equation of state. This value is set to 1.0 if not specified as an option. | +| GWF | VSC | OPTIONS | VISCOSITY | KEYWORD | keyword to specify that record corresponds to viscosity. | +| GWF | VSC | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWF | VSC | OPTIONS | VISCOSITYFILE | STRING | name of the binary output file to write viscosity information. The viscosity file has the same format as the head file. Viscosity values will be written to the viscosity file whenever heads are written to the binary head file. The settings for controlling head output are contained in the Output Control option. | +| GWF | VSC | OPTIONS | THERMAL_VISCOSITY_FUNC | KEYWORD | may be used for specifying which viscosity formulation to use for a species identified by the auxilary name TEMPERATURE. Can be either LINEAR or NONLINEAR. The LINEAR viscosity formulation is the default. | +| GWF | VSC | OPTIONS | FORMULATION | STRING | may be used for specifying which viscosity formulation to use. The linear viscosity formulation is the default. | +| GWF | VSC | OPTIONS | A2 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | A3 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | A4 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned (Voss, 1984). | +| GWF | VSC | DIMENSIONS | NVISCSPECIES | INTEGER | number of species used in the viscosity equation of state. If either concentrations or temperature (or both) are used to update viscosity then then nrhospecies needs to be at least one. | +| GWF | VSC | PACKAGEDATA | IVISCSPEC | INTEGER | integer value that defines the species number associated with the specified PACKAGEDATA data entered on each line. IVISCSPECIES must be greater than zero and less than or equal to NVISCSPECIES. Information must be specified for each of the NVISCSPECIES species or the program will terminate with an error. The program will also terminate with an error if information for a species is specified more than once. | +| GWF | VSC | PACKAGEDATA | DVISCDC | DOUBLE PRECISION | real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY\_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY\_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. | +| GWF | VSC | PACKAGEDATA | CVISCREF | DOUBLE PRECISION | real value that defines the reference temperature or reference concentration value used for this species in the viscosity equation of state. If AUXSPECIESNAME entered on a line is TEMPERATURE, then CVISCREF refers to a reference temperature, otherwise it refers to a reference concentration. | +| GWF | VSC | PACKAGEDATA | MODELNAME | STRING | name of a GWT (or eventuallky a GWE) model used to simulate a species that will be used in the viscosity equation of state. This name will have no effect if the simulation does not include a GWT model that corresponds to this GWF model. | +| GWF | VSC | PACKAGEDATA | AUXSPECIESNAME | STRING | name of an auxiliary variable in a GWF stress package that will be used for this species to calculate the viscosity values. If a viscosity value is needed by the Viscosity Package then it will use the temperature or concentration values associated with this AUXSPECIESNAME in the viscosity equation of state. For advanced stress packages (LAK, SFR, MAW, and UZF) that have an associated advanced transport package (LKT, SFT, MWT, and UZT), the FLOW\_PACKAGE\_AUXILIARY\_NAME option in the advanced transport package can be used to transfer simulated temperature or concentration(s) into the flow package auxiliary variable. In this manner, the Viscosity Package can calculate viscosity values for lakes, streams, multi-aquifer wells, and unsaturated zone flow cells using simulated concentrations. | | GWF | STO | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. | | GWF | STO | OPTIONS | STORAGECOEFFICIENT | KEYWORD | keyword to indicate that the SS array is read as storage coefficient rather than specific storage. | -| GWF | STO | OPTIONS | SS_CONFINED_ONLY | KEYWORD | keyword to indicate that specific storage is only calculated when a cell is under confined conditions (head greater than or equal to the top of the cell). This option is identical to the approach used to calculate storage changes under confined conditions in MODFLOW-2005. | +| GWF | STO | OPTIONS | SS_CONFINED_ONLY | KEYWORD | keyword to indicate that compressible storage is only calculated for a convertible cell (ICONVERT>0) when the cell is under confined conditions (head greater than or equal to the top of the cell). This option has no effect on cells that are marked as being always confined (ICONVERT=0). This option is identical to the approach used to calculate storage changes under confined conditions in MODFLOW-2005. | | GWF | STO | OPTIONS | TVS6 | KEYWORD | keyword to specify that record corresponds to a time-varying storage (TVS) file. The behavior of TVS and a description of the input file is provided separately. | | GWF | STO | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | GWF | STO | OPTIONS | TVS_FILENAME | STRING | defines a time-varying storage (TVS) input file. Records in the TVS file can be used to change specific storage and specific yield properties at specified times or stress periods. | @@ -647,7 +662,7 @@ | GWF | LAK | CONNECTIONDATA | ICONN | INTEGER | integer value that defines the GWF connection number for this lake connection entry. ICONN must be greater than zero and less than or equal to NLAKECONN for lake LAKENO. | | GWF | LAK | CONNECTIONDATA | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | | GWF | LAK | CONNECTIONDATA | CLAKTYPE | STRING | character string that defines the lake-GWF connection type for the lake connection. Possible lake-GWF connection type strings include: VERTICAL--character keyword to indicate the lake-GWF connection is vertical and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. HORIZONTAL--character keyword to indicate the lake-GWF connection is horizontal and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDH--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{11}$ tensor component defined for CELLID in the NPF package. EMBEDDEDV--character keyword to indicate the lake-GWF connection is embedded in a single cell and connection conductance calculations use the hydraulic conductivity corresponding to the $K_{33}$ tensor component defined for CELLID in the NPF package. Embedded lakes can only be connected to a single cell (NLAKECONN = 1) and there must be a lake table associated with each embedded lake. | -| GWF | LAK | CONNECTIONDATA | BEDLEAK | DOUBLE PRECISION | character string or real value that defines the bed leakance for the lake-GWF connection. BEDLEAK must be greater than or equal to zero or specified to be NONE. If BEDLEAK is specified to be NONE, the lake-GWF connection conductance is solely a function of aquifer properties in the connected GWF cell and lakebed sediments are assumed to be absent. | +| GWF | LAK | CONNECTIONDATA | BEDLEAK | STRING | character string or real value that defines the bed leakance for the lake-GWF connection. BEDLEAK must be greater than or equal to zero or specified to be NONE. If BEDLEAK is specified to be NONE, the lake-GWF connection conductance is solely a function of aquifer properties in the connected GWF cell and lakebed sediments are assumed to be absent. | | GWF | LAK | CONNECTIONDATA | BELEV | DOUBLE PRECISION | real value that defines the bottom elevation for a HORIZONTAL lake-GWF connection. Any value can be specified if CLAKTYPE is VERTICAL, EMBEDDEDH, or EMBEDDEDV. If CLAKTYPE is HORIZONTAL and BELEV is not equal to TELEV, BELEV must be greater than or equal to the bottom of the GWF cell CELLID. If BELEV is equal to TELEV, BELEV is reset to the bottom of the GWF cell CELLID. | | GWF | LAK | CONNECTIONDATA | TELEV | DOUBLE PRECISION | real value that defines the top elevation for a HORIZONTAL lake-GWF connection. Any value can be specified if CLAKTYPE is VERTICAL, EMBEDDEDH, or EMBEDDEDV. If CLAKTYPE is HORIZONTAL and TELEV is not equal to BELEV, TELEV must be less than or equal to the top of the GWF cell CELLID. If TELEV is equal to BELEV, TELEV is reset to the top of the GWF cell CELLID. | | GWF | LAK | CONNECTIONDATA | CONNLEN | DOUBLE PRECISION | real value that defines the distance between the connected GWF CELLID node and the lake for a HORIZONTAL, EMBEDDEDH, or EMBEDDEDV lake-GWF connection. CONLENN must be greater than zero for a HORIZONTAL, EMBEDDEDH, or EMBEDDEDV lake-GWF connection. Any value can be specified if CLAKTYPE is VERTICAL. | @@ -791,12 +806,12 @@ | GWF | VSC | OPTIONS | VISCOSITYFILE | STRING | name of the binary output file to write viscosity information. The viscosity file has the same format as the head file. Viscosity values will be written to the viscosity file whenever heads are written to the binary head file. The settings for controlling head output are contained in the Output Control option. | | GWF | VSC | OPTIONS | THERMAL_VISCOSITY_FUNC | KEYWORD | may be used for specifying which viscosity formulation to use for a species identified by the auxilary name TEMPERATURE. Can be either LINEAR or NONLINEAR. The LINEAR viscosity formulation is the default. | | GWF | VSC | OPTIONS | FORMULATION | STRING | may be used for specifying which viscosity formulation to use. The linear viscosity formulation is the default. | -| GWF | VSC | OPTIONS | A2 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned based on Voss (1984). | -| GWF | VSC | OPTIONS | A3 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned based on Voss (1984). | -| GWF | VSC | OPTIONS | A4 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned based on Voss (1984). | +| GWF | VSC | OPTIONS | A2 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | A3 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | A4 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned (Voss, 1984). | | GWF | VSC | DIMENSIONS | NVISCSPECIES | INTEGER | number of species used in the viscosity equation of state. If either concentrations or temperature (or both) are used to update viscosity then then nrhospecies needs to be at least one. | | GWF | VSC | PACKAGEDATA | IVISCSPEC | INTEGER | integer value that defines the species number associated with the specified PACKAGEDATA data entered on each line. IVISCSPECIES must be greater than zero and less than or equal to NVISCSPECIES. Information must be specified for each of the NVISCSPECIES species or the program will terminate with an error. The program will also terminate with an error if information for a species is specified more than once. | -| GWF | VSC | PACKAGEDATA | DVISCDC | DOUBLE PRECISION | real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. | +| GWF | VSC | PACKAGEDATA | DVISCDC | DOUBLE PRECISION | real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY\_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY\_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. | | GWF | VSC | PACKAGEDATA | CVISCREF | DOUBLE PRECISION | real value that defines the reference temperature or reference concentration value used for this species in the viscosity equation of state. If AUXSPECIESNAME entered on a line is TEMPERATURE, then CVISCREF refers to a reference temperature, otherwise it refers to a reference concentration. | | GWF | VSC | PACKAGEDATA | MODELNAME | STRING | name of a GWT (or eventuallky a GWE) model used to simulate a species that will be used in the viscosity equation of state. This name will have no effect if the simulation does not include a GWT model that corresponds to this GWF model. | | GWF | VSC | PACKAGEDATA | AUXSPECIESNAME | STRING | name of an auxiliary variable in a GWF stress package that will be used for this species to calculate the viscosity values. If a viscosity value is needed by the Viscosity Package then it will use the temperature or concentration values associated with this AUXSPECIESNAME in the viscosity equation of state. For advanced stress packages (LAK, SFR, MAW, and UZF) that have an associated advanced transport package (LKT, SFT, MWT, and UZT), the FLOW\_PACKAGE\_AUXILIARY\_NAME option in the advanced transport package can be used to transfer simulated temperature or concentration(s) into the flow package auxiliary variable. In this manner, the Viscosity Package can calculate viscosity values for lakes, streams, multi-aquifer wells, and unsaturated zone flow cells using simulated concentrations. | diff --git a/doc/mf6io/mf6ivar/mf6ivar.py b/doc/mf6io/mf6ivar/mf6ivar.py index 6e8b1c8d1ac..ae2d5e8c8d7 100644 --- a/doc/mf6io/mf6ivar/mf6ivar.py +++ b/doc/mf6io/mf6ivar/mf6ivar.py @@ -646,6 +646,7 @@ def write_appendix(texdir, allblocks): 'gwf-ic', # dfn completed tex updated 'gwf-npf', # dfn completed tex updated 'gwf-buy', # dfn completed tex updated + 'gwf-vsc', # dfn completed tex updated 'gwf-sto', # dfn completed tex updated 'gwf-csub', # dfn completed tex updated 'gwf-hfb', # dfn completed tex updated diff --git a/doc/mf6io/mf6ivar/tex/appendixA.tex b/doc/mf6io/mf6ivar/tex/appendixA.tex index 7cbb933e60e..862bb4430bd 100644 --- a/doc/mf6io/mf6ivar/tex/appendixA.tex +++ b/doc/mf6io/mf6ivar/tex/appendixA.tex @@ -74,6 +74,10 @@ GWF & BUY & DIMENSIONS & yes \\ GWF & BUY & PACKAGEDATA & yes \\ \hline +GWF & VSC & OPTIONS & yes \\ +GWF & VSC & DIMENSIONS & yes \\ +GWF & VSC & PACKAGEDATA & yes \\ +\hline GWF & STO & OPTIONS & yes \\ GWF & STO & GRIDDATA & no \\ GWF & STO & PERIOD & yes \\ diff --git a/doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex index 214760a543f..66ebef85c1c 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-vsc-desc.tex @@ -15,11 +15,11 @@ \item \texttt{formulation}---may be used for specifying which viscosity formulation to use. The linear viscosity formulation is the default. -\item \texttt{a2}---is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned based on Voss (1984). +\item \texttt{a2}---is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned (Voss, 1984). -\item \texttt{a3}---is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned based on Voss (1984). +\item \texttt{a3}---is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned (Voss, 1984). -\item \texttt{a4}---is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned based on Voss (1984). +\item \texttt{a4}---is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned (Voss, 1984). \end{description} \item \textbf{Block: DIMENSIONS} @@ -33,7 +33,7 @@ \begin{description} \item \texttt{iviscspec}---integer value that defines the species number associated with the specified PACKAGEDATA data entered on each line. IVISCSPECIES must be greater than zero and less than or equal to NVISCSPECIES. Information must be specified for each of the NVISCSPECIES species or the program will terminate with an error. The program will also terminate with an error if information for a species is specified more than once. -\item \texttt{dviscdc}---real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. +\item \texttt{dviscdc}---real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line is TEMPERATURE, this value will be used when VISCOSITY\_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY\_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. \item \texttt{cviscref}---real value that defines the reference temperature or reference concentration value used for this species in the viscosity equation of state. If AUXSPECIESNAME entered on a line is TEMPERATURE, then CVISCREF refers to a reference temperature, otherwise it refers to a reference concentration. From a4071694eeae34441bb5e8e59e759771a6448534 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 4 Oct 2022 15:58:05 -0700 Subject: [PATCH 042/212] reinstating NPF changes (related to VSC) that were lost when getting caught up with "upstream" repo --- src/Model/GroundWaterFlow/gwf3npf8.f90 | 78 ++++++++++++++++++++++++-- 1 file changed, 74 insertions(+), 4 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index a9ad4fd0499..5a57ecdc80b 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -11,6 +11,7 @@ module GwfNpfModule use GwfNpfOptionsModule, only: GwfNpfOptionsType use BaseDisModule, only: DisBaseType use GwfIcModule, only: GwfIcType + use GwfVscModule, only: GwfVscType use Xt3dModule, only: Xt3dType use BlockParserModule, only: BlockParserType use InputOutputModule, only: GetUnit, openfile @@ -33,6 +34,7 @@ module GwfNpfModule type, extends(NumericalPackageType) :: GwfNpfType type(GwfIcType), pointer :: ic => null() !< initial conditions object + type(GwfVscType), pointer :: vsc => null() !< viscosity object type(Xt3dType), pointer :: xt3d => null() !< xt3d pointer integer(I4B), pointer :: iname => null() !< length of variable names character(len=24), dimension(:), pointer :: aname => null() !< variable names @@ -64,6 +66,9 @@ module GwfNpfModule real(DP), dimension(:), pointer, contiguous :: k11 => null() !< hydraulic conductivity; if anisotropic, then this is Kx prior to rotation real(DP), dimension(:), pointer, contiguous :: k22 => null() !< hydraulic conductivity; if specified then this is Ky prior to rotation real(DP), dimension(:), pointer, contiguous :: k33 => null() !< hydraulic conductivity; if specified then this is Kz prior to rotation + real(DP), dimension(:), pointer, contiguous :: k11_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification + real(DP), dimension(:), pointer, contiguous :: k22_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification + real(DP), dimension(:), pointer, contiguous :: k33_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification integer(I4B), pointer :: iavgkeff => null() !< effective conductivity averaging (0: harmonic, 1: arithmetic) integer(I4B), pointer :: ik22 => null() !< flag that k22 is specified integer(I4B), pointer :: ik33 => null() !< flag that k33 is specified @@ -91,7 +96,9 @@ module GwfNpfModule real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() !< edge properties (Q, area, nx, ny, distance) ! integer(I4B), pointer :: intvk => null() ! TVK (time-varying K) unit number (0 if unused) + integer(I4B), pointer :: invsc => null() ! VSC (viscosity) unit number (0 if unused); viscosity leads to time-varying K's type(TvkType), pointer :: tvk => null() ! TVK object + !type(GwfVscType), pointer :: vsc => null() ! VSC object integer(I4B), pointer :: kchangeper => null() ! last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), pointer :: kchangestp => null() ! last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() ! grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) @@ -116,6 +123,7 @@ module GwfNpfModule procedure, private :: wd => sgwf_npf_wetdry procedure, private :: wdmsg => sgwf_npf_wdmsg procedure :: allocate_scalars + procedure, private :: store_original_k_arrays procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: set_options @@ -149,7 +157,7 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - type(GwfNpftype), pointer :: npfobj + type(GwfNpfType), pointer :: npfobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout @@ -179,7 +187,7 @@ end subroutine npf_cr !! should be passed. A consistency check is performed, and finally !! xt3d_df is called, when enabled. !< - subroutine npf_df(this, dis, xt3d, ingnc, npf_options) + subroutine npf_df(this, dis, xt3d, ingnc, invsc, npf_options) ! ****************************************************************************** ! npf_df -- Define ! ****************************************************************************** @@ -194,6 +202,7 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) class(DisBaseType), pointer, intent(inout) :: dis !< the pointer to the discretization type(Xt3dType), pointer :: xt3d !< the pointer to the XT3D 'package' integer(I4B), intent(in) :: ingnc !< ghostnodes enabled? (>0 means yes) + integer(I4B), intent(in) :: invsc !< viscosity enabled? (>0 means yes) type(GwfNpfOptionsType), optional, intent(in) :: npf_options !< the optional options, for when not constructing from file ! -- local ! -- formats @@ -206,6 +215,9 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) ! -- Set a pointer to dis this%dis => dis ! + ! -- Set flag signifying whether vsc is active + if (invsc > 0) this%invsc = invsc + ! if (.not. present(npf_options)) then ! -- Print a message identifying the node property flow package. write (this%iout, fmtheader) this%inunit @@ -296,7 +308,7 @@ end subroutine npf_mc !! from the input argument (when the optional @param grid_data is passed), !! preprocess the input data and call *_ar on xt3d, when active. !< - subroutine npf_ar(this, ic, ibound, hnew, grid_data) + subroutine npf_ar(this, ic, vsc, ibound, hnew, grid_data) ! ****************************************************************************** ! npf_ar -- Allocate and Read ! ****************************************************************************** @@ -306,6 +318,7 @@ subroutine npf_ar(this, ic, ibound, hnew, grid_data) ! -- dummy class(GwfNpftype) :: this !< instance of the NPF package type(GwfIcType), pointer, intent(in) :: ic !< initial conditions + type(GwfVscType), pointer, intent(in) :: vsc !< viscosity package integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array type(GwfNpfGridDataType), optional, intent(in) :: grid_data !< (optional) data structure with NPF grid data @@ -330,14 +343,27 @@ subroutine npf_ar(this, ic, ibound, hnew, grid_data) this%spdis(:, n) = DZERO end do end if - ! if (present(grid_data)) then ! -- set the data block call this%set_grid_data(grid_data) end if ! + ! -- Store pointer to VSC if active + if (this%invsc /= 0) then + this%vsc => vsc + end if + + ! + ! -- allocate arrays to store original user input in case TVK/VSC modify them + if (this%invsc > 0) then + ! Need to allocate arrays that will store the original K values so + ! that the current K11 etc. carry the "real" K's that are updated + call this%store_original_k_arrays(this%dis%nodes, this%dis%njas) + end if + ! ! -- preprocess data + ! Hereafter working with the "real" K values call this%preprocess_input() ! ! -- xt3d @@ -416,6 +442,12 @@ subroutine npf_ad(this, nodes, hold, hnew, irestore) call this%tvk%ad() end if ! + ! -- VSC + ! -- Hit the TVK-updated K's with VSC correction before calling/updating condsat + if (this%invsc /= 0) then + call this%vsc%update_k_with_vsc() + end if + ! ! -- If any K values have changed, we need to update CONDSAT or XT3D arrays if (this%kchangeper == kper .and. this%kchangestp == kstp) then if (this%ixt3d == 0) then @@ -1085,6 +1117,7 @@ subroutine npf_da(this) call mem_deallocate(this%ik22overk) call mem_deallocate(this%ik33overk) call mem_deallocate(this%intvk) + call mem_deallocate(this%invsc) call mem_deallocate(this%kchangeper) call mem_deallocate(this%kchangestp) ! @@ -1095,6 +1128,9 @@ subroutine npf_da(this) call mem_deallocate(this%k11) call mem_deallocate(this%k22) call mem_deallocate(this%k33) + call mem_deallocate(this%k11_input, 'K11_INPUT', trim(this%memoryPath)) + call mem_deallocate(this%k22_input, 'K22_INPUT', trim(this%memoryPath)) + call mem_deallocate(this%k33_input, 'K33_INPUT', trim(this%memoryPath)) call mem_deallocate(this%sat) call mem_deallocate(this%condsat) call mem_deallocate(this%wetdry) @@ -1163,6 +1199,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%nedges, 'NEDGES', this%memoryPath) call mem_allocate(this%lastedge, 'LASTEDGE', this%memoryPath) call mem_allocate(this%intvk, 'INTVK', this%memoryPath) + call mem_allocate(this%invsc, 'INVSC', this%memoryPath) call mem_allocate(this%kchangeper, 'KCHANGEPER', this%memoryPath) call mem_allocate(this%kchangestp, 'KCHANGESTP', this%memoryPath) ! @@ -1203,6 +1240,7 @@ subroutine allocate_scalars(this) this%nedges = 0 this%lastedge = 0 this%intvk = 0 + this%invsc = 0 this%kchangeper = 0 this%kchangestp = 0 ! @@ -1213,6 +1251,35 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + subroutine store_original_k_arrays(this, ncells, njas) +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfNpftype) :: this + integer(I4B), intent(in) :: ncells + integer(I4B), intent(in) :: njas + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Retain copy of user-specified K arrays + do n = 1, ncells + this%k11_input(n) = this%k11(n) + if (this%ik22 /= 0) then + this%k22_input(n) = this%k22(n) + end if + if (this%ik33 /= 0) then + this%k33_input(n) = this%k33(n) + end if + end do + ! + ! -- Return + return + end subroutine store_original_k_arrays + subroutine allocate_arrays(this, ncells, njas) ! ****************************************************************************** ! allocate_arrays -- Allocate npf arrays @@ -1239,6 +1306,9 @@ subroutine allocate_arrays(this, ncells, njas) ! -- Optional arrays dimensioned to full size initially call mem_allocate(this%k22, ncells, 'K22', this%memoryPath) call mem_allocate(this%k33, ncells, 'K33', this%memoryPath) + call mem_allocate(this%k11_input, ncells, 'K11_INPUT', this%memoryPath) + call mem_allocate(this%k22_input, ncells, 'K22_INPUT', this%memoryPath) + call mem_allocate(this%k33_input, ncells, 'K33_INPUT', this%memoryPath) call mem_allocate(this%wetdry, ncells, 'WETDRY', this%memoryPath) call mem_allocate(this%angle1, ncells, 'ANGLE1', this%memoryPath) call mem_allocate(this%angle2, ncells, 'ANGLE2', this%memoryPath) From f2efad974b78208cc58366e745398a88e8b728b6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 12 Oct 2022 10:59:16 -0700 Subject: [PATCH 043/212] Some code updates and some work on example problems. --- autotest/data/stg-vol-surfarea-vsc04-lak.xlsx | Bin 0 -> 30532 bytes autotest/ex-gwf-vsc03_sfr.py | 2 +- autotest/ex-gwf_vsc04_lak.py | 568 ++++++++++++++++++ doc/MODFLOW6References.bib | 10 + src/Model/GroundWaterFlow/gwf3lak8.f90 | 19 +- src/Model/GroundWaterFlow/gwf3maw8.f90 | 39 +- src/Model/GroundWaterFlow/gwf3sfr8.f90 | 34 +- src/Model/GroundWaterFlow/gwf3vsc8.f90 | 129 ++++ 8 files changed, 784 insertions(+), 17 deletions(-) create mode 100644 autotest/data/stg-vol-surfarea-vsc04-lak.xlsx create mode 100644 autotest/ex-gwf_vsc04_lak.py diff --git a/autotest/data/stg-vol-surfarea-vsc04-lak.xlsx b/autotest/data/stg-vol-surfarea-vsc04-lak.xlsx new file mode 100644 index 0000000000000000000000000000000000000000..a1c18ca1ce846609028aac37e5c01b4b329afe81 GIT binary patch literal 30532 zcmeEt^LON5n{8~{wmY`%j&0kvZFbC#-LaF7opfw=Z0lC{_kCyPu9^E6%&i|jwN|Zz z2YWyJIaQ|=WkA8ufFOXNfPjFAfeezox&wfLfZ!m2fKY*;K(s~d?OaUlT=Z2u9Za2d z89Z!lhzh|#sPch80OSAv>wj?s2301dLBAk%!*&lORi2eT5Rq(nT^*GPpMn;Tx^S>& zg-ocdwYamdk|=3Mfir40jQR*9@8fRNaI1F;3FG?EGgJmr^`073*;`$6`_k2l1r~RH zW$-BbiKDn4H$5#r?+QlOx@t_XRp>!VeuBXrsv5EFX-c5q+L;@9I)D?tRvVA}Fv z$}1J6c;cZV?~KZlqFuwEJp!o{RhU0Fj=FOzFlfZhe~@6%Y;`^hDTO_+TQLbS@`Tke zQ7A%a1D)ugCz}qj0+XVRbDW`6tQKS^i6DrN{6B5nQrobD8KP&PL`dH9jLY#P`oQs>&8z zmUTwCPTVA(`X)BLx1w1+sP8`X^4TLwB&;Y;%+nIXA=W-(h*l`K(_wYaP#Z^~3!9EY3qZ{%gNd z>kA4^JF&k#jj_Y8n(&%WI$3;h$$YiIsV0+?r`en-cox^bU7Nh@(Y0^Wpy$-b2AXLS zX-sj#*H+6)ZK60w*Pn-=1IJ`bWI~gv)Psk#2BRXn>t_ zRaI$8`bZR{CJOT2Y;xKxQQ0W7ZAGHCfn(aK2Ray}D%)+TIA7NI6^#A1-8lK*SVGX#dHI9LiWliUx<|ID-Sl#pCK! zo$Y)5Fgau>Zv0(s95hTQ_zQ@B0lB6u#yMzW$!w&Rh5Rnp-w?Z(W zx%QOq2}P6*fiZy$HzGn?!qWXq?$g7hTeya3WP4zq&<~0kapEKRVqdYi%9Gn45U+&6 z9EbW^Zt_7wxmfumpEHkh&%9up_u>u+k9yX^5tZH*R3s&h#{r zZ_j5$kryV`zR#*<>1i;?BxJ$r&o58E3#~MObuVB0W{_o?;Bu3~W_(59j5?U{dBmT7 zKwT2y{2{WxG72Rx1vw(M?r_3cAOIyiImKP@-Ci@l+`DKt^}5(jFJRG`X6}m4$Th5W z(iJ(o#_j;c)+2OP9u17)BH35)p>=u|=6C$KWU3H&xjZ3~;acPZOnb6>^#Wf+dZ6}l zqXa0=O#+{*@4k@M*WYajINqq{Cy1rVmb;aBl`S%F{_FMaVY?qcN;J|$M>2_4VD#ML znT3&6+)T~ENoIP$i02KZ2B>u2GQHKH0djddY93UuQ0Ezz*yZ=h%e+wTlpi>2m z{onoSOjeK?WJ3CR8MH+_u~Ayx9%0iCDYjf$Lr7FSUuu(;GV%0%Yg4h_)v!E$*Ksr9 z(T|sTZNq#i${lXO<2#Xz64LJ&MqG7T4?bSqjXQvMsn=voYKL^-@BzZ1@m~risO1&MKxa!E!z`!S|HIVbB*+Apk8lq1`U53 z-)wDmSKtK4Z+5!=ev%E@9|@gR49C&z#7H!clOo}=yCKgw z%QM8tTB(9IcCjX?vRhxDAfsn<>YxDA#IN(&L1GLrOF;F6J~UIsB3Sism=7;;{D@4a zALSrWFU}^74hZPi4G<6(03!dA17{0UQx|8(zi(gu=t6e#THG2DQrIQ!JwDQ7 zeXK%#HCg4Pl&I#Ay=pkq=V;!O_QPr(3P_8pITGeB%W?+`vNr3?mm&SB@uiaIs zU$I}HNn$*PRp{IAvHV}#@zAiaWjek!SL_-4Y(s3xZua1wr}(krPSJx1n-6&y+vpNa7<>D@1?TF2Isf+oGK|`c~VYz`F1z)e7n({?k5Lv;mgZFO1wirVL$dA-GjgtM1Y>u*sDI+3D?7?Y}G zKS+T=o;~rwV4P5tz{Hd=%7?MM9X{!=ArEApApg`Y0H8iUt8%R4$y*%5KBMY1u+(e_ z*_a{wDr0cFYtM{#G(K8Hve6q z`?<#VabRTY>T=?4GFaq;3-^Y9LS6mv);IPFk*!~0(QKJkse9&^^9Qb6#bo*$hwKY3 z;q6w&{FcV;mPWt5&(9Z_=&DK$lP#CW(1lI$d3c#8&!>m1mW|8L zXMH`t*N1_%hmAGD%{cuJ(9b)_*R7s6-`j)c(F2-^;g@)is>@Bc%T2#eHz?zK{Y?Rs z_u%)SciB(V9a6#^{>`;fKKDz#_Ws)HN7v?QCe1$INtk9x3dr?Dc7bJonY3zMrKC}crEhZ&-Hj8XT5&cuzplPPw#kLC^_JdeRsfp@ytkTv&Wf|bWAWm zall{heN&J0*(&`=E#x`yeW}2O4 zhC=x6@x<}46tX0{On>9*(Gqv-JAI8y>;KlR@x7d*r34<~J2jo!sX*tV*wAws=N4jU zEyLp9eXfTQKMtek|Lhg*nh@=Z)2`;>H=Q{6^Jj&mP4o}jbh}Q+2Kf!jEqb2WsJhJ&5`$o&wKiDB) zw4dvF5#dbH<0)1s;6TGm`t$sl!M4jayFhBSKJV2RTZ%`#5c9lD(t~HpmS>~1I|tLd z=9}ilH_gVq$SW_Zv-4IL5&yN%)zUiaG#H)_)c!tcqtFk_>zz1pz0$2^|ChUu7Jsde zE4j}Db+hdgmk%p<+;D2)rt!NS#9jHf2L|h$Mnv|Rot#EPyP@u$bM^FuSBLahw@3l? zhe;jQqtO!zJeWou+1nYozWU^7YLu?l475nwFZTnyt{gsLehtH4*T#PCe~3S~ohx$w z@wDY!IatG#fr}a%s&kJ;Wwo#q+dx}ZKXQ~CxwD>M|IOQ%i1r&HBnRBE&mD1{>>?QF- zG4It`N5~SLwyT=i*M!f}=MMHh@F)8n9a>An_mYdYl47?9HDHUV5Oafd)M#3gCsjKeTb^NZF_=UPT!_}%KPxd%8Ara)q-X(ep|6?hzwYx9Jr0tfAj9U`n&~|h3o2-{9 z1SG{;%4UlPC0N{_z3*;KSX5@8a|W5)A^gh-Wm|=rRRsusMf9jE-W!$rbvioIy{$OU zKQdSKVIAE2Qgji>c&j$HOxQ9R241>LcqJ``Fy+dEjLHR#R?lf#^XN>bd~kBd_oyqq z%+Ui4O~Gw|&HbhX{>IN7R(OYce6Qi9{L=eVXx9lwnz8y0sz4xD+m{(yoC8|2MJun= z5w4DH{$-Df??X@Mv^4YE)C=sO$deC?i9}o2{B*IpnIgYxSnf=3_15L|#_q9Fe8P)$ zQ!bHJvY=Iyo$R!u7VkLW@WLUU%I#z#me|_Vp3(eXn|e*b3CnRRHkDQj=Pd>oedtw0 zq{BU6o}faqfkNedL8e@*5cur&im!KvUu`@6(eL@D{N87FIc1sbR{O9C`laoo%)7DT zaVMtwWNaLVJm z$?4R_DbudbB!IZtAH7%v({PX^e3*Z_IrTRogZRcSqC%}wAfZ(^p6R&l`wf|B`Qrt( zA7eC!FL`m)@7uAQc4l4Wi6a-kjbKGBDikjnTh_X+?;S5*v{?3u*^@H8;8asuG|A1B z{o+o?&f<-3?dV-@e0?ycjG@^5v59yN#cb6v6tgdT06c&cHRrl>ui-KOEL!E#ErzMN z!(dBF_kxo{Y0xCsTlR}9vzKo@x!MI>6GJJ%uAP#05>Qb(GO?6+79NWgB+y5G0U{c<_k=b0W2 z$XM!Up|+=)Z~D#AtMerP5atwi=B^pCt^+@>gg_Rb*%sAgRoWy96*;h2_B5V!{>hu% zgxj6(Y9?l&zaKYJLXx>MN><@7*bFfcGUBKtIhA3BGMW)Gxv#gYTTn8^GxaEvEZ-eX zaQthF?|)(it)f1AxtEwg#=ywB?xbGQat~X^%;kx0#1+Nb;xoAJc1)2o93@nNl3QJxUU}E)j4B0&`_+H=<&uY51Xg-!w~9j7#+N3}0`XT`{2LSw?6Sy&l@94{ zt|I`8t#wJ}9c@TIbW87t6D{Am`r9rzgZJo>5O9zCn8He3m13d*DaCI>I6&H!fU?14 zQc@3>&3USEjg%cWJ$4WK`mcFOi@;`e^w1TI^MWMfP!-LPK96#fYJ^NT zXy$V=X7WlP$?I2oz(lS;AgD$Z#p#oTCrcoJk#)Sbt=`aMe4Vs-8eo}6ChH9?i+LoHvgk$UgG`btsw1=_W53yzF~nW8(C>KM#w>rE z<%Ive4U%emGVp>zOquIp}!3z$QSZUwehkq}0IF4)^OF1sCaGdL9W!6x4!t z$onjL!nhGf_S3FX%VkaxLUvp~!f?BjYcJ?woOWRqRo$@w^o84E<4gUcKpWEF*=cVL z>ei3kAl)W@lxY}_rU(jt0GJi%!3phYH(uUn-n}`$D=$5kPQ(0UtMjJlVz&IrSeOAx z^Kg-Z2J+yGzYJjRqH>*#a1z*^yyX}m`pbamYn{^nEMgE?SXos~o_)j;(LAO6(@*H1 z7VQ~bK6L{aRJTTH(4x@Cpmlj@H|&=QsBQpDqqHbb`9#KZ(`#7h$&VVSgTmbElWDq` zK~1YgCPLG?B*tOyy1EfA{v_Lm z|JGFerVEc1a^0nZb$+2X-zcY9w#}2==n0p1&apoTW8>Na?=-cab32=)LJf>5`2DwS zL1=fgIV;Q3>Oa9cX{eF+(O;%+{qa5XJ^I~|M4M@_9}^!#Zjgs=VD5g>_S+7qvCW*) zE|NK%+)6uu^5?01JSc8xUE?}n={^6B)PsF;^&J2PhHJ`R?_ne6(`P(beLfAekrPCWH7gJ@ zl{4kO|I`b16|RkkZwtc3rey`tTp=`i@YfR(&(=?XAfk*xo7M|CRRwB5Fks2c642>nx&W{CvFXdXLpJGOEc zbib2+T7P@ZqnWN1gBEg?1vCoe&vjrFVqZRc zMmes^f-Mz4oi?5R2l8G#`dVYm5``l>4D^;=2)+nX4Xz2llT8MjP}7;K1>*Pt{ooX) z^${?h=tXn{EV>+X%J{$9iQ{}%$=>xnz(i54Fz&nK!N(sAvqwO+2Ikj)dJ$iMua-IB zOK>5$7b}eH9lQptcPoHWGa<-jXyYj1y|yv*H%JA4gH*5&Z^M%qv*z$!d92XVb`wpkP_Yw2dAAWzb`uYRmq=aRDv%MnVW0+g;WYE1@Mv&X7?lMrW zZP9oqT5CzPb1@Lgh1yEO$##ac`~t~3=Ra#XJKLg2^JA`Y;PjV8Vr5E#CVpuX=`UX! z|8ZD$?=n>$3r0F0aYYul*!_2TQt|MAIxNv$8an=tYzA;Sj6{{I!t3K>3=kR4*!zdMJ@{G0?-}=ml!9Z z;gi#qWJaIYYiJzDABh5XO_4`Uo#ht>;{K7C5mNw&(cC{h=H2FOjmT1Q8TMy#4nBo?b1TP60mX6FkGxZtxjTuQZEkPnY1SN52S?aL&u6}29t|bB z4a*-;&1{#PxBlCnQiK8`#gC6@8Rx@H+J3`bWxf7B*hh>laXl%c6~=3N_fbN&Uwu2= zjiYwIANQ$-yA6|_a!WULI7mPaOE!!7$Ay*zecww5Wlgk21-=*ex(x^j&~sTnHHiuQ zf^f&aCE!8PbvXAp3_5gx|4v?A3%8WaXpsB#9q`Tr!0!+_sLqy znXyWaA-2tG`VbMyxGI8r{ZMD>6$S-_KU9F%s5KRi(m{dIUEvDO4Oz{IwzEmKTktKzW{2z&g}?F)q)6s( zzk1iO?b$r@z1-zN)|GQPGJM=b+Of{oR!CaF1QyUE(fO#J9tmQJAo3wHFL%OY3hRYT z{JVGwoyMh3db)p7w^bo) zcF3RRYre3<6;SD7>cxi!PvKMJB6Yu`C8_;m^^`IhoN;3j-!CB_R~|hyDxJA!&mcFf z->~d6P2twIVb>|9KQkLkUH&%BT6y@?-jqD(`By6G`F}N#DrOP7m~ewOYZ2W*d+vn` zAfw#LPc57%JhrY)d9d5%VJNuA(1 z%@E#kp|!au((+3kv1r~I*JdNZ%kjw_$yx$nIeGxqr%hICvg1igmA~Q6;3j8sl{TdL zc3}xmuvNfQBtUy;st<+rQGaQ9rOobCrd)Nv1+*3 z5m>Z5O0*kZF>wve(uy;k&)3s$5&D}8xEwACB`f*@eYIn|Y%v9R2Y(w4fiX<16;4^m zjWVU`CBs>+zQV@A!Zaz&fEBWwv_JV}G?+C#^XSI42d6j?40js+vD5g^+3{HJ^lls+ zBDclt+i6`HDx$NJP1TkA#)C($pSeV}Mg!mKR{l;%| zt^j3QrOk0aG_-*9av9{1Qn=@);--wvG=mnio!&&+PcdDoKT|EqQx3It$q9DNe10W< z!Q3GR`Q?X0sn^l=Qe?t2OG8HIto z=t%9MrVvn4ymYX~0es-<$~O;syU?9pEEa-k_5;rO$Y@}uX<)4BF2q$6f?q&8u%z9$ zl_fUSjKWF~MgTo1izJcEPM9zF>&N^!3pEDAS(xSSM{!)TAn~&kuX$pR$LvsRJ1$m{ z55@H$xXg1Hy;or+7#Wzbc6`Zu<^oroJC#}#&Qgh4nMkutkPT*}O(yG+6-IXVFqQF2 z5ITk=2b!c4^{?nKj9u!_NjT?X_!Hu<@^3-&|>FR1QwjNbD_YHvO7ztaL2Qt zq}V-$nU-o~Q9JN(j{XRN|5~%kh1|h2hkfv#}#zpLK%D?x7}Ae z$sLy1pB_nU>#)r6?|8836TP%9qP}M$>Fco$f?&WqfSldf&1|!5f|nf(m2Q_Xn$1LD z1F+C`tiZe+cbC3w%%bBhA1x5JQUYSBYS#*3HGTf z)^P;}$0v8k>Biy-1HA4W`ruc7zxgW(qHPebPh4)F{B$w*QzzM#r_>IMSzWQMKi4>S z-;qYE34}C{Cs9I_)|*?+=$RR(0%#t@mkjY|$wE=!G6(B4h(lh~1jtjs!6TjwH?U#9 zeiE+4JyBK}GVk){wIF5J{M*DD#;u>g$oX5gWICJ>T5orecq0-!*dP_Qyb@$vJMkG& z6g?;MXg87?iOd9EOpFQIVDJ|_0p1ifv7KxanVD3SsOQsYy^EVZEZGxx`yS76?3d&B zC4YYf))8?KkOAoil)A8_i;ZkG9GbhP%u-pn_)z(_n?!FdlDwlB1&%O$(R%S|Hu&qT zaMY3LyQXHeBV{38je+YSk!vSWew4*B(0QbgNAa!8yo{8lAz8WVcz2mcLTf6GW$mKI zGkTA23?^&0FW*{e7ldjq;o-lo^%D5d)X=z5v0*3WcdT+zrL)To;Q`z8l)=bJkJPE# z#X@0d8yDxVc2{%@Jjn(V_o24?`>knet!LfEMtd`M>7<^;z)~MJZUanP!DgQjBNz^C z%MeDRa4KN7aiqF%4>Ju!X@3;>TBURr!)@SepGAitT>JDPNUZh}4qm@;54yfr633QqQ=Ww9yGqRD~B}%(;^Rb$u?-|6x7dLs#yD*)_K%(Hd{Xeih#x)RM%hx zKdjp}_&+_`wmw2%B?qo-XvTF83!1`4nEi9%>a^i$DTxroBnUY#zeuc@86I(?DR9&M zaE{t5*C!?TeQew$Gj--8-+OU9AtZwJyX1ite0;Rmh#Ar|&SrDi4<}7xZE$oH z?^=auJWa2ErI`oqF`S6eIEfaDd}US({jf~rwp6NN$3nanl6Ttn*6bquJ0G)i_R#?K zk3(D4F*i;KTS(Q>I9Z~QnQKax@cy37PBv+E$6V?(7wn%k_@)`OnIbd%tdqcQRw)y5|Cy9aifA%nR*tbBsOPj^rf^jiT@t=)?(ki+` zlPd_Lo*|efK)Qv8-9U5f@*#34NwW^OG>%LZkdJy_5I8{v7Ob(&hN<*Gpw1 zR=^>!(%+VF8C?gx%7z3>bLbHVR`wb++625BH3`*Z4R|5y`zIwYN8#DHVH|SqkZNeS zVKCpBQhx0o^OPP)x&(En=XRLiFr*3WPTra{B%3jpN|au{Kv2D5Kdm5=dkk;#|ZQesWc``!G5G3}uwg_nM6o_`!J>5kea%Q3vE%JZ}y4$z#GtCe9 z{Tp~%ok|I6GU!`&`SqEnrE&Lxoy#10$mJ(HDw?~P{doSwz0Y^fHf@LS$!?aM#!Z5J zor8Lv1La~(+&}k*eLP&dm1k;)KTtCQzc|37EHH+l3&%u5>F+{i*?X4tk!9W!S(+w? zGm4&wrIhDL9`?w_vKd7vsaa^LxRGP$#&EeW?1*jVu5n|~kgMi~RH9^Gr?d1kzoZZo zFoi{p(ih|$da?hIjLNG4$^619yP3RFN2(-nwO+)P(io zgmpchs;p ztxAv7Q+H$DyrKKz!Z&S(s?Xj!FJT#bcuC)59P89DC>Q@Eg@){sYDypI*R7E<*9w{1 zYdV!3`abj+BnVs0f-T}@^%R~wKX(-wS)LT6mzz!+n}4^zo_nRzA!jUXqk|o9_!49l zmKawRr?agX0v!E#gdv8LJ6^Q?j!u3QJt-7go07Tes)gz|Qp36;J>;pM1HEqxrkQ=RCkTJJ%uXNo*LMRrsj3+HSR%xeITp18IY#!L0+l)LuG+I7T4{;pxf zQ$Z$@ZRtVLJe>M0X<%MUDme6mM%VPobD!C%r_0v}2>>kP zTc`=_m3ia1IGOpv5q_F=>;dMRIOBMZiL)`L_^0pPB4&t)?Kf{5Iv{4;JhkVDxoMO~ z_&B9P=88i8B9DM|RuR5opG<0@CWB<{o4Y4#k4YcB;0)h~KF;oSkhfg;2NaajV%?Ee zL{VmtX2kNc2(;))Ji{o>H;dx@?Oq{VG{l}+fK@{GA2IVs*4S&Y zA!3dcfw@&A5tPf1iEgi(5^U46l5sLaoZKB;XSNtvts~!<4dbLGH%k*b<%qcsiR>^U zTr?FdYM$qL4TMD?F~$+5@znCjWu~ZLes6I)zN}cXJ81K`|Oa zWerLa&-2JMV3Az*JOtVHvqlW%-`&>sr5TQglY)Y0H7L35`>@$^{}@w0u(Pt zx(i~iKrjob+$#)7jk%2-?hkdqPwQ`XaSWmR7*AL7apC(7{l?x7g5mqE%sl8ht3a6y zo^3s#idcVYPlAsFdY>o|rjmji0Ok4ztX_hW9BN@C4VPOuOGm#?Ks!SxznsU+b4j1_qLo>L z@(75+F7?Itkb!Qk);8E=x}WBtR$MO5l+o=|2)Q@>$$LqX%J}=tdnsQL?w~jNzNnSw zL%>X+QLlhc&@qo$GWh#z2K6Lves zw8*qlA^RwToZ@nBbUi`47L&@n8yR7?!swcEy2uUo(DCD?gwWt)M}E7^)Q$#&Gwt$? zg(OAF;nmZY(hmz2i5F0yyaU|<{lLQ+r_UAZ8WZP+Ro>R0>+6<8M*T?C> zKr`GaWqm<1g)|?7L}O2TWFIJLa^B0hRu{{76$r?7R?eBxZ6JHR9b{XKNCL|%^^CC7 z0fNZmQ;(W9F@71B00FTdQ01g^8iO`Ap8^$*%z3*S{2GJkY#t~0Xm?3sG<%@BIE24V zeDZsogD$?SEm~xyfl3#XYmk}M?dh3DsNf&Gl)FY;4U~%wpbb>ouCtgV(d|$-j@0|q zMO0c}o$&e9LAA4r&Ws`fV`^F0P`olZ9?>F$SX4fqvhUR0E}LRZt4OrjC5XiI z;12Q&i72Qo>1S*1LvW=%LevAx@nU}7=`Zw(K5e851u?**xG+l!_VCMqw%I3EX>z3R zhtem_ET2avwi)J;OZVzDiCE*54K&y`Xq-H(kNxfke>Ol?U*D$oI1s6T>E3v$O>L-{82f;!*zQIR3sr8cj*fb6|i9#l22F18dl)HT}i5g@WjM`)rjngjs zfJ&yB&+j}-*DnGML|c&{xDVPm!jKpQ2q>-Nl}@MARcUR=jXZxtM957iD!Lc;6|c8h zBCI0+LF28g48~dv<@L*mKv5Y+Jzt*(%E&!f<2yp5$f?Grb_l(2YVh~H)Zj^9ay|E( zL@_cwO2eq4R$UTJcwai*brR?zd{A?q{YI1P%qXjP}>dWT&CSsI--2^sSY(etef0-=Mo~c+-_OTWdv60Op5@o|yDx4ma~OnC*2MJM|sQNuH-j@4xOf61g50 zt{4+bjCOED`*!9S&8_2cD;}*DOc_${qZ1Ib_>wCEtQR6vG>`9yGO_E0wsjEHu#Jj@I=dGr__H@}09BF#^EaG%NvupJ_i6W^cDr912- zW8=4afLFgwUU)FBF7845QYEPCNa8|hUsYqD(zcf!GJctM1#BQ@-V~!!#H)1v#Xf1Y zWIjSqaxT(ZW-1#gN41>h!;1kl@;mc#( zAgIocODyCH_(o?(ngE2uo1YBu|7>=Qcxdlt2 zi~~^7Dj=@uGI4ZCAg**Mo2G-)WAIMk-ziz$$6}m`LELh3e5AnSp-|~AoUb6RpyB~i11pHIvU$;3`VuWD&1>wYMQJjEyR7Dfy z)$Q6H4xq)e+=6~!&y{T-=fE^NJZ`;SeM1xHhQ#;OGbrriZJz`d@{BRfD$d&=)%ht) z5K0o7>r#T>PhEyRDHk1k4V~}Nw+}Gzh1hXTCP1(psXGNu1YSgw7?Tj z5u}u*@30l~|ImQsBA>dgIUI9QoMqvBX?l9I^ka29(gIRQm}!e@-h3oCmT$^$gOx+X zk7FIOx~R8onYhRB;A5DJk}I?rV@=2JLXv)k8eok@yRsS76FFi;f{pT?*!t1nuKo=p zew($W!GZSwq^<%~)>JU=-4D9@l1>LHoi~cUC|uu{!Nk z6Q}C?DV1aqCt{ST9@spUHbc=0tESnketX6eih@U3l!gV(3ps(~j7ler1POrgOcL*38T6gJz|c4%ftZe=H7;VS>qgqSQi2N8}q; zNMAQSUyC|4%tiD3Hqo$yk_$;VWbC&$=KuG4@!v;r&c@UQyIrU~`3N}YVh`U4*zb-b z@gP>g_|l(eMDv@zgmVpa%G%IK&qPotV|f-|wf0GVJ`UG@-k;X?yzd=t`F$J@`@cW- z^t>)@^|){OKi>QMeH^KOoZIibUVbe7%=3R<^Z(cq@Oyt5ul;;GzudaimVP~r-1@xR zV`RP)FsbSWZmWG;+VZ~<__%si06b(;pJGskwRgv<9N8lYGmNv!^fSt0QX@~$rs)q- zCPlkGdNyRIK9-h3p0xa*$48g#ggqZ?mZ`yWlt#bUQWKPCORPU8!hKF*oP2`m?NnW9~h@Q>MQiH^0*{q7?p^&)6!C%*wD!N}b_N{Rp?Gy}5tn^S1BmSff;) z?)A&VQU95#4ae(12i__~W21oU12vg@nN%@o9*eo z*8S$<+7zKBmo2k4v)v9SGiB1&`&YUl9VcM$v9!F6&zBQBXlQ$^N+{>-dfqIXjK@&X z%vxVNbE-}JjAaJ~Uqk7e?%p)MX1u8f+3q(OQSRVGa|b-qN0#lE&=?STOYdH4?SZ4} z3gF*hXZ$d-2wp8g<=m}}_!!#q{V#AhI<20fEx{_pVNOr2;qy2G_UQ113XnB3!L#;j znt`fIdsfRWzVV|!Y}qGXgQn(FGdSFaM?2&A#G~svRgWfN+UVOJj`O;%7Y)FTbrBm1 zfeG({M}&f5C8k-jfz%wR(Wc%sk~V&%>lhh7#U|hTnOWC?wAM)I%;u+L<4PjnsL*YU z6YLB2sSElk1mEjBQ3q*j`#fA09ecy82`=52MMF%9oq1Zlqbul6w1RFDKBMX2#QAN~ zsD;FiLcgAEMJ{ct1*k)Ay{fZHzV57k_$KIWY$DE`Sb8bmFG~Z?Wy}|roUe>+bTtEE zk3IsZ(|y$ewFnn%z4RXIYXCdda|EXQhYtdze%=;@=lG18YKFjHUieXL2J83f}#T&$UAoTzR$xUlPJlsBxC5|8Fw@dMK6YXH@WV|y5RE07u}14yrB@6Qy` zuaT`&)werl;!Plf-SKv_L?J|kuFYVWy$$oqAhS@NcfaWea8!EDdK}n!37!XYZfO&$ zf;()H#x4k_-8F)7?#z5td(JcKI8m?BaLaGiG=oWzh3xSA6%dqrKt{P+=ZToBDPdUT zrywmiAjt8N1)W3DNo_c*SX2(;P-Qm>dU$zzA4_f2h*oeV4;_w?Y-jR?Z;(kePMx@) zN3a!&|3z&M`qeHdum@b&Z@-#C3jR z3{A&afG7GA!Zs#;S-%UZ4F*9^oDQA|cjh=Vl7F>)=iaOsYTi>GjBEUcUrHNs_UfU* zD*2Rk{)Ed~mdJp5yNzu~E`jo8)d5X)A47uA6>M>k1)esdDwu~I*tZHo(i-f9 zgwUV#<(ioM((P1Pg=_uJVLxu-n`K?lNFR|C#=Hg3w8k)`BRlw_JSs0hcTjiqSJiTXv@~|J;K`0| zV-PFZEF6TYAs_O&p<$u{G1NSA;Mq8Gy<8bgv9pC z&|ZVDP~mrBNKUt>qU8Cs&8!2Oc30Xc-{MJ~tooo^Etc}f5`~ezy*vJ*^uSO@(u91( z5me%}N!JA}W`su|VUf(w$N_s}XD>6VWAASeAbuPyiJ%Rr3eEz#YC+OKTw$Y9l(HC2 zNVLy38}X>L16>&&e(1E{%^3RQXcq)FN42fVo`YXPS|&8aNK5D&J+U~Zt%KqL-ZRzH z!;wJ-7^EXL?i+{+h!)6W_!$msYXG~)Tm_B?_~<}VEUN^v@*La9Sc?FVz`Ox?!d`T< zc(6kVq!1)LL$T>%2piMoFm})_S!*=}dg4yJ;U=NFuQ2Bjy69qG4tgRQQcT5kzR)BZ z} zPk8;E(}!IkgV*4LRVQ`c$m~!h#_Q!36c?5H zIP*h0tdz^D6%2uy9hC$Hz{`K+217SqFjHKO{(O z5vEI-8-hzNVZ4+tK7leTHV4%Lfyz(*w@k7Toq1r<{}GVn(LF&`DJH3~04=T#2-PWX z(L#A|zeYi2Ff-DwaW+UlE;2rwSX3ExJ*i zAS2wZ+Q9i$GO^#_Q2X0~l&Yb=ZTyOw@+wf3A4exv$P)QN+;js&aJsDr+?j#Vf&i;% zUGG$?Wj(-{)ME>(Ni&{%tLwQWvZ&QdhVF+oc0{K7AxT$(4pg-jh|A;c5YD?q+_ z-m7)G%HkDvs?gcaJniqlLd5z21N%!o0?qQ2^FRjEf8-HPhDtajAiEoT89-3T3~KvaP*(j4;< z+%y5#G>*m^s2qTOAKmALsyYSRg_Ap1T|>1~-S=lz71^oi+QpHoufbZJ^lcJM!OvnI zP)Txb@H7~xe9Fz6(k*e30xD{C8jvl{Q1D5^tY#`m0D-?C%jrxsB-xSk&^+TWb270h zap_96o2)9UGWeVFcz%<#Nf**;91nhhr7vV4Mx-&B7c>$W5+1HqXI^F!mYPDwfSy6H zp|WSgXdBD&m*CiCs@>v^Hz$X&n5z8gB`gQ;M@9h^twmL^H+Vz50;{zqeX%Mq$t%+K zFY2}euspFk7!^(mVDMT51HDA!7S zGSPD<`EI@xiJE^$QumJL=IxqCLr9*Y6oYCP$>=~C<}rWvV%Bolq^ds zoc#6z`!Z>sy%$_+XpcL;sUXYr*ER8W5XMmZR)Jgt=qXTH0c{OsEm+qTK?(YU)Dvse zZwMW*32!HnWgyU8a7Ak3O2E(H;}i!^BMz`mtW6on^pN0S59{t)t{uIjr$-c3Jbn}; zL-cB8cECvI58PoYrmOA~b{n!FM`ELa+!_X)`m9Lh>;%YzuMU!nCK2(B=bD}B4-u&G zTE&5P3A0S|X^3cnJj|QyB|=UnFfvAj=y9PD$k=A(OF08Oqnd&=J-}yScR49)tgCYW zcD_1IFg2^x8EQQtnL-#~K)7{`dq8-pKo_LCqFpqA#kEl#Q*K?W-H3RRE_!pcrPiUQ zx>v>!Vb#~)NUe2!S0=G%UilXp4ZSDf#!?K+iGG=XdoKgWAv`AdGa;u9ki=Nsmkew} z2vxuwA-@+fQ=M5xG3tEQgU}UQA7nhNw{C%587U+`e-yzP*(G~MYasL3ZG|RperM-) zDaKXn-t?(d8G3s%n^X(IfacjGW`eaEs!ka{VI+=QrIIaao0_W8C8YKU?P1`xR-8>c zO@;MH4f5qL;63#<#zEP@_!hbCs1yrep$IKY>FA`y4?d%-c#v zaH?+Lja0^xIIrgEZ%s(U@&oP1RbKViE@wMes3URr8y;>kaTp)J>TwB@<@r?d+mPS; ztbeY)EZIsImicw_LqU-iUQhTeU8K6*-%3M!|C7U`E$cDkd2@(n+byTjVAi>t(=_0L zte8M~XCJ-?#T^n&B77=T{g^N28+|dWgX{=4=XARba=!P*wEY4Um)Z-cs~LtuU2d$Y z91Z?^c{w#+W-Hl)B#rNHIkK@?g$&P5)mv`f;4meU7bA#-0;^j(YSg&rZIs8fY}o-p zPIl|Z)DH{68l$(KS!@JwHr{q7seX@SOa##~U{DsOm8u*A-Xz)n^u6CT*JeSQc-Cfz zoJio&G@48Z4kTSQfU+j~b|E%5vC$(tfs)@XhTl^8ERhgEgBIDmRm}IY`Q2|}CdH#~ z*OoH4bhM61UeI$hYL8vQh3%3zi7J?aA|b0M+Ez48Z*5K&rePyG97n!b=vs3)xzr^Z zzJ+aQxk@YyF`+v(pbi2zpMqkAZM3PDOftWtx)y6R*B3g^x#&EdalA>(iA+$UC+_ zH?~Lc9_)krs3R(bS_8Rn#;5cNnG)}P4@>*-nP_L5?^sGQK_{eQdHNYy-V)2XUxmTC zJTh6Wn(RdBX;|FPxgH~@TZJWh35=^;Zi9uEfS@X$J6R@B{yX)X^g5cZyG~KvxRK97 zb+r*N2U>KXzQWNEFOw&>e4C5v-=E_?@j0Dj6Q5}KdvtDkag*D7dBFxm&X#foxxR;$!XmuRBUNCP<3a-A3b@*X4i+kg>5sWG`>d4zR zIe~(s&d}ZFc6%=smmupoQ2h0KHR~)>618pip-d-!H))(wkpOp~8*B_o8pPa-XqXPO zR1>1*N?pZI4EfQg<2A`EX6@=!MoMIEM#(^1+eEo#4I<{j5#*2$!)3oRbA3~>ehqOs zvsxip!8fdUHH|`$G-4Oe_Ip_fxG)8p1 zgjL3Q$!IwIh82ePuE#@;P`DgQJa}9S1fI!H>!fvIu7rpUaD9%ZSLF|^(o?=MHHyx&o zJcC6>mdThH*{r9JLFQB7KmGOglXUJ}yo|mq&Lk+q-1^5QQhPHejf*X0S*0vuAO?Qg@n#uryn(E_+cnJOEq zloeZJEcLPM5>4Q1SBP84BAPad_QAJozQb@MmzpMGvEW<$4B1Hwq`|Lo!Om3=s`_sE zd7d|*={vRIq~{e(Adc4AyZm+{RBM0(A$qn=eb9iu8-j?<)Q=|38Gq~N+h*=881boP zi)j=1x|Q@6u<~^Kwd(;U^Skzgx@m}&kT#1P1LAuORJW>pghhfpPO*r5yS#1;`_@J; z{hPv*Y_{P7VvWY}l?oxp=O*(4R_6pcf!ATGcb0K77>aq@_^E2>d+7Lo%aiQMyILjw3xKNYXOM>n_g{ee1 z)QPY}p*mU~{W$yc`^o!IY|yeW_+>zHG(sm=S$nbLcE6t$K0ZE@%wbLOuv>?LDd26uvUAQZ$mHVn z=3BUl_}zQ9Sg?!W#SiDFj0=GDT>Lt`;labaL2fiP?wV2!eN703$Ocz=#3!VmNTPEL87cwf>l+vJYz5xzTD`FR6e|*)+@Y&r2s6 zMiw#OBX6fos`4AF;TDn*%?^?M(IfN8^|qRU$qv5ozoBo9LC|FnOL&a_Jt};T)@&a^ zmNgy_M5qvysO|UzsFtnqC5%O8`mjZHCP6=Ws2OVMWZ8(8oani^KIq)CMBdO|^v1U^ zI)sIZ>uoM`0hw87^fPzXH7rausOPhh1t4F(iTg%bY$yb@q-U|T`mFbpVb^!?d;~2d z!}>HbFR97_pOWz=Rl-;YBv&GN1EG#k+Uu}fPgp`Z0SSoaoCsuvi!olpJW^}FI+gcA;>PHc9gXqdZ~ybhAX@lvYC{upyLV!(l$wWw!*zqV37 z`Iy%Yc#gfl6@-lC@eP2EJKm?y`YJhL-24c)&}vXT_j{yq6(^TmG=1}36*#02MF|R% zH)bTXr2}(5R!vV?ZJ|-@y6a;6fbXEcy3NB?QhJo@1S=n7o7dt;g8GK`H2RMhjUu$| zQOzC`cZ903G6#HVK%jz|4Z*pSDZ#?_?k{QYboYs*9{g+HI_%e;o6#EuCFJKLV+RL8yrX8OoE5Y^44v=r za%w*RaadFX@o;c`X)^FVjS>J<=Dt=ok5JW|f#{8V?sM}yG_D{NZ_|gq`^mrdK$y1tt-yc7jw(IQQyHHnkT-&~UJfY&j zW;M3F?bHFbs7D~VHl1d*!RlS&8;eT+j=X<$94?u-BW?ND1hYah|rllm|hh!^I=dtAYupEaMjZ>#}}L@RJ;he z$uA4z;n~sH^iY0}TI-`G2`zvmQCZjKl20uWDn4%BR2MIQ5*Yot-BUp)qo8#4j!|x8 zkU^tQ_8mjHI{PSxrV8zV!iaCV{5fJ>U-=T|KLTl$D8`6?*W8qTJ}jZ-x*X zy9;x>NjtdaxF2%!5@&y>#`@n3TkW`LEsCHVHa%p&lfeGTi{xZsZez~!=krfWq(kkY zFhXvuR@{4GBuCfBw;NGZ%c~dsoEnQqZyi|EZ%yP`cY2D1vyOmx%tPBn+$LF3#YU3=45y2WWVZ&3*Wqf=r;Xuy|a*a5+Ab?No9E#=yAH? zzQokEz31^;p$_kr>7e|E(@R7gu$+v;@Li=Ck23bwz~4mK!;77q@(?*e&d1|tlhPVn zj2Ln_?TThWIaOBqMrVasaNw@WF){i4xp4*?Kgqhs_zf)vhPTBX)zc1cEep<=2DQW% zjJCLK<_mkhf{~}znB)0gyVW=uT!4c4Q7M-BBW>xm1Z0%tPSe9FF%A~mc^B9@BM3F&nPrN962;b0~c%TTv- zM*he^x%SdpSwa?A_k}sI+RC+l9^0&AHxhFhDL}M2mTm+Pja+!BqN<=p!M&vue#|Ze z<_n?nMs~fw8%b#tuA(lCmUp#lfocK{!|n?PwNafK9kQJIZK;soa~@@A4J&(Yg1%9R z7NN?un@Lx{Ld_#X<`g#>ONOAw^XcA2P^+NNM&zJl!r5L;q)$6v94GV^j(+y<6nIc2D)VX9nNJ(9ScNSJl5FK4z9H0=wDa$kbd{nTseh-$o9_ z2+8AVA6IQH7Y`>cY!naPnh|7QS11d)JVq-G2%ex42O3eSFjtA21pn$VC;L2qKD2C8 z+L>=XCFp5JX$(3KR`1}STRp!lm;r|>yb^40iCe*-L+LK=O&LGS zZ}SCR5s0=TAZ?&Lkmz@D#mWPB$LquJIAR1{W+RjZ9Oo5c`?|cTQOG4@TmxirJ)`FM zB?QHZlq=X4YvF4;p59Z`L2p{6#M1=dn-3G0H-&#~CdGB~FAFoD7pR%79tz>$=ezis zFyDx$>J;9C=TR%EhP0c+$66M|MTZk>v&9Di&8R%Ws*v3}bg9te74@vGg z$DaE34BmE?y+(%1f=4Y-_?}kyWY@LVLudeNe*xn!a0p1aOa8&w&w3K+g*qRP<5Oo- zxlkdoq%@i_<2EC@M?xxS9$g1WT)`b-prdrp9^&~@Y0Y;e{3_vZNExl&Eix9{>|=`@ zr$4DX8cf~3JQTd2Fc2y=AGZE_q0@79eI;u3waL?OfcoToH$$nZe2arT{`ePkccYlA z7gW<&I4o=a0-%AW-U@t};x^@NGUH-ACDVojwJ;6)eAFnCj=1?!TUw~Xm6{s|b*5=< zkTV1Jx6$GU#S6EnhzZ3H^+gRSKM|p0@7(D0BE*yA@^*CuPnL@(54?BPT(y&6Xy+#I zj1}G!0-W&xhA3iK1|L2f%zf1wbJ7}9-cQQXk#g8VV70-#@m$6aIO zA4+`C?rHcMG|8@1Z&FVP&HC#K)}&l8EQii&GqcVT(!ji0@)DWb#Qs<{Tr+wqelpMHAB5 zND*NmO?5zX;_q`~Z>O~UvV;f7P$czRQ!TN7F6dq%E_yRZ)X_{D5!DRIx5JH|tEI)l z02>+N8x{cEA7b-MEyIr4x^rDO8nBpY3LWQ-kEG-aQ+CNtHp}RE8&Wbjro=#sr!<$+ zo^`-1kX!(H-K@04O*%E;2xGbZA+MW$f6^&#FNl8=x$snDh@_CB&A8NTN`I79>KE`8sWb5K^OHHrb~p-ddygXESOvbX7Nmu0R?HbaoaPHODAqkec3&zRBN8}m zrbI@WpR!dx;6|th*6PApQJH(^Xy?Nw$nodb5UI(Rdeg|^F$bY$CN2gC8%^iO~zmu!JV7tJI888Lz`Nd4`R7l9oCkm>!o>+NRgc2(Mx)Tr zXk#T5-PGmzmm=NRzD>|O^l&^xPM?Pr?$5ejmJx{R?Cqdp?g~*qg!d&^5*6wVr#A{f zISBHCT*G$KL7ljJ>h!SL6$*`OhaQI>oJiopcDk-7kygz>(BLPtx^>@ZRpdTx93S?( z|D@y4Fdd5UO%4^PBf>|8xxVcBa&wRGqDxtw5a?8^{$-8$j)EvDy3crSl{lbYb85^>k(e%Qc$gfH-H8vpz921bcSDZ z)fnpr9icc}g6=t3Ql&iTXEJihr%rOGF>;D4{1ZwbMf_^i>Q~^#KB^A*`>Bj6R4;{{ zABr=$KWImxunYGzK#yn`e;GL#DO%UX|JKxUp6)^{0XpVi$sOzJH7ahbJgry_tNHTb zc4ugP;^QaPu69m6g@ChQs&+kFR+!2Y;yQFL!J)icQP5il~y7YD*!R zs`>#dgPAddXR#EX#%s|(H6QeUfLZpLlC2a*-OMyfLo-H7;c^(4mh|mg*x4afiu}U3 zvBLQJt!mr2W791O6fvg(WfkYOnzrjR2|tO&V_jt(kT?PTu#oCwtD0{R=mQ@Q-$GYLc+PcXNnKq@NAh4e;iVI!6Y0^U5~ zb$WNrl}Ez=j27CSlMVUA+J6^DI9gO-Wpi!_Tg9SSeZsiur5V5{sG|LR80keSV4KrA zEOS2cS(Z22NGMx|w@>ou+}A|(!1X%A+6x6L&t~w~#Wnmt&A_(ddyR3>$jd+#Dro+i z0eg@pIGF=g&7GWns|3rdV>V_JOIx6sjB(!w850?EWg|Evdt-Z3GGx{Y*2*R0x(_O(AK7=d#+-0ngvZR@JR3ga($`aXkv+*2a(4w4}Xq~saR*?Pz zog{S1?P8piZ`wS;ozcvUz>MK$+sZ!UC)u#VLsEl(!Lxh+1?dA$6N;l_>PrZAK1A-m zFxvV#<&_t=)w&S^xXOkX*kD_UB6DP>9@04jI}EQ7o|e@c z_Dyj4pAtrMG3+Tk()Mt^gJQgqYhqJF00UbS0Ruz(Yg$Z=KbneL7+c!@_8U%m z3$}XPNS-XCK3az!8&k`*!Er&8+%nRiEQQ;W@`7`H1o_SUWzCiWh-9-~%Dedb0!?A$y|)IRLYOq>Cq zN6rLZ9`|;>2?;F<3wwTQ^5Gj&=-l(<_3`w1IXmd?zFRxH1^PUn-fy^7fUX$suYoVN zFAvvG>yH~pZZAiVZUQZ>0)~vZVMpCzbjd#Vx2ztGX+BGXAC$H`J+B{Ed|0H;T(DAO zLfmF>Q(IpcETu{B*Uj8KI^#Z#C9ni~Qf*q3yA~Cv%KE;8u)(m8Yiq=EOM*C2S=C2q zlJ|3^J7tDm{{F8bx7wS`_TZfpG0 zsJOZW-^B0dN^^P)wVdA8sG1bh)`;om3UOkvx`f!|;pfV7dJMhX+}4QecC&wt?REok zBDyLF*97Z#Lv~66wH(mqf#!w^Y8*rE=f+yoqU|YHjyKKX=@pBK3^XA|l;p<=b!Egl z)1uu>v7+0QC09cDq|z5B#tffirWXsO8&1I5lM8jGl5C7!*Ox^v%}v%+nPi|lPQbd8 z3-zLsY>izvltnMg#nV#3Vx&V!#DbR(4WyFnj9oXDMK8}y)>2Vpq+?FR!j}(?ppxv3 zT{o3QugJyIR*7e%Q%uC7lMhXZX!KM-FYV#@fc1z2t+^4x7FieRpGsR7;onGG7wWAi z-Tn@1QL3HT7+;D0h7;k-^PVea?~+uzK9*iYZ_7gHUw!#8!hc-nUveSXX0P%glw_~U zKW5hZj3?bjghpADV6!t>J)%_GWlBNLl@5cRrGNw|Kgn6q^jr;YU<;J&h)_N<+rAy^ zqRj`WULCZIafZW4;Q}9ts3P;dyrbJ8bP#h{5v;yxVr8*DAV#vJMiEg#mkQX}^PIIU z#^i*@&W~+7QCWnMb3{MOE#ugyWir9+uTrk*E($>g0|+UYdl$VIKYUQe>#viLaoxVY z({kbal7RaVCZ!>|Rl&i#dl>X7D@MJn?eGm6UpIAbj5=E1;UhYq;PwKZy;z7$-Vw#D z19U6~0WNbyG9VF+iq*GTyMG22^cScG2b6b5CVQrj> z9%L+X_~D3}1TXc3hKCdfvY76_wT}eUxTPdT)_7-Y_Qz2anJGb>nr~FAMALqr3Ip&( z*X+BX)0p780l}3laHF67<8!ZuI51|U?hAK#@iywM8!2UUvGJ9zKlirs%nkK<`D63# z@Xz1Zj<520rOT>F4krk1b?{wUYJdimYdu%_cK2|FdTxT-O>t3f(;FY(pwX3&FN83p zsvItTE>4OpJKevF{Z>5u7stCU*~!EhCm5Tq62AH1cJf-AoZ;fzpIf}eltl6z8F>9eqx`TAU@6;AOJLMSVtRv>h z4^kt01d>El=i3u<7v<;b5ZHMCn>ZI_*$>yS*eh9XvX+2}KEF2!mzn~zP);$0ShWW< zkg^4*Odb))){=U|2aeB7%H@bHVw*i|!`UMFcLl~X^}F>wOPWRGsCfu5xXl-qmF;|z1hgjTah z`(wXH$f%(O;75X6TH70#il38ni(OOv|&9S;cMV`>UB3&J(6-BN%FDZ_KeMDW>Lhk@`hry@n(b9!xf^1 z-5fT%GAnk;-yrC^(XABnaqWXSOH%EDl4GT-%xda5iA1f$gQUfA+kBsiq>|KWge~$( z&*_zu(xUEIKVY;UT_frmMH_$g2>o=tnetw&;wG?7siAw65@Xu$T3lWLIi=u>xaUKC7H_%C6{;d^X`wC3?4Z2ZB~h*ZW%Uh*T}rPj z328-9X~hHHy}{)iNCt|VA2D+eZmUY3x+J3q6UT5TSAO~p{1V@ksgz)xP@oyGrp#(X zOLF{6a>~ARwKSo^Ye}eie2DF39V)iPHND4(K-4C|M}_ENhO z;cbzhe;7sx+fWCeu|zZmPPo{_J)G2uOEZKO;mn@wSFGnw%2R<@5(5;lZ2S5PtpJgB zlmqYQHq;4&)pf_L9!F(f|gWg>~qd(1pornSdq5WMQwmwN;Zw3 z#FguXn!x)rt&4aJ(%?STniBf$Q}ABQsTX9Am5K0SfWiqUv^})Xc-Z_nK~>ti+INb^ zw=jw%pqMO$kPOVZqduv~RXif=OXN2xkJ^OYVaL%W+P7<*0HAg&; zn{p~~`#kgmzE&N7kxxT--o|NWQX=ro(e+H8aB^hevy+;PT)*dU2&S=~_X*-s^^Ad6 z#c%G31KVzVS4FRjss8f4{l4rr6vJj{8y=3=DnwNhz9h;uU?*7^fo?!aUL^*PnZsv;0wiZJ*T&_Jd5s9x91qe;M=Az zfkTOrwNxR46W(LJd0|NwkH!_g*#iOF&WCt_3+{l+oH>zLuM;KT!PG_bQ_ZcmuOAe2(gwQcwo542>5#eYu|d`RGHXoxKhYb9)79tgUl^ z-!gjY)RCQggR{dXv5gShb)_D$+6A`Kvl?LCirz)JCWlNONth0)ZhNfLpw-Y0-bgI1 zTmsjnC?@i6Np6r=U2!sf7v)*+-b(d7$ZYtMT7(l6?vl*DO>MsGGTS#h#Ya#z)UvobVZ<+Gs3WK={{J zY6W~ZPPqUF?Af-sTq*@zi=8xTJlz^dQJYQT@i0PjC}(f$8ZFgp#aiD9o(yB~NZ>y0 zv2PYh$gc0^M~Qt@)f=#3)=4rEzOXpj_7wwIsaau`%YiOB`WdU0Jv7&W?T={EH_IA1 z<(4V={r7l6KK_Q9s7hW_WwA>|c$w@w;jEC8bgCusmKGl9i>aYoZWK=9ML(Sxgiqc< zKjuAc2~G*tma?_^!3yEwTM;EB9bVfuOPCYKYzwEt8-V|)AmuX`Y+``0TiPSg%W z9|oR4UXvm%Ve-x?Bl#6&%kW>88H2~Ve0Y~5C&8< z2yzP@kY$Bsp%t1lv%_&EG7}-5Io&qgQn0_ll-n@%71IOjE`GihJyQ8d9s@bZLt#X2 zmF+@FHBUegAfE`ypso->ZaV?!DFEUe=Lo((jVP57lHr&O6vdlY!Bv?doF5>tAG-Jb}9kKx#D8tD16rs}%~WCyqSaB5=3_ zvrZnOfqGYi#u0Zxyt+EBYj8?9#F=1NX_8avYL1X+NdeYykcVyA(H**@R>|GS4)gZ= zq4pJOdx`u@GbkBwVqaTfgN+xs;Wou&6ic@of+}!(mP5j!wDyv2@%2bhPV^) znre7yT0_B;z~?}Ls8&CNCB_RSUc={)d7BFXGkk9`Wv*~^bhENF0mzg-JN`cUKhOYZI{*Lx literal 0 HcmV?d00001 diff --git a/autotest/ex-gwf-vsc03_sfr.py b/autotest/ex-gwf-vsc03_sfr.py index d1bac18c3bb..092f383ad71 100644 --- a/autotest/ex-gwf-vsc03_sfr.py +++ b/autotest/ex-gwf-vsc03_sfr.py @@ -172,7 +172,7 @@ def build_model(idx, sim_folder='vsc_wSFR'): gwf, viscref=viscref, viscosity_filerecord=vsc_filerecord, - viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], + viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.15)], nviscspecies=len(vsc_pd), packagedata=vsc_pd, pname='vsc', diff --git a/autotest/ex-gwf_vsc04_lak.py b/autotest/ex-gwf_vsc04_lak.py new file mode 100644 index 00000000000..5a7a9364a6c --- /dev/null +++ b/autotest/ex-gwf_vsc04_lak.py @@ -0,0 +1,568 @@ +# Simple single lake model. Lake cut into top two layers. Model +# is loosely based on one of the MT3D-USGS test problems. This test +# developed to isolate lake-aquifer interaction; no SFR or other advanced +# packages. Problem set up to have groundwater pass through the lake: +# gw inflow on the left side, gw outflow on the right side of the lake. + + +import os +import sys + +import numpy as np +import pytest + +try: + import flopy +except: + msg = "Error. FloPy package is not available.\n" + msg += "Try installing using the following command:\n" + msg += " pip install flopy" + raise Exception(msg) + +from framework import testing_framework +from simulation import Simulation +import config + +ex = ["vsc-lak01"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", "examples", s)) + +# Model units +length_units = "m" +time_units = "days" + +# model domain and grid definition +delr = [ + 76.2, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 152.4, + 152.4, + 152.4, + 152.4, + 152.4, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 76.2 +] + +delc = [ + 76.2, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 152.4, + 152.4, + 152.4, + 152.4, + 152.4, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 76.2 +] + +fixedstrthds = [ + 35.052, + 34.9267, + 34.7216, + 34.5062, + 34.2755, + 34.0237, + 33.8143, + 33.6657, + 33.5077, + 33.3394, + 33.1599, + 32.8728, + 32.4431, + 31.9632, + 31.4353, + 30.8627, + 30.48 +] + +nrow = len(delc) +ncol = len(delr) +top = np.ones((nrow, ncol)) * 35.6616 +bot1 = np.ones_like(top) * 32.6136 +bot2 = np.ones_like(top) * 29.5656 +bot3 = np.ones_like(top) * 26.5176 +bot4 = np.ones_like(top) * 23.4696 +bot5 = np.ones_like(top) * 20.4216 +botm = np.array([bot1, bot2, bot3, bot4, bot5]) +nlay = botm.shape[0] +ibound = np.ones_like(botm) + +# deactive gw cells where lake cells are active +ibound[0, 6:11, 6:11] = 0 # layer 1 +ibound[1, 7:10, 7:10] = 0 # layer 2 + +strthd = np.zeros_like(ibound) +for j in np.arange(ncol): + strthd[:, :, j] = fixedstrthds[j] + +# setup lake array +lakibnd = np.zeros_like(ibound) +lakibnd[0] = 1 - ibound[0] # layer 1 +lakibnd[1] = 1 - ibound[1] # layer 2 + +# NPF parameters +k11 = 9.144 # = 30 ft/day +k33 = 0.9144 # = 30 ft/day +ss = 3e-4 +sy = 0.20 +hani = 1 +laytyp = 1 + +# Package boundary conditions +chdl = 35.052 +chdr = 30.48 +viscref = 8.904e-4 + +# time params +transient = {0: True} +nstp = [100] +tsmult = [1.02] +perlen = [5000] + +# solver params +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-3, 1e-4, 0.97 + +# Transport related parameters +al = 1 # longitudinal dispersivity ($m$) +ath1 = al # horizontal transverse dispersivity +atv = al # vertical transverse dispersivity +mixelm = 0 # Upstream vs TVD (Upstream selected) +initial_temperature = 35.0 # Initial temperature (unitless) +porosity = 0.20 # porosity (unitless) +K_therm = 2.0 # Thermal conductivity # ($W/m/C$) +rho_water = 1000 # Density of water ($kg/m^3$) +rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) +C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) +C_s = 880 # Heat capacity of the solids ($J/kg/C$) +D_m = K_therm / (porosity * rho_water * C_p_w) +rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) +K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) +leftTemp = 30.0 # Temperature of inflow from left constant head ($C$) + +# Viscosity related parameters +tviscref = 20.0 + +# MODFLOW 6 flopy GWF & GWT simulation object (sim) is returned +# +def build_model(idx, sim_folder='vsc_wLAK'): + print("Building model...{}".format(sim_folder)) + + # generate names for each model + name = "vsc" + gwfname = "gwf-" + name + str(idx) + "-lak" + gwtname = "gwt-" + name + str(idx) + "-lak" + + sim_ws = os.path.join(exdirs[0], sim_folder) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe + ) + + tdis_rc = [] + for i in range(len(nstp)): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + flopy.mf6.ModflowTdis( + sim, nper=len(nstp), perioddata=tdis_rc, time_units=time_units + ) + + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + newtonoptions="newton" + ) + + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="cooley", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(ims, [gwfname]) + + # Instantiate discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=ibound, + filename='{}.dis'.format(gwfname) + ) + + # Instantiate node property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=1, # >0 means saturated thickness varies with computed head + k=k11, + k33=k33 + ) + + # Instantiate storage package + flopy.mf6.ModflowGwfsto( + gwf, + save_flows=False, + iconvert=laytyp, + ss=ss, + sy=sy, + transient=transient + ) + + # Instantiate initial conditions package + flopy.mf6.ModflowGwfic( + gwf, + strt=strthd + ) + + # Instantiate viscosity package + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, tviscref, gwtname, "TEMPERATURE")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=viscref, + viscosity_filerecord=vsc_filerecord, + viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.15)], + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname='vsc', + filename="{}.vsc".format(gwfname) + ) + + # Instantiate output control package + flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{gwfname}.cbc", + head_filerecord=f"{gwfname}.hds", + headprintrecord=[("COLUMNS", 17, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # Instantiate constant head package + # (for driving gw flow from left to right) + chdlistl = [] + chdlistr = [] + for k in np.arange(nlay): + for i in np.arange(nrow): + # left side + if botm[k, i, 0] <= chdl: + chdlistl.append([(k, i, 0), chdl, leftTemp]) + # right side + if botm[k, i, -1] <= chdr: + chdlistr.append([(k, i, ncol - 1), chdr, 10.0]) + + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chdlistl, + print_input=True, + print_flows=True, + save_flows=False, + pname="CHD-L", + auxiliary="TEMPERATURE", + filename=f"{gwfname}.left.chd", + ) + + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chdlistr, + print_input=True, + print_flows=True, + save_flows=False, + pname="CHD-R", + auxiliary="TEMPERATURE", + filename=f"{gwfname}.right.chd", + ) + + # Instantiate lake package + + lakeconnectiondata = [] + nlakecon = [0] # Expand this to [0, 0, ...] for each additional lake + ilakconn = -1 + lak_leakance = 0.1 + for k in [0, 1]: + for i in range(nrow): + for j in range(ncol): + if lakibnd[k, i, j] == 0: + continue + else: + ilak = int(lakibnd[k, i, j] - 1) + # back + if i > 0: + if lakibnd[k, i - 1, j] == 0 and ibound[k, i - 1, j] == 1: + ilakconn += 1 + # by setting belev==telev, MF6 will automatically re-assign elevations based on cell dimensions + # + h = [ilak, ilakconn, (k, i - 1, j), 'horizontal', lak_leakance, 0.0, 0.0, delc[i] / 2., delr[j]] + lakeconnectiondata.append(h) + + # left + if j > 0: + if lakibnd[k, i, j - 1] == 0 and ibound[k, i, j - 1] == 1: + ilakconn += 1 + h = [ilak, ilakconn, (k, i, j - 1), 'horizontal', lak_leakance, 0.0, 0.0, delr[j] / 2., delc[i]] + lakeconnectiondata.append(h) + + # right + if j < ncol - 1: + if lakibnd[k, i, j + 1] == 0 and ibound[k, i, j + 1] == 1: + ilakconn += 1 + h = [ilak, ilakconn, (k, i, j + 1), 'horizontal', lak_leakance, 0.0, 0.0, delr[j] / 2., delc[i]] + lakeconnectiondata.append(h) + + # front + if i < nrow - 1: + if lakibnd[k, i + 1, j] == 0 and ibound[k, i + 1, j] == 1: + ilakconn += 1 + h = [ilak, ilakconn, (k, i + 1, j), 'horizontal', lak_leakance, 0.0, 0.0, delc[i] / 2., delr[j]] + lakeconnectiondata.append(h) + + # vertical + if lakibnd[k, i, j] == 1 and ibound[k + 1, i, j] == 1: + ilakconn += 1 + v = [ilak, ilakconn, (k + 1, i, j), 'vertical', lak_leakance, 0.0, 0.0, 0.0, 0.0] + lakeconnectiondata.append(v) + + strtStg = 33.75 + lakpackagedata = [[0, strtStg, len(lakeconnectiondata), 4.0, 'lake1']] + lak_pkdat_dict = {'filename': "lak_pakdata.in", 'data': lakpackagedata} + + lakeperioddata = {0: [(0, 'STATUS', 'CONSTANT'), #RAINFALL 0.005 & 0.00504739035 + (0, 'STAGE', 33.5)]} + + lak_obs = {'{}.lakeobs'.format(gwfname): [('lakestage', 'stage', 'lake1'), + ('gwexchng', 'lak', 'lake1')]} + lak = flopy.mf6.ModflowGwflak( + gwf, + auxiliary="TEMPERATURE", + time_conversion=86400.0, + print_stage=True, + print_flows=True, + budget_filerecord=gwfname + '.lak.bud', + length_conversion=1.0, + mover=False, + pname='LAK-1', + boundnames=True, + nlakes=len(lakpackagedata), + noutlets=0, + packagedata=lak_pkdat_dict, + connectiondata=lakeconnectiondata, + perioddata=lakeperioddata, + observations=lak_obs, + filename='{}.lak'.format(gwfname) + ) + + # pull in th etabfile defining the lake stage, vol, & surface area + fname = os.path.join('data', 'vsc04-laktab', 'stg-vol-surfarea.csv') + tabinput = [] + with open(fname, 'r') as f: + # peel off the hdr line + hdr = next(f) + for line in f: + m_arr = line.strip().split(',') + # , , , + tabinput.append([float(m_arr[0]), m_arr[1], m_arr[2]]) + + tab6_filename = '{}.laktab'.format(gwfname) + flopy.mf6.ModflowUtllaktab( + gwf, + nrow=len(tabinput), + ncol=3, + table=tabinput, + filename=tab6_filename, + pname='LAK_tab', + parent_file=lak + ) + + # create gwt model + # ---------------- + gwt = flopy.mf6.ModflowGwt( + sim, + modelname=gwtname, + model_nam_file='{}.nam'.format(gwtname) + ) + gwt.name_file.save_flows = True + + imsgwt = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename=f"{gwtname}.ims", + ) + sim.register_ims_package(imsgwt, [gwt.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwtdis( + gwt, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=ibound, + filename='{}.dis'.format(gwtname) + ) + + # Instantiating MODFLOW 6 transport initial concentrations + strtconc = leftTemp + flopy.mf6.ModflowGwtic( + gwt, + strt=strtconc, + filename='{}.ic'.format(gwtname) + ) + + # Instantiate mobile storage and transfer package + sto = flopy.mf6.ModflowGwtmst( + gwt, porosity=porosity, filename=f"{gwtname}.sto" + ) + + # Instantiating MODFLOW 6 transport advection package + if mixelm == 0: + scheme = 'UPSTREAM' + elif mixelm == -1: + scheme = 'TVD' + else: + raise Exception() + flopy.mf6.ModflowGwtadv(gwt, + scheme=scheme, + filename='{}.adv'.format(gwtname) + ) + + # Instantiate dispersion package + flopy.mf6.ModflowGwtdsp( + gwt, + alh=al, + ath1=ath1, + atv=atv, + filename='{}.dsp'.format(gwtname) + ) + + # Instantiate source/sink mixing package + sourcerecarray = [ + ("CHD-L", "AUX", "TEMPERATURE"), + ("CHD-R", "AUX", "TEMPERATURE"), + ] + flopy.mf6.ModflowGwtssm( + gwt, + sources=sourcerecarray, + filename=f"{gwtname}.ssm" + ) + + # Instantiating MODFLOW 6 transport output control package + flopy.mf6.ModflowGwtoc( + gwt, + budget_filerecord='{}.cbc'.format(gwtname), + concentration_filerecord='{}.ucn'.format( + gwtname), + concentrationprintrecord=[ + ('COLUMNS', 17, 'WIDTH', 15, 'DIGITS', 6, 'GENERAL')], + saverecord=[('CONCENTRATION', 'ALL'), ('BUDGET', 'ALL')], + printrecord=[('CONCENTRATION', 'ALL'), ('BUDGET', 'ALL')], + filename='{}.oc'.format(gwtname) + ) + + # Instantiating MODFLOW 6 lake transport (lkt) package + lktpackagedata = [(0, 4., 'lake1')] + + lktperioddata = {0: [(0, 'STATUS', 'CONSTANT'), + (0, 'CONCENTRATION', 4.0)]} + + # note: for specifying lake number, use fortran indexing! + lkt_obs = {'{}.lakobs'.format(gwtname): [('resTemp', 'concentration', 1), + ('resGwMassExchng', 'lkt', 'lake1')]} + + flopy.mf6.ModflowGwtlkt( + gwt, # Set time_conversion for use with Manning's eqn. + flow_package_name='LAK-1', + flow_package_auxiliary_name='TEMPERATURE', + budget_filerecord=gwtname + '.lkt.bud', + boundnames=True, + save_flows=True, + print_input=True, + print_flows=False, + print_concentration=True, + packagedata=lktpackagedata, + lakeperioddata=lktperioddata, + observations=lkt_obs, + pname='LKT-1', + filename='{}.lkt'.format(gwtname) + ) + + # GWF GWT exchange + flopy.mf6.ModflowGwfgwt( + sim, + exgtype="GWF6-GWT6", + exgmnamea=gwfname, + exgmnameb=gwtname, + filename=f"{name}.gwfgwt", + ) + + return sim + + +def write_model(sim, silent=True): + if config.writeModel: + sim.write_simulation(silent=silent) + return + + +def scenario(idx, silent=True): + sim = build_model(idx) + write_model(sim, silent=silent) + + +# nosetest - exclude block from this nosetest to the next nosetest +def test_01(): + scenario(0, silent=False) + +# nosetest end + +if __name__ == "__main__": + + # ### MT3D-USGS LKT test problem adapted for testing vsc in/out of lake + scenario(0) + diff --git a/doc/MODFLOW6References.bib b/doc/MODFLOW6References.bib index 15ed2c4a54d..ebd845d7ab0 100644 --- a/doc/MODFLOW6References.bib +++ b/doc/MODFLOW6References.bib @@ -2908,3 +2908,13 @@ @book{hughes2004 Urldate = {September 27, 2022}, Year = {2004}, Bdsk-Url-1 = {https://pubs.er.usgs.gov/publication/ofr20041207}} + +@book{maidment1993, + Author = {Maidment, David R}, + Date-Added = {2022-10-11 15:42:15 -0400}, + Date-Modified = {2022-10-11 15:46:29 -0400}, + Isbn = {0-07-039732-5}, + Publisher = {McGraw-Hill}, + Address = {New York, USA}, + Title = {Handbook of Hydrology}, + Year = {1993}} diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index c683b1acba0..85c2eb7b288 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -358,6 +358,7 @@ subroutine lak_allocate_scalars(this) call mem_allocate(this%bditems, 'BDITEMS', this%memoryPath) call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%memoryPath) call mem_allocate(this%idense, 'IDENSE', this%memoryPath) + call mem_allocate(this%ivsc, 'IVSC', this%memoryPath) ! ! -- Set values this%iprhed = 0 @@ -380,6 +381,7 @@ subroutine lak_allocate_scalars(this) this%bditems = 11 this%cbcauxitems = 1 this%idense = 0 + this%ivsc = 0 ! ! -- return return @@ -2346,9 +2348,11 @@ subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) real(DP) :: botl real(DP) :: sat real(DP) :: wa + real(DP) :: vscratio ! -- formats ! ------------------------------------------------------------------------------ cond = DZERO + vscratio = DONE topl = this%telev(iconn) botl = this%belev(iconn) call this%lak_calculate_cond_head(iconn, stage, head, vv) @@ -2378,7 +2382,18 @@ subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond) end if sat = wa end if - cond = sat * this%satcond(iconn) + ! + ! -- account for viscosity effects (if vsc active) + if (this%ivsc == 1) then + ! flow from lake to aquifer + if (stage > head) then + vscratio = this%viscratios(1, iconn) + ! flow from aquifer to lake + else if (head > stage) then + vscratio = this%viscratios(2, iconn) + end if + end if + cond = sat * this%satcond(iconn) * vscratio ! ! -- return return @@ -6399,7 +6414,7 @@ subroutine lak_activate_viscosity(this) ! -- return return end subroutine lak_activate_viscosity - + subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, & botl, flow, gwfhcof, gwfrhs) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index 8cc6a6c1bb3..a516e572b03 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -304,6 +304,7 @@ subroutine maw_allocate_scalars(this) call mem_allocate(this%kappa, 'KAPPA', this%memoryPath) call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%memoryPath) call mem_allocate(this%idense, 'IDENSE', this%memoryPath) + call mem_allocate(this%ivsc, 'IVSC', this%memoryPath) ! ! -- Set values this%correct_flow = .FALSE. @@ -323,6 +324,7 @@ subroutine maw_allocate_scalars(this) this%kappa = DEM4 this%cbcauxitems = 1 this%idense = 0 + this%ivsc = 0 ! ! -- return return @@ -3041,6 +3043,7 @@ subroutine maw_da(this) call mem_deallocate(this%kappa) call mem_deallocate(this%cbcauxitems) call mem_deallocate(this%idense) + call mem_deallocate(this%ivsc) call mem_deallocate(this%viscratios) ! ! -- pointers to gwf variables @@ -3867,10 +3870,12 @@ subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & real(DP) :: hbar real(DP) :: drterm real(DP) :: dhbarterm + real(DP) :: vscratio ! ------------------------------------------------------------------------------ ! ! -- initialize terms cterm = DZERO + vscratio = DONE icflow = 0 if (present(term2)) then inewton = 1 @@ -3886,9 +3891,19 @@ subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & tmaw = this%topscrn(jpos) bmaw = this%botscrn(jpos) ! + ! -- if vsc active, select appropriate viscosity ratio + if (this%ivsc == 1) then + ! flow out of well (flow is negative) + if (flow < 0) then + vscratio = this%viscratios(1, igwfnode) + else if (flow > 0) then + vscratio = this%viscratios(2, igwfnode) + end if + end if + ! ! -- calculate saturation call this%maw_calculate_saturation(n, j, igwfnode, sat) - cmaw = this%satcond(jpos) * sat + cmaw = this%satcond(jpos) * vscratio * sat ! ! -- set upstream head, term, and term2 if returning newton terms if (inewton == 1) then @@ -3937,14 +3952,14 @@ subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & ! -- maw is upstream if (hmaw > hgwf) then hbar = sQuadratic0sp(hgwf, en, this%satomega) - term = drterm * this%satcond(jpos) * (hbar - hmaw) + term = drterm * this%satcond(jpos) * vscratio * (hbar - hmaw) dhbarterm = sQuadratic0spDerivative(hgwf, en, this%satomega) term2 = cmaw * (dhbarterm - DONE) ! ! -- gwf is upstream else hbar = sQuadratic0sp(hmaw, en, this%satomega) - term = -drterm * this%satcond(jpos) * (hgwf - hbar) + term = -drterm * this%satcond(jpos) * vscratio * (hgwf - hbar) dhbarterm = sQuadratic0spDerivative(hmaw, en, this%satomega) term2 = cmaw * (DONE - dhbarterm) end if @@ -3953,7 +3968,7 @@ subroutine maw_calculate_conn_terms(this, n, j, icflow, cmaw, cterm, term, & ! ! -- flow is not corrected, so calculate term for newton formulation if (inewton /= 0) then - term = drterm * this%satcond(jpos) * (hgwf - hmaw) + term = drterm * this%satcond(jpos) * vscratio * (hgwf - hmaw) end if end if ! @@ -4174,20 +4189,32 @@ subroutine maw_calculate_qpot(this, n, qnet) real(DP) :: bmaw real(DP) :: htmp real(DP) :: hv + real(DP) :: vscratio ! -- format ! ------------------------------------------------------------------------------ ! ! -- initialize qnet and htmp qnet = DZERO + vscratio = DONE htmp = this%shutofflevel(n) ! + ! -- if vsc active, select appropriate viscosity ratio + if (this%ivsc == 1) then + ! flow out of well (flow is negative) + if (qnet < 0) then + vscratio = this%viscratios(1, igwfnode) + else if (qnet > 0) then + vscratio = this%viscratios(2, igwfnode) + end if + end if + ! ! -- calculate discharge to flowing wells if (this%iflowingwells > 0) then if (this%fwcond(n) > DZERO) then bt = this%fwelev(n) tp = bt + this%fwrlen(n) scale = sQSaturation(tp, bt, htmp) - cfw = scale * this%fwcond(n) + cfw = scale * this%fwcond(n) * this%viscratios(2, n) this%ifwdischarge(n) = 0 if (cfw > DZERO) then this%ifwdischarge(n) = 1 @@ -4212,7 +4239,7 @@ subroutine maw_calculate_qpot(this, n, qnet) jpos = this%get_jpos(n, j) igwfnode = this%get_gwfnode(n, j) call this%maw_calculate_saturation(n, j, igwfnode, sat) - cmaw = this%satcond(jpos) * sat + cmaw = this%satcond(jpos) * vscratio * sat hgwf = this%xnew(igwfnode) bmaw = this%botscrn(jpos) hv = htmp diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index 70287640526..c57182516ef 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -2480,7 +2480,7 @@ subroutine sfr_ot_dv(this, idvsave, idvprint) call this%stagetab%add_term(stage) call this%stagetab%add_term(depth) call this%stagetab%add_term(w) - call this%sfr_calc_cond(n, depth, cond) + call this%sfr_calc_cond(n, depth, cond, stage, hgwf) if (node > 0) then sbot = this%strtop(n) - this%bthick(n) if (hgwf < sbot) then @@ -3416,7 +3416,7 @@ subroutine sfr_solve(this, n, h, hcof, rhs, update) ! ! -- calculate reach conductance for a unit depth of water ! if equal to zero will skip iterations - call this%sfr_calc_cond(n, d1, cstr) + call this%sfr_calc_cond(n, d1, cstr, hsfr, hgwf) ! ! -- set flag to skip iterations isolve = 1 @@ -3979,10 +3979,7 @@ subroutine sfr_calc_qgwf(this, n, depth, hgwf, qgwf, gwfhcof, gwfrhs) ! -- calculate saturation call sChSmooth(depth, sat, derv) ! - ! -- calculate conductance - call this%sfr_calc_cond(n, depth, cond) - ! - ! -- calculate groundwater leakage + ! -- terms for calculating direction of gradient across streambed tp = this%strtop(n) bt = tp - this%bthick(n) hsfr = tp + depth @@ -3990,6 +3987,11 @@ subroutine sfr_calc_qgwf(this, n, depth, hgwf, qgwf, gwfhcof, gwfrhs) if (htmp < bt) then htmp = bt end if + ! + ! -- calculate conductance + call this%sfr_calc_cond(n, depth, cond, hsfr, htmp) + ! + ! -- calculate groundwater leakage qgwf = sat * cond * (htmp - hsfr) gwfrhs0 = -sat * cond * hsfr gwfhcof0 = -sat * cond @@ -4013,25 +4015,41 @@ end subroutine sfr_calc_qgwf !! Method to calculate the reach-aquifer conductance for a SFR package reach. !! !< - subroutine sfr_calc_cond(this, n, depth, cond) + subroutine sfr_calc_cond(this, n, depth, cond, hsfr, htmp) ! -- dummy variables class(SfrType) :: this !< SfrType object integer(I4B), intent(in) :: n !< reach number real(DP), intent(in) :: depth !< reach depth real(DP), intent(inout) :: cond !< reach-aquifer conductance + real(DP), intent(in), optional :: hsfr !< stream stage + real(DP), intent(in), optional :: htmp !< head in gw cell ! -- local variables integer(I4B) :: node real(DP) :: wp + real(DP) :: vscratio ! ! -- initialize conductance cond = DZERO ! + ! -- initial viscosity ratio to 1 + vscratio = DONE + ! ! -- calculate conductance if GWF cell is active node = this%igwfnode(n) if (node > 0) then if (this%ibound(node) > 0) then + ! + ! -- direction of gradient across streambed determines which vsc ratio + if (this%ivsc == 1) then + if (hsfr > htmp) then + ! strm stg > gw head + vscratio = this%viscratios(1, n) + else if (htmp > hsfr) then + vscratio = this%viscratios(2, n) + end if + end if wp = this%calc_perimeter_wet(n, depth) - cond = this%hk(n) * this%length(n) * wp / this%bthick(n) + cond = this%hk(n) * vscratio * this%length(n) * wp / this%bthick(n) end if end if ! diff --git a/src/Model/GroundWaterFlow/gwf3vsc8.f90 b/src/Model/GroundWaterFlow/gwf3vsc8.f90 index c78b13b29c3..f0bc248e7bc 100644 --- a/src/Model/GroundWaterFlow/gwf3vsc8.f90 +++ b/src/Model/GroundWaterFlow/gwf3vsc8.f90 @@ -474,6 +474,11 @@ subroutine vsc_ad_bnd(this, packobj, hnew) case ('LAK') ! ! -- lake + ! Update 'viscratios' internal to lak such that they are + ! automatically applied in the LAK calc_cond() routine + call vsc_ad_lak(packobj, this%visc, this%viscref, this%elev, locvisc, & + locconc, this%dviscdc, this%cviscref, this%ivisc, & + this%a2, this%a3, this%a4, this%ctemp) case ('SFR') ! ! -- streamflow routing @@ -613,7 +618,131 @@ subroutine vsc_ad_sfr(packobj, visc, viscref, elev, locvisc, locconc, & ! -- Return return end subroutine vsc_ad_sfr + + !> @brief Update lak-related viscosity ratios + !! + !! When the viscosity package is active, update the viscosity ratio that is + !! applied to the lakebed conductance calculated in the LAK package + !< + subroutine vsc_ad_lak(packobj, visc, viscref, elev, locvisc, locconc, & + dviscdc, cviscref, ivisc, a2, a3, a4, ctemp) + ! -- modules + use BndModule, only: BndType + use LakModule, only: LakType + class(BndType), pointer :: packobj + ! -- dummy + real(DP), intent(in) :: viscref + real(DP), intent(in) :: a2, a3, a4 + integer(I4B), intent(in) :: locvisc + integer(I4B), dimension(:), intent(in) :: locconc + integer(I4B), dimension(:), intent(in) :: ivisc + real(DP), dimension(:), intent(in) :: visc + real(DP), dimension(:), intent(in) :: elev + real(DP), dimension(:), intent(in) :: dviscdc + real(DP), dimension(:), intent(in) :: cviscref + real(DP), dimension(:), intent(inout) :: ctemp + ! -- local + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: visclak +! ------------------------------------------------------------------------------- + ! + ! -- update viscosity ratios for updating hyd. cond (and conductance) + select type (packobj) + type is (LakType) + do n = 1, packobj%nbound + ! + ! -- get gwf node number + node = packobj%nodelist(n) + ! + ! -- Check if boundary cell is active, cycle if not + if (packobj%ibound(node) <= 0) cycle + ! + ! -- + ! + ! -- calculate the viscosity associcated with the boundary + visclak = calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, & + cviscref, ctemp, ivisc, a2, a3, a4, & + packobj%auxvar) + ! + ! -- fill lak relative viscosity into column 1 of viscratios + packobj%viscratios(1, n) = calc_vsc_ratio(viscref, visclak) + ! + ! -- fill gwf relative viscosity into column 2 of viscratios + packobj%viscratios(2, n) = calc_vsc_ratio(viscref, visc(node)) + ! + ! -- fill gwf elevation into column 3 of viscratios + !packobj%viscratios(3, n) = elev(node) + ! + end do + end select + ! + ! -- Return + return + end subroutine vsc_ad_lak + !> @brief Update maw-related viscosity ratios + !! + !! When the viscosity package is active, update the viscosity ratio that is + !! applied to the conductance calculated in the MAW package + !< + subroutine vsc_ad_maw(packobj, visc, viscref, elev, locvisc, locconc, & + dviscdc, cviscref, ivisc, a2, a3, a4, ctemp) + ! -- modules + use BndModule, only: BndType + use MawModule, only: MawType + class(BndType), pointer :: packobj + ! -- dummy + real(DP), intent(in) :: viscref + real(DP), intent(in) :: a2, a3, a4 + integer(I4B), intent(in) :: locvisc + integer(I4B), dimension(:), intent(in) :: locconc + integer(I4B), dimension(:), intent(in) :: ivisc + real(DP), dimension(:), intent(in) :: visc + real(DP), dimension(:), intent(in) :: elev + real(DP), dimension(:), intent(in) :: dviscdc + real(DP), dimension(:), intent(in) :: cviscref + real(DP), dimension(:), intent(inout) :: ctemp + ! -- local + integer(I4B) :: n + integer(I4B) :: node + real(DP) :: viscmaw +! ------------------------------------------------------------------------------- + ! + ! -- update viscosity ratios for updating hyd. cond (and conductance) + select type (packobj) + type is (MawType) + do n = 1, packobj%nbound + ! + ! -- get gwf node number + node = packobj%nodelist(n) + ! + ! -- Check if boundary cell is active, cycle if not + if (packobj%ibound(node) <= 0) cycle + ! + ! -- + ! + ! -- calculate the viscosity associcated with the boundary + viscmaw = calc_bnd_viscosity(n, locvisc, locconc, viscref, dviscdc, & + cviscref, ctemp, ivisc, a2, a3, a4, & + packobj%auxvar) + ! + ! -- fill lak relative viscosity into column 1 of viscratios + packobj%viscratios(1, n) = calc_vsc_ratio(viscref, viscmaw) + ! + ! -- fill gwf relative viscosity into column 2 of viscratios + packobj%viscratios(2, n) = calc_vsc_ratio(viscref, visc(node)) + ! + ! -- fill gwf elevation into column 3 of viscratios + !packobj%viscratios(3, n) = elev(node) + ! + end do + end select + ! + ! -- Return + return + end subroutine vsc_ad_maw + !> @brief apply bnd viscosity to the conductance term !! !! When the viscosity package is active apply the viscosity ratio to the From 227da2e319caa35a26e0722e095c8046cacc67d4 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 12 Oct 2022 14:17:29 -0700 Subject: [PATCH 044/212] For some reason, this file wasn't in my fork (but should've been) --- src/Model/ModelUtilities/GwtAdvOptions.f90 | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 src/Model/ModelUtilities/GwtAdvOptions.f90 diff --git a/src/Model/ModelUtilities/GwtAdvOptions.f90 b/src/Model/ModelUtilities/GwtAdvOptions.f90 new file mode 100644 index 00000000000..4e724a745d0 --- /dev/null +++ b/src/Model/ModelUtilities/GwtAdvOptions.f90 @@ -0,0 +1,10 @@ +module GwtAdvOptionsModule + use KindModule, only: I4B + implicit none + private + + type, public :: GwtAdvOptionsType + integer(I4B) :: iAdvScheme !< the advection scheme: 0 = up, 1 = central, 2 = TVD + end type GwtAdvOptionsType + +end module GwtAdvOptionsModule From 5ca9daf6712362c64443e18d1f56afecc8c1600a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 12 Oct 2022 14:30:01 -0700 Subject: [PATCH 045/212] Need to restore a change that was lost during a merge conflict --- src/Model/Connection/GwfInterfaceModel.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index 63c8f28fb89..3156c851350 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -94,7 +94,7 @@ subroutine gwfifm_df(this) ! define NPF package call npfOptions%construct() call this%setNpfOptions(npfOptions) - call this%npf%npf_df(this%dis, this%xt3d, 0, npfOptions) + call this%npf%npf_df(this%dis, this%xt3d, 0, 0, npfOptions) call npfOptions%destroy() ! define BUY package From 933f3d47fbe322cbc1611983fdc35b599106bff8 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 12 Oct 2022 17:50:53 -0700 Subject: [PATCH 046/212] Resolving some more losses that were experienced in the last merge commit --- msvs/mf6core.vfproj | 39 +++++++---- src/Exchange/GwtGwtExchange.f90 | 6 +- src/Model/Connection/GwfInterfaceModel.f90 | 2 +- src/Model/GroundWaterFlow/gwf3npf8.f90 | 76 +++++++++++++++++++++- 4 files changed, 104 insertions(+), 19 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 91c9f7e40ad..1b58d04a4fa 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -14,7 +14,7 @@ - + @@ -48,6 +48,8 @@ + + @@ -61,6 +63,8 @@ + + @@ -73,6 +77,10 @@ + + + + @@ -101,42 +109,49 @@ + - - - - - + - - - - - + + + + + + + + + + + + - + + + + diff --git a/src/Exchange/GwtGwtExchange.f90 b/src/Exchange/GwtGwtExchange.f90 index b12e5c30c04..2ccbf24353c 100644 --- a/src/Exchange/GwtGwtExchange.f90 +++ b/src/Exchange/GwtGwtExchange.f90 @@ -22,7 +22,7 @@ module GwtGwtExchangeModule use DisConnExchangeModule, only: DisConnExchangeType use GwtModule, only: GwtModelType use DistributedModelModule, only: GetDistModelFromList - use GwtMvtModule, only: GwtMvtType + use TspMvtModule, only: TspMvtType use ObserveModule, only: ObserveType use ObsModule, only: ObsType use SimModule, only: count_errors, store_error, & @@ -65,7 +65,7 @@ module GwtGwtExchangeModule ! ! -- Mover transport package integer(I4B), pointer :: inmvt => null() !< unit number for mover transport (0 if off) - type(GwtMvtType), pointer :: mvt => null() !< water mover object + type(TspMvtType), pointer :: mvt => null() !< water mover object ! ! -- Observation package integer(I4B), pointer :: inobs => null() !< unit number for GWT-GWT observations @@ -935,7 +935,7 @@ end function parse_option !< subroutine read_mvt(this, iout) ! -- modules - use GwtMvtModule, only: mvt_cr + use TspMvtModule, only: mvt_cr ! -- dummy class(GwtExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: iout diff --git a/src/Model/Connection/GwfInterfaceModel.f90 b/src/Model/Connection/GwfInterfaceModel.f90 index 3156c851350..fb7aab8b5aa 100644 --- a/src/Model/Connection/GwfInterfaceModel.f90 +++ b/src/Model/Connection/GwfInterfaceModel.f90 @@ -119,7 +119,7 @@ end subroutine gwfifm_df subroutine gwfifm_ar(this) class(GwfInterfaceModelType) :: this !< the GWF interface model - call this%npf%npf_ar(this%ic, this%ibound, this%x) + call this%npf%npf_ar(this%ic, this%vsc, this%ibound, this%x) if (this%inbuy > 0) call this%buy%buy_ar(this%npf, this%ibound) end subroutine gwfifm_ar diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 886907e15f3..89112e8c77c 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -10,6 +10,7 @@ module GwfNpfModule use GwfNpfOptionsModule, only: GwfNpfOptionsType use BaseDisModule, only: DisBaseType use GwfIcModule, only: GwfIcType + use GwfVscModule, only: GwfVscType use Xt3dModule, only: Xt3dType use BlockParserModule, only: BlockParserType use InputOutputModule, only: GetUnit, openfile @@ -32,6 +33,7 @@ module GwfNpfModule type, extends(NumericalPackageType) :: GwfNpfType type(GwfIcType), pointer :: ic => null() !< initial conditions object + type(GwfVscType), pointer :: vsc => null() !< viscosity object type(Xt3dType), pointer :: xt3d => null() !< xt3d pointer integer(I4B), pointer :: iname => null() !< length of variable names character(len=24), dimension(:), pointer :: aname => null() !< variable names @@ -63,6 +65,9 @@ module GwfNpfModule real(DP), dimension(:), pointer, contiguous :: k11 => null() !< hydraulic conductivity; if anisotropic, then this is Kx prior to rotation real(DP), dimension(:), pointer, contiguous :: k22 => null() !< hydraulic conductivity; if specified then this is Ky prior to rotation real(DP), dimension(:), pointer, contiguous :: k33 => null() !< hydraulic conductivity; if specified then this is Kz prior to rotation + real(DP), dimension(:), pointer, contiguous :: k11_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification + real(DP), dimension(:), pointer, contiguous :: k22_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification + real(DP), dimension(:), pointer, contiguous :: k33_input => null() !< hydraulic conductivity originally specified by user prior to TVK or VSC modification integer(I4B), pointer :: iavgkeff => null() !< effective conductivity averaging (0: harmonic, 1: arithmetic) integer(I4B), pointer :: ik22 => null() !< flag that k22 is specified integer(I4B), pointer :: ik33 => null() !< flag that k33 is specified @@ -90,7 +95,9 @@ module GwfNpfModule real(DP), dimension(:, :), pointer, contiguous :: propsedge => null() !< edge properties (Q, area, nx, ny, distance) ! integer(I4B), pointer :: intvk => null() ! TVK (time-varying K) unit number (0 if unused) + integer(I4B), pointer :: invsc => null() ! VSC (viscosity) unit number (0 if unused); viscosity leads to time-varying K's type(TvkType), pointer :: tvk => null() ! TVK object + !type(GwfVscType), pointer :: vsc => null() ! VSC object integer(I4B), pointer :: kchangeper => null() ! last stress period in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), pointer :: kchangestp => null() ! last time step in which any node K (or K22, or K33) values were changed (0 if unchanged from start of simulation) integer(I4B), dimension(:), pointer, contiguous :: nodekchange => null() ! grid array of flags indicating for each node whether its K (or K22, or K33) value changed (1) at (kchangeper, kchangestp) or not (0) @@ -115,6 +122,7 @@ module GwfNpfModule procedure, private :: wd => sgwf_npf_wetdry procedure, private :: wdmsg => sgwf_npf_wdmsg procedure :: allocate_scalars + procedure, private :: store_original_k_arrays procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: set_options @@ -147,7 +155,7 @@ subroutine npf_cr(npfobj, name_model, inunit, iout) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - type(GwfNpftype), pointer :: npfobj + type(GwfNpfType), pointer :: npfobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout @@ -177,7 +185,7 @@ end subroutine npf_cr !! should be passed. A consistency check is performed, and finally !! xt3d_df is called, when enabled. !< - subroutine npf_df(this, dis, xt3d, ingnc, npf_options) + subroutine npf_df(this, dis, xt3d, ingnc, invsc, npf_options) ! ****************************************************************************** ! npf_df -- Define ! ****************************************************************************** @@ -192,6 +200,7 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) class(DisBaseType), pointer, intent(inout) :: dis !< the pointer to the discretization type(Xt3dType), pointer :: xt3d !< the pointer to the XT3D 'package' integer(I4B), intent(in) :: ingnc !< ghostnodes enabled? (>0 means yes) + integer(I4B), intent(in) :: invsc !< viscosity enabled? (>0 means yes) type(GwfNpfOptionsType), optional, intent(in) :: npf_options !< the optional options, for when not constructing from file ! -- local ! -- formats @@ -204,6 +213,9 @@ subroutine npf_df(this, dis, xt3d, ingnc, npf_options) ! -- Set a pointer to dis this%dis => dis ! + ! -- Set flag signifying whether vsc is active + if (invsc > 0) this%invsc = invsc + ! if (.not. present(npf_options)) then ! -- Print a message identifying the node property flow package. write (this%iout, fmtheader) this%inunit @@ -293,7 +305,7 @@ end subroutine npf_mc !! Allocate remaining package arrays, preprocess the input data and !! call *_ar on xt3d, when active. !< - subroutine npf_ar(this, ic, ibound, hnew) + subroutine npf_ar(this, ic, vsc, ibound, hnew) ! ****************************************************************************** ! npf_ar -- Allocate and Read ! ****************************************************************************** @@ -305,6 +317,7 @@ subroutine npf_ar(this, ic, ibound, hnew) ! -- dummy class(GwfNpftype) :: this !< instance of the NPF package type(GwfIcType), pointer, intent(in) :: ic !< initial conditions + type(GwfVscType), pointer, intent(in) :: vsc !< viscosity package integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: ibound !< model ibound array real(DP), dimension(:), pointer, contiguous, intent(inout) :: hnew !< pointer to model head array ! -- local @@ -329,6 +342,19 @@ subroutine npf_ar(this, ic, ibound, hnew) end do end if ! + ! -- Store pointer to VSC if active + if (this%invsc /= 0) then + this%vsc => vsc + end if + + ! + ! -- allocate arrays to store original user input in case TVK/VSC modify them + if (this%invsc > 0) then + ! Need to allocate arrays that will store the original K values so + ! that the current K11 etc. carry the "real" K's that are updated + call this%store_original_k_arrays(this%dis%nodes, this%dis%njas) + end if + ! ! -- preprocess data call this%preprocess_input() ! @@ -408,6 +434,12 @@ subroutine npf_ad(this, nodes, hold, hnew, irestore) call this%tvk%ad() end if ! + ! -- VSC + ! -- Hit the TVK-updated K's with VSC correction before calling/updating condsat + if (this%invsc /= 0) then + call this%vsc%update_k_with_vsc() + end if + ! ! -- If any K values have changed, we need to update CONDSAT or XT3D arrays if (this%kchangeper == kper .and. this%kchangestp == kstp) then if (this%ixt3d == 0) then @@ -1077,6 +1109,7 @@ subroutine npf_da(this) call mem_deallocate(this%ik22overk) call mem_deallocate(this%ik33overk) call mem_deallocate(this%intvk) + call mem_deallocate(this%invsc) call mem_deallocate(this%kchangeper) call mem_deallocate(this%kchangestp) ! @@ -1087,6 +1120,9 @@ subroutine npf_da(this) call mem_deallocate(this%k11) call mem_deallocate(this%k22) call mem_deallocate(this%k33) + call mem_deallocate(this%k11_input) ! , 'K11_INPUT', trim(this%memoryPath) + call mem_deallocate(this%k22_input) ! , 'K22_INPUT', trim(this%memoryPath) + call mem_deallocate(this%k33_input) ! , 'K33_INPUT', trim(this%memoryPath) call mem_deallocate(this%sat) call mem_deallocate(this%condsat) call mem_deallocate(this%wetdry) @@ -1155,6 +1191,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%nedges, 'NEDGES', this%memoryPath) call mem_allocate(this%lastedge, 'LASTEDGE', this%memoryPath) call mem_allocate(this%intvk, 'INTVK', this%memoryPath) + call mem_allocate(this%invsc, 'INVSC', this%memoryPath) call mem_allocate(this%kchangeper, 'KCHANGEPER', this%memoryPath) call mem_allocate(this%kchangestp, 'KCHANGESTP', this%memoryPath) ! @@ -1195,6 +1232,7 @@ subroutine allocate_scalars(this) this%nedges = 0 this%lastedge = 0 this%intvk = 0 + this%invsc = 0 this%kchangeper = 0 this%kchangestp = 0 ! @@ -1205,6 +1243,35 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + subroutine store_original_k_arrays(this, ncells, njas) +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GwfNpftype) :: this + integer(I4B), intent(in) :: ncells + integer(I4B), intent(in) :: njas + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- Retain copy of user-specified K arrays + do n = 1, ncells + this%k11_input(n) = this%k11(n) + if (this%ik22 /= 0) then + this%k22_input(n) = this%k22(n) + end if + if (this%ik33 /= 0) then + this%k33_input(n) = this%k33(n) + end if + end do + ! + ! -- Return + return + end subroutine store_original_k_arrays + subroutine allocate_arrays(this, ncells, njas) ! ****************************************************************************** ! allocate_arrays -- Allocate npf arrays @@ -1231,6 +1298,9 @@ subroutine allocate_arrays(this, ncells, njas) ! -- Optional arrays dimensioned to full size initially call mem_allocate(this%k22, ncells, 'K22', this%memoryPath) call mem_allocate(this%k33, ncells, 'K33', this%memoryPath) + call mem_allocate(this%k11_input, ncells, 'K11_INPUT', this%memoryPath) + call mem_allocate(this%k22_input, ncells, 'K22_INPUT', this%memoryPath) + call mem_allocate(this%k33_input, ncells, 'K33_INPUT', this%memoryPath) call mem_allocate(this%wetdry, ncells, 'WETDRY', this%memoryPath) call mem_allocate(this%angle1, ncells, 'ANGLE1', this%memoryPath) call mem_allocate(this%angle2, ncells, 'ANGLE2', this%memoryPath) From 971e78465e0a77ff48b91d1686e26e16c475206e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 17 Oct 2022 13:28:00 -0700 Subject: [PATCH 047/212] Updates to vsc.tex based on Alden's review --- doc/mf6io/gwf/vsc.tex | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/doc/mf6io/gwf/vsc.tex b/doc/mf6io/gwf/vsc.tex index e8f6f9c2efc..1a1e41270cc 100644 --- a/doc/mf6io/gwf/vsc.tex +++ b/doc/mf6io/gwf/vsc.tex @@ -1,24 +1,22 @@ -Input to the Viscosity (VSC) Package is read from the file that has type ``VSC6'' in the Name File. If the VSC Package is active within a groundwater flow model, then the model will account for variations in viscosity on groundwater flow. Viscosity may be calculated as a function of one or more groundwater solute transport (GWT) species using an approach described in the Supplemental Technical Information document distributed with MODFLOW 6 (Chapter 8). Only one VSC Package may be active within a GWF model. The VSC Package may be coupled with one or more GWT Models so that the fluid viscosity is updated dynamically with one or more simulated concentration fields. +Input to the Viscosity (VSC) Package is read from the file that has type ``VSC6'' in the Name File. If the VSC Package is active within a groundwater flow model, then the model will account for the dependence of fluid viscosity on solute concentration and the resulting changes in hydraulic conductivity and stress-package conductances, which vary inversely with viscosity. Viscosity can be calculated as a function of one or more groundwater solute transport (GWT) species using an approach described in the Supplemental Technical Information document distributed with MODFLOW 6 (Chapter 8). Only one VSC Package can be specified for a GWF model. The VSC Package can be coupled with one or more GWT Models so that the fluid viscosity is updated dynamically with one or more simulated concentration fields. -The VSC Package calculates fluid viscosity using the following equation of state from \cite{langevin2008seawat}: +The VSC Package calculates fluid viscosity using the following equation from \cite{langevin2008seawat}: \begin{equation} \label{eqn:visclinear} \mu = VISCREF + \sum_{i=1}^{NVISCSPECIES} DVISCDC_i \left ( CONCENTRATION_i - CVISCREF_i \right ) \end{equation} -\noindent where $\mu$ is the calculated viscosity, $VISCREF$ is the viscosity of a reference fluid, typically taken to be freshwater at a temperature of 20 $^{\circ}$C, $NVISCSPECIES$ is the number of chemical species that contribute to the viscosity calculation, $DVISCDC_i$ is the parameter that describes how viscosity changes linearly as a function of concentration for chemical species $i$ (i.e. the slope of a line that relates viscosity to concentration), $CONCENTRATION_i$ is the concentration of species $i$ and will commonly be set equal to the concentration calculated by one or more GWT models, and $CVISCREF_i$ is the reference concentration for species $i$ corresponding to when the viscosity of the reference fluid is equal to $VISCREF$ (typically set to zero when accounting for the effects of dissolved solute on viscosity). +\noindent where $\mu$ is the calculated viscosity, $VISCREF$ is the viscosity of a reference fluid, typically taken to be freshwater at a temperature of 20 degrees Celsius, $NVISCSPECIES$ is the number of chemical species that contribute to the viscosity calculation, $DVISCDC_i$ is the parameter that describes how viscosity changes linearly as a function of concentration for chemical species $i$ (i.e. the slope of a line that relates viscosity to concentration), $CONCENTRATION_i$ is the concentration of species $i$, and $CVISCREF_i$ is the reference concentration for species $i$ corresponding to when the viscosity of the reference fluid is equal to $VISCREF$, which is normally set to a concentration of zero. -In many cases, fluid viscosity is generally considered to be more sensitive to variations in temperature than to variations in concentration. When simulating temperature as a species \citep{zheng2010supplemental}, the simulated fluid viscosity may vary linearly with changes in temperature using equation~\ref{eqn:visclinear}. For example, $DVISCDC_i$, the paramter that describes how viscosity changes linearly as a function of concentration, can effectively serve as a surrogate for $DVISCDT_i$ (note that $DC_i$ changed to $DT_i$), a term representing changes in viscosity as a function of temperature. Analogously, $CONCENTRATION_i$ and $CVISCREF_i$ serve as surrogates for $TEMPERATURE_i$ and $TVISCREF_i$, representing the dynamically simulated (or specified at the boundary) temperature and reference temperature for species $i$, respectively. - -In addition to supporting a linear relationship between viscosity and temperature, the VSC package also supports a nonlinear relationship as well. For the nonlinear case, the VSC package may be directed to solve the following equation of state: +In many applications, variations in temperature have a greater effect on fluid viscosity than variations in solute concentration. When a GWT model is formulated such that one of the transported ``species'' is heat (thermal energy), with ``concentration'' used to represent temperature \citep{zheng2010supplemental}, the viscosity can vary linearly with temperature, as it can with any other ``concentration.'' In that case, $CONCENTRATION_i$ and $CVISCREF_i$ represent the simulated and reference temperatures, respectively, and $DVISCDC_i$ represents the rate at which viscosity changes with temperature. In addition, the viscosity formula can optionally include a nonlinear dependence on temperature. In that case, equation 3 becomes \begin{equation} \label{eqn:viscnonlinear} \mu = \mu_T(T) + \sum_{i=1}^{NVISCSPECIES} DVISCDC_i \left ( CONCENTRATION_i - CVISCREF_i \right ) \end{equation} -\noindent where the second term on the right-hand side of the equation adjusts the viscosity based on one or more solute concentrations and $\mu_T(T)$ calculates the viscosity adjustment based on the simulated temperature using, +where the first term on the right-hand side, $\mu_T(T)$, is a nonlinear function of temperature, and the summation corresponds to the summation in equation \ref{eqn:visclinear}, in which one of the ``species'' is heat. The nonlinear term in equation \ref{eqn:viscnonlinear} is of the form \begin{equation} \label{eqn:munonlinear} @@ -28,11 +26,12 @@ \noindent where the coefficients $A_2$, $A_3$, and $A_4$ are specified by the user. Values for $A_2$, $A_3$, and $A_4$ are commonly 10, 248.7, and 133.15, respectively \citep{langevin2008seawat, Voss1984sutra}. \subsubsection{Stress Packages} -For head-dependent stress packages, the VSC Package may require fluid viscosity and elevation for each head-dependent boundary so that the model can use the appropriate viscosity to calculate flow between the boundary and the aquifer. By default, the boundary elevation is set equal to the cell elevation. For water-table conditions, the cell elevation is calculated as bottom elevation plus half of saturation multiplied by the cell thickness. If desired, the user can more precisely locate the boundary elevation by specifying an auxiliary variable with the name ``ELEVATION''. The program will use the values in this column as the boundary elevation. A situation where this may be required is for river or general-head boundaries that are conceptualized as being on top of a model cell. In those cases, an ELEVATION column should be specified and the values set to the top of the cell or some other appropriate elevation that corresponds to where the boundary stage applies. -By default, the boundary viscosity is set equal to VISCREF, which, for freshwater, is typically set equal to 1.0. However, there are two additional options for setting the viscosity of a boundary package. The first is to assign an auxiliary variable with the name ``VISCOSITY''. If an auxiliary variable named ``VISCOSITY'' is detected, then it will be assigned as the viscosity of the fluid entering from the boundary. Alternatively, a viscosity value can be calculated for each boundary using the viscosity equation of state (described above) and one or more concentrations provided as auxiliary variables. In this case, the user must assign one auxiliary variable for each AUXSPECIESNAME listed in the PACKAGEDATA block below. Thus, there must be NVISCSPECIES auxiliary variables, each with the identical name as those specified in PACKAGEDATA. The VSC Package will calculate the viscosity for each boundary using these concentrations and the values specified for VISCREF, DVISCDC, and CVISCREF. If the boundary package contains an auxiliary variable named VISCOSITY and also contains AUXSPECIESNAME auxiliary variables, then the specified - not the internally calculated - boundary viscosity value will be assigned to the one in the VISCOSITY auxiliary variable. +For head-dependent stress packages, the VSC Package can adjust the conductance used to calculate flow between the boundary and the aquifer to account for variations in viscosity. Conductance is assumed to vary inversely with viscosity. + +By default, the boundary viscosity is set equal to VISCREF, which, for freshwater, is typically set equal to 1.0. However, there are two additional options for setting the viscosity of a boundary package. The first is to assign an auxiliary variable with the name ``VISCOSITY''. If an auxiliary variable named ``VISCOSITY'' is detected, then it will be assigned as the viscosity of the fluid entering from the boundary. Alternatively, a viscosity value can be calculated for each boundary using the viscosity equation described above and one or more concentrations provided as auxiliary variables. In this case, the user must assign one auxiliary variable for each AUXSPECIESNAME listed in the PACKAGEDATA block below. Thus, there must be NVISCSPECIES auxiliary variables, each with the identical name as those specified in PACKAGEDATA. The VSC Package will calculate the viscosity for each boundary using these concentrations and the values specified for VISCREF, DVISCDC, and CVISCREF. If the boundary package contains an auxiliary variable named VISCOSITY and also contains AUXSPECIESNAME auxiliary variables, then the boundary viscosity value will be assigned to the one in the VISCOSITY auxiliary variable. -A GWT Model can be used to calculate concentration of features associated with one of the advanced stress packages (LAK, SFR, MAW, and UZF) if corresponding advanced transport packages are specified (LKT, SFT, MWT, and UZT). The advanced stress packages have an input option called FLOW\_PACKAGE\_AUXILIARY\_NAME. When activated, this option will result in the simulated concentration for a lake or other feature being copied from the advanced transport package into the auxiliary variable for the corresponding GWF stress package. This means that the viscosity for a lake or stream, for example, can be dynamically updated during the simulation using concentrations from advanced transport packages that are fed into auxiliary variables in the advanced stress packages, and ultimately used by the VSC Package to calculate a fluid viscosity using the equation of state. This concept also applies when multiple GWT Models are used simultaneously to simulate multiple species. In this case, multiple auxiliary variables are required for an advanced stress package, with each one representing a concentration from a different GWT Model. +A GWT Model can be used to calculate concentrations for the advanced stress packages (LAK, SFR, MAW, and UZF) if corresponding advanced transport packages are specified (LKT, SFT, MWT, and UZT). The advanced stress packages have an input option called FLOW\_PACKAGE\_AUXILIARY\_NAME. When activated, this option will result in the simulated concentration for a lake or other feature being copied from the advanced transport package into the auxiliary variable for the corresponding GWF stress package. This means that the viscosity for a lake or stream, for example, can be dynamically updated during the simulation using concentrations from advanced transport packages that are fed into auxiliary variables in the advanced stress packages, and ultimately used by the VSC Package to calculate a fluid viscosity. This concept also applies when multiple GWT Models are used simultaneously to simulate multiple species. In this case, multiple auxiliary variables are required for an advanced stress package, with each one representing a concentration from a different GWT Model. \begin{longtable}{p{3cm} p{12cm}} @@ -45,12 +44,12 @@ \subsubsection{Stress Packages} \endhead \hline \endfoot -GHB & ELEVATION can be specified as an auxiliary variable. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ -RIV & ELEVATION can be specified as an auxiliary variable. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +GHB & A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +RIV & A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ DRN & The drain formulation assumes that the drain boundary contains water of the same viscosity as the discharging water; auxiliary variables have no effect on the drain calculation \\ -LAK & Elevation for each lake-aquifer connection is determined based on lake bottom and adjacent cell elevations. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ -SFR & Elevation for each sfr-aquifer connection is determined based on stream bottom and adjacent cell elevations. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ -MAW & Elevation for each maw-aquifer connection is determined based on cell elevation. A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +LAK & A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +SFR & A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ +MAW & A VISCOSITY auxiliary variable or one or more auxiliary variables for calculating viscosity in the equation of state can be specified \\ UZF & Pending ... \\ \end{longtable} From 5ff49f5e1f6dba2b6a4f123f7a051502ceb88aa7 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 17 Oct 2022 15:24:49 -0700 Subject: [PATCH 048/212] Resolving some losses that were experienced in the last merge commit --- msvs/mf6core.vfproj | 37 +++++++++++++++------ src/Model/Connection/GwtInterfaceModel.f90 | 12 ++++--- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 6 ++-- 3 files changed, 36 insertions(+), 19 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 975d2eb3bd0..8aa828b2c61 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -14,7 +14,7 @@ - + @@ -48,6 +48,8 @@ + + @@ -61,6 +63,8 @@ + + @@ -73,6 +77,10 @@ + + + + @@ -105,43 +113,50 @@ + - + - + - - + + - + - - + + - - + + + + + - + + + + diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 472a63e980e..5dcfb231014 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -5,13 +5,13 @@ module GwtInterfaceModelModule use NumericalModelModule, only: NumericalModelType use GwtModule, only: GwtModelType, CastAsGwtModel use GwfDisuModule, only: disu_cr, CastAsDisuType - use GwtFmiModule, only: fmi_cr, GwtFmiType - use GwtAdvModule, only: adv_cr, GwtAdvType - use GwtAdvOptionsModule, only: GwtAdvOptionsType + use TspFmiModule, only: fmi_cr, TspFmiType + use TspAdvModule, only: adv_cr, TspAdvType + use TspAdvOptionsModule, only: TspAdvOptionsType use GwtDspModule, only: dsp_cr, GwtDspType use GwtDspOptionsModule, only: GwtDspOptionsType use GwtMstModule, only: mst_cr - use GwtObsModule, only: gwt_obs_cr + use TspObsModule, only: tsp_obs_cr use GridConnectionModule implicit none @@ -30,6 +30,8 @@ module GwtInterfaceModelModule class(GwtModelType), private, pointer :: owner => null() !< the real GWT model for which the exchange coefficients !! are calculated with this interface model + real(DP), dimension(:), pointer, contiguous :: porosity => null() !< to be filled with MST porosity + contains procedure, pass(this) :: gwtifmod_cr procedure :: model_df => gwtifmod_df @@ -117,7 +119,7 @@ subroutine gwtifmod_df(this) class(GwtInterfaceModelType) :: this !< the GWT interface model ! local class(*), pointer :: disPtr - type(GwtAdvOptionsType) :: adv_options + type(TspAdvOptionsType) :: adv_options type(GwtDspOptionsType) :: dsp_options this%moffset = 0 diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index 3bff76ec9ec..e2a828ea619 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -4,7 +4,7 @@ module GwtDspModule use ConstantsModule, only: DONE, DZERO, DHALF, DPI use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr use GwtDspOptionsModule, only: GwtDspOptionsType @@ -16,7 +16,7 @@ module GwtDspModule type, extends(NumericalPackageType) :: GwtDspType integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWT model ibound - type(GwtFmiType), pointer :: fmi => null() ! pointer to GWT fmi object + type(TspFmiType), pointer :: fmi => null() ! pointer to GWT fmi object real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWT storage porosity real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity @@ -86,7 +86,7 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout - type(GwtFmiType), intent(in), target :: fmi + type(TspFmiType), intent(in), target :: fmi ! -- formats character(len=*), parameter :: fmtdsp = & "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & From 03f3801906105c6c8dd58a68e9bbc4cb165734a8 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Oct 2022 20:37:53 -0700 Subject: [PATCH 049/212] Resolving lots of issues post PR #1059 that should've been caught earlier, but somehow were not. In any event, I think GWE exchanges once again mirror GWT exchanges. My fork is compiling again. --- msvs/mf6core.vfproj | 20 +- src/Exchange/GweGweExchange.f90 | 69 ++++-- src/Exchange/GwfGweExchange.f90 | 46 +++- src/Model/Connection/CellWithNbrs.f90 | 1 - src/Model/Connection/GweGweConnection.f90 | 241 +++++++-------------- src/Model/Connection/GweInterfaceModel.f90 | 100 +++++---- src/Model/Connection/GwtInterfaceModel.f90 | 2 +- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 63 +----- src/SimulationCreate.f90 | 9 + 9 files changed, 248 insertions(+), 303 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 8aa828b2c61..fa1f412c657 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -117,24 +117,23 @@ - - - + - - - - - + + + + + + + - @@ -144,11 +143,9 @@ - - @@ -161,6 +158,7 @@ + diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index ec2b78fa617..dc74e3a9855 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -18,9 +18,10 @@ module GweGweExchangeModule TABCENTER, TABLEFT, LENAUXNAME, DNODATA, & LENMODELNAME use ListModule, only: ListType - use ListsModule, only: basemodellist + use ListsModule, only: basemodellist, distmodellist use DisConnExchangeModule, only: DisConnExchangeType use GweModule, only: GweModelType + use DistributedModelModule, only: GetDistModelFromList use TspMvtModule, only: TspMvtType use ObserveModule, only: ObserveType use ObsModule, only: ObsType @@ -49,6 +50,7 @@ module GweGweExchangeModule ! -- names of the GWF models that are connected by this exchange character(len=LENMODELNAME) :: gwfmodelname1 = '' !< name of gwfmodel that corresponds to gwtmodel1 character(len=LENMODELNAME) :: gwfmodelname2 = '' !< name of gwfmodel that corresponds to gwtmodel2 + real(DP), dimension(:), pointer, contiguous :: gwfsimvals => null() !< simulated gwf flow rate for each exchange ! ! -- pointers to gwt models type(GweModelType), pointer :: gwemodel1 => null() !< pointer to GWT Model 1 @@ -152,6 +154,7 @@ subroutine gweexchange_create(filename, id, m1id, m2id) exchange%model1 => mb exchange%gwemodel1 => mb end select + exchange%dmodel1 => GetDistModelFromList(distmodellist, m1id) ! ! -- set gwtmodel2 mb => GetBaseModelFromList(basemodellist, m2id) @@ -160,6 +163,7 @@ subroutine gweexchange_create(filename, id, m1id, m2id) exchange%model2 => mb exchange%gwemodel2 => mb end select + exchange%dmodel2 => GetDistModelFromList(distmodellist, m2id) ! ! -- Verify that gwt model1 is of the correct type if (.not. associated(exchange%gwemodel1)) then @@ -520,10 +524,14 @@ subroutine gwe_gwe_bdsav(this) ! ! -- If cell-by-cell flows will be saved as a list, write header. if (ibinun1 /= 0) then - call this%gwemodel1%dis%record_srcdst_list_header( & - budtxt(1), this%gwemodel1%name, this%name, & - this%gwemodel2%name, this%name, this%naux, this%auxname, & - ibinun1, this%nexg, this%gwemodel1%iout) + call this%gwemodel1%dis%record_srcdst_list_header(budtxt(1), & + this%gwemodel1%name, & + this%name, & + this%gwemodel2%name, & + this%name, & + this%naux, this%auxname, & + ibinun1, this%nexg, & + this%gwemodel1%iout) end if ! ! Initialize accumulators @@ -596,10 +604,14 @@ subroutine gwe_gwe_bdsav(this) ! ! -- If cell-by-cell flows will be saved as a list, write header. if (ibinun2 /= 0) then - call this%gwemodel2%dis%record_srcdst_list_header( & - budtxt(1), this%gwemodel2%name, this%name, this%gwemodel1%name, & - this%name, this%naux, this%auxname, ibinun2, this%nexg, & - this%gwemodel2%iout) + call this%gwemodel2%dis%record_srcdst_list_header(budtxt(1), & + this%gwemodel2%name, & + this%name, & + this%gwemodel1%name, & + this%name, & + this%naux, this%auxname, & + ibinun2, this%nexg, & + this%gwemodel2%iout) end if ! ! Initialize accumulators @@ -873,8 +885,7 @@ function parse_option(this, keyword, iout) result(parsed) inobs = GetUnit() call openfile(inobs, iout, this%obs%inputFilename, 'OBS') this%obs%inUnitObs = inobs - case ('ADVSCHEME') - !cdl todo: change to ADV_SCHEME? + case ('ADV_SCHEME') call this%parser%GetStringCaps(subkey) select case (subkey) case ('UPSTREAM') @@ -890,14 +901,27 @@ function parse_option(this, keyword, iout) result(parsed) end select write (iout, '(4x,a,a)') & 'CELL AVERAGING METHOD HAS BEEN SET TO: ', trim(subkey) - case ('XT3D_OFF') - !cdl todo: change to DSP_XT3D_OFF? + case ('DSP_XT3D_OFF') this%ixt3d = 0 write (iout, '(4x,a)') 'XT3D FORMULATION HAS BEEN SHUT OFF.' - case ('XT3D_RHS') - !cdl todo: change to DSP_XT3D_RHS? + case ('DSP_XT3D_RHS') this%ixt3d = 2 write (iout, '(4x,a)') 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' + case ('ADVSCHEME') + errmsg = 'ADVSCHEME is no longer a valid keyword. Use ADV_SCHEME & + &instead.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + case ('XT3D_OFF') + errmsg = 'XT3D_OFF is no longer a valid keyword. Use DSP_XT3D_OFF & + &instead.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + case ('XT3D_RHS') + errmsg = 'XT3D_RHS is no longer a valid keyword. Use DSP_XT3D_RHS & + &instead.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() case default parsed = .false. end select @@ -986,6 +1010,7 @@ subroutine gwe_gwe_da(this) ! -- arrays call mem_deallocate(this%cond) call mem_deallocate(this%simvals) + call mem_deallocate(this%gwfsimvals, 'GWFSIMVALS', this%memoryPath) ! linked memory ! ! -- output table objects if (associated(this%outputtab1)) then @@ -1212,12 +1237,24 @@ function gwe_gwe_connects_model(this, model) result(is_connected) end function gwe_gwe_connects_model !> @brief Should interface model be used for this exchange + !! + !! For now this always returns true, since we do not support + !! a classic-style two-point flux approximation for GWT-GWT. + !! If we ever add logic to support a simpler non-interface + !! model flux calculation, then logic should be added here to + !! set the return accordingly. !< function use_interface_model(this) result(useIM) class(GweExchangeType) :: this !< GwtExchangeType logical(LGP) :: useIM !< true when interface model should be used - useIM = (this%ixt3d > 0) + ! if support is added in the future for simpler flow calcuation, + ! then set useIM as follows + !useIM = (this%ixt3d > 0) + + ! For now set useIM to .true. since the interface model approach + ! must currently be used for any GWT-GWT exchange. + useIM = .true. end function diff --git a/src/Exchange/GwfGweExchange.f90 b/src/Exchange/GwfGweExchange.f90 index 1df74b3abf0..5a7173239bb 100644 --- a/src/Exchange/GwfGweExchange.f90 +++ b/src/Exchange/GwfGweExchange.f90 @@ -148,6 +148,7 @@ subroutine exg_df(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use MemoryManagerModule, only: mem_checkin ! -- dummy class(GwfGweExchangeType) :: this ! -- local @@ -171,8 +172,22 @@ subroutine exg_df(this) gwemodel => mb end select ! + ! -- Check to make sure that flow is solved before transport and in a + ! different IMS solution + if (gwfmodel%idsoln >= gwemodel%idsoln) then + write (errmsg, '(3a)') 'Problem with GWF-GWE exchange ', trim(this%name), & + '. The GWF model must be solved by a different IMS than the GWE model. & + &Furthermore, the IMS specified for GWF must be listed in mfsim.nam & + &before the IMS for GWE.' + call store_error(errmsg, terminate=.true.) + end if + ! ! -- Set pointer to flowja gwemodel%fmi%gwfflowja => gwfmodel%flowja + call mem_checkin(gwemodel%fmi%gwfflowja, & + 'GWFFLOWJA', gwemodel%fmi%memoryPath, & + 'FLOWJA', gwfmodel%memoryPath) + ! ! -- Set the npf flag so that specific discharge is available for ! transport calculations if dispersion is active @@ -192,6 +207,7 @@ subroutine exg_ar(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use MemoryManagerModule, only: mem_checkin ! -- dummy class(GwfGweExchangeType) :: this ! -- local @@ -234,8 +250,17 @@ subroutine exg_ar(this) ! ! -- setup pointers to gwf variables allocated in gwf_ar gwemodel%fmi%gwfhead => gwfmodel%x + call mem_checkin(gwemodel%fmi%gwfhead, & + 'GWFHEAD', gwemodel%fmi%memoryPath, & + 'X', gwfmodel%memoryPath) gwemodel%fmi%gwfsat => gwfmodel%npf%sat + call mem_checkin(gwemodel%fmi%gwfsat, & + 'GWFSAT', gwemodel%fmi%memoryPath, & + 'SAT', gwfmodel%npf%memoryPath) gwemodel%fmi%gwfspdis => gwfmodel%npf%spdis + call mem_checkin(gwemodel%fmi%gwfspdis, & + 'GWFSPDIS', gwemodel%fmi%memoryPath, & + 'SPDIS', gwfmodel%npf%memoryPath) ! ! -- setup pointers to the flow storage rates. GWF strg arrays are ! available after the gwf_ar routine is called. @@ -250,11 +275,13 @@ subroutine exg_ar(this) end if end if ! - ! -- Set a pointer to conc + ! -- Set a pointer to conc in buy if (gwfmodel%inbuy > 0) then call gwfmodel%buy%set_concentration_pointer(gwemodel%name, gwemodel%x, & gwemodel%ibound) end if + ! + ! -- Set a pointer to conc (which could be a temperature) in vsc if (gwfmodel%invsc > 0) then call gwfmodel%vsc%set_concentration_pointer(gwemodel%name, gwemodel%x, & gwemodel%ibound, 1) @@ -280,6 +307,7 @@ end subroutine exg_ar subroutine gwfconn2gweconn(this, gwfModel, gweModel) use SimModule, only: store_error use SimVariablesModule, only: iout + use MemoryManagerModule, only: mem_checkin class(GwfGweExchangeType) :: this !< this exchange type(GwfModelType), pointer :: gwfModel !< the flow model type(GweModelType), pointer :: gweModel !< the transport model @@ -357,7 +385,13 @@ subroutine gwfconn2gweconn(this, gwfModel, gweModel) ' to ', trim(gwfEx%name), ' for GWE model ', & trim(gweModel%name) gwfExIdx = iex - gweConn%exgflowja => gwfEx%simvals + if (gweConn%exchangeIsOwned) then + gweConn%gweExchange%gwfsimvals => gwfEx%simvals + call mem_checkin(gweConn%gweExchange%gwfsimvals, & + 'GWFSIMVALS', gweConn%gweExchange%memoryPath, & + 'SIMVALS', gwfEx%memoryPath) + end if + !cdl link up mvt to mvr if (gwfEx%inmvr > 0) then @@ -394,12 +428,18 @@ end subroutine gwfconn2gweconn !> @brief Links a GWE connection to its GWF counterpart !< subroutine link_connections(this, gweConn, gwfConn) + use MemoryManagerModule, only: mem_checkin class(GwfGweExchangeType) :: this !< this exchange class(GweGweConnectionType), pointer :: gweConn !< GWE connection class(GwfGwfConnectionType), pointer :: gwfConn !< GWF connection !gweConn%exgflowja => gwfConn%exgflowja - gweConn%exgflowja => gwfConn%gwfExchange%simvals + if (gweConn%exchangeIsOwned) then + gweConn%gweExchange%gwfsimvals => gwfConn%gwfExchange%simvals + call mem_checkin(gweConn%gweExchange%gwfsimvals, & + 'GWFSIMVALS', gweConn%gweExchange%memoryPath, & + 'SIMVALS', gwfConn%gwfExchange%memoryPath) + end if !cdl link up mvt to mvr if (gwfConn%gwfExchange%inmvr > 0) then diff --git a/src/Model/Connection/CellWithNbrs.f90 b/src/Model/Connection/CellWithNbrs.f90 index 43c28cf4afd..9a2b488e7fc 100644 --- a/src/Model/Connection/CellWithNbrs.f90 +++ b/src/Model/Connection/CellWithNbrs.f90 @@ -60,7 +60,6 @@ subroutine addNbrCell(this, index, dist_model) this%neighbors(nbrCnt + 1)%cell%index = index this%neighbors(nbrCnt + 1)%cell%dmodel => dist_model - this%nrOfNbrs = nbrCnt + 1 end subroutine addNbrCell diff --git a/src/Model/Connection/GweGweConnection.f90 b/src/Model/Connection/GweGweConnection.f90 index 55a559f34bc..dce51bd6256 100644 --- a/src/Model/Connection/GweGweConnection.f90 +++ b/src/Model/Connection/GweGweConnection.f90 @@ -3,7 +3,7 @@ module GweGweConnectionModule use ConstantsModule, only: LINELENGTH, LENCOMPONENTNAME, DZERO, LENBUDTXT use CsrUtilsModule, only: getCSRIndex use SimModule, only: ustop - use MemoryManagerModule, only: mem_allocate, mem_deallocate + use MemoryManagerModule, only: mem_allocate, mem_deallocate, mem_checkin use SpatialModelConnectionModule use NumericalModelModule use GweModule @@ -13,6 +13,7 @@ module GweGweConnectionModule use SparseModule, only: sparsematrix use ConnectionsModule, only: ConnectionsType use CellWithNbrsModule, only: GlobalCellType + use DistributedDataModule implicit none private @@ -28,14 +29,13 @@ module GweGweConnectionModule type(GweModelType), pointer :: gweModel => null() !< the model for which this connection exists type(GweExchangeType), pointer :: gweExchange => null() !< the primary exchange, cast to GWE-GWE logical(LGP) :: exchangeIsOwned !< there are two connections (in serial) for an exchange, - !! one of them needs to manage/own the exchange (e.g. clean up) + !! one of them needs to manage/own the exchange (e.g. clean up) type(GweInterfaceModelType), pointer :: gweInterfaceModel => null() !< the interface model integer(I4B), pointer :: iIfaceAdvScheme => null() !< the advection scheme at the interface: - !! 0 = upstream, 1 = central, 2 = TVD + !! 0 = upstream, 1 = central, 2 = TVD integer(I4B), pointer :: iIfaceXt3d => null() !< XT3D in the interface DSP package: 0 = no, 1 = lhs, 2 = rhs - real(DP), dimension(:), pointer, contiguous :: exgflowja => null() !< intercell flows at the interface, coming from GWF interface model integer(I4B), pointer :: exgflowSign => null() !< indicates the flow direction of exgflowja - real(DP), dimension(:), pointer, contiguous :: exgflowjaGwt => null() !< gwe-flowja at the interface (this is a subset of the GWE + real(DP), dimension(:), pointer, contiguous :: exgflowjaGwe => null() !< gwe-flowja at the interface (this is a subset of the GWT !! interface model flowja's) real(DP), dimension(:), pointer, contiguous :: gwfflowja => null() !< gwfflowja for the interface model @@ -71,7 +71,6 @@ module GweGweConnectionModule ! local stuff procedure, pass(this), private :: allocate_scalars procedure, pass(this), private :: allocate_arrays - procedure, pass(this), private :: syncInterfaceModel procedure, pass(this), private :: setGridExtent procedure, pass(this), private :: setFlowToExchange @@ -85,7 +84,7 @@ subroutine gweGweConnection_ctor(this, model, gweEx) use InputOutputModule, only: openfile class(GweGweConnectionType) :: this !< the connection class(NumericalModelType), pointer :: model !< the model owning this connection, - !! this must be a GweModelType + !! this must be a GweModelType class(DisConnExchangeType), pointer :: gweEx !< the GWE-GWE exchange the interface model is created for ! local character(len=LINELENGTH) :: fname @@ -116,7 +115,8 @@ subroutine gweGweConnection_ctor(this, model, gweEx) end if ! first call base constructor - call this%SpatialModelConnectionType%spatialConnection_ctor(model, gweEx, & + call this%SpatialModelConnectionType%spatialConnection_ctor(model,& + gweEx, & name) call this%allocate_scalars() @@ -141,32 +141,6 @@ subroutine allocate_scalars(this) end subroutine allocate_scalars -!> @brief Allocate array variables for this connection -!< - subroutine allocate_arrays(this) - class(GweGweConnectionType) :: this !< the connection - ! local - integer(I4B) :: i - - call mem_allocate(this%gwfflowja, this%interfaceModel%nja, 'GWFFLOWJA', & - this%memoryPath) - call mem_allocate(this%gwfsat, this%neq, 'GWFSAT', this%memoryPath) - call mem_allocate(this%gwfhead, this%neq, 'GWFHEAD', this%memoryPath) - call mem_allocate(this%gwfspdis, 3, this%neq, 'GWFSPDIS', this%memoryPath) - - call mem_allocate(this%exgflowjaGwt, this%gridConnection%nrOfBoundaryCells, & - 'EXGFLOWJAGWE', this%memoryPath) - - do i = 1, size(this%gwfflowja) - this%gwfflowja = 0.0_DP - end do - - do i = 1, this%neq - this%gwfsat = 0.0_DP - end do - - end subroutine allocate_arrays - !> @brief define the GWE-GWE connection !< subroutine gwegwecon_df(this) @@ -194,22 +168,63 @@ subroutine gwegwecon_df(this) else write (imName, '(a,i0)') 'GWEIM2_', this%gweExchange%id end if - call this%gweInterfaceModel%gweifmod_cr(imName, this%iout, & + call this%gweInterfaceModel%gweifmod_cr(imName, & + this%iout, & this%gridConnection) + call this%gweInterfaceModel%set_idsoln(this%gweModel%idsoln) this%gweInterfaceModel%iAdvScheme = this%iIfaceAdvScheme this%gweInterfaceModel%ixt3d = this%iIfaceXt3d call this%gweInterfaceModel%model_df() + call this%addDistVar('X', '', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR, BEFORE_AD, BEFORE_CF/)) + call this%addDistVar('IBOUND', '', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('TOP', 'DIS', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('BOT', 'DIS', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('AREA', 'DIS', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + if (this%gweInterfaceModel%dsp%idiffc > 0) then + call this%addDistVar('DIFFC', 'DSP', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + end if + if (this%gweInterfaceModel%dsp%idisp > 0) then + call this%addDistVar('ALH', 'DSP', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('ALV', 'DSP', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('ATH1', 'DSP', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('ATH2', 'DSP', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + call this%addDistVar('ATV', 'DSP', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AR/)) + end if + call this%addDistVar('GWFHEAD', 'FMI', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AD/)) + call this%addDistVar('GWFSAT', 'FMI', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AD/)) + call this%addDistVar('GWFSPDIS', 'FMI', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/BEFORE_AD/)) + call this%addDistVar('GWFFLOWJA', 'FMI', this%gweInterfaceModel%name, & + SYNC_CONNECTIONS, '', (/BEFORE_AD/)) + call this%addDistVar('GWFFLOWJA', 'FMI', this%gweInterfaceModel%name, & + SYNC_EXCHANGES, 'GWFSIMVALS', (/BEFORE_AD/)) + ! fill porosity from mst packages, needed for dsp + if (this%gweModel%indsp > 0 .and. this%gweModel%inmst > 0) then + call this%addDistVar('POROSITY', 'MST', this%gweInterfaceModel%name, & + SYNC_NODES, '', (/AFTER_AR/)) + end if + call this%mapVariables() + call this%allocate_arrays() + call this%gweInterfaceModel%allocate_fmi() ! connect X, RHS, IBOUND, and flowja call this%spatialcon_setmodelptrs() - this%gweInterfaceModel%fmi%gwfflowja => this%gwfflowja - this%gweInterfaceModel%fmi%gwfsat => this%gwfsat - this%gweInterfaceModel%fmi%gwfhead => this%gwfhead - this%gweInterfaceModel%fmi%gwfspdis => this%gwfspdis - ! connect pointers (used by BUY) this%conc => this%gweInterfaceModel%x this%icbound => this%gweInterfaceModel%ibound @@ -219,8 +234,18 @@ subroutine gwegwecon_df(this) end subroutine gwegwecon_df -!> @brief Set required extent of the interface grid from -!< the configuration + !> @brief Allocate array variables for this connection + !< + subroutine allocate_arrays(this) + class(GweGweConnectionType) :: this !< the connection + + call mem_allocate(this%exgflowjaGwe, this%gridConnection%nrOfBoundaryCells, & + 'EXGFLOWJAGWT', this%memoryPath) + + end subroutine allocate_arrays + + !> @brief Set required extent of the interface grid from + !< the configuration subroutine setGridExtent(this) class(GweGweConnectionType) :: this !< the connection ! local @@ -253,26 +278,12 @@ end subroutine setGridExtent !< subroutine gwegwecon_ar(this) class(GweGweConnectionType) :: this !< the connection - ! local - integer(I4B) :: i, idx - class(GweModelType), pointer :: gweModel - class(*), pointer :: modelPtr ! check if we can construct an interface model ! NB: only makes sense after the models' allocate&read have been ! called, which is why we do it here call this%validateConnection() - ! fill porosity from mst packages, needed for dsp - if (this%gweModel%inmst > 0) then - do i = 1, this%neq - modelPtr => this%gridConnection%idxToGlobal(i)%model - gweModel => CastAsGweModel(modelPtr) - idx = this%gridConnection%idxToGlobal(i)%index - this%gweInterfaceModel%porosity(i) = gweModel%mst%porosity(idx) - end do - end if - ! allocate and read base call this%spatialcon_ar() @@ -344,8 +355,8 @@ subroutine gwegwecon_ac(this, sparse) do ic = 1, this%gridConnection%nrOfBoundaryCells boundaryCell = this%gridConnection%boundaryCells(ic)%cell connectedCell = this%gridConnection%connectedCells(ic)%cell - iglo = boundaryCell%index + boundaryCell%model%moffset - jglo = connectedCell%index + connectedCell%model%moffset + iglo = boundaryCell%index + boundaryCell%dmodel%moffset + jglo = connectedCell%index + connectedCell%dmodel%moffset call sparse%addconnection(iglo, jglo, 1) call sparse%addconnection(jglo, iglo, 1) end do @@ -365,14 +376,11 @@ subroutine gwegwecon_rp(this) end subroutine gwegwecon_rp -!> @brief Advance this connection + !> @brief Advance this connection !< subroutine gwegwecon_ad(this) class(GweGweConnectionType) :: this !< this connection - ! copy model data into interface model - call this%syncInterfaceModel() - ! recalculate dispersion ellipse if (this%gweInterfaceModel%indsp > 0) call this%gweInterfaceModel%dsp%dsp_ad() @@ -388,10 +396,6 @@ subroutine gwegwecon_cf(this, kiter) ! local integer(I4B) :: i - ! copy model data into interface model - ! (when kiter == 1, this is already done in _ad) - if (kiter > 1) call this%syncInterfaceModel() - ! reset interface system do i = 1, this%nja this%amat(i) = 0.0_DP @@ -404,75 +408,6 @@ subroutine gwegwecon_cf(this, kiter) end subroutine gwegwecon_cf -!> @brief called during advance (*_ad), to copy the data -!! from the models into the connection's placeholder arrays -!< - subroutine syncInterfaceModel(this) - class(GweGweConnectionType) :: this !< the connection - ! local - integer(I4B) :: i, n, m, ipos, iposLoc, idx - type(ConnectionsType), pointer :: imCon !< interface model connections - type(GlobalCellType), dimension(:), pointer :: toGlobal !< map interface index to global cell - type(GlobalCellType), pointer :: boundaryCell, connectedCell - class(GweModelType), pointer :: gweModel - class(*), pointer :: modelPtr - - ! for readability - imCon => this%gweInterfaceModel%dis%con - toGlobal => this%gridConnection%idxToGlobal - - ! loop over connections in interface - do n = 1, this%neq - do ipos = imCon%ia(n) + 1, imCon%ia(n + 1) - 1 - m = imCon%ja(ipos) - if (associated(toGlobal(n)%model, toGlobal(m)%model)) then - ! internal connection for a model, copy from its flowja - iposLoc = getCSRIndex(toGlobal(n)%index, toGlobal(m)%index, & - toGlobal(n)%model%ia, toGlobal(n)%model%ja) - modelPtr => toGlobal(n)%model - gweModel => CastAsGweModel(modelPtr) - this%gwfflowja(ipos) = gweModel%fmi%gwfflowja(iposLoc) - end if - end do - end do - - ! the flowja for exchange cells - do i = 1, this%gridConnection%nrOfBoundaryCells - boundaryCell => this%gridConnection%boundaryCells(i)%cell - connectedCell => this%gridConnection%connectedCells(i)%cell - n = this%gridConnection%getInterfaceIndex(boundaryCell%index, & - boundaryCell%model) - m = this%gridConnection%getInterfaceIndex(connectedCell%index, & - connectedCell%model) - ipos = getCSRIndex(n, m, imCon%ia, imCon%ja) - this%gwfflowja(ipos) = this%exgflowja(i) * this%exgflowSign - ipos = getCSRIndex(m, n, imCon%ia, imCon%ja) - this%gwfflowja(ipos) = -this%exgflowja(i) * this%exgflowSign - end do - - ! copy concentrations - do i = 1, this%gridConnection%nrOfCells - idx = this%gridConnection%idxToGlobal(i)%index - this%x(i) = this%gridConnection%idxToGlobal(i)%model%x(idx) - this%gweInterfaceModel%xold(i) = & - this%gridConnection%idxToGlobal(i)%model%xold(idx) - end do - - ! copy fmi - do i = 1, this%gridConnection%nrOfCells - idx = this%gridConnection%idxToGlobal(i)%index - modelPtr => this%gridConnection%idxToGlobal(i)%model - gweModel => CastAsGweModel(modelPtr) - - this%gwfsat(i) = gweModel%fmi%gwfsat(idx) - this%gwfhead(i) = gweModel%fmi%gwfhead(idx) - this%gwfspdis(1, i) = gweModel%fmi%gwfspdis(1, idx) - this%gwfspdis(2, i) = gweModel%fmi%gwfspdis(2, idx) - this%gwfspdis(3, i) = gweModel%fmi%gwfspdis(3, idx) - end do - - end subroutine syncInterfaceModel - subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) class(GweGweConnectionType) :: this !< the connection integer(I4B), intent(in) :: kiter !< the iteration counter @@ -489,13 +424,12 @@ subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) do n = 1, this%neq ! We only need the coefficients for our own model ! (i.e. rows in the matrix that belong to this%owner): - if (.not. associated(this%gridConnection%idxToGlobal(n)%model, & - this%owner)) then + if (.not. this%gridConnection%idxToGlobal(n)%dmodel == this%owner) then cycle end if nglo = this%gridConnection%idxToGlobal(n)%index + & - this%gridConnection%idxToGlobal(n)%model%moffset + this%gridConnection%idxToGlobal(n)%dmodel%moffset rhssln(nglo) = rhssln(nglo) + this%rhs(n) do ipos = this%ia(n), this%ia(n + 1) - 1 @@ -526,27 +460,22 @@ end subroutine gwegwecon_cq !> @brief Set the flows (flowja from interface model) to the !< simvals in the exchange, leaving the budget calcution in there subroutine setFlowToExchange(this) + use InterfaceMapModule class(GweGweConnectionType) :: this !< this connection ! local integer(I4B) :: i - integer(I4B) :: nIface, mIface, ipos class(GweExchangeType), pointer :: gweEx + type(IndexMapSgnType), pointer :: map - gweEx => this%gweExchange if (this%exchangeIsOwned) then - do i = 1, gweEx%nexg - gweEx%simvals(i) = DZERO - - if (gweEx%gwemodel1%ibound(gweEx%nodem1(i)) /= 0 .and. & - gweEx%gwemodel2%ibound(gweEx%nodem2(i)) /= 0) then - nIface = this%gridConnection%getInterfaceIndex(gweEx%nodem1(i), & - gweEx%model1) - mIface = this%gridConnection%getInterfaceIndex(gweEx%nodem2(i), & - gweEx%model2) - ipos = getCSRIndex(nIface, mIface, this%gweInterfaceModel%ia, & - this%gweInterfaceModel%ja) - gweEx%simvals(i) = this%gweInterfaceModel%flowja(ipos) - end if + gweEx => this%gweExchange + map => this%interfaceMap%exchange_map(this%interfaceMap%prim_exg_idx) + + ! use (half of) the exchnage map in reverse: + do i = 1, size(map%src_idx) + if (map%sign(i) < 0) cycle ! simvals is defined from exg%m1 => exg%m2 + gweEx%simvals(map%src_idx(i)) = & + this%gweInterfaceModel%flowja(map%tgt_idx(i)) end do end if @@ -590,11 +519,7 @@ subroutine gwegwecon_da(this) call mem_deallocate(this%exgflowSign) ! arrays - call mem_deallocate(this%gwfflowja) - call mem_deallocate(this%gwfsat) - call mem_deallocate(this%gwfhead) - call mem_deallocate(this%gwfspdis) - call mem_deallocate(this%exgflowjaGwt) + call mem_deallocate(this%exgflowjaGwe) ! interface model call this%gweInterfaceModel%model_da() diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 3523c6fe767..68177810247 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -1,6 +1,6 @@ module GweInterfaceModelModule use KindModule, only: I4B, DP - use MemoryManagerModule, only: mem_allocate, mem_deallocate + use MemoryManagerModule, only: mem_allocate, mem_deallocate, mem_reallocate use MemoryHelperModule, only: create_mem_path use NumericalModelModule, only: NumericalModelType use GweModule, only: GweModelType, CastAsGweModel @@ -10,7 +10,7 @@ module GweInterfaceModelModule use TspAdvOptionsModule, only: TspAdvOptionsType use GweDspModule, only: dsp_cr, GweDspType use GweDspOptionsModule, only: GweDspOptionsType - use GweDspGridDataModule, only: GweDspGridDataType + use GweMstModule, only: mst_cr use TspObsModule, only: tsp_obs_cr use GridConnectionModule @@ -37,8 +37,8 @@ module GweInterfaceModelModule procedure :: model_df => gweifmod_df procedure :: model_ar => gweifmod_ar procedure :: model_da => gweifmod_da + procedure, public :: allocate_fmi procedure :: allocate_scalars - procedure :: setDspGridData end type GweInterfaceModelType contains @@ -83,7 +83,7 @@ subroutine gweifmod_cr(this, name, iout, gridConn) call disu_cr(this%dis, this%name, -1, this%iout) call fmi_cr(this%fmi, this%name, 0, this%iout) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, dsp_unit, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) call tsp_obs_cr(this%obs, inobs) end subroutine gweifmod_cr @@ -99,6 +99,20 @@ subroutine allocate_scalars(this, modelname) end subroutine allocate_scalars + subroutine allocate_fmi(this) + class(GweInterfaceModelType) :: this !< the GWT interface model + + call mem_allocate(this%fmi%gwfflowja, this%nja, 'GWFFLOWJA', & + this%fmi%memoryPath) + call mem_allocate(this%fmi%gwfhead, this%neq, 'GWFHEAD', & + this%fmi%memoryPath) + call mem_allocate(this%fmi%gwfsat, this%neq, 'GWFSAT', & + this%fmi%memoryPath) + call mem_allocate(this%fmi%gwfspdis, 3, this%neq, 'GWFSPDIS', & + this%fmi%memoryPath) + + end subroutine allocate_fmi + !> @brief Define the GWE interface model !< subroutine gweifmod_df(this) @@ -107,7 +121,6 @@ subroutine gweifmod_df(this) class(*), pointer :: disPtr type(TspAdvOptionsType) :: adv_options type(GweDspOptionsType) :: dsp_options - integer(I4B) :: i this%moffset = 0 adv_options%iAdvScheme = this%iAdvScheme @@ -122,7 +135,32 @@ subroutine gweifmod_df(this) call this%adv%adv_df(adv_options) end if if (this%indsp > 0) then + this%dsp%idiffc = this%owner%dsp%idiffc + this%dsp%idisp = this%owner%dsp%idisp call this%dsp%dsp_df(this%dis, dsp_options) + if (this%dsp%idiffc > 0) then + call mem_reallocate(this%dsp%diffc, this%dis%nodes, 'DIFFC', & + trim(this%dsp%memoryPath)) + end if + if (this%dsp%idisp > 0) then + call mem_reallocate(this%dsp%alh, this%dis%nodes, 'ALH', & + trim(this%dsp%memoryPath)) + call mem_reallocate(this%dsp%alv, this%dis%nodes, 'ALV', & + trim(this%dsp%memoryPath)) + call mem_reallocate(this%dsp%ath1, this%dis%nodes, 'ATH1', & + trim(this%dsp%memoryPath)) + call mem_reallocate(this%dsp%ath2, this%dis%nodes, 'ATH2', & + trim(this%dsp%memoryPath)) + call mem_reallocate(this%dsp%atv, this%dis%nodes, 'ATV', & + trim(this%dsp%memoryPath)) + call mem_reallocate(this%dsp%ktw, this%dis%nodes, 'KTW', & + trim(this%dsp%memoryPath)) + call mem_reallocate(this%dsp%kts, this%dis%nodes, 'KTS', & + trim(this%dsp%memoryPath)) + end if + allocate (this%mst) + call mem_allocate(this%mst%porosity, this%dis%nodes, & + 'POROSITY', create_mem_path(this%name, 'MST')) end if ! assign or point model members to dis members @@ -133,14 +171,6 @@ subroutine gweifmod_df(this) ! ! allocate model arrays, now that neq and nja are assigned call this%allocate_arrays() - call mem_allocate(this%porosity, this%neq, 'POROSITY', this%memoryPath) - - do i = 1, size(this%flowja) - this%flowja = 0.0_DP - end do - do i = 1, this%neq - this%porosity = 0.0_DP - end do end subroutine gweifmod_df @@ -149,54 +179,18 @@ end subroutine gweifmod_df !< files subroutine gweifmod_ar(this) class(GweInterfaceModelType) :: this !< the GWE interface model - ! local - type(GweDspGridDataType) :: dspGridData call this%fmi%fmi_ar(this%ibound) if (this%inadv > 0) then call this%adv%adv_ar(this%dis, this%ibound) end if if (this%indsp > 0) then - this%dsp%idiffc = this%owner%dsp%idiffc - this%dsp%idisp = this%owner%dsp%idisp - call dspGridData%construct(this%neq) - call this%setDspGridData(dspGridData) call this%dsp%dsp_ar(this%ibound, this%porosity, this%dsp%cpw, & - this%dsp%rhow, dspGridData) + this%dsp%rhow) end if end subroutine gweifmod_ar -!> @brief set dsp grid data from models -!< - subroutine setDspGridData(this, gridData) - class(GweInterfaceModelType) :: this !< the GWE interface model - type(GweDspGridDataType) :: gridData !< the dsp grid data to be set - ! local - integer(I4B) :: i, idx - class(GweModelType), pointer :: gweModel - class(*), pointer :: modelPtr - - do i = 1, this%neq - modelPtr => this%gridConnection%idxToGlobal(i)%model - gweModel => CastAsGweModel(modelPtr) - idx = this%gridConnection%idxToGlobal(i)%index - - if (this%dsp%idiffc > 0) then - gridData%diffc(i) = gweModel%dsp%diffc(idx) - end if - if (this%dsp%idisp > 0) then - gridData%alh(i) = gweModel%dsp%alh(idx) - gridData%alv(i) = gweModel%dsp%alv(idx) - gridData%ath1(i) = gweModel%dsp%ath1(idx) - gridData%ath2(i) = gweModel%dsp%ath2(idx) - gridData%atv(i) = gweModel%dsp%atv(idx) - end if - - end do - - end subroutine setDspGridData - !> @brief Clean up resources !< subroutine gweifmod_da(this) @@ -205,7 +199,6 @@ subroutine gweifmod_da(this) ! this call mem_deallocate(this%iAdvScheme) call mem_deallocate(this%ixt3d) - call mem_deallocate(this%porosity) ! gwe packages call this%dis%dis_da() @@ -217,6 +210,11 @@ subroutine gweifmod_da(this) deallocate (this%fmi) deallocate (this%adv) deallocate (this%dsp) + + if (associated(this%mst)) then + call mem_deallocate(this%mst%porosity) + deallocate (this%mst) + end if ! gwe scalars call mem_deallocate(this%inic) diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 5dcfb231014..77c7a744d35 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -84,7 +84,7 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) call fmi_cr(this%fmi, this%name, 0, this%iout) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) - call gwt_obs_cr(this%obs, inobs) + call tsp_obs_cr(this%obs, inobs) end subroutine gwtifmod_cr diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 4d351559e2d..7b96b2d5266 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -7,7 +7,6 @@ module GweDspModule use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr use GweDspOptionsModule, only: GweDspOptionsType - use GweDspGridDataModule, only: GweDspGridDataType implicit none private @@ -63,7 +62,6 @@ module GweDspModule procedure :: allocate_arrays procedure, private :: read_options procedure, private :: read_data - procedure, private :: set_data procedure, private :: calcdispellipse procedure, private :: calcdispcoef @@ -201,7 +199,7 @@ subroutine dsp_mc(this, moffset, iasln, jasln) return end subroutine dsp_mc - subroutine dsp_ar(this, ibound, porosity, cpw, rhow, grid_data) + subroutine dsp_ar(this, ibound, porosity, cpw, rhow) ! ****************************************************************************** ! dsp_ar -- Allocate and Read ! ****************************************************************************** @@ -215,8 +213,6 @@ subroutine dsp_ar(this, ibound, porosity, cpw, rhow, grid_data) real(DP), dimension(:), pointer, contiguous :: porosity real(DP), dimension(:), pointer, contiguous :: cpw real(DP), dimension(:), pointer, contiguous :: rhow - type(GweDspGridDataType), optional, intent(in) :: grid_data !< optional data structure with DSP grid data, - !! to create the package without input file ! -- local ! -- formats character(len=*), parameter :: fmtdsp = & @@ -230,22 +226,6 @@ subroutine dsp_ar(this, ibound, porosity, cpw, rhow, grid_data) this%cpw => cpw this%rhow => rhow ! - ! -- Print a message identifying the dispersion package. - if (this%iout > 0) then - write (this%iout, fmtdsp) this%inunit - end if - ! - ! -- Allocate arrays - call this%allocate_arrays(this%dis%nodes) - ! - if (present(grid_data)) then - ! -- Set dispersion data - call this%set_data(grid_data) - else - ! -- Read dispersion data - call this%read_data() - end if - ! ! -- Return return end subroutine dsp_ar @@ -751,47 +731,6 @@ subroutine read_data(this) return end subroutine read_data - !< @brief Set the grid data to the package - !< - subroutine set_data(this, grid_data) - use MemoryManagerModule, only: mem_reallocate - class(GweDspType) :: this !< this DSP package - type(GweDspGridDataType), intent(in) :: grid_data !< the data structure with DSP grid data - ! local - integer(I4B) :: i - - call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & - trim(this%memoryPath)) - call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & - trim(this%memoryPath)) - call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & - trim(this%memoryPath)) - call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & - trim(this%memoryPath)) - call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & - trim(this%memoryPath)) - call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & - trim(this%memoryPath)) - call mem_reallocate(this%ktw, this%dis%nodes, 'KTW', & - trim(this%memoryPath)) - call mem_reallocate(this%kts, this%dis%nodes, 'KTS', & - trim(this%memoryPath)) - - do i = 1, this%dis%nodes - this%diffc(i) = grid_data%diffc(i) - this%alh(i) = grid_data%alh(i) - this%alv(i) = grid_data%alv(i) - this%ath1(i) = grid_data%ath1(i) - this%ath2(i) = grid_data%ath2(i) - this%atv(i) = grid_data%atv(i) - this%ktw(i) = grid_data%ktw(i) - this%kts(i) = grid_data%kts(i) - this%cpw(i) = grid_data%cpw(i) ! TODO: May need to check that mst is active - this%rhow(i) = grid_data%rhow(i) - end do - - end subroutine - subroutine calcdispellipse(this) ! ****************************************************************************** ! calcdispellipse -- Calculate dispersion coefficients diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index f5d70a1a057..bf9bf1837ba 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -250,6 +250,7 @@ subroutine models_create() ! -- modules use GwfModule, only: gwf_cr use GwtModule, only: gwt_cr + use GweModule, only: gwe_cr use ConstantsModule, only: LENMODELNAME ! -- dummy ! -- local @@ -282,6 +283,11 @@ subroutine models_create() call add_model(im, 'GWT6', mname) call gwt_cr(fname, im, modelname(im)) call add_dist_model(im) + case ('GWE6') + call parser%GetString(fname) + call add_model(im, 'GWE6', mname) + call gwe_cr(fname, im, modelname(im)) + call add_dist_model(im) case default write (errmsg, '(4x,a,a)') & '****ERROR. UNKNOWN SIMULATION MODEL: ', & @@ -308,6 +314,7 @@ subroutine exchanges_create() use GwfGwfExchangeModule, only: gwfexchange_create use GwfGwtExchangeModule, only: gwfgwt_cr use GwtGwtExchangeModule, only: gwtexchange_create + use GwfGweExchangeModule, only: gwfgwe_cr ! -- dummy ! -- local integer(I4B) :: ierr @@ -362,6 +369,8 @@ subroutine exchanges_create() call gwfgwt_cr(fname, id, m1, m2) case ('GWT6-GWT6') call gwtexchange_create(fname, id, m1, m2) + case ('GWF6-GWE6') + call gwfgwe_cr(fname, id, m1, m2) case default write (errmsg, '(4x,a,a)') & '****ERROR. UNKNOWN SIMULATION EXCHANGES: ', & From 34a411b432c9049d6a5258c96cad31eed0973fd7 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 23 Nov 2022 08:26:39 -0800 Subject: [PATCH 050/212] Upload GWE-related definition files (.dfn) --- doc/mf6io/mf6ivar/dfn/exg-gwegwe.dfn | 275 +++++++++++++++++++++++ doc/mf6io/mf6ivar/dfn/exg-gwfgwe.dfn | 3 + doc/mf6io/mf6ivar/dfn/gwe-adv.dfn | 11 + doc/mf6io/mf6ivar/dfn/gwe-dis.dfn | 122 +++++++++++ doc/mf6io/mf6ivar/dfn/gwe-disv.dfn | 202 +++++++++++++++++ doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn | 102 +++++++++ doc/mf6io/mf6ivar/dfn/gwe-fmi.dfn | 58 +++++ doc/mf6io/mf6ivar/dfn/gwe-ic.dfn | 11 + doc/mf6io/mf6ivar/dfn/gwe-mst.dfn | 83 +++++++ doc/mf6io/mf6ivar/dfn/gwe-nam.dfn | 73 +++++++ doc/mf6io/mf6ivar/dfn/gwe-oc.dfn | 313 +++++++++++++++++++++++++++ doc/mf6io/mf6ivar/dfn/gwe-src.dfn | 205 ++++++++++++++++++ doc/mf6io/mf6ivar/dfn/gwe-ssm.dfn | 122 +++++++++++ doc/mf6io/mf6ivar/dfn/gwe-tmp.dfn | 206 ++++++++++++++++++ msvs/mf6core.vfproj | 32 ++- 15 files changed, 1807 insertions(+), 11 deletions(-) create mode 100644 doc/mf6io/mf6ivar/dfn/exg-gwegwe.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/exg-gwfgwe.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-adv.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-dis.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-disv.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-fmi.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-ic.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-mst.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-nam.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-oc.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-src.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-ssm.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-tmp.dfn diff --git a/doc/mf6io/mf6ivar/dfn/exg-gwegwe.dfn b/doc/mf6io/mf6ivar/dfn/exg-gwegwe.dfn new file mode 100644 index 00000000000..8b92f636de8 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/exg-gwegwe.dfn @@ -0,0 +1,275 @@ +# --------------------- exg gwegwe options --------------------- +# flopy multi-package + +block options +name gwfmodelname1 +type string +reader urword +optional false +longname keyword to specify name of first corresponding GWF Model +description keyword to specify name of first corresponding GWF Model. In the simulation name file, the GWE6-GWE6 entry contains names for GWE Models (exgmnamea and exgmnameb). The GWE Model with the name exgmnamea must correspond to the GWF Model with the name gwfmodelname1. + +block options +name gwfmodelname2 +type string +reader urword +optional false +longname keyword to specify name of second corresponding GWF Model +description keyword to specify name of second corresponding GWF Model. In the simulation name file, the GWE6-GWE6 entry contains names for GWE Models (exgmnamea and exgmnameb). The GWE Model with the name exgmnameb must correspond to the GWF Model with the name gwfmodelname2. + +block options +name auxiliary +type string +shape (naux) +reader urword +optional true +longname keyword to specify aux variables +description an array of auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided. Most auxiliary variables will not be used by the GWF-GWF Exchange, but they will be available for use by other parts of the program. If an auxiliary variable with the name ``ANGLDEGX'' is found, then this information will be used as the angle (provided in degrees) between the connection face normal and the x axis, where a value of zero indicates that a normal vector points directly along the positive x axis. The connection face normal is a normal vector on the cell face shared between the cell in model 1 and the cell in model 2 pointing away from the model 1 cell. Additional information on ``ANGLDEGX'' is provided in the description of the DISU Package. If an auxiliary variable with the name ``CDIST'' is found, then this information will be used as the straight-line connection distance, including the vertical component, between the two cell centers. Both ANGLDEGX and CDIST are required if specific discharge is calculated for either of the groundwater models. + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'GWE Exchange'} + +block options +name print_input +type keyword +reader urword +optional true +longname keyword to print input to list file +description keyword to indicate that the list of exchange entries will be echoed to the listing file immediately after it is read. + +block options +name print_flows +type keyword +reader urword +optional true +longname keyword to print gwfgwf flows to list file +description keyword to indicate that the list of exchange flow rates will be printed to the listing file for every stress period in which ``SAVE BUDGET'' is specified in Output Control. + +block options +name save_flows +type keyword +reader urword +optional true +longname keyword to save GWFGWF flows +description keyword to indicate that cell-by-cell flow terms will be written to the budget file for each model provided that the Output Control for the models are set up with the ``BUDGET SAVE FILE'' option. + +block options +name adv_scheme +type string +valid upstream central tvd +reader urword +optional true +longname advective scheme +description scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. + +block options +name dsp_xt3d_off +type keyword +shape +reader urword +optional true +longname deactivate xt3d +description deactivate the xt3d method for the dispersive flux and use the faster and less accurate approximation for this exchange. + +block options +name dsp_xt3d_rhs +type keyword +shape +reader urword +optional true +longname xt3d on right-hand side +description add xt3d dispersion terms to right-hand side, when possible, for this exchange. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name mvt_filerecord +type record mvt6 filein mvt6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name mvt6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to a transport mover file. + +block options +name mvt6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname mvt6 input filename +description is the file name of the transport mover input file to apply to this exchange. Information for the transport mover are provided in the file provided with these keywords. + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description is the file name of the observations input file for this exchange. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:gwe-obstypetable} lists observation type(s) supported by the GWE-GWE package. + +block options +name dev_interfacemodel_on +type keyword +reader urword +optional true +longname activate interface model on exchange +description activates the interface model mechanism for calculating the coefficients at (and possibly near) the exchange. This keyword should only be used for development purposes. + +# --------------------- exg gwegwe dimensions --------------------- + +block dimensions +name nexg +type integer +reader urword +optional false +longname number of exchanges +description keyword and integer value specifying the number of GWE-GWE exchanges. + + +# --------------------- exg gwegwe exchangedata --------------------- + +block exchangedata +name exchangedata +type recarray cellidm1 cellidm2 ihc cl1 cl2 hwva aux boundname +reader urword +optional false +longname exchange data +description + +block exchangedata +name cellidm1 +type integer +in_record true +tagged false +reader urword +optional false +longname cellid of first cell +description is the cellid of the cell in model 1 as specified in the simulation name file. For a structured grid that uses the DIS input file, CELLIDM1 is the layer, row, and column numbers of the cell. For a grid that uses the DISV input file, CELLIDM1 is the layer number and CELL2D number for the two cells. If the model uses the unstructured discretization (DISU) input file, then CELLIDM1 is the node number for the cell. +numeric_index true + +block exchangedata +name cellidm2 +type integer +in_record true +tagged false +reader urword +optional false +longname cellid of second cell +description is the cellid of the cell in model 2 as specified in the simulation name file. For a structured grid that uses the DIS input file, CELLIDM2 is the layer, row, and column numbers of the cell. For a grid that uses the DISV input file, CELLIDM2 is the layer number and CELL2D number for the two cells. If the model uses the unstructured discretization (DISU) input file, then CELLIDM2 is the node number for the cell. +numeric_index true + +block exchangedata +name ihc +type integer +in_record true +tagged false +reader urword +optional false +longname integer flag for connection type +description is an integer flag indicating the direction between node n and all of its m connections. If IHC = 0 then the connection is vertical. If IHC = 1 then the connection is horizontal. If IHC = 2 then the connection is horizontal for a vertically staggered grid. + +block exchangedata +name cl1 +type double precision +in_record true +tagged false +reader urword +optional false +longname connection distance +description is the distance between the center of cell 1 and the its shared face with cell 2. + +block exchangedata +name cl2 +type double precision +in_record true +tagged false +reader urword +optional false +longname connection distance +description is the distance between the center of cell 2 and the its shared face with cell 1. + +block exchangedata +name hwva +type double precision +in_record true +tagged false +reader urword +optional false +longname horizontal cell width or area for vertical flow +description is the horizontal width of the flow connection between cell 1 and cell 2 if IHC $>$ 0, or it is the area perpendicular to flow of the vertical connection between cell 1 and cell 2 if IHC = 0. + +block exchangedata +name aux +type double precision +in_record true +tagged false +shape (naux) +reader urword +optional true +longname auxiliary variables +description represents the values of the auxiliary variables for each GWEGWE Exchange. The values of auxiliary variables must be present for each exchange. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. + +block exchangedata +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname exchange boundname +description REPLACE boundname {'{#1}': 'GWE Exchange'} diff --git a/doc/mf6io/mf6ivar/dfn/exg-gwfgwe.dfn b/doc/mf6io/mf6ivar/dfn/exg-gwfgwe.dfn new file mode 100644 index 00000000000..fe5410261fc --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/exg-gwfgwe.dfn @@ -0,0 +1,3 @@ +# --------------------- exg gwfgwe options --------------------- + + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-adv.dfn b/doc/mf6io/mf6ivar/dfn/gwe-adv.dfn new file mode 100644 index 00000000000..682ed4a756a --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-adv.dfn @@ -0,0 +1,11 @@ +# --------------------- gwe adv options --------------------- + +block options +name scheme +type string +valid central upstream tvd +reader urword +optional true +longname advective scheme +description scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-dis.dfn b/doc/mf6io/mf6ivar/dfn/gwe-dis.dfn new file mode 100644 index 00000000000..bb77bac782e --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-dis.dfn @@ -0,0 +1,122 @@ +# --------------------- gwe dis options --------------------- + +block options +name length_units +type string +reader urword +optional true +longname model length units +description is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. + +block options +name nogrb +type keyword +reader urword +optional true +longname do not write binary grid file +description keyword to deactivate writing of the binary grid file. + +block options +name xorigin +type double precision +reader urword +optional true +longname x-position of the model grid origin +description x-position of the lower-left corner of the model grid. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name yorigin +type double precision +reader urword +optional true +longname y-position of the model grid origin +description y-position of the lower-left corner of the model grid. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name angrot +type double precision +reader urword +optional true +longname rotation angle +description counter-clockwise rotation angle (in degrees) of the lower-left corner of the model grid. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + + +# --------------------- gwe dis dimensions --------------------- + +block dimensions +name nlay +type integer +reader urword +optional false +longname number of layers +description is the number of layers in the model grid. +default_value 1 + +block dimensions +name nrow +type integer +reader urword +optional false +longname number of rows +description is the number of rows in the model grid. +default_value 2 + +block dimensions +name ncol +type integer +reader urword +optional false +longname number of columns +description is the number of columns in the model grid. +default_value 2 + +# --------------------- gwe dis griddata --------------------- + +block griddata +name delr +type double precision +shape (ncol) +reader readarray +longname spacing along a row +description is the column spacing in the row direction. +default_value 1.0 + +block griddata +name delc +type double precision +shape (nrow) +reader readarray +longname spacing along a column +description is the row spacing in the column direction. +default_value 1.0 + +block griddata +name top +type double precision +shape (ncol, nrow) +reader readarray +longname cell top elevation +description is the top elevation for each cell in the top model layer. +default_value 1.0 + +block griddata +name botm +type double precision +shape (ncol, nrow, nlay) +reader readarray +layered true +longname cell bottom elevation +description is the bottom elevation for each cell. +default_value 0. + +block griddata +name idomain +type integer +shape (ncol, nrow, nlay) +reader readarray +layered true +optional true +longname idomain existence array +description is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. + + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-disv.dfn b/doc/mf6io/mf6ivar/dfn/gwe-disv.dfn new file mode 100644 index 00000000000..dcb84895d91 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-disv.dfn @@ -0,0 +1,202 @@ +# --------------------- gwe disv options --------------------- + +block options +name length_units +type string +reader urword +optional true +longname model length units +description is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. + +block options +name nogrb +type keyword +reader urword +optional true +longname do not write binary grid file +description keyword to deactivate writing of the binary grid file. + +block options +name xorigin +type double precision +reader urword +optional true +longname x-position origin of the model grid coordinate system +description x-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name yorigin +type double precision +reader urword +optional true +longname y-position origin of the model grid coordinate system +description y-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name angrot +type double precision +reader urword +optional true +longname rotation angle +description counter-clockwise rotation angle (in degrees) of the model grid coordinate system relative to a real-world coordinate system. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +# --------------------- gwe disv dimensions --------------------- + +block dimensions +name nlay +type integer +reader urword +optional false +longname number of layers +description is the number of layers in the model grid. + +block dimensions +name ncpl +type integer +reader urword +optional false +longname number of cells per layer +description is the number of cells per layer. This is a constant value for the grid and it applies to all layers. + +block dimensions +name nvert +type integer +reader urword +optional false +longname number of columns +description is the total number of (x, y) vertex pairs used to characterize the horizontal configuration of the model grid. + +# --------------------- gwe disv griddata --------------------- + +block griddata +name top +type double precision +shape (ncpl) +reader readarray +longname model top elevation +description is the top elevation for each cell in the top model layer. + +block griddata +name botm +type double precision +shape (nlay, ncpl) +reader readarray +layered true +longname model bottom elevation +description is the bottom elevation for each cell. + +block griddata +name idomain +type integer +shape (nlay, ncpl) +reader readarray +layered true +optional true +longname idomain existence array +description is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. + + +# --------------------- gwe disv vertices --------------------- + +block vertices +name vertices +type recarray iv xv yv +reader urword +optional false +longname vertices data +description + +block vertices +name iv +type integer +in_record true +tagged false +reader urword +optional false +longname vertex number +description is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. +numeric_index true + +block vertices +name xv +type double precision +in_record true +tagged false +reader urword +optional false +longname x-coordinate for vertex +description is the x-coordinate for the vertex. + +block vertices +name yv +type double precision +in_record true +tagged false +reader urword +optional false +longname y-coordinate for vertex +description is the y-coordinate for the vertex. + + +# --------------------- gwe disv cell2d --------------------- + +block cell2d +name cell2d +type recarray icell2d xc yc ncvert icvert +reader urword +optional false +longname cell2d data +description + +block cell2d +name icell2d +type integer +in_record true +tagged false +reader urword +optional false +longname cell2d number +description is the CELL2D number. Records in the CELL2D block must be listed in consecutive order from the first to the last. +numeric_index true + +block cell2d +name xc +type double precision +in_record true +tagged false +reader urword +optional false +longname x-coordinate for cell center +description is the x-coordinate for the cell center. + +block cell2d +name yc +type double precision +in_record true +tagged false +reader urword +optional false +longname y-coordinate for cell center +description is the y-coordinate for the cell center. + +block cell2d +name ncvert +type integer +in_record true +tagged false +reader urword +optional false +longname number of cell vertices +description is the number of vertices required to define the cell. There may be a different number of vertices for each cell. + +block cell2d +name icvert +type integer +shape (ncvert) +in_record true +tagged false +reader urword +optional false +longname array of vertex numbers +description is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. Cells that are connected must share vertices. +numeric_index true diff --git a/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn b/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn new file mode 100644 index 00000000000..bf979a9b31e --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn @@ -0,0 +1,102 @@ +# --------------------- gwe dsp options --------------------- + +block options +name xt3d_off +type keyword +shape +reader urword +optional true +longname deactivate xt3d +description deactivate the xt3d method and use the faster and less accurate approximation. This option may provide a fast and accurate solution under some circumstances, such as when flow aligns with the model grid, there is no mechanical dispersion, or when the longitudinal and transverse dispersivities are equal. This option may also be used to assess the computational demand of the XT3D approach by noting the run time differences with and without this option on. + +block options +name xt3d_rhs +type keyword +shape +reader urword +optional true +longname xt3d on right-hand side +description add xt3d terms to right-hand side, when possible. This option uses less memory, but may require more iterations. + +# --------------------- gwe dsp griddata --------------------- + +block griddata +name diffc +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname effective molecular diffusion coefficient +description effective molecular diffusion coefficient. + +block griddata +name alh +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname longitudinal dispersivity in horizontal direction +description longitudinal dispersivity in horizontal direction. If flow is strictly horizontal, then this is the longitudinal dispersivity that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. + +block griddata +name alv +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname longitudinal dispersivity in vertical direction +description longitudinal dispersivity in vertical direction. If flow is strictly vertical, then this is the longitudinal dispsersivity value that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ALH. + +block griddata +name ath1 +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname transverse dispersivity in horizontal direction +description transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the second ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the y direction. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. + +block griddata +name ath2 +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname transverse dispersivity in horizontal direction +description transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the third ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the z direction. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH1. + +block griddata +name atv +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname transverse dispersivity when flow is in vertical direction +description transverse dispersivity when flow is in vertical direction. If flow is strictly vertical and directed in the z direction, then this value controls spreading in the x and y directions. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH2. + +block griddata +name ktw +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname thermal conductivity of water +description thermal conductivity of water + +block griddata +name kts +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname thermal conductivity of the aquifer material +description thermal conductivity of the aquifer material + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-fmi.dfn b/doc/mf6io/mf6ivar/dfn/gwe-fmi.dfn new file mode 100644 index 00000000000..274002ab479 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-fmi.dfn @@ -0,0 +1,58 @@ +# --------------------- gwe fmi options --------------------- + +block options +name save_flows +type keyword +reader urword +optional true +longname save calculated flow imbalance correction to budget file +description REPLACE save_flows {'{#1}': 'FMI'} + +block options +name flow_imbalance_correction +type keyword +reader urword +optional true +longname correct for flow imbalance +description correct for an imbalance in flows by assuming that any residual flow error comes in or leaves at the concentration of the cell. When this option is activated, the GWT Model budget written to the listing file will contain two additional entries: FLOW-ERROR and FLOW-CORRECTION. These two entries will be equal but opposite in sign. The FLOW-CORRECTION term is a mass flow that is added to offset the error caused by an imprecise flow balance. If these terms are not relatively small, the flow model should be rerun with stricter convergence tolerances. + +# --------------------- gwe fmi packagedata --------------------- + +block packagedata +name packagedata +type recarray flowtype filein fname +reader urword +optional false +longname flowtype list +description + +block packagedata +name flowtype +in_record true +type string +tagged false +reader urword +longname flow type +description is the word GWFBUDGET, GWFHEAD, GWFMOVER or the name of an advanced GWF stress package. If GWFBUDGET is specified, then the corresponding file must be a budget file from a previous GWF Model run. If an advanced GWF stress package name appears then the corresponding file must be the budget file saved by a LAK, SFR, MAW or UZF Package. + +block packagedata +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block packagedata +name fname +in_record true +type string +preserve_case true +tagged false +reader urword +longname file name +description is the name of the file containing flows. The path to the file should be included if the file is not located in the folder where the program was run. + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-ic.dfn b/doc/mf6io/mf6ivar/dfn/gwe-ic.dfn new file mode 100644 index 00000000000..0cda10416ba --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-ic.dfn @@ -0,0 +1,11 @@ +# --------------------- gwe ic griddata --------------------- + +block griddata +name strt +type double precision +shape (nodes) +reader readarray +layered true +longname starting temperature +description is the initial (starting) temperature---that is, the temperature at the beginning of the GWE Model simulation. STRT must be specified for all GWE Model simulations. One value is read for every model cell. +default_value 0.0 diff --git a/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn b/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn new file mode 100644 index 00000000000..3a1934677ad --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn @@ -0,0 +1,83 @@ +# --------------------- gwe mst options --------------------- + +block options +name save_flows +type keyword +reader urword +optional true +longname save calculated flows to budget file +description REPLACE save_flows {'{#1}': 'MST'} + +block options +name first_order_decay +type keyword +reader urword +optional true +longname activate first-order decay +description is a text keyword to indicate that first-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. + +block options +name zero_order_decay +type keyword +reader urword +optional true +longname activate zero-order decay +description is a text keyword to indicate that zero-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. + +# --------------------- gwe mst griddata --------------------- + +block griddata +name porosity +type double precision +shape (nodes) +reader readarray +layered true +longname porosity +description is the aquifer porosity. + +block griddata +name decay +type double precision +shape (nodes) +reader readarray +layered true +optional true +longname aqueous phase decay rate coefficient +description is the rate coefficient for first or zero-order decay for the aqueous phase of the mobile domain. A negative value indicates solute production. The dimensions of decay for first-order decay is one over time. The dimensions of decay for zero-order decay is mass per length cubed per time. decay will have no effect on simulation results unless either first- or zero-order decay is specified in the options block. + +block griddata +name cpw +type double precision +shape (nodes) +reader readarray +layered true +longname heat capacity of water +description is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. + +block griddata +name cps +type double precision +shape (nodes) +reader readarray +layered true +longname heat capacity of the aquifer material +description is the mass-based heat capacity of dry solids (aquifer material). Thus, enter value in units of J/kg/C + +block griddata +name rhow +type double precision +shape (nodes) +reader readarray +layered true +longname density of water +description is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 + +block griddata +name rhos +type double precision +shape (nodes) +reader readarray +layered true +longname density of aquifer material +description is a user-specified value of the density of aquifer material no considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-nam.dfn b/doc/mf6io/mf6ivar/dfn/gwe-nam.dfn new file mode 100644 index 00000000000..dc11fb20db3 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-nam.dfn @@ -0,0 +1,73 @@ +# --------------------- gwe nam options --------------------- + +block options +name list +type string +reader urword +optional true +longname name of listing file +description is name of the listing file to create for this GWE model. If not specified, then the name of the list file will be the basename of the GWE model name file and the '.lst' extension. For example, if the GWE name file is called ``my.model.nam'' then the list file will be called ``my.model.lst''. + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'all model stress package'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'all model package'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save flows for all packages to budget file +description REPLACE save_flows {'{#1}': 'all model package'} + +# --------------------- gwe nam packages --------------------- + +block packages +name packages +type recarray ftype fname pname +reader urword +optional false +longname package list +description + +block packages +name ftype +in_record true +type string +tagged false +reader urword +longname package type +description is the file type, which must be one of the following character values shown in table~\ref{table:ftype}. Ftype may be entered in any combination of uppercase and lowercase. + +block packages +name fname +in_record true +type string +preserve_case true +tagged false +reader urword +longname file name +description is the name of the file containing the package input. The path to the file should be included if the file is not located in the folder where the program was run. + +block packages +name pname +in_record true +type string +tagged false +reader urword +optional true +longname user name for package +description is the user-defined name for the package. PNAME is restricted to 16 characters. No spaces are allowed in PNAME. PNAME character values are read and stored by the program for stress packages only. These names may be useful for labeling purposes when multiple stress packages of the same type are located within a single GWE Model. If PNAME is specified for a stress package, then PNAME will be used in the flow budget table in the listing file; it will also be used for the text entry in the cell-by-cell budget file. PNAME is case insensitive and is stored in all upper case letters. + diff --git a/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn b/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn new file mode 100644 index 00000000000..a54fcbdd271 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn @@ -0,0 +1,313 @@ +# --------------------- gwt oc options --------------------- + +block options +name budget_filerecord +type record budget fileout budgetfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budget +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name budgetfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the output file to write budget information. + +block options +name budgetcsv_filerecord +type record budgetcsv fileout budgetcsvfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budgetcsv +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget CSV. + +block options +name budgetcsvfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +block options +name concentration_filerecord +type record concentration fileout concentrationfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name concentration +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname concentration keyword +description keyword to specify that record corresponds to concentration. + +block options +name concentrationfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the output file to write conc information. + +block options +name concentrationprintrecord +type record concentration print_format formatrecord +shape +reader urword +optional true +longname +description + +block options +name print_format +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname keyword to indicate that a print format follows +description keyword to specify format for printing to the listing file. + +block options +name formatrecord +type record columns width digits format +shape +in_record true +reader urword +tagged +optional false +longname +description + +block options +name columns +type integer +shape +in_record true +reader urword +tagged true +optional +longname number of columns +description number of columns for writing data. + +block options +name width +type integer +shape +in_record true +reader urword +tagged true +optional +longname width for each number +description width for writing each number. + +block options +name digits +type integer +shape +in_record true +reader urword +tagged true +optional +longname number of digits +description number of digits to use for writing a number. + +block options +name format +type string +shape +in_record true +reader urword +tagged false +optional false +longname write format +description write format can be EXPONENTIAL, FIXED, GENERAL, or SCIENTIFIC. + + +# --------------------- gwt oc period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name saverecord +type record save rtype ocsetting +shape +reader urword +tagged false +optional true +longname +description + +block period +name save +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname keyword to save +description keyword to indicate that information will be saved this stress period. + +block period +name printrecord +type record print rtype ocsetting +shape +reader urword +tagged false +optional true +longname +description + +block period +name print +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname keyword to save +description keyword to indicate that information will be printed this stress period. + +block period +name rtype +type string +shape +in_record true +reader urword +tagged false +optional false +longname record type +description type of information to save or print. Can be BUDGET or CONCENTRATION. + +block period +name ocsetting +type keystring all first last frequency steps +shape +tagged false +in_record true +reader urword +longname +description specifies the steps for which the data will be saved. + +block period +name all +type keyword +shape +in_record true +reader urword +longname +description keyword to indicate save for all time steps in period. + +block period +name first +type keyword +shape +in_record true +reader urword +longname +description keyword to indicate save for first step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +block period +name last +type keyword +shape +in_record true +reader urword +longname +description keyword to indicate save for last step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +block period +name frequency +type integer +shape +tagged true +in_record true +reader urword +longname +description save at the specified time step frequency. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +block period +name steps +type integer +shape ( + + @@ -61,6 +63,8 @@ + + @@ -73,6 +77,10 @@ + + + + @@ -109,41 +117,43 @@ - - - + - - - - - - - + + + + + + + + + + - + + From 857bab40d2299acd6d963224ee91528851b28a15 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 30 Nov 2022 11:14:31 -0800 Subject: [PATCH 051/212] File updates to account for new IDM in GWE's DSP package (DSP was IDM'd in GWT) --- doc/mf6io/mf6ivar/dfn/gwe-oc.dfn | 18 +- msvs/mf6core.vfproj | 1 + src/Model/Connection/GweGweConnection.f90 | 8 +- src/Model/Connection/GweInterfaceModel.f90 | 10 +- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 490 +++++++++++---------- src/Model/GroundWaterEnergy/gwe1dspidm.f90 | 219 +++++++++ 6 files changed, 503 insertions(+), 243 deletions(-) create mode 100644 src/Model/GroundWaterEnergy/gwe1dspidm.f90 diff --git a/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn b/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn index a54fcbdd271..296113c7ba6 100644 --- a/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwe-oc.dfn @@ -78,8 +78,8 @@ longname file keyword description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. block options -name concentration_filerecord -type record concentration fileout concentrationfile +name temperature_filerecord +type record temperature fileout temperaturefile shape reader urword tagged true @@ -88,18 +88,18 @@ longname description block options -name concentration +name temperature type keyword shape in_record true reader urword tagged true optional false -longname concentration keyword -description keyword to specify that record corresponds to concentration. +longname temperature keyword +description keyword to specify that record corresponds to temperature. block options -name concentrationfile +name temperaturefile type string preserve_case true shape @@ -111,8 +111,8 @@ longname file keyword description name of the output file to write conc information. block options -name concentrationprintrecord -type record concentration print_format formatrecord +name temperatureprintrecord +type record temperature print_format formatrecord shape reader urword optional true @@ -252,7 +252,7 @@ reader urword tagged false optional false longname record type -description type of information to save or print. Can be BUDGET or CONCENTRATION. +description type of information to save or print. Can be BUDGET or TEMPERATURE. block period name ocsetting diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index f3cfdf227e1..7412a15898b 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -80,6 +80,7 @@ + diff --git a/src/Model/Connection/GweGweConnection.f90 b/src/Model/Connection/GweGweConnection.f90 index dce51bd6256..8ebcc2f5470 100644 --- a/src/Model/Connection/GweGweConnection.f90 +++ b/src/Model/Connection/GweGweConnection.f90 @@ -186,10 +186,10 @@ subroutine gwegwecon_df(this) SYNC_NODES, '', (/BEFORE_AR/)) call this%addDistVar('AREA', 'DIS', this%gweInterfaceModel%name, & SYNC_NODES, '', (/BEFORE_AR/)) - if (this%gweInterfaceModel%dsp%idiffc > 0) then - call this%addDistVar('DIFFC', 'DSP', this%gweInterfaceModel%name, & - SYNC_NODES, '', (/BEFORE_AR/)) - end if + !if (this%gweInterfaceModel%dsp%idiffc > 0) then + ! call this%addDistVar('DIFFC', 'DSP', this%gweInterfaceModel%name, & + ! SYNC_NODES, '', (/BEFORE_AR/)) + !end if if (this%gweInterfaceModel%dsp%idisp > 0) then call this%addDistVar('ALH', 'DSP', this%gweInterfaceModel%name, & SYNC_NODES, '', (/BEFORE_AR/)) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 68177810247..1ec542378e2 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -135,13 +135,13 @@ subroutine gweifmod_df(this) call this%adv%adv_df(adv_options) end if if (this%indsp > 0) then - this%dsp%idiffc = this%owner%dsp%idiffc + !this%dsp%idiffc = this%owner%dsp%idiffc this%dsp%idisp = this%owner%dsp%idisp call this%dsp%dsp_df(this%dis, dsp_options) - if (this%dsp%idiffc > 0) then - call mem_reallocate(this%dsp%diffc, this%dis%nodes, 'DIFFC', & - trim(this%dsp%memoryPath)) - end if + !if (this%dsp%idiffc > 0) then + ! call mem_reallocate(this%dsp%diffc, this%dis%nodes, 'DIFFC', & + ! trim(this%dsp%memoryPath)) + !end if if (this%dsp%idisp > 0) then call mem_reallocate(this%dsp%alh, this%dis%nodes, 'ALH', & trim(this%dsp%memoryPath)) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 7b96b2d5266..f1324710ff1 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -18,21 +18,28 @@ module GweDspModule integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWE model ibound type(TspFmiType), pointer :: fmi => null() ! pointer to GWE fmi object real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWE storage porosity - ! TODO: I don't think diffc is necessary for GWE - real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell - real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water - real(DP), dimension(:), pointer, contiguous :: ktw => null() ! thermal conductivity of water - real(DP), dimension(:), pointer, contiguous :: kts => null() ! thermal conductivity of aquifer material - real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water + ! TODO: Can remove diffc from GWE + !real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: alv => null() ! longitudinal vertical dispersivity real(DP), dimension(:), pointer, contiguous :: ath1 => null() ! transverse horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: ath2 => null() ! transverse horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity - integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active - integer(I4B), pointer :: iktw => null() ! flag indicating ktw was input - integer(I4B), pointer :: ikts => null() ! flag indicating kts was input + real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water + real(DP), dimension(:), pointer, contiguous :: ktw => null() ! thermal conductivity of water + real(DP), dimension(:), pointer, contiguous :: kts => null() ! thermal conductivity of aquifer material + real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water + !integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active + integer(I4B), pointer :: ialh => null() ! longitudinal horizontal dispersivity data flag + integer(I4B), pointer :: ialv => null() ! longitudinal vertical dispersivity data flag + integer(I4B), pointer :: iath1 => null() ! transverse horizontal dispersivity data flag + integer(I4B), pointer :: iath2 => null() ! transverse horizontal dispersivity data flag + integer(I4B), pointer :: iatv => null() ! transverse vertical dispersivity data flag + integer(I4B), pointer :: ixt3doff => null() ! xt3d off flag, xt3d is set inactive if 1 + integer(I4B), pointer :: ixt3drhs => null() ! xt3d rhs flag, xt3d rhs is set active if 1 + integer(I4B), pointer :: iktw => null() ! thermal conductivity of water data flag + integer(I4B), pointer :: ikts => null() ! thermal conductivity of aquifer material data flag integer(I4B), pointer :: ixt3d => null() ! flag indicating xt3d is active type(Xt3dType), pointer :: xt3d => null() ! xt3d object real(DP), dimension(:), pointer, contiguous :: dispcoef => null() ! disp coefficient (only if xt3d not active) @@ -60,8 +67,10 @@ module GweDspModule procedure :: dsp_da procedure :: allocate_scalars procedure :: allocate_arrays - procedure, private :: read_options - procedure, private :: read_data + procedure, private :: source_options + procedure, private :: source_griddata + procedure, private :: log_options + procedure, private :: log_griddata procedure, private :: calcdispellipse procedure, private :: calcdispcoef @@ -76,12 +85,19 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- modules + use IdmMf6FileLoaderModule, only: input_load + use ConstantsModule, only: LENPACKAGETYPE ! -- dummy type(GweDspType), pointer :: dspobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi + ! -- formats + character(len=*), parameter :: fmtdsp = & + "(1x,/1x,'DSP-- THERMAL CONDUCTION AND DISPERSION PACKAGE, VERSION 1, ', & + &'3/01/2023, INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -98,13 +114,30 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) dspobj%iout = iout dspobj%fmi => fmi ! + ! -- Check if input file is open + if (dspobj%inunit > 0) then + ! + ! -- Print a message identifying the dispersion package. + if (dspobj%iout > 0) then + write (dspobj%iout, fmtdsp) dspobj%inunit + end if + ! + ! -- Initialize block parser + call dspobj%parser%Initialize(dspobj%inunit, dspobj%iout) + ! + ! -- Use the input data model routines to load the input data + ! into memory + call input_load(dspobj%parser, 'DSP6', 'GWE', 'DSP', dspobj%name_model, & + 'DSP', [character(len=LENPACKAGETYPE) ::], iout) + end if + ! ! -- Return return end subroutine dsp_cr subroutine dsp_df(this, dis, dspOptions) ! ****************************************************************************** -! dsp_df -- Allocate and Read +! dsp_df -- Define ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -116,10 +149,6 @@ subroutine dsp_df(this, dis, dspOptions) type(GweDspOptionsType), optional, intent(in) :: dspOptions !< the optional DSP options, used when not !! creating DSP from file ! -- local - ! -- formats - character(len=*), parameter :: fmtdsp = & - "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & - &' INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! -- Store pointer to dis @@ -132,11 +161,17 @@ subroutine dsp_df(this, dis, dspOptions) ! -- Read dispersion options if (present(dspOptions)) then this%ixt3d = dspOptions%ixt3d + ! + ! -- Allocate only, grid data will not be read from file + call this%allocate_arrays(this%dis%nodes) else ! - ! -- Initialize block parser - call this%parser%Initialize(this%inunit, this%iout) - call this%read_options() + ! -- Source options + call this%source_options() + call this%allocate_arrays(this%dis%nodes) + ! + ! -- Source dispersion data + call this%source_griddata() end if ! ! -- xt3d create @@ -216,8 +251,8 @@ subroutine dsp_ar(this, ibound, porosity, cpw, rhow) ! -- local ! -- formats character(len=*), parameter :: fmtdsp = & - "(1x,/1x,'DSP-- DISPERSION PACKAGE, VERSION 1, 1/24/2018', & - &' INPUT READ FROM UNIT ', i0, //)" + "(1x,/1x,'DSP-- THERMAL CONDUCTION AND DISPERSION PACKAGE, VERSION 1, ', & + &'3/01/2023, INPUT READ FROM UNIT ', i0, //)" ! ------------------------------------------------------------------------------ ! ! -- dsp pointers to arguments that were passed in @@ -250,10 +285,9 @@ subroutine dsp_ad(this) if (kstp * kper == 1) then if (this%ixt3d > 0) then call this%xt3d%xt3d_ar(this%fmi%ibdgwfsat0, this%d11, this%id33, & - this%d33, this%fmi%gwfsat, this%id22, & - this%d22, this%iangle1, this%iangle2, & - this%iangle3, this%angle1, this%angle2, & - this%angle3) + this%d33, this%fmi%gwfsat, this%id22, this%d22, & + this%iangle1, this%iangle2, this%iangle3, & + this%angle1, this%angle2, this%angle3) end if end if ! @@ -383,28 +417,42 @@ subroutine allocate_scalars(this) call this%NumericalPackageType%allocate_scalars() ! ! -- Allocate - call mem_allocate(this%idiffc, 'IDIFFC', this%memoryPath) - call mem_allocate(this%iktw, 'IKTW', this%memoryPath) - call mem_allocate(this%ikts, 'IKTS', this%memoryPath) + !call mem_allocate(this%idiffc, 'IDIFFC', this%memoryPath) call mem_allocate(this%idisp, 'IDISP', this%memoryPath) + call mem_allocate(this%ialh, 'IALH', this%memoryPath) + call mem_allocate(this%ialv, 'IALV', this%memoryPath) + call mem_allocate(this%iath1, 'IATH1', this%memoryPath) + call mem_allocate(this%iath2, 'IATH2', this%memoryPath) + call mem_allocate(this%iatv, 'IATV', this%memoryPath) + call mem_allocate(this%ixt3doff, 'IXT3DOFF', this%memoryPath) + call mem_allocate(this%ixt3drhs, 'IXT3DRHS', this%memoryPath) call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) call mem_allocate(this%id22, 'ID22', this%memoryPath) call mem_allocate(this%id33, 'ID33', this%memoryPath) call mem_allocate(this%iangle1, 'IANGLE1', this%memoryPath) call mem_allocate(this%iangle2, 'IANGLE2', this%memoryPath) call mem_allocate(this%iangle3, 'IANGLE3', this%memoryPath) + call mem_allocate(this%iktw, 'IKTW', this%memoryPath) + call mem_allocate(this%ikts, 'IKTS', this%memoryPath) ! ! -- Initialize - this%idiffc = 0 - this%iktw = 0 - this%ikts = 0 + !this%idiffc = 0 this%idisp = 0 + this%ialh = 0 + this%ialv = 0 + this%iath1 = 0 + this%iath2 = 0 + this%iatv = 0 + this%ixt3doff = 0 + this%ixt3drhs = 0 this%ixt3d = 0 this%id22 = 1 this%id33 = 1 this%iangle1 = 1 this%iangle2 = 1 this%iangle3 = 1 + this%iktw = 1 + this%ikts = 1 ! ! -- Return return @@ -427,20 +475,20 @@ subroutine allocate_arrays(this, nodes) ! ------------------------------------------------------------------------------ ! ! -- Allocate - call mem_allocate(this%alh, 0, 'ALH', trim(this%memoryPath)) - call mem_allocate(this%alv, 0, 'ALV', trim(this%memoryPath)) - call mem_allocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) - call mem_allocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) - call mem_allocate(this%atv, 0, 'ATV', trim(this%memoryPath)) - call mem_allocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) - call mem_allocate(this%KTW, 0, 'KTW', trim(this%memoryPath)) - call mem_allocate(this%KTS, 0, 'KTS', trim(this%memoryPath)) + call mem_allocate(this%alh, nodes, 'ALH', trim(this%memoryPath)) + call mem_allocate(this%alv, nodes, 'ALV', trim(this%memoryPath)) + call mem_allocate(this%ath1, nodes, 'ATH1', trim(this%memoryPath)) + call mem_allocate(this%ath2, nodes, 'ATH2', trim(this%memoryPath)) + call mem_allocate(this%atv, nodes, 'ATV', trim(this%memoryPath)) + !call mem_allocate(this%diffc, nodes, 'DIFFC', trim(this%memoryPath)) call mem_allocate(this%d11, nodes, 'D11', trim(this%memoryPath)) call mem_allocate(this%d22, nodes, 'D22', trim(this%memoryPath)) call mem_allocate(this%d33, nodes, 'D33', trim(this%memoryPath)) call mem_allocate(this%angle1, nodes, 'ANGLE1', trim(this%memoryPath)) call mem_allocate(this%angle2, nodes, 'ANGLE2', trim(this%memoryPath)) call mem_allocate(this%angle3, nodes, 'ANGLE3', trim(this%memoryPath)) + call mem_allocate(this%ktw, nodes, 'KTW', trim(this%memoryPath)) + call mem_allocate(this%kts, nodes, 'KTS', trim(this%memoryPath)) ! ! -- Allocate dispersion coefficient array if xt3d not in use if (this%ixt3d == 0) then @@ -463,10 +511,15 @@ subroutine dsp_da(this) ! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate + use MemoryManagerExtModule, only: memorylist_remove + use SimVariablesModule, only: idm_context ! -- dummy class(GweDspType) :: this ! -- local ! ------------------------------------------------------------------------------ + ! + ! -- Deallocate input memory + call memorylist_remove(this%name_model, 'DSP', idm_context) ! ! -- deallocate arrays if (this%inunit /= 0) then @@ -475,15 +528,15 @@ subroutine dsp_da(this) call mem_deallocate(this%ath1) call mem_deallocate(this%ath2, 'ATH2', trim(this%memoryPath)) call mem_deallocate(this%atv, 'ATV', trim(this%memoryPath)) - call mem_deallocate(this%diffc) - call mem_deallocate(this%ktw) - call mem_deallocate(this%kts) + !call mem_deallocate(this%diffc) call mem_deallocate(this%d11) call mem_deallocate(this%d22) call mem_deallocate(this%d33) call mem_deallocate(this%angle1) call mem_deallocate(this%angle2) call mem_deallocate(this%angle3) + call mem_deallocate(this%ktw) + call mem_deallocate(this%kts) call mem_deallocate(this%dispcoef) if (this%ixt3d > 0) call this%xt3d%xt3d_da() end if @@ -492,16 +545,23 @@ subroutine dsp_da(this) if (this%ixt3d > 0) deallocate (this%xt3d) ! ! -- deallocate scalars - call mem_deallocate(this%idiffc) - call mem_deallocate(this%iktw) - call mem_deallocate(this%ikts) + !call mem_deallocate(this%idiffc) call mem_deallocate(this%idisp) + call mem_deallocate(this%ialh) + call mem_deallocate(this%ialv) + call mem_deallocate(this%iath1) + call mem_deallocate(this%iath2) + call mem_deallocate(this%iatv) + call mem_deallocate(this%ixt3doff) + call mem_deallocate(this%ixt3drhs) call mem_deallocate(this%ixt3d) call mem_deallocate(this%id22) call mem_deallocate(this%id33) call mem_deallocate(this%iangle1) call mem_deallocate(this%iangle2) call mem_deallocate(this%iangle3) + call mem_deallocate(this%iktw) + call mem_deallocate(this%ikts) ! ! -- deallocate variables in NumericalPackageType call this%NumericalPackageType%da() @@ -510,226 +570,206 @@ subroutine dsp_da(this) return end subroutine dsp_da - subroutine read_options(this) + !> @brief Write user options to list file + !< + subroutine log_options(this, found) + use GweDspInputModule, only: GweDspParamFoundType + class(GweDspType) :: this + type(GweDspParamFoundType), intent(in) :: found + + write (this%iout, '(1x,a)') 'Setting DSP Options' + write (this%iout, '(4x,a,i0)') 'XT3D formulation [0=INACTIVE, 1=ACTIVE, & + &3=ACTIVE RHS] set to: ', this%ixt3d + write (this%iout, '(1x,a,/)') 'End Setting DSP Options' + end subroutine log_options + + subroutine source_options(this) ! ****************************************************************************** -! read_options -- Allocate and Read +! source_options -- update simulation mempath options ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error + !use KindModule, only: LGP + use MemoryHelperModule, only: create_mem_path + use MemoryTypeModule, only: MemoryType + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + use ConstantsModule, only: LENMEMPATH + use GweDspInputModule, only: GweDspParamFoundType ! -- dummy class(GweDspType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - integer(I4B) :: ierr - logical :: isfound, endOfBlock - ! -- formats + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + type(GweDspParamFoundType) :: found ! ------------------------------------------------------------------------------ ! - ! -- get options block - call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & - supportOpenClose=.true.) - ! - ! -- parse options block if detected - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING DISPERSION OPTIONS' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - select case (keyword) - case ('XT3D_OFF') - this%ixt3d = 0 - write (this%iout, '(4x,a)') & - 'XT3D FORMULATION HAS BEEN SHUT OFF.' - case ('XT3D_RHS') - this%ixt3d = 2 - write (this%iout, '(4x,a)') & - 'XT3D RIGHT-HAND SIDE FORMULATION IS SELECTED.' - case default - write (errmsg, '(4x,a,a)') 'UNKNOWN DISPERSION OPTION: ', & - trim(keyword) - call store_error(errmsg, terminate=.TRUE.) - end select - end do - write (this%iout, '(1x,a)') 'END OF DISPERSION OPTIONS' + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DSP', idm_context) + ! + ! -- update defaults with idm sourced values + call mem_set_value(this%ixt3doff, 'XT3D_OFF', idmMemoryPath, found%xt3d_off) + call mem_set_value(this%ixt3drhs, 'XT3D_RHS', idmMemoryPath, found%xt3d_rhs) + ! + ! -- set xt3d state flag + if (found%xt3d_off) this%ixt3d = 0 + if (found%xt3d_rhs) this%ixt3d = 2 + ! + ! -- log options + if (this%iout > 0) then + call this%log_options(found) end if ! ! -- Return return - end subroutine read_options + end subroutine source_options + + !> @brief Write dimensions to list file + !< + subroutine log_griddata(this, found) + use GweDspInputModule, only: GweDspParamFoundType + class(GweDspType) :: this + type(GweDspParamFoundType), intent(in) :: found + + write (this%iout, '(1x,a)') 'Setting DSP Griddata' + + !if (found%diffc) then + ! write (this%iout, '(4x,a)') 'DIFFC set from input file' + !end if + + if (found%alh) then + write (this%iout, '(4x,a)') 'ALH set from input file' + end if + + if (found%alv) then + write (this%iout, '(4x,a)') 'ALV set from input file' + end if + + if (found%ath1) then + write (this%iout, '(4x,a)') 'ATH1 set from input file' + end if + + if (found%ath2) then + write (this%iout, '(4x,a)') 'ATH2 set from input file' + end if + + if (found%atv) then + write (this%iout, '(4x,a)') 'ATV set from input file' + end if + + if (found%ktw) then + write (this%iout, '(4x,a)') 'KTW set from input file' + end if + + if (found%kts) then + write (this%iout, '(4x,a)') 'KTS set from input file' + end if + + write (this%iout, '(1x,a,/)') 'End Setting DSP Griddata' + + end subroutine log_griddata - subroutine read_data(this) + subroutine source_griddata(this) ! ****************************************************************************** -! read_data -- read the dispersion data +! source_griddata -- update dsp simulation data from input mempath ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors - use MemoryManagerModule, only: mem_reallocate, mem_copyptr, mem_reassignptr + ! -- modules + use SimModule, only: count_errors, store_error + use MemoryHelperModule, only: create_mem_path + use MemoryManagerModule, only: mem_reallocate, mem_reassignptr + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + use ConstantsModule, only: LENMEMPATH, LINELENGTH + use GweDspInputModule, only: GweDspParamFoundType ! -- dummy class(GweDspType) :: this - ! -- local - character(len=LINELENGTH) :: errmsg, keyword - character(len=:), allocatable :: line - integer(I4B) :: istart, istop, lloc, ierr - logical :: isfound, endOfBlock - logical, dimension(8) :: lname - character(len=24), dimension(8) :: aname + ! -- locals + character(len=LENMEMPATH) :: idmMemoryPath + character(len=LINELENGTH) :: errmsg + type(GweDspParamFoundType) :: found + integer(I4B), dimension(:), pointer, contiguous :: map ! -- formats - ! -- data - data aname(1)/' DIFFUSION COEFFICIENT'/ - data aname(2)/' ALH'/ - data aname(3)/' ALV'/ - data aname(4)/' ATH1'/ - data aname(5)/' ATH2'/ - data aname(6)/' ATV'/ - data aname(6)/' KTW'/ - data aname(6)/' KTS'/ ! ------------------------------------------------------------------------------ ! - ! -- initialize - lname(:) = .false. - isfound = .false. - ! - ! -- get griddata block - call this%parser%GetBlock('GRIDDATA', isfound, ierr) - if (isfound) then - write (this%iout, '(1x,a)') 'PROCESSING GRIDDATA' - do - call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - call this%parser%GetStringCaps(keyword) - call this%parser%GetRemainingLine(line) - lloc = 1 - select case (keyword) -! case ('DIFFC') -! call mem_reallocate(this%diffc, this%dis%nodes, 'DIFFC', & -! trim(this%memoryPath)) -! call this%dis%read_grid_array(line, lloc, istart, istop, this%iout,& -! this%parser%iuactive, this%diffc, & -! aname(1)) -! lname(1) = .true. - case ('ALH') - call mem_reallocate(this%alh, this%dis%nodes, 'ALH', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%alh, & - aname(2)) - lname(2) = .true. - case ('ALV') - call mem_reallocate(this%alv, this%dis%nodes, 'ALV', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%alv, & - aname(3)) - lname(3) = .true. - case ('ATH1') - call mem_reallocate(this%ath1, this%dis%nodes, 'ATH1', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ath1, & - aname(4)) - lname(4) = .true. - case ('ATH2') - call mem_reallocate(this%ath2, this%dis%nodes, 'ATH2', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ath2, & - aname(5)) - lname(5) = .true. - case ('ATV') - call mem_reallocate(this%atv, this%dis%nodes, 'ATV', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%atv, & - aname(6)) - lname(6) = .true. - case ('KTW') - call mem_reallocate(this%ktw, this%dis%nodes, 'KTW', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%ktw, & - aname(7)) - lname(7) = .true. - case ('KTS') - call mem_reallocate(this%kts, this%dis%nodes, 'KTS', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%kts, & - aname(8)) - lname(8) = .true. - - case default - write (errmsg, '(4x,a,a)') 'Unknown GRIDDATA tag: ', trim(keyword) - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end select - end do - write (this%iout, '(1x,a)') 'END PROCESSING GRIDDATA' - else - write (errmsg, '(1x,a)') 'Required GRIDDATA block not found.' - call store_error(errmsg) - call this%parser%StoreErrorUnit() - end if + ! -- set memory path + idmMemoryPath = create_mem_path(this%name_model, 'DSP', idm_context) ! - if (lname(1)) this%idiffc = 1 - if (lname(2)) this%idisp = this%idisp + 1 - if (lname(3)) this%idisp = this%idisp + 1 - if (lname(4)) this%idisp = this%idisp + 1 - if (lname(5)) this%idisp = this%idisp + 1 - if (lname(7)) this%iktw = 1 - if (lname(8)) this%ikts = 1 + ! -- set map + map => null() + if (this%dis%nodes < this%dis%nodesuser) map => this%dis%nodeuser ! - ! -- if dispersivities are specified, then both alh and ath1 must be included + ! -- update defaults with idm sourced values + !call mem_set_value(this%diffc, 'DIFFC', idmMemoryPath, map, found%diffc) + call mem_set_value(this%alh, 'ALH', idmMemoryPath, map, found%alh) + call mem_set_value(this%alv, 'ALV', idmMemoryPath, map, found%alv) + call mem_set_value(this%ath1, 'ATH1', idmMemoryPath, map, found%ath1) + call mem_set_value(this%ath2, 'ATH2', idmMemoryPath, map, found%ath2) + call mem_set_value(this%atv, 'ATV', idmMemoryPath, map, found%atv) + call mem_set_value(this%ktw, 'KTW', idmMemoryPath, map, found%ktw) + call mem_set_value(this%kts, 'KTS', idmMemoryPath, map, found%kts) + ! + ! -- set active flags + !if (found%diffc) this%idiffc = 1 + if (found%alh) this%ialh = 1 + if (found%alv) this%ialv = 1 + if (found%ath1) this%iath1 = 1 + if (found%ath2) this%iath2 = 1 + if (found%atv) this%iatv = 1 + if (found%ktw) this%iktw = 1 + if (found%kts) this%ikts = 1 + ! + ! -- reallocate diffc if not found + !if (.not. found%diffc) then + ! call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) + !end if + ! + ! -- set this%idisp flag + if (found%alh) this%idisp = this%idisp + 1 + if (found%alv) this%idisp = this%idisp + 1 + if (found%ath1) this%idisp = this%idisp + 1 + if (found%ath2) this%idisp = this%idisp + 1 + if (found%ktw) this%idisp = this%idisp + 1 + if (found%kts) this%idisp = this%idisp + 1 + ! + ! -- manage dispersion arrays if (this%idisp > 0) then - ! - ! -- make sure alh was specified - if (.not. lname(2)) then - write (errmsg, '(1x,a)') 'IF DISPERSIVITIES ARE SPECIFIED THEN ALH '// & - 'IS REQUIRED.' + if (.not. (found%alh .and. found%ath1)) then + write (errmsg, '(1x,a)') & + 'if dispersivities are specified then ALH and ATH1 are required.' call store_error(errmsg) end if - ! - ! -- make sure ath1 was specified - if (.not. lname(4)) then - write (errmsg, '(1x,a)') 'IF DISPERSIVITIES ARE SPECIFIED THEN ATH1 '// & - 'IS REQUIRED.' - call store_error(errmsg) - end if - ! ! -- If alv not specified then point it to alh - if (.not. lname(3)) then + if (.not. found%alv) & call mem_reassignptr(this%alv, 'ALV', trim(this%memoryPath), & 'ALH', trim(this%memoryPath)) - end if - ! - ! -- If ath2 not specified then assign it to ath1 - if (.not. lname(5)) then + ! -- If ath2 not specified then point it to ath1 + if (.not. found%ath2) & call mem_reassignptr(this%ath2, 'ATH2', trim(this%memoryPath), & 'ATH1', trim(this%memoryPath)) - end if - ! - ! -- If atv not specified then assign it to ath2 - if (.not. lname(6)) then + ! -- If atv not specified then point it to ath2 + if (.not. found%atv) & call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & 'ATH2', trim(this%memoryPath)) - end if + else + call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath)) + call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath)) + call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) + call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) + call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath)) end if ! - ! -- terminate if errors - if (count_errors() > 0) then - call this%parser%StoreErrorUnit() + ! -- log griddata + if (this%iout > 0) then + call this%log_griddata(found) end if ! ! -- Return return - end subroutine read_data + end subroutine source_griddata subroutine calcdispellipse(this) ! ****************************************************************************** @@ -791,9 +831,9 @@ subroutine calcdispellipse(this) ! ! -- calculate dstar = DZERO -! if (this%idiffc > 0) then -! dstar = this%diffc(n) * this%porosity(n) -! endif + !if (this%idiffc > 0) then + ! dstar = this%diffc(n) * this%porosity(n) + !end if ktbulk = DZERO if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) if (this%ikts > 0) ktbulk = ktbulk + (DONE - this%porosity(n)) * this%kts(n) diff --git a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 new file mode 100644 index 00000000000..1cf4e912e0f --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 @@ -0,0 +1,219 @@ +module GweDspInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwe_dsp_param_definitions + public gwe_dsp_aggregate_definitions + public gwe_dsp_block_definitions + public GweDspParamFoundType + + type GweDspParamFoundType + logical :: xt3d_off = .false. + logical :: xt3d_rhs = .false. + !logical :: diffc = .false. + logical :: alh = .false. + logical :: alv = .false. + logical :: ath1 = .false. + logical :: ath2 = .false. + logical :: atv = .false. + logical :: ktw = .false. + logical :: kts = .false. + end type GweDspParamFoundType + + type(InputParamDefinitionType), parameter :: & + gwedsp_xt3d_off = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'OPTIONS', & ! block + 'XT3D_OFF', & ! tag name + 'XT3D_OFF', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_xt3d_rhs = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'OPTIONS', & ! block + 'XT3D_RHS', & ! tag name + 'XT3D_RHS', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + !type(InputParamDefinitionType), parameter :: & + ! gwtdsp_diffc = InputParamDefinitionType & + ! ( & + ! 'GWT', & ! component + ! 'DSP', & ! subcomponent + ! 'GRIDDATA', & ! block + ! 'DIFFC', & ! tag name + ! 'DIFFC', & ! fortran variable + ! 'DOUBLE1D', & ! type + ! 'NODES', & ! shape + ! .false., & ! required + ! .false., & ! multi-record + ! .false., & ! preserve case + ! .true. & ! layered + ! ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_alh = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ALH', & ! tag name + 'ALH', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_alv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ALV', & ! tag name + 'ALV', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_ath1 = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ATH1', & ! tag name + 'ATH1', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_ath2 = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ATH2', & ! tag name + 'ATH2', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_atv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'ATV', & ! tag name + 'ATV', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_ktw = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'KTW', & ! tag name + 'KTW', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedsp_kts = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DSP', & ! subcomponent + 'GRIDDATA', & ! block + 'KTS', & ! tag name + 'KTS', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_dsp_param_definitions(*) = & + [ & + gwedsp_xt3d_off, & + gwedsp_xt3d_rhs, & + !gwtdsp_diffc, & + gwedsp_alh, & + gwedsp_alv, & + gwedsp_ath1, & + gwedsp_ath2, & + gwedsp_atv, & + gwedsp_ktw, & + gwedsp_kts & + ] + + type(InputParamDefinitionType), parameter :: & + gwe_dsp_aggregate_definitions(*) = & + [ & + InputParamDefinitionType :: & + ] + + type(InputBlockDefinitionType), parameter :: & + gwe_dsp_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false. & ! aggregate + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .false., & ! required + .false. & ! aggregate + ) & + ] + +end module GweDspInputModule From 5a40f133ff62eaeb9c85a87f1b417e9ba532eaf4 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 30 Nov 2022 11:48:01 -0800 Subject: [PATCH 052/212] A change to avoid warning messages generated by IDM related to the GWE/DSP (a change I should've made previously) --- src/Utilities/Idm/InputDefinitionSelector.f90 | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Utilities/Idm/InputDefinitionSelector.f90 b/src/Utilities/Idm/InputDefinitionSelector.f90 index 17e030858b2..5a8f144185f 100644 --- a/src/Utilities/Idm/InputDefinitionSelector.f90 +++ b/src/Utilities/Idm/InputDefinitionSelector.f90 @@ -27,6 +27,9 @@ module InputDefinitionSelectorModule use GwtDspInputModule, only: gwt_dsp_param_definitions, & gwt_dsp_aggregate_definitions, & gwt_dsp_block_definitions + use GweDspInputModule, only: gwe_dsp_param_definitions, & + gwe_dsp_aggregate_definitions, & + gwe_dsp_block_definitions implicit none private @@ -55,6 +58,8 @@ function param_definitions(component) result(input_definition) call set_pointer(input_definition, gwf_npf_param_definitions) case ('GWT/DSP') call set_pointer(input_definition, gwt_dsp_param_definitions) + case ('GWE/DSP') + call set_pointer(input_definition, gwe_dsp_param_definitions) case default write (warnmsg, '(a,a)') 'IDM Unsupported input type: ', trim(component) call store_warning(warnmsg) @@ -80,6 +85,8 @@ function aggregate_definitions(component) result(input_definition) call set_pointer(input_definition, gwf_npf_aggregate_definitions) case ('GWT/DSP') call set_pointer(input_definition, gwt_dsp_aggregate_definitions) + case ('GWE/DSP') + call set_pointer(input_definition, gwe_dsp_aggregate_definitions) case default write (warnmsg, '(a,a)') 'IDM Unsupported input type: ', trim(component) call store_warning(warnmsg) @@ -105,6 +112,8 @@ function block_definitions(component) result(input_definition) call set_block_pointer(input_definition, gwf_npf_block_definitions) case ('GWT/DSP') call set_block_pointer(input_definition, gwt_dsp_block_definitions) + case ('GWE/DSP') + call set_block_pointer(input_definition, gwe_dsp_block_definitions) case default write (warnmsg, '(a,a)') 'IDM Unsupported input type: ', trim(component) call store_warning(warnmsg) From efccc6b005748498b6e478ed6554b76b5d93209a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 30 Nov 2022 13:05:22 -0800 Subject: [PATCH 053/212] fprettify (for gfortran-compliant formatting, I hope) --- src/Model/Connection/GweGweConnection.f90 | 6 +-- src/Model/Connection/GweInterfaceModel.f90 | 4 +- src/Model/GroundWaterEnergy/gwe1.f90 | 49 +++++++++++----------- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 4 +- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 8 ++-- 5 files changed, 36 insertions(+), 35 deletions(-) diff --git a/src/Model/Connection/GweGweConnection.f90 b/src/Model/Connection/GweGweConnection.f90 index 8ebcc2f5470..648426bef8f 100644 --- a/src/Model/Connection/GweGweConnection.f90 +++ b/src/Model/Connection/GweGweConnection.f90 @@ -115,7 +115,7 @@ subroutine gweGweConnection_ctor(this, model, gweEx) end if ! first call base constructor - call this%SpatialModelConnectionType%spatialConnection_ctor(model,& + call this%SpatialModelConnectionType%spatialConnection_ctor(model, & gweEx, & name) @@ -218,7 +218,7 @@ subroutine gwegwecon_df(this) SYNC_NODES, '', (/AFTER_AR/)) end if call this%mapVariables() - + call this%allocate_arrays() call this%gweInterfaceModel%allocate_fmi() @@ -470,7 +470,7 @@ subroutine setFlowToExchange(this) if (this%exchangeIsOwned) then gweEx => this%gweExchange map => this%interfaceMap%exchange_map(this%interfaceMap%prim_exg_idx) - + ! use (half of) the exchnage map in reverse: do i = 1, size(map%src_idx) if (map%sign(i) < 0) cycle ! simvals is defined from exg%m1 => exg%m2 diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 1ec542378e2..573fcafd159 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -112,7 +112,7 @@ subroutine allocate_fmi(this) this%fmi%memoryPath) end subroutine allocate_fmi - + !> @brief Define the GWE interface model !< subroutine gweifmod_df(this) @@ -210,7 +210,7 @@ subroutine gweifmod_da(this) deallocate (this%fmi) deallocate (this%adv) deallocate (this%dsp) - + if (associated(this%mst)) then call mem_deallocate(this%mst%porosity) deallocate (this%mst) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 507de256f44..3356794677c 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -778,7 +778,8 @@ subroutine gwe_ot(this) ! -- Override ibudfl and idvprint flags for nonconvergence ! and end of period ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & + this%icnvg, endofperiod) ! ! Calculate and save observations call this%gwe_ot_obs() @@ -1159,27 +1160,27 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & case ('TMP6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab) - !case('SRC6') - ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname) - !case('LKT6') - ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('SFT6') - ! call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('MWT6') - ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('UZT6') - ! call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) - !case('IST6') - ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi, this%mst) - !case('API6') - ! call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname) + !case('SRC6') + ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname) + !case('LKT6') + ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('SFT6') + ! call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('MWT6') + ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('UZT6') + ! call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi) + !case('IST6') + ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname, this%fmi, this%mst) + !case('API6') + ! call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + ! pakname) case default write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) @@ -1221,8 +1222,8 @@ subroutine ftype_check(this, namefile_obj, indis) character(len=LINELENGTH) :: errmsg integer(I4B) :: i, iu character(len=LENFTYPE), dimension(10) :: nodupftype = & - (/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', & - 'DSP6 ', 'SSM6 ', 'OC6 ', 'OBS6 '/) + &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', & + &'ADV6 ', 'DSP6 ', 'SSM6 ', 'OC6 ', 'OBS6 '/) ! ------------------------------------------------------------------------------ ! ! -- Check for IC6, DIS(u), and MST. Stop if not present. diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index f1324710ff1..e88b04df6ea 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -657,11 +657,11 @@ subroutine log_griddata(this, found) if (found%atv) then write (this%iout, '(4x,a)') 'ATV set from input file' end if - + if (found%ktw) then write (this%iout, '(4x,a)') 'KTW set from input file' end if - + if (found%kts) then write (this%iout, '(4x,a)') 'KTS set from input file' end if diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 0d2e9d2eb89..3329a594cd3 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -281,8 +281,8 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & ! ! -- Call function to get zero-order decay rate, which may be changed ! from the user-specified rate to prevent negative temperatures ! kluge note: think through negative temps - decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & - kiter, cold(n), cnew(n), delt) + decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & + kiter, cold(n), cnew(n), delt) this%decaylast(n) = decay_rate rrhs = decay_rate * vcell * swtpdt * this%porosity(n) rhs(n) = rhs(n) + rrhs @@ -645,8 +645,8 @@ subroutine read_options(this) logical :: isfound, endOfBlock ! -- formats character(len=*), parameter :: fmtisvflow = & - "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY "// & - "FILE WHENEVER ICBCFL IS NOT ZERO.')" + &"(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY "// & + &"FILE WHENEVER ICBCFL IS NOT ZERO.')" character(len=*), parameter :: fmtidcy1 = & "(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" character(len=*), parameter :: fmtidcy2 = & From 7faa5e287321959bb743478d9b37a406f815c870 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Dec 2022 12:05:30 -0800 Subject: [PATCH 054/212] An early GWE autotest --- autotest/test_gwe_dsp.py | 550 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 550 insertions(+) create mode 100644 autotest/test_gwe_dsp.py diff --git a/autotest/test_gwe_dsp.py b/autotest/test_gwe_dsp.py new file mode 100644 index 00000000000..dd999f4b0cc --- /dev/null +++ b/autotest/test_gwe_dsp.py @@ -0,0 +1,550 @@ +# ## Test problem for GWE +# +# One-Dimensional Transport in a Uniform Flow Field. +# The purpose of this script is to test the new heat transport model developed +# for MODFLOW 6. To that end, this problem uses the setup of the first MT3DMS +# test problem but adapts it for heat. MODFLOW 6 is setup using the new GWE +# model with input parameters entered in their native units. The equivalent +# values are calculated for "tricking" MT3DMS into heat transport. +# +# It may be possible to find a 1D heat transport analytical solution in the +# future. + +# Imports + +import os +import sys + +import numpy as np +import pytest + +try: + import flopy +except: + msg = "Error. FloPy package is not available.\n" + msg += "Try installing using the following command:\n" + msg += " pip install flopy" + raise Exception(msg) + +import targets + +exe_name_mf = targets.target_dict["mf2005s"] +exe_name_mt = targets.target_dict["mt3dms"] +exe_name_mf6 = targets.target_dict["mf6"] + +# Base simulation and model name and workspace + +viscosity_on = [False] +ex = ["dsp01"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", s)) + +# Model units + +length_units = "meters" +time_units = "days" + +# Table MODFLOW 6 GWE comparison to MT3DMS + +nper = 1 # Number of periods +nlay = 1 # Number of layers +ncol = 101 # Number of columns +nrow = 1 # Number of rows +delr = 10.0 # Column width ($m$) +delc = 1.0 # Row width ($m$) +top = 0.0 # Top of the model ($m$) +botm = -1.0 # Layer bottom elevations ($m$) +prsity = 0.25 # Porosity +perlen = 2000 # Simulation time ($days$) +k11 = 1.0 # Horizontal hydraulic conductivity ($m/d$) + +# Set some static model parameter values + +k33 = k11 # Vertical hydraulic conductivity ($m/d$) +laytyp = 1 +nstp = 100.0 +dt0 = perlen / nstp +Lx = (ncol - 1) * delr +v = 0.24 +q = v * prsity +h1 = q * Lx +strt = np.zeros((nlay, nrow, ncol), dtype=float) +strt[0, 0, 0] = h1 # Starting head ($m$) +l = 1000.0 # Needed for plots +icelltype = 1 # Cell conversion type +ibound = np.ones((nlay, nrow, ncol), dtype=int) +ibound[0, 0, 0] = -1 +ibound[0, 0, -1] = -1 + +# Set some static transport related model parameter values + +mixelm = 0 # FD +rhob = 1110.0 +sp2 = 0.0 # read, but not used in this problem +kd = 1.8168E-4 +strt_temp = np.zeros((nlay, nrow, ncol), dtype=float) +dispersivity = 1.0 +dmcoef = 3.2519E-7 # Molecular diffusion coefficient + +# Set solver parameter values (and related) +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-6, 1e-6, 1.0 +ttsmult = 1.0 +dceps = 1.0e-5 # HMOC parameters in case they are invoked +nplane = 1 # HMOC +npl = 0 # HMOC +nph = 4 # HMOC +npmin = 0 # HMOC +npmax = 8 # HMOC +nlsink = nplane # HMOC +npsink = nph # HMOC + +# Static temporal data used by TDIS file + +tdis_rc = [] +tdis_rc.append((perlen, nstp, 1.0)) + +# ### Create MODFLOW 6 GWE MT3DMS Example 1 Boundary Conditions +# +# Constant head cells are specified on both ends of the model + +chdspd = [[(0, 0, 0), h1], [(0, 0, ncol - 1), 0.0]] +c0 = 40.0 +ctpspd = [[(0, 0, 0), c0]] + + +# +# MF2K5/MT3DMS and MODFLOW 6 (sim) flopy objects returned if building the model +# + +def build_mfmt_models(idx, dir): + # Base MF2K5/MT3DMS runs + ws = dir + name = ex[idx] + + mt3d_ws = os.path.join(ws, name, "mt3d") + modelname_mf = "p01-mf" + + # Instantiate the MODFLOW model + mf = flopy.modflow.Modflow( + modelname=modelname_mf, model_ws=mt3d_ws, exe_name=exe_name_mf + ) + + # Instantiate discretization package + # units: itmuni=4 (days), lenuni=2 (m) + flopy.modflow.ModflowDis( + mf, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + nstp=nstp, + botm=botm, + perlen=perlen, + itmuni=4, + lenuni=2, + ) + + # Instantiate basic package + flopy.modflow.ModflowBas(mf, ibound=ibound, strt=strt) + + # Instantiate layer property flow package + flopy.modflow.ModflowLpf(mf, hk=k11, laytyp=laytyp) + + # Instantiate solver package + flopy.modflow.ModflowPcg(mf) + + # Instantiate link mass transport package (for writing linker file) + flopy.modflow.ModflowLmt(mf) + + # Write and run the simulation to create the linker file + mf.write_input() + mf.run_model(silent=False) + + # Transport + modelname_mt = "p01-mt" + mt = flopy.mt3d.Mt3dms( + modelname=modelname_mt, + model_ws=mt3d_ws, + exe_name=exe_name_mt, + modflowmodel=mf, + ) + + icbund = np.ones((nlay, nrow, ncol), dtype=int) + icbund[0, 0, 0] = -1 + strt_temp = np.zeros((nlay, nrow, ncol), dtype=float) + strt_temp[0, 0, 0] = c0 + flopy.mt3d.Mt3dBtn( + mt, + laycon=laytyp, + icbund=icbund, + prsity=prsity, + sconc=strt_temp, + dt0=dt0, + ifmtcn=1, + ) + + # Instatiate the advection package + flopy.mt3d.Mt3dAdv( + mt, + mixelm=mixelm, + dceps=dceps, + nplane=nplane, + npl=npl, + nph=nph, + npmin=npmin, + npmax=npmax, + nlsink=nlsink, + npsink=npsink, + percel=0.5, + ) + + # Instantiate the dispersion package + flopy.mt3d.Mt3dDsp(mt, al=dispersivity, dmcoef=dmcoef) + + # Set reactive variables and instantiate chemical reaction package + isothm = 1 + flopy.mt3d.Mt3dRct( + mt, + isothm=isothm, + ireact=0, + igetsc=0, + rhob=rhob, + sp1=kd + ) + + # Instantiate the source/sink mixing package + flopy.mt3d.Mt3dSsm(mt) + + # Instantiate the GCG solver in MT3DMS + flopy.mt3d.Mt3dGcg(mt, mxiter=10) + + mt.write_input() + fname = os.path.join(mt3d_ws, "MT3D001.UCN") + if os.path.isfile(fname): + os.remove(fname) + mt.run_model(silent=False) + + ucnobj = flopy.utils.UcnFile(fname) + times = ucnobj.get_times() + conc = ucnobj.get_alldata() + + return conc, times + + +def build_mf6_models(idx, dir): + # Base MF6 GWE model type + ws = dir + name = ex[idx] + + print("Building MF6 model...()".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwename = "gwe-" + name + + sim_ws = os.path.join(ws, name) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name=exe_name_mf6, version="mf6" + ) + + # Instantiating MODFLOW 6 time discretization + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=tdis_rc, time_units=time_units + ) + + # Instantiating MODFLOW 6 groundwater flow model + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + model_nam_file="{}.nam".format(gwfname), + ) + + # Instantiating MODFLOW 6 solver for flow model + imsgwf = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="CG", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(imsgwf, [gwfname]) + + # Instantiating MODFLOW 6 discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=np.ones((nlay, nrow, ncol), dtype=int), + filename="{}.dis".format(gwfname), + ) + + # Instantiating MODFLOW 6 node-property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_flows=False, + icelltype=icelltype, + k=k11, + k33=k33, + save_specific_discharge=True, + filename="{}.npf".format(gwfname), + ) + + # Instantiating MODFLOW 6 initial conditions package for flow model + flopy.mf6.ModflowGwfic( + gwf, strt=strt, filename="{}.ic".format(gwfname) + ) + + # Instantiating VSC + if viscosity_on[idx]: + # Instantiate viscosity (VSC) package + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, 20.0, gwename, "temperature")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=8.904e-4, + viscosity_filerecord=vsc_filerecord, + thermal_formulation="nonlinear", + thermal_a2=10.0, + thermal_a3=248.37, + thermal_a4=133.16, + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname="vsc", + filename="{}.vsc".format(gwfname), + ) + + # Instantiating MODFLOW 6 constant head package + flopy.mf6.ModflowGwfchd( + gwf, + maxbound=len(chdspd), + stress_period_data=chdspd, + save_flows=False, + pname="CHD-1", + filename="{}.chd".format(gwfname), + ) + + # Instantiating MODFLOW 6 output control package for flow model + flopy.mf6.ModflowGwfoc( + gwf, + head_filerecord="{}.hds".format(gwfname), + budget_filerecord="{}.cbc".format(gwfname), + headprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], + printrecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], + ) + + # Instantiating MODFLOW 6 groundwater transport package + gwe = flopy.mf6.MFModel( + sim, + model_type="gwe6", + modelname=gwename, + model_nam_file="{}.nam".format(gwename), + ) + gwe.name_file.save_flows = True + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename), + ) + sim.register_ims_package(imsgwe, [gwe.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=1, + filename="{}.dis".format(gwename), + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe, strt=strt_temp, filename="{}.ic".format(gwename) + ) + + # Instantiating MODFLOW 6 transport advection package + if mixelm == 0: + scheme = "UPSTREAM" + elif mixelm == -1: + scheme = "TVD" + else: + raise Exception() + flopy.mf6.ModflowGweadv( + gwe, scheme=scheme, filename="{}.adv".format(gwename) + ) + + # Instantiating MODFLOW 6 transport dispersion package + if dispersivity != 0: + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=True, + alh=dispersivity, + ath1=dispersivity, + ktw=0.5918, + kts=0.2700, + filename="{}.dsp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) + flopy.mf6.ModflowGwemst( + gwe, + porosity=prsity, + cpw=4183.0, + cps=760.0, + rhow=1000.0, + rhos=1500.0, + filename="{}.mst".format(gwename), + ) + + # Instantiating MODFLOW 6 transport constant concentration package + flopy.mf6.ModflowGwetmp( + gwe, + maxbound=len(ctpspd), + stress_period_data=ctpspd, + save_flows=False, + pname="TMP-1", + filename="{}.tmp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + flopy.mf6.ModflowGwessm( + gwe, sources=[[]], filename="{}.ssm".format(gwename) + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe, + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "LAST"), ("BUDGET", "LAST")], + printrecord=[("TEMPERATURE", "LAST"), ("BUDGET", "LAST")], + ) + + # Instantiating MODFLOW 6 flow-transport exchange mechanism + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename="{}.gwfgwe".format(name), + ) + + # Grab output + sim.write_simulation() + fname = os.path.join(ws, gwename + ".ucn") + if os.path.isfile(fname): + os.remove(fname) + success, buff = sim.run_simulation(silent=False, report=True) + if not success: + print(buff) + + # load temperatures + ucnobj = flopy.utils.HeadFile(fname, precision="double", text="TEMPERATURE") + times = ucnobj.get_times() + conc = ucnobj.get_alldata() + + return conc, times + + +# Function to write model files +def write_model(mf2k5, mt3d, sim, silent=True): + if config.writeModel: + mf2k5.write_input() + mt3d.write_input() + sim.write_simulation(silent=silent) + + +# Function to ensure GWE model is working properly +def eval_results(mt3d, mf6): + print("evaluating results...") + + # read transport results from model + mt3d_out_path = mt3d.model_ws + mf6_out_path = mf6.simulation_data.mfpath.get_sim_path() + mf6.simulation_data.mfpath.get_sim_path() + + # Get the MT3DMS concentration output + fname_mt3d = os.path.join(mt3d_out_path, "MT3D001.UCN") + ucnobj_mt3d = flopy.utils.UcnFile(fname_mt3d) + conc_mt3d = ucnobj_mt3d.get_alldata() + + # Get the MF6 concentration output + gwt = mf6.get_model(list(mf6.model_names)[1]) + #ucnobj_mf6 = gwt.output.temperature() + ucnobj_mf6 = gwt.output.concentration() + conc_mf6 = ucnobj_mf6.get_alldata() + + +def eval_results(sim): + print("evaluating results...") + + # read transport results from GWE model + name = ex[sim.idxsim] + gwfname = "gwf-" + name + + fname = gwfname + ".bud" + fname = os.path.join(sim.simpath, fname) + assert os.path.isfile(fname) + budobj = flopy.utils.CellBudgetFile(fname, precision="double") + outbud = budobj.get_data(text=" GHB") + + +def test_gwe_dsp01(): + + # run the test model + idx = 0 + dir = exdirs[idx] + + mt3d_conc, mt3d_times = build_mfmt_models(idx, dir) + gwe_temp, gwe_times = build_mf6_models(idx, dir) + + msg = f"gwe temperatures do not equal mt3dms concentrations" + assert np.allclose(gwe_temp, mt3d_conc, atol=0.41159), msg + + +if __name__ == "__main__": + # ### Heat Transport in 1-dimension + # print message + print(f"standalone run of {os.path.basename(__file__)}") + + # run main routine + test_gwe_dsp01() From dc4cc0fc5612f86acd87f7e6e76fabe17f5d31c1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Dec 2022 08:43:02 -0800 Subject: [PATCH 055/212] These tests have been superceded by those pushed with the VSC PR --- autotest/ex-gwf-vsc03_sfr.py | 470 ------------------------- autotest/ex-gwf_vsc04_lak.py | 568 ------------------------------- autotest/ex-gwt-vsc01.py | 369 -------------------- autotest/ex-gwt-vsc02-bndtype.py | 364 -------------------- 4 files changed, 1771 deletions(-) delete mode 100644 autotest/ex-gwf-vsc03_sfr.py delete mode 100644 autotest/ex-gwf_vsc04_lak.py delete mode 100644 autotest/ex-gwt-vsc01.py delete mode 100644 autotest/ex-gwt-vsc02-bndtype.py diff --git a/autotest/ex-gwf-vsc03_sfr.py b/autotest/ex-gwf-vsc03_sfr.py deleted file mode 100644 index 092f383ad71..00000000000 --- a/autotest/ex-gwf-vsc03_sfr.py +++ /dev/null @@ -1,470 +0,0 @@ -import sys -import math -from io import StringIO -import os -import shutil -import numpy as np -from subprocess import check_output -import flopy - -# Append to system path to include the common subdirectory - -sys.path.append(os.path.join("..", "common")) - -# Import common functionality - -import config -from figspecs import USGSFigure - -mf6exe = os.path.abspath(config.mf6_exe) - -# Base simulation and model name and workspace - -ws = os.path.join('temp', 'examples', 'vsc-sfr01') - - -# Equation for determining land surface elevation with a stream running down the middle -def topElev_sfrCentered(x, y): - return ((-0.003 * x) + 260.) + (((-2E-9 * (x - 5000.)) + 1E-5) * (y + 1500.)**2) - -# Model units -length_units = "m" -time_units = "days" - -# model domain and grid definition -Lx = 10000. -Ly = 3000. -nrow = 60 -ncol = 200 -nlay = 1 -delr = Lx / ncol -delc = Ly / nrow -xmax = ncol * delr -ymax = nrow * delc -X, Y = np.meshgrid(np.linspace(delr / 2, xmax - delr / 2, ncol), - np.linspace(ymax - delc / 2, 0 + delc / 2, nrow)) -ibound = np.ones((nlay, nrow, ncol)) -# Because eqn uses negative values in the Y direction, need to do a little manipulation -Y_m = -1 * np.flipud(Y) -top = topElev_sfrCentered(X, Y_m) -botm = np.zeros(top.shape) -strthd = top - 10. - -# NPF parameters -k11 = 1 -ss = 0.00001 -sy = 0.20 -hani = 1 -laytyp = 1 - -# Package boundary conditions -viscref = 8.904e-4 - -# time params -steady = {0: True, 1: False} -transient = {0: False, 1: True} -nstp = [10, 20] -tsmult = [1, 1] -perlen = [1, 20] - -nouter, ninner = 1000, 300 -hclose, rclose, relax = 1e-3, 1e-4, 0.97 - -# Transport related parameters -initial_temperature = 35.0 # Initial temperature (unitless) -porosity = 0.20 # porosity (unitless) -K_therm = 2.0 # Thermal conductivity # ($W/m/C$) -rho_water = 1000 # Density of water ($kg/m^3$) -rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) -C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) -C_s = 880 # Heat capacity of the solids ($J/kg/C$) -D_m = K_therm / (porosity * rho_water * C_p_w) -rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) -K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) - - -# MODFLOW 6 flopy GWF & GWT simulation object (sim) is returned -# -def build_model(idx, sim_folder='vsc_wSFR'): - print("Building model...{}".format(sim_folder)) - - # generate names for each model - name = "vsc" - gwfname = "gwf-" + name + str(idx) + "-sfr" - gwtname = "gwt-" + name + str(idx) + "-sfr" - - sim_ws = os.path.join(ws, sim_folder) - sim = flopy.mf6.MFSimulation( - sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe - ) - - tdis_rc = [] - for i in range(len(nstp)): - tdis_rc.append((perlen[i], nstp[i], tsmult[i])) - - flopy.mf6.ModflowTdis( - sim, nper=len(nstp), perioddata=tdis_rc, time_units=time_units - ) - - gwf = flopy.mf6.ModflowGwf( - sim, - modelname=gwfname, - save_flows=True, - newtonoptions="newton" - ) - - ims = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="cooley", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwfname), - ) - sim.register_ims_package(ims, [gwfname]) - - # Instantiate discretization package - flopy.mf6.ModflowGwfdis( - gwf, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - ) - - # Instantiate node property flow package - flopy.mf6.ModflowGwfnpf( - gwf, - save_specific_discharge=True, - icelltype=1, # >0 means saturated thickness varies with computed head - k=k11 - ) - - # Instantiate storage package - flopy.mf6.ModflowGwfsto( - gwf, - save_flows=False, - iconvert=laytyp, - ss=ss, - sy=sy, - steady_state=steady, - transient=transient, - ) - - # Instantiate initial conditions package - flopy.mf6.ModflowGwfic(gwf, strt=strthd) - - # Instantiate viscosity package - vsc_filerecord = "{}.vsc.bin".format(gwfname) - vsc_pd = [(0, 0.0, 20.0, gwtname, "TEMPERATURE")] - flopy.mf6.ModflowGwfvsc( - gwf, - viscref=viscref, - viscosity_filerecord=vsc_filerecord, - viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.15)], - nviscspecies=len(vsc_pd), - packagedata=vsc_pd, - pname='vsc', - filename="{}.vsc".format(gwfname) - ) - - # Instantiate output control package - flopy.mf6.ModflowGwfoc( - gwf, - budget_filerecord=f"{gwfname}.cbc", - head_filerecord=f"{gwfname}.hds", - headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], - saverecord=[("HEAD", "ALL")], - printrecord=[("HEAD", "ALL"), ("BUDGET", "LAST")], - ) - - # Instantiate recharge package - # total inflow 2000.0 on each side (4,000 total) - rech = np.zeros_like(top) - rech_rate_lo = 0.001 - rech_rate_hi = 0.015 - for i in np.arange(ncol): - rech[0, i] = rech_rate_lo + \ - (rech_rate_hi - rech_rate_lo) / ncol*i - - rech[-1, :] = rech[0, :] - irch = np.zeros_like(rech) - irch = irch.astype(int) - temperature_array = np.ones_like(irch) * 15.0 - aux = {0: [temperature_array]} - flopy.mf6.ModflowGwfrcha( - gwf, - print_flows=True, - recharge=rech, - irch=irch, - auxiliary=["TEMPERATURE"], - aux=aux, - pname='RCHA-1', - filename="{}.rcha".format(gwfname) - ) - - # Instantiate evapotranspiration package - # ET rate is 0.003 everywhere in the model - evtr_lo = 0.0001 - evtr_hi = 0.012 - extdp_hi = 30 - extdp_lo = 10 - evtspd = [] - for i in np.arange(nrow): - for j in np.arange(ncol): - evtr = evtr_hi - (evtr_hi - evtr_lo) / ncol * j - extdp = extdp_hi - (extdp_hi - extdp_lo) / ncol * j - # cellid, surface, rate, depth, [pxdp], [petm], [petm0], [aux] - evtspd.append([(0, i, j), top[i, j], evtr, extdp, 1.0, 0.0]) - surf_rate_specified = True - flopy.mf6.ModflowGwfevt( - gwf, - print_flows=False, - surf_rate_specified=surf_rate_specified, - maxbound=nrow*ncol, - nseg=1, - stress_period_data=evtspd, - auxiliary='TEMPERATURE', - pname='EVT-1', - filename="{}.evt".format(gwfname) - ) - - # Instantiate streamflow routing package - - # Determine the middle row and store in rMid (account for 0-base) - rMid = nrow // 2 - 1 - # sfr data - nreaches = ncol - rlen = delr - rwid = 7.0 - roughness = 0.035 - rbth = 1.0 - rhk = 1.0 - strm_up = 254.899750 - strm_dn = 225.150250 - slope = (strm_up - strm_dn) / ((ncol - 1) * delr) - ustrf = 1.0 - ndv = 0 - strm_incision = 10 - viscaux = 1.111111111 - temperatureaux = 8.0 - - - packagedata = [] - for irch in range(nreaches): - nconn = 1 - if 0 < irch < nreaches - 1: - nconn += 1 - rp = [ - irch, - (0, rMid, irch), - rlen, - rwid, - slope, - top[rMid, irch] - strm_incision, - rbth, - rhk, - roughness, - nconn, - ustrf, - ndv, - viscaux, - temperatureaux - ] - packagedata.append(rp) - - connectiondata = [] - for irch in range(nreaches): - rc = [irch] - if irch > 0: - rc.append(irch - 1) - if irch < nreaches - 1: - rc.append(-(irch + 1)) - connectiondata.append(rc) - - inflow_loc = 0 - sfr_perioddata = [ - [inflow_loc, "inflow", 25000.0], - ] - sfr_perioddata = {0: sfr_perioddata} - - budpth = f"{gwfname}.sfr.cbc" - flopy.mf6.ModflowGwfsfr( - gwf, - print_stage=True, - print_flows=True, - print_input=False, - auxiliary=["VDUMMY", "TEMPERATURE"], - unit_conversion=1.486 * 86400, - budget_filerecord=budpth, - mover=False, - nreaches=nreaches, - packagedata=packagedata, - connectiondata=connectiondata, - perioddata=sfr_perioddata, - pname="SFR-1", - filename="{}.sfr".format(gwfname) - ) - - # Setup the GWT model for simulating heat transport - gwt = flopy.mf6.ModflowGwt(sim, modelname=gwtname) - imsgwt = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="NONE", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwtname), - ) - sim.register_ims_package(imsgwt, [gwtname]) - flopy.mf6.ModflowGwtdis( - gwt, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - ) - - # Instantiate Mobile Storage and Transfer package - flopy.mf6.ModflowGwtmst( - gwt, - porosity=porosity, - sorption='linear', - bulk_density=rhob, - distcoef=K_d, - pname="MST-1", - filename="{}.mst".format(gwtname), - ) - - # Instantiate Transport Initial Conditions package - flopy.mf6.ModflowGwtic(gwt, strt=initial_temperature) - - # Instantiate Advection package - flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") - - # Instantiate Dispersion package (also handles conduction) - flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) - - # Instantiate Source/Sink Mixing package - sourcerecarray = [ - ("RCHA-1", "AUX", "TEMPERATURE"), - ("EVT-1", "AUX", "TEMPERATURE") - ] - flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) - - # Instantiate Streamflow Transport package - sftpackagedata = [] - for irno in range(ncol): - t = (irno, 0.0) - sftpackagedata.append(t) - - sftperioddata = [(0, "STATUS", "CONSTANT"), (0, "CONCENTRATION", 8.0)] - - flopy.mf6.modflow.ModflowGwtsft( - gwt, - boundnames=False, - save_flows=True, - print_input=False, - print_flows=True, - print_concentration=True, - concentration_filerecord=gwtname + ".sft.bin", - budget_filerecord=gwtname + ".sft.bud", - packagedata=sftpackagedata, - reachperioddata=sftperioddata, - flow_package_auxiliary_name="TEMPERATURE", - flow_package_name='SFR-1', - pname="SFT-1", - filename="{}.sft".format(gwtname), - ) - - # Instantiate Output Control package for transport - flopy.mf6.ModflowGwtoc( - gwt, - concentration_filerecord="{}.ucn".format(gwtname), - saverecord=[("CONCENTRATION", "ALL")], - printrecord=[("CONCENTRATION", "LAST"), ("BUDGET", "LAST")], - filename="{}.oc".format(gwtname), - ) - - # Instantiate Gwf-Gwt Exchange package - flopy.mf6.ModflowGwfgwt( - sim, - exgtype="GWF6-GWT6", - exgmnamea=gwfname, - exgmnameb=gwtname, - filename="{}.gwfgwt".format(gwtname), - ) - - return sim - - -# Function to write model files - - -def write_model(sim, silent=True): - if config.writeModel: - sim.write_simulation(silent=silent) - return - -# Function to run the model -# True is returned if the model runs successfully - - -@config.timeit -def run_model(sim, silent=True): - success = True - if config.runModel: - success = False - success, buff = sim.run_simulation(silent=silent) - if not success: - print(buff) - return success - - -def scenario(idx, silent=True): - # Three model runs that are all part of the same scenario - - # Model Run 1 (Do not account for the effects of viscosity) - # --------------------------------------------------------- - #key = list(parameters.keys())[idx] - #parameter_dict = parameters[key] - sim = build_model(idx + 1) - write_model(sim, silent=silent) - - -def test_01(): - scenario(0, silent=False) - - -# nosetest end - -if __name__ == "__main__": - # ### Henry Problem - - # Scenario 1 - Compare model runs with and without viscosity package active - - scenario(0) - - diff --git a/autotest/ex-gwf_vsc04_lak.py b/autotest/ex-gwf_vsc04_lak.py deleted file mode 100644 index 5a7a9364a6c..00000000000 --- a/autotest/ex-gwf_vsc04_lak.py +++ /dev/null @@ -1,568 +0,0 @@ -# Simple single lake model. Lake cut into top two layers. Model -# is loosely based on one of the MT3D-USGS test problems. This test -# developed to isolate lake-aquifer interaction; no SFR or other advanced -# packages. Problem set up to have groundwater pass through the lake: -# gw inflow on the left side, gw outflow on the right side of the lake. - - -import os -import sys - -import numpy as np -import pytest - -try: - import flopy -except: - msg = "Error. FloPy package is not available.\n" - msg += "Try installing using the following command:\n" - msg += " pip install flopy" - raise Exception(msg) - -from framework import testing_framework -from simulation import Simulation -import config - -ex = ["vsc-lak01"] -exdirs = [] -for s in ex: - exdirs.append(os.path.join("temp", "examples", s)) - -# Model units -length_units = "m" -time_units = "days" - -# model domain and grid definition -delr = [ - 76.2, - 304.8, - 304.8, - 304.8, - 304.8, - 304.8, - 152.4, - 152.4, - 152.4, - 152.4, - 152.4, - 304.8, - 304.8, - 304.8, - 304.8, - 304.8, - 76.2 -] - -delc = [ - 76.2, - 304.8, - 304.8, - 304.8, - 304.8, - 304.8, - 152.4, - 152.4, - 152.4, - 152.4, - 152.4, - 304.8, - 304.8, - 304.8, - 304.8, - 304.8, - 76.2 -] - -fixedstrthds = [ - 35.052, - 34.9267, - 34.7216, - 34.5062, - 34.2755, - 34.0237, - 33.8143, - 33.6657, - 33.5077, - 33.3394, - 33.1599, - 32.8728, - 32.4431, - 31.9632, - 31.4353, - 30.8627, - 30.48 -] - -nrow = len(delc) -ncol = len(delr) -top = np.ones((nrow, ncol)) * 35.6616 -bot1 = np.ones_like(top) * 32.6136 -bot2 = np.ones_like(top) * 29.5656 -bot3 = np.ones_like(top) * 26.5176 -bot4 = np.ones_like(top) * 23.4696 -bot5 = np.ones_like(top) * 20.4216 -botm = np.array([bot1, bot2, bot3, bot4, bot5]) -nlay = botm.shape[0] -ibound = np.ones_like(botm) - -# deactive gw cells where lake cells are active -ibound[0, 6:11, 6:11] = 0 # layer 1 -ibound[1, 7:10, 7:10] = 0 # layer 2 - -strthd = np.zeros_like(ibound) -for j in np.arange(ncol): - strthd[:, :, j] = fixedstrthds[j] - -# setup lake array -lakibnd = np.zeros_like(ibound) -lakibnd[0] = 1 - ibound[0] # layer 1 -lakibnd[1] = 1 - ibound[1] # layer 2 - -# NPF parameters -k11 = 9.144 # = 30 ft/day -k33 = 0.9144 # = 30 ft/day -ss = 3e-4 -sy = 0.20 -hani = 1 -laytyp = 1 - -# Package boundary conditions -chdl = 35.052 -chdr = 30.48 -viscref = 8.904e-4 - -# time params -transient = {0: True} -nstp = [100] -tsmult = [1.02] -perlen = [5000] - -# solver params -nouter, ninner = 1000, 300 -hclose, rclose, relax = 1e-3, 1e-4, 0.97 - -# Transport related parameters -al = 1 # longitudinal dispersivity ($m$) -ath1 = al # horizontal transverse dispersivity -atv = al # vertical transverse dispersivity -mixelm = 0 # Upstream vs TVD (Upstream selected) -initial_temperature = 35.0 # Initial temperature (unitless) -porosity = 0.20 # porosity (unitless) -K_therm = 2.0 # Thermal conductivity # ($W/m/C$) -rho_water = 1000 # Density of water ($kg/m^3$) -rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) -C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) -C_s = 880 # Heat capacity of the solids ($J/kg/C$) -D_m = K_therm / (porosity * rho_water * C_p_w) -rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) -K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) -leftTemp = 30.0 # Temperature of inflow from left constant head ($C$) - -# Viscosity related parameters -tviscref = 20.0 - -# MODFLOW 6 flopy GWF & GWT simulation object (sim) is returned -# -def build_model(idx, sim_folder='vsc_wLAK'): - print("Building model...{}".format(sim_folder)) - - # generate names for each model - name = "vsc" - gwfname = "gwf-" + name + str(idx) + "-lak" - gwtname = "gwt-" + name + str(idx) + "-lak" - - sim_ws = os.path.join(exdirs[0], sim_folder) - sim = flopy.mf6.MFSimulation( - sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe - ) - - tdis_rc = [] - for i in range(len(nstp)): - tdis_rc.append((perlen[i], nstp[i], tsmult[i])) - - flopy.mf6.ModflowTdis( - sim, nper=len(nstp), perioddata=tdis_rc, time_units=time_units - ) - - gwf = flopy.mf6.ModflowGwf( - sim, - modelname=gwfname, - save_flows=True, - newtonoptions="newton" - ) - - ims = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="cooley", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwfname), - ) - sim.register_ims_package(ims, [gwfname]) - - # Instantiate discretization package - flopy.mf6.ModflowGwfdis( - gwf, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - idomain=ibound, - filename='{}.dis'.format(gwfname) - ) - - # Instantiate node property flow package - flopy.mf6.ModflowGwfnpf( - gwf, - save_specific_discharge=True, - icelltype=1, # >0 means saturated thickness varies with computed head - k=k11, - k33=k33 - ) - - # Instantiate storage package - flopy.mf6.ModflowGwfsto( - gwf, - save_flows=False, - iconvert=laytyp, - ss=ss, - sy=sy, - transient=transient - ) - - # Instantiate initial conditions package - flopy.mf6.ModflowGwfic( - gwf, - strt=strthd - ) - - # Instantiate viscosity package - vsc_filerecord = "{}.vsc.bin".format(gwfname) - vsc_pd = [(0, 0.0, tviscref, gwtname, "TEMPERATURE")] - flopy.mf6.ModflowGwfvsc( - gwf, - viscref=viscref, - viscosity_filerecord=vsc_filerecord, - viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.15)], - nviscspecies=len(vsc_pd), - packagedata=vsc_pd, - pname='vsc', - filename="{}.vsc".format(gwfname) - ) - - # Instantiate output control package - flopy.mf6.ModflowGwfoc( - gwf, - budget_filerecord=f"{gwfname}.cbc", - head_filerecord=f"{gwfname}.hds", - headprintrecord=[("COLUMNS", 17, "WIDTH", 15, "DIGITS", 6, "GENERAL")], - saverecord=[("HEAD", "ALL")], - printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], - ) - - # Instantiate constant head package - # (for driving gw flow from left to right) - chdlistl = [] - chdlistr = [] - for k in np.arange(nlay): - for i in np.arange(nrow): - # left side - if botm[k, i, 0] <= chdl: - chdlistl.append([(k, i, 0), chdl, leftTemp]) - # right side - if botm[k, i, -1] <= chdr: - chdlistr.append([(k, i, ncol - 1), chdr, 10.0]) - - flopy.mf6.ModflowGwfchd( - gwf, - stress_period_data=chdlistl, - print_input=True, - print_flows=True, - save_flows=False, - pname="CHD-L", - auxiliary="TEMPERATURE", - filename=f"{gwfname}.left.chd", - ) - - flopy.mf6.ModflowGwfchd( - gwf, - stress_period_data=chdlistr, - print_input=True, - print_flows=True, - save_flows=False, - pname="CHD-R", - auxiliary="TEMPERATURE", - filename=f"{gwfname}.right.chd", - ) - - # Instantiate lake package - - lakeconnectiondata = [] - nlakecon = [0] # Expand this to [0, 0, ...] for each additional lake - ilakconn = -1 - lak_leakance = 0.1 - for k in [0, 1]: - for i in range(nrow): - for j in range(ncol): - if lakibnd[k, i, j] == 0: - continue - else: - ilak = int(lakibnd[k, i, j] - 1) - # back - if i > 0: - if lakibnd[k, i - 1, j] == 0 and ibound[k, i - 1, j] == 1: - ilakconn += 1 - # by setting belev==telev, MF6 will automatically re-assign elevations based on cell dimensions - # - h = [ilak, ilakconn, (k, i - 1, j), 'horizontal', lak_leakance, 0.0, 0.0, delc[i] / 2., delr[j]] - lakeconnectiondata.append(h) - - # left - if j > 0: - if lakibnd[k, i, j - 1] == 0 and ibound[k, i, j - 1] == 1: - ilakconn += 1 - h = [ilak, ilakconn, (k, i, j - 1), 'horizontal', lak_leakance, 0.0, 0.0, delr[j] / 2., delc[i]] - lakeconnectiondata.append(h) - - # right - if j < ncol - 1: - if lakibnd[k, i, j + 1] == 0 and ibound[k, i, j + 1] == 1: - ilakconn += 1 - h = [ilak, ilakconn, (k, i, j + 1), 'horizontal', lak_leakance, 0.0, 0.0, delr[j] / 2., delc[i]] - lakeconnectiondata.append(h) - - # front - if i < nrow - 1: - if lakibnd[k, i + 1, j] == 0 and ibound[k, i + 1, j] == 1: - ilakconn += 1 - h = [ilak, ilakconn, (k, i + 1, j), 'horizontal', lak_leakance, 0.0, 0.0, delc[i] / 2., delr[j]] - lakeconnectiondata.append(h) - - # vertical - if lakibnd[k, i, j] == 1 and ibound[k + 1, i, j] == 1: - ilakconn += 1 - v = [ilak, ilakconn, (k + 1, i, j), 'vertical', lak_leakance, 0.0, 0.0, 0.0, 0.0] - lakeconnectiondata.append(v) - - strtStg = 33.75 - lakpackagedata = [[0, strtStg, len(lakeconnectiondata), 4.0, 'lake1']] - lak_pkdat_dict = {'filename': "lak_pakdata.in", 'data': lakpackagedata} - - lakeperioddata = {0: [(0, 'STATUS', 'CONSTANT'), #RAINFALL 0.005 & 0.00504739035 - (0, 'STAGE', 33.5)]} - - lak_obs = {'{}.lakeobs'.format(gwfname): [('lakestage', 'stage', 'lake1'), - ('gwexchng', 'lak', 'lake1')]} - lak = flopy.mf6.ModflowGwflak( - gwf, - auxiliary="TEMPERATURE", - time_conversion=86400.0, - print_stage=True, - print_flows=True, - budget_filerecord=gwfname + '.lak.bud', - length_conversion=1.0, - mover=False, - pname='LAK-1', - boundnames=True, - nlakes=len(lakpackagedata), - noutlets=0, - packagedata=lak_pkdat_dict, - connectiondata=lakeconnectiondata, - perioddata=lakeperioddata, - observations=lak_obs, - filename='{}.lak'.format(gwfname) - ) - - # pull in th etabfile defining the lake stage, vol, & surface area - fname = os.path.join('data', 'vsc04-laktab', 'stg-vol-surfarea.csv') - tabinput = [] - with open(fname, 'r') as f: - # peel off the hdr line - hdr = next(f) - for line in f: - m_arr = line.strip().split(',') - # , , , - tabinput.append([float(m_arr[0]), m_arr[1], m_arr[2]]) - - tab6_filename = '{}.laktab'.format(gwfname) - flopy.mf6.ModflowUtllaktab( - gwf, - nrow=len(tabinput), - ncol=3, - table=tabinput, - filename=tab6_filename, - pname='LAK_tab', - parent_file=lak - ) - - # create gwt model - # ---------------- - gwt = flopy.mf6.ModflowGwt( - sim, - modelname=gwtname, - model_nam_file='{}.nam'.format(gwtname) - ) - gwt.name_file.save_flows = True - - imsgwt = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="NONE", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename=f"{gwtname}.ims", - ) - sim.register_ims_package(imsgwt, [gwt.name]) - - # Instantiating MODFLOW 6 transport discretization package - flopy.mf6.ModflowGwtdis( - gwt, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - idomain=ibound, - filename='{}.dis'.format(gwtname) - ) - - # Instantiating MODFLOW 6 transport initial concentrations - strtconc = leftTemp - flopy.mf6.ModflowGwtic( - gwt, - strt=strtconc, - filename='{}.ic'.format(gwtname) - ) - - # Instantiate mobile storage and transfer package - sto = flopy.mf6.ModflowGwtmst( - gwt, porosity=porosity, filename=f"{gwtname}.sto" - ) - - # Instantiating MODFLOW 6 transport advection package - if mixelm == 0: - scheme = 'UPSTREAM' - elif mixelm == -1: - scheme = 'TVD' - else: - raise Exception() - flopy.mf6.ModflowGwtadv(gwt, - scheme=scheme, - filename='{}.adv'.format(gwtname) - ) - - # Instantiate dispersion package - flopy.mf6.ModflowGwtdsp( - gwt, - alh=al, - ath1=ath1, - atv=atv, - filename='{}.dsp'.format(gwtname) - ) - - # Instantiate source/sink mixing package - sourcerecarray = [ - ("CHD-L", "AUX", "TEMPERATURE"), - ("CHD-R", "AUX", "TEMPERATURE"), - ] - flopy.mf6.ModflowGwtssm( - gwt, - sources=sourcerecarray, - filename=f"{gwtname}.ssm" - ) - - # Instantiating MODFLOW 6 transport output control package - flopy.mf6.ModflowGwtoc( - gwt, - budget_filerecord='{}.cbc'.format(gwtname), - concentration_filerecord='{}.ucn'.format( - gwtname), - concentrationprintrecord=[ - ('COLUMNS', 17, 'WIDTH', 15, 'DIGITS', 6, 'GENERAL')], - saverecord=[('CONCENTRATION', 'ALL'), ('BUDGET', 'ALL')], - printrecord=[('CONCENTRATION', 'ALL'), ('BUDGET', 'ALL')], - filename='{}.oc'.format(gwtname) - ) - - # Instantiating MODFLOW 6 lake transport (lkt) package - lktpackagedata = [(0, 4., 'lake1')] - - lktperioddata = {0: [(0, 'STATUS', 'CONSTANT'), - (0, 'CONCENTRATION', 4.0)]} - - # note: for specifying lake number, use fortran indexing! - lkt_obs = {'{}.lakobs'.format(gwtname): [('resTemp', 'concentration', 1), - ('resGwMassExchng', 'lkt', 'lake1')]} - - flopy.mf6.ModflowGwtlkt( - gwt, # Set time_conversion for use with Manning's eqn. - flow_package_name='LAK-1', - flow_package_auxiliary_name='TEMPERATURE', - budget_filerecord=gwtname + '.lkt.bud', - boundnames=True, - save_flows=True, - print_input=True, - print_flows=False, - print_concentration=True, - packagedata=lktpackagedata, - lakeperioddata=lktperioddata, - observations=lkt_obs, - pname='LKT-1', - filename='{}.lkt'.format(gwtname) - ) - - # GWF GWT exchange - flopy.mf6.ModflowGwfgwt( - sim, - exgtype="GWF6-GWT6", - exgmnamea=gwfname, - exgmnameb=gwtname, - filename=f"{name}.gwfgwt", - ) - - return sim - - -def write_model(sim, silent=True): - if config.writeModel: - sim.write_simulation(silent=silent) - return - - -def scenario(idx, silent=True): - sim = build_model(idx) - write_model(sim, silent=silent) - - -# nosetest - exclude block from this nosetest to the next nosetest -def test_01(): - scenario(0, silent=False) - -# nosetest end - -if __name__ == "__main__": - - # ### MT3D-USGS LKT test problem adapted for testing vsc in/out of lake - scenario(0) - diff --git a/autotest/ex-gwt-vsc01.py b/autotest/ex-gwt-vsc01.py deleted file mode 100644 index eb8e0f50513..00000000000 --- a/autotest/ex-gwt-vsc01.py +++ /dev/null @@ -1,369 +0,0 @@ -# ## Test problem for VSC -# -# Model domain is lifted from the Henry Problem -# - -# ### VSC Problem Setup - -# Imports - -import os -import sys -import matplotlib.pyplot as plt -import flopy -import numpy as np - -# Append to system path to include the common subdirectory - -sys.path.append(os.path.join("..", "common")) - -# Import common functionality - -import config -from figspecs import USGSFigure - -mf6exe = os.path.abspath(config.mf6_exe) - - -# Set figure properties specific to this problem - -figure_size = (6, 4) - -# Base simulation and model name and workspace - -ws = os.path.join('temp', 'examples', 'vsc-chd-ghb') - -# Scenario parameters - make sure there is at least one blank line before next item - -hyd_cond = [1205.49396942506, 864.0] # Hydraulic conductivity ($m d^{-1}$) -parameters = { - "ex-gwt-no-vsc": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[0]}, - "ex-gwt-vsc": {"vsc_on": True, "hydraulic_conductivity": hyd_cond[1]}, - "ex-gwt-no-vsc-low-k": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[1]} -} - -# Model units - -length_units = "cm" -time_units = "seconds" - -# Table of model parameters - -nper = 1 # Number of periods -nstp = 500 # Number of time steps -perlen = 0.5 # Simulation time length ($d$) -nlay = 1 # Number of layers -nrow = 10 # Number of rows -ncol = 80 # Number of columns -system_length = 2.0 # Length of system ($m$) -delr = 1.0 # Column width ($m$) -delc = 1.0 # Row width ($m$) -delv = 1.0 # Layer thickness -top = 1.0 # Top of the model ($m$) -initial_temperature = 35.0 # Initial temperature (unitless) -porosity = 0.26 # porosity (unitless) -K_therm = 2.0 # Thermal conductivity # ($W/m/C$) -rho_water = 1000 # Density of water ($kg/m^3$) -rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) -C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) -C_s = 880 # Heat capacity of the solids ($J/kg/C$) -D_m = K_therm / (porosity * rho_water * C_p_w) -rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) -K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) -inflow = 5.7024 # ($m^3/d$) - -botm = [top - k * delv for k in range(1, nlay + 1)] - -nouter, ninner = 100, 300 -hclose, rclose, relax = 1e-10, 1e-6, 0.97 - - -# ### Functions to build, write, run, and plot models -# -# MODFLOW 6 flopy GWF simulation object (sim) is returned -# - - -def build_model(idx, sim_folder, vsc_on, hydraulic_conductivity): - print("Building model...{}".format(sim_folder)) - - # generate names for each model - name = "vsc" - gwfname = "gwf-" + name + "-" + str(idx) - gwtname = "gwt-" + name + "-" + str(idx) - - sim_ws = os.path.join(ws, sim_folder) - sim = flopy.mf6.MFSimulation( - sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe - ) - tdis_ds = ((perlen, nstp, 1.0),) - flopy.mf6.ModflowTdis( - sim, nper=nper, perioddata=tdis_ds, time_units=time_units - ) - gwf = flopy.mf6.ModflowGwf(sim, modelname=gwfname, save_flows=True) - ims = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="NONE", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwfname), - ) - sim.register_ims_package(ims, [gwfname]) - flopy.mf6.ModflowGwfdis( - gwf, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - ) - flopy.mf6.ModflowGwfnpf( - gwf, - save_specific_discharge=True, - icelltype=0, - k=hydraulic_conductivity, - ) - flopy.mf6.ModflowGwfic(gwf, strt=0.0) - - if vsc_on: - # Instantiate viscosity (VSC) package - vsc_filerecord = "{}.vsc.bin".format(gwfname) - vsc_pd = [(0, 0.0, 20.0, gwtname, "temperature")] - flopy.mf6.ModflowGwfvsc( - gwf, - viscref=8.904e-4, - viscosity_filerecord=vsc_filerecord, - viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], - nviscspecies=len(vsc_pd), - packagedata=vsc_pd, - pname='vsc', - filename="{}.vsc".format(gwfname) - ) - - # Instantiating GHB - ghbcond = hydraulic_conductivity * delv * delc / (0.5 * delr) - ghbspd = [[(0, i, ncol - 1), top, ghbcond, initial_temperature] for i in range(nrow)] - flopy.mf6.ModflowGwfghb( - gwf, - stress_period_data=ghbspd, - pname="GHB-1", - auxiliary="temperature", - ) - - # Instantiating WEL - chdspd = [[(0, i, 0), 2.0, initial_temperature] for i in range(nrow)] - flopy.mf6.ModflowGwfchd( - gwf, - stress_period_data=chdspd, - pname="CHD-1", - auxiliary="temperature", - ) - head_filerecord = "{}.hds".format(name) - budget_filerecord = "{}.bud".format(name) - - # Instatiatingi OC - flopy.mf6.ModflowGwfoc( - gwf, - head_filerecord=head_filerecord, - budget_filerecord=budget_filerecord, - saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], - ) - - # Setup the GWT model for simulating heat transport - gwt = flopy.mf6.ModflowGwt(sim, modelname=gwtname) - imsgwt = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="NONE", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwtname), - ) - sim.register_ims_package(imsgwt, [gwtname]) - flopy.mf6.ModflowGwtdis( - gwt, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - ) - - flopy.mf6.ModflowGwtmst( - gwt, - porosity=porosity, - sorption='linear', - bulk_density=rhob, - distcoef=K_d, - pname="MST-1", - filename="{}.mst".format(gwtname), - ) - - flopy.mf6.ModflowGwtic(gwt, strt=initial_temperature) - flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") - flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) - sourcerecarray = [ - ("CHD-1", "AUX", "TEMPERATURE"), - ("GHB-1", "AUX", "TEMPERATURE"), - ] - flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) - flopy.mf6.ModflowGwtoc( - gwt, - concentration_filerecord="{}.ucn".format(gwtname), - saverecord=[("CONCENTRATION", "ALL")], - printrecord=[("CONCENTRATION", "LAST"), ("BUDGET", "LAST")], - ) - flopy.mf6.ModflowGwfgwt( - sim, - exgtype="GWF6-GWT6", - exgmnamea=gwfname, - exgmnameb=gwtname - ) - return sim - - -# Function to write model files - - -def write_model(sim, silent=True): - if config.writeModel: - sim.write_simulation(silent=silent) - return - - -# Function to run the model -# True is returned if the model runs successfully - - -@config.timeit -def run_model(sim, silent=True): - success = True - if config.runModel: - success = False - success, buff = sim.run_simulation(silent=silent) - if not success: - print(buff) - return success - - -# Function to plot the model results - - -def plot_conc(sim, idx): - fs = USGSFigure(figure_type="map", verbose=False) - sim_name = list(parameters.keys())[idx] - sim_ws = os.path.join(ws, sim_name) - gwf = sim.get_model("flow") - gwt = sim.get_model("trans") - - fig = plt.figure(figsize=figure_size) - fig.tight_layout() - - # get MODFLOW 6 temperature - conc = gwt.output.temperature().get_data() - - ax = fig.add_subplot(1, 1, 1, aspect="equal") - pxs = flopy.plot.PlotCrossSection(model=gwf, ax=ax, line={"row": 0}) - pxs.plot_array(conc, cmap="jet") - levels = [35 * f for f in [0.01, 0.1, 0.5, 0.9, 0.99]] - cs = pxs.contour_array( - conc, levels=levels, colors="w", linewidths=1.0, linestyles="-" - ) - ax.set_xlabel("x position (m)") - ax.set_ylabel("z position (m)") - plt.clabel(cs, fmt="%4.2f", fontsize=5) - - # save figure - if config.plotSave: - fpth = os.path.join( - "..", "figures", "{}-conc{}".format(sim_name, config.figure_ext) - ) - fig.savefig(fpth) - return - - -def plot_results(sim, idx): - if config.plotModel: - plot_conc(sim, idx) - return - - -# Function that wraps all of the steps for each scenario -# -# 1. build_model, -# 2. write_model, -# 3. run_model, and -# 4. plot_results. -# - - -def scenario(idx, silent=True): - # Three model runs that are all part of the same scenario - - # Model Run 1 (Do not account for the effects of viscosity) - # --------------------------------------------------------- - key = list(parameters.keys())[idx] - parameter_dict = parameters[key] - sim = build_model(idx + 1, key, **parameter_dict) - write_model(sim, silent=silent) - #success = run_model(sim, silent=silent) - #if success: - # plot_results(sim, idx) - - # Model Run 2 (Activate viscosity package) - # ---------------------------------------- - idx += 1 - key = list(parameters.keys())[idx] - parameter_dict = parameters[key] - sim = build_model(idx + 1, key, **parameter_dict) - write_model(sim, silent=silent) - #success = run_model(sim, silent=silent) - #if success: - # plot_results(sim, idx) - - # Model Run 3 (No VSC package; use same K as when VSC package active; - # should get a different solution) - # ------------------------------------------------------------------ - idx += 1 - key = list(parameters.keys())[idx] - parameter_dict = parameters[key] - sim = build_model(idx + 1, key, **parameter_dict) - write_model(sim, silent=silent) - - -# nosetest - exclude block from this nosetest to the next nosetest -def test_01(): - scenario(0, silent=False) - - - -# nosetest end - -if __name__ == "__main__": - # ### Henry Problem - - # Scenario 1 - Compare model runs with and without viscosity package active - - scenario(0) - diff --git a/autotest/ex-gwt-vsc02-bndtype.py b/autotest/ex-gwt-vsc02-bndtype.py deleted file mode 100644 index 497dcf8d5d5..00000000000 --- a/autotest/ex-gwt-vsc02-bndtype.py +++ /dev/null @@ -1,364 +0,0 @@ -# ## Test problem for VSC -# -# Model domain is lifted from the Henry Problem -# - -# ### VSC Problem Setup - -# Imports - -import os -import sys -import matplotlib.pyplot as plt -import flopy -import numpy as np - -# Append to system path to include the common subdirectory - -sys.path.append(os.path.join("..", "common")) - -# Import common functionality - -import config -from figspecs import USGSFigure - -mf6exe = os.path.abspath(config.mf6_exe) - - -# Set figure properties specific to this problem - -figure_size = (6, 4) - -# Base simulation and model name and workspace - -ws = os.path.join('temp', 'examples', 'vsc-ghb-drn') - -# Scenario parameters - make sure there is at least one blank line before next item - -hyd_cond = [1205.49396942506, 864.0] # Hydraulic conductivity ($m d^{-1}$) -parameters = { - "ex-gwt-no-vsc": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[0]}, - "ex-gwt-vsc": {"vsc_on": True, "hydraulic_conductivity": hyd_cond[1]}, - "ex-gwt-no-vsc-low-k": {"vsc_on": False, "hydraulic_conductivity": hyd_cond[1]} -} - -# Model units - -length_units = "cm" -time_units = "seconds" - -# Table of model parameters - -nper = 1 # Number of periods -nstp = 500 # Number of time steps -perlen = 0.5 # Simulation time length ($d$) -nlay = 1 # Number of layers -nrow = 10 # Number of rows -ncol = 80 # Number of columns -system_length = 2.0 # Length of system ($m$) -delr = 1.0 # Column width ($m$) -delc = 1.0 # Row width ($m$) -delv = 1.0 # Layer thickness -top = 1.0 # Top of the model ($m$) -initial_temperature = 35.0 # Initial temperature (unitless) -porosity = 0.26 # porosity (unitless) -K_therm = 2.0 # Thermal conductivity # ($W/m/C$) -rho_water = 1000 # Density of water ($kg/m^3$) -rho_solids = 2650 # Density of the aquifer material ($kg/m^3$) -C_p_w = 4180 # Heat Capacity of water ($J/kg/C$) -C_s = 880 # Heat capacity of the solids ($J/kg/C$) -D_m = K_therm / (porosity * rho_water * C_p_w) -rhob = (1 - porosity) * rho_solids # Bulk density ($kg/m^3$) -K_d = C_s / (rho_water * C_p_w) # Partitioning coefficient ($m^3/kg$) -inflow = 5.7024 # ($m^3/d$) - -botm = [top - k * delv for k in range(1, nlay + 1)] - -nouter, ninner = 100, 300 -hclose, rclose, relax = 1e-10, 1e-6, 0.97 - - -# ### Functions to build, write, run, and plot models -# -# MODFLOW 6 flopy GWF simulation object (sim) is returned -# - - -def build_model(idx, sim_folder, vsc_on, hydraulic_conductivity): - print("Building model...{}".format(sim_folder)) - - # generate names for each model - name = "vsc02" - gwfname = "gwf-" + name + "-" + str(idx) - gwtname = "gwt-" + name + "-" + str(idx) - - sim_ws = os.path.join(ws, sim_folder) - sim = flopy.mf6.MFSimulation( - sim_name=name, sim_ws=sim_ws, exe_name=config.mf6_exe - ) - tdis_ds = ((perlen, nstp, 1.0),) - flopy.mf6.ModflowTdis( - sim, nper=nper, perioddata=tdis_ds, time_units=time_units - ) - gwf = flopy.mf6.ModflowGwf(sim, modelname=gwfname, save_flows=True) - ims = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="NONE", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwfname), - ) - sim.register_ims_package(ims, [gwfname]) - flopy.mf6.ModflowGwfdis( - gwf, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - ) - flopy.mf6.ModflowGwfnpf( - gwf, - save_specific_discharge=True, - icelltype=0, - k=hydraulic_conductivity, - ) - flopy.mf6.ModflowGwfic(gwf, strt=0.0) - - if vsc_on: - # Instantiate viscosity (VSC) package - vsc_filerecord = "{}.vsc.bin".format(gwfname) - vsc_pd = [(0, 0.0, 20.0, gwtname, "temperature")] - flopy.mf6.ModflowGwfvsc( - gwf, - viscref=8.904e-4, - viscosity_filerecord=vsc_filerecord, - viscosityfuncrecord=[('nonlinear', 10.0, 248.37, 133.16)], - nviscspecies=len(vsc_pd), - packagedata=vsc_pd, - pname='vsc', - filename="{}.vsc".format(gwfname) - ) - - # Instantiating GHB - ghbcond = hydraulic_conductivity * delv * delc / (0.5 * delr) - ghbspd = [[(0, i, 0), top+3, ghbcond, initial_temperature] for i in range(nrow)] - flopy.mf6.ModflowGwfghb( - gwf, - stress_period_data=ghbspd, - pname="GHB-1", - auxiliary="temperature", - ) - - # Instantiating DRN - drnspd = [[(0, i, ncol - 1), top, 1.2 * ghbcond, initial_temperature] for i in range(nrow)] - flopy.mf6.ModflowGwfdrn( - gwf, - stress_period_data=drnspd, - pname="DRN-1", - auxiliary="temperature", - ) - head_filerecord = "{}.hds".format(name) - budget_filerecord = "{}.bud".format(name) - - # Instatiatingi OC - flopy.mf6.ModflowGwfoc( - gwf, - head_filerecord=head_filerecord, - budget_filerecord=budget_filerecord, - saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], - ) - - # Setup the GWT model for simulating heat transport - gwt = flopy.mf6.ModflowGwt(sim, modelname=gwtname) - imsgwt = flopy.mf6.ModflowIms( - sim, - print_option="ALL", - outer_dvclose=hclose, - outer_maximum=nouter, - under_relaxation="NONE", - inner_maximum=ninner, - inner_dvclose=hclose, - rcloserecord=rclose, - linear_acceleration="BICGSTAB", - scaling_method="NONE", - reordering_method="NONE", - relaxation_factor=relax, - filename="{}.ims".format(gwtname), - ) - sim.register_ims_package(imsgwt, [gwtname]) - flopy.mf6.ModflowGwtdis( - gwt, - length_units=length_units, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - botm=botm, - ) - - flopy.mf6.ModflowGwtmst( - gwt, - porosity=porosity, - sorption='linear', - bulk_density=rhob, - distcoef=K_d, - pname="MST-1", - filename="{}.mst".format(gwtname), - ) - - flopy.mf6.ModflowGwtic(gwt, strt=initial_temperature) - flopy.mf6.ModflowGwtadv(gwt, scheme="UPSTREAM") - flopy.mf6.ModflowGwtdsp(gwt, xt3d_off=True, diffc=D_m) - sourcerecarray = [ - ("GHB-1", "AUX", "TEMPERATURE"), - ("DRN-1", "AUX", "TEMPERATURE"), - ] - flopy.mf6.ModflowGwtssm(gwt, sources=sourcerecarray) - flopy.mf6.ModflowGwtoc( - gwt, - concentration_filerecord="{}.ucn".format(gwtname), - saverecord=[("CONCENTRATION", "ALL")], - printrecord=[("CONCENTRATION", "LAST"), ("BUDGET", "LAST")], - ) - flopy.mf6.ModflowGwfgwt( - sim, - exgtype="GWF6-GWT6", - exgmnamea=gwfname, - exgmnameb=gwtname - ) - return sim - - -# Function to write model files - - -def write_model(sim, silent=True): - if config.writeModel: - sim.write_simulation(silent=silent) - return - - -# Function to run the model -# True is returned if the model runs successfully - - -@config.timeit -def run_model(sim, silent=True): - success = True - if config.runModel: - success = False - success, buff = sim.run_simulation(silent=silent) - if not success: - print(buff) - return success - - -# Function to plot the model results - - -def plot_conc(sim, idx): - fs = USGSFigure(figure_type="map", verbose=False) - sim_name = list(parameters.keys())[idx] - sim_ws = os.path.join(ws, sim_name) - gwf = sim.get_model("flow") - gwt = sim.get_model("trans") - - fig = plt.figure(figsize=figure_size) - fig.tight_layout() - - # get MODFLOW 6 temperature - conc = gwt.output.temperature().get_data() - - ax = fig.add_subplot(1, 1, 1, aspect="equal") - pxs = flopy.plot.PlotCrossSection(model=gwf, ax=ax, line={"row": 0}) - pxs.plot_array(conc, cmap="jet") - levels = [35 * f for f in [0.01, 0.1, 0.5, 0.9, 0.99]] - cs = pxs.contour_array( - conc, levels=levels, colors="w", linewidths=1.0, linestyles="-" - ) - ax.set_xlabel("x position (m)") - ax.set_ylabel("z position (m)") - plt.clabel(cs, fmt="%4.2f", fontsize=5) - - # save figure - if config.plotSave: - fpth = os.path.join( - "..", "figures", "{}-conc{}".format(sim_name, config.figure_ext) - ) - fig.savefig(fpth) - return - - - -# Function that wraps all of the steps for each scenario -# -# 1. build_model, -# 2. write_model, -# 3. run_model, and -# 4. plot_results. -# - - -def scenario(idx, silent=True): - # Three model runs that are all part of the same scenario - - # Model Run 1 (Do not account for the effects of viscosity) - # --------------------------------------------------------- - key = list(parameters.keys())[idx] - parameter_dict = parameters[key] - sim = build_model(idx + 1, key, **parameter_dict) - write_model(sim, silent=silent) - #success = run_model(sim, silent=silent) - #if success: - # plot_results(sim, idx) - - # Model Run 2 (Activate viscosity package) - # ---------------------------------------- - idx += 1 - key = list(parameters.keys())[idx] - parameter_dict = parameters[key] - sim = build_model(idx + 1, key, **parameter_dict) - write_model(sim, silent=silent) - #success = run_model(sim, silent=silent) - #if success: - # plot_results(sim, idx) - - # Model Run 3 (No VSC package; use same K as when VSC package active; - # should get a different solution) - # ------------------------------------------------------------------ - idx += 1 - key = list(parameters.keys())[idx] - parameter_dict = parameters[key] - sim = build_model(idx + 1, key, **parameter_dict) - write_model(sim, silent=silent) - - -# nosetest - exclude block from this nosetest to the next nosetest -def test_01(): - scenario(0, silent=False) - - - -# nosetest end - -if __name__ == "__main__": - # ### Henry Problem - - # Scenario 1 - Compare model runs with and without viscosity package active - - scenario(0) - From 557adad4ada40b45623a40dd8c964e4e0847ce7b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Dec 2022 07:04:29 -0800 Subject: [PATCH 056/212] First autotest should be working better now. --- autotest/test_gwe_dsp.py | 363 ++++++++++++++++++--------------------- 1 file changed, 165 insertions(+), 198 deletions(-) diff --git a/autotest/test_gwe_dsp.py b/autotest/test_gwe_dsp.py index dd999f4b0cc..b3281f37ca9 100644 --- a/autotest/test_gwe_dsp.py +++ b/autotest/test_gwe_dsp.py @@ -3,11 +3,11 @@ # One-Dimensional Transport in a Uniform Flow Field. # The purpose of this script is to test the new heat transport model developed # for MODFLOW 6. To that end, this problem uses the setup of the first MT3DMS -# test problem but adapts it for heat. MODFLOW 6 is setup using the new GWE +# test problem but adapts it for heat. MODFLOW 6 is setup using the new GWE # model with input parameters entered in their native units. The equivalent -# values are calculated for "tricking" MT3DMS into heat transport. +# values are calculated for "tricking" MT3DMS into heat transport. # -# It may be possible to find a 1D heat transport analytical solution in the +# It may be possible to find a 1D heat transport analytical solution in the # future. # Imports @@ -18,6 +18,14 @@ import numpy as np import pytest +try: + import pymake +except: + msg = "Error. Pymake package is not available.\n" + msg += "Try installing using the following command:\n" + msg += " pip install https://github.com/modflowpy/pymake/zipball/master" + raise Exception(msg) + try: import flopy except: @@ -28,9 +36,8 @@ import targets -exe_name_mf = targets.target_dict["mf2005s"] -exe_name_mt = targets.target_dict["mt3dms"] -exe_name_mf6 = targets.target_dict["mf6"] +from framework import testing_framework +from simulation import Simulation # Base simulation and model name and workspace @@ -82,10 +89,10 @@ mixelm = 0 # FD rhob = 1110.0 sp2 = 0.0 # read, but not used in this problem -kd = 1.8168E-4 +kd = 1.8168e-4 strt_temp = np.zeros((nlay, nrow, ncol), dtype=float) dispersivity = 1.0 -dmcoef = 3.2519E-7 # Molecular diffusion coefficient +dmcoef = 3.2519e-7 # Molecular diffusion coefficient # Set solver parameter values (and related) nouter, ninner = 100, 300 @@ -114,128 +121,7 @@ ctpspd = [[(0, 0, 0), c0]] -# -# MF2K5/MT3DMS and MODFLOW 6 (sim) flopy objects returned if building the model -# - -def build_mfmt_models(idx, dir): - # Base MF2K5/MT3DMS runs - ws = dir - name = ex[idx] - - mt3d_ws = os.path.join(ws, name, "mt3d") - modelname_mf = "p01-mf" - - # Instantiate the MODFLOW model - mf = flopy.modflow.Modflow( - modelname=modelname_mf, model_ws=mt3d_ws, exe_name=exe_name_mf - ) - - # Instantiate discretization package - # units: itmuni=4 (days), lenuni=2 (m) - flopy.modflow.ModflowDis( - mf, - nlay=nlay, - nrow=nrow, - ncol=ncol, - delr=delr, - delc=delc, - top=top, - nstp=nstp, - botm=botm, - perlen=perlen, - itmuni=4, - lenuni=2, - ) - - # Instantiate basic package - flopy.modflow.ModflowBas(mf, ibound=ibound, strt=strt) - - # Instantiate layer property flow package - flopy.modflow.ModflowLpf(mf, hk=k11, laytyp=laytyp) - - # Instantiate solver package - flopy.modflow.ModflowPcg(mf) - - # Instantiate link mass transport package (for writing linker file) - flopy.modflow.ModflowLmt(mf) - - # Write and run the simulation to create the linker file - mf.write_input() - mf.run_model(silent=False) - - # Transport - modelname_mt = "p01-mt" - mt = flopy.mt3d.Mt3dms( - modelname=modelname_mt, - model_ws=mt3d_ws, - exe_name=exe_name_mt, - modflowmodel=mf, - ) - - icbund = np.ones((nlay, nrow, ncol), dtype=int) - icbund[0, 0, 0] = -1 - strt_temp = np.zeros((nlay, nrow, ncol), dtype=float) - strt_temp[0, 0, 0] = c0 - flopy.mt3d.Mt3dBtn( - mt, - laycon=laytyp, - icbund=icbund, - prsity=prsity, - sconc=strt_temp, - dt0=dt0, - ifmtcn=1, - ) - - # Instatiate the advection package - flopy.mt3d.Mt3dAdv( - mt, - mixelm=mixelm, - dceps=dceps, - nplane=nplane, - npl=npl, - nph=nph, - npmin=npmin, - npmax=npmax, - nlsink=nlsink, - npsink=npsink, - percel=0.5, - ) - - # Instantiate the dispersion package - flopy.mt3d.Mt3dDsp(mt, al=dispersivity, dmcoef=dmcoef) - - # Set reactive variables and instantiate chemical reaction package - isothm = 1 - flopy.mt3d.Mt3dRct( - mt, - isothm=isothm, - ireact=0, - igetsc=0, - rhob=rhob, - sp1=kd - ) - - # Instantiate the source/sink mixing package - flopy.mt3d.Mt3dSsm(mt) - - # Instantiate the GCG solver in MT3DMS - flopy.mt3d.Mt3dGcg(mt, mxiter=10) - - mt.write_input() - fname = os.path.join(mt3d_ws, "MT3D001.UCN") - if os.path.isfile(fname): - os.remove(fname) - mt.run_model(silent=False) - - ucnobj = flopy.utils.UcnFile(fname) - times = ucnobj.get_times() - conc = ucnobj.get_alldata() - - return conc, times - - -def build_mf6_models(idx, dir): +def build_model(idx, dir): # Base MF6 GWE model type ws = dir name = ex[idx] @@ -248,7 +134,7 @@ def build_mf6_models(idx, dir): sim_ws = os.path.join(ws, name) sim = flopy.mf6.MFSimulation( - sim_name=name, sim_ws=ws, exe_name=exe_name_mf6, version="mf6" + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" ) # Instantiating MODFLOW 6 time discretization @@ -309,9 +195,7 @@ def build_mf6_models(idx, dir): ) # Instantiating MODFLOW 6 initial conditions package for flow model - flopy.mf6.ModflowGwfic( - gwf, strt=strt, filename="{}.ic".format(gwfname) - ) + flopy.mf6.ModflowGwfic(gwf, strt=strt, filename="{}.ic".format(gwfname)) # Instantiating VSC if viscosity_on[idx]: @@ -347,9 +231,7 @@ def build_mf6_models(idx, dir): gwf, head_filerecord="{}.hds".format(gwfname), budget_filerecord="{}.cbc".format(gwfname), - headprintrecord=[ - ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") - ], + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], saverecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], printrecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], ) @@ -424,6 +306,7 @@ def build_mf6_models(idx, dir): # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) flopy.mf6.ModflowGwemst( gwe, + save_flows=True, porosity=prsity, cpw=4183.0, cps=760.0, @@ -468,83 +351,167 @@ def build_mf6_models(idx, dir): filename="{}.gwfgwe".format(name), ) - # Grab output - sim.write_simulation() - fname = os.path.join(ws, gwename + ".ucn") - if os.path.isfile(fname): - os.remove(fname) - success, buff = sim.run_simulation(silent=False, report=True) - if not success: - print(buff) - - # load temperatures - ucnobj = flopy.utils.HeadFile(fname, precision="double", text="TEMPERATURE") - times = ucnobj.get_times() - conc = ucnobj.get_alldata() + return sim, None - return conc, times - -# Function to write model files -def write_model(mf2k5, mt3d, sim, silent=True): - if config.writeModel: - mf2k5.write_input() - mt3d.write_input() - sim.write_simulation(silent=silent) - - -# Function to ensure GWE model is working properly -def eval_results(mt3d, mf6): - print("evaluating results...") - - # read transport results from model - mt3d_out_path = mt3d.model_ws - mf6_out_path = mf6.simulation_data.mfpath.get_sim_path() - mf6.simulation_data.mfpath.get_sim_path() - - # Get the MT3DMS concentration output - fname_mt3d = os.path.join(mt3d_out_path, "MT3D001.UCN") - ucnobj_mt3d = flopy.utils.UcnFile(fname_mt3d) - conc_mt3d = ucnobj_mt3d.get_alldata() - - # Get the MF6 concentration output - gwt = mf6.get_model(list(mf6.model_names)[1]) - #ucnobj_mf6 = gwt.output.temperature() - ucnobj_mf6 = gwt.output.concentration() - conc_mf6 = ucnobj_mf6.get_alldata() - - -def eval_results(sim): +def eval_model(sim): print("evaluating results...") # read transport results from GWE model name = ex[sim.idxsim] - gwfname = "gwf-" + name + gwename = "gwe-" + name - fname = gwfname + ".bud" - fname = os.path.join(sim.simpath, fname) - assert os.path.isfile(fname) - budobj = flopy.utils.CellBudgetFile(fname, precision="double") - outbud = budobj.get_data(text=" GHB") + fpth = os.path.join(sim.simpath, f"{gwename}.ucn") + try: + # load temperatures + cobj = flopy.utils.HeadFile( + fpth, precision="double", text="TEMPERATURE" + ) + conc1 = cobj.get_alldata() + except: + assert False, f'could not load concentration data from "{fpth}"' + + # This is the answer + c_ans = [ + 4.00000000e01, + 3.99999983e01, + 3.99999898e01, + 3.99999566e01, + 3.99998462e01, + 3.99995197e01, + 3.99986427e01, + 3.99964775e01, + 3.99915230e01, + 3.99809477e01, + 3.99597839e01, + 3.99198995e01, + 3.98488519e01, + 3.97288247e01, + 3.95359427e01, + 3.92403042e01, + 3.88070317e01, + 3.81985089e01, + 3.73777505e01, + 3.63125911e01, + 3.49801399e01, + 3.33708033e01, + 3.14911723e01, + 2.93652158e01, + 2.70334931e01, + 2.45504338e01, + 2.19800532e01, + 1.93907148e01, + 1.68496655e01, + 1.44180473e01, + 1.21469471e01, + 1.00748333e01, + 8.22648357e00, + 6.61329449e00, + 5.23470060e00, + 4.08034410e00, + 3.13261741e00, + 2.36924164e00, + 1.76562010e00, + 1.29679741e00, + 9.38944408e-01, + 6.70362685e-01, + 4.72056032e-01, + 3.27947150e-01, + 2.24829892e-01, + 1.52144844e-01, + 1.01654320e-01, + 6.70766201e-02, + 4.37223104e-02, + 2.81598160e-02, + 1.79249349e-02, + 1.12795213e-02, + 7.01828727e-03, + 4.31895689e-03, + 2.62924728e-03, + 1.58374083e-03, + 9.44125798e-04, + 5.57133590e-04, + 3.25507431e-04, + 1.88330495e-04, + 1.07925092e-04, + 6.12700035e-05, + 3.44648666e-05, + 1.92125906e-05, + 1.06157638e-05, + 5.81494908e-06, + 3.15821246e-06, + 1.70101068e-06, + 9.08679391e-07, + 4.81524218e-07, + 2.53159103e-07, + 1.32068539e-07, + 6.83748562e-08, + 3.51353218e-08, + 1.79225415e-08, + 9.07652498e-09, + 4.56413759e-09, + 2.27913640e-09, + 1.13033292e-09, + 5.56823550e-10, + 2.72491770e-10, + 1.32483548e-10, + 6.40015158e-11, + 3.07244529e-11, + 1.46584603e-11, + 6.95098705e-12, + 3.27643160e-12, + 1.53530190e-12, + 7.15261898e-13, + 3.31325318e-13, + 1.52616350e-13, + 6.99104644e-14, + 3.18504005e-14, + 1.44329547e-14, + 6.50576657e-15, + 2.91728603e-15, + 1.30145909e-15, + 5.77678170e-16, + 2.55141072e-16, + 1.12178999e-16, + 5.01900830e-17, + ] + + msg = f"gwe temperatures do not match stored concentrations" + assert np.allclose(conc1[0, 0, 0, :], c_ans, atol=1e-5), msg + + +# - No need to change any code below +@pytest.mark.parametrize( + "idx, dir", + list(enumerate(exdirs)), +) +def test_mf6model(idx, dir): + # initialize testing framework + test = testing_framework() + + # build the model + test.build_mf6_models(build_model, idx, dir) + # run the test model + test.run_mf6(Simulation(dir, exfunc=eval_model, idxsim=idx)) -def test_gwe_dsp01(): - # run the test model - idx = 0 - dir = exdirs[idx] +def main(): + # initialize testing framework + test = testing_framework() - mt3d_conc, mt3d_times = build_mfmt_models(idx, dir) - gwe_temp, gwe_times = build_mf6_models(idx, dir) + # run the test model + for idx, dir in enumerate(exdirs): - msg = f"gwe temperatures do not equal mt3dms concentrations" - assert np.allclose(gwe_temp, mt3d_conc, atol=0.41159), msg + test.build_mf6_models(build_model, idx, dir) + sim = Simulation(dir, exfunc=eval_model, idxsim=idx) + test.run_mf6(sim) if __name__ == "__main__": - # ### Heat Transport in 1-dimension + # Heat Transport in 1-dimension # print message print(f"standalone run of {os.path.basename(__file__)}") # run main routine - test_gwe_dsp01() + main() From 485a65fde33eaf32862982df5e0c2bf5876d5238 Mon Sep 17 00:00:00 2001 From: Chieh Ying Chen Date: Tue, 6 Dec 2022 14:39:53 -0600 Subject: [PATCH 057/212] Add stallman analysis --- autotest/test_gwe_stallman.py | 436 ++++++++++++++++++++++++++++++++++ 1 file changed, 436 insertions(+) create mode 100644 autotest/test_gwe_stallman.py diff --git a/autotest/test_gwe_stallman.py b/autotest/test_gwe_stallman.py new file mode 100644 index 00000000000..eb8b02cdd69 --- /dev/null +++ b/autotest/test_gwe_stallman.py @@ -0,0 +1,436 @@ +# ## Test problem for GWE +# +# One-Dimensional Stallman Problem +# Compare MF6-GWE simulation results with analytical solution + + +# Imports +import os +import sys + +import numpy as np +import pytest +import matplotlib.pyplot as plt + +try: + import pymake +except: + msg = "Error. Pymake package is not available.\n" + msg += "Try installing using the following command:\n" + msg += " pip install https://github.com/modflowpy/pymake/zipball/master" + raise Exception(msg) + +try: + import flopy +except: + msg = "Error. FloPy package is not available.\n" + msg += "Try installing using the following command:\n" + msg += " pip install flopy" + raise Exception(msg) + +import targets + +from framework import testing_framework +from simulation import Simulation + + +# Base simulation and model name and workspace + +viscosity_on = [False] +ex = ["stallman"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", s)) + +# Model units + +length_units = "meters" +time_units = "seconds" + +# Table MODFLOW 6 GWE parameters + +nper = 600 # Number of periods +nstp = 6 # Number of time steps +perlen = 525600 # Simulation time length ($s$) +nlay = 120 # Number of layers +nrow = 1 # Number of rows +ncol = 1 # Number of columns +system_length = 60.0 # Length of system ($m$) +delr = 1.0 # Column width ($m$) +delc = 1.0 # Row width ($m$) +delv_str = "ranges from 0.1 to 1" # Layer thickness +top = 60.0 # Top of the model ($m$) +hydraulic_conductivity = 1.0e-4 # Hydraulic conductivity ($m s^{-1}$) +porosity = 0.35 # Porosity (unitless) +alphal = 0.0 # Longitudinal dispersivity ($m$) +alphat = 0.0 # Transverse dispersivity ($m$) +diffc = 1.02882E-06 # Diffusion coefficient ($m s^{-1}$) +T_az = 10 # Ambient temperature ($^o C$) +dT = 5 # Temperature variation ($^o C$) +bulk_dens = 2630 # Bulk density ($kg/m^3$) +kd = 0.000191663 # Distribution coefficient (unitless) +ktw=0.58 +kts=2 +cpw=4174.0 +cps=800.0 +rhow=1000.0 +rhos = bulk_dens + +# Stress period input +per_data = [] +for k in range(nper): + per_data.append((perlen, nstp, 1.0)) +per_mf6 = per_data + +# Geometry input +tp = top +botm = [] +for i in range(nlay): + if i==0:botm.append(59.9) + elif i==119:botm.append(0.0) + else: botm.append(60-i*0.5) + +# Head input +chd_data = {} +for k in range(nper): + chd_data[k] = [[(0, 0, 0), 60.000000],[(119, 0, 0), 59.701801]] +chd_mf6 = chd_data + +# Initial temperature input +strt_conc = T_az* np.ones((nlay, 1, 1), dtype=np.float32) + +# Boundary temperature input +cnc_data = {} +for k in range(nper): + cnc_temp = T_az+dT*np.sin(2*np.pi*k*perlen/365/86400) + cnc_data[k] = [[(0, 0, 0), cnc_temp]] +cnc_mf6 = cnc_data + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-8, 1e-8, 0.97 + + + +# Analytical solution for Stallman analysis (Stallman 1965, JGR) +# Analytical solution for Stallman analysis (Stallman 1965, JGR) +def Stallman(T_az,dT,tau,t,c_rho,darcy_flux,ko,c_w,rho_w,zbotm,nlay): + zstallman = np.zeros((nlay, 2)) + K = np.pi*c_rho/ko/tau + V = darcy_flux*c_w*rho_w/2/ko + a = ((K**2+V**4/4)**0.5+V**2/2)**0.5-V + b = ((K**2+V**4/4)**0.5-V**2/2)**0.5 + for i in range(len(zstallman)): + zstallman[i,0] = zbotm[i] + zstallman[i,1] = dT*np.exp(-a*(-zstallman[i,0]))*np.sin(2*np.pi*t/tau-b*(-zstallman[i,0])) + T_az + return zstallman + +# +# MODFLOW 6 (sim) flopy objects returned if building the model +# + + +def build_model(idx, dir): + # Base MF6 GWE model type + ws = dir + name = ex[idx] + + print("Building MF6 model...()".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwename = "gwe-" + name + + #sim_ws = os.path.join(ws, name) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" + ) + + # Instantiating MODFLOW 6 time discretization + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=per_mf6, time_units=time_units + ) + + # Instantiating MODFLOW 6 groundwater flow model + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + model_nam_file="{}.nam".format(gwfname), + ) + + # Instantiating MODFLOW 6 solver for flow model + imsgwf = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="CG", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(imsgwf, [gwfname]) + + # Instantiating MODFLOW 6 discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + filename="{}.dis".format(gwfname), + ) + + # Instantiating MODFLOW 6 node-property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=0, + k=hydraulic_conductivity, + filename="{}.npf".format(gwfname), + ) + + # Instantiating MODFLOW 6 initial conditions package for flow model + flopy.mf6.ModflowGwfic( + gwf, strt=top, filename="{}.ic".format(gwfname) + ) + + # Instantiating VSC + if viscosity_on[idx]: + # Instantiate viscosity (VSC) package + vsc_filerecord = "{}.vsc.bin".format(gwfname) + vsc_pd = [(0, 0.0, 20.0, gwename, "temperature")] + flopy.mf6.ModflowGwfvsc( + gwf, + viscref=8.904e-4, + viscosity_filerecord=vsc_filerecord, + thermal_formulation="nonlinear", + thermal_a2=10.0, + thermal_a3=248.37, + thermal_a4=133.16, + nviscspecies=len(vsc_pd), + packagedata=vsc_pd, + pname="vsc", + filename="{}.vsc".format(gwfname), + ) + + # Instantiating MODFLOW 6 constant head package + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chd_mf6, + filename="{}.chd".format(gwfname), + ) + + # Instantiating MODFLOW 6 output control package for flow model + flopy.mf6.ModflowGwfoc( + gwf, + head_filerecord="{}.hds".format(gwfname), + budget_filerecord="{}.cbc".format(gwfname), + headprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], + printrecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], + ) + + # Instantiating MODFLOW 6 groundwater transport package + gwe = flopy.mf6.MFModel( + sim, + model_type="gwe6", + modelname=gwename, + model_nam_file="{}.nam".format(gwename), + ) + gwe.name_file.save_flows = True + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename), + ) + sim.register_ims_package(imsgwe, [gwe.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + filename="{}.dis".format(gwename), + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe, strt=strt_conc, filename="{}.ic".format(gwename) + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGweadv( + gwe, scheme="TVD", filename="{}.adv".format(gwename) + ) + + # Instantiating MODFLOW 6 transport dispersion package + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=True, + alh=alphal, + ath1=alphat, + ktw=ktw, + kts=kts, + filename="{}.dsp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) + flopy.mf6.ModflowGwemst( + gwe, + porosity=porosity, + cpw=cpw, + cps=cps, + rhow=rhow, + rhos=rhos, + filename="{}.mst".format(gwename), + ) + + # Instantiating MODFLOW 6 transport constant concentration package + flopy.mf6.ModflowGwetmp( + gwe, + stress_period_data=cnc_mf6, + filename="{}.tmp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + flopy.mf6.ModflowGwessm( + gwe, sources=[[]], filename="{}.ssm".format(gwename) + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe, + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "LAST"), ("BUDGET", "LAST")], + printrecord=[("TEMPERATURE", "LAST"), ("BUDGET", "LAST")], + ) + + # Instantiating MODFLOW 6 flow-transport exchange mechanism + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename="{}.gwfgwe".format(name), + ) + return sim, None + + +def eval_model(sim): + print("evaluating results...") + + # read transport results from GWE model + name = ex[sim.idxsim] + gwename = "gwe-" + name + + fpth = os.path.join(sim.simpath, f"{gwename}.ucn") + try: + # load temperatures + cobj = flopy.utils.HeadFile( + fpth, precision="double", text="TEMPERATURE" + ) + times = cobj.get_times() + conc1 = cobj.get_data(totim=times[540]) + except: + assert False, f'could not load concentration data from "{fpth}"' + + # Prepare to compare the results of MF6-GWE with analytical solution + zconc = np.zeros((nlay, 2)) + for i in range(nlay): + if i != (nlay-1): zconc[i+1,0] = -(60-botm[i]) + zconc[i,1] = conc1[i][0][0] + + # Analytical solution - Stallman analysis + tau = 365*86400 + t = 283824000.0 + c_w = 4174 + rho_w = 1000 + c_r = 800 + rho_r = 2630 + c_rho = c_r*rho_r*(1-porosity) + c_w*rho_w*porosity + darcy_flux = 5.00E-07 + ko = 1.503 + zanal = Stallman(T_az,dT,tau,t,c_rho,darcy_flux,ko,c_w,rho_w,zconc[:,0],nlay) + + plt.plot(zconc[:,1], zconc[:,0], "k--", linewidth=0.5, label='MF6-GWE') + plt.plot(zanal[:,1], zanal[:,0], "bo", mfc="none", label='Analytical') + plt.xlim(T_az-dT, T_az+dT) + plt.ylim(-top, 0) + plt.ylabel("Depth (m)") + plt.xlabel("Temperature (deg C)") + plt.legend() + plt.savefig('stallman.png') + + msg = f"gwe temperatures do not match stored concentrations" + assert np.allclose(zconc[:,1], zanal[:,1], atol=1e-1), msg + + return + + +# - No need to change any code below +@pytest.mark.parametrize( + "idx, dir", + list(enumerate(exdirs)), +) +def test_mf6model(idx, dir): + # initialize testing framework + test = testing_framework() + + # build the model + test.build_mf6_models(build_model, idx, dir) + + # run the test model + test.run_mf6(Simulation(dir, exfunc=eval_model, idxsim=idx)) + + +def main(): + # initialize testing framework + test = testing_framework() + + # run the test model + for idx, dir in enumerate(exdirs): + + test.build_mf6_models(build_model, idx, dir) + sim = Simulation(dir, exfunc=eval_model, idxsim=idx) + test.run_mf6(sim) + + +if __name__ == "__main__": + # Heat Transport in 1-dimension + # print message + print(f"standalone run of {os.path.basename(__file__)}") + + # run main routine + main() \ No newline at end of file From fb3e67d6c5160899d86caac1e957ea497a71ba4c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Dec 2022 14:17:39 -0800 Subject: [PATCH 058/212] Generalizing advanced package transport for extending its use in GWE --- msvs/mf6core.vfproj | 2 +- src/Model/GroundWaterTransport/gwt1lkt1.f90 | 18 +-- src/Model/GroundWaterTransport/gwt1mwt1.f90 | 18 +-- src/Model/GroundWaterTransport/gwt1sft1.f90 | 18 +-- src/Model/GroundWaterTransport/gwt1uzt1.f90 | 18 +-- .../{gwt1apt1.f90 => tsp1apt1.f90} | 120 +++++++++--------- 6 files changed, 97 insertions(+), 97 deletions(-) rename src/Model/GroundWaterTransport/{gwt1apt1.f90 => tsp1apt1.f90} (98%) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 7412a15898b..4b406e0fb0d 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -118,7 +118,6 @@ - @@ -129,6 +128,7 @@ + diff --git a/src/Model/GroundWaterTransport/gwt1lkt1.f90 b/src/Model/GroundWaterTransport/gwt1lkt1.f90 index 2c447db443d..58103bbb260 100644 --- a/src/Model/GroundWaterTransport/gwt1lkt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1lkt1.f90 @@ -40,7 +40,7 @@ module GwtLktModule use TspFmiModule, only: TspFmiType use LakModule, only: LakType use ObserveModule, only: ObserveType - use GwtAptModule, only: GwtAptType, apt_process_obsID, & + use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 implicit none @@ -51,7 +51,7 @@ module GwtLktModule character(len=*), parameter :: flowtype = 'LAK' character(len=16) :: text = ' LKT' - type, extends(GwtAptType) :: GwtLktType + type, extends(TspAptType) :: GwtLktType integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr @@ -271,7 +271,7 @@ end subroutine find_lkt_package subroutine lkt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** -! lkt_fc_expanded -- this will be called from GwtAptType%apt_fc_expanded() +! lkt_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() ! in order to add matrix terms specifically for LKT ! **************************************************************************** ! @@ -652,8 +652,8 @@ subroutine allocate_scalars(this) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- allocate scalars in GwtAptType - call this%GwtAptType%allocate_scalars() + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() ! ! -- Allocate call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%memoryPath) @@ -696,8 +696,8 @@ subroutine lkt_allocate_arrays(this) call mem_allocate(this%concroff, this%ncv, 'CONCROFF', this%memoryPath) call mem_allocate(this%conciflw, this%ncv, 'CONCIFLW', this%memoryPath) ! - ! -- call standard GwtApttype allocate arrays - call this%GwtAptType%apt_allocate_arrays() + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() ! ! -- Initialize do n = 1, this%ncv @@ -740,8 +740,8 @@ subroutine lkt_da(this) call mem_deallocate(this%concroff) call mem_deallocate(this%conciflw) ! - ! -- deallocate scalars in GwtAptType - call this%GwtAptType%bnd_da() + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() ! ! -- Return return diff --git a/src/Model/GroundWaterTransport/gwt1mwt1.f90 b/src/Model/GroundWaterTransport/gwt1mwt1.f90 index 013f2fb4463..a3101e4b766 100644 --- a/src/Model/GroundWaterTransport/gwt1mwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mwt1.f90 @@ -41,7 +41,7 @@ module GwtMwtModule use TspFmiModule, only: TspFmiType use MawModule, only: MawType use ObserveModule, only: ObserveType - use GwtAptModule, only: GwtAptType, apt_process_obsID, & + use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 implicit none @@ -52,7 +52,7 @@ module GwtMwtModule character(len=*), parameter :: flowtype = 'MAW' character(len=16) :: text = ' MWT' - type, extends(GwtAptType) :: GwtMwtType + type, extends(TspAptType) :: GwtMwtType integer(I4B), pointer :: idxbudrate => null() ! index of well rate terms in flowbudptr integer(I4B), pointer :: idxbudfwrt => null() ! index of flowing well rate terms in flowbudptr @@ -258,7 +258,7 @@ end subroutine find_mwt_package subroutine mwt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** -! mwt_fc_expanded -- this will be called from GwtAptType%apt_fc_expanded() +! mwt_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() ! in order to add matrix terms specifically for this package ! **************************************************************************** ! @@ -576,8 +576,8 @@ subroutine allocate_scalars(this) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- allocate scalars in GwtAptType - call this%GwtAptType%allocate_scalars() + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() ! ! -- Allocate call mem_allocate(this%idxbudrate, 'IDXBUDRATE', this%memoryPath) @@ -613,8 +613,8 @@ subroutine mwt_allocate_arrays(this) ! -- time series call mem_allocate(this%concrate, this%ncv, 'CONCRATE', this%memoryPath) ! - ! -- call standard GwtApttype allocate arrays - call this%GwtAptType%apt_allocate_arrays() + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() ! ! -- Initialize do n = 1, this%ncv @@ -649,8 +649,8 @@ subroutine mwt_da(this) ! -- deallocate time series call mem_deallocate(this%concrate) ! - ! -- deallocate scalars in GwtAptType - call this%GwtAptType%bnd_da() + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() ! ! -- Return return diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 73a67cb4378..380a60dd03e 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -39,7 +39,7 @@ module GwtSftModule use TspFmiModule, only: TspFmiType use SfrModule, only: SfrType use ObserveModule, only: ObserveType - use GwtAptModule, only: GwtAptType, apt_process_obsID, & + use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 implicit none @@ -50,7 +50,7 @@ module GwtSftModule character(len=*), parameter :: flowtype = 'SFR' character(len=16) :: text = ' SFT' - type, extends(GwtAptType) :: GwtSftType + type, extends(TspAptType) :: GwtSftType integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr @@ -265,7 +265,7 @@ end subroutine find_sft_package subroutine sft_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** -! sft_fc_expanded -- this will be called from GwtAptType%apt_fc_expanded() +! sft_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() ! in order to add matrix terms specifically for LKT ! **************************************************************************** ! @@ -604,8 +604,8 @@ subroutine allocate_scalars(this) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- allocate scalars in GwtAptType - call this%GwtAptType%allocate_scalars() + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() ! ! -- Allocate call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%memoryPath) @@ -646,8 +646,8 @@ subroutine sft_allocate_arrays(this) call mem_allocate(this%concroff, this%ncv, 'CONCROFF', this%memoryPath) call mem_allocate(this%conciflw, this%ncv, 'CONCIFLW', this%memoryPath) ! - ! -- call standard GwtApttype allocate arrays - call this%GwtAptType%apt_allocate_arrays() + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() ! ! -- Initialize do n = 1, this%ncv @@ -689,8 +689,8 @@ subroutine sft_da(this) call mem_deallocate(this%concroff) call mem_deallocate(this%conciflw) ! - ! -- deallocate scalars in GwtAptType - call this%GwtAptType%bnd_da() + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() ! ! -- Return return diff --git a/src/Model/GroundWaterTransport/gwt1uzt1.f90 b/src/Model/GroundWaterTransport/gwt1uzt1.f90 index d807f6d36bb..49387dfbf67 100644 --- a/src/Model/GroundWaterTransport/gwt1uzt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1uzt1.f90 @@ -33,7 +33,7 @@ module GwtUztModule use TspFmiModule, only: TspFmiType use UzfModule, only: UzfType use ObserveModule, only: ObserveType - use GwtAptModule, only: GwtAptType, apt_process_obsID, & + use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 implicit none @@ -44,7 +44,7 @@ module GwtUztModule character(len=*), parameter :: flowtype = 'UZF' character(len=16) :: text = ' UZT' - type, extends(GwtAptType) :: GwtUztType + type, extends(TspAptType) :: GwtUztType integer(I4B), pointer :: idxbudinfl => null() ! index of uzf infiltration terms in flowbudptr integer(I4B), pointer :: idxbudrinf => null() ! index of rejected infiltration terms in flowbudptr @@ -251,7 +251,7 @@ end subroutine find_uzt_package subroutine uzt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** -! uzt_fc_expanded -- this will be called from GwtAptType%apt_fc_expanded() +! uzt_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() ! in order to add matrix terms specifically for this package ! **************************************************************************** ! @@ -570,8 +570,8 @@ subroutine allocate_scalars(this) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- allocate scalars in GwtAptType - call this%GwtAptType%allocate_scalars() + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() ! ! -- Allocate call mem_allocate(this%idxbudinfl, 'IDXBUDINFL', this%memoryPath) @@ -608,8 +608,8 @@ subroutine uzt_allocate_arrays(this) call mem_allocate(this%concinfl, this%ncv, 'CONCINFL', this%memoryPath) call mem_allocate(this%concuzet, this%ncv, 'CONCUZET', this%memoryPath) ! - ! -- call standard GwtApttype allocate arrays - call this%GwtAptType%apt_allocate_arrays() + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() ! ! -- Initialize do n = 1, this%ncv @@ -646,8 +646,8 @@ subroutine uzt_da(this) call mem_deallocate(this%concinfl) call mem_deallocate(this%concuzet) ! - ! -- deallocate scalars in GwtAptType - call this%GwtAptType%bnd_da() + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() ! ! -- Return return diff --git a/src/Model/GroundWaterTransport/gwt1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 similarity index 98% rename from src/Model/GroundWaterTransport/gwt1apt1.f90 rename to src/Model/GroundWaterTransport/tsp1apt1.f90 index aecb934686a..2b0346b2824 100644 --- a/src/Model/GroundWaterTransport/gwt1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -33,7 +33,7 @@ ! none none CONSTANT accumulate ! ! -module GwtAptModule +module TspAptModule use KindModule, only: DP, I4B, LGP use ConstantsModule, only: DZERO, DONE, DEP20, LENFTYPE, LINELENGTH, & @@ -54,14 +54,14 @@ module GwtAptModule implicit none - public :: GwtAptType + public :: TspAptType public :: apt_process_obsID public :: apt_process_obsID12 character(len=LENFTYPE) :: ftype = 'APT' character(len=16) :: text = ' APT' - type, extends(BndType) :: GwtAptType + type, extends(BndType) :: TspAptType character(len=LENPACKAGENAME) :: flowpackagename = '' !< name of corresponding flow package character(len=8), & @@ -173,7 +173,7 @@ module GwtAptModule procedure, private :: apt_copy2flowp procedure, private :: apt_setup_tableobj - end type GwtAptType + end type TspAptType contains @@ -187,7 +187,7 @@ subroutine apt_ac(this, moffset, sparse) use MemoryManagerModule, only: mem_setptr use SparseModule, only: sparsematrix ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: moffset type(sparsematrix), intent(inout) :: sparse ! -- local @@ -241,7 +241,7 @@ subroutine apt_mc(this, moffset, iasln, jasln) ! ------------------------------------------------------------------------------ use SparseModule, only: sparsematrix ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: moffset integer(I4B), dimension(:), intent(in) :: iasln integer(I4B), dimension(:), intent(in) :: jasln @@ -327,7 +327,7 @@ subroutine apt_ar(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: j logical :: found @@ -402,7 +402,7 @@ subroutine apt_rp(this) ! ------------------------------------------------------------------------------ use TdisModule, only: kper, nper ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: ierr integer(I4B) :: n @@ -528,7 +528,7 @@ subroutine apt_set_stressperiod(this, itemno) ! -- module use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno ! -- local character(len=LINELENGTH) :: text @@ -629,7 +629,7 @@ subroutine pak_set_stressperiod(this, itemno, keyword, found) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno character(len=*), intent(in) :: keyword logical, intent(inout) :: found @@ -655,7 +655,7 @@ function apt_check_valid(this, itemno) result(ierr) ! -- return integer(I4B) :: ierr ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno ! -- local ! -- formats @@ -679,7 +679,7 @@ subroutine apt_ad(this) ! -- modules use SimVariablesModule, only: iFailedStepRetry ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: n integer(I4B) :: j, iaux @@ -740,7 +740,7 @@ end subroutine apt_ad !< subroutine apt_cf(this, reset_mover) ! -- modules - class(GwtAptType) :: this !< GwtAptType object + class(TspAptType) :: this !< TspAptType object logical(LGP), intent(in), optional :: reset_mover !< boolean for resetting mover ! -- local integer(I4B) :: i @@ -768,7 +768,7 @@ subroutine apt_fc(this, rhs, ia, idxglo, amatsln) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo @@ -797,7 +797,7 @@ subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo @@ -832,7 +832,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo @@ -945,7 +945,7 @@ subroutine pak_fc_expanded(this, rhs, ia, idxglo, amatsln) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo @@ -970,7 +970,7 @@ subroutine apt_cfupdate(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: j, n real(DP) :: qbnd @@ -1006,7 +1006,7 @@ subroutine apt_cq(this, x, flowja, iadv) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this real(DP), dimension(:), intent(in) :: x real(DP), dimension(:), contiguous, intent(inout) :: flowja integer(I4B), optional, intent(in) :: iadv @@ -1047,7 +1047,7 @@ end subroutine apt_cq subroutine apt_ot_package_flows(this, icbcfl, ibudfl) use TdisModule, only: kstp, kper, delt, pertim, totim - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: ibudfl integer(I4B) :: ibinun @@ -1074,7 +1074,7 @@ subroutine apt_ot_dv(this, idvsave, idvprint) use TdisModule, only: kstp, kper, pertim, totim use ConstantsModule, only: DHNOFLO, DHDRY use InputOutputModule, only: ulasav - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: idvsave integer(I4B), intent(in) :: idvprint integer(I4B) :: ibinun @@ -1123,7 +1123,7 @@ subroutine apt_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- module use TdisModule, only: totim ! -- dummy - class(GwtAptType) :: this !< GwtAptType object + class(TspAptType) :: this !< TspAptType object integer(I4B), intent(in) :: kstp !< time step number integer(I4B), intent(in) :: kper !< period number integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file @@ -1144,7 +1144,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local ! ! -- allocate scalars in NumericalPackageType @@ -1201,7 +1201,7 @@ subroutine apt_allocate_index_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: n @@ -1260,7 +1260,7 @@ subroutine apt_allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: n ! @@ -1319,7 +1319,7 @@ subroutine apt_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local ! ! -- deallocate arrays @@ -1396,7 +1396,7 @@ subroutine find_apt_package(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -1410,7 +1410,7 @@ end subroutine find_apt_package subroutine apt_options(this, option, found) ! ****************************************************************************** -! apt_options -- set options specific to GwtAptType +! apt_options -- set options specific to TspAptType ! ! apt_options overrides BndType%bnd_options ! ****************************************************************************** @@ -1421,7 +1421,7 @@ subroutine apt_options(this, option, found) use OpenSpecModule, only: access, form use InputOutputModule, only: urword, getunit, openfile ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this character(len=*), intent(inout) :: option logical, intent(inout) :: found ! -- local @@ -1514,7 +1514,7 @@ subroutine apt_read_dimensions(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: ierr ! -- format @@ -1591,7 +1591,7 @@ subroutine apt_read_cvs(this) use MemoryManagerModule, only: mem_allocate use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: text character(len=LENBOUNDNAME) :: bndName, bndNameTemp @@ -1755,7 +1755,7 @@ subroutine apt_read_initial_attr(this) use ConstantsModule, only: LINELENGTH use BudgetModule, only: budget_cr ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local !character(len=LINELENGTH) :: text integer(I4B) :: j, n @@ -1847,7 +1847,7 @@ subroutine apt_solve(this) ! ------------------------------------------------------------------------------ use ConstantsModule, only: LINELENGTH ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: n, j, igwfnode integer(I4B) :: n1, n2 @@ -1939,7 +1939,7 @@ subroutine pak_solve(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -1959,7 +1959,7 @@ subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: ilak real(DP), intent(in) :: rrate real(DP), intent(inout) :: ccratin @@ -1997,7 +1997,7 @@ subroutine define_listlabel(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! ! -- create the header list label @@ -2029,7 +2029,7 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), pointer :: neq integer(I4B), dimension(:), pointer, contiguous :: ibound real(DP), dimension(:), pointer, contiguous :: xnew @@ -2064,7 +2064,7 @@ subroutine get_volumes(this, icv, vnew, vold, delt) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: icv real(DP), intent(inout) :: vnew, vold real(DP), intent(in) :: delt @@ -2095,7 +2095,7 @@ function pak_get_nbudterms(this) result(nbudterms) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- return integer(I4B) :: nbudterms ! -- local @@ -2117,7 +2117,7 @@ subroutine apt_setup_budobj(this) ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: nbudterm integer(I4B) :: nlen @@ -2301,7 +2301,7 @@ subroutine pak_setup_budobj(this, idx) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(inout) :: idx ! -- local ! ------------------------------------------------------------------------------ @@ -2324,7 +2324,7 @@ subroutine apt_fill_budobj(this, x) ! -- modules use TdisModule, only: delt ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this real(DP), dimension(:), intent(in) :: x ! -- local integer(I4B) :: naux @@ -2463,7 +2463,7 @@ subroutine pak_fill_budobj(this, idx, x, ccratin, ccratout) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x real(DP), intent(inout) :: ccratin @@ -2483,7 +2483,7 @@ end subroutine pak_fill_budobj subroutine apt_stor_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) use TdisModule, only: delt - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: ientry integer(I4B), intent(inout) :: n1 integer(I4B), intent(inout) :: n2 @@ -2507,7 +2507,7 @@ end subroutine apt_stor_term subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: ientry integer(I4B), intent(inout) :: n1 integer(I4B), intent(inout) :: n2 @@ -2530,7 +2530,7 @@ end subroutine apt_tmvr_term subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) - class(GwtAptType) :: this + class(TspAptType) :: this integer(I4B), intent(in) :: ientry integer(I4B), intent(inout) :: n1 integer(I4B), intent(inout) :: n2 @@ -2564,7 +2564,7 @@ subroutine apt_copy2flowp(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: n, j ! ------------------------------------------------------------------------------ @@ -2596,7 +2596,7 @@ logical function apt_obs_supported(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! ------------------------------------------------------------------------------ ! ! -- Set to true @@ -2617,7 +2617,7 @@ subroutine apt_df_obs(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -2638,7 +2638,7 @@ subroutine pak_df_obs(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -2656,7 +2656,7 @@ end subroutine pak_df_obs !< subroutine pak_rp_obs(this, obsrv, found) ! -- dummy - class(GwtAptType), intent(inout) :: this !< package class + class(TspAptType), intent(inout) :: this !< package class type(ObserveType), intent(inout) :: obsrv !< observation object logical, intent(inout) :: found !< indicate whether observation was found ! -- local @@ -2675,7 +2675,7 @@ end subroutine pak_rp_obs !! !< subroutine rp_obs_byfeature(this, obsrv) - class(GwtAptType), intent(inout) :: this !< object + class(TspAptType), intent(inout) :: this !< object type(ObserveType), intent(inout) :: obsrv !< observation integer(I4B) :: nn1 integer(I4B) :: j @@ -2721,7 +2721,7 @@ end subroutine rp_obs_byfeature !! !< subroutine rp_obs_budterm(this, obsrv, budterm) - class(GwtAptType), intent(inout) :: this !< object + class(TspAptType), intent(inout) :: this !< object type(ObserveType), intent(inout) :: obsrv !< observation type(BudgetTermType), intent(in) :: budterm !< budget term integer(I4B) :: nn1 @@ -2796,7 +2796,7 @@ end subroutine rp_obs_budterm !! !< subroutine rp_obs_flowjaface(this, obsrv, budterm) - class(GwtAptType), intent(inout) :: this !< object + class(TspAptType), intent(inout) :: this !< object type(ObserveType), intent(inout) :: obsrv !< observation type(BudgetTermType), intent(in) :: budterm !< budget term integer(I4B) :: nn1 @@ -2875,7 +2875,7 @@ subroutine apt_rp_obs(this) ! -- modules use TdisModule, only: kper ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: i logical :: found @@ -2948,14 +2948,14 @@ end subroutine apt_rp_obs subroutine apt_bd_obs(this) ! ****************************************************************************** ! apt_bd_obs -- Calculate observations common to SFT/LKT/MWT/UZT -! ObsType%SaveOneSimval for each GwtAptType observation. +! ObsType%SaveOneSimval for each TspAptType observation. ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: i integer(I4B) :: igwfnode @@ -3050,7 +3050,7 @@ subroutine pak_bd_obs(this, obstypeid, jj, v, found) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtAptType), intent(inout) :: this + class(TspAptType), intent(inout) :: this character(len=*), intent(in) :: obstypeid integer(I4B), intent(in) :: jj real(DP), intent(inout) :: v @@ -3177,7 +3177,7 @@ subroutine apt_setup_tableobj(this) ! -- modules use ConstantsModule, only: LINELENGTH, LENBUDTXT ! -- dummy - class(GwtAptType) :: this + class(TspAptType) :: this ! -- local integer(I4B) :: nterms character(len=LINELENGTH) :: title @@ -3220,4 +3220,4 @@ subroutine apt_setup_tableobj(this) return end subroutine apt_setup_tableobj -end module GwtAptModule +end module TspAptModule From 640f322ea3b5dc99981eb130c6d8429d2899c36a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 14 Dec 2022 12:33:59 -0800 Subject: [PATCH 059/212] Some more .dfn file stuff --- doc/mf6io/mf6ivar/dfn/common.dfn | 3 + doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn | 460 ++++++++++++++++++++++++++++ doc/mf6io/mf6ivar/md/mf6ivar.md | 207 +++++++++++++ doc/mf6io/mf6ivar/mf6ivar.py | 15 + doc/mf6io/mf6ivar/tex/appendixA.tex | 49 +++ 5 files changed, 734 insertions(+) create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn diff --git a/doc/mf6io/mf6ivar/dfn/common.dfn b/doc/mf6io/mf6ivar/dfn/common.dfn index b69ae67edf9..0fd5220c2f0 100644 --- a/doc/mf6io/mf6ivar/dfn/common.dfn +++ b/doc/mf6io/mf6ivar/dfn/common.dfn @@ -21,6 +21,9 @@ description keyword to indicate that the list of {#1} {#2} will be printed to th name print_concentration description keyword to indicate that the list of {#1} {#2} will be printed to the listing file for every stress period in which ``CONCENTRATION PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_{#3} is specified, then {#2} are printed for the last time step of each stress period. +name print_temperature +description keyword to indicate that the list of {#1} {#2} will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_{#3} is specified, then {#2} are printed for the last time step of each stress period. + name print_flows description keyword to indicate that the list of {#1} flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. diff --git a/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn b/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn new file mode 100644 index 00000000000..d960f2d07ab --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn @@ -0,0 +1,460 @@ +# --------------------- gwe sfe options --------------------- +# flopy multi-package + +block options +name flow_package_name +type string +shape +reader urword +optional true +longname keyword to specify name of corresponding flow package +description keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +block options +name auxiliary +type string +shape (naux) +reader urword +optional true +longname keyword to specify aux variables +description REPLACE auxnames {'{#1}': 'Groundwater Energy Transport'} + +block options +name flow_package_auxiliary_name +type string +shape +reader urword +optional true +longname keyword to specify name of temperature auxiliary variable in flow package +description keyword to specify the name of an auxiliary variable provided in the corresponding flow package (i.e., FLOW\_PACKAE\_NAME). If specified, then the simulated temperatures from this advanced energy transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced energy transport package are read from a file, then this option will have no effect. + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'reach'} + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'reach'} + +block options +name print_temperature +type keyword +reader urword +optional true +longname print calculated temperature to listing file +description REPLACE print_temperature {'{#1}': 'reach', '{#2}': 'temperatures', '{#3}': 'TEMPERATURE'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'reach'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save reach flows to budget file +description REPLACE save_flows {'{#1}': 'reach'} + +block options +name temperature_filerecord +type record temperature fileout tempfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name temperature +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname temperature keyword +description keyword to specify that record corresponds to temperature. + +block options +name tempfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write temperature information. + +block options +name budget_filerecord +type record budget fileout budgetfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budget +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name budgetfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write budget information. + +block options +name budgetcsv_filerecord +type record budgetcsv fileout budgetcsvfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budgetcsv +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget CSV. + +block options +name budgetcsvfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +block options +name ts_filerecord +type record ts6 filein ts6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name ts6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname head keyword +description keyword to specify that record corresponds to a time-series file. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name ts6_filename +type string +preserve_case true +in_record true +reader urword +optional false +tagged false +longname file name of time series information +description REPLACE timeseriesfile {} + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description REPLACE obs6_filename {'{#1}': 'SFT'} + + +# --------------------- gwe sfe packagedata --------------------- + +block packagedata +name packagedata +type recarray rno strt aux boundname +shape (maxbound) +reader urword +longname +description + +block packagedata +name rno +type integer +shape +tagged false +in_record true +reader urword +longname reach number for this entry +description integer value that defines the reach number associated with the specified PACKAGEDATA data on the line. RNO must be greater than zero and less than or equal to NREACHES. Reach information must be specified for every reach or the program will terminate with an error. The program will also terminate with an error if information for a reach is specified more than once. +numeric_index true + +block packagedata +name strt +type double precision +shape +tagged false +in_record true +reader urword +longname starting reach temperature +description real value that defines the starting temperature for the reach. + +block packagedata +name aux +type double precision +in_record true +tagged false +shape (naux) +reader urword +time_series true +optional true +longname auxiliary variables +description REPLACE aux {'{#1}': 'reach'} + +block packagedata +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname well name +description REPLACE boundname {'{#1}': 'reach'} + + +# --------------------- gwe sfe period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name reachperioddata +type recarray rno reachsetting +shape +reader urword +longname +description + +block period +name rno +type integer +shape +tagged false +in_record true +reader urword +longname reach number for this entry +description integer value that defines the reach number associated with the specified PERIOD data on the line. RNO must be greater than zero and less than or equal to NREACHES. +numeric_index true + +block period +name reachsetting +type keystring status temperature rainfall evaporation runoff inflow auxiliaryrecord +shape +tagged false +in_record true +reader urword +longname +description line of information that is parsed into a keyword and values. Keyword values that can be used to start the REACHSETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature of associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Streamflow Package supports a ``DIVERSION'' flow term. Diversion water will be routed using the calculated temperature of the reach. + +block period +name status +type string +shape +tagged true +in_record true +reader urword +longname reach temperature status +description keyword option to define reach status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the reach. If a reach is inactive, then there will be no energy fluxes into or out of the reach and the inactive value will be written for the reach temperature. If a reach is constant, then the temperature for the reach will be fixed at the user specified value. + +block period +name temperature +type string +shape +tagged true +in_record true +time_series true +reader urword +longname reach temperature +description real or character value that defines the temperature for the reach. The specified TEMPERATURE is only applied if the reach is a constant temperature reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name rainfall +type string +shape +tagged true +in_record true +reader urword +time_series true +longname rainfall temperature +description real or character value that defines the rainfall temperature $(^{\circ}C)$ for the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name evaporation +type string +shape +tagged true +in_record true +reader urword +time_series true +longname evaporation temperature +description real or character value that defines the temperature of evaporated water $(^{\circ}C)$ for the reach. If this temperature value is larger than the simulated temperature in the reach, then the evaporated water will be removed at the same temperature as the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name runoff +type string +shape +tagged true +in_record true +reader urword +time_series true +longname runoff temperature +description real or character value that defines the temperature of runoff $(^{\circ}C)$ for the reach. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name inflow +type string +shape +tagged true +in_record true +reader urword +time_series true +longname inflow temperature +description real or character value that defines the temperature of inflow $(^{\circ}C)$ for the reach. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name auxiliaryrecord +type record auxiliary auxname auxval +shape +tagged +in_record true +reader urword +longname +description + +block period +name auxiliary +type keyword +shape +in_record true +reader urword +longname +description keyword for specifying auxiliary variable. + +block period +name auxname +type string +shape +tagged false +in_record true +reader urword +longname +description name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +block period +name auxval +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname auxiliary variable value +description value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. diff --git a/doc/mf6io/mf6ivar/md/mf6ivar.md b/doc/mf6io/mf6ivar/md/mf6ivar.md index 4423337ddb1..6261eefa1ae 100644 --- a/doc/mf6io/mf6ivar/md/mf6ivar.md +++ b/doc/mf6io/mf6ivar/md/mf6ivar.md @@ -80,6 +80,31 @@ | EXG | GWTGWT | EXCHANGEDATA | HWVA | DOUBLE PRECISION | is the horizontal width of the flow connection between cell 1 and cell 2 if IHC $>$ 0, or it is the area perpendicular to flow of the vertical connection between cell 1 and cell 2 if IHC = 0. | | EXG | GWTGWT | EXCHANGEDATA | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each GWTGWT Exchange. The values of auxiliary variables must be present for each exchange. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. | | EXG | GWTGWT | EXCHANGEDATA | BOUNDNAME | STRING | name of the GWT Exchange cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | +| EXG | GWEGWE | OPTIONS | GWFMODELNAME1 | STRING | keyword to specify name of first corresponding GWF Model. In the simulation name file, the GWE6-GWE6 entry contains names for GWE Models (exgmnamea and exgmnameb). The GWE Model with the name exgmnamea must correspond to the GWF Model with the name gwfmodelname1. | +| EXG | GWEGWE | OPTIONS | GWFMODELNAME2 | STRING | keyword to specify name of second corresponding GWF Model. In the simulation name file, the GWE6-GWE6 entry contains names for GWE Models (exgmnamea and exgmnameb). The GWE Model with the name exgmnameb must correspond to the GWF Model with the name gwfmodelname2. | +| EXG | GWEGWE | OPTIONS | AUXILIARY | STRING (NAUX) | an array of auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided. Most auxiliary variables will not be used by the GWF-GWF Exchange, but they will be available for use by other parts of the program. If an auxiliary variable with the name ``ANGLDEGX'' is found, then this information will be used as the angle (provided in degrees) between the connection face normal and the x axis, where a value of zero indicates that a normal vector points directly along the positive x axis. The connection face normal is a normal vector on the cell face shared between the cell in model 1 and the cell in model 2 pointing away from the model 1 cell. Additional information on ``ANGLDEGX'' is provided in the description of the DISU Package. If an auxiliary variable with the name ``CDIST'' is found, then this information will be used as the straight-line connection distance, including the vertical component, between the two cell centers. Both ANGLDEGX and CDIST are required if specific discharge is calculated for either of the groundwater models. | +| EXG | GWEGWE | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of GWE Exchange cells. | +| EXG | GWEGWE | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of exchange entries will be echoed to the listing file immediately after it is read. | +| EXG | GWEGWE | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of exchange flow rates will be printed to the listing file for every stress period in which ``SAVE BUDGET'' is specified in Output Control. | +| EXG | GWEGWE | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that cell-by-cell flow terms will be written to the budget file for each model provided that the Output Control for the models are set up with the ``BUDGET SAVE FILE'' option. | +| EXG | GWEGWE | OPTIONS | ADV_SCHEME | STRING | scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. | +| EXG | GWEGWE | OPTIONS | DSP_XT3D_OFF | KEYWORD | deactivate the xt3d method for the dispersive flux and use the faster and less accurate approximation for this exchange. | +| EXG | GWEGWE | OPTIONS | DSP_XT3D_RHS | KEYWORD | add xt3d dispersion terms to right-hand side, when possible, for this exchange. | +| EXG | GWEGWE | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | +| EXG | GWEGWE | OPTIONS | MVT6 | KEYWORD | keyword to specify that record corresponds to a transport mover file. | +| EXG | GWEGWE | OPTIONS | MVT6_FILENAME | STRING | is the file name of the transport mover input file to apply to this exchange. Information for the transport mover are provided in the file provided with these keywords. | +| EXG | GWEGWE | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | +| EXG | GWEGWE | OPTIONS | OBS6_FILENAME | STRING | is the file name of the observations input file for this exchange. See the ``Observation utility'' section for instructions for preparing observation input files. Table \ref{table:gwe-obstypetable} lists observation type(s) supported by the GWE-GWE package. | +| EXG | GWEGWE | OPTIONS | DEV_INTERFACEMODEL_ON | KEYWORD | activates the interface model mechanism for calculating the coefficients at (and possibly near) the exchange. This keyword should only be used for development purposes. | +| EXG | GWEGWE | DIMENSIONS | NEXG | INTEGER | keyword and integer value specifying the number of GWE-GWE exchanges. | +| EXG | GWEGWE | EXCHANGEDATA | CELLIDM1 | INTEGER | is the cellid of the cell in model 1 as specified in the simulation name file. For a structured grid that uses the DIS input file, CELLIDM1 is the layer, row, and column numbers of the cell. For a grid that uses the DISV input file, CELLIDM1 is the layer number and CELL2D number for the two cells. If the model uses the unstructured discretization (DISU) input file, then CELLIDM1 is the node number for the cell. | +| EXG | GWEGWE | EXCHANGEDATA | CELLIDM2 | INTEGER | is the cellid of the cell in model 2 as specified in the simulation name file. For a structured grid that uses the DIS input file, CELLIDM2 is the layer, row, and column numbers of the cell. For a grid that uses the DISV input file, CELLIDM2 is the layer number and CELL2D number for the two cells. If the model uses the unstructured discretization (DISU) input file, then CELLIDM2 is the node number for the cell. | +| EXG | GWEGWE | EXCHANGEDATA | IHC | INTEGER | is an integer flag indicating the direction between node n and all of its m connections. If IHC = 0 then the connection is vertical. If IHC = 1 then the connection is horizontal. If IHC = 2 then the connection is horizontal for a vertically staggered grid. | +| EXG | GWEGWE | EXCHANGEDATA | CL1 | DOUBLE PRECISION | is the distance between the center of cell 1 and the its shared face with cell 2. | +| EXG | GWEGWE | EXCHANGEDATA | CL2 | DOUBLE PRECISION | is the distance between the center of cell 2 and the its shared face with cell 1. | +| EXG | GWEGWE | EXCHANGEDATA | HWVA | DOUBLE PRECISION | is the horizontal width of the flow connection between cell 1 and cell 2 if IHC $>$ 0, or it is the area perpendicular to flow of the vertical connection between cell 1 and cell 2 if IHC = 0. | +| EXG | GWEGWE | EXCHANGEDATA | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each GWEGWE Exchange. The values of auxiliary variables must be present for each exchange. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. | +| EXG | GWEGWE | EXCHANGEDATA | BOUNDNAME | STRING | name of the GWE Exchange cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | SLN | IMS | OPTIONS | PRINT_OPTION | STRING | is a flag that controls printing of convergence information from the solver. NONE means print nothing. SUMMARY means print only the total number of iterations and nonlinear residual reduction summaries. ALL means print linear matrix solver convergence information to the solution listing file and model specific linear matrix solver convergence information to each model listing file in addition to SUMMARY information. NONE is default if PRINT\_OPTION is not specified. | | SLN | IMS | OPTIONS | COMPLEXITY | STRING | is an optional keyword that defines default non-linear and linear solver parameters. SIMPLE - indicates that default solver input values will be defined that work well for nearly linear models. This would be used for models that do not include nonlinear stress packages and models that are either confined or consist of a single unconfined layer that is thick enough to contain the water table within a single layer. MODERATE - indicates that default solver input values will be defined that work well for moderately nonlinear models. This would be used for models that include nonlinear stress packages and models that consist of one or more unconfined layers. The MODERATE option should be used when the SIMPLE option does not result in successful convergence. COMPLEX - indicates that default solver input values will be defined that work well for highly nonlinear models. This would be used for models that include nonlinear stress packages and models that consist of one or more unconfined layers representing complex geology and surface-water/groundwater interaction. The COMPLEX option should be used when the MODERATE option does not result in successful convergence. Non-linear and linear solver parameters assigned using a specified complexity can be modified in the NONLINEAR and LINEAR blocks. If the COMPLEXITY option is not specified, NONLINEAR and LINEAR variables will be assigned the simple complexity values. | | SLN | IMS | OPTIONS | CSV_OUTPUT | KEYWORD | keyword to specify that the record corresponds to the comma separated values solver convergence output. The CSV\_OUTPUT option has been deprecated and split into the CSV_OUTER_OUTPUT and CSV_INNER_OUTPUT options. Starting with MODFLOW 6 version 6.1.1 if the CSV_OUTPUT option is specified, then it is treated as the CSV_OUTER_OUTPUT option. | @@ -231,6 +256,21 @@ | GWF | BUY | PACKAGEDATA | CRHOREF | DOUBLE PRECISION | real value that defines the reference concentration value used for this species in the density equation of state. | | GWF | BUY | PACKAGEDATA | MODELNAME | STRING | name of GWT model used to simulate a species that will be used in the density equation of state. This name will have no effect if the simulation does not include a GWT model that corresponds to this GWF model. | | GWF | BUY | PACKAGEDATA | AUXSPECIESNAME | STRING | name of an auxiliary variable in a GWF stress package that will be used for this species to calculate a density value. If a density value is needed by the Buoyancy Package then it will use the concentration values in this AUXSPECIESNAME column in the density equation of state. For advanced stress packages (LAK, SFR, MAW, and UZF) that have an associated advanced transport package (LKT, SFT, MWT, and UZT), the FLOW\_PACKAGE\_AUXILIARY\_NAME option in the advanced transport package can be used to transfer simulated concentrations into the flow package auxiliary variable. In this manner, the Buoyancy Package can calculate density values for lakes, streams, multi-aquifer wells, and unsaturated zone flow cells using simulated concentrations. | +| GWF | VSC | OPTIONS | VISCREF | DOUBLE | fluid reference viscosity used in the equation of state. This value is set to 1.0 if not specified as an option. | +| GWF | VSC | OPTIONS | TEMPERATURE_SPECIES_NAME | STRING | string used to identify the auxspeciesname in PACKAGEDATA that corresponds to the temperature species. There can be only one occurrence of this temperature species name in the PACKAGEDATA block or the program will terminate with an error. This value has no effect if viscosity does not depend on temperature. | +| GWF | VSC | OPTIONS | THERMAL_FORMULATION | STRING | may be used for specifying which viscosity formulation to use for the temperature species. Can be either LINEAR or NONLINEAR. The LINEAR viscosity formulation is the default. | +| GWF | VSC | OPTIONS | THERMAL_A2 | DOUBLE | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A2 is not specified, a default value of 10.0 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | THERMAL_A3 | DOUBLE | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A3 is not specified, a default value of 248.37 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | THERMAL_A4 | DOUBLE PRECISION | is an empirical parameter specified by the user for calculating viscosity using a nonlinear formulation. If A4 is not specified, a default value of 133.15 is assigned (Voss, 1984). | +| GWF | VSC | OPTIONS | VISCOSITY | KEYWORD | keyword to specify that record corresponds to viscosity. | +| GWF | VSC | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWF | VSC | OPTIONS | VISCOSITYFILE | STRING | name of the binary output file to write viscosity information. The viscosity file has the same format as the head file. Viscosity values will be written to the viscosity file whenever heads are written to the binary head file. The settings for controlling head output are contained in the Output Control option. | +| GWF | VSC | DIMENSIONS | NVISCSPECIES | INTEGER | number of species used in the viscosity equation of state. If either concentrations or temperature (or both) are used to update viscosity then then nrhospecies needs to be at least one. | +| GWF | VSC | PACKAGEDATA | IVISCSPEC | INTEGER | integer value that defines the species number associated with the specified PACKAGEDATA data entered on each line. IVISCSPECIES must be greater than zero and less than or equal to NVISCSPECIES. Information must be specified for each of the NVISCSPECIES species or the program will terminate with an error. The program will also terminate with an error if information for a species is specified more than once. | +| GWF | VSC | PACKAGEDATA | DVISCDC | DOUBLE PRECISION | real value that defines the slope of the line defining the linear relationship between viscosity and temperature or between viscosity and concentration, depending on the type of species entered on each line. If the value of AUXSPECIESNAME entered on a line corresponds to TEMPERATURE\_SPECIES\_NAME (in the OPTIONS block), this value will be used when VISCOSITY\_FUNC is equal to LINEAR (the default) in the OPTIONS block. When VISCOSITY\_FUNC is set to NONLINEAR, a value for DVISCDC must be specified though it is not used. | +| GWF | VSC | PACKAGEDATA | CVISCREF | DOUBLE PRECISION | real value that defines the reference temperature or reference concentration value used for this species in the viscosity equation of state. If AUXSPECIESNAME entered on a line corresponds to TEMPERATURE\_SPECIES\_NAME (in the OPTIONS block), then CVISCREF refers to a reference temperature, otherwise it refers to a reference concentration. | +| GWF | VSC | PACKAGEDATA | MODELNAME | STRING | name of a GWT model used to simulate a species that will be used in the viscosity equation of state. This name will have no effect if the simulation does not include a GWT model that corresponds to this GWF model. | +| GWF | VSC | PACKAGEDATA | AUXSPECIESNAME | STRING | name of an auxiliary variable in a GWF stress package that will be used for this species to calculate the viscosity values. If a viscosity value is needed by the Viscosity Package then it will use the temperature or concentration values associated with this AUXSPECIESNAME in the viscosity equation of state. For advanced stress packages (LAK, SFR, MAW, and UZF) that have an associated advanced transport package (LKT, SFT, MWT, and UZT), the FLOW\_PACKAGE\_AUXILIARY\_NAME option in the advanced transport package can be used to transfer simulated temperature or concentration(s) into the flow package auxiliary variable. In this manner, the Viscosity Package can calculate viscosity values for lakes, streams, multi-aquifer wells, and unsaturated zone flow cells using simulated concentrations. | | GWF | STO | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that cell-by-cell flow terms will be written to the file specified with ``BUDGET SAVE FILE'' in Output Control. | | GWF | STO | OPTIONS | STORAGECOEFFICIENT | KEYWORD | keyword to indicate that the SS array is read as storage coefficient rather than specific storage. | | GWF | STO | OPTIONS | SS_CONFINED_ONLY | KEYWORD | keyword to indicate that compressible storage is only calculated for a convertible cell (ICONVERT>0) when the cell is under confined conditions (head greater than or equal to the top of the cell). This option has no effect on cells that are marked as being always confined (ICONVERT=0). This option is identical to the approach used to calculate storage changes under confined conditions in MODFLOW-2005. | @@ -1151,6 +1191,173 @@ | GWT | API | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the api boundary package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the api boundary package. | | GWT | API | OPTIONS | MOVER | KEYWORD | keyword to indicate that this instance of the api boundary Package can be used with the Water Mover (MVR) Package. When the MOVER option is specified, additional memory is allocated within the package to store the available, provided, and received water. | | GWT | API | DIMENSIONS | MAXBOUND | INTEGER | integer value specifying the maximum number of api boundary cells that will be specified for use during any stress period. | +| GWE | NAM | OPTIONS | LIST | STRING | is name of the listing file to create for this GWE model. If not specified, then the name of the list file will be the basename of the GWE model name file and the '.lst' extension. For example, if the GWE name file is called ``my.model.nam'' then the list file will be called ``my.model.lst''. | +| GWE | NAM | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of all model stress package information will be written to the listing file immediately after it is read. | +| GWE | NAM | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of all model package flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | +| GWE | NAM | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that all model package flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | NAM | PACKAGES | FTYPE | STRING | is the file type, which must be one of the following character values shown in table~\ref{table:ftype}. Ftype may be entered in any combination of uppercase and lowercase. | +| GWE | NAM | PACKAGES | FNAME | STRING | is the name of the file containing the package input. The path to the file should be included if the file is not located in the folder where the program was run. | +| GWE | NAM | PACKAGES | PNAME | STRING | is the user-defined name for the package. PNAME is restricted to 16 characters. No spaces are allowed in PNAME. PNAME character values are read and stored by the program for stress packages only. These names may be useful for labeling purposes when multiple stress packages of the same type are located within a single GWE Model. If PNAME is specified for a stress package, then PNAME will be used in the flow budget table in the listing file; it will also be used for the text entry in the cell-by-cell budget file. PNAME is case insensitive and is stored in all upper case letters. | +| GWE | ADV | OPTIONS | SCHEME | STRING | scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. | +| GWE | DIS | OPTIONS | LENGTH_UNITS | STRING | is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. | +| GWE | DIS | OPTIONS | NOGRB | KEYWORD | keyword to deactivate writing of the binary grid file. | +| GWE | DIS | OPTIONS | XORIGIN | DOUBLE PRECISION | x-position of the lower-left corner of the model grid. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DIS | OPTIONS | YORIGIN | DOUBLE PRECISION | y-position of the lower-left corner of the model grid. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DIS | OPTIONS | ANGROT | DOUBLE PRECISION | counter-clockwise rotation angle (in degrees) of the lower-left corner of the model grid. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DIS | DIMENSIONS | NLAY | INTEGER | is the number of layers in the model grid. | +| GWE | DIS | DIMENSIONS | NROW | INTEGER | is the number of rows in the model grid. | +| GWE | DIS | DIMENSIONS | NCOL | INTEGER | is the number of columns in the model grid. | +| GWE | DIS | GRIDDATA | DELR | DOUBLE PRECISION (NCOL) | is the column spacing in the row direction. | +| GWE | DIS | GRIDDATA | DELC | DOUBLE PRECISION (NROW) | is the row spacing in the column direction. | +| GWE | DIS | GRIDDATA | TOP | DOUBLE PRECISION (NCOL, NROW) | is the top elevation for each cell in the top model layer. | +| GWE | DIS | GRIDDATA | BOTM | DOUBLE PRECISION (NCOL, NROW, NLAY) | is the bottom elevation for each cell. | +| GWE | DIS | GRIDDATA | IDOMAIN | INTEGER (NCOL, NROW, NLAY) | is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. | +| GWE | DISV | OPTIONS | LENGTH_UNITS | STRING | is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. | +| GWE | DISV | OPTIONS | NOGRB | KEYWORD | keyword to deactivate writing of the binary grid file. | +| GWE | DISV | OPTIONS | XORIGIN | DOUBLE PRECISION | x-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DISV | OPTIONS | YORIGIN | DOUBLE PRECISION | y-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DISV | OPTIONS | ANGROT | DOUBLE PRECISION | counter-clockwise rotation angle (in degrees) of the model grid coordinate system relative to a real-world coordinate system. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DISV | DIMENSIONS | NLAY | INTEGER | is the number of layers in the model grid. | +| GWE | DISV | DIMENSIONS | NCPL | INTEGER | is the number of cells per layer. This is a constant value for the grid and it applies to all layers. | +| GWE | DISV | DIMENSIONS | NVERT | INTEGER | is the total number of (x, y) vertex pairs used to characterize the horizontal configuration of the model grid. | +| GWE | DISV | GRIDDATA | TOP | DOUBLE PRECISION (NCPL) | is the top elevation for each cell in the top model layer. | +| GWE | DISV | GRIDDATA | BOTM | DOUBLE PRECISION (NLAY, NCPL) | is the bottom elevation for each cell. | +| GWE | DISV | GRIDDATA | IDOMAIN | INTEGER (NLAY, NCPL) | is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. | +| GWE | DISV | VERTICES | IV | INTEGER | is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. | +| GWE | DISV | VERTICES | XV | DOUBLE PRECISION | is the x-coordinate for the vertex. | +| GWE | DISV | VERTICES | YV | DOUBLE PRECISION | is the y-coordinate for the vertex. | +| GWE | DISV | CELL2D | ICELL2D | INTEGER | is the CELL2D number. Records in the CELL2D block must be listed in consecutive order from the first to the last. | +| GWE | DISV | CELL2D | XC | DOUBLE PRECISION | is the x-coordinate for the cell center. | +| GWE | DISV | CELL2D | YC | DOUBLE PRECISION | is the y-coordinate for the cell center. | +| GWE | DISV | CELL2D | NCVERT | INTEGER | is the number of vertices required to define the cell. There may be a different number of vertices for each cell. | +| GWE | DISV | CELL2D | ICVERT | INTEGER (NCVERT) | is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. Cells that are connected must share vertices. | +| GWE | DSP | OPTIONS | XT3D_OFF | KEYWORD | deactivate the xt3d method and use the faster and less accurate approximation. This option may provide a fast and accurate solution under some circumstances, such as when flow aligns with the model grid, there is no mechanical dispersion, or when the longitudinal and transverse dispersivities are equal. This option may also be used to assess the computational demand of the XT3D approach by noting the run time differences with and without this option on. | +| GWE | DSP | OPTIONS | XT3D_RHS | KEYWORD | add xt3d terms to right-hand side, when possible. This option uses less memory, but may require more iterations. | +| GWE | DSP | GRIDDATA | DIFFC | DOUBLE PRECISION (NODES) | effective molecular diffusion coefficient. | +| GWE | DSP | GRIDDATA | ALH | DOUBLE PRECISION (NODES) | longitudinal dispersivity in horizontal direction. If flow is strictly horizontal, then this is the longitudinal dispersivity that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. | +| GWE | DSP | GRIDDATA | ALV | DOUBLE PRECISION (NODES) | longitudinal dispersivity in vertical direction. If flow is strictly vertical, then this is the longitudinal dispsersivity value that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ALH. | +| GWE | DSP | GRIDDATA | ATH1 | DOUBLE PRECISION (NODES) | transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the second ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the y direction. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. | +| GWE | DSP | GRIDDATA | ATH2 | DOUBLE PRECISION (NODES) | transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the third ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the z direction. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH1. | +| GWE | DSP | GRIDDATA | ATV | DOUBLE PRECISION (NODES) | transverse dispersivity when flow is in vertical direction. If flow is strictly vertical and directed in the z direction, then this value controls spreading in the x and y directions. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH2. | +| GWE | DSP | GRIDDATA | KTW | DOUBLE PRECISION (NODES) | thermal conductivity of water | +| GWE | DSP | GRIDDATA | KTS | DOUBLE PRECISION (NODES) | thermal conductivity of the aquifer material | +| GWE | FMI | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that FMI flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | FMI | OPTIONS | FLOW_IMBALANCE_CORRECTION | KEYWORD | correct for an imbalance in flows by assuming that any residual flow error comes in or leaves at the concentration of the cell. When this option is activated, the GWT Model budget written to the listing file will contain two additional entries: FLOW-ERROR and FLOW-CORRECTION. These two entries will be equal but opposite in sign. The FLOW-CORRECTION term is a mass flow that is added to offset the error caused by an imprecise flow balance. If these terms are not relatively small, the flow model should be rerun with stricter convergence tolerances. | +| GWE | FMI | PACKAGEDATA | FLOWTYPE | STRING | is the word GWFBUDGET, GWFHEAD, GWFMOVER or the name of an advanced GWF stress package. If GWFBUDGET is specified, then the corresponding file must be a budget file from a previous GWF Model run. If an advanced GWF stress package name appears then the corresponding file must be the budget file saved by a LAK, SFR, MAW or UZF Package. | +| GWE | FMI | PACKAGEDATA | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | +| GWE | FMI | PACKAGEDATA | FNAME | STRING | is the name of the file containing flows. The path to the file should be included if the file is not located in the folder where the program was run. | +| GWE | IC | GRIDDATA | STRT | DOUBLE PRECISION (NODES) | is the initial (starting) temperature---that is, the temperature at the beginning of the GWE Model simulation. STRT must be specified for all GWE Model simulations. One value is read for every model cell. | +| GWE | MST | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that MST flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | MST | OPTIONS | FIRST_ORDER_DECAY | KEYWORD | is a text keyword to indicate that first-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. | +| GWE | MST | OPTIONS | ZERO_ORDER_DECAY | KEYWORD | is a text keyword to indicate that zero-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. | +| GWE | MST | GRIDDATA | POROSITY | DOUBLE PRECISION (NODES) | is the aquifer porosity. | +| GWE | MST | GRIDDATA | DECAY | DOUBLE PRECISION (NODES) | is the rate coefficient for first or zero-order decay for the aqueous phase of the mobile domain. A negative value indicates solute production. The dimensions of decay for first-order decay is one over time. The dimensions of decay for zero-order decay is mass per length cubed per time. decay will have no effect on simulation results unless either first- or zero-order decay is specified in the options block. | +| GWE | MST | GRIDDATA | CPW | DOUBLE PRECISION (NODES) | is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. | +| GWE | MST | GRIDDATA | CPS | DOUBLE PRECISION (NODES) | is the mass-based heat capacity of dry solids (aquifer material). Thus, enter value in units of J/kg/C | +| GWE | MST | GRIDDATA | RHOW | DOUBLE PRECISION (NODES) | is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 | +| GWE | MST | GRIDDATA | RHOS | DOUBLE PRECISION (NODES) | is a user-specified value of the density of aquifer material no considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. | +| GWE | OC | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | +| GWE | OC | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWE | OC | OPTIONS | BUDGETFILE | STRING | name of the output file to write budget information. | +| GWE | OC | OPTIONS | BUDGETCSV | KEYWORD | keyword to specify that record corresponds to the budget CSV. | +| GWE | OC | OPTIONS | BUDGETCSVFILE | STRING | name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. | +| GWE | OC | OPTIONS | TEMPERATURE | KEYWORD | keyword to specify that record corresponds to temperature. | +| GWE | OC | OPTIONS | TEMPERATUREFILE | STRING | name of the output file to write conc information. | +| GWE | OC | OPTIONS | PRINT_FORMAT | KEYWORD | keyword to specify format for printing to the listing file. | +| GWE | OC | OPTIONS | COLUMNS | INTEGER | number of columns for writing data. | +| GWE | OC | OPTIONS | WIDTH | INTEGER | width for writing each number. | +| GWE | OC | OPTIONS | DIGITS | INTEGER | number of digits to use for writing a number. | +| GWE | OC | OPTIONS | FORMAT | STRING | write format can be EXPONENTIAL, FIXED, GENERAL, or SCIENTIFIC. | +| GWE | OC | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | +| GWE | OC | PERIOD | SAVE | KEYWORD | keyword to indicate that information will be saved this stress period. | +| GWE | OC | PERIOD | PRINT | KEYWORD | keyword to indicate that information will be printed this stress period. | +| GWE | OC | PERIOD | RTYPE | STRING | type of information to save or print. Can be BUDGET or TEMPERATURE. | +| GWE | OC | PERIOD | OCSETTING | KEYSTRING | specifies the steps for which the data will be saved. | +| GWE | OC | PERIOD | ALL | KEYWORD | keyword to indicate save for all time steps in period. | +| GWE | OC | PERIOD | FIRST | KEYWORD | keyword to indicate save for first step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | +| GWE | OC | PERIOD | LAST | KEYWORD | keyword to indicate save for last step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | +| GWE | OC | PERIOD | FREQUENCY | INTEGER | save at the specified time step frequency. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | +| GWE | OC | PERIOD | STEPS | INTEGER ( Date: Fri, 16 Dec 2022 11:59:08 -0800 Subject: [PATCH 060/212] ran black on Cindy's Stallman script --- autotest/test_gwe_stallman.py | 102 ++++++++++++++++++---------------- 1 file changed, 54 insertions(+), 48 deletions(-) diff --git a/autotest/test_gwe_stallman.py b/autotest/test_gwe_stallman.py index eb8b02cdd69..650fbf8163a 100644 --- a/autotest/test_gwe_stallman.py +++ b/autotest/test_gwe_stallman.py @@ -64,16 +64,16 @@ porosity = 0.35 # Porosity (unitless) alphal = 0.0 # Longitudinal dispersivity ($m$) alphat = 0.0 # Transverse dispersivity ($m$) -diffc = 1.02882E-06 # Diffusion coefficient ($m s^{-1}$) +diffc = 1.02882e-06 # Diffusion coefficient ($m s^{-1}$) T_az = 10 # Ambient temperature ($^o C$) dT = 5 # Temperature variation ($^o C$) bulk_dens = 2630 # Bulk density ($kg/m^3$) kd = 0.000191663 # Distribution coefficient (unitless) -ktw=0.58 -kts=2 -cpw=4174.0 -cps=800.0 -rhow=1000.0 +ktw = 0.58 +kts = 2 +cpw = 4174.0 +cps = 800.0 +rhow = 1000.0 rhos = bulk_dens # Stress period input @@ -86,23 +86,26 @@ tp = top botm = [] for i in range(nlay): - if i==0:botm.append(59.9) - elif i==119:botm.append(0.0) - else: botm.append(60-i*0.5) + if i == 0: + botm.append(59.9) + elif i == 119: + botm.append(0.0) + else: + botm.append(60 - i * 0.5) # Head input chd_data = {} -for k in range(nper): - chd_data[k] = [[(0, 0, 0), 60.000000],[(119, 0, 0), 59.701801]] +#for k in range(nper): +chd_data[0] = [[(0, 0, 0), 60.000000], [(119, 0, 0), 59.701801]] chd_mf6 = chd_data # Initial temperature input -strt_conc = T_az* np.ones((nlay, 1, 1), dtype=np.float32) +strt_temp = T_az * np.ones((nlay, 1, 1), dtype=np.float32) # Boundary temperature input cnc_data = {} for k in range(nper): - cnc_temp = T_az+dT*np.sin(2*np.pi*k*perlen/365/86400) + cnc_temp = T_az + dT * np.sin(2 * np.pi * k * perlen / 365 / 86400) cnc_data[k] = [[(0, 0, 0), cnc_temp]] cnc_mf6 = cnc_data @@ -110,20 +113,24 @@ hclose, rclose, relax = 1e-8, 1e-8, 0.97 - # Analytical solution for Stallman analysis (Stallman 1965, JGR) -# Analytical solution for Stallman analysis (Stallman 1965, JGR) -def Stallman(T_az,dT,tau,t,c_rho,darcy_flux,ko,c_w,rho_w,zbotm,nlay): +def Stallman(T_az, dT, tau, t, c_rho, darcy_flux, ko, c_w, rho_w, zbotm, nlay): zstallman = np.zeros((nlay, 2)) - K = np.pi*c_rho/ko/tau - V = darcy_flux*c_w*rho_w/2/ko - a = ((K**2+V**4/4)**0.5+V**2/2)**0.5-V - b = ((K**2+V**4/4)**0.5-V**2/2)**0.5 + K = np.pi * c_rho / ko / tau + V = darcy_flux * c_w * rho_w / 2 / ko + a = ((K ** 2 + V ** 4 / 4) ** 0.5 + V ** 2 / 2) ** 0.5 - V + b = ((K ** 2 + V ** 4 / 4) ** 0.5 - V ** 2 / 2) ** 0.5 for i in range(len(zstallman)): - zstallman[i,0] = zbotm[i] - zstallman[i,1] = dT*np.exp(-a*(-zstallman[i,0]))*np.sin(2*np.pi*t/tau-b*(-zstallman[i,0])) + T_az + zstallman[i, 0] = zbotm[i] + zstallman[i, 1] = ( + dT + * np.exp(-a * (-zstallman[i, 0])) + * np.sin(2 * np.pi * t / tau - b * (-zstallman[i, 0])) + + T_az + ) return zstallman + # # MODFLOW 6 (sim) flopy objects returned if building the model # @@ -140,7 +147,7 @@ def build_model(idx, dir): gwfname = "gwf-" + name gwename = "gwe-" + name - #sim_ws = os.path.join(ws, name) + # sim_ws = os.path.join(ws, name) sim = flopy.mf6.MFSimulation( sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" ) @@ -200,9 +207,7 @@ def build_model(idx, dir): ) # Instantiating MODFLOW 6 initial conditions package for flow model - flopy.mf6.ModflowGwfic( - gwf, strt=top, filename="{}.ic".format(gwfname) - ) + flopy.mf6.ModflowGwfic(gwf, strt=top, filename="{}.ic".format(gwfname)) # Instantiating VSC if viscosity_on[idx]: @@ -235,9 +240,7 @@ def build_model(idx, dir): gwf, head_filerecord="{}.hds".format(gwfname), budget_filerecord="{}.cbc".format(gwfname), - headprintrecord=[ - ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") - ], + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], saverecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], printrecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], ) @@ -283,7 +286,7 @@ def build_model(idx, dir): # Instantiating MODFLOW 6 transport initial concentrations flopy.mf6.ModflowGweic( - gwe, strt=strt_conc, filename="{}.ic".format(gwename) + gwe, strt=strt_temp, filename="{}.ic".format(gwename) ) # Instantiating MODFLOW 6 transport advection package @@ -350,11 +353,11 @@ def build_model(idx, dir): def eval_model(sim): print("evaluating results...") - + # read transport results from GWE model name = ex[sim.idxsim] gwename = "gwe-" + name - + fpth = os.path.join(sim.simpath, f"{gwename}.ucn") try: # load temperatures @@ -369,33 +372,36 @@ def eval_model(sim): # Prepare to compare the results of MF6-GWE with analytical solution zconc = np.zeros((nlay, 2)) for i in range(nlay): - if i != (nlay-1): zconc[i+1,0] = -(60-botm[i]) - zconc[i,1] = conc1[i][0][0] + if i != (nlay - 1): + zconc[i + 1, 0] = -(60 - botm[i]) + zconc[i, 1] = conc1[i][0][0] # Analytical solution - Stallman analysis - tau = 365*86400 - t = 283824000.0 + tau = 365 * 86400 + t = 283824000.0 c_w = 4174 rho_w = 1000 c_r = 800 rho_r = 2630 - c_rho = c_r*rho_r*(1-porosity) + c_w*rho_w*porosity - darcy_flux = 5.00E-07 + c_rho = c_r * rho_r * (1 - porosity) + c_w * rho_w * porosity + darcy_flux = 5.00e-07 ko = 1.503 - zanal = Stallman(T_az,dT,tau,t,c_rho,darcy_flux,ko,c_w,rho_w,zconc[:,0],nlay) - - plt.plot(zconc[:,1], zconc[:,0], "k--", linewidth=0.5, label='MF6-GWE') - plt.plot(zanal[:,1], zanal[:,0], "bo", mfc="none", label='Analytical') - plt.xlim(T_az-dT, T_az+dT) + zanal = Stallman( + T_az, dT, tau, t, c_rho, darcy_flux, ko, c_w, rho_w, zconc[:, 0], nlay + ) + + plt.plot(zconc[:, 1], zconc[:, 0], "k--", linewidth=0.5, label="MF6-GWE") + plt.plot(zanal[:, 1], zanal[:, 0], "bo", mfc="none", label="Analytical") + plt.xlim(T_az - dT, T_az + dT) plt.ylim(-top, 0) plt.ylabel("Depth (m)") plt.xlabel("Temperature (deg C)") plt.legend() - plt.savefig('stallman.png') - + plt.savefig("stallman.png") + msg = f"gwe temperatures do not match stored concentrations" - assert np.allclose(zconc[:,1], zanal[:,1], atol=1e-1), msg - + assert np.allclose(zconc[:, 1], zanal[:, 1], atol=1e-1), msg + return @@ -433,4 +439,4 @@ def main(): print(f"standalone run of {os.path.basename(__file__)}") # run main routine - main() \ No newline at end of file + main() From ab9dc6bef4082c6638806f051441ff1280bb9fe3 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 2 Jan 2023 08:37:41 -0800 Subject: [PATCH 061/212] Some more work on labeling of units --- src/Model/GroundWaterEnergy/gwe1.f90 | 8 +- src/Model/GroundWaterFlow/gwf3sfr8.f90 | 6 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1sft1.f90 | 18 +-- src/Model/GroundWaterTransport/tsp1apt1.f90 | 126 ++++++++++++-------- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 10 +- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 24 ++-- 7 files changed, 117 insertions(+), 77 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 3356794677c..70ad2d9cada 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1136,7 +1136,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & use TspCncModule, only: cnc_create ! use GweSrcModule, only: src_create ! use GweLktModule, only: lkt_create -! use GweSftModule, only: sft_create + use GweSfeModule, only: sfe_create ! use GweMwtModule, only: mwt_create ! use GweUztModule, only: uzt_create ! use ApiModule, only: api_create @@ -1166,9 +1166,9 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & !case('LKT6') ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) - !case('SFT6') - ! call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) + case('SFE6') + call sfe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%fmi, this%tsplab) !case('MWT6') ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index 649445fa55e..c470fb7c042 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -3272,6 +3272,7 @@ subroutine sfr_solve(this, n, h, hcof, rhs, update) integer(I4B) :: ibflg real(DP) :: hgwf real(DP) :: sa + real(DP) :: sa_wet real(DP) :: qu real(DP) :: qi real(DP) :: qr @@ -3355,9 +3356,10 @@ subroutine sfr_solve(this, n, h, hcof, rhs, update) this%usflow(n) = qu ! -- calculate remaining terms sa = this%calc_surface_area(n) + sa_wet = this%calc_surface_area_wet(n, this%depth(n)) qi = this%inflow(n) qr = this%rain(n) * sa - qe = this%evap(n) * sa + qe = this%evap(n) * sa_wet qro = this%runoff(n) ! ! -- Water mover term; assume that it goes in at the upstream end of the reach @@ -3831,7 +3833,7 @@ subroutine sfr_calc_qsource(this, n, depth, qsrc) a = this%calc_surface_area(n) ae = this%calc_surface_area_wet(n, depth) qr = this%rain(n) * a - qe = this%evap(n) * a + qe = this%evap(n) * ae ! ! -- calculate mover term qfrommvr = DZERO diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index f06ed98da4b..ad36dc064fd 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -1182,7 +1182,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & pakname, this%fmi) case ('SFT6') call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab) case ('MWT6') call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 380a60dd03e..f9abbccf2a2 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -41,6 +41,7 @@ module GwtSftModule use ObserveModule, only: ObserveType use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType implicit none @@ -89,9 +90,9 @@ module GwtSftModule contains subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi) + fmi, tsplab) ! ****************************************************************************** -! mwt_create -- Create a New MWT Package +! sft_create -- Create a New SFT Package ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -105,24 +106,25 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab ! -- local - type(GwtSftType), pointer :: lktobj + type(GwtSftType), pointer :: sftobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate (lktobj) - packobj => lktobj + allocate (sftobj) + packobj => sftobj ! ! -- create name and memory path call packobj%set_names(ibcnum, namemodel, pakname, ftype) packobj%text = text ! ! -- allocate scalars - call lktobj%allocate_scalars() + call sftobj%allocate_scalars() ! ! -- initialize package call packobj%pack_initialize() - + ! packobj%inunit = inunit packobj%iout = iout packobj%id = id @@ -133,7 +135,7 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Store pointer to flow model interface. When the GwfGwt exchange is ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages - lktobj%fmi => fmi + sftobj%fmi => fmi ! ! -- return return diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 2b0346b2824..9658d5c402b 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -66,7 +66,7 @@ module TspAptModule character(len=LENPACKAGENAME) :: flowpackagename = '' !< name of corresponding flow package character(len=8), & dimension(:), pointer, contiguous :: status => null() !< active, inactive, constant - character(len=LENAUXNAME) :: cauxfpconc = '' !< name of aux column in flow package auxvar array for concentration + character(len=LENAUXNAME) :: cauxfpconc = '' !< name of aux column in flow package auxvar array for concentration (or temperature) integer(I4B), pointer :: iauxfpconc => null() !< column in flow package bound array to insert concs integer(I4B), pointer :: imatrows => null() !< if active, add new rows to matrix integer(I4B), pointer :: iprconc => null() !< print conc to listing file @@ -75,7 +75,7 @@ module TspAptModule integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file integer(I4B), pointer :: ncv => null() !< number of control volumes integer(I4B), pointer :: igwfaptpak => null() !< package number of corresponding this package - real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration + real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration (or temperature) integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< map position in global rhs and x array of pack entry integer(I4B), dimension(:), pointer, contiguous :: idxpakdiag => null() !< map diag position of feature in global amat integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !< map position in global array of package diagonal row entries @@ -85,16 +85,16 @@ module TspAptModule integer(I4B), dimension(:), pointer, contiguous :: idxfjfdglo => null() !< map diagonal feature to feature in global amat integer(I4B), dimension(:), pointer, contiguous :: idxfjfoffdglo => null() !< map off diagonal feature to feature in global amat integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !< package ibound - real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !< feature concentration for current time step - real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !< feature concentration from previous time step + real(DP), dimension(:), pointer, contiguous :: xnewpak => null() !< feature concentration (or temperature) for current time step + real(DP), dimension(:), pointer, contiguous :: xoldpak => null() !< feature concentration (or temperature) from previous time step real(DP), dimension(:), pointer, contiguous :: dbuff => null() !< temporary storage array character(len=LENBOUNDNAME), & dimension(:), pointer, contiguous :: featname => null() - real(DP), dimension(:), pointer, contiguous :: concfeat => null() !< concentration of the feature + real(DP), dimension(:), pointer, contiguous :: concfeat => null() !< concentration (or temperature) of the feature real(DP), dimension(:, :), pointer, contiguous :: lauxvar => null() !< auxiliary variable type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object - real(DP), dimension(:), pointer, contiguous :: qsto => null() !< mass flux due to storage change - real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass flux required to maintain constant concentration + real(DP), dimension(:), pointer, contiguous :: qsto => null() !< mass (or energy) flux due to storage change + real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass (or energy) flux required to maintain constant concentration (or temperature) integer(I4B), pointer :: idxbudfjf => null() !< index of flow ja face in flowbudptr integer(I4B), pointer :: idxbudgwf => null() !< index of gwf terms in flowbudptr integer(I4B), pointer :: idxbudsto => null() !< index of storage terms in flowbudptr @@ -103,8 +103,8 @@ module TspAptModule integer(I4B), pointer :: idxbudaux => null() !< index of auxiliary terms in flowbudptr integer(I4B), dimension(:), pointer, contiguous :: idxbudssm => null() !< flag that flowbudptr%buditem is a general solute source/sink integer(I4B), pointer :: nconcbudssm => null() !< number of concbudssm terms (columns) - real(DP), dimension(:, :), pointer, contiguous :: concbudssm => null() !< user specified concentrations for flow terms - real(DP), dimension(:), pointer, contiguous :: qmfrommvr => null() !< a mass flow coming from the mover that needs to be added + real(DP), dimension(:, :), pointer, contiguous :: concbudssm => null() !< user specified concentrations (or temperatures) for flow terms + real(DP), dimension(:), pointer, contiguous :: qmfrommvr => null() !< a mass or energy flow coming from the mover that needs to be added ! ! -- pointer to flow package boundary type(BndType), pointer :: flowpackagebnd => null() @@ -361,8 +361,8 @@ subroutine apt_ar(this) this%fmi%datp(this%igwfaptpak)%qmfrommvr => this%qmfrommvr ! ! -- If there is an associated flow package and the user wishes to put - ! simulated concentrations into a aux variable column, then find - ! the column number. + ! simulated concentrations (or temperatures) into a aux variable + ! column, then find the column number. if (associated(this%flowpackagebnd)) then if (this%cauxfpconc /= '') then found = .false. @@ -542,9 +542,9 @@ subroutine apt_set_stressperiod(this, itemno) ! -- formats ! ------------------------------------------------------------------------------ ! - ! -- Support these general options with apply to LKT, SFT, MWT, UZT + ! -- Support these general options in LKT, SFT, MWT, UZT ! STATUS - ! CONCENTRATION + ! CONCENTRATION or TEMPERATURE ! WITHDRAWAL ! AUXILIARY ! @@ -569,7 +569,7 @@ subroutine apt_set_stressperiod(this, itemno) 'Unknown '//trim(this%text)//' status keyword: ', text//'.' call store_error(errmsg) end if - case ('CONCENTRATION') + case ('CONCENTRATION', 'TEMPERATURE') ierr = this%apt_check_valid(itemno) if (ierr /= 0) then goto 999 @@ -579,7 +579,7 @@ subroutine apt_set_stressperiod(this, itemno) bndElem => this%concfeat(itemno) call read_value_or_time_series_adv(text, itemno, jj, bndElem, & this%packName, 'BND', this%tsManager, & - this%iprpak, 'CONCENTRATION') + this%iprpak, this%tsplab%depvartype) case ('AUXILIARY') ierr = this%apt_check_valid(itemno) if (ierr /= 0) then @@ -700,8 +700,8 @@ subroutine apt_ad(this) end do end if ! - ! -- copy xnew into xold and set xnewpak to specified concentration for - ! constant concentration features + ! -- copy xnew into xold and set xnewpak to specified concentration (or + ! temperature) for constant concentration/temperature features if (iFailedStepRetry == 0) then do n = 1, this%ncv this%xoldpak(n) = this%xnewpak(n) @@ -790,7 +790,7 @@ end subroutine apt_fc subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) ! ****************************************************************************** ! apt_fc_nonexpanded -- formulate for the nonexpanded a matrix case in which -! feature concentrations are solved explicitly +! feature concentrations (or temperatures) are solved explicitly ! **************************************************************************** ! ! SPECIFICATIONS: @@ -806,7 +806,7 @@ subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) integer(I4B) :: j, igwfnode, idiag ! ------------------------------------------------------------------------------ ! - ! -- solve for concentration in the features + ! -- solve for concentration (or temperatures) in the features call this%apt_solve() ! ! -- add hcof and rhs terms (from apt_solve) to the gwf matrix @@ -857,7 +857,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! specific to the package call this%pak_fc_expanded(rhs, ia, idxglo, amatsln) ! - ! -- mass storage in features + ! -- mass (or energy) storage in features do n = 1, this%ncv cold = this%xoldpak(n) iloc = this%idxlocnode(n) @@ -1015,8 +1015,8 @@ subroutine apt_cq(this, x, flowja, iadv) real(DP) :: rrate ! ------------------------------------------------------------------------------ ! - ! -- Solve the feature concentrations again or update the feature hcof - ! and rhs terms + ! -- Solve the feature concentrations (or temperatures) again or update + ! the feature hcof and rhs terms if (this%imatrows == 0) then call this%apt_solve() else @@ -1035,7 +1035,7 @@ subroutine apt_cq(this, x, flowja, iadv) this%qsto(n) = rrate end do ! - ! -- Copy concentrations into the flow package auxiliary variable + ! -- Copy concentrations (or temperatures) into the flow package auxiliary variable call this%apt_copy2flowp() ! ! -- fill the budget object @@ -1071,15 +1071,20 @@ subroutine apt_ot_package_flows(this, icbcfl, ibudfl) end subroutine apt_ot_package_flows subroutine apt_ot_dv(this, idvsave, idvprint) + ! -- modules + use ConstantsModule, only: LENBUDTXT use TdisModule, only: kstp, kper, pertim, totim - use ConstantsModule, only: DHNOFLO, DHDRY + use ConstantsModule, only: DHNOFLO, DHDRY, LENBUDTXT use InputOutputModule, only: ulasav + ! -- dummy class(TspAptType) :: this integer(I4B), intent(in) :: idvsave integer(I4B), intent(in) :: idvprint + ! -- local integer(I4B) :: ibinun integer(I4B) :: n real(DP) :: c + character(len=LENBUDTXT) :: text ! ! -- set unit number for binary dependent variable output ibinun = 0 @@ -1097,7 +1102,8 @@ subroutine apt_ot_dv(this, idvsave, idvprint) end if this%dbuff(n) = c end do - call ulasav(this%dbuff, ' CONCENTRATION', kstp, kper, pertim, totim, & + write(text, '(a)') padl(this%tsplab%depvartype, 16) + call ulasav(this%dbuff, text, kstp, kper, pertim, totim, & this%ncv, 1, 1, ibinun) end if ! @@ -1293,7 +1299,7 @@ subroutine apt_allocate_arrays(this) call mem_allocate(this%concbudssm, this%nconcbudssm, this%ncv, & 'CONCBUDSSM', this%memoryPath) ! - ! -- mass added from the mover transport package + ! -- mass (or energy) added from the mover transport package call mem_allocate(this%qmfrommvr, this%ncv, 'QMFROMMVR', this%memoryPath) ! ! -- initialize arrays @@ -1454,11 +1460,12 @@ subroutine apt_options(this, option, found) write (this%iout, '(4x,a)') & trim(adjustl(this%text))// & ' WILL NOT ADD ADDITIONAL ROWS TO THE A MATRIX.' - case ('PRINT_CONCENTRATION') + case ('PRINT_CONCENTRATION', 'PRINT_TEMPERATURE') this%iprconc = 1 - write (this%iout, '(4x,a)') trim(adjustl(this%text))// & - ' CONCENTRATIONS WILL BE PRINTED TO LISTING FILE.' - case ('CONCENTRATION') + write (this%iout, '(4x,a,1x,a,1x,a)') trim(adjustl(this%text))// & + trim(adjustl(this%tsplab%depvartype))//'S WILL BE PRINTED TO LISTING & + &FILE.' + case ('CONCENTRATION', 'TEMPERATURE') call this%parser%GetStringCaps(keyword) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) @@ -1466,10 +1473,12 @@ subroutine apt_options(this, option, found) call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & form, access, 'REPLACE') write (this%iout, fmtaptbin) & - trim(adjustl(this%text)), 'CONCENTRATION', trim(fname), this%iconcout + trim(adjustl(this%text)), trim(adjustl(this%tsplab%depvartype)), & + trim(fname), this%iconcout else - call store_error('OPTIONAL CONCENTRATION KEYWORD MUST & - &BE FOLLOWED BY FILEOUT') + write (errmsg, "('OPTIONAL', 1x, a, 1x, 'KEYWORD MUST & + &BE FOLLOWED BY FILEOUT')") this%tsplab%depvartype + call store_error(errmsg) end if case ('BUDGET') call this%parser%GetStringCaps(keyword) @@ -1790,7 +1799,7 @@ subroutine apt_read_initial_attr(this) ! ------------------------------------------------------------------------------ ! - ! -- initialize xnewpak and set lake concentration + ! -- initialize xnewpak and set lake concentration (or temperature) ! -- todo: this should be a time series? do n = 1, this%ncv this%xnewpak(n) = this%strt(n) @@ -1839,8 +1848,8 @@ end subroutine apt_read_initial_attr subroutine apt_solve(this) ! ****************************************************************************** -! apt_solve -- explicit solve for concentration in features, which is an -! alternative to the iterative implicit solve +! apt_solve -- explicit solve for concentration (or temperature) in features, +! which is an alternative to the iterative implicit solve ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -1884,7 +1893,7 @@ subroutine apt_solve(this) end if ! ! -- go through each gwf connection and accumulate - ! total mass in dbuff mass + ! total mass (or energy) in dbuff mass do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) this%hcof(j) = DZERO @@ -1903,7 +1912,7 @@ subroutine apt_solve(this) end do ! ! -- go through each lak-lak connection and accumulate - ! total mass in dbuff mass + ! total mass (or energy) in dbuff mass if (this%idxbudfjf /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist call this%apt_fjf_term(j, n1, n2, rrate) @@ -1912,7 +1921,7 @@ subroutine apt_solve(this) end do end if ! - ! -- calulate the feature concentration + ! -- calulate the feature concentration/temperature do n = 1, this%ncv call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) ! @@ -1953,7 +1962,8 @@ end subroutine pak_solve subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) ! ****************************************************************************** -! apt_accumulate_ccterm -- Accumulate constant concentration terms for budget. +! apt_accumulate_ccterm -- Accumulate constant concentration (or temperature) +! terms for budget. ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -2106,6 +2116,20 @@ function pak_get_nbudterms(this) result(nbudterms) terminate=.TRUE.) nbudterms = 0 end function pak_get_nbudterms + + function padl(str, width) result(res) + ! -- local + character(len=*), intent(in) :: str + integer, intent(in) :: width + ! -- return + character(len=max(len_trim(str), width)) :: res +! ------------------------------------------------------------------------------ + res = str + res = adjustr(res) + ! + ! -- return + return + end function subroutine apt_setup_budobj(this) ! ****************************************************************************** @@ -2211,7 +2235,8 @@ subroutine apt_setup_budobj(this) idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudsto)%maxlist naux = 1 - auxtxt(1) = ' MASS' + write(text, '(a)') padl(this%tsplab%depvarunit, 16) + auxtxt(1) = text ! ' MASS' or ' ENERGY' call this%budobj%budterm(idx)%initialize(text, & this%name_model, & this%packName, & @@ -2343,8 +2368,8 @@ subroutine apt_fill_budobj(this, x) ! -- initialize counter idx = 0 ! - ! -- initialize ccterm, which is used to sum up all mass flows - ! into a constant concentration cell + ! -- initialize ccterm, which is used to sum up all mass (or energy) flows + ! into a constant concentration (or temperature) cell ccratin = DZERO ccratout = DZERO do n1 = 1, this%ncv @@ -2557,7 +2582,8 @@ end subroutine apt_fjf_term subroutine apt_copy2flowp(this) ! ****************************************************************************** -! apt_copy2flowp -- copy concentrations into flow package aux variable +! apt_copy2flowp -- copy concentrations (or temperatures) into flow package +! aux variable ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -2886,14 +2912,15 @@ subroutine apt_rp_obs(this) do i = 1, this%obs%npakobs obsrv => this%obs%pakobs(i)%obsrv select case (obsrv%ObsTypeId) - case ('CONCENTRATION') + case ('CONCENTRATION', 'TEMPERATURE') call this%rp_obs_byfeature(obsrv) ! ! -- catch non-cumulative observation assigned to observation defined ! by a boundname that is assigned to more than one element if (obsrv%indxbnds_count > 1) then - write (errmsg, '(a, a, a)') & - 'CONCENTRATION for observation', trim(adjustl(obsrv%Name)), & + write (errmsg, '(a, a, a, a)') & + trim(adjustl(this%tsplab%depvartype))// & + ' for observation', trim(adjustl(obsrv%Name)), & ' must be assigned to a feature with a unique boundname.' call store_error(errmsg) end if @@ -2978,7 +3005,7 @@ subroutine apt_bd_obs(this) v = DNODATA jj = obsrv%indxbnds(j) select case (obsrv%ObsTypeId) - case ('CONCENTRATION') + case ('CONCENTRATION', 'TEMPERATURE') if (this%iboundpak(jj) /= 0) then v = this%xnewpak(jj) end if @@ -3194,7 +3221,8 @@ subroutine apt_setup_tableobj(this) ! -- set up table title title = trim(adjustl(this%text))//' PACKAGE ('// & trim(adjustl(this%packName))// & - ') CONCENTRATION FOR EACH CONTROL VOLUME' + ') '//trim(adjustl(this%tsplab%depvartype))// & + &' FOR EACH CONTROL VOLUME' ! ! -- set up dv tableobj call table_cr(this%dvtab, this%packName, title) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index d0bea6f5ad3..aceda805981 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -85,8 +85,7 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ncolbnd = 1 packobj%iscloc = 1 ! - ! -- Store pointer to labels associated with the current model so that the - ! package has access to the assigned labels + ! -- Give package access to the assigned labels based on dependent variable packobj%tsplab => tsplab ! ! -- return @@ -346,16 +345,21 @@ subroutine cnc_cq(this, x, flowja, iadv) return end subroutine cnc_cq + !> @brief Add package ratin/ratout to model budget + !< subroutine cnc_bd(this, model_budget) - ! -- add package ratin/ratout to model budget + ! -- modules use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator + ! -- dummy class(TspCncType) :: this type(BudgetType), intent(inout) :: model_budget + ! -- local real(DP) :: ratin real(DP) :: ratout real(DP) :: dum integer(I4B) :: isuppress_output +! ------------------------------------------------------------------------------ isuppress_output = 0 call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratecncout(1:this%nbound), ratout, dum) diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index e4988b90970..78b151c62b4 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -12,6 +12,7 @@ module TspFmiModule use HeadFileReaderModule, only: HeadFileReaderType use PackageBudgetModule, only: PackageBudgetType use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr_bfr + use TspLabelsModule, only: TspLabelsType implicit none private @@ -95,7 +96,7 @@ module TspFmiModule contains - subroutine fmi_cr(fmiobj, name_model, inunit, iout) + subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) ! ****************************************************************************** ! fmi_cr -- Create a new FMI object ! ****************************************************************************** @@ -107,6 +108,7 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout) character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout + type(TspLabelsType), pointer, intent(in) :: tsplab ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -129,6 +131,9 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout) ! -- Initialize block parser call fmiobj%parser%Initialize(fmiobj%inunit, fmiobj%iout) ! + ! -- Give package access to the assigned labels based on dependent variable + fmiobj%tsplab => tsplab + ! ! -- Return return end subroutine fmi_cr @@ -283,12 +288,6 @@ subroutine fmi_ad(this, cnew) integer(I4B) :: ipos real(DP) :: crewet, tflow, flownm character(len=15) :: nodestr - character(len=*), parameter :: fmtdry = & - &"(/1X,'WARNING: DRY CELL ENCOUNTERED AT ',a,'; RESET AS INACTIVE & - &WITH DRY CONCENTRATION = ', G13.5)" - character(len=*), parameter :: fmtrewet = & - &"(/1X,'DRY CELL REACTIVATED AT ', a,& - &' WITH STARTING CONCENTRATION =',G13.5)" ! ------------------------------------------------------------------------------ ! ! -- Set flag to indicated that flows are being updated. For the case where @@ -336,7 +335,10 @@ subroutine fmi_ad(this, cnew) this%ibound(n) = 0 cnew(n) = DHDRY call this%dis%noder_to_string(n, nodestr) - write (this%iout, fmtdry) trim(nodestr), DHDRY + write (this%iout, '(/1x,a,1x,a,a,1x,a,1x,a,1x,G13.5)') & + 'WARNING: DRY CELL ENCOUNTERED AT', trim(nodestr), '; RESET AS & + &INACTIVE WITH DRY', trim(adjustl(this%tsplab%depvartype)), & + '=', DHDRY end if end if ! @@ -344,7 +346,7 @@ subroutine fmi_ad(this, cnew) if (cnew(n) == DHDRY) then if (this%gwfhead(n) /= DHDRY) then ! - ! -- obtain weighted concentration + ! -- obtain weighted concentration/temperature crewet = DZERO tflow = DZERO do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 @@ -367,7 +369,9 @@ subroutine fmi_ad(this, cnew) this%ibound(n) = 1 cnew(n) = crewet call this%dis%noder_to_string(n, nodestr) - write (this%iout, fmtrewet) trim(nodestr), crewet + write (this%iout, '(/1x,a,1x,a,1x,a,1x,a,1x,a,1x,G13.5)') & + 'DRY CELL REACTIVATED AT', trim(nodestr), 'WITH STARTING', & + trim(adjustl(this%tsplab%depvartype)), '=', crewet end if end if end do From e9f049d4664c20a5e9e490feb32e916ab5838d3e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 3 Jan 2023 10:31:29 -0800 Subject: [PATCH 062/212] Some labeling touch-up --- src/Model/GroundWaterEnergy/gwe1.f90 | 12 +++++++----- src/Model/GroundWaterTransport/gwt1.f90 | 4 ++-- src/Model/GroundWaterTransport/tsp1ic1.f90 | 10 ++++++++-- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 70ad2d9cada..d708d85009d 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -240,12 +240,13 @@ subroutine gwe_cr(filename, id, modelname) call budget_cr(this%budget, this%name) ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout) + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + this%tsplab) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) @@ -411,7 +412,8 @@ subroutine gwe_ar(this) if (this%inmvt > 0) call this%mvt%mvt_ar() if (this%inic > 0) call this%ic%ic_ar(this%x) if (this%inmst > 0) call this%mst%mst_ar(this%dis, this%ibound) - if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound) + if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound, & + this%mst%cpw, this%mst%rhow) if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity, & this%mst%cpw, this%mst%rhow) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) @@ -428,7 +430,7 @@ subroutine gwe_ar(this) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & - this%xold, this%flowja) + this%xold, this%flowja, this%mst%cpw, this%mst%rhow) ! -- Read and allocate package call packobj%bnd_ar() end do diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index ad36dc064fd..0a1b956e9e6 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -245,8 +245,8 @@ subroutine gwt_cr(filename, id, modelname) call budget_cr(this%budget, this%name) ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout) + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) diff --git a/src/Model/GroundWaterTransport/tsp1ic1.f90 b/src/Model/GroundWaterTransport/tsp1ic1.f90 index 8875d2f16e6..e732d59919a 100644 --- a/src/Model/GroundWaterTransport/tsp1ic1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ic1.f90 @@ -4,6 +4,7 @@ module TspIcModule use GwfIcModule, only: GwfIcType use BlockParserModule, only: BlockParserType use BaseDisModule, only: DisBaseType + use TspLabelsModule, only: TspLabelsType implicit none private @@ -18,7 +19,7 @@ module TspIcModule contains - subroutine ic_cr(ic, name_model, inunit, iout, dis) + subroutine ic_cr(ic, name_model, inunit, iout, dis, tsplab) ! ****************************************************************************** ! ic_cr -- Create a new initial conditions object ! ****************************************************************************** @@ -27,6 +28,7 @@ subroutine ic_cr(ic, name_model, inunit, iout, dis) ! ------------------------------------------------------------------------------ ! -- dummy type(TspIcType), pointer :: ic + type(TspLabelsType), pointer, intent(in) :: tsplab character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout @@ -48,6 +50,9 @@ subroutine ic_cr(ic, name_model, inunit, iout, dis) ! -- set pointers ic%dis => dis ! + ! -- Give package access to the assigned labelsd based on dependent variable + ic%tsplab => tsplab + ! ! -- Initialize block parser call ic%parser%Initialize(ic%inunit, ic%iout) ! @@ -77,7 +82,8 @@ subroutine read_data(this) ! ------------------------------------------------------------------------------ ! ! -- Setup the label - aname(1) = 'INITIAL CONCENTRATION' + write(aname(1), '(a,1x,a)') 'INITIAL', trim(adjustl(this%tsplab%depvartype)) + !aname(1) = , CONCENTRATION' ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) From bb73dc2661c71ed06c7bd5353b263e95ce707ba7 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 3 Jan 2023 10:34:39 -0800 Subject: [PATCH 063/212] minor touch-up --- autotest/test_gwe_stallman.py | 1 + 1 file changed, 1 insertion(+) diff --git a/autotest/test_gwe_stallman.py b/autotest/test_gwe_stallman.py index 650fbf8163a..cfb7eb46c7e 100644 --- a/autotest/test_gwe_stallman.py +++ b/autotest/test_gwe_stallman.py @@ -186,6 +186,7 @@ def build_model(idx, dir): # Instantiating MODFLOW 6 discretization package flopy.mf6.ModflowGwfdis( gwf, + nogrb=True, length_units=length_units, nlay=nlay, nrow=nrow, From 8646ba73644d206f3894a3fbb11752c51c2fef6e Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 3 Jan 2023 10:36:30 -0800 Subject: [PATCH 064/212] more labeling touch-up --- src/Model/Connection/GweInterfaceModel.f90 | 2 +- src/Model/Connection/GwtInterfaceModel.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 573fcafd159..d97e5e713f9 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -81,7 +81,7 @@ subroutine gweifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) call tsp_obs_cr(this%obs, inobs) diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 77c7a744d35..1e6ae99c030 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -81,7 +81,7 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) call tsp_obs_cr(this%obs, inobs) From b2a16b798844e9b74534a768adb96491eb2ed3cc Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 16:02:17 -0800 Subject: [PATCH 065/212] resolving GHB conflict after merging codes --- src/Model/GroundWaterFlow/gwf3ghb8.f90 | 27 +++++++------------------- 1 file changed, 7 insertions(+), 20 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3ghb8.f90 b/src/Model/GroundWaterFlow/gwf3ghb8.f90 index 15cc177d587..b6f1f1dd25e 100644 --- a/src/Model/GroundWaterFlow/gwf3ghb8.f90 +++ b/src/Model/GroundWaterFlow/gwf3ghb8.f90 @@ -1,12 +1,12 @@ module ghbmodule - use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME, LENMEMPATH, & - LENVARNAME, LENMEMSEPARATOR - use MemoryHelperModule, only: create_mem_path, split_mem_address + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME + use MemoryHelperModule, only: create_mem_path use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList + use MatrixModule ! implicit none ! @@ -16,10 +16,8 @@ module ghbmodule ! character(len=LENFTYPE) :: ftype = 'GHB' character(len=LENPACKAGENAME) :: text = ' GHB' - character(len=LENMEMSEPARATOR), parameter :: memPathSeparator = '/' ! type, extends(BndType) :: GhbType - contains procedure :: bnd_options => ghb_options procedure :: bnd_ck => ghb_ck @@ -54,10 +52,6 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) character(len=*), intent(in) :: pakname ! -- local type(GhbType), pointer :: ghbobj - character(len=LENMEMPATH) :: vscpath !< if vsc exist, this is path name - character(len=LENMEMPATH) :: locmempath !< the memory path for the model - character(len=LENVARNAME) :: locvarname !< the package name to check on - logical(LGP) :: vscexists !< flag will be true if vsc is active ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables @@ -82,13 +76,6 @@ subroutine ghb_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%iscloc = 2 packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! - ! -- check if vsc package exists and set flag if so - vscpath = trim(namemodel)//memPathSeparator//'VSC' - call split_mem_address(vscpath, locmempath, locvarname, vscexists) - if (vscexists) then - packobj%ivsc = 1 - end if - ! ! -- return return end subroutine ghb_create @@ -209,7 +196,7 @@ subroutine ghb_cf(this, reset_mover) return end subroutine ghb_cf - subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) + subroutine ghb_fc(this, rhs, ia, idxglo, matrix_sln) ! ************************************************************************** ! ghb_fc -- Copy rhs and hcof into solution rhs and amat ! ************************************************************************** @@ -221,7 +208,7 @@ subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: i, n, ipos real(DP) :: cond, bhead, qghb @@ -237,7 +224,7 @@ subroutine ghb_fc(this, rhs, ia, idxglo, amatsln) n = this%nodelist(i) rhs(n) = rhs(n) + this%rhs(i) ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + call matrix_sln%add_value_pos(idxglo(ipos), this%hcof(i)) ! ! -- If mover is active and this boundary is discharging, ! store available water (as positive value). From eb7635c831353acee23b9065efa7c9e9ade574ca Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 16:10:45 -0800 Subject: [PATCH 066/212] manual resolution of conflicts in LAK after updating GWE branch --- src/Model/GroundWaterFlow/gwf3lak8.f90 | 69 ++++++++++++++++++++++---- 1 file changed, 60 insertions(+), 9 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index cfb921248fa..9a2c3a7df8c 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -29,6 +29,7 @@ module LakModule use BlockParserModule, only: BlockParserType use BaseDisModule, only: DisBaseType use SimVariablesModule, only: errmsg + use MatrixModule ! implicit none ! @@ -3889,7 +3890,7 @@ subroutine lak_cf(this, reset_mover) return end subroutine lak_cf - subroutine lak_fc(this, rhs, ia, idxglo, amatsln) + subroutine lak_fc(this, rhs, ia, idxglo, matrix_sln) ! ************************************************************************** ! lak_fc -- Copy rhs and hcof into solution rhs and amat ! ************************************************************************** @@ -3901,7 +3902,7 @@ subroutine lak_fc(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j, n integer(I4B) :: igwfnode @@ -3922,7 +3923,7 @@ subroutine lak_fc(this, rhs, ia, idxglo, amatsln) igwfnode = this%cellid(j) if (this%ibound(igwfnode) < 1) cycle ipossymd = idxglo(ia(igwfnode)) - amatsln(ipossymd) = amatsln(ipossymd) + this%hcof(j) + call matrix_sln%add_value_pos(ipossymd, this%hcof(j)) rhs(igwfnode) = rhs(igwfnode) + this%rhs(j) end do end do @@ -3931,7 +3932,7 @@ subroutine lak_fc(this, rhs, ia, idxglo, amatsln) return end subroutine lak_fc - subroutine lak_fn(this, rhs, ia, idxglo, amatsln) + subroutine lak_fn(this, rhs, ia, idxglo, matrix_sln) ! ************************************************************************** ! lak_fn -- Fill newton terms ! ************************************************************************** @@ -3943,7 +3944,7 @@ subroutine lak_fn(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j, n integer(I4B) :: ipos @@ -3986,7 +3987,7 @@ subroutine lak_fn(this, rhs, ia, idxglo, amatsln) drterm = (q1 - q) / this%delh ! -- add terms to convert conductance formulation into ! newton-raphson formulation - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + drterm - this%hcof(j) + call matrix_sln%add_value_pos(idxglo(ipos), drterm - this%hcof(j)) rhs(igwfnode) = rhs(igwfnode) - rterm + drterm * head end if end if @@ -4023,9 +4024,13 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) integer(I4B) :: locdhmax integer(I4B) :: locdgwfmax integer(I4B) :: locdqoutmax + integer(I4B) :: locdqfrommvrmax integer(I4B) :: ntabrows integer(I4B) :: ntabcols integer(I4B) :: n + real(DP) :: q + real(DP) :: q0 + real(DP) :: qtolfact real(DP) :: area real(DP) :: gwf0 real(DP) :: gwf @@ -4044,6 +4049,8 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) real(DP) :: dhmax real(DP) :: dgwfmax real(DP) :: dqoutmax + real(DP) :: dqfrommvr + real(DP) :: dqfrommvrmax ! format ! -------------------------------------------------------------------------- ! @@ -4053,9 +4060,11 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) locdhmax = 0 locdgwfmax = 0 locdqoutmax = 0 + locdqfrommvrmax = 0 dhmax = DZERO dgwfmax = DZERO dqoutmax = DZERO + dqfrommvrmax = DZERO ! ! -- if not saving package convergence data on check convergence if ! the model is considered converged @@ -4076,6 +4085,9 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) if (this%noutlets > 0) then ntabcols = ntabcols + 2 end if + if (this%imover == 1) then + ntabcols = ntabcols + 2 + end if ! ! -- setup table call table_cr(this%pakcsvtab, this%packName, '') @@ -4108,6 +4120,12 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) tag = 'dqoutmax_loc' call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) end if + if (this%imover == 1) then + tag = 'dqfrommvrmax' + call this%pakcsvtab%initialize_column(tag, 15, alignment=TABLEFT) + tag = 'dqfrommvrmax_loc' + call this%pakcsvtab%initialize_column(tag, 16, alignment=TABLEFT) + end if end if end if ! @@ -4126,12 +4144,15 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! -- calculate surface area call this%lak_calculate_sarea(n, hlak, area) ! + ! -- set the Q to length factor + qtolfact = delt / area + ! ! -- change in gwf exchange dgwf = DZERO if (area > DZERO) then gwf0 = this%qgwf0(n) call this%lak_calculate_exchange(n, hlak, gwf) - dgwf = (gwf0 - gwf) * delt / area + dgwf = (gwf0 - gwf) * qtolfact end if ! ! -- change in outflows @@ -4142,10 +4163,18 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) call this%lak_calculate_outlet_outflow(n, hlak0, inf, qout0) call this%lak_calculate_available(n, hlak, inf, ra, ro, qinf, ex) call this%lak_calculate_outlet_outflow(n, hlak, inf, qout) - dqout = (qout0 - qout) * delt / area + dqout = (qout0 - qout) * qtolfact end if end if ! + ! -- q from mvr + dqfrommvr = DZERO + if (this%imover == 1) then + q = this%pakmvrobj%get_qfrommvr(n) + q0 = this%pakmvrobj%get_qfrommvr0(n) + dqfrommvr = qtolfact * (q0 - q) + end if + ! ! -- evaluate magnitude of differences if (n == 1) then locdhmax = n @@ -4154,6 +4183,8 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) dgwfmax = dgwf locdqoutmax = n dqoutmax = dqout + dqfrommvrmax = dqfrommvr + locdqfrommvrmax = n else if (abs(dh) > abs(dhmax)) then locdhmax = n @@ -4167,6 +4198,10 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) locdqoutmax = n dqoutmax = dqout end if + if (ABS(dqfrommvr) > abs(dqfrommvrmax)) then + dqfrommvrmax = dqfrommvr + locdqfrommvrmax = n + end if end if end do final_check ! @@ -4194,6 +4229,14 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) cpak = trim(cloc) end if end if + if (this%imover == 1) then + if (ABS(dqfrommvrmax) > abs(dpak)) then + ipak = locdqfrommvrmax + dpak = dqfrommvrmax + write (cloc, "(a,'-',a)") trim(this%packName), 'qfrommvr' + cpak = trim(cloc) + end if + end if ! ! -- write convergence data to package csv if (this%ipakcsv /= 0) then @@ -4212,6 +4255,10 @@ subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) call this%pakcsvtab%add_term(dqoutmax) call this%pakcsvtab%add_term(locdqoutmax) end if + if (this%imover == 1) then + call this%pakcsvtab%add_term(dqfrommvrmax) + call this%pakcsvtab%add_term(locdqfrommvrmax) + end if ! ! -- finalize the package csv if (iend == 1) then @@ -4649,7 +4696,8 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja) + subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja, & + cpw, rhow, latheatvap) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package ! has access to these things. @@ -4663,6 +4711,9 @@ subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja) real(DP), dimension(:), pointer, contiguous :: xnew real(DP), dimension(:), pointer, contiguous :: xold real(DP), dimension(:), pointer, contiguous :: flowja + real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (for GWE model type) + real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (for GWE model type) + real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (used by GWE model type, not here) ! -- local ! ------------------------------------------------------------------------------ ! From 72fe5062bcabaf94c1e200c5df831cf2ab0a2917 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 16:16:31 -0800 Subject: [PATCH 067/212] manual resolution of conflicts in MAW after updating GWE branch --- src/Model/GroundWaterFlow/gwf3maw8.f90 | 81 ++++++++++++-------------- 1 file changed, 37 insertions(+), 44 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index 295b84d8472..d71b15ac67b 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -28,6 +28,7 @@ module MawModule use MemoryManagerModule, only: mem_allocate, mem_reallocate, mem_setptr, & mem_deallocate use MemoryHelperModule, only: create_mem_path + use MatrixModule ! implicit none @@ -1681,7 +1682,7 @@ subroutine maw_ac(this, moffset, sparse) return end subroutine maw_ac - subroutine maw_mc(this, moffset, iasln, jasln) + subroutine maw_mc(this, moffset, matrix_sln) ! ****************************************************************************** ! bnd_ac -- map package connection to matrix ! ****************************************************************************** @@ -1693,13 +1694,11 @@ subroutine maw_mc(this, moffset, iasln, jasln) ! -- dummy class(MawType), intent(inout) :: this integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: n integer(I4B) :: j integer(I4B) :: ii - integer(I4B) :: jj integer(I4B) :: iglo integer(I4B) :: jglo integer(I4B) :: ipos @@ -1728,13 +1727,8 @@ subroutine maw_mc(this, moffset, iasln, jasln) do ii = 1, this%ngwfnodes(n) j = this%get_gwfnode(n, ii) jglo = j + moffset - searchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if (jglo == jasln(jj)) then - this%idxdglo(ipos) = iasln(iglo) - this%idxoffdglo(ipos) = jj - exit searchloop - end if - end do searchloop + this%idxdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) ipos = ipos + 1 end do end do @@ -1744,13 +1738,8 @@ subroutine maw_mc(this, moffset, iasln, jasln) do ii = 1, this%ngwfnodes(n) iglo = this%get_gwfnode(n, ii) + moffset jglo = moffset + this%dis%nodes + this%ioffset + n - symsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if (jglo == jasln(jj)) then - this%idxsymdglo(ipos) = iasln(iglo) - this%idxsymoffdglo(ipos) = jj - exit symsearchloop - end if - end do symsearchloop + this%idxsymdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxsymoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) ipos = ipos + 1 end do end do @@ -2317,7 +2306,7 @@ subroutine maw_cf(this, reset_mover) return end subroutine maw_cf - subroutine maw_fc(this, rhs, ia, idxglo, amatsln) + subroutine maw_fc(this, rhs, ia, idxglo, matrix_sln) ! ****************************************************************************** ! maw_fc -- Copy rhs and hcof into solution rhs and amat ! ****************************************************************************** @@ -2331,7 +2320,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j integer(I4B) :: n @@ -2402,7 +2391,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) this%xsto(n) = bt end if this%fwcondsim(n) = cfw - amatsln(iposd) = amatsln(iposd) - cfw + call matrix_sln%add_value_pos(iposd, -cfw) rhs(iloc) = rhs(iloc) - cfw * bt ratefw = cfw * (bt - hmaw) end if @@ -2411,7 +2400,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) ! -- add maw storage changes if (this%imawiss /= 1) then if (this%ifwdischarge(n) /= 1) then - amatsln(iposd) = amatsln(iposd) - (this%area(n) / delt) + call matrix_sln%add_value_pos(iposd, -this%area(n) / delt) rhs(iloc) = rhs(iloc) - (this%area(n) * this%xoldsto(n) / delt) else cterm = this%xoldsto(n) - this%fwelev(n) @@ -2450,8 +2439,8 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) ! -- add to maw row iposd = this%idxdglo(idx) iposoffd = this%idxoffdglo(idx) - amatsln(iposd) = amatsln(iposd) - term - amatsln(iposoffd) = term + call matrix_sln%add_value_pos(iposd, -term) + call matrix_sln%set_value_pos(iposoffd, term) ! ! -- add correction term rhs(iloc) = rhs(iloc) - cterm @@ -2461,8 +2450,8 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) isymloc = ia(isymnode) ipossymd = this%idxsymdglo(idx) ipossymoffd = this%idxsymoffdglo(idx) - amatsln(ipossymd) = amatsln(ipossymd) - term - amatsln(ipossymoffd) = term + call matrix_sln%add_value_pos(ipossymd, -term) + call matrix_sln%set_value_pos(ipossymoffd, term) ! ! -- add correction term to gwf row rhs(isymnode) = rhs(isymnode) + cterm @@ -2477,7 +2466,7 @@ subroutine maw_fc(this, rhs, ia, idxglo, amatsln) return end subroutine maw_fc - subroutine maw_fn(this, rhs, ia, idxglo, amatsln) + subroutine maw_fn(this, rhs, ia, idxglo, matrix_sln) ! ************************************************************************** ! maw_fn -- Fill newton terms ! ************************************************************************** @@ -2490,7 +2479,7 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j integer(I4B) :: n @@ -2542,7 +2531,7 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) drterm = (rate2 - rate) / DEM4 ! !-- fill amat and rhs with newton-raphson terms - amatsln(iposd) = amatsln(iposd) + drterm + call matrix_sln%add_value_pos(iposd, drterm) rhs(iloc) = rhs(iloc) + drterm * hmaw ! ! -- add flowing well @@ -2566,8 +2555,8 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) drterm = -(cfw + this%fwcond(n) * derv * (hmaw - bt)) ! ! -- fill amat and rhs with newton-raphson terms - amatsln(iposd) = amatsln(iposd) - & - this%fwcond(n) * derv * (hmaw - bt) + call matrix_sln%add_value_pos(iposd, & + -this%fwcond(n) * derv * (hmaw - bt)) rhs(iloc) = rhs(iloc) - rterm + drterm * hmaw end if end if @@ -2602,17 +2591,17 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) rhs(iloc) = rhs(iloc) + rhsterm rhs(isymnode) = rhs(isymnode) - rhsterm if (this%iboundpak(n) > 0) then - amatsln(iposd) = amatsln(iposd) + term - amatsln(iposoffd) = amatsln(iposoffd) + term2 + call matrix_sln%add_value_pos(iposd, term) + call matrix_sln%add_value_pos(iposoffd, term2) end if - amatsln(ipossymd) = amatsln(ipossymd) - term2 - amatsln(ipossymoffd) = amatsln(ipossymoffd) - term + call matrix_sln%add_value_pos(ipossymd, -term2) + call matrix_sln%add_value_pos(ipossymoffd, -term) else rhs(iloc) = rhs(iloc) + term * hmaw rhs(isymnode) = rhs(isymnode) - term * hmaw - amatsln(iposd) = amatsln(iposd) + term + call matrix_sln%add_value_pos(iposd, term) if (this%ibound(igwfnode) > 0) then - amatsln(ipossymoffd) = amatsln(ipossymoffd) - term + call matrix_sln%add_value_pos(ipossymoffd, -term) end if end if ! @@ -2623,18 +2612,18 @@ subroutine maw_fn(this, rhs, ia, idxglo, amatsln) rhs(iloc) = rhs(iloc) + rhsterm rhs(isymnode) = rhs(isymnode) - rhsterm if (this%iboundpak(n) > 0) then - amatsln(iposd) = amatsln(iposd) + term2 - amatsln(iposoffd) = amatsln(iposoffd) + term + call matrix_sln%add_value_pos(iposd, term2) + call matrix_sln%add_value_pos(iposoffd, term) end if - amatsln(ipossymd) = amatsln(ipossymd) - term - amatsln(ipossymoffd) = amatsln(ipossymoffd) - term2 + call matrix_sln%add_value_pos(ipossymd, -term) + call matrix_sln%add_value_pos(ipossymoffd, -term2) else rhs(iloc) = rhs(iloc) + term * hgwf rhs(isymnode) = rhs(isymnode) - term * hgwf if (this%iboundpak(n) > 0) then - amatsln(iposoffd) = amatsln(iposoffd) + term + call matrix_sln%add_value_pos(iposoffd, term) end if - amatsln(ipossymd) = amatsln(ipossymd) - term + call matrix_sln%add_value_pos(ipossymd, -term) end if end if end if @@ -3086,7 +3075,8 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) + subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja, & + cpw, rhow, latheatvap) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package ! has access to these things. @@ -3103,6 +3093,9 @@ subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) real(DP), dimension(:), pointer, contiguous :: xnew real(DP), dimension(:), pointer, contiguous :: xold real(DP), dimension(:), pointer, contiguous :: flowja + real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (used by GWE model type, not here) + real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (used by GWE model type, not here) + real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (used by GWE model type, not here) ! -- local integer(I4B) :: n integer(I4B) :: istart, iend From a6a36ee6f36bac62f48224b4ece20d4210678d5f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 16:30:11 -0800 Subject: [PATCH 068/212] manual resolution of conflicts in GWT.f90 after updating GWE branch --- src/Model/GroundWaterTransport/gwt1.f90 | 79 ++++++++++++++++++------- 1 file changed, 59 insertions(+), 20 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 0a1b956e9e6..9b1758681ff 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -25,7 +25,7 @@ module GwtModule use GwtDspModule, only: GwtDspType use GwtMstModule, only: GwtMstType use BudgetModule, only: BudgetType - use TspLabelsModule, only: TspLabelsType + use MatrixModule implicit none @@ -83,7 +83,7 @@ module GwtModule procedure, private :: gwt_ot_dv procedure, private :: gwt_ot_bdsummary procedure, private :: gwt_ot_obs - + procedure :: load_input_context => gwt_load_input_context end type GwtModelType ! -- Module variables constant for simulation @@ -234,16 +234,22 @@ subroutine gwt_cr(filename, id, modelname) ! ! -- Create discretization object if (indis6 > 0) then + call this%load_input_context('DIS6', this%name, 'DIS', indis, this%iout) call dis_cr(this%dis, this%name, indis, this%iout) elseif (indisu6 > 0) then + call this%load_input_context('DISU6', this%name, 'DISU', indis, this%iout) call disu_cr(this%dis, this%name, indis, this%iout) elseif (indisv6 > 0) then + call this%load_input_context('DISV6', this%name, 'DISV', indis, this%iout) call disv_cr(this%dis, this%name, indis, this%iout) end if ! ! -- Create utility objects call budget_cr(this%budget, this%name) ! + ! -- Load input context for currently supported packages + call this%load_input_context('DSP6', this%name, 'DSP', this%indsp, this%iout) + ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) @@ -302,7 +308,8 @@ subroutine gwt_df(this) if (this%indsp > 0) call this%dsp%dsp_df(this%dis) if (this%inssm > 0) call this%ssm%ssm_df() call this%oc%oc_df() - call this%budget%budget_df(niunit, 'MASS', 'M') + call this%budget%budget_df(niunit, this%tsplab%depvarunit, & + this%tsplab%depvarunitabbrev) ! ! -- Assign or point model members to dis members this%neq = this%dis%nodes @@ -360,7 +367,7 @@ subroutine gwt_ac(this, sparse) return end subroutine gwt_ac - subroutine gwt_mc(this, iasln, jasln) + subroutine gwt_mc(this, matrix_sln) ! ****************************************************************************** ! gwt_mc -- Map the positions of this models connections in the ! numerical solution coefficient matrix. @@ -370,8 +377,7 @@ subroutine gwt_mc(this, iasln, jasln) ! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln + class(MatrixBaseType), pointer :: matrix_sln !< global system matrix ! -- local class(BndType), pointer :: packobj integer(I4B) :: ip @@ -379,13 +385,13 @@ subroutine gwt_mc(this, iasln, jasln) ! ! -- Find the position of each connection in the global ia, ja structure ! and store them in idxglo. - call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln) - if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, iasln, jasln) + call this%dis%dis_mc(this%moffset, this%idxglo, matrix_sln) + if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, matrix_sln) ! ! -- Map any package connections do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_mc(this%moffset, iasln, jasln) + call packobj%bnd_mc(this%moffset, matrix_sln) end do ! ! -- return @@ -564,7 +570,7 @@ subroutine gwt_cf(this, kiter) return end subroutine gwt_cf - subroutine gwt_fc(this, kiter, amatsln, njasln, inwtflag) + subroutine gwt_fc(this, kiter, matrix_sln, inwtflag) ! ****************************************************************************** ! gwt_fc -- GroundWater Transport Model fill coefficients ! ****************************************************************************** @@ -575,8 +581,7 @@ subroutine gwt_fc(this, kiter, amatsln, njasln, inwtflag) ! -- dummy class(GwtModelType) :: this integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: njasln - real(DP), dimension(njasln), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in) :: inwtflag ! -- local class(BndType), pointer :: packobj @@ -584,31 +589,31 @@ subroutine gwt_fc(this, kiter, amatsln, njasln, inwtflag) ! ------------------------------------------------------------------------------ ! ! -- call fc routines - call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, njasln, & - amatsln, this%idxglo, this%rhs) + call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, matrix_sln, & + this%idxglo, this%rhs) if (this%inmvt > 0) then call this%mvt%mvt_fc(this%x, this%x) end if if (this%inmst > 0) then - call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, njasln, & - amatsln, this%idxglo, this%x, this%rhs, kiter) + call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, matrix_sln, & + this%idxglo, this%x, this%rhs, kiter) end if if (this%inadv > 0) then - call this%adv%adv_fc(this%dis%nodes, amatsln, this%idxglo, this%x, & + call this%adv%adv_fc(this%dis%nodes, matrix_sln, this%idxglo, this%x, & this%rhs) end if if (this%indsp > 0) then - call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, njasln, amatsln, & + call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, matrix_sln, & this%idxglo, this%rhs, this%x) end if if (this%inssm > 0) then - call this%ssm%ssm_fc(amatsln, this%idxglo, this%rhs) + call this%ssm%ssm_fc(matrix_sln, this%idxglo, this%rhs) end if ! ! -- packages do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) + call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, matrix_sln) end do ! ! -- return @@ -1298,4 +1303,38 @@ function CastAsGwtModel(model) result(gwtmodel) end function CastAsGwtModel + !> @brief Load input context for supported package + !< + subroutine gwt_load_input_context(this, filtyp, modelname, pkgname, inunit, & + iout, ipaknum) + ! -- modules + use IdmMf6FileLoaderModule, only: input_load + ! -- dummy + class(GwtModelType) :: this + character(len=*), intent(in) :: filtyp + character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: pkgname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + integer(I4B), optional, intent(in) :: ipaknum + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- only load if there is a file to read + if (inunit <= 0) return + ! + ! -- Load model package input to input context + select case (filtyp) + case ('DSP6') + call input_load('DSP6', 'GWT', 'DSP', modelname, pkgname, inunit, iout) + case default + call this%NumericalModelType%load_input_context(filtyp, modelname, & + pkgname, inunit, iout, & + ipaknum) + end select + ! + ! -- return + return + end subroutine gwt_load_input_context + end module GwtModule From 05cc7f6b9dccce3df692361dbee0f003642b2785 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 16:56:10 -0800 Subject: [PATCH 069/212] manual resolution of conflicts in tsp1adv1.f90 after updating GWE branch (previously named gwt1adv1.f90) --- src/Model/GroundWaterTransport/tsp1adv1.f90 | 45 ++++++++++++++++----- 1 file changed, 36 insertions(+), 9 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1adv1.f90 b/src/Model/GroundWaterTransport/tsp1adv1.f90 index cf5e126c524..6752e03ed54 100644 --- a/src/Model/GroundWaterTransport/tsp1adv1.f90 +++ b/src/Model/GroundWaterTransport/tsp1adv1.f90 @@ -17,6 +17,8 @@ module TspAdvModule integer(I4B), pointer :: iadvwt => null() !< advection scheme (0 up, 1 central, 2 tvd) integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water + real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water contains @@ -98,7 +100,7 @@ subroutine adv_df(this, adv_options) end subroutine adv_df - subroutine adv_ar(this, dis, ibound) + subroutine adv_ar(this, dis, ibound, cpw, rhow) ! ****************************************************************************** ! adv_ar -- Allocate and Read ! ****************************************************************************** @@ -109,7 +111,9 @@ subroutine adv_ar(this, dis, ibound) ! -- dummy class(TspAdvType) :: this class(DisBaseType), pointer, intent(in) :: dis - integer(I4B), dimension(:), pointer, contiguous :: ibound + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ibound + real(DP), dimension(:), pointer, contiguous, optional, intent(in) :: cpw + real(DP), dimension(:), pointer, contiguous, optional, intent(in) :: rhow ! -- local ! -- formats ! ------------------------------------------------------------------------------ @@ -118,11 +122,15 @@ subroutine adv_ar(this, dis, ibound) this%dis => dis this%ibound => ibound ! + ! -- if part of a GWE simulation, need heat capacity(cpw) and density (rhow) + if (present(cpw)) this%cpw => cpw + if (present(rhow)) this%rhow => rhow + ! ! -- Return return end subroutine adv_ar - subroutine adv_fc(this, nodes, amatsln, idxglo, cnew, rhs) + subroutine adv_fc(this, nodes, matrix_sln, idxglo, cnew, rhs) ! ****************************************************************************** ! adv_fc -- Calculate coefficients and fill amat and rhs ! ****************************************************************************** @@ -133,7 +141,7 @@ subroutine adv_fc(this, nodes, amatsln, idxglo, cnew, rhs) ! -- dummy class(TspAdvType) :: this integer, intent(in) :: nodes - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in), dimension(:) :: idxglo real(DP), intent(in), dimension(:) :: cnew real(DP), dimension(:), intent(inout) :: rhs @@ -153,8 +161,8 @@ subroutine adv_fc(this, nodes, amatsln, idxglo, cnew, rhs) if (this%ibound(m) == 0) cycle qnm = this%fmi%gwfflowja(ipos) omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + qnm * (DONE - omega) - amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + qnm * omega + call matrix_sln%add_value_pos(idxglo(ipos), qnm * (DONE - omega)) + call matrix_sln%add_value_pos(idxglo(idiag), qnm * omega) end do end do ! @@ -224,10 +232,13 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) integer(I4B) :: ipos, isympos, iup, idn, i2up, j real(DP) :: qnm, qmax, qupj, elupdn, elup2up real(DP) :: smooth, cdiff, alimiter + real(DP) :: unitadjdn, unitadjup ! ------------------------------------------------------------------------------ ! ! -- intialize qtvd = DZERO + unitadjdn = DONE + unitadjup = DONE ! ! -- Find upstream node isympos = this%dis%con%jas(iposnm) @@ -267,7 +278,12 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) end if if (smooth > DZERO) then alimiter = DTWO * smooth / (DONE + smooth) - qtvd = DHALF * alimiter * qnm * (cnew(idn) - cnew(iup)) + if (associated(this%cpw).and.associated(this%rhow)) then + unitadjdn = this%cpw(idn) * this%rhow(idn) + unitadjup = this%cpw(iup) * this%rhow(iup) + end if + qtvd = DHALF * alimiter * qnm * (cnew(idn) * unitadjdn - & + cnew(iup) * unitadjup) end if end if ! @@ -291,7 +307,12 @@ subroutine adv_cq(this, cnew, flowja) integer(I4B) :: nodes integer(I4B) :: n, m, idiag, ipos real(DP) :: omega, qnm + real(DP) :: unitadjn, unitadjm ! ------------------------------------------------------------------------------ + ! + ! -- intialize + unitadjn = DONE + unitadjm = DONE ! ! -- Calculate advection and add to flowja. qnm is the volumetric flow ! rate and has dimensions of L^/T. @@ -304,8 +325,12 @@ subroutine adv_cq(this, cnew, flowja) if (this%ibound(m) == 0) cycle qnm = this%fmi%gwfflowja(ipos) omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) - flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & - qnm * (DONE - omega) * cnew(m) + if (associated(this%cpw).and.associated(this%rhow)) then + unitadjn = this%cpw(n) * this%rhow(n) + unitadjm = this%cpw(m) * this%rhow(m) + end if + flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) * unitadjn + & + qnm * (DONE - omega) * cnew(m) * unitadjm end do end do ! @@ -369,6 +394,8 @@ subroutine adv_da(this) ! ! -- nullify pointers this%ibound => null() + nullify(this%cpw) + nullify(this%rhow) ! ! -- Scalars call mem_deallocate(this%iadvwt) From 14682dee5ebea4c87be314bf902abd581f150f14 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 17:19:59 -0800 Subject: [PATCH 070/212] manual resolution of conflicts in tsp1apt1.f90 after updating GWE branch (previously named gwt1apt1.f90) --- src/Model/GroundWaterTransport/tsp1apt1.f90 | 143 ++++++++++++-------- 1 file changed, 88 insertions(+), 55 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 9658d5c402b..aa35b65d5d1 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -51,6 +51,7 @@ module TspAptModule use ObserveModule, only: ObserveType use InputOutputModule, only: extract_idnum_or_bndname use BaseDisModule, only: DisBaseType + use MatrixModule implicit none @@ -232,7 +233,7 @@ subroutine apt_ac(this, moffset, sparse) return end subroutine apt_ac - subroutine apt_mc(this, moffset, iasln, jasln) + subroutine apt_mc(this, moffset, matrix_sln) ! ****************************************************************************** ! apt_mc -- map package connection to matrix ! ****************************************************************************** @@ -243,10 +244,9 @@ subroutine apt_mc(this, moffset, iasln, jasln) ! -- dummy class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln + class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: n, j, jj, iglo, jglo + integer(I4B) :: n, j, iglo, jglo integer(I4B) :: ipos ! -- format ! ------------------------------------------------------------------------------ @@ -265,20 +265,15 @@ subroutine apt_mc(this, moffset, iasln, jasln) do n = 1, this%ncv this%idxlocnode(n) = this%dis%nodes + this%ioffset + n iglo = moffset + this%dis%nodes + this%ioffset + n - this%idxpakdiag(n) = iasln(iglo) + this%idxpakdiag(n) = matrix_sln%get_position_diag(iglo) end do do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) iglo = moffset + this%dis%nodes + this%ioffset + n jglo = j + moffset - searchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if (jglo == jasln(jj)) then - this%idxdglo(ipos) = iasln(iglo) - this%idxoffdglo(ipos) = jj - exit searchloop - end if - end do searchloop + this%idxdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) end do ! ! -- apt contributions to gwf portion of global matrix @@ -287,13 +282,8 @@ subroutine apt_mc(this, moffset, iasln, jasln) j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) iglo = j + moffset jglo = moffset + this%dis%nodes + this%ioffset + n - symsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if (jglo == jasln(jj)) then - this%idxsymdglo(ipos) = iasln(iglo) - this%idxsymoffdglo(ipos) = jj - exit symsearchloop - end if - end do symsearchloop + this%idxsymdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxsymoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) end do ! ! -- apt-apt contributions to gwf portion of global matrix @@ -303,13 +293,8 @@ subroutine apt_mc(this, moffset, iasln, jasln) j = this%flowbudptr%budterm(this%idxbudfjf)%id2(ipos) iglo = moffset + this%dis%nodes + this%ioffset + n jglo = moffset + this%dis%nodes + this%ioffset + j - fjfsearchloop: do jj = iasln(iglo), iasln(iglo + 1) - 1 - if (jglo == jasln(jj)) then - this%idxfjfdglo(ipos) = iasln(iglo) - this%idxfjfoffdglo(ipos) = jj - exit fjfsearchloop - end if - end do fjfsearchloop + this%idxfjfdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxfjfoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) end do end if end if @@ -759,7 +744,7 @@ subroutine apt_cf(this, reset_mover) return end subroutine apt_cf - subroutine apt_fc(this, rhs, ia, idxglo, amatsln) + subroutine apt_fc(this, rhs, ia, idxglo, matrix_sln) ! ****************************************************************************** ! apt_fc ! **************************************************************************** @@ -772,22 +757,22 @@ subroutine apt_fc(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local ! ------------------------------------------------------------------------------ ! ! -- Call fc depending on whether or not a matrix is expanded or not if (this%imatrows == 0) then - call this%apt_fc_nonexpanded(rhs, ia, idxglo, amatsln) + call this%apt_fc_nonexpanded(rhs, ia, idxglo, matrix_sln) else - call this%apt_fc_expanded(rhs, ia, idxglo, amatsln) + call this%apt_fc_expanded(rhs, ia, idxglo, matrix_sln) end if ! ! -- Return return end subroutine apt_fc - subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) + subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, matrix_sln) ! ****************************************************************************** ! apt_fc_nonexpanded -- formulate for the nonexpanded a matrix case in which ! feature concentrations (or temperatures) are solved explicitly @@ -801,7 +786,7 @@ subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j, igwfnode, idiag ! ------------------------------------------------------------------------------ @@ -814,7 +799,7 @@ subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) if (this%ibound(igwfnode) < 1) cycle idiag = idxglo(ia(igwfnode)) - amatsln(idiag) = amatsln(idiag) + this%hcof(j) + call matrix_sln%add_value_pos(idiag, this%hcof(j)) rhs(igwfnode) = rhs(igwfnode) + this%rhs(j) end do ! @@ -822,7 +807,7 @@ subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, amatsln) return end subroutine apt_fc_nonexpanded - subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) + subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ****************************************************************************** ! apt_fc_expanded -- formulate for the expanded matrix case in which new ! rows are added to the system of equations for each feature @@ -836,7 +821,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j, n, n1, n2 integer(I4B) :: iloc @@ -845,6 +830,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) real(DP) :: cold real(DP) :: qbnd real(DP) :: omega + real(DP) :: unitadj real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval @@ -855,7 +841,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! GwtLktType, GwtSftType, GwtMwtType, GwtUztType ! This routine will add terms for rainfall, runoff, or other terms ! specific to the package - call this%pak_fc_expanded(rhs, ia, idxglo, amatsln) + call this%pak_fc_expanded(rhs, ia, idxglo, matrix_sln) ! ! -- mass (or energy) storage in features do n = 1, this%ncv @@ -863,7 +849,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) iloc = this%idxlocnode(n) iposd = this%idxpakdiag(n) call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) - amatsln(iposd) = amatsln(iposd) + hcofval + call matrix_sln%add_value_pos(iposd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do ! @@ -873,7 +859,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) call this%apt_tmvr_term(j, n1, n2, rrate, rhsval, hcofval) iloc = this%idxlocnode(n1) iposd = this%idxpakdiag(n1) - amatsln(iposd) = amatsln(iposd) + hcofval + call matrix_sln%add_value_pos(iposd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if @@ -902,14 +888,14 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) ! -- add to apt row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - amatsln(iposd) = amatsln(iposd) + omega * qbnd - amatsln(iposoffd) = amatsln(iposoffd) + (DONE - omega) * qbnd + call matrix_sln%add_value_pos(iposd, omega * qbnd) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) ! ! -- add to gwf row for apt connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - amatsln(ipossymd) = amatsln(ipossymd) - (DONE - omega) * qbnd - amatsln(ipossymoffd) = amatsln(ipossymoffd) - omega * qbnd + call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) + call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) end if end do ! @@ -926,8 +912,8 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) end if iposd = this%idxfjfdglo(j) iposoffd = this%idxfjfoffdglo(j) - amatsln(iposd) = amatsln(iposd) + omega * qbnd - amatsln(iposoffd) = amatsln(iposoffd) + (DONE - omega) * qbnd + call matrix_sln%add_value_pos(iposd, omega * qbnd) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) end do end if ! @@ -935,7 +921,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, amatsln) return end subroutine apt_fc_expanded - subroutine pak_fc_expanded(this, rhs, ia, idxglo, amatsln) + subroutine pak_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ****************************************************************************** ! pak_fc_expanded -- allow a subclass advanced transport package to inject ! terms into the matrix assembly. This method must be overridden. @@ -949,7 +935,7 @@ subroutine pak_fc_expanded(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local ! ------------------------------------------------------------------------------ ! @@ -975,11 +961,12 @@ subroutine apt_cfupdate(this) integer(I4B) :: j, n real(DP) :: qbnd real(DP) :: omega + real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! ! -- Calculate hcof and rhs terms so GWF exchanges are calculated correctly ! -- go through each apt-gwf connection and calculate - ! rhs and hcof terms for gwt matrix rows + ! rhs and hcof terms for gwt/gwe matrix rows do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) this%hcof(j) = DZERO @@ -987,9 +974,13 @@ subroutine apt_cfupdate(this) if (this%iboundpak(n) /= 0) then qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) omega = DZERO + unitadj = DONE if (qbnd < DZERO) omega = DONE + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%cpw(j) * this%rhow(j) + end if this%hcof(j) = -(DONE - omega) * qbnd - this%rhs(j) = omega * qbnd * this%xnewpak(n) + this%rhs(j) = omega * unitadj * qbnd * this%xnewpak(n) end if end do ! @@ -1385,6 +1376,10 @@ subroutine apt_da(this) call mem_deallocate(this%idxbudssm) call mem_deallocate(this%nconcbudssm) ! + ! -- nullify pointers + nullify(this%cpw) + nullify(this%rhow) + ! ! -- deallocate scalars in NumericalPackageType call this%BndType%bnd_da() ! @@ -1864,8 +1859,8 @@ subroutine apt_solve(this) real(DP) :: ctmp real(DP) :: c1, qbnd real(DP) :: hcofval, rhsval + real(DP) :: unitadj ! ------------------------------------------------------------------------------ - ! ! ! -- first initialize dbuff do n = 1, this%ncv @@ -1898,16 +1893,20 @@ subroutine apt_solve(this) n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) this%hcof(j) = DZERO this%rhs(j) = DZERO + unitadj = DONE igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%cpw(j) * this%rhow(j) + end if if (qbnd <= DZERO) then ctmp = this%xnewpak(n) - this%rhs(j) = qbnd * ctmp + this%rhs(j) = unitadj * qbnd * ctmp else ctmp = this%xnew(igwfnode) this%hcof(j) = -qbnd end if - c1 = qbnd * ctmp + c1 = unitadj * qbnd * ctmp this%dbuff(n) = this%dbuff(n) + c1 end do ! @@ -2031,7 +2030,8 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) + subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & + latheatvap) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package ! has access to these things. @@ -2045,12 +2045,21 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) real(DP), dimension(:), pointer, contiguous :: xnew real(DP), dimension(:), pointer, contiguous :: xold real(DP), dimension(:), pointer, contiguous :: flowja + real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (for GWE model type) + real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (for GWE model type) + real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (for GWE evaporation) + ! ! -- local integer(I4B) :: istart, iend ! ------------------------------------------------------------------------------ ! ! -- call base BndType set_pointers - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) + if (.not.present(cpw) .and. .not.present(rhow)) then + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) + else + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja, & + cpw, rhow, latheatvap) + end if ! ! -- Set the pointers ! @@ -2532,6 +2541,8 @@ end subroutine apt_stor_term subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) + ! -- modules + ! -- dummy class(TspAptType) :: this integer(I4B), intent(in) :: ientry integer(I4B), intent(inout) :: n1 @@ -2539,13 +2550,23 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: rrate real(DP), intent(inout), optional :: rhsval real(DP), intent(inout), optional :: hcofval + ! -- local real(DP) :: qbnd real(DP) :: ctmp + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + ! + ! -- If GWE package, adjust for thermal units + unitadj = DONE + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%cpw(ientry) * this%rhow(ientry) + end if + ! -- Calculate MVR-related terms n1 = this%flowbudptr%budterm(this%idxbudtmvr)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudtmvr)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudtmvr)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = unitadj * ctmp * qbnd if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! @@ -2555,6 +2576,8 @@ end subroutine apt_tmvr_term subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) + ! -- modules + ! -- dummy class(TspAptType) :: this integer(I4B), intent(in) :: ientry integer(I4B), intent(inout) :: n1 @@ -2562,8 +2585,18 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: rrate real(DP), intent(inout), optional :: rhsval real(DP), intent(inout), optional :: hcofval + ! -- local real(DP) :: qbnd real(DP) :: ctmp + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + ! + ! -- If GWE package, adjust for thermal units + unitadj = DONE + !if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%cpw(ientry) * this%rhow(ientry) + !end if + ! n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudfjf)%flow(ientry) @@ -2572,7 +2605,7 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & else ctmp = this%xnewpak(n2) end if - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = unitadj * ctmp * qbnd if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! From 6a4e081979766a0fd07c84586bca7b72ea494452 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 5 Jan 2023 17:26:27 -0800 Subject: [PATCH 071/212] manual resolution of conflicts in tsp1ssm1.f90 after updating GWE branch (previously named gwt1ssm1.f90) --- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 47 +++++++++++++++------ 1 file changed, 34 insertions(+), 13 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 84f42b9c901..36ff9aa7080 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -19,6 +19,7 @@ module TspSsmModule use TspLabelsModule, only: TspLabelsType use TableModule, only: TableType, table_cr use GwtSpcModule, only: GwtSpcType + use MatrixModule implicit none public :: TspSsmType @@ -41,6 +42,8 @@ module TspSsmModule integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound real(DP), dimension(:), pointer, contiguous :: cnew => null() !< pointer to gwt%x + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< pointer to gwe%cpw + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< pointer to gwe%rhow type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object type(TableType), pointer :: outputtab => null() !< output table object type(GwtSpcType), dimension(:), pointer :: ssmivec => null() !< array of stress package concentration objects @@ -105,7 +108,7 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab) call ssmobj%parser%Initialize(ssmobj%inunit, ssmobj%iout) ! ! -- Store pointer to labels associated with the current model so that the - ! package has access to the assigned labels + ! package has access to the corresponding dependent variable type ssmobj%tsplab => tsplab ! ! -- Return @@ -137,7 +140,7 @@ end subroutine ssm_df !! options and data, and sets up the output table. !! !< - subroutine ssm_ar(this, dis, ibound, cnew) + subroutine ssm_ar(this, dis, ibound, cnew, cpw, rhow) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy @@ -145,6 +148,8 @@ subroutine ssm_ar(this, dis, ibound, cnew) class(DisBaseType), pointer, intent(in) :: dis !< discretization package integer(I4B), dimension(:), pointer, contiguous :: ibound !< GWT model ibound real(DP), dimension(:), pointer, contiguous :: cnew !< GWT model dependent variable + real(DP), dimension(:), pointer, contiguous, optional :: cpw !< GWE heat capacity paramter + real(DP), dimension(:), pointer, contiguous, optional :: rhow !< GWE fluid density paramter ! -- local ! -- formats character(len=*), parameter :: fmtssm = & @@ -158,6 +163,8 @@ subroutine ssm_ar(this, dis, ibound, cnew) this%dis => dis this%ibound => ibound this%cnew => cnew + this%cpw => cpw + this%rhow => rhow ! ! -- Check to make sure that there are flow packages if (this%fmi%nflowpack == 0) then @@ -293,12 +300,21 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & real(DP) :: omega real(DP) :: hcoftmp real(DP) :: rhstmp + real(DP) :: unitadj ! - ! -- retrieve node number, qbnd and iauxpos + ! -- initialize hcoftmp = DZERO rhstmp = DZERO ctmp = DZERO qbnd = DZERO + ! + ! -- initialize unitadj, set its value if GWE model + unitadj = DONE + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%cpw(ientry) * this%rhow(ientry) + end if + ! + ! -- retrieve node number, qbnd and iauxpos n = this%fmi%gwfpackages(ipackage)%nodelist(ientry) ! ! -- If cell is active (ibound > 0) then calculate values @@ -347,7 +363,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & if (qbnd <= DZERO) then hcoftmp = qbnd * omega else - rhstmp = -qbnd * ctmp * (DONE - omega) + rhstmp = -qbnd * ctmp * (DONE - omega) * unitadj end if ! ! -- end of active ibound @@ -364,13 +380,14 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & return end subroutine ssm_term - !> @ brief Provide bound concentration and mixed flag + !> @ brief Provide bound concentration (or temperature) and mixed flag !! - !! SSM concentrations can be provided in auxiliary variables or - !! through separate SPC files. If not provided, the default - !! concentration is zero. This single routine provides the SSM - !! bound concentration based on these different approaches. - !! The mixed flag indicates whether or not + !! SSM concentrations and temperatures can be provided in auxiliary variables + !! or through separate SPC files. If not provided, the default + !! concentration (or temperature) is zero. This single routine provides + !! the SSM bound concentration (or temperature) based on these different + !! approaches. The mixed flag indicates whether or not the boundary as a + !! mixed type. !! !< subroutine get_ssm_conc(this, ipackage, ientry, conc, lauxmixed) @@ -407,11 +424,11 @@ end subroutine get_ssm_conc !! updating the a matrix and right-hand side vector. !! !< - subroutine ssm_fc(this, amatsln, idxglo, rhs) + subroutine ssm_fc(this, matrix_sln, idxglo, rhs) ! -- modules ! -- dummy class(TspSsmType) :: this - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in), dimension(:) :: idxglo real(DP), intent(inout), dimension(:) :: rhs ! -- local @@ -436,7 +453,7 @@ subroutine ssm_fc(this, amatsln, idxglo, rhs) if (n <= 0) cycle call this%ssm_term(ip, i, rhsval=rhsval, hcofval=hcofval) idiag = idxglo(this%dis%con%ia(n)) - amatsln(idiag) = amatsln(idiag) + hcofval + call matrix_sln%add_value_pos(idiag, hcofval) rhs(n) = rhs(n) + rhsval ! end do @@ -720,6 +737,10 @@ subroutine ssm_da(this) ! -- Scalars call mem_deallocate(this%nbound) ! + ! -- nullify pointers + nullify(this%cpw) + nullify(this%rhow) + ! ! -- deallocate parent call this%NumericalPackageType%da() ! From 08209370d829a7e59ac5ca3f34701432ef39b0a1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 6 Jan 2023 10:16:41 -0800 Subject: [PATCH 072/212] manual resolution of conflicts in BoundaryPackage.f90 after updating GWE branch --- src/Model/ModelUtilities/BoundaryPackage.f90 | 32 ++++++++++++++------ 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index c0f3d54ac7d..4d293e4dbca 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -31,6 +31,7 @@ module BndModule use BlockParserModule, only: BlockParserType use TableModule, only: TableType, table_cr use CharacterStringModule, only: CharacterStringType + use MatrixModule implicit none @@ -110,6 +111,11 @@ module BndModule type(TableType), pointer :: inputtab => null() !< input table object type(TableType), pointer :: outputtab => null() !< output table object for package flows writtent to the model listing file type(TableType), pointer :: errortab => null() !< package error table + ! + ! -- physical parameters + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< points to heat capacity specified in GWE MST package + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< points to density of fluid specified in GWE MST package + real(DP), dimension(:), pointer, contiguous :: latheatvap => null() !< points to latent heat of vaporization in GWE MST package contains procedure :: bnd_df @@ -255,12 +261,11 @@ end subroutine bnd_ac !! MAW package. Base implementation that must be extended. !! !< - subroutine bnd_mc(this, moffset, iasln, jasln) + subroutine bnd_mc(this, moffset, matrix_sln) ! -- dummy variables class(BndType), intent(inout) :: this !< BndType object integer(I4B), intent(in) :: moffset !< solution matrix model offset - integer(I4B), dimension(:), intent(in) :: iasln !< solution CRS row pointers - integer(I4B), dimension(:), intent(in) :: jasln !< solution CRS column pointers + class(MatrixBaseType), pointer :: matrix_sln !< global system matrix ! ! -- return return @@ -471,13 +476,13 @@ end subroutine bnd_cf !! a specific boundary package. !! !< - subroutine bnd_fc(this, rhs, ia, idxglo, amatsln) + subroutine bnd_fc(this, rhs, ia, idxglo, matrix_sln) ! -- dummy variables class(BndType) :: this !< BndType object real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + class(MatrixBaseType), pointer :: matrix_sln !< solution coefficient matrix ! -- local variables integer(I4B) :: i integer(I4B) :: n @@ -488,7 +493,7 @@ subroutine bnd_fc(this, rhs, ia, idxglo, amatsln) n = this%nodelist(i) rhs(n) = rhs(n) + this%rhs(i) ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + call matrix_sln%add_value_pos(idxglo(ipos), this%hcof(i)) end do ! ! -- return @@ -503,13 +508,13 @@ end subroutine bnd_fc !! package needs to add Newton-Raphson terms. !! !< - subroutine bnd_fn(this, rhs, ia, idxglo, amatsln) + subroutine bnd_fn(this, rhs, ia, idxglo, matrix_sln) ! -- dummy variables class(BndType) :: this !< BndType object real(DP), dimension(:), intent(inout) :: rhs !< right-hand side vector for model integer(I4B), dimension(:), intent(in) :: ia !< solution CRS row pointers integer(I4B), dimension(:), intent(in) :: idxglo !< mapping vector for model (local) to solution (global) - real(DP), dimension(:), intent(inout) :: amatsln !< solution coefficient matrix + class(MatrixBaseType), pointer :: matrix_sln !< solution coefficient matrix ! ! -- No addition terms for Newton-Raphson with constant conductance ! boundary conditions @@ -1205,7 +1210,8 @@ end subroutine pack_initialize !! variables. This base method should not need to be overridden. !! !< - subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) + subroutine set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & + latheatvap) ! -- dummy variables class(BndType) :: this !< BndType object integer(I4B), pointer :: neq !< number of equations in the model @@ -1213,6 +1219,9 @@ subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) real(DP), dimension(:), pointer, contiguous :: xnew !< current dependent variable real(DP), dimension(:), pointer, contiguous :: xold !< previous dependent variable real(DP), dimension(:), pointer, contiguous :: flowja !< connection flow terms + real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (for GWE model type) + real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (for GWE model type) + real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (for GWE model type) ! ! -- Set the pointers this%neq => neq @@ -1221,6 +1230,11 @@ subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) this%xold => xold this%flowja => flowja ! + ! -- if part of a GWE simulation, need heat capacity(cpw) and density (rhow) + if (present(cpw)) this%cpw => cpw + if (present(rhow)) this%rhow => rhow + if (present(latheatvap)) this%latheatvap => latheatvap + ! ! -- return end subroutine set_pointers From 5b0eb33e5a70434e207139ce8f941fcdf564e2a9 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 6 Jan 2023 11:30:21 -0800 Subject: [PATCH 073/212] manual resolution of conflicts in mf6core.vfproj after updating GWE branch --- msvs/mf6core.vfproj | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 4b406e0fb0d..9c2a98b86eb 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -81,7 +81,8 @@ - + + @@ -149,6 +150,7 @@ + @@ -204,6 +206,9 @@ + + + From 8e530c24cd31f60f490707e893d3862b89fe739b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Sat, 7 Jan 2023 05:59:12 -0800 Subject: [PATCH 074/212] Had to get GweGweExchange.f90 and GweGweConnection.f90 caught up after getting GWE code base caught up with main deevelop branch --- src/Exchange/GweGweExchange.f90 | 8 +++--- src/Model/Connection/GweGweConnection.f90 | 31 +++++++++++++---------- 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index dc74e3a9855..dcb445aa9a9 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -30,6 +30,7 @@ module GweGweExchangeModule use SimVariablesModule, only: errmsg use BlockParserModule, only: BlockParserType use TableModule, only: TableType, table_cr + use MatrixModule implicit none @@ -378,14 +379,13 @@ end subroutine gwe_gwe_ad !! Calculate conductance and fill coefficient matrix !! !< - subroutine gwe_gwe_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) + subroutine gwe_gwe_fc(this, kiter, matrix_sln, rhs_sln, inwtflag) ! -- modules ! -- dummy class(GweExchangeType) :: this !< GwtExchangeType integer(I4B), intent(in) :: kiter - integer(I4B), dimension(:), intent(in) :: iasln - real(DP), dimension(:), intent(inout) :: amatsln - real(DP), dimension(:), intent(inout) :: rhssln + class(MatrixBaseType), pointer :: matrix_sln + real(DP), dimension(:), intent(inout) :: rhs_sln integer(I4B), optional, intent(in) :: inwtflag ! -- local ! diff --git a/src/Model/Connection/GweGweConnection.f90 b/src/Model/Connection/GweGweConnection.f90 index 648426bef8f..27c7d539351 100644 --- a/src/Model/Connection/GweGweConnection.f90 +++ b/src/Model/Connection/GweGweConnection.f90 @@ -14,6 +14,7 @@ module GweGweConnectionModule use ConnectionsModule, only: ConnectionsType use CellWithNbrsModule, only: GlobalCellType use DistributedDataModule + use MatrixModule implicit none private @@ -397,9 +398,7 @@ subroutine gwegwecon_cf(this, kiter) integer(I4B) :: i ! reset interface system - do i = 1, this%nja - this%amat(i) = 0.0_DP - end do + call this%matrix%zero_entries() do i = 1, this%neq this%rhs(i) = 0.0_DP end do @@ -408,17 +407,19 @@ subroutine gwegwecon_cf(this, kiter) end subroutine gwegwecon_cf - subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) + subroutine gwegwecon_fc(this, kiter, matrix_sln, rhs_sln, inwtflag) class(GweGweConnectionType) :: this !< the connection integer(I4B), intent(in) :: kiter !< the iteration counter - integer(I4B), dimension(:), intent(in) :: iasln !< global system's IA array - real(DP), dimension(:), intent(inout) :: amatsln !< global system matrix coefficients - real(DP), dimension(:), intent(inout) :: rhssln !< global right-hand-side + class(MatrixBaseType), pointer :: matrix_sln !< the system matrix + real(DP), dimension(:), intent(inout) :: rhs_sln !< global right-hand-side integer(I4B), optional, intent(in) :: inwtflag !< newton-raphson flag ! local - integer(I4B) :: n, nglo, ipos + integer(I4B) :: n, nglo + integer(I4B) :: icol_start, icol_end, ipos + class(MatrixBaseType), pointer :: matrix_base - call this%gweInterfaceModel%model_fc(kiter, this%amat, this%nja, inwtflag) + matrix_base => this%matrix + call this%gweInterfaceModel%model_fc(kiter, matrix_base, inwtflag) ! map back to solution matrix do n = 1, this%neq @@ -430,18 +431,20 @@ subroutine gwegwecon_fc(this, kiter, iasln, amatsln, rhssln, inwtflag) nglo = this%gridConnection%idxToGlobal(n)%index + & this%gridConnection%idxToGlobal(n)%dmodel%moffset - rhssln(nglo) = rhssln(nglo) + this%rhs(n) + rhs_sln(nglo) = rhs_sln(nglo) + this%rhs(n) - do ipos = this%ia(n), this%ia(n + 1) - 1 - amatsln(this%mapIdxToSln(ipos)) = amatsln(this%mapIdxToSln(ipos)) + & - this%amat(ipos) + icol_start = this%matrix%get_first_col_pos(n) + icol_end = this%matrix%get_last_col_pos(n) + do ipos = icol_start, icol_end + call matrix_sln%add_value_pos(this%mapIdxToSln(ipos), & + this%matrix%get_value_pos(ipos)) end do end do ! FC the movers through the exchange; we can call ! exg_fc() directly because it only handles mover terms (unlike in GwfExchange%exg_fc) if (this%exchangeIsOwned) then - call this%gweExchange%exg_fc(kiter, iasln, amatsln, rhssln, inwtflag) + call this%gweExchange%exg_fc(kiter, matrix_sln, rhs_sln, inwtflag) end if end subroutine gwegwecon_fc From e4784b01d685b0a54d771320cf0004f9e7336e47 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Sat, 7 Jan 2023 06:02:50 -0800 Subject: [PATCH 075/212] Resolution of some code that got mangled in the update merge. Some of the generalized transport module naming was undone as well as some of the generalized labels module referencing. Seems to be working now --- src/Model/GroundWaterTransport/gwt1.f90 | 106 +++++++++++-------- src/Model/GroundWaterTransport/gwt1sft1.f90 | 32 +++--- src/Model/GroundWaterTransport/tsp1adv1.f90 | 83 ++++++++++----- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 88 ++++++++-------- src/Model/GroundWaterTransport/tsp1ic1.f90 | 1 - src/Model/GroundWaterTransport/tsp1ssm1.f90 | 111 ++++++++++++-------- src/Utilities/Budget.f90 | 20 +++- 7 files changed, 265 insertions(+), 176 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 067fca16249..3ce2aefae2b 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -12,19 +12,20 @@ module GwtModule use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType + use TransportModelModule, only: TransportModelType, cunit, niunit use BaseModelModule, only: BaseModelType use BndModule, only: BndType, AddBndToList, GetBndFromList - use GwtIcModule, only: GwtIcType - use GwtFmiModule, only: GwtFmiType - use GwtAdvModule, only: GwtAdvType + use TspIcModule, only: TspIcType + use TspFmiModule, only: TspFmiType + use TspAdvModule, only: TspAdvType + use TspSsmModule, only: TspSsmType + use TspMvtModule, only: TspMvtType + use TspOcModule, only: TspOcType + use TspObsModule, only: TspObsType use GwtDspModule, only: GwtDspType - use GwtSsmModule, only: GwtSsmType - use GwtMvtModule, only: GwtMvtType use GwtMstModule, only: GwtMstType - use GwtOcModule, only: GwtOcType - use GwtObsModule, only: GwtObsType use BudgetModule, only: BudgetType + use TspLabelsModule, only: TspLabelsType use MatrixModule implicit none @@ -36,15 +37,16 @@ module GwtModule type, extends(TransportModelType) :: GwtModelType - type(GwtIcType), pointer :: ic => null() ! initial conditions package - type(GwtFmiType), pointer :: fmi => null() ! flow model interface + type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels + type(TspIcType), pointer :: ic => null() ! initial conditions package + type(TspFmiType), pointer :: fmi => null() ! flow model interface + type(TspAdvType), pointer :: adv => null() ! advection package + type(TspSsmType), pointer :: ssm => null() ! source sink mixing package + type(TspMvtType), pointer :: mvt => null() ! mover transport package + type(TspOcType), pointer :: oc => null() ! output control package + type(TspObsType), pointer :: obs => null() ! observation package type(GwtMstType), pointer :: mst => null() ! mass storage and transfer package - type(GwtAdvType), pointer :: adv => null() ! advection package type(GwtDspType), pointer :: dsp => null() ! dispersion package - type(GwtSsmType), pointer :: ssm => null() ! source sink mixing package - type(GwtMvtType), pointer :: mvt => null() ! mover transport package - type(GwtOcType), pointer :: oc => null() ! output control package - type(GwtObsType), pointer :: obs => null() ! observation package type(BudgetType), pointer :: budget => null() ! budget object integer(I4B), pointer :: inic => null() ! unit number IC integer(I4B), pointer :: infmi => null() ! unit number FMI @@ -86,14 +88,14 @@ module GwtModule end type GwtModelType ! -- Module variables constant for simulation - integer(I4B), parameter :: NIUNIT = 100 - character(len=LENFTYPE), dimension(NIUNIT) :: cunit - data cunit/'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 - &'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 - &'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 - &'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - &'API6 ', ' ', ' ', ' ', ' ', & ! 25 - &75*' '/ + !integer(I4B), parameter :: NIUNIT = 100 + !character(len=LENFTYPE), dimension(NIUNIT) :: cunit + !data cunit/'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 + ! &'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 + ! &'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 + ! &'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 + ! &'API6 ', ' ', ' ', ' ', ' ', & ! 25 + ! &75*' '/ contains @@ -115,16 +117,17 @@ subroutine gwt_cr(filename, id, modelname) use GwfDisModule, only: dis_cr use GwfDisvModule, only: disv_cr use GwfDisuModule, only: disu_cr - use GwtIcModule, only: ic_cr - use GwtFmiModule, only: fmi_cr + use TspIcModule, only: ic_cr + use TspFmiModule, only: fmi_cr + use TspAdvModule, only: adv_cr + use TspSsmModule, only: ssm_cr + use TspMvtModule, only: mvt_cr + use TspOcModule, only: oc_cr + use TspObsModule, only: tsp_obs_cr use GwtMstModule, only: mst_cr - use GwtAdvModule, only: adv_cr use GwtDspModule, only: dsp_cr - use GwtSsmModule, only: ssm_cr - use GwtMvtModule, only: mvt_cr - use GwtOcModule, only: oc_cr - use GwtObsModule, only: gwt_obs_cr use BudgetModule, only: budget_cr + use TspLabelsModule, only: tsplabels_cr use NameFileModule, only: NameFileType ! -- dummy character(len=*), intent(in) :: filename @@ -140,6 +143,7 @@ subroutine gwt_cr(filename, id, modelname) class(BaseModelType), pointer :: model integer(I4B) :: nwords character(len=LINELENGTH), allocatable, dimension(:) :: words + cunit(10) = 'CNC6 ' ! ------------------------------------------------------------------------------ ! ! -- Allocate a new GWT Model (this) and add it to basemodellist @@ -158,6 +162,9 @@ subroutine gwt_cr(filename, id, modelname) this%macronym = 'GWT' this%id = id ! + ! -- Instantiate generalized labels for later assignment + call tsplabels_cr(this%tsplab, this%name) + ! ! -- Open namefile and set iout call namefile_obj%init(this%filename, 0) call namefile_obj%add_cunit(niunit, cunit) @@ -239,21 +246,21 @@ subroutine gwt_cr(filename, id, modelname) end if ! ! -- Create utility objects - call budget_cr(this%budget, this%name) + call budget_cr(this%budget, this%name, this%tsplab) ! ! -- Load input context for currently supported packages call this%load_input_context('DSP6', this%name, 'DSP', this%indsp, this%iout) ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout) + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) - call gwt_obs_cr(this%obs, this%inobs) + call tsp_obs_cr(this%obs, this%inobs) ! ! -- Create stress packages ipakid = 1 @@ -283,12 +290,16 @@ subroutine gwt_df(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use TspLabelsModule, only: setTspLabels ! -- dummy class(GwtModelType) :: this ! -- local integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Set labels to be used with transport model + call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') ! ! -- Define packages and utility objects call this%dis%dis_df() @@ -414,13 +425,13 @@ subroutine gwt_ar(this) if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound) if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) - if (this%inobs > 0) call this%obs%gwt_obs_ar(this%ic, this%x, this%flowja) + if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! ! -- Call dis_ar to write binary grid file !call this%dis%dis_ar(this%npf%icelltype) ! ! -- set up output control - call this%oc%oc_ar(this%x, this%dis, DHNOFLO) + call this%oc%oc_ar(this%x, this%dis, DHNOFLO, this%tsplab%depvartype) call this%budget%set_ibudcsv(this%oc%ibudcsv) ! ! -- Package input files now open, so allocate and read @@ -769,8 +780,8 @@ subroutine gwt_ot(this) idvprint = 0 icbcfl = 0 ibudfl = 0 - if (this%oc%oc_save('CONCENTRATION')) idvsave = 1 - if (this%oc%oc_print('CONCENTRATION')) idvprint = 1 + if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 + if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 if (this%oc%oc_save('BUDGET')) icbcfl = 1 if (this%oc%oc_print('BUDGET')) ibudfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') @@ -778,7 +789,7 @@ subroutine gwt_ot(this) ! -- Override ibudfl and idvprint flags for nonconvergence ! and end of period ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag('CONCENTRATION', this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) ! ! Calculate and save observations call this%gwt_ot_obs() @@ -990,6 +1001,7 @@ subroutine gwt_da(this) call this%budget%budget_da() call this%oc%oc_da() call this%obs%obs_da() + call this%tsplab%tsplabels_da() ! ! -- Internal package objects deallocate (this%dis) @@ -1003,6 +1015,7 @@ subroutine gwt_da(this) deallocate (this%budget) deallocate (this%oc) deallocate (this%obs) + deallocate (this%tsplab) ! ! -- Boundary packages do ip = 1, this%bndlist%Count() @@ -1140,7 +1153,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error - use GwtCncModule, only: cnc_create + use TspCncModule, only: cnc_create use GwtSrcModule, only: src_create use GwtIstModule, only: ist_create use GwtLktModule, only: lkt_create @@ -1166,15 +1179,17 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- This part creates the package object select case (filtyp) case ('CNC6') - call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab) case ('SRC6') - call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab) case ('LKT6') call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) case ('SFT6') call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab) case ('MWT6') call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) @@ -1185,7 +1200,8 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%mst) case ('API6') - call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname) case default write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 25ee2306bcb..5a186dfb6aa 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -36,11 +36,12 @@ module GwtSftModule use ConstantsModule, only: DZERO, DONE, LINELENGTH use SimModule, only: store_error use BndModule, only: BndType, GetBndFromList - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use SfrModule, only: SfrType use ObserveModule, only: ObserveType - use GwtAptModule, only: GwtAptType, apt_process_obsID, & + use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType use MatrixModule implicit none @@ -51,7 +52,7 @@ module GwtSftModule character(len=*), parameter :: flowtype = 'SFR' character(len=16) :: text = ' SFT' - type, extends(GwtAptType) :: GwtSftType + type, extends(TspAptType) :: GwtSftType integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr @@ -90,7 +91,7 @@ module GwtSftModule contains subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi) + fmi, tsplab) ! ****************************************************************************** ! sft_create -- Create a New SFT Package ! ****************************************************************************** @@ -105,7 +106,8 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & integer(I4B), intent(in) :: iout character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname - type(GwtFmiType), pointer :: fmi + type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab ! -- local type(GwtSftType), pointer :: sftobj ! ------------------------------------------------------------------------------ @@ -123,7 +125,7 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! ! -- initialize package call packobj%pack_initialize() - + ! packobj%inunit = inunit packobj%iout = iout packobj%id = id @@ -136,6 +138,10 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages sftobj%fmi => fmi ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + sftobj%tsplab => tsplab + ! ! -- return return end subroutine sft_create @@ -266,7 +272,7 @@ end subroutine find_sft_package subroutine sft_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ****************************************************************************** -! sft_fc_expanded -- this will be called from GwtAptType%apt_fc_expanded() +! sft_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() ! in order to add matrix terms specifically for SFT ! **************************************************************************** ! @@ -605,8 +611,8 @@ subroutine allocate_scalars(this) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- allocate scalars in GwtAptType - call this%GwtAptType%allocate_scalars() + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() ! ! -- Allocate call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%memoryPath) @@ -647,8 +653,8 @@ subroutine sft_allocate_arrays(this) call mem_allocate(this%concroff, this%ncv, 'CONCROFF', this%memoryPath) call mem_allocate(this%conciflw, this%ncv, 'CONCIFLW', this%memoryPath) ! - ! -- call standard GwtApttype allocate arrays - call this%GwtAptType%apt_allocate_arrays() + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() ! ! -- Initialize do n = 1, this%ncv @@ -690,8 +696,8 @@ subroutine sft_da(this) call mem_deallocate(this%concroff) call mem_deallocate(this%conciflw) ! - ! -- deallocate scalars in GwtAptType - call this%GwtAptType%bnd_da() + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() ! ! -- Return return diff --git a/src/Model/GroundWaterTransport/tsp1adv1.f90 b/src/Model/GroundWaterTransport/tsp1adv1.f90 index 422a0993cd9..91e6e50e074 100644 --- a/src/Model/GroundWaterTransport/tsp1adv1.f90 +++ b/src/Model/GroundWaterTransport/tsp1adv1.f90 @@ -1,23 +1,25 @@ -module GwtAdvModule +module TspAdvModule use KindModule, only: DP, I4B use ConstantsModule, only: DONE, DZERO, DHALF, DTWO use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType - use GwtAdvOptionsModule, only: GwtAdvOptionsType + use TspFmiModule, only: TspFmiType + use TspAdvOptionsModule, only: TspAdvOptionsType use MatrixModule - + implicit none private - public :: GwtAdvType + public :: TspAdvType public :: adv_cr - type, extends(NumericalPackageType) :: GwtAdvType + type, extends(NumericalPackageType) :: TspAdvType integer(I4B), pointer :: iadvwt => null() !< advection scheme (0 up, 1 central, 2 tvd) integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water + real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water contains @@ -34,7 +36,7 @@ module GwtAdvModule procedure :: adv_weight procedure :: advtvd - end type GwtAdvType + end type TspAdvType contains @@ -46,11 +48,11 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtAdvType), pointer :: advobj + type(TspAdvType), pointer :: advobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout - type(GwtFmiType), intent(in), target :: fmi + type(TspFmiType), intent(in), target :: fmi ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -72,8 +74,8 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi) end subroutine adv_cr subroutine adv_df(this, adv_options) - class(GwtAdvType) :: this - type(GwtAdvOptionsType), optional, intent(in) :: adv_options !< the optional options, for when not constructing from file + class(TspAdvType) :: this + type(TspAdvOptionsType), optional, intent(in) :: adv_options !< the optional options, for when not constructing from file ! local character(len=*), parameter :: fmtadv = & "(1x,/1x,'ADV-- ADVECTION PACKAGE, VERSION 1, 8/25/2017', & @@ -99,7 +101,7 @@ subroutine adv_df(this, adv_options) end subroutine adv_df - subroutine adv_ar(this, dis, ibound) + subroutine adv_ar(this, dis, ibound, cpw, rhow) ! ****************************************************************************** ! adv_ar -- Allocate and Read ! ****************************************************************************** @@ -108,9 +110,11 @@ subroutine adv_ar(this, dis, ibound) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this class(DisBaseType), pointer, intent(in) :: dis - integer(I4B), dimension(:), pointer, contiguous :: ibound + integer(I4B), dimension(:), pointer, contiguous, intent(in) :: ibound + real(DP), dimension(:), pointer, contiguous, optional, intent(in) :: cpw + real(DP), dimension(:), pointer, contiguous, optional, intent(in) :: rhow ! -- local ! -- formats ! ------------------------------------------------------------------------------ @@ -119,6 +123,10 @@ subroutine adv_ar(this, dis, ibound) this%dis => dis this%ibound => ibound ! + ! -- if part of a GWE simulation, need heat capacity(cpw) and density (rhow) + if (present(cpw)) this%cpw => cpw + if (present(rhow)) this%rhow => rhow + ! ! -- Return return end subroutine adv_ar @@ -132,7 +140,7 @@ subroutine adv_fc(this, nodes, matrix_sln, idxglo, cnew, rhs) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this integer, intent(in) :: nodes class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in), dimension(:) :: idxglo @@ -180,7 +188,7 @@ subroutine advtvd(this, n, cnew, rhs) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this integer(I4B), intent(in) :: n real(DP), dimension(:), intent(in) :: cnew real(DP), dimension(:), intent(inout) :: rhs @@ -216,7 +224,7 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) ! -- return real(DP) :: qtvd ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this integer(I4B), intent(in) :: n integer(I4B), intent(in) :: m integer(I4B), intent(in) :: iposnm @@ -225,10 +233,13 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) integer(I4B) :: ipos, isympos, iup, idn, i2up, j real(DP) :: qnm, qmax, qupj, elupdn, elup2up real(DP) :: smooth, cdiff, alimiter + real(DP) :: unitadjdn, unitadjup ! ------------------------------------------------------------------------------ ! ! -- intialize qtvd = DZERO + unitadjdn = DONE + unitadjup = DONE ! ! -- Find upstream node isympos = this%dis%con%jas(iposnm) @@ -268,7 +279,12 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) end if if (smooth > DZERO) then alimiter = DTWO * smooth / (DONE + smooth) - qtvd = DHALF * alimiter * qnm * (cnew(idn) - cnew(iup)) + if (associated(this%cpw).and.associated(this%rhow)) then + unitadjdn = this%cpw(idn) * this%rhow(idn) + unitadjup = this%cpw(iup) * this%rhow(iup) + end if + qtvd = DHALF * alimiter * qnm * (cnew(idn) * unitadjdn - & + cnew(iup) * unitadjup) end if end if ! @@ -285,14 +301,19 @@ subroutine adv_cq(this, cnew, flowja) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this real(DP), intent(in), dimension(:) :: cnew real(DP), intent(inout), dimension(:) :: flowja ! -- local integer(I4B) :: nodes integer(I4B) :: n, m, idiag, ipos real(DP) :: omega, qnm + real(DP) :: unitadjn, unitadjm ! ------------------------------------------------------------------------------ + ! + ! -- intialize + unitadjn = DONE + unitadjm = DONE ! ! -- Calculate advection and add to flowja. qnm is the volumetric flow ! rate and has dimensions of L^/T. @@ -305,8 +326,12 @@ subroutine adv_cq(this, cnew, flowja) if (this%ibound(m) == 0) cycle qnm = this%fmi%gwfflowja(ipos) omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) - flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & - qnm * (DONE - omega) * cnew(m) + if (associated(this%cpw).and.associated(this%rhow)) then + unitadjn = this%cpw(n) * this%rhow(n) + unitadjm = this%cpw(m) * this%rhow(m) + end if + flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) * unitadjn + & + qnm * (DONE - omega) * cnew(m) * unitadjm end do end do ! @@ -326,7 +351,7 @@ subroutine advtvd_bd(this, cnew, flowja) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this real(DP), dimension(:), intent(in) :: cnew real(DP), dimension(:), intent(inout) :: flowja ! -- local @@ -361,7 +386,7 @@ subroutine adv_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this ! ------------------------------------------------------------------------------ ! ! -- Deallocate arrays if package was active @@ -370,6 +395,8 @@ subroutine adv_da(this) ! ! -- nullify pointers this%ibound => null() + nullify(this%cpw) + nullify(this%rhow) ! ! -- Scalars call mem_deallocate(this%iadvwt) @@ -391,7 +418,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -422,7 +449,7 @@ subroutine read_options(this) use ConstantsModule, only: LINELENGTH use SimModule, only: store_error ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this ! -- local character(len=LINELENGTH) :: errmsg, keyword integer(I4B) :: ierr @@ -488,7 +515,7 @@ function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) ! -- return real(DP) :: omega ! -- dummy - class(GwtAdvType) :: this + class(TspAdvType) :: this integer, intent(in) :: iadvwt integer, intent(in) :: ipos integer, intent(in) :: n @@ -524,4 +551,4 @@ function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) return end function adv_weight -end module GwtAdvModule +end module TspAdvModule diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index fd724dbe244..ec0d8b8b08e 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -1,4 +1,4 @@ -module GwtFmiModule +module TspFmiModule use KindModule, only: DP, I4B use ConstantsModule, only: DONE, DZERO, DHALF, LINELENGTH, LENBUDTXT, & @@ -12,11 +12,12 @@ module GwtFmiModule use HeadFileReaderModule, only: HeadFileReaderType use PackageBudgetModule, only: PackageBudgetType use BudgetObjectModule, only: BudgetObjectType, budgetobject_cr_bfr + use TspLabelsModule, only: TspLabelsType use MatrixModule implicit none private - public :: GwtFmiType + public :: TspFmiType public :: fmi_cr integer(I4B), parameter :: NBDITEMS = 2 @@ -32,7 +33,7 @@ module GwtFmiModule type(BudgetObjectType), pointer :: ptr end type BudObjPtrArray - type, extends(NumericalPackageType) :: GwtFmiType + type, extends(NumericalPackageType) :: TspFmiType logical, pointer :: flows_from_file => null() !< if .false., then flows come from GWF through GWF-GWT exg integer(I4B), dimension(:), pointer, contiguous :: iatp => null() !< advanced transport package applied to gwfpackages @@ -92,11 +93,11 @@ module GwtFmiModule procedure :: get_package_index procedure :: set_aptbudobj_pointer - end type GwtFmiType + end type TspFmiType contains - subroutine fmi_cr(fmiobj, name_model, inunit, iout) + subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) ! ****************************************************************************** ! fmi_cr -- Create a new FMI object ! ****************************************************************************** @@ -104,10 +105,11 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - type(GwtFmiType), pointer :: fmiobj + type(TspFmiType), pointer :: fmiobj character(len=*), intent(in) :: name_model integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout + type(TspLabelsType), pointer, intent(in) :: tsplab ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -130,6 +132,9 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout) ! -- Initialize block parser call fmiobj%parser%Initialize(fmiobj%inunit, fmiobj%iout) ! + ! -- Give package access to the assigned labels based on dependent variable + fmiobj%tsplab => tsplab + ! ! -- Return return end subroutine fmi_cr @@ -144,7 +149,7 @@ subroutine fmi_df(this, dis, inssm) ! -- modules use SimModule, only: store_error ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this class(DisBaseType), pointer, intent(in) :: dis integer(I4B), intent(in) :: inssm ! -- local @@ -213,7 +218,7 @@ subroutine fmi_ar(this, ibound) ! -- modules use SimModule, only: store_error ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), dimension(:), pointer, contiguous :: ibound ! -- local ! -- formats @@ -239,7 +244,7 @@ subroutine fmi_rp(this, inmvr) ! -- modules use TdisModule, only: kper, kstp ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: inmvr ! -- local ! -- formats @@ -276,7 +281,7 @@ subroutine fmi_ad(this, cnew) ! -- modules use ConstantsModule, only: DHDRY ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this real(DP), intent(inout), dimension(:) :: cnew ! -- local integer(I4B) :: n @@ -284,12 +289,6 @@ subroutine fmi_ad(this, cnew) integer(I4B) :: ipos real(DP) :: crewet, tflow, flownm character(len=15) :: nodestr - character(len=*), parameter :: fmtdry = & - &"(/1X,'WARNING: DRY CELL ENCOUNTERED AT ',a,'; RESET AS INACTIVE & - &WITH DRY CONCENTRATION = ', G13.5)" - character(len=*), parameter :: fmtrewet = & - &"(/1X,'DRY CELL REACTIVATED AT ', a,& - &' WITH STARTING CONCENTRATION =',G13.5)" ! ------------------------------------------------------------------------------ ! ! -- Set flag to indicated that flows are being updated. For the case where @@ -337,7 +336,10 @@ subroutine fmi_ad(this, cnew) this%ibound(n) = 0 cnew(n) = DHDRY call this%dis%noder_to_string(n, nodestr) - write (this%iout, fmtdry) trim(nodestr), DHDRY + write (this%iout, '(/1x,a,1x,a,a,1x,a,1x,a,1x,G13.5)') & + 'WARNING: DRY CELL ENCOUNTERED AT', trim(nodestr), '; RESET AS & + &INACTIVE WITH DRY', trim(adjustl(this%tsplab%depvartype)), & + '=', DHDRY end if end if ! @@ -345,7 +347,7 @@ subroutine fmi_ad(this, cnew) if (cnew(n) == DHDRY) then if (this%gwfhead(n) /= DHDRY) then ! - ! -- obtain weighted concentration + ! -- obtain weighted concentration/temperature crewet = DZERO tflow = DZERO do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 @@ -368,7 +370,9 @@ subroutine fmi_ad(this, cnew) this%ibound(n) = 1 cnew(n) = crewet call this%dis%noder_to_string(n, nodestr) - write (this%iout, fmtrewet) trim(nodestr), crewet + write (this%iout, '(/1x,a,1x,a,1x,a,1x,a,1x,a,1x,G13.5)') & + 'DRY CELL REACTIVATED AT', trim(nodestr), 'WITH STARTING', & + trim(adjustl(this%tsplab%depvartype)), '=', crewet end if end if end do @@ -387,7 +391,7 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) ! -- modules !use BndModule, only: BndType, GetBndFromList ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer, intent(in) :: nodes real(DP), intent(in), dimension(nodes) :: cold integer(I4B), intent(in) :: nja @@ -423,7 +427,7 @@ subroutine fmi_cq(this, cnew, flowja) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this real(DP), intent(in), dimension(:) :: cnew real(DP), dimension(:), contiguous, intent(inout) :: flowja ! -- local @@ -462,7 +466,7 @@ subroutine fmi_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: isuppress_output type(BudgetType), intent(inout) :: model_budget ! -- local @@ -488,7 +492,7 @@ subroutine fmi_ot_flow(this, icbcfl, icbcun) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: icbcun ! -- local @@ -536,7 +540,7 @@ subroutine fmi_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! ------------------------------------------------------------------------------ ! -- todo: finalize hfr and bfr either here or in a finalize routine ! @@ -594,7 +598,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local ! ------------------------------------------------------------------------------ ! @@ -642,7 +646,7 @@ subroutine allocate_arrays(this, nodes) !modules use ConstantsModule, only: DZERO ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: nodes ! -- local integer(I4B) :: n @@ -719,7 +723,7 @@ function gwfsatold(this, n, delt) result(satold) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: n real(DP), intent(in) :: delt ! -- result @@ -755,7 +759,7 @@ subroutine read_options(this) use InputOutputModule, only: getunit, openfile, urdaux use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -813,7 +817,7 @@ subroutine read_packagedata(this) use InputOutputModule, only: getunit, openfile, urdaux use SimModule, only: store_error, store_error_unit ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local type(BudgetObjectType), pointer :: budobjptr character(len=LINELENGTH) :: keyword, fname @@ -947,7 +951,7 @@ subroutine set_aptbudobj_pointer(this, name, budobjptr) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dumm character(len=*), intent(in) :: name type(BudgetObjectType), pointer :: budobjptr @@ -975,7 +979,7 @@ subroutine initialize_bfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy integer(I4B) :: ncrbud ! ------------------------------------------------------------------------------ @@ -998,7 +1002,7 @@ subroutine advance_bfr(this) ! -- modules use TdisModule, only: kstp, kper ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local logical :: success integer(I4B) :: n @@ -1144,7 +1148,7 @@ subroutine finalize_bfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -1161,7 +1165,7 @@ subroutine initialize_hfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -1181,7 +1185,7 @@ subroutine advance_hfr(this) ! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B) :: nu, nr, i, ilay integer(I4B) :: ncpl real(DP) :: val @@ -1277,7 +1281,7 @@ subroutine finalize_hfr(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- dummy ! ------------------------------------------------------------------------------ ! @@ -1298,7 +1302,7 @@ subroutine initialize_gwfterms_from_bfr(this) use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, store_error_unit, count_errors ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local integer(I4B) :: nflowpack integer(I4B) :: i, ip @@ -1403,7 +1407,7 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) ! -- modules use BndModule, only: BndType, GetBndFromList ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local integer(I4B) :: ngwfpack integer(I4B) :: ngwfterms @@ -1479,7 +1483,7 @@ subroutine allocate_gwfpackages(this, ngwfterms) use ConstantsModule, only: LENMEMPATH use MemoryManagerModule, only: mem_allocate ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this integer(I4B), intent(in) :: ngwfterms ! -- local integer(I4B) :: n @@ -1521,7 +1525,7 @@ subroutine deallocate_gwfpackages(this) ! ------------------------------------------------------------------------------ ! -- modules ! -- dummy - class(GwtFmiType) :: this + class(TspFmiType) :: this ! -- local integer(I4B) :: n ! ------------------------------------------------------------------------------ @@ -1543,7 +1547,7 @@ subroutine get_package_index(this, name, idx) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ use BndModule, only: BndType, GetBndFromList - class(GwtFmiType) :: this + class(TspFmiType) :: this character(len=*), intent(in) :: name integer(I4B), intent(inout) :: idx ! -- local @@ -1567,4 +1571,4 @@ subroutine get_package_index(this, name, idx) return end subroutine get_package_index -end module GwtFmiModule +end module TspFmiModule diff --git a/src/Model/GroundWaterTransport/tsp1ic1.f90 b/src/Model/GroundWaterTransport/tsp1ic1.f90 index e732d59919a..7bc10e84162 100644 --- a/src/Model/GroundWaterTransport/tsp1ic1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ic1.f90 @@ -83,7 +83,6 @@ subroutine read_data(this) ! ! -- Setup the label write(aname(1), '(a,1x,a)') 'INITIAL', trim(adjustl(this%tsplab%depvartype)) - !aname(1) = , CONCENTRATION' ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index d94daa5663c..36ff9aa7080 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -1,11 +1,11 @@ -!> @brief This module contains the GwtSsm Module +!> @brief This module contains the TspSsm Module !! !! This module contains the code for handling sources and sinks !! associated with groundwater flow model stress packages. !! !! todo: need observations for SSM terms !< -module GwtSsmModule +module TspSsmModule use KindModule, only: DP, I4B, LGP use ConstantsModule, only: DONE, DZERO, LENAUXNAME, LENFTYPE, & @@ -15,13 +15,14 @@ module GwtSsmModule use SimVariablesModule, only: errmsg use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType + use TspLabelsModule, only: TspLabelsType use TableModule, only: TableType, table_cr use GwtSpcModule, only: GwtSpcType use MatrixModule implicit none - public :: GwtSsmType + public :: TspSsmType public :: ssm_cr character(len=LENFTYPE) :: ftype = 'SSM' @@ -34,14 +35,16 @@ module GwtSsmModule !! equation. !! !< - type, extends(NumericalPackageType) :: GwtSsmType + type, extends(NumericalPackageType) :: TspSsmType integer(I4B), pointer :: nbound !< total number of flow boundaries in this time step integer(I4B), dimension(:), pointer, contiguous :: isrctype => null() !< source type 0 is unspecified, 1 is aux, 2 is auxmixed, 3 is ssmi, 4 is ssmimixed integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound real(DP), dimension(:), pointer, contiguous :: cnew => null() !< pointer to gwt%x - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< pointer to gwe%cpw + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< pointer to gwe%rhow + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object type(TableType), pointer :: outputtab => null() !< output table object type(GwtSpcType), dimension(:), pointer :: ssmivec => null() !< array of stress package concentration objects @@ -68,7 +71,7 @@ module GwtSsmModule procedure, private :: set_ssmivec procedure, private :: get_ssm_conc - end type GwtSsmType + end type TspSsmType contains @@ -78,13 +81,14 @@ module GwtSsmModule !! and initializing the parser. !! !< - subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) + subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab) ! -- dummy - type(GwtSsmType), pointer :: ssmobj !< GwtSsmType object + type(TspSsmType), pointer :: ssmobj !< TspSsmType object character(len=*), intent(in) :: name_model !< name of the model integer(I4B), intent(in) :: inunit !< fortran unit for input integer(I4B), intent(in) :: iout !< fortran unit for output - type(GwtFmiType), intent(in), target :: fmi !< GWT FMI package + type(TspFmiType), intent(in), target :: fmi !< Transport FMI package + type(TspLabelsType), intent(in), pointer :: tsplab !< TspLabelsType object ! ! -- Create the object allocate (ssmobj) @@ -103,6 +107,10 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) ! -- Initialize block parser call ssmobj%parser%Initialize(ssmobj%inunit, ssmobj%iout) ! + ! -- Store pointer to labels associated with the current model so that the + ! package has access to the corresponding dependent variable type + ssmobj%tsplab => tsplab + ! ! -- Return return end subroutine ssm_cr @@ -118,7 +126,7 @@ subroutine ssm_df(this) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local ! -- formats ! @@ -132,14 +140,16 @@ end subroutine ssm_df !! options and data, and sets up the output table. !! !< - subroutine ssm_ar(this, dis, ibound, cnew) + subroutine ssm_ar(this, dis, ibound, cnew, cpw, rhow) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object class(DisBaseType), pointer, intent(in) :: dis !< discretization package integer(I4B), dimension(:), pointer, contiguous :: ibound !< GWT model ibound real(DP), dimension(:), pointer, contiguous :: cnew !< GWT model dependent variable + real(DP), dimension(:), pointer, contiguous, optional :: cpw !< GWE heat capacity paramter + real(DP), dimension(:), pointer, contiguous, optional :: rhow !< GWE fluid density paramter ! -- local ! -- formats character(len=*), parameter :: fmtssm = & @@ -153,6 +163,8 @@ subroutine ssm_ar(this, dis, ibound, cnew) this%dis => dis this%ibound => ibound this%cnew => cnew + this%cpw => cpw + this%rhow => rhow ! ! -- Check to make sure that there are flow packages if (this%fmi%nflowpack == 0) then @@ -193,7 +205,7 @@ end subroutine ssm_ar subroutine ssm_rp(this) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -224,7 +236,7 @@ end subroutine ssm_rp subroutine ssm_ad(this) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -272,7 +284,7 @@ end subroutine ssm_ad subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & cssm, qssm) ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType + class(TspSsmType) :: this !< TspSsmType integer(I4B), intent(in) :: ipackage !< package number integer(I4B), intent(in) :: ientry !< bound number real(DP), intent(out), optional :: rrate !< calculated mass flow rate @@ -288,12 +300,21 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & real(DP) :: omega real(DP) :: hcoftmp real(DP) :: rhstmp + real(DP) :: unitadj ! - ! -- retrieve node number, qbnd and iauxpos + ! -- initialize hcoftmp = DZERO rhstmp = DZERO ctmp = DZERO qbnd = DZERO + ! + ! -- initialize unitadj, set its value if GWE model + unitadj = DONE + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%cpw(ientry) * this%rhow(ientry) + end if + ! + ! -- retrieve node number, qbnd and iauxpos n = this%fmi%gwfpackages(ipackage)%nodelist(ientry) ! ! -- If cell is active (ibound > 0) then calculate values @@ -342,7 +363,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & if (qbnd <= DZERO) then hcoftmp = qbnd * omega else - rhstmp = -qbnd * ctmp * (DONE - omega) + rhstmp = -qbnd * ctmp * (DONE - omega) * unitadj end if ! ! -- end of active ibound @@ -359,18 +380,19 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & return end subroutine ssm_term - !> @ brief Provide bound concentration and mixed flag + !> @ brief Provide bound concentration (or temperature) and mixed flag !! - !! SSM concentrations can be provided in auxiliary variables or - !! through separate SPC files. If not provided, the default - !! concentration is zero. This single routine provides the SSM - !! bound concentration based on these different approaches. - !! The mixed flag indicates whether or not + !! SSM concentrations and temperatures can be provided in auxiliary variables + !! or through separate SPC files. If not provided, the default + !! concentration (or temperature) is zero. This single routine provides + !! the SSM bound concentration (or temperature) based on these different + !! approaches. The mixed flag indicates whether or not the boundary as a + !! mixed type. !! !< subroutine get_ssm_conc(this, ipackage, ientry, conc, lauxmixed) ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType + class(TspSsmType) :: this !< TspSsmType integer(I4B), intent(in) :: ipackage !< package number integer(I4B), intent(in) :: ientry !< bound number real(DP), intent(out) :: conc !< user-specified concentration for this bound @@ -405,7 +427,7 @@ end subroutine get_ssm_conc subroutine ssm_fc(this, matrix_sln, idxglo, rhs) ! -- modules ! -- dummy - class(GwtSsmType) :: this + class(TspSsmType) :: this class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in), dimension(:) :: idxglo real(DP), intent(inout), dimension(:) :: rhs @@ -452,7 +474,7 @@ end subroutine ssm_fc subroutine ssm_cq(this, flowja) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow across each face in the model grid ! -- local integer(I4B) :: ip @@ -494,7 +516,7 @@ subroutine ssm_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object integer(I4B), intent(in) :: isuppress_output !< flag to suppress output type(BudgetType), intent(inout) :: model_budget !< budget object for the GWT model ! -- local @@ -552,7 +574,7 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) use TdisModule, only: kstp, kper use ConstantsModule, only: LENPACKAGENAME, LENBOUNDNAME, LENAUXNAME, DZERO ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object integer(I4B), intent(in) :: icbcfl !< flag for writing binary budget terms integer(I4B), intent(in) :: ibudfl !< flag for printing budget terms to list file integer(I4B), intent(in) :: icbcun !< fortran unit number for binary budget file @@ -681,7 +703,7 @@ subroutine ssm_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -715,6 +737,10 @@ subroutine ssm_da(this) ! -- Scalars call mem_deallocate(this%nbound) ! + ! -- nullify pointers + nullify(this%cpw) + nullify(this%rhow) + ! ! -- deallocate parent call this%NumericalPackageType%da() ! @@ -731,7 +757,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local ! ! -- allocate scalars in NumericalPackageType @@ -756,7 +782,7 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: nflowpack integer(I4B) :: i @@ -787,7 +813,7 @@ end subroutine allocate_arrays subroutine read_options(this) ! -- modules ! -- dummy - class(GwtSSMType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -838,7 +864,7 @@ end subroutine read_options !< subroutine read_data(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! ! -- read and process required SOURCES block call this%read_sources_aux() @@ -856,7 +882,7 @@ end subroutine read_data !< subroutine read_sources_aux(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword character(len=20) :: srctype @@ -959,7 +985,7 @@ end subroutine read_sources_aux !< subroutine read_sources_fileinput(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword character(len=LINELENGTH) :: keyword2 @@ -1080,7 +1106,7 @@ end subroutine read_sources_fileinput !< subroutine set_iauxpak(this, ip, packname) ! -- dummy - class(GwtSsmtype), intent(inout) :: this !< GwtSsmtype + class(TspSsmType), intent(inout) :: this !< TspSsmType integer(I4B), intent(in) :: ip !< package number character(len=*), intent(in) :: packname !< name of package ! -- local @@ -1125,7 +1151,7 @@ subroutine set_ssmivec(this, ip, packname) ! -- module use InputOutputModule, only: openfile, getunit ! -- dummy - class(GwtSsmtype), intent(inout) :: this !< GwtSsmtype + class(TspSsmType), intent(inout) :: this !< TspSsmType integer(I4B), intent(in) :: ip !< package number character(len=*), intent(in) :: packname !< name of package ! -- local @@ -1143,8 +1169,9 @@ subroutine set_ssmivec(this, ip, packname) call ssmiptr%initialize(this%dis, ip, inunit, this%iout, this%name_model, & trim(packname)) - write (this%iout, '(4x, a, a, a, a)') 'USING SPC INPUT FILE ', & - trim(filename), ' TO SET CONCENTRATIONS FOR PACKAGE ', trim(packname) + write (this%iout, '(4x, a, a, a, a, a)') 'USING SPC INPUT FILE ', & + trim(filename), ' TO SET ',trim(this%tsplab%depvartype),'S FOR PACKAGE ', & + trim(packname) ! ! -- return return @@ -1157,7 +1184,7 @@ end subroutine set_ssmivec !< subroutine pak_setup_outputtab(this) ! -- dummy - class(GwtSsmtype), intent(inout) :: this + class(TspSsmType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -1199,4 +1226,4 @@ subroutine pak_setup_outputtab(this) return end subroutine pak_setup_outputtab -end module GwtSsmModule +end module TspSsmModule diff --git a/src/Utilities/Budget.f90 b/src/Utilities/Budget.f90 index e3947909e80..a56d7b7d190 100644 --- a/src/Utilities/Budget.f90 +++ b/src/Utilities/Budget.f90 @@ -23,6 +23,7 @@ module BudgetModule use SimModule, only: store_error, count_errors use ConstantsModule, only: LINELENGTH, LENBUDTXT, LENBUDROWLABEL, DZERO, & DTWO, DHUNDRED + use TspLabelsModule, only: TspLabelsType implicit none private @@ -54,6 +55,9 @@ module BudgetModule ! -- csv output integer(I4B), pointer :: ibudcsv => null() integer(I4B), pointer :: icsvheader => null() + ! + ! -- labels + type(TspLabelsType), pointer :: tsplab => null() contains procedure :: budget_df @@ -79,11 +83,12 @@ module BudgetModule !! Create a new budget object. !! !< - subroutine budget_cr(this, name_model) + subroutine budget_cr(this, name_model, tsplab) ! -- modules ! -- dummy type(BudgetType), pointer :: this !< BudgetType object character(len=*), intent(in) :: name_model !< name of the model + type(TspLabelsType), pointer, intent(in), optional :: tsplab !< TspLabelsType object ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -92,6 +97,11 @@ subroutine budget_cr(this, name_model) ! -- Allocate scalars call this%allocate_scalars(name_model) ! + ! -- Store pointer to labels associated with the current model in order + ! assign the correct transport-related labels - only necessary for + ! transport model type (i.e., GWT or GWE) + if (present(tsplab)) this%tsplab => tsplab + ! ! -- Return return end subroutine budget_cr @@ -300,11 +310,11 @@ subroutine budget_ot(this, kstp, kper, iout) , ' TIME STEP', I5, ', STRESS PERIOD', I4 / 2X, 78('-')) 261 FORMAT(//2X, a, ' BUDGET FOR ', a, ' AT END OF' & , ' TIME STEP', I5, ', STRESS PERIOD', I4 / 2X, 99('-')) -265 FORMAT(1X, /5X, 'CUMULATIVE ', a, 6X, a, 7X & - , 'RATES FOR THIS TIME STEP', 6X, a, '/T'/5X, 18('-'), 17X, 24('-') & +265 FORMAT(1X, /5X, 'CUMULATIVE ', a, 11X, a, 6X & + , 'RATES FOR THIS TIME STEP', 8X, a, '/T'/5X, 18('-'), 17X, 24('-') & //11X, 'IN:', 38X, 'IN:'/11X, '---', 38X, '---') -266 FORMAT(1X, /5X, 'CUMULATIVE ', a, 6X, a, 7X & - , 'RATES FOR THIS TIME STEP', 6X, a, '/T', 10X, A16, & +266 FORMAT(1X, /5X, 'CUMULATIVE ', a, 11X, a, 6X & + , 'RATES FOR THIS TIME STEP', 8X, a, '/T', 10X, A16, & /5X, 18('-'), 17X, 24('-'), 21X, 16('-') & //11X, 'IN:', 38X, 'IN:'/11X, '---', 38X, '---') 275 FORMAT(1X, 3X, A16, ' =', A17, 6X, A16, ' =', A17) From b0ef8e5ae0e22bad32f03378ec6be32e93d453dd Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Sat, 7 Jan 2023 06:04:41 -0800 Subject: [PATCH 076/212] GWE needs the MatrixModule updates that were applied to GWT in #1078 --- src/Model/GroundWaterEnergy/gwe1.f90 | 120 ++++++++++++++++------- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 33 +++---- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 94 +++++++++++++----- src/Model/TransportModel.f90 | 2 +- 4 files changed, 169 insertions(+), 80 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index d708d85009d..44945d58f09 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -21,6 +21,7 @@ module GweModule use GweMstModule, only: GweMstType use BudgetModule, only: BudgetType use TspLabelsModule, only: TspLabelsType + use MatrixModule implicit none @@ -78,7 +79,7 @@ module GweModule procedure, private :: gwe_ot_dv procedure, private :: gwe_ot_bdsummary procedure, private :: gwe_ot_obs - + procedure :: load_input_context => gwe_load_input_context end type GweModelType ! -- Module variables constant for simulation @@ -105,8 +106,9 @@ subroutine gwe_cr(filename, id, modelname) use BaseModelModule, only: AddBaseModelToList use SimModule, only: store_error, count_errors use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use CompilerVersion + use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path - use NameFileModule, only: NameFileType use GwfDisModule, only: dis_cr use GwfDisvModule, only: disv_cr use GwfDisuModule, only: disu_cr @@ -121,7 +123,7 @@ subroutine gwe_cr(filename, id, modelname) use GweDspModule, only: dsp_cr use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr - + use NameFileModule, only: NameFileType ! -- dummy character(len=*), intent(in) :: filename integer(I4B), intent(in) :: id @@ -129,13 +131,13 @@ subroutine gwe_cr(filename, id, modelname) ! -- local integer(I4B) :: indis, indis6, indisu6, indisv6 integer(I4B) :: ipakid, i, j, iu, ipaknum - integer(I4B) :: nwords character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname - character(len=LINELENGTH), allocatable, dimension(:) :: words type(NameFileType) :: namefile_obj type(GweModelType), pointer :: this class(BaseModelType), pointer :: model + integer(I4B) :: nwords + character(len=LINELENGTH), allocatable, dimension(:) :: words cunit(10) = 'TMP6 ' ! ------------------------------------------------------------------------------ ! @@ -217,8 +219,8 @@ subroutine gwe_cr(filename, id, modelname) call namefile_obj%get_unitnumber('IC6', this%inic, 1) call namefile_obj%get_unitnumber('FMI6', this%infmi, 1) call namefile_obj%get_unitnumber('MVT6', this%inmvt, 1) - call namefile_obj%get_unitnumber('ADV6', this%inadv, 1) call namefile_obj%get_unitnumber('MST6', this%inmst, 1) + call namefile_obj%get_unitnumber('ADV6', this%inadv, 1) call namefile_obj%get_unitnumber('DSP6', this%indsp, 1) call namefile_obj%get_unitnumber('SSM6', this%inssm, 1) call namefile_obj%get_unitnumber('OC6', this%inoc, 1) @@ -229,15 +231,21 @@ subroutine gwe_cr(filename, id, modelname) ! ! -- Create discretization object if (indis6 > 0) then + call this%load_input_context('DIS6', this%name, 'DIS', indis, this%iout) call dis_cr(this%dis, this%name, indis, this%iout) elseif (indisu6 > 0) then + call this%load_input_context('DISU6', this%name, 'DISU', indis, this%iout) call disu_cr(this%dis, this%name, indis, this%iout) elseif (indisv6 > 0) then + call this%load_input_context('DISV6', this%name, 'DISV', indis, this%iout) call disv_cr(this%dis, this%name, indis, this%iout) end if ! ! -- Create utility objects - call budget_cr(this%budget, this%name) + call budget_cr(this%budget, this%name, this%tsplab) + ! + ! -- Load input context for currently supported packages + call this%load_input_context('DSP6', this%name, 'DSP', this%indsp, this%iout) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) @@ -298,7 +306,8 @@ subroutine gwe_df(this) if (this%indsp > 0) call this%dsp%dsp_df(this%dis) if (this%inssm > 0) call this%ssm%ssm_df() call this%oc%oc_df() - call this%budget%budget_df(niunit, 'MASS', 'M') + call this%budget%budget_df(niunit, this%tsplab%depvarunit, & + this%tsplab%depvarunitabbrev) ! ! -- Assign or point model members to dis members this%neq = this%dis%nodes @@ -322,7 +331,6 @@ subroutine gwe_df(this) ! ! -- return return - end subroutine gwe_df subroutine gwe_ac(this, sparse) @@ -357,7 +365,7 @@ subroutine gwe_ac(this, sparse) return end subroutine gwe_ac - subroutine gwe_mc(this, iasln, jasln) + subroutine gwe_mc(this, matrix_sln) ! ****************************************************************************** ! gwe_mc -- Map the positions of this models connections in the ! numerical solution coefficient matrix. @@ -367,8 +375,7 @@ subroutine gwe_mc(this, iasln, jasln) ! ------------------------------------------------------------------------------ ! -- dummy class(GweModelType) :: this - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln + class(MatrixBaseType), pointer :: matrix_sln !< global system matrix ! -- local class(BndType), pointer :: packobj integer(I4B) :: ip @@ -376,13 +383,13 @@ subroutine gwe_mc(this, iasln, jasln) ! ! -- Find the position of each connection in the global ia, ja structure ! and store them in idxglo. - call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln) - if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, iasln, jasln) + call this%dis%dis_mc(this%moffset, this%idxglo, matrix_sln) + if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, matrix_sln) ! ! -- Map any package connections do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_mc(this%moffset, iasln, jasln) + call packobj%bnd_mc(this%moffset, matrix_sln) end do ! ! -- return @@ -416,7 +423,8 @@ subroutine gwe_ar(this) this%mst%cpw, this%mst%rhow) if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity, & this%mst%cpw, this%mst%rhow) - if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) + if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x, & + this%mst%cpw, this%mst%rhow) if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! ! -- Call dis_ar to write binary grid file @@ -562,7 +570,7 @@ subroutine gwe_cf(this, kiter) return end subroutine gwe_cf - subroutine gwe_fc(this, kiter, amatsln, njasln, inwtflag) + subroutine gwe_fc(this, kiter, matrix_sln, inwtflag) ! ****************************************************************************** ! gwe_fc -- GroundWater Energy Transport Model fill coefficients ! ****************************************************************************** @@ -573,8 +581,7 @@ subroutine gwe_fc(this, kiter, amatsln, njasln, inwtflag) ! -- dummy class(GweModelType) :: this integer(I4B), intent(in) :: kiter - integer(I4B), intent(in) :: njasln - real(DP), dimension(njasln), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in) :: inwtflag ! -- local class(BndType), pointer :: packobj @@ -582,31 +589,31 @@ subroutine gwe_fc(this, kiter, amatsln, njasln, inwtflag) ! ------------------------------------------------------------------------------ ! ! -- call fc routines - call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, njasln, & - amatsln, this%idxglo, this%rhs) + call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, matrix_sln, & + this%idxglo, this%rhs) if (this%inmvt > 0) then call this%mvt%mvt_fc(this%x, this%x) end if if (this%inmst > 0) then - call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, njasln, & - amatsln, this%idxglo, this%x, this%rhs, kiter) + call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, matrix_sln, & + this%idxglo, this%x, this%rhs, kiter) end if if (this%inadv > 0) then - call this%adv%adv_fc(this%dis%nodes, amatsln, this%idxglo, this%x, & + call this%adv%adv_fc(this%dis%nodes, matrix_sln, this%idxglo, this%x, & this%rhs) end if if (this%indsp > 0) then - call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, njasln, amatsln, & + call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, matrix_sln, & this%idxglo, this%rhs, this%x) end if if (this%inssm > 0) then - call this%ssm%ssm_fc(amatsln, this%idxglo, this%rhs) + call this%ssm%ssm_fc(matrix_sln, this%idxglo, this%rhs) end if ! ! -- packages do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln) + call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, matrix_sln) end do ! ! -- return @@ -1057,18 +1064,15 @@ subroutine gwe_bdentry(this, budterm, budtxt, rowlabel) return end subroutine gwe_bdentry + !> @brief return 1 if any package causes the matrix to be asymmetric. + !! Otherwise return 0. + !< function gwe_get_iasym(this) result(iasym) -! ****************************************************************************** -! gwe_get_iasym -- return 1 if any package causes the matrix to be asymmetric. -! Otherwise return 0. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ class(GweModelType) :: this ! -- local integer(I4B) :: iasym -! ------------------------------------------------------------------------------ + integer(I4B) :: ip + class(BndType), pointer :: packobj ! ! -- Start by setting iasym to zero iasym = 0 @@ -1078,6 +1082,16 @@ function gwe_get_iasym(this) result(iasym) if (this%adv%iasym /= 0) iasym = 1 end if ! + ! -- DSP + if (this%indsp > 0) then + if (this%dsp%ixt3d /= 0) iasym = 1 + end if + ! + ! -- Check for any packages that introduce matrix asymmetry + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + if (packobj%iasym /= 0) iasym = 1 + end do ! -- return return end function gwe_get_iasym @@ -1122,7 +1136,7 @@ subroutine allocate_scalars_gwe(this, modelname) ! ! -- return return - end subroutine + end subroutine allocate_scalars_gwe subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) @@ -1285,5 +1299,39 @@ function CastAsGweModel(model) result(gwemodel) end select end function CastAsGweModel + + !> @brief Load input context for supported package + !< + subroutine gwe_load_input_context(this, filtyp, modelname, pkgname, inunit, & + iout, ipaknum) + ! -- modules + use IdmMf6FileLoaderModule, only: input_load + ! -- dummy + class(GweModelType) :: this + character(len=*), intent(in) :: filtyp + character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: pkgname + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + integer(I4B), optional, intent(in) :: ipaknum + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- only load if there is a file to read + if (inunit <= 0) return + ! + ! -- Load model package input to input context + select case (filtyp) + case ('DSP6') + call input_load('DSP6', 'GWE', 'DSP', modelname, pkgname, inunit, iout) + case default + call this%NumericalModelType%load_input_context(filtyp, modelname, & + pkgname, inunit, iout, & + ipaknum) + end select + ! + ! -- return + return + end subroutine gwe_load_input_context end module GweModule diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index e88b04df6ea..d6cab4e4f8d 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -7,7 +7,8 @@ module GweDspModule use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr use GweDspOptionsModule, only: GweDspOptionsType - + use MatrixModule + implicit none private public :: GweDspType @@ -121,14 +122,6 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) if (dspobj%iout > 0) then write (dspobj%iout, fmtdsp) dspobj%inunit end if - ! - ! -- Initialize block parser - call dspobj%parser%Initialize(dspobj%inunit, dspobj%iout) - ! - ! -- Use the input data model routines to load the input data - ! into memory - call input_load(dspobj%parser, 'DSP6', 'GWE', 'DSP', dspobj%name_model, & - 'DSP', [character(len=LENPACKAGETYPE) ::], iout) end if ! ! -- Return @@ -210,7 +203,7 @@ subroutine dsp_ac(this, moffset, sparse) return end subroutine dsp_ac - subroutine dsp_mc(this, moffset, iasln, jasln) + subroutine dsp_mc(this, moffset, matrix_sln) ! ****************************************************************************** ! dsp_mc -- Map connections and construct iax, jax, and idxglox ! ****************************************************************************** @@ -222,13 +215,12 @@ subroutine dsp_mc(this, moffset, iasln, jasln) ! -- dummy class(GweDspType) :: this integer(I4B), intent(in) :: moffset - integer(I4B), dimension(:), intent(in) :: iasln - integer(I4B), dimension(:), intent(in) :: jasln + class(MatrixBaseType), pointer :: matrix_sln ! -- local ! ------------------------------------------------------------------------------ ! ! -- Call xt3d map connections - if (this%ixt3d > 0) call this%xt3d%xt3d_mc(moffset, iasln, jasln) + if (this%ixt3d > 0) call this%xt3d%xt3d_mc(moffset, matrix_sln) ! ! -- Return return @@ -307,7 +299,7 @@ subroutine dsp_ad(this) return end subroutine dsp_ad - subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) + subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) ! ****************************************************************************** ! dsp_fc -- Calculate coefficients and fill amat and rhs ! ****************************************************************************** @@ -320,8 +312,7 @@ subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) integer(I4B) :: kiter integer(I4B), intent(in) :: nodes integer(I4B), intent(in) :: nja - integer(I4B), intent(in) :: njasln - real(DP), dimension(njasln), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in), dimension(nja) :: idxglo real(DP), intent(inout), dimension(nodes) :: rhs real(DP), intent(inout), dimension(nodes) :: cnew @@ -331,7 +322,7 @@ subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) ! ------------------------------------------------------------------------------ ! if (this%ixt3d > 0) then - call this%xt3d%xt3d_fc(kiter, njasln, amatsln, idxglo, rhs, cnew) + call this%xt3d%xt3d_fc(kiter, matrix_sln, idxglo, rhs, cnew) else do n = 1, nodes if (this%fmi%ibdgwfsat0(n) == 0) cycle @@ -345,14 +336,14 @@ subroutine dsp_fc(this, kiter, nodes, nja, njasln, amatsln, idxglo, rhs, cnew) dnm = this%dispcoef(isympos) ! ! -- Contribution to row n - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + dnm - amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) - dnm + call matrix_sln%add_value_pos(idxglo(ipos), dnm) + call matrix_sln%add_value_pos(idxglo(idiag), -dnm) ! ! -- Contribution to row m idiagm = this%dis%con%ia(m) isymcon = this%dis%con%isym(ipos) - amatsln(idxglo(isymcon)) = amatsln(idxglo(isymcon)) + dnm - amatsln(idxglo(idiagm)) = amatsln(idxglo(idiagm)) - dnm + call matrix_sln%add_value_pos(idxglo(isymcon), dnm) + call matrix_sln%add_value_pos(idxglo(idiagm), -dnm) end do end do end if diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 3329a594cd3..226dd216ef2 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -17,6 +17,7 @@ module GweMstModule use SimVariablesModule, only: errmsg, warnmsg use SimModule, only: store_error, count_errors, & store_warning + use MatrixModule use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType use TspFmiModule, only: TspFmiType @@ -45,12 +46,14 @@ module GweMstModule ! ! -- decay integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) + integer(I4B), pointer :: ilhv => null() !< latent heat of vaporization for calculating temperature change associcated with evaporation (0: not specified, not 0: specified) real(DP), dimension(:), pointer, contiguous :: decay => null() !< first or zero order decay rate (aqueous) real(DP), dimension(:), pointer, contiguous :: ratedcy => null() !< rate of decay real(DP), dimension(:), pointer, contiguous :: decaylast => null() !< decay rate used for last iteration (needed for zero order decay) ! ! -- misc integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound + real(DP), dimension(:), pointer, contiguous :: latheatvap => null() !< latent heat of vaporization type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object contains @@ -150,7 +153,7 @@ end subroutine mst_ar !! Method to calculate and fill coefficients for the package. !! !< - subroutine mst_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, cnew, & + subroutine mst_fc(this, nodes, cold, nja, matrix_sln, idxglo, cnew, & rhs, kiter) ! -- modules ! -- dummy @@ -158,8 +161,7 @@ subroutine mst_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, cnew, & integer, intent(in) :: nodes !< number of nodes real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step integer(I4B), intent(in) :: nja !< number of GWE connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + class(MatrixBaseType), pointer :: matrix_sln !< solution matrix integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step @@ -167,11 +169,11 @@ subroutine mst_fc(this, nodes, cold, nja, njasln, amatsln, idxglo, cnew, & ! -- local ! ! -- storage contribution - call this%mst_fc_sto(nodes, cold, nja, njasln, amatsln, idxglo, rhs) + call this%mst_fc_sto(nodes, cold, nja, matrix_sln, idxglo, rhs) ! ! -- decay contribution if (this%idcy /= 0) then - call this%mst_fc_dcy(nodes, cold, cnew, nja, njasln, amatsln, idxglo, & + call this%mst_fc_dcy(nodes, cold, cnew, nja, matrix_sln, idxglo, & rhs, kiter) end if ! @@ -184,7 +186,7 @@ end subroutine mst_fc !! Method to calculate and fill storage coefficients for the package. !! !< - subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) + subroutine mst_fc_sto(this, nodes, cold, nja, matrix_sln, idxglo, rhs) ! -- modules use TdisModule, only: delt ! -- dummy @@ -192,8 +194,7 @@ subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) integer, intent(in) :: nodes !< number of nodes real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step integer(I4B), intent(in) :: nja !< number of GWE connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + class(MatrixBaseType), pointer :: matrix_sln !< solution coefficient matrix integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model ! -- local @@ -224,7 +225,7 @@ subroutine mst_fc_sto(this, nodes, cold, nja, njasln, amatsln, idxglo, rhs) hhcof = -(vnew + term) * tled rrhs = -(vold + term) * tled * cold(n) idiag = this%dis%con%ia(n) - amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof + call matrix_sln%add_value_pos(idxglo(idiag), hhcof) rhs(n) = rhs(n) + rrhs end do ! @@ -237,7 +238,7 @@ end subroutine mst_fc_sto !! Method to calculate and fill decay coefficients for the package. !! !< - subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & + subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & idxglo, rhs, kiter) ! -- modules use TdisModule, only: delt @@ -247,8 +248,7 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & real(DP), intent(in), dimension(nodes) :: cold !< temperature at end of last time step real(DP), intent(in), dimension(nodes) :: cnew !< temperature at end of this time step integer(I4B), intent(in) :: nja !< number of GWE connections - integer(I4B), intent(in) :: njasln !< number of connections in solution - real(DP), dimension(njasln), intent(inout) :: amatsln !< solution coefficient matrix + class(MatrixBaseType), pointer :: matrix_sln !< solution coefficient matrix integer(I4B), intent(in), dimension(nja) :: idxglo !< mapping vector for model (local) to solution (global) real(DP), intent(inout), dimension(nodes) :: rhs !< right-hand side vector for model integer(I4B), intent(in) :: kiter !< solution outer iteration number @@ -276,7 +276,7 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, njasln, amatsln, & ! -- first order decay rate is a function of temperature, so add ! to left hand side hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) - amatsln(idxglo(idiag)) = amatsln(idxglo(idiag)) + hhcof + call matrix_sln%add_value_pos(idxglo(idiag), hhcof) elseif (this%idcy == 2) then ! ! -- Call function to get zero-order decay rate, which may be changed @@ -340,7 +340,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) integer(I4B) :: idiag real(DP) :: rate real(DP) :: tled - real(DP) :: vnew, vold, vcell, vsolid, term + real(DP) :: vwatnew, vwatold, vcell, vsolid, term real(DP) :: hhcof, rrhs ! ! -- initialize @@ -355,16 +355,16 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) ! ! -- calculate new and old water volumes and solid volume vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) - vnew = vcell * this%fmi%gwfsat(n) * this%porosity(n) - vold = vnew - if (this%fmi%igwfstrgss /= 0) vold = vold + this%fmi%gwfstrgss(n) * delt - if (this%fmi%igwfstrgsy /= 0) vold = vold + this%fmi%gwfstrgsy(n) * delt + vwatnew = vcell * this%fmi%gwfsat(n) * this%porosity(n) + vwatold = vwatnew + if (this%fmi%igwfstrgss /= 0) vwatold = vwatold + this%fmi%gwfstrgss(n) * delt + if (this%fmi%igwfstrgsy /= 0) vwatold = vwatold + this%fmi%gwfstrgsy(n) * delt vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow(n) * this%cpw(n)) - hhcof = -(vnew + term) * tled - rrhs = -(vold + term) * tled * cold(n) + hhcof = -(vwatnew + term) * tled + rrhs = -(vwatold + term) * tled * cold(n) rate = hhcof * cnew(n) - rrhs this%ratesto(n) = rate idiag = this%dis%con%ia(n) @@ -530,6 +530,7 @@ subroutine mst_da(this) call mem_deallocate(this%porosity) call mem_deallocate(this%ratesto) call mem_deallocate(this%idcy) + call mem_deallocate(this%ilhv) call mem_deallocate(this%decay) call mem_deallocate(this%ratedcy) call mem_deallocate(this%decaylast) @@ -537,6 +538,7 @@ subroutine mst_da(this) call mem_deallocate(this%cps) call mem_deallocate(this%rhow) call mem_deallocate(this%rhos) + call mem_deallocate(this%latheatvap) this%ibound => null() this%fmi => null() end if @@ -567,9 +569,11 @@ subroutine allocate_scalars(this) ! ! -- Allocate call mem_allocate(this%idcy, 'IDCY', this%memoryPath) + call mem_allocate(this%ilhv, 'ILHV', this%memoryPath) ! ! -- Initialize this%idcy = 0 + this%ilhv = 0 ! ! -- Return return @@ -610,6 +614,13 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%decaylast, nodes, 'DECAYLAST', this%memoryPath) end if ! + ! -- latent heat of vaporization + if (this%ilhv == 0) then + call mem_allocate(this%latheatvap, 1, 'LATHEATVAP', this%memoryPath) + else + call mem_allocate(this%latheatvap, nodes, 'LATHEATVAP', this%memoryPath) + end if + ! ! -- Initialize do n = 1, nodes this%porosity(n) = DZERO @@ -624,6 +635,9 @@ subroutine allocate_arrays(this, nodes) this%ratedcy(n) = DZERO this%decaylast(n) = DZERO end do + do n = 1, size(this%latheatvap) + this%latheatvap(n) = DZERO + end do ! ! -- Return return @@ -640,7 +654,7 @@ subroutine read_options(this) ! -- dummy class(GweMstType) :: this !< GweMstType object ! -- local - character(len=LINELENGTH) :: keyword, keyword2 + character(len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! -- formats @@ -651,6 +665,9 @@ subroutine read_options(this) "(4x,'FIRST-ORDER DECAY IS ACTIVE. ')" character(len=*), parameter :: fmtidcy2 = & "(4x,'ZERO-ORDER DECAY IS ACTIVE. ')" + character(len=*), parameter :: fmtilhv = & + "(4x,'LATENT HEAT OF VAPORIZATION WILL BE & + &USED IN EVAPORATION CALCULATIONS.')" ! ! -- get options block call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false., & @@ -673,6 +690,9 @@ subroutine read_options(this) case ('ZERO_ORDER_DECAY') this%idcy = 2 write (this%iout, fmtidcy2) + case ('LATENT_HEAT_VAPORIZATION') + this%ilhv = 1 + write (this%iout, fmtilhv) case default write (errmsg, '(a,a)') 'UNKNOWN MST OPTION: ', trim(keyword) call store_error(errmsg) @@ -703,7 +723,7 @@ subroutine read_data(this) integer(I4B) :: istart, istop, lloc, ierr logical :: isfound, endOfBlock logical, dimension(10) :: lname - character(len=24), dimension(6) :: aname + character(len=24), dimension(7) :: aname ! -- formats ! -- data data aname(1)/' MOBILE DOMAIN POROSITY'/ @@ -712,6 +732,7 @@ subroutine read_data(this) data aname(4)/' HEAT CAPACITY OF SOLIDS'/ data aname(5)/' DENSITY OF WATER'/ data aname(6)/' DENSITY OF SOLIDS'/ + data aname(7)/'LATENT HEAT VAPORIZATION'/ ! ! -- initialize isfound = .false. @@ -761,6 +782,14 @@ subroutine read_data(this) this%parser%iuactive, this%rhos, & aname(6)) lname(6) = .true. + case ('LATHEATVAP') + if (this%ilhv == 0) & + call mem_reallocate(this%latheatvap, this%dis%nodes, 'LATHEATVAP', & + trim(this%memoryPath)) + call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & + this%parser%iuactive, this%latheatvap, & + aname(7)) + lname(7) = .true. case default write (errmsg, '(a,a)') 'UNKNOWN GRIDDATA TAG: ', trim(keyword) call store_error(errmsg) @@ -814,6 +843,27 @@ subroutine read_data(this) end if end if ! + ! -- Check for latent heat of vaporization. May be used by multiple packages + ! wherever evaporation occurs, is specified in mst instead of in multiple + ! GWE packages that simulate evaporation (SFE, LKE, UZE) + if (this%ilhv > 0) then + if (.not. lname(7)) then + write (errmsg, '(a)') 'EVAPORATION IS EXPECTED IN A GWE PACKAGE & + &BUT THE LATENT HEAT OF VAPORIZATION IS NOT SPECIFIED. LATHEATVAP & + &MUST BE SPECIFIED IN GRIDDATA BLOCK.' + call store_error(errmsg) + end if + else + if (lname(7)) then + write (warnmsg, '(a)') 'LATENT HEAT OF VAPORIZATION FOR CALCULATING & + &EVAPORATION IS SPECIFIED, BUT CORRESPONDING OPTION NOT SET IN & + &OPTIONS BLOCK. EVAPORATION CALCULATIONS WILL STILL USE LATHEATVAP & + &SPECIFIED IN GWE MST PACKAGE.' + call store_warning(warnmsg) + write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + end if + end if + ! ! -- terminate if errors if (count_errors() > 0) then call this%parser%StoreErrorUnit() diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index ac592cac15f..839496be7b7 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -34,7 +34,7 @@ module TransportModelModule 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', ' ', & ! 10 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - 'API6 ', ' ', ' ', ' ', ' ', & ! 25 + 'API6 ', ' ', 'SFE6 ', ' ', ' ', & ! 25 75*' '/ contains From 311ff681c50dd61c17278526f97d487780947de1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Sat, 7 Jan 2023 06:06:01 -0800 Subject: [PATCH 077/212] checking a couple of files that are still under construction but compile. --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 1057 ++++++++++++++++++++++ src/Model/GroundWaterEnergy/gwe1src1.f90 | 318 +++++++ 2 files changed, 1375 insertions(+) create mode 100644 src/Model/GroundWaterEnergy/gwe1sfe1.f90 create mode 100644 src/Model/GroundWaterEnergy/gwe1src1.f90 diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 new file mode 100644 index 00000000000..bddef28c3f5 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -0,0 +1,1057 @@ +! -- Stream Energy Transport Module +! -- todo: Temperature decay? +! -- todo: save the sfe temperature into the sfr aux variable? (perhaps needed for GWT-GWE exchanges) +! -- todo: calculate the sfr VISC aux variable using temperature? +! +! SFR flows (sfrbudptr) index var SFE term Transport Type +!--------------------------------------------------------------------------------- + +! -- terms from SFR that will be handled by parent APT Package +! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv +! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf +! STORAGE (aux VOLUME) idxbudsto none used for cv volumes +! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) +! TO-MVR idxbudtmvr TO-MVR q * tfeat + +! -- SFR terms +! RAINFALL idxbudrain RAINFALL q * train +! EVAPORATION idxbudevap EVAPORATION tfeat null() ! index of rainfall terms in flowbudptr + integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr + integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr + integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr + integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + + real(DP), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature + real(DP), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature + real(DP), dimension(:), pointer, contiguous :: temproff => null() ! runoff temperature + real(DP), dimension(:), pointer, contiguous :: tempiflw => null() ! inflow temperature + + contains + + procedure :: bnd_da => sfe_da + procedure :: allocate_scalars + procedure :: apt_allocate_arrays => sfe_allocate_arrays + procedure :: find_apt_package => find_sfe_package + procedure :: pak_fc_expanded => sfe_fc_expanded + procedure :: pak_solve => sfe_solve + procedure :: pak_get_nbudterms => sfe_get_nbudterms + procedure :: pak_setup_budobj => sfe_setup_budobj + procedure :: pak_fill_budobj => sfe_fill_budobj + procedure :: sfe_rain_term + procedure :: sfe_evap_term + procedure :: sfe_roff_term + procedure :: sfe_iflw_term + procedure :: sfe_outf_term + procedure :: pak_df_obs => sfe_df_obs + procedure :: pak_rp_obs => sfe_rp_obs + procedure :: pak_bd_obs => sfe_bd_obs + procedure :: pak_set_stressperiod => sfe_set_stressperiod + + end type GweSfeType + +contains + + subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + fmi, tsplab) +! ****************************************************************************** +! sfe_create -- Create a New SFE Package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab + ! -- local + type(GweSfeType), pointer :: sfeobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate (sfeobj) + packobj => sfeobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call sfeobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + ! + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + ! + ! -- Store pointer to flow model interface. When the GwfGwt exchange is + ! created, it sets fmi%bndlist so that the GWT model has access to all + ! the flow packages + sfeobj%fmi => fmi + ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + sfeobj%tsplab => tsplab + ! + ! -- return + return + end subroutine sfe_create + + subroutine find_sfe_package(this) +! ****************************************************************************** +! find corresponding sfe package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweSfeType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + class(BndType), pointer :: packobj + integer(I4B) :: ip, icount + integer(I4B) :: nbudterm + logical :: found +! ------------------------------------------------------------------------------ + ! + ! -- Initialize found to false, and error later if flow package cannot + ! be found + found = .false. + ! + ! -- If user is specifying flows in a binary budget file, then set up + ! the budget file reader, otherwise set a pointer to the flow package + ! budobj + if (this%fmi%flows_from_file) then + call this%fmi%set_aptbudobj_pointer(this%flowpackagename, this%flowbudptr) + if (associated(this%flowbudptr)) found = .true. + ! + else + if (associated(this%fmi%gwfbndlist)) then + ! -- Look through gwfbndlist for a flow package with the same name as + ! this transport package name + do ip = 1, this%fmi%gwfbndlist%Count() + packobj => GetBndFromList(this%fmi%gwfbndlist, ip) + if (packobj%packName == this%flowpackagename) then + found = .true. + ! + ! -- store BndType pointer to packobj, and then + ! use the select type to point to the budobj in flow package + this%flowpackagebnd => packobj + select type (packobj) + type is (SfrType) + this%flowbudptr => packobj%budobj + end select + end if + if (found) exit + end do + end if + end if + ! + ! -- error if flow package not found + if (.not. found) then + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + ! + ! -- allocate space for idxbudssm, which indicates whether this is a + ! special budget term or one that is a general source and sink + nbudterm = this%flowbudptr%nbudterm + call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) + ! + ! -- Process budget terms and identify special budget terms + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv + icount = 1 + do ip = 1, this%flowbudptr%nbudterm + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') + this%idxbudfjf = ip + this%idxbudssm(ip) = 0 + case ('GWF') + this%idxbudgwf = ip + this%idxbudssm(ip) = 0 + case ('STORAGE') + this%idxbudsto = ip + this%idxbudssm(ip) = 0 + case ('RAINFALL') + this%idxbudrain = ip + this%idxbudssm(ip) = 0 + case ('EVAPORATION') + this%idxbudevap = ip + this%idxbudssm(ip) = 0 + case ('RUNOFF') + this%idxbudroff = ip + this%idxbudssm(ip) = 0 + case ('EXT-INFLOW') + this%idxbudiflw = ip + this%idxbudssm(ip) = 0 + case ('EXT-OUTFLOW') + this%idxbudoutf = ip + this%idxbudssm(ip) = 0 + case ('TO-MVR') + this%idxbudtmvr = ip + this%idxbudssm(ip) = 0 + case ('FROM-MVR') + this%idxbudfmvr = ip + this%idxbudssm(ip) = 0 + case ('AUXILIARY') + this%idxbudaux = ip + this%idxbudssm(ip) = 0 + case default + ! + ! -- set idxbudssm equal to a column index for where the temperatures + ! are stored in the concbud(nbudssm, ncv) array + this%idxbudssm(ip) = icount + icount = icount + 1 + end select + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & + ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & + ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist + end do + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' + ! + ! -- Return + return + end subroutine find_sfe_package + + !> @brief Add matrix terms related to SFE + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for SFE + !! + !< + subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) + ! -- modules + ! -- dummy + class(GweSfeType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + class(MatrixBaseType), pointer :: matrix_sln + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: iloc + integer(I4B) :: iposd + real(DP) :: rrate + real(DP) :: rhsval + real(DP) :: hcofval +! ------------------------------------------------------------------------------ + ! + ! -- add rainfall contribution + if (this%idxbudrain /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist + call this%sfe_rain_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add evaporation contribution + if (this%idxbudevap /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist + call this%sfe_evap_term(j, n1, n2, rrate, rhsval) !, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add runoff contribution + if (this%idxbudroff /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist + call this%sfe_roff_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add inflow contribution + if (this%idxbudiflw /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist + call this%sfe_iflw_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add outflow contribution + if (this%idxbudoutf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist + call this%sfe_outf_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- Return + return + end subroutine sfe_fc_expanded + + !> @ brief Add terms specific to sfr to the explicit sfr solve + !< + subroutine sfe_solve(this) + ! -- dummy + class(GweSfeType) :: this + ! -- local + integer(I4B) :: j + integer(I4B) :: n1, n2 + real(DP) :: rrate +! ------------------------------------------------------------------------------ + ! + ! -- add rainfall contribution + if (this%idxbudrain /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist + call this%sfe_rain_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add evaporation contribution + if (this%idxbudevap /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist + call this%sfe_evap_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add runoff contribution + if (this%idxbudroff /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist + call this%sfe_roff_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add inflow contribution + if (this%idxbudiflw /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist + call this%sfe_iflw_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add outflow contribution + if (this%idxbudoutf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist + call this%sfe_outf_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- Return + return + end subroutine sfe_solve + + !> @brief Function to return the number of budget terms just for this package. + !! + !! This overrides function in parent. + !! + !< + function sfe_get_nbudterms(this) result(nbudterms) + ! -- modules + ! -- dummy + class(GweSfeType) :: this + ! -- return + integer(I4B) :: nbudterms + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Number of budget terms is 6 + nbudterms = 5 + ! + ! -- Return + return + end function sfe_get_nbudterms + + !> @brief Set up the budget object that stores all the sfe flows + !< + subroutine sfe_setup_budobj(this, idx) + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(inout) :: idx + ! -- local + integer(I4B) :: maxlist, naux + character(len=LENBUDTXT) :: text +! ------------------------------------------------------------------------------ + ! + ! -- + text = ' RAINFALL' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EVAPORATION' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' RUNOFF' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-INFLOW' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-OUTFLOW' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- return + return + end subroutine sfe_setup_budobj + + !> @brief Copy flow terms into this%budobj + !< + subroutine sfe_fill_budobj(this, idx, x, ccratin, ccratout) + ! -- modules + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(inout) :: idx + real(DP), dimension(:), intent(in) :: x + real(DP), intent(inout) :: ccratin + real(DP), intent(inout) :: ccratout + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: nlist + real(DP) :: q + ! -- formats +! ----------------------------------------------------------------------------- + + ! -- RAIN + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%sfe_rain_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- EVAPORATION + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%sfe_evap_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- RUNOFF + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%sfe_roff_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- EXT-INFLOW + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%sfe_iflw_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- EXT-OUTFLOW + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%sfe_outf_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! + ! -- return + return + end subroutine sfe_fill_budobj + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweSfeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%memoryPath) + call mem_allocate(this%idxbudevap, 'IDXBUDEVAP', this%memoryPath) + call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath) + call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) + call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) + ! + ! -- Initialize + this%idxbudrain = 0 + this%idxbudevap = 0 + this%idxbudroff = 0 + this%idxbudiflw = 0 + this%idxbudoutf = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + !> @brief Allocate arrays + !< + subroutine sfe_allocate_arrays(this) + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweSfeType), intent(inout) :: this + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- time series + call mem_allocate(this%temprain, this%ncv, 'TEMPRAIN', this%memoryPath) + call mem_allocate(this%tempevap, this%ncv, 'TEMPEVAP', this%memoryPath) + call mem_allocate(this%temproff, this%ncv, 'TEMPROFF', this%memoryPath) + call mem_allocate(this%tempiflw, this%ncv, 'TEMPIFLW', this%memoryPath) + ! + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() + ! + ! -- Initialize + do n = 1, this%ncv + this%temprain(n) = DZERO + this%tempevap(n) = DZERO + this%temproff(n) = DZERO + this%tempiflw(n) = DZERO + end do + ! + ! + ! -- Return + return + end subroutine sfe_allocate_arrays + + !> @brief Deallocate + !< + subroutine sfe_da(this) + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweSfeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- deallocate scalars + call mem_deallocate(this%idxbudrain) + call mem_deallocate(this%idxbudevap) + call mem_deallocate(this%idxbudroff) + call mem_deallocate(this%idxbudiflw) + call mem_deallocate(this%idxbudoutf) + ! + ! -- deallocate time series + call mem_deallocate(this%temprain) + call mem_deallocate(this%tempevap) + call mem_deallocate(this%temproff) + call mem_deallocate(this%tempiflw) + ! + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() + ! + ! -- Return + return + end subroutine sfe_da + + !> @brief Rain term + !< + subroutine sfe_rain_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudrain)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) + ctmp = this%temprain(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine sfe_rain_term + + !> @brief Evaporative term + !< + subroutine sfe_evap_term(this, ientry, n1, n2, rrate, rhsval) + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + ! -- local + real(DP) :: qbnd + real(DP) :: heatlat + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + unitadj = this%bndType%cpw(n1) * this%bndType%rhow(n1) + n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) + ! -- note that qbnd is negative for evap + qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) + heatlat = this%bndType%rhow(n1) * this%latheatvap(n1) + if (present(rrate)) rrate = qbnd * heatlat !m^3/day * kg/m^3 * J/kg = J/day + if (present(rhsval)) rhsval = -1 * qbnd * heatlat + !if (present(hcofval)) hcofval = omega * qbnd + ! + ! -- return + return + end subroutine sfe_evap_term + + !> @brief Runoff term + !< + subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + unitadj = this%bndType%cpw(n1) * this%bndType%rhow(n1) + n1 = this%flowbudptr%budterm(this%idxbudroff)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) + ctmp = this%temproff(n1) + if (present(rrate)) rrate = unitadj * ctmp * qbnd + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine sfe_roff_term + + !> @brief Inflow Term + !< + subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudiflw)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) + ctmp = this%tempiflw(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine sfe_iflw_term + + !> @brief Outflow term + !< + subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) + ! -- dummy + class(GweSfeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudoutf)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) + ctmp = this%xnewpak(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine sfe_outf_term + + !> @brief Observations + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !! + !< + subroutine sfe_df_obs(this) + ! -- modules + ! -- dummy + class(GweSfeType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for temperature observation type. + call this%obs%StoreObsType('temperature', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for flow between reaches. + call this%obs%StoreObsType('flow-ja-face', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID12 + ! + ! -- Store obs type and assign procedure pointer + ! for from-mvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for constant observation type. + call this%obs%StoreObsType('constant', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type: sfe + call this%obs%StoreObsType('sfe', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for rainfall observation type. + call this%obs%StoreObsType('rainfall', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for evaporation observation type. + call this%obs%StoreObsType('evaporation', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for runoff observation type. + call this%obs%StoreObsType('runoff', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('ext-inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ext-outflow observation type. + call this%obs%StoreObsType('ext-outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + return + end subroutine sfe_df_obs + + !> @brief Process package specific obs + !! + !! Method to process specific observations for this package. + !! + !< + subroutine sfe_rp_obs(this, obsrv, found) + ! -- dummy + class(GweSfeType), intent(inout) :: this !< package class + type(ObserveType), intent(inout) :: obsrv !< observation object + logical, intent(inout) :: found !< indicate whether observation was found + ! -- local + ! + found = .true. + select case (obsrv%ObsTypeId) + case ('RAINFALL') + call this%rp_obs_byfeature(obsrv) + case ('EVAPORATION') + call this%rp_obs_byfeature(obsrv) + case ('RUNOFF') + call this%rp_obs_byfeature(obsrv) + case ('EXT-INFLOW') + call this%rp_obs_byfeature(obsrv) + case ('EXT-OUTFLOW') + call this%rp_obs_byfeature(obsrv) + case ('TO-MVR') + call this%rp_obs_byfeature(obsrv) + case default + found = .false. + end select + ! + return + end subroutine sfe_rp_obs + + !> @brief Calculate observation value and pass it back to APT + !< + subroutine sfe_bd_obs(this, obstypeid, jj, v, found) + ! -- dummy + class(GweSfeType), intent(inout) :: this + character(len=*), intent(in) :: obstypeid + real(DP), intent(inout) :: v + integer(I4B), intent(in) :: jj + logical, intent(inout) :: found + ! -- local + integer(I4B) :: n1, n2 +! ------------------------------------------------------------------------------ + ! + found = .true. + select case (obstypeid) + case ('RAINFALL') + if (this%iboundpak(jj) /= 0) then + call this%sfe_rain_term(jj, n1, n2, v) + end if + case ('EVAPORATION') + if (this%iboundpak(jj) /= 0) then + call this%sfe_evap_term(jj, n1, n2, v) + end if + case ('RUNOFF') + if (this%iboundpak(jj) /= 0) then + call this%sfe_roff_term(jj, n1, n2, v) + end if + case ('EXT-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%sfe_iflw_term(jj, n1, n2, v) + end if + case ('EXT-OUTFLOW') + if (this%iboundpak(jj) /= 0) then + call this%sfe_outf_term(jj, n1, n2, v) + end if + case default + found = .false. + end select + ! + return + end subroutine sfe_bd_obs + + !> @brief Sets the stress period attributes for keyword use. + !< + subroutine sfe_set_stressperiod(this, itemno, keyword, found) + use TimeSeriesManagerModule, only: read_value_or_time_series_adv + ! -- dummy + class(GweSfeType), intent(inout) :: this + integer(I4B), intent(in) :: itemno + character(len=*), intent(in) :: keyword + logical, intent(inout) :: found + ! -- local + character(len=LINELENGTH) :: text + integer(I4B) :: ierr + integer(I4B) :: jj + real(DP), pointer :: bndElem => null() + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! RAINFALL + ! EVAPORATION + ! RUNOFF + ! INFLOW + ! WITHDRAWAL + ! + found = .true. + select case (keyword) + case ('RAINFALL') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%temprain(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RAINFALL') + case ('EVAPORATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%tempevap(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EVAPORATION') + case ('RUNOFF') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%temproff(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RUNOFF') + case ('INFLOW') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%tempiflw(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'INFLOW') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. + end select + ! +999 continue + ! + ! -- return + return + end subroutine sfe_set_stressperiod + +end module GweSfeModule diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 new file mode 100644 index 00000000000..e0525db34d9 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -0,0 +1,318 @@ +module GweSrcModule + ! + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DEM1, DONE, LENFTYPE + use BndModule, only: BndType + use TspLabelsModule, only: TspLabelsType + use ObsModule, only: DefaultObsIdProcessor + use TimeSeriesLinkModule, only: TimeSeriesLinkType, & + GetTimeSeriesLinkFromList + use BlockParserModule, only: BlockParserType + ! + implicit none + ! + private + public :: src_create + ! + character(len=LENFTYPE) :: ftype = 'SRC' + character(len=16) :: text = ' SRC' + ! + type, extends(BndType) :: GweSrcType + contains + procedure :: allocate_scalars => src_allocate_scalars + procedure :: bnd_cf => src_cf + procedure :: bnd_fc => src_fc + procedure :: bnd_da => src_da + procedure :: define_listlabel + ! -- methods for observations + procedure, public :: bnd_obs_supported => src_obs_supported + procedure, public :: bnd_df_obs => src_df_obs + ! -- methods for time series + procedure, public :: bnd_rp_ts => src_rp_ts + end type GweSrcType + +contains + + subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + tsplab) +! ****************************************************************************** +! src_create -- Create a New Src Package +! Subroutine: (1) create new-style package +! (2) point bndobj to the new package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(TspLabelsType), pointer :: tsplab + ! -- local + type(GweSrcType), pointer :: srcobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate (srcobj) + packobj => srcobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call srcobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + ! + ! -- Store pointer to labels associated with the current model so that the + ! package has access to the assigned labels + packobj%tsplab => tsplab + ! + ! -- return + return + end subroutine src_create + + subroutine src_da(this) +! ****************************************************************************** +! src_da -- deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweSrcType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Deallocate parent package + call this%BndType%bnd_da() + ! + ! -- scalars + ! + ! -- return + return + end subroutine src_da + + subroutine src_allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars -- allocate scalar members +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweSrcType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- call standard BndType allocate scalars + call this%BndType%allocate_scalars() + ! + ! -- allocate the object and assign values to object variables + ! + ! -- Set values + ! + ! -- return + return + end subroutine src_allocate_scalars + + subroutine src_cf(this, reset_mover) +! ****************************************************************************** +! src_cf -- Formulate the HCOF and RHS terms +! Subroutine: (1) skip if no sources +! (2) calculate hcof and rhs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweSrcType) :: this + logical, intent(in), optional :: reset_mover + ! -- local + integer(I4B) :: i, node + real(DP) :: q + logical :: lrm +! ------------------------------------------------------------------------------ + ! + ! -- Return if no sources + if (this%nbound == 0) return + ! + ! -- pakmvrobj cf + lrm = .true. + if (present(reset_mover)) lrm = reset_mover + if (this%imover == 1 .and. lrm) then + call this%pakmvrobj%cf() + end if + ! + ! -- Calculate hcof and rhs for each source entry + do i = 1, this%nbound + node = this%nodelist(i) + this%hcof(i) = DZERO + if (this%ibound(node) <= 0) then + this%rhs(i) = DZERO + cycle + end if + q = this%bound(1, i) + this%rhs(i) = -q + end do + ! + return + end subroutine src_cf + + subroutine src_fc(this, rhs, ia, idxglo, amatsln) +! ************************************************************************** +! src_fc -- Copy rhs and hcof into solution rhs and amat +! ************************************************************************** +! +! SPECIFICATIONS: +! -------------------------------------------------------------------------- + ! -- dummy + class(GweSrcType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + real(DP), dimension(:), intent(inout) :: amatsln + ! -- local + integer(I4B) :: i, n, ipos +! -------------------------------------------------------------------------- + ! + ! -- pakmvrobj fc + if (this%imover == 1) then + call this%pakmvrobj%fc() + end if + ! + ! -- Copy package rhs and hcof into solution rhs and amat + do i = 1, this%nbound + n = this%nodelist(i) + rhs(n) = rhs(n) + this%rhs(i) + ipos = ia(n) + amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + ! + ! -- If mover is active and mass is being withdrawn, + ! store available mass (as positive value). + if (this%imover == 1 .and. this%rhs(i) > DZERO) then + call this%pakmvrobj%accumulate_qformvr(i, this%rhs(i)) + end if + end do + ! + ! -- return + return + end subroutine src_fc + + subroutine define_listlabel(this) +! ****************************************************************************** +! define_listlabel -- Define the list heading that is written to iout when +! PRINT_INPUT option is used. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + class(GweSrcType), intent(inout) :: this +! ------------------------------------------------------------------------------ + ! + ! -- create the header list label + this%listlabel = trim(this%filtyp)//' NO.' + if (this%dis%ndim == 3) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL' + elseif (this%dis%ndim == 2) then + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER' + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D' + else + write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' + end if + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE' + if (this%inamedbound == 1) then + write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' + end if + ! + ! -- return + return + end subroutine define_listlabel + + ! -- Procedures related to observations + logical function src_obs_supported(this) + ! ****************************************************************************** + ! src_obs_supported + ! -- Return true because SRC package supports observations. + ! -- Overrides BndType%bnd_obs_supported() + ! ****************************************************************************** + ! + ! SPECIFICATIONS: + ! ------------------------------------------------------------------------------ + implicit none + class(GweSrcType) :: this + ! ------------------------------------------------------------------------------ + src_obs_supported = .true. + return + end function src_obs_supported + + 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(GweSrcType) :: this + ! -- local + integer(I4B) :: indx + ! ------------------------------------------------------------------------------ + call this%obs%StoreObsType('src', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor + ! + ! -- return + return + end subroutine src_df_obs + + ! -- Procedure related to 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(GweSrcType), intent(inout) :: this + ! -- local + integer(I4B) :: i, nlinks + type(TimeSeriesLinkType), pointer :: tslink => null() + ! + nlinks = this%TsManager%boundtslinks%Count() + do i = 1, nlinks + tslink => GetTimeSeriesLinkFromList(this%TsManager%boundtslinks, i) + if (associated(tslink)) then + if (tslink%JCol == 1) then + tslink%Text = 'SMASSRATE' + end if + end if + end do + ! + return + end subroutine src_rp_ts + +end module GweSrcModule From a58d5be6faf7a5d90fa8c794cad0b272c99c6970 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 10 Jan 2023 06:43:10 -0800 Subject: [PATCH 078/212] clean-out bad code --- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 2 ++ src/Model/GroundWaterTransport/tsp1adv1.f90 | 23 +++------------------ src/Model/GroundWaterTransport/tsp1ssm1.f90 | 9 +------- 3 files changed, 6 insertions(+), 28 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 226dd216ef2..210d3b6a2f3 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -342,6 +342,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) real(DP) :: tled real(DP) :: vwatnew, vwatold, vcell, vsolid, term real(DP) :: hhcof, rrhs + real(DP) :: unitadj ! ! -- initialize tled = DONE / delt @@ -349,6 +350,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) ! -- Calculate storage change do n = 1, nodes this%ratesto(n) = DZERO + unitadj = this%cpw(n) * this%rhow(n) ! ! -- skip if transport inactive if (this%ibound(n) <= 0) cycle diff --git a/src/Model/GroundWaterTransport/tsp1adv1.f90 b/src/Model/GroundWaterTransport/tsp1adv1.f90 index 91e6e50e074..fd7e8e6e9e7 100644 --- a/src/Model/GroundWaterTransport/tsp1adv1.f90 +++ b/src/Model/GroundWaterTransport/tsp1adv1.f90 @@ -233,13 +233,10 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) integer(I4B) :: ipos, isympos, iup, idn, i2up, j real(DP) :: qnm, qmax, qupj, elupdn, elup2up real(DP) :: smooth, cdiff, alimiter - real(DP) :: unitadjdn, unitadjup ! ------------------------------------------------------------------------------ ! ! -- intialize qtvd = DZERO - unitadjdn = DONE - unitadjup = DONE ! ! -- Find upstream node isympos = this%dis%con%jas(iposnm) @@ -279,12 +276,7 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) end if if (smooth > DZERO) then alimiter = DTWO * smooth / (DONE + smooth) - if (associated(this%cpw).and.associated(this%rhow)) then - unitadjdn = this%cpw(idn) * this%rhow(idn) - unitadjup = this%cpw(iup) * this%rhow(iup) - end if - qtvd = DHALF * alimiter * qnm * (cnew(idn) * unitadjdn - & - cnew(iup) * unitadjup) + qtvd = DHALF * alimiter * qnm * (cnew(idn) - cnew(iup)) end if end if ! @@ -308,12 +300,7 @@ subroutine adv_cq(this, cnew, flowja) integer(I4B) :: nodes integer(I4B) :: n, m, idiag, ipos real(DP) :: omega, qnm - real(DP) :: unitadjn, unitadjm ! ------------------------------------------------------------------------------ - ! - ! -- intialize - unitadjn = DONE - unitadjm = DONE ! ! -- Calculate advection and add to flowja. qnm is the volumetric flow ! rate and has dimensions of L^/T. @@ -326,12 +313,8 @@ subroutine adv_cq(this, cnew, flowja) if (this%ibound(m) == 0) cycle qnm = this%fmi%gwfflowja(ipos) omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) - if (associated(this%cpw).and.associated(this%rhow)) then - unitadjn = this%cpw(n) * this%rhow(n) - unitadjm = this%cpw(m) * this%rhow(m) - end if - flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) * unitadjn + & - qnm * (DONE - omega) * cnew(m) * unitadjm + flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & + qnm * (DONE - omega) * cnew(m) end do end do ! diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 36ff9aa7080..d3f78552d09 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -300,7 +300,6 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & real(DP) :: omega real(DP) :: hcoftmp real(DP) :: rhstmp - real(DP) :: unitadj ! ! -- initialize hcoftmp = DZERO @@ -308,12 +307,6 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ctmp = DZERO qbnd = DZERO ! - ! -- initialize unitadj, set its value if GWE model - unitadj = DONE - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%cpw(ientry) * this%rhow(ientry) - end if - ! ! -- retrieve node number, qbnd and iauxpos n = this%fmi%gwfpackages(ipackage)%nodelist(ientry) ! @@ -363,7 +356,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & if (qbnd <= DZERO) then hcoftmp = qbnd * omega else - rhstmp = -qbnd * ctmp * (DONE - omega) * unitadj + rhstmp = -qbnd * ctmp * (DONE - omega) end if ! ! -- end of active ibound From 60879c426a1c676cd8b84671ab190f79af146ea4 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 26 Jan 2023 14:10:19 -0800 Subject: [PATCH 079/212] XT3D changes necessary for conduction through solid matrix material --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 2 +- src/Model/ModelUtilities/Xt3dInterface.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index d6cab4e4f8d..66e32f1ae7b 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -291,7 +291,7 @@ subroutine dsp_ad(this) if (this%ixt3d == 0) then call this%calcdispcoef() else if (this%ixt3d > 0) then - call this%xt3d%xt3d_fcpc(this%dis%nodes, .false.) + call this%xt3d%xt3d_fcpc(this%dis%nodes, .true.) end if end if ! diff --git a/src/Model/ModelUtilities/Xt3dInterface.f90 b/src/Model/ModelUtilities/Xt3dInterface.f90 index b6ca168f187..ff095a21928 100644 --- a/src/Model/ModelUtilities/Xt3dInterface.f90 +++ b/src/Model/ModelUtilities/Xt3dInterface.f90 @@ -553,7 +553,7 @@ subroutine xt3d_fcpc(this, nodes, lsat) ! -- dummy class(Xt3dType) :: this integer(I4B), intent(in) :: nodes - logical, intent(in) :: lsat !< if true, then calculations made with saturated areas (should be false for dispersion) + logical, intent(in) :: lsat !< if true, then calculations made with saturated areas (should be false for solute dispersion; should be true for heat) ! -- local integer(I4B) :: n, m, ipos ! From 15b2e795fcd8942c3eac6284c0cb22a0afd76ade Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 26 Jan 2023 14:17:26 -0800 Subject: [PATCH 080/212] Preliminary work on latent heat associated with evaporation from the surface of a water body --- src/Model/GroundWaterEnergy/gwe1.f90 | 3 ++- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 10 +++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 44945d58f09..c34ba3bf8d2 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -438,7 +438,8 @@ subroutine gwe_ar(this) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & - this%xold, this%flowja, this%mst%cpw, this%mst%rhow) + this%xold, this%flowja, this%mst%cpw, & + this%mst%rhow, this%mst%latheatvap) ! -- Read and allocate package call packobj%bnd_ar() end do diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index bddef28c3f5..590f19e8046 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -719,20 +719,20 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, rhsval) integer(I4B), intent(inout) :: n2 real(DP), intent(inout), optional :: rrate real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval ! -- local real(DP) :: qbnd real(DP) :: heatlat real(DP) :: unitadj ! ------------------------------------------------------------------------------ - unitadj = this%bndType%cpw(n1) * this%bndType%rhow(n1) n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) - heatlat = this%bndType%rhow(n1) * this%latheatvap(n1) - if (present(rrate)) rrate = qbnd * heatlat !m^3/day * kg/m^3 * J/kg = J/day - if (present(rhsval)) rhsval = -1 * qbnd * heatlat - !if (present(hcofval)) hcofval = omega * qbnd + heatlat = this%bndType%rhow(n1) * this%latheatvap(n1) ! kg/m^3 * J/kg = J/m^3 + if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO ! ! -- return return From 1f6b3dedc87947187233893df262589caa458483 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 26 Jan 2023 14:21:27 -0800 Subject: [PATCH 081/212] Another latent heat change --- src/Model/GroundWaterTransport/tsp1apt1.f90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index aa35b65d5d1..c3a9e8f2803 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -2057,8 +2057,13 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & if (.not.present(cpw) .and. .not.present(rhow)) then call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) else - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja, & - cpw, rhow, latheatvap) + if (.not.present(latheatvap)) then + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja, & + cpw, rhow) + else + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja, & + cpw, rhow, latheatvap) + end if end if ! ! -- Set the pointers From 305f9512587295c6ffaf9521dbd7425e0003c252 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 26 Jan 2023 14:24:42 -0800 Subject: [PATCH 082/212] Address minor items related to the Labels module --- src/Model/GroundWaterTransport/tsp1apt1.f90 | 7 ++++--- src/Model/ModelUtilities/TspLabels.f90 | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index c3a9e8f2803..7878d3753b6 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -3233,8 +3233,8 @@ end subroutine apt_process_obsID12 subroutine apt_setup_tableobj(this) ! ****************************************************************************** ! apt_setup_tableobj -- Set up the table object that is used to write the apt -! conc data. The terms listed here must correspond in -! in the apt_ot method. +! concentration (or temperature) data. The terms listed +! here must correspond in the apt_ot method. ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -3278,7 +3278,8 @@ subroutine apt_setup_tableobj(this) call this%dvtab%initialize_column(text_temp, 10, alignment=TABCENTER) ! ! -- feature conc - text_temp = 'CONC' + !text_temp = 'CONC' + text_temp = this%tsplab%depvartype(1:4) call this%dvtab%initialize_column(text_temp, 12, alignment=TABCENTER) end if ! diff --git a/src/Model/ModelUtilities/TspLabels.f90 b/src/Model/ModelUtilities/TspLabels.f90 index 36919c7a429..3c3a401cb1e 100644 --- a/src/Model/ModelUtilities/TspLabels.f90 +++ b/src/Model/ModelUtilities/TspLabels.f90 @@ -96,7 +96,7 @@ end subroutine tsplabels_cr !< subroutine setTspLabels(this, tsptype, depvartype, depvarunit, depvarunitabbrev) class(TspLabelsType) :: this - character(len=*), intent(in) :: tsptype !< type of model, default is GWT6 + character(len=*), intent(in) :: tsptype !< type of model, default is GWT (alternative is GWE) character(len=*), intent(in) :: depvartype !< dependent variable type, default is "CONCENTRATION" character(len=*), intent(in) :: depvarunit !< units of dependent variable for writing to list file character(len=*), intent(in) :: depvarunitabbrev !< abbreviation of associated units From f781e143f10e0ad4a73949c964ab18e9c00e22af Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 26 Jan 2023 14:28:07 -0800 Subject: [PATCH 083/212] Changes related to conduction through dry cells --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 49 ++++++--- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 106 ++++++++++++++++---- 2 files changed, 120 insertions(+), 35 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 66e32f1ae7b..8f779b3fcbc 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -325,13 +325,17 @@ subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) call this%xt3d%xt3d_fc(kiter, matrix_sln, idxglo, rhs, cnew) else do n = 1, nodes - if (this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(n) == 0) cycle + end if idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 if (this%dis%con%mask(ipos) == 0) cycle m = this%dis%con%ja(ipos) if (m < n) cycle - if (this%fmi%ibdgwfsat0(m) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(m) == 0) cycle + end if isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) ! @@ -374,10 +378,14 @@ subroutine dsp_cq(this, cnew, flowja) call this%xt3d%xt3d_flowja(cnew, flowja) else do n = 1, this%dis%nodes - if (this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(n) == 0) cycle + end if do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) - if (this%fmi%ibdgwfsat0(m) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(m) == 0) cycle + end if isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) flowja(ipos) = flowja(ipos) + dnm * (cnew(m) - cnew(n)) @@ -780,6 +788,7 @@ subroutine calcdispellipse(this) real(DP) :: qzoqsquared real(DP) :: dstar real(DP) :: ktbulk ! TODO: Implement additional options for characterizing ktbulk (see Markle refs) + real(DP) :: qsw ! ------------------------------------------------------------------------------ ! ! -- loop through and calculate dispersion coefficients and angles @@ -793,7 +802,9 @@ subroutine calcdispellipse(this) this%angle1(n) = DZERO this%angle2(n) = DZERO this%angle3(n) = DZERO - if (this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(n) == 0) cycle + end if ! ! -- specific discharge qx = DZERO @@ -826,7 +837,8 @@ subroutine calcdispellipse(this) ! dstar = this%diffc(n) * this%porosity(n) !end if ktbulk = DZERO - if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) + if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) * & + this%fmi%gwfsat(n) if (this%ikts > 0) ktbulk = ktbulk + (DONE - this%porosity(n)) * this%kts(n) dstar = ktbulk / (this%cpw(n) * this%rhow(n)) ! @@ -842,9 +854,10 @@ subroutine calcdispellipse(this) end if ! ! -- Calculate and save the diagonal components of the dispersion tensor - this%d11(n) = al * q + dstar - this%d22(n) = at1 * q + dstar - this%d33(n) = at2 * q + dstar + qsw = q * this%fmi%gwfsat(n) + this%d11(n) = al * qsw + dstar + this%d22(n) = at1 * qsw + dstar + this%d33(n) = at2 * qsw + dstar ! ! -- Angles of rotation if velocity based dispersion tensor if (this%idisp > 0) then @@ -914,7 +927,9 @@ subroutine calcdispcoef(this) ! -- Proces connections nodes = size(this%d11) do n = 1, nodes - if (this%fmi%ibdgwfsat0(n) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(n) == 0) cycle + end if idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 ! @@ -925,7 +940,9 @@ subroutine calcdispcoef(this) if (m < n) cycle isympos = this%dis%con%jas(ipos) this%dispcoef(isympos) = DZERO - if (this%fmi%ibdgwfsat0(m) == 0) cycle + if (this%fmi%idryinactive /= 0) then + if (this%fmi%ibdgwfsat0(m) == 0) cycle + end if ! ! -- cell dimensions hwva = this%dis%con%hwva(isympos) @@ -938,8 +955,14 @@ subroutine calcdispcoef(this) botm = this%dis%bot(m) ! ! -- flow model information - satn = this%fmi%gwfsat(n) - satm = this%fmi%gwfsat(m) + if (this%fmi%idryinactive == 0) then + satn = this%fmi%ibdgwfsat0(n) + satm = this%fmi%ibdgwfsat0(m) + else + ! -- GWT approach + satn = this%fmi%gwfsat(n) + satm = this%fmi%gwfsat(m) + end if ! ! -- Calculate dispersion coefficient for cell n in the direction ! normal to the shared n-m face and for cell m in the direction diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index ec0d8b8b08e..6e3e53acfa5 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -47,6 +47,7 @@ module TspFmiModule real(DP), dimension(:), pointer, contiguous :: gwfhead => null() !< pointer to the GWF head array real(DP), dimension(:), pointer, contiguous :: gwfsat => null() !< pointer to the GWF saturation array integer(I4B), dimension(:), pointer, contiguous :: ibdgwfsat0 => null() !< mark cells with saturation = 0 to exclude from dispersion + integer(I4B), pointer :: idryinactive => null() !< mark cells with an additional flag to exclude from deactivation (gwe will simulate conduction through dry cells) real(DP), dimension(:), pointer, contiguous :: gwfstrgss => null() !< pointer to flow model QSTOSS real(DP), dimension(:), pointer, contiguous :: gwfstrgsy => null() !< pointer to flow model QSTOSY integer(I4B), pointer :: igwfstrgss => null() !< indicates if gwfstrgss is available @@ -92,6 +93,7 @@ module TspFmiModule procedure :: deallocate_gwfpackages procedure :: get_package_index procedure :: set_aptbudobj_pointer + procedure :: set_active_status end type TspFmiType @@ -204,6 +206,13 @@ subroutine fmi_df(this, dis, inssm) end if end if ! + ! -- Set flag that stops dry flows from being deactivated in a GWE transport + ! transport model since conduction will still be simulated. + ! 0: GWE (skip deactivation step); 1: GWT (default: use existing code) + if (this%tsplab%tsptype == 'GWE') then + this%idryinactive = 0 + end if + ! ! -- Return return end subroutine fmi_df @@ -318,30 +327,35 @@ subroutine fmi_ad(this, cnew) end do end if ! + ! -- set inactive transport cell status + if (this%idryinactive /= 0) then + call this%set_active_status(cnew) + end if + ! ! -- if flow cell is dry, then set gwt%ibound = 0 and conc to dry 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 transport cell is inactive for flow - if (this%ibound(n) > 0) then - if (this%gwfhead(n) == DHDRY) then - ! -- transport cell should be made inactive - this%ibound(n) = 0 - cnew(n) = DHDRY - call this%dis%noder_to_string(n, nodestr) - write (this%iout, '(/1x,a,1x,a,a,1x,a,1x,a,1x,G13.5)') & - 'WARNING: DRY CELL ENCOUNTERED AT', trim(nodestr), '; RESET AS & - &INACTIVE WITH DRY', trim(adjustl(this%tsplab%depvartype)), & - '=', DHDRY - end if - end if + !!!! + !!!! -- 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 transport cell is inactive for flow + !!!if (this%ibound(n) > 0) then + !!! if (this%gwfhead(n) == DHDRY) then + !!! ! -- transport cell should be made inactive + !!! this%ibound(n) = 0 + !!! cnew(n) = DHDRY + !!! call this%dis%noder_to_string(n, nodestr) + !!! write (this%iout, '(/1x,a,1x,a,a,1x,a,1x,a,1x,G13.5)') & + !!! 'WARNING: DRY CELL ENCOUNTERED AT', trim(nodestr), '; RESET AS & + !!! &INACTIVE WITH DRY', trim(adjustl(this%tsplab%depvartype)), & + !!! '=', DHDRY + !!! end if + !!!end if ! ! -- Convert dry transport cell to active if flow has rewet if (cnew(n) == DHDRY) then @@ -559,6 +573,7 @@ subroutine fmi_da(this) deallocate (this%aptbudobj) call mem_deallocate(this%flowcorrect) call mem_deallocate(this%ibdgwfsat0) + call mem_deallocate(this%idryinactive) if (this%flows_from_file) then call mem_deallocate(this%gwfstrgss) call mem_deallocate(this%gwfstrgsy) @@ -615,6 +630,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%iuhds, 'IUHDS', this%memoryPath) call mem_allocate(this%iumvr, 'IUMVR', this%memoryPath) call mem_allocate(this%nflowpack, 'NFLOWPACK', this%memoryPath) + call mem_allocate(this%idryinactive, "IDRYINACTIVE", this%memoryPath) ! ! -- Although not a scalar, allocate the advanced package transport ! budget object to zero so that it can be dynamically resized later @@ -630,6 +646,7 @@ subroutine allocate_scalars(this) this%iuhds = 0 this%iumvr = 0 this%nflowpack = 0 + this%idryinactive = 1 ! ! -- Return return @@ -713,6 +730,51 @@ subroutine allocate_arrays(this, nodes) return end subroutine allocate_arrays + !> @brief set gwt transport cell status + !! + !! Dry GWF cells are treated differently by GWT and GWE. Transport does not + !! occur in deactivated GWF cells; however, GWE still simulates conduction + !! through dry cells. + !< + subroutine set_active_status(this, cnew) + ! -- modules + use ConstantsModule, only: DHDRY + ! -- dummy + class(TspFmiType) :: this + real(DP), intent(inout), dimension(:) :: cnew + ! -- local + integer(I4B) :: n + character(len=15) :: nodestr +! ------------------------------------------------------------------------------ + ! + 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 transport cell is inactive for flow + if (this%ibound(n) > 0) then + if (this%gwfhead(n) == DHDRY) then + ! -- transport cell should be made inactive + this%ibound(n) = 0 + cnew(n) = DHDRY + call this%dis%noder_to_string(n, nodestr) + write (this%iout, '(/1x,a,1x,a,a,1x,a,1x,a,1x,G13.5)') & + 'WARNING: DRY CELL ENCOUNTERED AT', trim(nodestr), '; RESET AS & + &INACTIVE WITH DRY', trim(adjustl(this%tsplab%depvartype)), & + '=', DHDRY + end if + end if + end do + ! + ! -- return + return + end subroutine set_active_status + function gwfsatold(this, n, delt) result(satold) ! ****************************************************************************** ! gwfsatold -- calculate the groundwater cell head saturation for the end of From 55a94f6412eb31826bfc65060500a2330f5db2a5 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 26 Jan 2023 14:30:18 -0800 Subject: [PATCH 084/212] Changes I've been reluctant to push because it will all need to get backed out once the units issue is resolved --- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 6 +++ src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 18 +++++---- src/Model/GroundWaterTransport/tsp1apt1.f90 | 41 ++++++++++++--------- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 12 ++++++ src/Model/GroundWaterTransport/tsp1ssm1.f90 | 19 ++++++++-- 5 files changed, 68 insertions(+), 28 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 210d3b6a2f3..aa65cc04185 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -449,9 +449,15 @@ subroutine mst_bd(this, isuppress_output, model_budget) integer(I4B), intent(in) :: isuppress_output !< flag to supress output type(BudgetType), intent(inout) :: model_budget !< model budget object ! -- local + integer(I4B) :: n real(DP) :: rin real(DP) :: rout ! + ! -- for GWE, storage rate needs to have units adjusted + do n = 1, size(this%ratesto) + this%ratesto(n) = this%ratesto(n) * this%cpw(n) * this%rhow(n) + end do + ! ! -- sto call rate_accumulator(this%ratesto, rin, rout) call model_budget%addentry(rin, rout, delt, budtxt(1), & diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 590f19e8046..21ec6db02d0 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -701,7 +701,7 @@ subroutine sfe_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -711,7 +711,8 @@ end subroutine sfe_rain_term !> @brief Evaporative term !< - subroutine sfe_evap_term(this, ientry, n1, n2, rrate, rhsval) + subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) ! -- dummy class(GweSfeType) :: this integer(I4B), intent(in) :: ientry @@ -754,12 +755,11 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) real(DP) :: ctmp real(DP) :: unitadj ! ------------------------------------------------------------------------------ - unitadj = this%bndType%cpw(n1) * this%bndType%rhow(n1) n1 = this%flowbudptr%budterm(this%idxbudroff)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = unitadj * ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -768,6 +768,10 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) end subroutine sfe_roff_term !> @brief Inflow Term + !! + !! Accounts for energy added externally, for example, energy entering the + !! model domain via a specified flow in a stream channel. + !! !< subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- dummy @@ -786,7 +790,7 @@ subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -813,9 +817,9 @@ subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%cpw(n1) * this%rhow(n1) ! ! -- return return diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 7878d3753b6..2c83c4caa8b 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -835,6 +835,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: rhsval real(DP) :: hcofval ! ------------------------------------------------------------------------------ + unitadj = DONE !TODO: Avoid checking whether solute or energy ! ! -- call the specific method for the advanced transport package, such as ! what would be overridden by @@ -888,14 +889,14 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to apt row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, omega * qbnd) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) + call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) ! ! -- add to gwf row for apt connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) - call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) + call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd * unitadj) + call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd * unitadj) end if end do ! @@ -905,6 +906,10 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(j) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudfjf)%flow(j) + ! TODO - Clean this out + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(j) * this%bndtype%rhow(j) + end if if (qbnd <= DZERO) then omega = DONE else @@ -912,8 +917,8 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end if iposd = this%idxfjfdglo(j) iposoffd = this%idxfjfoffdglo(j) - call matrix_sln%add_value_pos(iposd, omega * qbnd) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) + call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) end do end if ! @@ -974,12 +979,12 @@ subroutine apt_cfupdate(this) if (this%iboundpak(n) /= 0) then qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) omega = DZERO - unitadj = DONE + unitadj = DONE !TODO: Avoid checking whether solute or energy if (qbnd < DZERO) omega = DONE if (associated(this%cpw).and.associated(this%rhow)) then unitadj = this%cpw(j) * this%rhow(j) end if - this%hcof(j) = -(DONE - omega) * qbnd + this%hcof(j) = -(DONE - omega) * unitadj * qbnd this%rhs(j) = omega * unitadj * qbnd * this%xnewpak(n) end if end do @@ -1893,7 +1898,7 @@ subroutine apt_solve(this) n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) this%hcof(j) = DZERO this%rhs(j) = DZERO - unitadj = DONE + unitadj = DONE ! Avoid checking whether solute or energy igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) if (associated(this%cpw).and.associated(this%rhow)) then @@ -1904,7 +1909,7 @@ subroutine apt_solve(this) this%rhs(j) = unitadj * qbnd * ctmp else ctmp = this%xnew(igwfnode) - this%hcof(j) = -qbnd + this%hcof(j) = -qbnd * unitadj end if c1 = unitadj * qbnd * ctmp this%dbuff(n) = this%dbuff(n) + c1 @@ -2536,9 +2541,9 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & call this%get_volumes(n1, v1, v0, delt) c0 = this%xoldpak(n1) c1 = this%xnewpak(n1) - if (present(rrate)) rrate = -c1 * v1 / delt + c0 * v0 / delt - if (present(rhsval)) rhsval = -c0 * v0 / delt - if (present(hcofval)) hcofval = -v1 / delt + if (present(rrate)) rrate = (-c1 * v1 / delt + c0 * v0 / delt) * this%cpw(n1) * this%rhow(n1) + if (present(rhsval)) rhsval = -c0 * v0 / delt * this%cpw(n1) * this%rhow(n1) + if (present(hcofval)) hcofval = -v1 / delt * this%cpw(n1) * this%rhow(n1) ! ! -- return return @@ -2562,7 +2567,7 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ! ------------------------------------------------------------------------------ ! ! -- If GWE package, adjust for thermal units - unitadj = DONE + unitadj = DONE ! TODO: Avoid checking whether solute or energy if (associated(this%cpw).and.associated(this%rhow)) then unitadj = this%cpw(ientry) * this%rhow(ientry) end if @@ -2573,7 +2578,7 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ctmp = this%xnewpak(n1) if (present(rrate)) rrate = unitadj * ctmp * qbnd if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * unitadj ! ! -- return return @@ -2597,10 +2602,10 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ! ------------------------------------------------------------------------------ ! ! -- If GWE package, adjust for thermal units - unitadj = DONE - !if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = DONE ! TODO: Avoid checking whether solute or energy + if (associated(this%cpw).and.associated(this%rhow)) then unitadj = this%cpw(ientry) * this%rhow(ientry) - !end if + end if ! n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(ientry) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 1589b18341a..6421f12d278 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -356,12 +356,24 @@ subroutine cnc_bd(this, model_budget) class(TspCncType) :: this type(BudgetType), intent(inout) :: model_budget ! -- local + integer(I4B) :: n real(DP) :: ratin real(DP) :: ratout real(DP) :: dum integer(I4B) :: isuppress_output ! ------------------------------------------------------------------------------ isuppress_output = 0 + ! + ! -- for GWE model types, storage rate needs to have units adjusted + if (this%tsplab%depvartype /= 'GWE') then + do n = 1, size(this%ratecncin) + this%ratecncin(n) = this%ratecncin(n) * this%cpw(n) * this%rhow(n) + end do + do n = 1, size(this%ratecncout) + this%ratecncout(n) = this%ratecncout(n) * this%cpw(n) * this%rhow(n) + end do + end if + ! call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratecncout(1:this%nbound), ratout, dum) call model_budget%addentry(ratin, ratout, delt, this%text, & diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index d3f78552d09..d724d589f6b 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -163,8 +163,8 @@ subroutine ssm_ar(this, dis, ibound, cnew, cpw, rhow) this%dis => dis this%ibound => ibound this%cnew => cnew - this%cpw => cpw - this%rhow => rhow + if (present(cpw)) this%cpw => cpw + if (present(rhow)) this%rhow => rhow ! ! -- Check to make sure that there are flow packages if (this%fmi%nflowpack == 0) then @@ -300,12 +300,14 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & real(DP) :: omega real(DP) :: hcoftmp real(DP) :: rhstmp + real(DP) :: unitadj ! ! -- initialize hcoftmp = DZERO rhstmp = DZERO ctmp = DZERO qbnd = DZERO + unitadj = DONE ! ! -- retrieve node number, qbnd and iauxpos n = this%fmi%gwfpackages(ipackage)%nodelist(ientry) @@ -352,6 +354,11 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & end if end if ! + ! -- If GWE transport model type, adjust units to energy + if (this%tsplab%tsptype == "GWE") then + unitadj = this%cpw(n) * this%rhow(n) + end if + ! ! -- Add terms based on qbnd sign if (qbnd <= DZERO) then hcoftmp = qbnd * omega @@ -365,7 +372,13 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! -- set requested values if (present(hcofval)) hcofval = hcoftmp if (present(rhsval)) rhsval = rhstmp - if (present(rrate)) rrate = hcoftmp * ctmp - rhstmp + if (present(rrate)) then + if (this%tsplab%tsptype /= 'GWE') then + rrate = hcoftmp * ctmp - rhstmp + else + rrate = hcoftmp * ctmp * unitadj - rhstmp * unitadj + endif + end if if (present(cssm)) cssm = ctmp if (present(qssm)) qssm = qbnd ! From 659b9c9c411b34a211906f99009266cd23725211 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 27 Jan 2023 10:10:52 -0800 Subject: [PATCH 085/212] gweSrc.f90 had slipped out of my solution and was behind. Readded to sln and getting it caught up --- src/Model/GroundWaterEnergy/gwe1src1.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index e0525db34d9..5faeafa1be0 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -8,6 +8,7 @@ module GweSrcModule use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList use BlockParserModule, only: BlockParserType + use MatrixModule ! implicit none ! @@ -173,7 +174,7 @@ subroutine src_cf(this, reset_mover) return end subroutine src_cf - subroutine src_fc(this, rhs, ia, idxglo, amatsln) + subroutine src_fc(this, rhs, ia, idxglo, matrix_sln) ! ************************************************************************** ! src_fc -- Copy rhs and hcof into solution rhs and amat ! ************************************************************************** @@ -185,7 +186,7 @@ subroutine src_fc(this, rhs, ia, idxglo, amatsln) real(DP), dimension(:), intent(inout) :: rhs integer(I4B), dimension(:), intent(in) :: ia integer(I4B), dimension(:), intent(in) :: idxglo - real(DP), dimension(:), intent(inout) :: amatsln + class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: i, n, ipos ! -------------------------------------------------------------------------- @@ -200,7 +201,7 @@ subroutine src_fc(this, rhs, ia, idxglo, amatsln) n = this%nodelist(i) rhs(n) = rhs(n) + this%rhs(i) ipos = ia(n) - amatsln(idxglo(ipos)) = amatsln(idxglo(ipos)) + this%hcof(i) + call matrix_sln%add_value_pos(idxglo(ipos), this%hcof(i)) ! ! -- If mover is active and mass is being withdrawn, ! store available mass (as positive value). From 54402a4faa0cc233a32d8fb488b462edee9cd924 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 30 Jan 2023 15:01:24 -0800 Subject: [PATCH 086/212] Implemented idryinactive flag wrong. Correcting to something that makes more sense. Related to f781e14 --- src/Model/Connection/GweInterfaceModel.f90 | 2 +- src/Model/Connection/GwtInterfaceModel.f90 | 2 +- src/Model/GroundWaterEnergy/gwe1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 113 ++++++++------------ 5 files changed, 49 insertions(+), 72 deletions(-) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index d97e5e713f9..b5d16db5755 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -129,7 +129,7 @@ subroutine gweifmod_df(this) ! define DISU disPtr => this%dis call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) - call this%fmi%fmi_df(this%dis, 0) + call this%fmi%fmi_df(this%dis, 0, 0) if (this%inadv > 0) then call this%adv%adv_df(adv_options) diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 1e6ae99c030..2991e665622 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -129,7 +129,7 @@ subroutine gwtifmod_df(this) ! define DISU disPtr => this%dis call this%gridConnection%getDiscretization(CastAsDisuType(disPtr)) - call this%fmi%fmi_df(this%dis, 0) + call this%fmi%fmi_df(this%dis, 0, 1) if (this%inadv > 0) then call this%adv%adv_df(adv_options) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index c34ba3bf8d2..5b1d7877744 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -300,7 +300,7 @@ subroutine gwe_df(this) ! ! -- Define packages and utility objects call this%dis%dis_df() - call this%fmi%fmi_df(this%dis, this%inssm) + call this%fmi%fmi_df(this%dis, this%inssm, 0) if (this%inmvt > 0) call this%mvt%mvt_df(this%dis) if (this%inadv > 0) call this%adv%adv_df() if (this%indsp > 0) call this%dsp%dsp_df(this%dis) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 3ce2aefae2b..10b1a49a1ea 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -303,7 +303,7 @@ subroutine gwt_df(this) ! ! -- Define packages and utility objects call this%dis%dis_df() - call this%fmi%fmi_df(this%dis, this%inssm) + call this%fmi%fmi_df(this%dis, this%inssm, 1) if (this%inmvt > 0) call this%mvt%mvt_df(this%dis) if (this%inadv > 0) call this%adv%adv_df() if (this%indsp > 0) call this%dsp%dsp_df(this%dis) diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index 6e3e53acfa5..f3fc98aaf2c 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -141,7 +141,7 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) return end subroutine fmi_cr - subroutine fmi_df(this, dis, inssm) + subroutine fmi_df(this, dis, inssm, idryinactive) ! ****************************************************************************** ! fmi_df -- Define ! ****************************************************************************** @@ -154,6 +154,7 @@ subroutine fmi_df(this, dis, inssm) class(TspFmiType) :: this class(DisBaseType), pointer, intent(in) :: dis integer(I4B), intent(in) :: inssm + integer(I4B), intent(in) :: idryinactive ! -- local ! -- formats character(len=*), parameter :: fmtfmi = & @@ -206,12 +207,10 @@ subroutine fmi_df(this, dis, inssm) end if end if ! - ! -- Set flag that stops dry flows from being deactivated in a GWE transport + ! -- Set flag that stops dry flows from being deactivated in a GWE ! transport model since conduction will still be simulated. ! 0: GWE (skip deactivation step); 1: GWT (default: use existing code) - if (this%tsplab%tsptype == 'GWE') then - this%idryinactive = 0 - end if + this%idryinactive = idryinactive ! ! -- Return return @@ -294,10 +293,6 @@ subroutine fmi_ad(this, cnew) real(DP), intent(inout), dimension(:) :: cnew ! -- local integer(I4B) :: n - integer(I4B) :: m - integer(I4B) :: ipos - real(DP) :: crewet, tflow, flownm - character(len=15) :: nodestr ! ------------------------------------------------------------------------------ ! ! -- Set flag to indicated that flows are being updated. For the case where @@ -332,65 +327,6 @@ subroutine fmi_ad(this, cnew) call this%set_active_status(cnew) end if ! - ! -- if flow cell is dry, then set gwt%ibound = 0 and conc to dry - 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 transport cell is inactive for flow - !!!if (this%ibound(n) > 0) then - !!! if (this%gwfhead(n) == DHDRY) then - !!! ! -- transport cell should be made inactive - !!! this%ibound(n) = 0 - !!! cnew(n) = DHDRY - !!! call this%dis%noder_to_string(n, nodestr) - !!! write (this%iout, '(/1x,a,1x,a,a,1x,a,1x,a,1x,G13.5)') & - !!! 'WARNING: DRY CELL ENCOUNTERED AT', trim(nodestr), '; RESET AS & - !!! &INACTIVE WITH DRY', trim(adjustl(this%tsplab%depvartype)), & - !!! '=', DHDRY - !!! end if - !!!end if - ! - ! -- Convert dry transport cell to active if flow has rewet - if (cnew(n) == DHDRY) then - if (this%gwfhead(n) /= DHDRY) then - ! - ! -- obtain weighted concentration/temperature - crewet = DZERO - tflow = DZERO - do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 - m = this%dis%con%ja(ipos) - flownm = this%gwfflowja(ipos) - if (flownm > 0) then - if (this%ibound(m) /= 0) then - crewet = crewet + cnew(m) * flownm - tflow = tflow + this%gwfflowja(ipos) - end if - end if - end do - if (tflow > DZERO) then - crewet = crewet / tflow - else - crewet = DZERO - end if - ! - ! -- cell is now wet - this%ibound(n) = 1 - cnew(n) = crewet - call this%dis%noder_to_string(n, nodestr) - write (this%iout, '(/1x,a,1x,a,1x,a,1x,a,1x,a,1x,G13.5)') & - 'DRY CELL REACTIVATED AT', trim(nodestr), 'WITH STARTING', & - trim(adjustl(this%tsplab%depvartype)), '=', crewet - end if - end if - end do - ! ! -- Return return end subroutine fmi_ad @@ -744,6 +680,9 @@ subroutine set_active_status(this, cnew) real(DP), intent(inout), dimension(:) :: cnew ! -- local integer(I4B) :: n + integer(I4B) :: m + integer(I4B) :: ipos + real(DP) :: crewet, tflow, flownm character(len=15) :: nodestr ! ------------------------------------------------------------------------------ ! @@ -770,6 +709,44 @@ subroutine set_active_status(this, cnew) end if end if end do + ! + ! -- if flow cell is dry, then set gwt%ibound = 0 and conc to dry + do n = 1, this%dis%nodes + ! + ! -- Convert dry transport cell to active if flow has rewet + if (cnew(n) == DHDRY) then + if (this%gwfhead(n) /= DHDRY) then + ! + ! -- obtain weighted concentration/temperature + crewet = DZERO + tflow = DZERO + do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 + m = this%dis%con%ja(ipos) + flownm = this%gwfflowja(ipos) + if (flownm > 0) then + if (this%ibound(m) /= 0) then + crewet = crewet + cnew(m) * flownm + tflow = tflow + this%gwfflowja(ipos) + end if + end if + end do + if (tflow > DZERO) then + crewet = crewet / tflow + else + crewet = DZERO + end if + ! + ! -- cell is now wet + this%ibound(n) = 1 + cnew(n) = crewet + call this%dis%noder_to_string(n, nodestr) + write (this%iout, '(/1x,a,1x,a,1x,a,1x,a,1x,a,1x,G13.5)') & + 'DRY CELL REACTIVATED AT', trim(nodestr), 'WITH STARTING', & + trim(adjustl(this%tsplab%depvartype)), '=', crewet + end if + end if + end do + ! ! -- return return From d021c7526abd991b41afc8e826636917be136b3b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 1 Mar 2023 15:17:22 -0800 Subject: [PATCH 087/212] need to simplify changes --- src/Model/GroundWaterTransport/gwt1.f90 | 47 ++++++------------- src/Model/TransportModel.f90 | 61 ++++++++++++++++++++++++- 2 files changed, 72 insertions(+), 36 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 10b1a49a1ea..98e1ef664c9 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -12,20 +12,12 @@ module GwtModule use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType, cunit, niunit use BaseModelModule, only: BaseModelType use BndModule, only: BndType, AddBndToList, GetBndFromList - use TspIcModule, only: TspIcType - use TspFmiModule, only: TspFmiType - use TspAdvModule, only: TspAdvType - use TspSsmModule, only: TspSsmType - use TspMvtModule, only: TspMvtType - use TspOcModule, only: TspOcType - use TspObsModule, only: TspObsType use GwtDspModule, only: GwtDspType use GwtMstModule, only: GwtMstType use BudgetModule, only: BudgetType - use TspLabelsModule, only: TspLabelsType + use TransportModelModule use MatrixModule implicit none @@ -34,29 +26,21 @@ module GwtModule public :: gwt_cr public :: GwtModelType public :: CastAsGwtModel + public :: niunit type, extends(TransportModelType) :: GwtModelType - type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels - type(TspIcType), pointer :: ic => null() ! initial conditions package - type(TspFmiType), pointer :: fmi => null() ! flow model interface - type(TspAdvType), pointer :: adv => null() ! advection package - type(TspSsmType), pointer :: ssm => null() ! source sink mixing package - type(TspMvtType), pointer :: mvt => null() ! mover transport package - type(TspOcType), pointer :: oc => null() ! output control package - type(TspObsType), pointer :: obs => null() ! observation package type(GwtMstType), pointer :: mst => null() ! mass storage and transfer package type(GwtDspType), pointer :: dsp => null() ! dispersion package - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: infmi => null() ! unit number FMI - integer(I4B), pointer :: inmvt => null() ! unit number MVT - integer(I4B), pointer :: inmst => null() ! unit number MST - integer(I4B), pointer :: inadv => null() ! unit number ADV - integer(I4B), pointer :: indsp => null() ! unit number DSP - integer(I4B), pointer :: inssm => null() ! unit number SSM - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: inobs => null() ! unit number OBS + ! integer(I4B), pointer :: inic => null() ! unit number IC + ! integer(I4B), pointer :: infmi => null() ! unit number FMI + ! integer(I4B), pointer :: inmvt => null() ! unit number MVT + ! integer(I4B), pointer :: inmst => null() ! unit number MST + ! integer(I4B), pointer :: inadv => null() ! unit number ADV + ! integer(I4B), pointer :: indsp => null() ! unit number DSP + ! integer(I4B), pointer :: inssm => null() ! unit number SSM + ! integer(I4B), pointer :: inoc => null() ! unit number OC + ! integer(I4B), pointer :: inobs => null() ! unit number OBS contains @@ -77,13 +61,8 @@ module GwtModule procedure :: allocate_scalars procedure, private :: package_create - procedure, private :: ftype_check + !procedure, private :: ftype_check procedure :: get_iasym => gwt_get_iasym - procedure, private :: gwt_ot_flow - procedure, private :: gwt_ot_flowja - procedure, private :: gwt_ot_dv - procedure, private :: gwt_ot_bdsummary - procedure, private :: gwt_ot_obs procedure :: load_input_context => gwt_load_input_context end type GwtModelType @@ -387,6 +366,7 @@ subroutine gwt_mc(this, matrix_sln) ! -- Find the position of each connection in the global ia, ja structure ! and store them in idxglo. call this%dis%dis_mc(this%moffset, this%idxglo, matrix_sln) + ! if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, matrix_sln) ! ! -- Map any package connections @@ -745,7 +725,6 @@ subroutine gwt_bd(this, icnvg, isuppress_output) packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_bd(this%budget) end do - ! ! -- Return return diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 839496be7b7..5a4b03e85e4 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -9,10 +9,25 @@ module TransportModelModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENFTYPE + use InputOutputModule, only: ParseLine + use VersionModule, only: write_listfile_header + use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC use SimVariablesModule, only: errmsg use NumericalModelModule, only: NumericalModelType + use NumericalPackageModule, only: NumericalPackageType use TspLabelsModule, only: TspLabelsType + use BndModule, only: BndType, GetBndFromList + use GwtMstModule, only: GwtMstType, CastAsGwtMstType + use GweMstModule, only: GweMstType + use TspIcModule, only: TspIcType + use TspFmiModule, only: TspFmiType + use TspAdvModule, only: TspAdvType + use TspSsmModule, only: TspSsmType + use TspMvtModule, only: TspMvtType + use TspOcModule, only: TspOcType + use TspObsModule, only: TspObsType + use BudgetModule, only: BudgetType + use MatrixModule implicit none @@ -23,7 +38,49 @@ module TransportModelModule type, extends(NumericalModelType) :: TransportModelType + ! Generalized transport package types common to either GWT or GWE + class(*), pointer :: tspmst => null() !< flavor of MST package associated with this model type (GWT or GWE) + type(TspAdvType), pointer :: adv => null() ! advection package + type(TspFmiType), pointer :: fmi => null() ! flow model interface + type(TspIcType), pointer :: ic => null() ! initial conditions package + type(TspMvtType), pointer :: mvt => null() ! mover transport package + type(TspObsType), pointer :: obs => null() ! observation package + type(TspOcType), pointer :: oc => null() ! output control package + type(TspSsmType), pointer :: ssm => null() ! source sink mixing package + type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels + type(BudgetType), pointer :: budget => null() ! budget object + integer(I4B), pointer :: inic => null() ! unit number IC + integer(I4B), pointer :: infmi => null() ! unit number FMI + integer(I4B), pointer :: inmvt => null() ! unit number MVT + integer(I4B), pointer :: inadv => null() ! unit number ADV + integer(I4B), pointer :: inssm => null() ! unit number SSM + integer(I4B), pointer :: inoc => null() ! unit number OC + integer(I4B), pointer :: inobs => null() ! unit number OBS + integer(I4B), pointer :: inmst => null() ! unit number MST + integer(I4B), pointer :: indsp => null() ! unit number DSP + contains + + ! -- public + procedure :: allocate_scalars + procedure, public :: tsp_cr + procedure, public :: tsp_df + procedure, public :: tsp_ac + procedure, public :: tsp_mc + procedure, public :: tsp_ar + procedure, public :: tsp_rp + procedure, public :: tsp_ad + procedure, public :: tsp_fc + procedure, public :: tsp_cc + procedure, public :: tsp_cq + procedure, public :: tsp_bd + procedure, public :: tsp_ot + procedure, private :: ftype_check + procedure, private :: tsp_ot_obs + procedure, private :: tsp_ot_flow + procedure, private :: tsp_ot_flowja + procedure, private :: tsp_ot_dv + procedure, private :: tsp_ot_bdsummary end type TransportModelType @@ -31,7 +88,7 @@ module TransportModelModule integer(I4B), parameter :: NIUNIT = 100 character(len=LENFTYPE), dimension(NIUNIT) :: cunit data cunit/'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 - 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', ' ', & ! 10 + 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 'API6 ', ' ', 'SFE6 ', ' ', ' ', & ! 25 From 6f6a0bf198a999350d9724d97318357ff7ce5570 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 2 Mar 2023 04:59:08 -0800 Subject: [PATCH 088/212] More fixes --- src/Model/GroundWaterTransport/gwt1.f90 | 141 ++--- src/Model/TransportModel.f90 | 669 +++++++++++++++++++++++- 2 files changed, 719 insertions(+), 91 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 98e1ef664c9..42488f88643 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -63,6 +63,11 @@ module GwtModule procedure, private :: package_create !procedure, private :: ftype_check procedure :: get_iasym => gwt_get_iasym + procedure, private :: gwt_ot_flow + procedure, private :: gwt_ot_flowja + procedure, private :: gwt_ot_dv + procedure, private :: gwt_ot_bdsummary + procedure, private :: gwt_ot_obs procedure :: load_input_context => gwt_load_input_context end type GwtModelType @@ -141,7 +146,7 @@ subroutine gwt_cr(filename, id, modelname) this%macronym = 'GWT' this%id = id ! - ! -- Instantiate generalized labels for later assignment + ! -- Instantiate generalized labels call tsplabels_cr(this%tsplab, this%name) ! ! -- Open namefile and set iout @@ -210,7 +215,7 @@ subroutine gwt_cr(filename, id, modelname) call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) ! ! -- Check to make sure that required ftype's have been specified - call this%ftype_check(namefile_obj, indis) + call this%TransportModelType%ftype_check(namefile_obj, indis) ! ! -- Create discretization object if (indis6 > 0) then @@ -1203,72 +1208,72 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & return end subroutine package_create - subroutine ftype_check(this, namefile_obj, indis) -! ****************************************************************************** -! ftype_check -- Check to make sure required input files have been specified -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors - use NameFileModule, only: NameFileType - ! -- dummy - class(GwtModelType) :: this - type(NameFileType), intent(in) :: namefile_obj - integer(I4B), intent(in) :: indis - ! -- local - character(len=LINELENGTH) :: errmsg - integer(I4B) :: i, iu - character(len=LENFTYPE), dimension(10) :: nodupftype = & - &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', 'DSP6 ', & - &'SSM6 ', 'OC6 ', 'OBS6 '/) -! ------------------------------------------------------------------------------ - ! - ! -- Check for IC6, DIS(u), and MST. Stop if not present. - if (this%inic == 0) then - write (errmsg, '(1x,a)') & - 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - end if - if (indis == 0) then - write (errmsg, '(1x,a)') & - 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - end if - if (this%inmst == 0) then - write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & - &PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - end if - if (count_errors() > 0) then - write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' - call store_error(errmsg) - end if - ! - ! -- Check to make sure that some GWT packages are not specified more - ! than once - do i = 1, size(nodupftype) - call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) - if (iu > 0) then - write (errmsg, '(1x, a, a, a)') & - 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & - ' NOT ALLOWED FOR GWT MODEL.' - call store_error(errmsg) - end if - end do - ! - ! -- Stop if errors - if (count_errors() > 0) then - write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & - trim(namefile_obj%filename) - call store_error(errmsg, terminate=.TRUE.) - end if - ! - ! -- return - return - end subroutine ftype_check +! subroutine ftype_check(this, namefile_obj, indis) +!! ****************************************************************************** +!! ftype_check -- Check to make sure required input files have been specified +!! ****************************************************************************** +!! +!! SPECIFICATIONS: +!! ------------------------------------------------------------------------------ +! ! -- modules +! use ConstantsModule, only: LINELENGTH +! use SimModule, only: store_error, count_errors +! use NameFileModule, only: NameFileType +! ! -- dummy +! class(GwtModelType) :: this +! type(NameFileType), intent(in) :: namefile_obj +! integer(I4B), intent(in) :: indis +! ! -- local +! character(len=LINELENGTH) :: errmsg +! integer(I4B) :: i, iu +! character(len=LENFTYPE), dimension(10) :: nodupftype = & +! &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', 'DSP6 ', & +! &'SSM6 ', 'OC6 ', 'OBS6 '/) +!! ------------------------------------------------------------------------------ +! ! +! ! -- Check for IC6, DIS(u), and MST. Stop if not present. +! if (this%inic == 0) then +! write (errmsg, '(1x,a)') & +! 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' +! call store_error(errmsg) +! end if +! if (indis == 0) then +! write (errmsg, '(1x,a)') & +! 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' +! call store_error(errmsg) +! end if +! if (this%inmst == 0) then +! write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & +! &PACKAGE NOT SPECIFIED.' +! call store_error(errmsg) +! end if +! if (count_errors() > 0) then +! write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' +! call store_error(errmsg) +! end if +! ! +! ! -- Check to make sure that some GWT packages are not specified more +! ! than once +! do i = 1, size(nodupftype) +! call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) +! if (iu > 0) then +! write (errmsg, '(1x, a, a, a)') & +! 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & +! ' NOT ALLOWED FOR GWT MODEL.' +! call store_error(errmsg) +! end if +! end do +! ! +! ! -- Stop if errors +! if (count_errors() > 0) then +! write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & +! trim(namefile_obj%filename) +! call store_error(errmsg, terminate=.TRUE.) +! end if +! ! +! ! -- return +! return +! end subroutine ftype_check !> @brief Cast to GwtModelType function CastAsGwtModel(model) result(gwtmodel) diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 5a4b03e85e4..32e03b58d13 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -17,7 +17,7 @@ module TransportModelModule use NumericalPackageModule, only: NumericalPackageType use TspLabelsModule, only: TspLabelsType use BndModule, only: BndType, GetBndFromList - use GwtMstModule, only: GwtMstType, CastAsGwtMstType + use GwtMstModule, only: GwtMstType use GweMstModule, only: GweMstType use TspIcModule, only: TspIcType use TspFmiModule, only: TspFmiType @@ -63,6 +63,7 @@ module TransportModelModule ! -- public procedure :: allocate_scalars + procedure, public :: ftype_check procedure, public :: tsp_cr procedure, public :: tsp_df procedure, public :: tsp_ac @@ -75,7 +76,6 @@ module TransportModelModule procedure, public :: tsp_cq procedure, public :: tsp_bd procedure, public :: tsp_ot - procedure, private :: ftype_check procedure, private :: tsp_ot_obs procedure, private :: tsp_ot_flow procedure, private :: tsp_ot_flowja @@ -94,8 +94,567 @@ module TransportModelModule 'API6 ', ' ', 'SFE6 ', ' ', ' ', & ! 25 75*' '/ -contains + contains + subroutine tsp_cr(this, filename, id, modelname) + ! -- modules + use SimModule, only: store_error + use MemoryManagerModule, only: mem_allocate + use MemoryHelperModule, only: create_mem_path + use GwfDisModule, only: dis_cr + use GwfDisvModule, only: disv_cr + use GwfDisuModule, only: disu_cr + use TspAdvModule, only: adv_cr + use TspFmiModule, only: fmi_cr + use TspIcModule, only: ic_cr + use TspMvtModule, only: mvt_cr + use TspObsModule, only: tsp_obs_cr + use TspOcModule, only: oc_cr + use TspSsmModule, only: ssm_cr + use BudgetModule, only: budget_cr + use ConstantsModule, only: LINELENGTH + use NameFileModule, only: NameFileType + use InputOutputModule, only: upcase + ! -- dummy + class(TransportModelType) :: this + character(len=*), intent(in) :: filename + integer(I4B), intent(in) :: id + character(len=*), intent(in) :: modelname + ! -- local + class(*), pointer :: mstobjPtr + type(NameFileType) :: namefile_obj + integer(I4B) :: indis, indis6, indisu6, indisv6 + character(len=LINELENGTH) :: errmsg + integer(I4B) :: nwords + integer(I4B) :: i + character(len=LINELENGTH), allocatable, dimension(:) :: words +! ------------------------------------------------------------------------------ + ! + ! -- Assign values + this%filename = filename + this%name = modelname + this%id = id + ! + ! -- Open namefile and set iout + call namefile_obj%init(this%filename, 0) + call namefile_obj%add_cunit(niunit, cunit) + call namefile_obj%openlistfile(this%iout) + ! + ! -- Write header to model list file + call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') + ! + ! -- Open files + call namefile_obj%openfiles(this%iout) + ! + ! -- + if (size(namefile_obj%opts) > 0) then + write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + end if + ! + ! -- parse options in the gwt name file + do i = 1, size(namefile_obj%opts) + call ParseLine(namefile_obj%opts(i), nwords, words) + call upcase(words(1)) + select case (words(1)) + case ('PRINT_INPUT') + this%iprpak = 1 + write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + 'FOR ALL MODEL STRESS PACKAGES' + case ('PRINT_FLOWS') + this%iprflow = 1 + write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + 'FOR ALL MODEL PACKAGES' + case ('SAVE_FLOWS') + this%ipakcb = -1 + write (this%iout, '(4x,a)') & + 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + case default + write (errmsg, '(4x,a,a,a,a)') & + 'UNKNOWN GWT NAMEFILE (', & + trim(adjustl(this%filename)), ') OPTION: ', & + trim(adjustl(namefile_obj%opts(i))) + call store_error(errmsg, terminate=.TRUE.) + end select + end do + ! + ! -- Assign unit numbers to attached modules, and remove + ! -- from unitnumber (by specifying 1 for iremove) + ! + indis = 0 + indis6 = 0 + indisu6 = 0 + indisv6 = 0 + call namefile_obj%get_unitnumber('DIS6', indis6, 1) + if (indis6 > 0) indis = indis6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) + if (indisu6 > 0) indis = indisu6 + if (indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) + if (indisv6 > 0) indis = indisv6 + call namefile_obj%get_unitnumber('ADV6', this%inadv, 1) + call namefile_obj%get_unitnumber('FMI6', this%infmi, 1) + call namefile_obj%get_unitnumber('IC6', this%inic, 1) + call namefile_obj%get_unitnumber('MVT6', this%inmvt, 1) + call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) + call namefile_obj%get_unitnumber('OC6', this%inoc, 1) + call namefile_obj%get_unitnumber('SSM6', this%inssm, 1) + ! + ! -- Check to make sure that required ftype's have been specified + call this%ftype_check(namefile_obj, indis) + ! + ! -- Create discretization object + if (indis6 > 0) then + call this%load_input_context('DIS6', this%name, 'DIS', indis, this%iout) + call dis_cr(this%dis, this%name, indis, this%iout) + elseif (indisu6 > 0) then + call this%load_input_context('DISU6', this%name, 'DISU', indis, this%iout) + call disu_cr(this%dis, this%name, indis, this%iout) + elseif (indisv6 > 0) then + call this%load_input_context('DISV6', this%name, 'DISV', indis, this%iout) + call disv_cr(this%dis, this%name, indis, this%iout) + end if + ! + ! -- Create utility objects + call budget_cr(this%budget, this%name, this%tsplab) + ! + ! -- Create packages that are tied directly to model + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call oc_cr(this%oc, this%name, this%inoc, this%iout) + call tsp_obs_cr(this%obs, this%inobs) + ! + ! -- Return + return + end subroutine tsp_cr + + subroutine tsp_df(this) +! ****************************************************************************** +! gwt_df -- Define packages of the model +! Subroutine: (1) call df routines for each package +! (2) set variables and pointers +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(TransportModelType) :: this + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_df + + subroutine tsp_ac(this, sparse) +! ****************************************************************************** +! gwt_ac -- Add the internal connections of this model to the sparse matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use SparseModule, only: sparsematrix + ! -- dummy variables + class(TransportModelType) :: this + type(sparsematrix), intent(inout) :: sparse + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_ac + + subroutine tsp_mc(this, matrix_sln) +! ****************************************************************************** +! gwt_mc -- Map the positions of this models connections in the +! numerical solution coefficient matrix. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TransportModelType) :: this + class(MatrixBaseType), pointer :: matrix_sln !< global system matrix + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_mc + + subroutine tsp_ar(this) +! ****************************************************************************** +! gwt_ar -- GroundWater Transport Model Allocate and Read +! Subroutine: (1) allocates and reads packages part of this model, +! (2) allocates memory for arrays part of this model object +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(TransportModelType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_ar + + subroutine tsp_rp(this) +! ****************************************************************************** +! gwt_rp -- GroundWater Transport Model Read and Prepare +! Subroutine: (1) calls package read and prepare routines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(TransportModelType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- Return + return + end subroutine tsp_rp + + subroutine tsp_ad(this) +! ****************************************************************************** +! gwt_ad -- GroundWater Transport Model Time Step Advance +! Subroutine: (1) calls package advance subroutines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(TransportModelType) :: this +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_ad + + subroutine tsp_fc(this, kiter, matrix_sln, inwtflag) +! ****************************************************************************** +! gwt_fc -- GroundWater Transport Model fill coefficients +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(TransportModelType) :: this + integer(I4B), intent(in) :: kiter + class(MatrixBaseType), pointer :: matrix_sln + integer(I4B), intent(in) :: inwtflag +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_fc + + subroutine tsp_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) +! ****************************************************************************** +! gwt_cc -- GroundWater Transport Model Final Convergence Check +! Subroutine: (1) calls package cc routines +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TransportModelType) :: this + integer(I4B), intent(in) :: innertot + integer(I4B), intent(in) :: kiter + integer(I4B), intent(in) :: iend + integer(I4B), intent(in) :: icnvgmod + character(len=LENPAKLOC), intent(inout) :: cpak + integer(I4B), intent(inout) :: ipak + real(DP), intent(inout) :: dpak + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- return + return + end subroutine tsp_cc + + subroutine tsp_cq(this, icnvg, isuppress_output) +! ****************************************************************************** +! tsp_cq -- Transport model calculate flow +! Subroutine: (1) Calculate intercell flows (flowja) +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy variables + class(TransportModelType) :: this + integer(I4B), intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- Return + return + end subroutine tsp_cq + + subroutine tsp_bd(this, icnvg, isuppress_output) +! ****************************************************************************** +! tsp_bd --GroundWater Transport Model Budget +! Subroutine: (1) Calculate intercell flows (flowja) +! (2) Calculate package contributions to model budget +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TransportModelType) :: this + integer(I4B), intent(in) :: icnvg + integer(I4B), intent(in) :: isuppress_output +! ------------------------------------------------------------------------------ + ! + ! -- Function extended by either GWT or GWE + ! + ! -- Return + return + end subroutine tsp_bd + + subroutine tsp_ot(this) +! ****************************************************************************** +! tsp_ot -- Transport Model Output +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use TdisModule, only: kstp, kper, tdis_ot, endofperiod + ! -- dummy + class(TransportModelType) :: this + ! -- local + integer(I4B) :: idvsave + integer(I4B) :: idvprint + integer(I4B) :: icbcfl + integer(I4B) :: icbcun + integer(I4B) :: ibudfl + integer(I4B) :: ipflag + ! -- formats + character(len=*), parameter :: fmtnocnvg = & + "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & + &I0,' OF STRESS PERIOD ',I0,'****')" +! ------------------------------------------------------------------------------ + ! + ! -- Set write and print flags + idvsave = 0 + idvprint = 0 + icbcfl = 0 + ibudfl = 0 + if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 + if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 + if (this%oc%oc_save('BUDGET')) icbcfl = 1 + if (this%oc%oc_print('BUDGET')) ibudfl = 1 + icbcun = this%oc%oc_save_unit('BUDGET') + ! + ! -- Override ibudfl and idvprint flags for nonconvergence + ! and end of period + ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) + ! + ! Calculate and save observations + call this%tsp_ot_obs() + ! + ! Save and print flows + call this%tsp_ot_flow(icbcfl, ibudfl, icbcun) + ! + ! Save and print dependent variables + call this%tsp_ot_dv(idvsave, idvprint, ipflag) + ! + ! Print budget summaries + call this%tsp_ot_bdsummary(ibudfl, ipflag) + ! + ! -- Timing Output; if any dependendent variables or budgets + ! are printed, then ipflag is set to 1. + if (ipflag == 1) call tdis_ot(this%iout) + ! + ! -- Write non-convergence message + if (this%icnvg == 0) then + write (this%iout, fmtnocnvg) kstp, kper + end if + ! + ! -- Return + return + end subroutine tsp_ot + + subroutine tsp_ot_obs(this) + class(TransportModelType) :: this + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! -- Calculate and save observations + call this%obs%obs_bd() + call this%obs%obs_ot() + + ! -- Calculate and save package obserations + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_bd_obs() + call packobj%bnd_ot_obs() + end do + + end subroutine tsp_ot_obs + + subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun) + class(TransportModelType) :: this + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(in) :: icbcun + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! -- Save TSP flows + call this%tsp_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) + if (this%inmst > 0) call this%tsp_ot_flowja(this%nja, this%flowja, & + icbcfl, icbcun) + if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) + if (this%inssm > 0) then + call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) + end if + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) + end do + + ! -- Save advanced package flows + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) + end do + if (this%inmvt > 0) then + call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) + end if + + ! -- Print Model (GWT or GWE) flows + ! no need to print flowja + ! no need to print mst + ! no need to print fmi + if (this%inssm > 0) then + call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) + end if + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) + end do + + ! -- Print advanced package flows + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) + end do + if (this%inmvt > 0) then + call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) + end if + + end subroutine tsp_ot_flow + + subroutine tsp_ot_flowja(this, nja, flowja, icbcfl, icbcun) +! ****************************************************************************** +! gwt_ot_flowja -- Write intercell flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(TransportModelType) :: this + integer(I4B), intent(in) :: nja + real(DP), dimension(nja), intent(in) :: flowja + integer(I4B), intent(in) :: icbcfl + integer(I4B), intent(in) :: icbcun + ! -- local + integer(I4B) :: ibinun + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! -- Set unit number for binary output + if (this%ipakcb < 0) then + ibinun = icbcun + elseif (this%ipakcb == 0) then + ibinun = 0 + else + ibinun = this%ipakcb + end if + if (icbcfl == 0) ibinun = 0 + ! + ! -- Write the face flows if requested + if (ibinun /= 0) then + call this%dis%record_connection_array(flowja, ibinun, this%iout) + end if + ! + ! -- Return + return + end subroutine tsp_ot_flowja + + subroutine tsp_ot_dv(this, idvsave, idvprint, ipflag) + class(TransportModelType) :: this + integer(I4B), intent(in) :: idvsave + integer(I4B), intent(in) :: idvprint + integer(I4B), intent(inout) :: ipflag + class(BndType), pointer :: packobj + integer(I4B) :: ip +! ------------------------------------------------------------------------------ + ! -- Print advanced package dependent variables + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_dv(idvsave, idvprint) + end do + + ! -- save head and print head + call this%oc%oc_ot(ipflag) + + end subroutine tsp_ot_dv + + subroutine tsp_ot_bdsummary(this, ibudfl, ipflag) + use TdisModule, only: kstp, kper, totim + class(TransportModelType) :: this + integer(I4B), intent(in) :: ibudfl + integer(I4B), intent(inout) :: ipflag + class(BndType), pointer :: packobj + integer(I4B) :: ip + + ! + ! -- Package budget summary + do ip = 1, this%bndlist%Count() + packobj => GetBndFromList(this%bndlist, ip) + call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) + end do + + ! -- mover budget summary + if (this%inmvt > 0) then + call this%mvt%mvt_ot_bdsummary(ibudfl) + end if + + ! -- model budget summary + if (ibudfl /= 0) then + ipflag = 1 + call this%budget%budget_ot(kstp, kper, this%iout) + end if + + ! -- Write to budget csv + call this%budget%writecsv(totim) + + end subroutine tsp_ot_bdsummary + subroutine allocate_scalars(this, modelname) ! ****************************************************************************** ! allocate_scalars -- Allocate memory for non-allocatable members @@ -110,32 +669,96 @@ subroutine allocate_scalars(this, modelname) character(len=*), intent(in) :: modelname ! ------------------------------------------------------------------------------ ! - ! -- allocate members from parent class + ! -- allocate members from (grand)parent class call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class - !call mem_allocate(this%inic , 'INIC', this%memoryPath) - !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) - !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) - !call mem_allocate(this%inmst, 'INMST', this%memoryPath) - !call mem_allocate(this%inadv, 'INADV', this%memoryPath) - !call mem_allocate(this%indsp, 'INDSP', this%memoryPath) - !call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - !call mem_allocate(this%inoc, 'INOC ', this%memoryPath) - !call mem_allocate(this%inobs, 'INOBS', this%memoryPath) - ! - !this%inic = 0 - !this%infmi = 0 - !this%inmvt = 0 - !this%inmst = 0 - !this%inadv = 0 - !this%indsp = 0 - !this%inssm = 0 - !this%inoc = 0 - !this%inobs = 0 + call mem_allocate(this%inic, 'INIC', this%memoryPath) + call mem_allocate(this%infmi, 'INFMI', this%memoryPath) + call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) + call mem_allocate(this%inadv, 'INADV', this%memoryPath) + call mem_allocate(this%inssm, 'INSSM', this%memoryPath) + call mem_allocate(this%inoc, 'INOC ', this%memoryPath) + call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + ! + this%inic = 0 + this%infmi = 0 + this%inmvt = 0 + this%inadv = 0 + this%inssm = 0 + this%inoc = 0 + this%inobs = 0 ! ! -- return return end subroutine allocate_scalars + + subroutine ftype_check(this, namefile_obj, indis) +! ****************************************************************************** +! ftype_check -- Check to make sure required input files have been specified +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH + use SimModule, only: store_error, count_errors + use NameFileModule, only: NameFileType + ! -- dummy + class(TransportModelType) :: this + type(NameFileType), intent(in) :: namefile_obj + integer(I4B), intent(in) :: indis + ! -- local + character(len=LINELENGTH) :: errmsg + integer(I4B) :: i, iu + character(len=LENFTYPE), dimension(10) :: nodupftype = & + &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', 'DSP6 ', & + &'SSM6 ', 'OC6 ', 'OBS6 '/) +! ------------------------------------------------------------------------------ + ! + ! -- Check for IC6, DIS(u), and MST. Stop if not present. + if (this%inic == 0) then + write (errmsg, '(1x,a)') & + 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + end if + if (indis == 0) then + write (errmsg, '(1x,a)') & + 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + end if + if (this%inmst == 0) then + write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & + &PACKAGE NOT SPECIFIED.' + call store_error(errmsg) + end if + if (count_errors() > 0) then + write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' + call store_error(errmsg) + end if + ! + ! -- Check to make sure that some GWT packages are not specified more + ! than once + do i = 1, size(nodupftype) + call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) + if (iu > 0) then + write (errmsg, '(1x, a, a, a)') & + 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & + ' NOT ALLOWED FOR GWT MODEL.' + call store_error(errmsg) + end if + end do + ! + ! -- Stop if errors + if (count_errors() > 0) then + write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & + trim(namefile_obj%filename) + call store_error(errmsg, terminate=.TRUE.) + end if + ! + ! -- return + return + end subroutine ftype_check + end module TransportModelModule From 6404ae0dbdcd861d20c89d735f82e3f201c9f9ab Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 2 Mar 2023 05:00:56 -0800 Subject: [PATCH 089/212] I thought these 'undo' changes had already been committed --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 38 ++++++------------------ 1 file changed, 9 insertions(+), 29 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 8f779b3fcbc..066cc95af7d 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -325,17 +325,13 @@ subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) call this%xt3d%xt3d_fc(kiter, matrix_sln, idxglo, rhs, cnew) else do n = 1, nodes - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(n) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(n) == 0) cycle idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 if (this%dis%con%mask(ipos) == 0) cycle m = this%dis%con%ja(ipos) if (m < n) cycle - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(m) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(m) == 0) cycle isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) ! @@ -378,14 +374,10 @@ subroutine dsp_cq(this, cnew, flowja) call this%xt3d%xt3d_flowja(cnew, flowja) else do n = 1, this%dis%nodes - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(n) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(n) == 0) cycle do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(m) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(m) == 0) cycle isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) flowja(ipos) = flowja(ipos) + dnm * (cnew(m) - cnew(n)) @@ -802,9 +794,7 @@ subroutine calcdispellipse(this) this%angle1(n) = DZERO this%angle2(n) = DZERO this%angle3(n) = DZERO - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(n) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(n) == 0) cycle ! ! -- specific discharge qx = DZERO @@ -927,9 +917,7 @@ subroutine calcdispcoef(this) ! -- Proces connections nodes = size(this%d11) do n = 1, nodes - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(n) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(n) == 0) cycle idiag = this%dis%con%ia(n) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 ! @@ -940,9 +928,7 @@ subroutine calcdispcoef(this) if (m < n) cycle isympos = this%dis%con%jas(ipos) this%dispcoef(isympos) = DZERO - if (this%fmi%idryinactive /= 0) then - if (this%fmi%ibdgwfsat0(m) == 0) cycle - end if + if (this%fmi%ibdgwfsat0(m) == 0) cycle ! ! -- cell dimensions hwva = this%dis%con%hwva(isympos) @@ -955,14 +941,8 @@ subroutine calcdispcoef(this) botm = this%dis%bot(m) ! ! -- flow model information - if (this%fmi%idryinactive == 0) then - satn = this%fmi%ibdgwfsat0(n) - satm = this%fmi%ibdgwfsat0(m) - else - ! -- GWT approach - satn = this%fmi%gwfsat(n) - satm = this%fmi%gwfsat(m) - end if + satn = this%fmi%ibdgwfsat0(n) + satm = this%fmi%ibdgwfsat0(m) ! ! -- Calculate dispersion coefficient for cell n in the direction ! normal to the shared n-m face and for cell m in the direction From 78d6b16966108140d8f7b1c696c1c46304c8e179 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 2 Mar 2023 05:03:04 -0800 Subject: [PATCH 090/212] Fixing a bug introduced while working on the GWE code. Bug found while running a GWT model with the latest modifications --- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 6421f12d278..e18515807be 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -361,19 +361,24 @@ subroutine cnc_bd(this, model_budget) real(DP) :: ratout real(DP) :: dum integer(I4B) :: isuppress_output + real(DP) :: unitadj ! ------------------------------------------------------------------------------ isuppress_output = 0 ! ! -- for GWE model types, storage rate needs to have units adjusted - if (this%tsplab%depvartype /= 'GWE') then - do n = 1, size(this%ratecncin) - this%ratecncin(n) = this%ratecncin(n) * this%cpw(n) * this%rhow(n) - end do - do n = 1, size(this%ratecncout) - this%ratecncout(n) = this%ratecncout(n) * this%cpw(n) * this%rhow(n) - end do + if (this%tsplab%tsptype /= 'GWE') then + unitadj = DONE + else + unitadj = this%cpw(n) * this%rhow(n) end if ! + do n = 1, size(this%ratecncin) + this%ratecncin(n) = this%ratecncin(n) * unitadj + end do + do n = 1, size(this%ratecncout) + this%ratecncout(n) = this%ratecncout(n) * unitadj + end do + ! call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratecncout(1:this%nbound), ratout, dum) call model_budget%addentry(ratin, ratout, delt, this%text, & From e0c9ad625bec80f490cd69498291ee09b81100eb Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 3 Mar 2023 23:56:45 -0800 Subject: [PATCH 091/212] committing first draft of uze before getting on the road --- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 1292 ++++++++++++++++++++++ 1 file changed, 1292 insertions(+) create mode 100644 src/Model/GroundWaterEnergy/gwe1uze1.f90 diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 new file mode 100644 index 00000000000..171131316d7 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -0,0 +1,1292 @@ +! -- Unsaturated Zone Flow Energy Transport Module +! -- todo: save the uze temperature into the uze aux variable? +! -- todo: calculate the uzf DENSE aux variable using temperature? +! -- todo: GWD and GWD-TO-MVR do not seem to be included; prob in UZF? +! +! UZF flows (flowbudptr) index var UZE term Transport Type +!--------------------------------------------------------------------------------- + +! -- terms from UZF that will be handled by parent APT Package +! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv +! GWF (aux FLOW-AREA) idxbudgwf GWF uzf2gwf +! STORAGE (aux VOLUME) idxbudsto none used for water volumes +! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) +! AUXILIARY none none none +! none none STORAGE (aux MASS) +! none none AUXILIARY none + +! -- terms from UZF that need to be handled here +! INFILTRATION idxbudinfl INFILTRATION q < 0: q * cwell, else q * cuser +! REJ-INF idxbudrinf REJ-INF q * cuze +! UZET idxbuduzet UZET q * cet +! REJ-INF-TO-MVR idxbudritm REJ-INF-TO-MVR q * cinfil? + +! -- terms from UZF that should be skipped + +module GweUzeModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, DONE, LINELENGTH + use SimModule, only: store_error + use BndModule, only: BndType, GetBndFromList + use TspFmiModule, only: TspFmiType + use UzfModule, only: UzfType + use ObserveModule, only: ObserveType + use TspAptModule, only: TspAptType, apt_process_obsID, & + apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType + use MatrixModule + implicit none + + public uze_create + + character(len=*), parameter :: ftype = 'UZE' + character(len=*), parameter :: flowtype = 'UZF' + character(len=16) :: text = ' UZE' + + type, extends(TspAptType) :: GweUzeType + + integer(I4B), pointer :: idxbudinfl => null() ! index of uzf infiltration terms in flowbudptr + integer(I4B), pointer :: idxbudrinf => null() ! index of rejected infiltration terms in flowbudptr + integer(I4B), pointer :: idxbuduzet => null() ! index of unsat et terms in flowbudptr + integer(I4B), pointer :: idxbudritm => null() ! index of rej infil to mover rate to mover terms in flowbudptr + real(DP), dimension(:), pointer, contiguous :: tempinfl => null() ! infiltration temperature + real(DP), dimension(:), pointer, contiguous :: tempuzet => null() ! unsat et temperature + + contains + + procedure :: bnd_da => uze_da + procedure :: allocate_scalars + procedure :: apt_allocate_arrays => uze_allocate_arrays + procedure :: find_apt_package => find_uze_package + procedure :: apt_fc_expanded => uze_fc_expanded + procedure :: pak_solve => uze_solve + procedure :: pak_get_nbudterms => uze_get_nbudterms + procedure :: pak_setup_budobj => uze_setup_budobj + procedure :: pak_fill_budobj => uze_fill_budobj + procedure :: uze_infl_term + procedure :: uze_rinf_term + procedure :: uze_uzet_term + procedure :: uze_ritm_term + procedure :: pak_df_obs => uze_df_obs + procedure :: pak_rp_obs => uze_rp_obs + procedure :: pak_bd_obs => uze_bd_obs + procedure :: pak_set_stressperiod => uze_set_stressperiod + procedure :: bnd_ac => uze_ac + procedure :: bnd_mc => uze_mc + + end type GweUzeType + +contains + + subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + fmi, tsplab) +! ****************************************************************************** +! uze_create -- Create a New UZE Package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab + ! -- local + type(GweUzeType), pointer :: uzeobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate (uzeobj) + packobj => uzeobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call uzeobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + + ! -- Store pointer to flow model interface. When the GwfGwt exchange is + ! created, it sets fmi%bndlist so that the GWT model has access to all + ! the flow packages + uzeobj%fmi => fmi + ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + uzeobj%tsplab => tsplab + ! + ! -- return + return + end subroutine uze_create + + subroutine find_uze_package(this) +! ****************************************************************************** +! find corresponding uze package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweUzeType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + class(BndType), pointer :: packobj + integer(I4B) :: ip, icount + integer(I4B) :: nbudterm + logical :: found +! ------------------------------------------------------------------------------ + ! + ! -- Initialize found to false, and error later if flow package cannot + ! be found + found = .false. + ! + ! -- If user is specifying flows in a binary budget file, then set up + ! the budget file reader, otherwise set a pointer to the flow package + ! budobj + if (this%fmi%flows_from_file) then + call this%fmi%set_aptbudobj_pointer(this%flowpackagename, this%flowbudptr) + if (associated(this%flowbudptr)) found = .true. + ! + else + if (associated(this%fmi%gwfbndlist)) then + ! -- Look through gwfbndlist for a flow package with the same name as + ! this transport package name + do ip = 1, this%fmi%gwfbndlist%Count() + packobj => GetBndFromList(this%fmi%gwfbndlist, ip) + if (packobj%packName == this%flowpackagename) then + found = .true. + ! + ! -- store BndType pointer to packobj, and then + ! use the select type to point to the budobj in flow package + this%flowpackagebnd => packobj + select type (packobj) + type is (UzfType) + this%flowbudptr => packobj%budobj + end select + end if + if (found) exit + end do + end if + end if + ! + ! -- error if flow package not found + if (.not. found) then + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + ! + ! -- allocate space for idxbudssm, which indicates whether this is a + ! special budget term or one that is a general source and sink + nbudterm = this%flowbudptr%nbudterm + call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) + ! + ! -- Process budget terms and identify special budget terms + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv + icount = 1 + do ip = 1, this%flowbudptr%nbudterm + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') + this%idxbudfjf = ip + this%idxbudssm(ip) = 0 + case ('GWF') + this%idxbudgwf = ip + this%idxbudssm(ip) = 0 + case ('STORAGE') + this%idxbudsto = ip + this%idxbudssm(ip) = 0 + case ('INFILTRATION') + this%idxbudinfl = ip + this%idxbudssm(ip) = 0 + case ('REJ-INF') + this%idxbudrinf = ip + this%idxbudssm(ip) = 0 + case ('UZET') + this%idxbuduzet = ip + this%idxbudssm(ip) = 0 + case ('REJ-INF-TO-MVR') + this%idxbudritm = ip + this%idxbudssm(ip) = 0 + case ('TO-MVR') + this%idxbudtmvr = ip + this%idxbudssm(ip) = 0 + case ('FROM-MVR') + this%idxbudfmvr = ip + this%idxbudssm(ip) = 0 + case ('AUXILIARY') + this%idxbudaux = ip + this%idxbudssm(ip) = 0 + case default + ! + ! -- set idxbudssm equal to a column index for where the temperatures + ! are stored in the tempbud(nbudssm, ncv) array + this%idxbudssm(ip) = icount + icount = icount + 1 + end select + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & + ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & + ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist + end do + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' + ! + ! -- Return + return + end subroutine find_uze_package + + subroutine uze_ac(this, moffset, sparse) +! ****************************************************************************** +! uze_ac -- Add package connection to matrix. Overrides apt_ac to fold the +! UZE heat balance terms into the row corresponding to the host cell +! and enforce thermal equilibrium between UZE and the GWE cell. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use MemoryManagerModule, only: mem_setptr + use SparseModule, only: sparsematrix + ! -- dummy + class(GweUzeType), intent(inout) :: this + integer(I4B), intent(in) :: moffset !< current models starting position in global matrix + type(sparsematrix), intent(inout) :: sparse + ! -- local + integer(I4B) :: i, ii + integer(I4B) :: n !< index of a uze object within the complete list of uze objects + integer(I4B) :: jj !< + integer(I4B) :: nglo !< index of uze object in global matrix + integer(I4B) :: jglo !< host cell's position in global matrix for a uze object + integer(I4B) :: idxn !< used for cross-check + integer(I4B) :: idxjj !< used for cross-check + integer(I4B) :: idxnglo !< used for cross-check + integer(I4B) :: idxjglo !< used for cross-check + ! -- format +! ------------------------------------------------------------------------------ + ! + ! -- Add package rows to sparse + if (this%imatrows /= 0) then + ! + ! -- diagonal on the row assoc. with the uze feature + do n = 1, this%ncv + nglo = moffset + this%dis%nodes + this%ioffset + n + call sparse%addconnection(nglo, nglo, 1) + end do + ! + ! -- add uze-to-gwe connections. For uze, this loop is + ! the same as its counterpart in apt_ac. + ! nlist: number of gwe cells with a connection to at least one uze object + do i = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(i) !< uze object position within uze object list + jj = this%flowbudptr%budterm(this%idxbudgwf)%id2(i) !< position of gwe cell to which uze feature is connected + nglo = moffset + this%dis%nodes + this%ioffset + n !< uze feature position + jglo = moffset + jj !< gwe cell position + call sparse%addconnection(nglo, jglo, 1) + call sparse%addconnection(jglo, nglo, 1) + end do + ! + ! -- For uze, add feature-to-feature connections (i.e., + ! vertically stacked UZ objects) to row corresponding + ! to the host cell. Terms added to row assoc. with host + ! cell go into columns associated with other uze features. + ! This approach deviates from the approach taken in apt_ac. + if (this%idxbudfjf /= 0) then + do i = 1, this%flowbudptr%budterm(this%idxbudfjf)%maxlist + n = this%flowbudptr%budterm(this%idxbudfjf)%id1(i) !< position of currently considered uze feature + jj = this%flowbudptr%budterm(this%idxbudfjf)%id2(i) !< position of connected uze feature + nglo = moffset + this%dis%nodes + this%ioffset + n !< global position of currently considered uze feature + jglo = moffset + this%dis%nodes + this%ioffset + jj !< global position of connected uze feature + ! -- if connected uze feature is upstream, find cell that hosts currently + ! considered uze feature and add connection to that cell's row +!! if (jj < n) then ! presumes that deeper uze object has id with larger integer + do ii = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist !< uze object id among uze objects + idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(ii) !< uze object position within uze object list + idxjj = this%flowbudptr%budterm(this%idxbudgwf)%id2(ii) !< position of gwe cell to which uze feature is connected + idxnglo = moffset + this%dis%nodes + this%ioffset + idxn !< uze feature global position + idxjglo = moffset + idxjj !< gwe cell global position + if (nglo == idxnglo) exit + end do + call sparse%addconnection(idxjglo, jglo, 1) +!! end if + end do + end if + end if + ! + ! -- return + return + end subroutine uze_ac + + subroutine uze_mc(this, moffset, matrix_sln) +! ****************************************************************************** +! uze_mc -- map package connection to matrix +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use SparseModule, only: sparsematrix + ! -- dummy + class(GweUzeType), intent(inout) :: this + integer(I4B), intent(in) :: moffset + class(MatrixBaseType), pointer :: matrix_sln + ! -- local + integer(I4B) :: n, j, iglo, jglo + integer(I4B) :: idxn, idxj, idxiglo, idxjglo + integer(I4B) :: ipos, idxpos + ! -- format +! ------------------------------------------------------------------------------ + ! + ! + ! -- allocate memory for index arrays + call this%apt_allocate_index_arrays() + ! + ! -- store index positions + if (this%imatrows /= 0) then + ! + ! -- Find the position of each connection in the global ia, ja structure + ! and store them in idxglo. idxglo allows this model to insert or + ! retrieve values into or from the global A matrix + ! apt rows + ! + ! -- feature diagonal in global matrix + do n = 1, this%ncv +!! this%idxlocnode(n) = this%dis%nodes + this%ioffset + n + iglo = moffset + this%dis%nodes + this%ioffset + n + this%idxpakdiag(n) = matrix_sln%get_position_diag(iglo) + end do + ! + ! -- cell to feature connection in global matrix + do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) + j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) + iglo = moffset + this%dis%nodes + this%ioffset + n + jglo = j + moffset + ! -- Note that this is where idxlocnode is set now; it is set + ! to the host cell global row rather than the feature global row + this%idxlocnode(n) = jglo + this%idxdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) + end do + ! + ! -- feature to cell connection in global matrix + do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) + j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) + iglo = j + moffset + jglo = moffset + this%dis%nodes + this%ioffset + n + this%idxsymdglo(ipos) = matrix_sln%get_position_diag(iglo) + this%idxsymoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) + end do + ! + ! -- feature to feature connection in global matrix + if (this%idxbudfjf /= 0) then + do ipos = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist + n = this%flowbudptr%budterm(this%idxbudfjf)%id1(ipos) !< position of currently considered uze feature + j = this%flowbudptr%budterm(this%idxbudfjf)%id2(ipos) !< position of connected uze feature + iglo = moffset + this%dis%nodes + this%ioffset + n !< global position of currently considered uze feature + jglo = moffset + this%dis%nodes + this%ioffset + j !< global position of connected uze feature + ! -- if connected uze feature is upstream, find cell that hosts currently + ! considered uze feature and map connection to that cell's row +!! if (j < n) then + do idxpos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(idxpos) !< uze object position within uze object list + idxj = this%flowbudptr%budterm(this%idxbudgwf)%id2(idxpos) !< gwe cell list position + idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature's global position + idxiglo = moffset + idxj !< uze cell's global position + if (iglo == idxjglo) exit + end do + this%idxfjfdglo(ipos) = matrix_sln%get_position_diag(idxiglo) + this%idxfjfoffdglo(ipos) = matrix_sln%get_position(idxiglo, jglo) +!! end if + end do + end if + end if + ! + ! -- return + return + end subroutine uze_mc + + subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) +! ****************************************************************************** +! uze_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() +! in order to add matrix terms specifically for this package +! **************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweUzeType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + class(MatrixBaseType), pointer :: matrix_sln + ! -- local + integer(I4B) :: j, n, n1, n2 + integer(I4B) :: iloc, ihostcell + integer(I4B) :: iposd, iposoffd + integer(I4B) :: ipossymd, ipossymoffd + real(DP) :: cold + real(DP) :: qbnd + real(DP) :: omega + real(DP) :: unitadj + real(DP) :: rrate + real(DP) :: rhsval + real(DP) :: hcofval +! ------------------------------------------------------------------------------ + ! + ! -- TODO: This needs to be cleaned up, unitadj should be based on + ! scalars that are spatially constant. + ! At some point, unitadj's name should be adapted to represent the + ! this physics it captures. For example, could be something like + ! cpw_vol which denotes volume-based heat capacity. Its stored + ! value would represent cpw * rhow + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) + end if + ! + ! -- add infiltration contribution + ! uze does not put feature balance coefficients in the row + ! associated with the feature. Instead, these coefficients are + ! moved into the row assoicated with cell hosting the uze feature + if (this%idxbudinfl /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudinfl)%nlist + call this%uze_infl_term(j, n1, n2, rrate, rhsval, hcofval) + ipossymd = this%idxsymdglo(j) + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row +!! iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(ipossymd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add rejected infiltration contribution + if (this%idxbudrinf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrinf)%nlist + call this%uze_rinf_term(j, n1, n2, rrate, rhsval, hcofval) + ipossymd = this%idxsymdglo(j) + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row +!! iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(ipossymd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add unsaturated et contribution + if (this%idxbuduzet /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbuduzet)%nlist + call this%uze_uzet_term(j, n1, n2, rrate, rhsval, hcofval) + ipossymd = this%idxsymdglo(j) + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row +!! iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(ipossymd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add rejected infiltration to mover contribution + if (this%idxbudritm /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudritm)%nlist + call this%uze_ritm_term(j, n1, n2, rrate, rhsval, hcofval) + ipossymd = this%idxsymdglo(j) + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row +!! iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(ipossymd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- For UZE, content of apt_fc_expanded placed here as the approach is to + ! completely override apt_fc_expanded() with what follows + ! + ! -- mass (or energy) storage in features + do n = 1, this%ncv + cold = this%xoldpak(n) +!! iloc = this%idxlocnode(n) +!! iposd = this%idxpakdiag(n) +!! call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) +!! call matrix_sln%add_value_pos(iposd, hcofval) + ipossymd = this%idxsymdglo(n) ! TO DO: convince ourselves that "n" is ok here, since it's not aloop over "j" + iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell global row +!! iposd = this%idxpakdiag(n1) + call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) + call matrix_sln%add_value_pos(ipossymd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + ! + ! -- add to mover contribution + if (this%idxbudtmvr /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudtmvr)%nlist + call this%apt_tmvr_term(j, n1, n2, rrate, rhsval, hcofval) +!! iloc = this%idxlocnode(n1) +!! iposd = this%idxpakdiag(n1) +!! call matrix_sln%add_value_pos(iposd, hcofval) + ipossymd = this%idxsymdglo(j) + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row +!! iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(ipossymd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add from mover contribution + if (this%idxbudfmvr /= 0) then + do n = 1, this%ncv + rhsval = this%qmfrommvr(n) + iloc = this%idxlocnode(n) + rhs(iloc) = rhs(iloc) - rhsval + end do + end if + ! + ! -- go through each apt-gwf connection + do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + ! + ! -- set n to feature number and process if active feature + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + if (this%iboundpak(n) /= 0) then + ! + ! -- set acoef and rhs to negative so they are relative to apt and not gwt + qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) + omega = DZERO + if (qbnd < DZERO) omega = DONE + ! + ! -- this code altered from its counterpart appearing in apt; this equates + ! uze temperature to cell temperature using the feature's row + iposd = this%idxdglo(j) + iposoffd = this%idxoffdglo(j) + call matrix_sln%add_value_pos(iposd, DONE) + call matrix_sln%add_value_pos(iposoffd, -DONE) + ! + ! -- add to gwf row for apt connection + ipossymd = this%idxsymdglo(j) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd * unitadj) + call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd * unitadj) + end if + end do + ! + ! -- go through each apt-apt connection + if (this%idxbudfjf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist + n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(j) + n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(j) + qbnd = this%flowbudptr%budterm(this%idxbudfjf)%flow(j) + if (qbnd <= DZERO) then + omega = DONE + else + omega = DZERO + end if + iposd = this%idxfjfdglo(j) + iposoffd = this%idxfjfoffdglo(j) + call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) + end do + end if + ! + ! -- Return + return + end subroutine uze_fc_expanded + + subroutine uze_solve(this) +! ****************************************************************************** +! uze_solve -- add terms specific to the unsaturated zone to the explicit +! unsaturated-zone solve +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType) :: this + ! -- local + integer(I4B) :: j + integer(I4B) :: n1, n2 + real(DP) :: rrate +! ------------------------------------------------------------------------------ + ! + ! -- add infiltration contribution + if (this%idxbudinfl /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudinfl)%nlist + call this%uze_infl_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add rejected infiltration contribution + if (this%idxbudrinf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrinf)%nlist + call this%uze_rinf_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add unsaturated et contribution + if (this%idxbuduzet /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbuduzet)%nlist + call this%uze_uzet_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add rejected infiltration to mover contribution + if (this%idxbudritm /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudritm)%nlist + call this%uze_ritm_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- Return + return + end subroutine uze_solve + + function uze_get_nbudterms(this) result(nbudterms) +! ****************************************************************************** +! uze_get_nbudterms -- function to return the number of budget terms just for +! this package. This overrides function in parent. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweUzeType) :: this + ! -- return + integer(I4B) :: nbudterms + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Number of budget terms is 4 + nbudterms = 0 + if (this%idxbudinfl /= 0) nbudterms = nbudterms + 1 + if (this%idxbudrinf /= 0) nbudterms = nbudterms + 1 + if (this%idxbuduzet /= 0) nbudterms = nbudterms + 1 + if (this%idxbudritm /= 0) nbudterms = nbudterms + 1 + ! + ! -- Return + return + end function uze_get_nbudterms + + subroutine uze_setup_budobj(this, idx) +! ****************************************************************************** +! uze_setup_budobj -- Set up the budget object that stores all the unsaturated- +! zone flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(inout) :: idx + ! -- local + integer(I4B) :: maxlist, naux + character(len=LENBUDTXT) :: text +! ------------------------------------------------------------------------------ + ! + ! -- + text = ' INFILTRATION' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudinfl)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + + ! + ! -- + if (this%idxbudrinf /= 0) then + text = ' REJ-INF' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudrinf)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + + ! + ! -- + if (this%idxbuduzet /= 0) then + text = ' UZET' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbuduzet)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + + ! + ! -- + if (this%idxbudritm /= 0) then + text = ' INF-REJ-TO-MVR' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudritm)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + + ! + ! -- return + return + end subroutine uze_setup_budobj + + subroutine uze_fill_budobj(this, idx, x, ccratin, ccratout) +! ****************************************************************************** +! uze_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(inout) :: idx + real(DP), dimension(:), intent(in) :: x + real(DP), intent(inout) :: ccratin + real(DP), intent(inout) :: ccratout + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: nlist + real(DP) :: q + ! -- formats +! ----------------------------------------------------------------------------- + + ! -- INFILTRATION + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%uze_infl_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- REJ-INF + if (this%idxbudrinf /= 0) then + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudrinf)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%uze_rinf_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + end if + + ! -- UZET + if (this%idxbuduzet /= 0) then + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbuduzet)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%uze_uzet_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + end if + + ! -- REJ-INF-TO-MVR + if (this%idxbudritm /= 0) then + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudritm)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%uze_ritm_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + end if + + ! + ! -- return + return + end subroutine uze_fill_budobj + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweUzeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%idxbudinfl, 'IDXBUDINFL', this%memoryPath) + call mem_allocate(this%idxbudrinf, 'IDXBUDRINF', this%memoryPath) + call mem_allocate(this%idxbuduzet, 'IDXBUDUZET', this%memoryPath) + call mem_allocate(this%idxbudritm, 'IDXBUDRITM', this%memoryPath) + ! + ! -- Initialize + this%idxbudinfl = 0 + this%idxbudrinf = 0 + this%idxbuduzet = 0 + this%idxbudritm = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine uze_allocate_arrays(this) +! ****************************************************************************** +! uze_allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweUzeType), intent(inout) :: this + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- time series + call mem_allocate(this%tempinfl, this%ncv, 'TEMPINFL', this%memoryPath) + call mem_allocate(this%tempuzet, this%ncv, 'TEMPUZET', this%memoryPath) + ! + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() + ! + ! -- Initialize + do n = 1, this%ncv + this%tempinfl(n) = DZERO + this%tempuzet(n) = DZERO + end do + ! + ! + ! -- Return + return + end subroutine uze_allocate_arrays + + subroutine uze_da(this) +! ****************************************************************************** +! uze_da +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweUzeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- deallocate scalars + call mem_deallocate(this%idxbudinfl) + call mem_deallocate(this%idxbudrinf) + call mem_deallocate(this%idxbuduzet) + call mem_deallocate(this%idxbudritm) + ! + ! -- deallocate time series + call mem_deallocate(this%tempinfl) + call mem_deallocate(this%tempuzet) + ! + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() + ! + ! -- Return + return + end subroutine uze_da + + subroutine uze_infl_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! uze_infl_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp + real(DP) :: h, r +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudinfl)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudinfl)%id2(ientry) + ! -- note that qbnd is negative for negative infiltration + qbnd = this%flowbudptr%budterm(this%idxbudinfl)%flow(ientry) + if (qbnd < DZERO) then + ctmp = this%xnewpak(n1) + h = qbnd + r = DZERO + else + ctmp = this%tempinfl(n1) + h = DZERO + r = -qbnd * ctmp + end if + if (present(rrate)) rrate = qbnd * ctmp + if (present(rhsval)) rhsval = r + if (present(hcofval)) hcofval = h + ! + ! -- return + return + end subroutine uze_infl_term + + subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! uze_rinf_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudrinf)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudrinf)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudrinf)%flow(ientry) + ctmp = this%tempinfl(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine uze_rinf_term + + subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! uze_uzet_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp + real(DP) :: omega +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbuduzet)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbuduzet)%id2(ientry) + ! -- note that qbnd is negative for uzet + qbnd = this%flowbudptr%budterm(this%idxbuduzet)%flow(ientry) + ctmp = this%tempuzet(n1) + if (this%xnewpak(n1) < ctmp) then + omega = DONE + else + omega = DZERO + end if + if (present(rrate)) & + rrate = omega * qbnd * this%xnewpak(n1) + & + (DONE - omega) * qbnd * ctmp + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp + if (present(hcofval)) hcofval = omega * qbnd + ! + ! -- return + return + end subroutine uze_uzet_term + + subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! uze_ritm_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudritm)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudritm)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudritm)%flow(ientry) + ctmp = this%tempinfl(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine uze_ritm_term + + subroutine uze_df_obs(this) +! ****************************************************************************** +! uze_df_obs -- obs are supported? +! -- Store observation type supported by APT package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweUzeType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for temperature observation type. + call this%obs%StoreObsType('temperature', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for flow between uze cells. + call this%obs%StoreObsType('flow-ja-face', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID12 + ! + ! -- Store obs type and assign procedure pointer + ! for from-mvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- to-mvr not supported for uze + !call this%obs%StoreObsType('to-mvr', .true., indx) + !this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for constant observation type. + call this%obs%StoreObsType('constant', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type: uze + call this%obs%StoreObsType('uze', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('infiltration', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('rej-inf', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('uzet', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('rej-inf-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + return + end subroutine uze_df_obs + + !> @brief Process package specific obs + !! + !! Method to process specific observations for this package. + !! + !< + subroutine uze_rp_obs(this, obsrv, found) + ! -- dummy + class(GweUzeType), intent(inout) :: this !< package class + type(ObserveType), intent(inout) :: obsrv !< observation object + logical, intent(inout) :: found !< indicate whether observation was found + ! -- local + ! + found = .true. + select case (obsrv%ObsTypeId) + case ('INFILTRATION') + call this%rp_obs_byfeature(obsrv) + case ('REJ-INF') + call this%rp_obs_byfeature(obsrv) + case ('UZET') + call this%rp_obs_byfeature(obsrv) + case ('REJ-INF-TO-MVR') + call this%rp_obs_byfeature(obsrv) + case default + found = .false. + end select + ! + return + end subroutine uze_rp_obs + + subroutine uze_bd_obs(this, obstypeid, jj, v, found) +! ****************************************************************************** +! uze_bd_obs -- calculate observation value and pass it back to APT +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType), intent(inout) :: this + character(len=*), intent(in) :: obstypeid + real(DP), intent(inout) :: v + integer(I4B), intent(in) :: jj + logical, intent(inout) :: found + ! -- local + integer(I4B) :: n1, n2 +! ------------------------------------------------------------------------------ + ! + found = .true. + select case (obstypeid) + case ('INFILTRATION') + if (this%iboundpak(jj) /= 0 .and. this%idxbudinfl > 0) then + call this%uze_infl_term(jj, n1, n2, v) + end if + case ('REJ-INF') + if (this%iboundpak(jj) /= 0 .and. this%idxbudrinf > 0) then + call this%uze_rinf_term(jj, n1, n2, v) + end if + case ('UZET') + if (this%iboundpak(jj) /= 0 .and. this%idxbuduzet > 0) then + call this%uze_uzet_term(jj, n1, n2, v) + end if + case ('REJ-INF-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudritm > 0) then + call this%uze_ritm_term(jj, n1, n2, v) + end if + case default + found = .false. + end select + ! + return + end subroutine uze_bd_obs + + subroutine uze_set_stressperiod(this, itemno, keyword, found) +! ****************************************************************************** +! uze_set_stressperiod -- Set a stress period attribute for using keywords. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TimeSeriesManagerModule, only: read_value_or_time_series_adv + ! -- dummy + class(GweUzeType), intent(inout) :: this + integer(I4B), intent(in) :: itemno + character(len=*), intent(in) :: keyword + logical, intent(inout) :: found + ! -- local + character(len=LINELENGTH) :: temp_text + integer(I4B) :: ierr + integer(I4B) :: jj + real(DP), pointer :: bndElem => null() + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! INFILTRATION + ! UZET + ! + found = .true. + select case (keyword) + case ('INFILTRATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(temp_text) + jj = 1 + bndElem => this%tempinfl(itemno) + call read_value_or_time_series_adv(temp_text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'INFILTRATION') + case ('UZET') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(temp_text) + jj = 1 + bndElem => this%tempuzet(itemno) + call read_value_or_time_series_adv(temp_text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'UZET') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. + end select + ! +999 continue + ! + ! -- return + return + end subroutine uze_set_stressperiod + +end module GweUzeModule From 5eeb582cc14b83e9eef54c32377bd4f65fa529af Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 15 Mar 2023 10:23:25 -0700 Subject: [PATCH 092/212] Updates on UZE indexing --- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 207 +++++++++++++++-------- 1 file changed, 136 insertions(+), 71 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 171131316d7..3a8aa425f69 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -293,8 +293,8 @@ subroutine uze_ac(this, moffset, sparse) call sparse%addconnection(nglo, nglo, 1) end do ! - ! -- add uze-to-gwe connections. For uze, this loop is - ! the same as its counterpart in apt_ac. + ! -- add uze-to-gwe connections. For uze, this particular do loop + ! is the same as its counterpart in apt_ac. ! nlist: number of gwe cells with a connection to at least one uze object do i = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(i) !< uze object position within uze object list @@ -307,8 +307,8 @@ subroutine uze_ac(this, moffset, sparse) ! ! -- For uze, add feature-to-feature connections (i.e., ! vertically stacked UZ objects) to row corresponding - ! to the host cell. Terms added to row assoc. with host - ! cell go into columns associated with other uze features. + ! to the host cell. Terms added to the row associated with host + ! cell are added to columns associated with other uze features. ! This approach deviates from the approach taken in apt_ac. if (this%idxbudfjf /= 0) then do i = 1, this%flowbudptr%budterm(this%idxbudfjf)%maxlist @@ -376,23 +376,32 @@ subroutine uze_mc(this, moffset, matrix_sln) ! ! -- cell to feature connection in global matrix do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) - j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) - iglo = moffset + this%dis%nodes + this%ioffset + n - jglo = j + moffset - ! -- Note that this is where idxlocnode is set now; it is set - ! to the host cell global row rather than the feature global row - this%idxlocnode(n) = jglo + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) !< feature number + j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) !< cell number + iglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index + jglo = j + moffset !< cell row index + ! -- Note that this is where idxlocnode is set for uze; it is set +!! ! to the host cell global row rather than the feature global row +!! this%idxlocnode(n) = jglo + ! to the host cell local row index rather than the feature local + ! row index ! jiffylube: LOCAL row + this%idxlocnode(n) = j ! jiffylube: LOCAL row + ! -- for connection ipos in list of feature-cell connections, + ! global positions of feature-row diagonal and off-diagonal + ! corresponding to the cell this%idxdglo(ipos) = matrix_sln%get_position_diag(iglo) this%idxoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) end do ! ! -- feature to cell connection in global matrix do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) - j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) - iglo = j + moffset - jglo = moffset + this%dis%nodes + this%ioffset + n + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) !< feature number + j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) !< cell number + iglo = j + moffset !< cell row index + jglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index + ! -- for connection ipos in list of feature-cell connections, + ! global positions of cell-row diagonal and off-diagonal + ! corresponding to the feature this%idxsymdglo(ipos) = matrix_sln%get_position_diag(iglo) this%idxsymoffdglo(ipos) = matrix_sln%get_position(iglo, jglo) end do @@ -400,20 +409,25 @@ subroutine uze_mc(this, moffset, matrix_sln) ! -- feature to feature connection in global matrix if (this%idxbudfjf /= 0) then do ipos = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist - n = this%flowbudptr%budterm(this%idxbudfjf)%id1(ipos) !< position of currently considered uze feature - j = this%flowbudptr%budterm(this%idxbudfjf)%id2(ipos) !< position of connected uze feature + n = this%flowbudptr%budterm(this%idxbudfjf)%id1(ipos) !< number of currently considered uze feature + j = this%flowbudptr%budterm(this%idxbudfjf)%id2(ipos) !< number of connected uze feature iglo = moffset + this%dis%nodes + this%ioffset + n !< global position of currently considered uze feature jglo = moffset + this%dis%nodes + this%ioffset + j !< global position of connected uze feature ! -- if connected uze feature is upstream, find cell that hosts currently ! considered uze feature and map connection to that cell's row -!! if (j < n) then +!! if (j < n) then ! jiffylube: determine ordering of features; is id1 always upstream of id2? do idxpos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(idxpos) !< uze object position within uze object list - idxj = this%flowbudptr%budterm(this%idxbudgwf)%id2(idxpos) !< gwe cell list position - idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature's global position - idxiglo = moffset + idxj !< uze cell's global position - if (iglo == idxjglo) exit + idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(idxpos) !< feature number + idxj = this%flowbudptr%budterm(this%idxbudgwf)%id2(idxpos) !< cell number + ! jiffylube: should be able to base search simply on (idxn == n) + idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature row index + idxiglo = moffset + idxj !< cell row index + if (idxjglo == iglo) exit end do + ! -- for connection ipos in list of feature-feature connections, + ! global positions of host-cell-row entries corresponding to + ! (in the same columns as) the feature-id1-row diagonal and the + ! feature-id1-row off-diagonal corresponding to feature id2 this%idxfjfdglo(ipos) = matrix_sln%get_position_diag(idxiglo) this%idxfjfoffdglo(ipos) = matrix_sln%get_position(idxiglo, jglo) !! end if @@ -434,6 +448,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use TdisModule, only: kper, kstp ! -- dummy class(GweUzeType) :: this real(DP), dimension(:), intent(inout) :: rhs @@ -452,29 +467,32 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval + real(DP) :: dummy ! ------------------------------------------------------------------------------ ! ! -- TODO: This needs to be cleaned up, unitadj should be based on ! scalars that are spatially constant. ! At some point, unitadj's name should be adapted to represent the - ! this physics it captures. For example, could be something like + ! physics it captures. For example, could be something like ! cpw_vol which denotes volume-based heat capacity. Its stored ! value would represent cpw * rhow if (associated(this%cpw).and.associated(this%rhow)) then unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) end if + unitadj = DONE ! jiffylube: kluge debug ! ! -- add infiltration contribution ! uze does not put feature balance coefficients in the row ! associated with the feature. Instead, these coefficients are - ! moved into the row assoicated with cell hosting the uze feature + ! moved into the row associated with cell hosting the uze feature if (this%idxbudinfl /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudinfl)%nlist call this%uze_infl_term(j, n1, n2, rrate, rhsval, hcofval) - ipossymd = this%idxsymdglo(j) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index !! iposd = this%idxpakdiag(n1) - call matrix_sln%add_value_pos(ipossymd, hcofval) +!! call matrix_sln%add_value_pos(iposd, hcofval) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if @@ -483,10 +501,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudrinf /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudrinf)%nlist call this%uze_rinf_term(j, n1, n2, rrate, rhsval, hcofval) - ipossymd = this%idxsymdglo(j) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index !! iposd = this%idxpakdiag(n1) - call matrix_sln%add_value_pos(ipossymd, hcofval) +!! call matrix_sln%add_value_pos(iposd, hcofval) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if @@ -495,10 +514,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbuduzet /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbuduzet)%nlist call this%uze_uzet_term(j, n1, n2, rrate, rhsval, hcofval) - ipossymd = this%idxsymdglo(j) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index !! iposd = this%idxpakdiag(n1) - call matrix_sln%add_value_pos(ipossymd, hcofval) +!! call matrix_sln%add_value_pos(iposd, hcofval) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if @@ -507,10 +527,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudritm /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudritm)%nlist call this%uze_ritm_term(j, n1, n2, rrate, rhsval, hcofval) - ipossymd = this%idxsymdglo(j) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index !! iposd = this%idxpakdiag(n1) - call matrix_sln%add_value_pos(ipossymd, hcofval) +!! call matrix_sln%add_value_pos(iposd, hcofval) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if @@ -525,11 +546,13 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) !! iposd = this%idxpakdiag(n) !! call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) !! call matrix_sln%add_value_pos(iposd, hcofval) - ipossymd = this%idxsymdglo(n) ! TO DO: convince ourselves that "n" is ok here, since it's not aloop over "j" - iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell global row -!! iposd = this%idxpakdiag(n1) + iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index + ipossymoffd = this%idxsymoffdglo(n) ! TO DO: convince ourselves that "n" is ok here, since it's not aloop over "j" + if (kper == 3 .and. kstp == 2) then + dummy = 2.2 + end if call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) - call matrix_sln%add_value_pos(ipossymd, hcofval) + call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do ! @@ -539,11 +562,16 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) call this%apt_tmvr_term(j, n1, n2, rrate, rhsval, hcofval) !! iloc = this%idxlocnode(n1) !! iposd = this%idxpakdiag(n1) +!! +!! NOTE: originally was iposd, but changed to idxsymdglo on the first +!! modification. It was later realized we needed idxsymoffdglo. +!! (If this works, consider changing 'ipossymd' to 'ipossymoffd' +!! !! call matrix_sln%add_value_pos(iposd, hcofval) - ipossymd = this%idxsymdglo(j) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell global row + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index !! iposd = this%idxpakdiag(n1) - call matrix_sln%add_value_pos(ipossymd, hcofval) + ipossymoffd = this%idxsymoffdglo(j) !< TODO: Need + call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if @@ -552,7 +580,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudfmvr /= 0) then do n = 1, this%ncv rhsval = this%qmfrommvr(n) - iloc = this%idxlocnode(n) + iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index rhs(iloc) = rhs(iloc) - rhsval end do end if @@ -564,11 +592,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) if (this%iboundpak(n) /= 0) then ! - ! -- set acoef and rhs to negative so they are relative to apt and not gwt - qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) - omega = DZERO - if (qbnd < DZERO) omega = DONE - ! +!! ! -- set acoef and rhs to negative so they are relative to apt and not gwt +!! qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) ! jiffylube: shouldn't need these 3 lines +!! omega = DZERO +!! if (qbnd < DZERO) omega = DONE +!! ! ! -- this code altered from its counterpart appearing in apt; this equates ! uze temperature to cell temperature using the feature's row iposd = this%idxdglo(j) @@ -576,11 +604,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) call matrix_sln%add_value_pos(iposd, DONE) call matrix_sln%add_value_pos(iposoffd, -DONE) ! - ! -- add to gwf row for apt connection - ipossymd = this%idxsymdglo(j) - ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd * unitadj) - call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd * unitadj) + !! -- add to gwf row for apt connection (recharge) + !!ipossymd = this%idxsymdglo(j) + !!ipossymoffd = this%idxsymoffdglo(j) + !!call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd * unitadj) + !!call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd * unitadj) end if end do ! @@ -595,8 +623,8 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) else omega = DZERO end if - iposd = this%idxfjfdglo(j) - iposoffd = this%idxfjfoffdglo(j) + iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row + iposoffd = this%idxfjfoffdglo(j) !< position of feature-id2 column in feature id1's host-cell row call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) end do @@ -958,7 +986,16 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & real(DP) :: qbnd real(DP) :: ctmp real(DP) :: h, r + real(DP) :: unitadj ! ------------------------------------------------------------------------------ + ! + ! -- TODO: these unitadj values should be cleaned-up as denoted in + ! uze_fc_expanded + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) + end if + unitadj = DONE ! jiffylube: kluge debug + ! n1 = this%flowbudptr%budterm(this%idxbudinfl)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudinfl)%id2(ientry) ! -- note that qbnd is negative for negative infiltration @@ -972,9 +1009,9 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & h = DZERO r = -qbnd * ctmp end if - if (present(rrate)) rrate = qbnd * ctmp - if (present(rhsval)) rhsval = r - if (present(hcofval)) hcofval = h + if (present(rrate)) rrate = qbnd * ctmp * unitadj + if (present(rhsval)) rhsval = r * unitadj + if (present(hcofval)) hcofval = h * unitadj ! ! -- return return @@ -999,14 +1036,23 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp + real(DP) :: unitadj ! ------------------------------------------------------------------------------ + ! + ! -- TODO: these unitadj values should be cleaned-up as denoted in + ! uze_fc_expanded + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) + end if + unitadj = DONE ! jiffylube: kluge debug + ! n1 = this%flowbudptr%budterm(this%idxbudrinf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudrinf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrinf)%flow(ientry) ctmp = this%tempinfl(n1) - if (present(rrate)) rrate = ctmp * qbnd - if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(rrate)) rrate = ctmp * qbnd * unitadj + if (present(rhsval)) rhsval = DZERO * unitadj + if (present(hcofval)) hcofval = qbnd * unitadj ! ! -- return return @@ -1031,8 +1077,18 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: omega + real(DP) :: omega + real(DP) :: unitadj ! ------------------------------------------------------------------------------ + ! + ! -- TODO: these unitadj values should be cleaned-up as denoted in + ! uze_fc_expanded + ! -- TODO: Latent heat will likely need to play a role here at some point + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) + end if + unitadj = DONE ! jiffylube: kluge debug + ! n1 = this%flowbudptr%budterm(this%idxbuduzet)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbuduzet)%id2(ientry) ! -- note that qbnd is negative for uzet @@ -1044,10 +1100,10 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & omega = DZERO end if if (present(rrate)) & - rrate = omega * qbnd * this%xnewpak(n1) + & - (DONE - omega) * qbnd * ctmp - if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp - if (present(hcofval)) hcofval = omega * qbnd + rrate = (omega * qbnd * this%xnewpak(n1) + & + (DONE - omega) * qbnd * ctmp) * unitadj ! jiffylube: added parens so unitadj multiplies the whole expression + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * unitadj + if (present(hcofval)) hcofval = omega * qbnd * unitadj ! ! -- return return @@ -1072,14 +1128,23 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp + real(DP) :: unitadj ! ------------------------------------------------------------------------------ + ! + ! -- TODO: these unitadj values should be cleaned-up as denoted in + ! uze_fc_expanded + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) + end if + unitadj = DONE ! jiffylube: kluge debug + ! n1 = this%flowbudptr%budterm(this%idxbudritm)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudritm)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudritm)%flow(ientry) ctmp = this%tempinfl(n1) - if (present(rrate)) rrate = ctmp * qbnd - if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(rrate)) rrate = ctmp * qbnd * unitadj + if (present(rhsval)) rhsval = DZERO * unitadj + if (present(hcofval)) hcofval = qbnd * unitadj ! ! -- return return From a998aa2a5f8c842085db19be474b32c890f7e65b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 16 Mar 2023 05:55:58 -0700 Subject: [PATCH 093/212] Pushing some loose-ends --- msvs/mf6core.vfproj | 10 +- src/Model/GroundWaterEnergy/gwe1.f90 | 123 ++++++++---------- src/Model/GroundWaterEnergy/gwe1dspidm.f90 | 15 ++- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 10 +- src/Model/GroundWaterFlow/gwf3dis8idm.f90 | 15 ++- src/Model/GroundWaterFlow/gwf3npf8idm.f90 | 15 ++- src/Model/GroundWaterTransport/gwt1.f90 | 31 ++--- src/Model/GroundWaterTransport/gwt1dspidm.f90 | 15 ++- src/Model/GroundWaterTransport/tsp1apt1.f90 | 53 +++++--- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 2 +- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 2 +- .../ModelUtilities/SfrCrossSectionUtils.f90 | 6 +- src/Model/TransportModel.f90 | 33 ++++- src/Solution/NumericalSolution.f90 | 2 +- 14 files changed, 206 insertions(+), 126 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 9c2a98b86eb..be707443e30 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -82,7 +82,9 @@ - + + + @@ -199,6 +201,9 @@ + + + @@ -206,9 +211,6 @@ - - - diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 5b1d7877744..adbd7166c9a 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -7,20 +7,12 @@ module GweModule use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType, cunit, niunit use BaseModelModule, only: BaseModelType use BndModule, only: BndType, AddBndToList, GetBndFromList - use TspIcModule, only: TspIcType - use TspFmiModule, only: TspFmiType - use TspOcModule, only: TspOcType - use TspAdvModule, only: TspAdvType - use TspSsmModule, only: TspSsmType - use TspMvtModule, only: TspMvtType - use TspObsModule, only: TspObsType use GweDspModule, only: GweDspType use GweMstModule, only: GweMstType use BudgetModule, only: BudgetType - use TspLabelsModule, only: TspLabelsType + use TransportModelModule use MatrixModule implicit none @@ -32,26 +24,18 @@ module GweModule type, extends(TransportModelType) :: GweModelType - type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels - type(TspIcType), pointer :: ic => null() ! initial conditions package - type(TspFmiType), pointer :: fmi => null() ! flow model interface - type(TspAdvType), pointer :: adv => null() ! advection package - type(TspSsmType), pointer :: ssm => null() ! source sink mixing package - type(TspMvtType), pointer :: mvt => null() ! mover transport package - type(TspOcType), pointer :: oc => null() ! output control package - type(TspObsType), pointer :: obs => null() ! observation package type(GweMstType), pointer :: mst => null() ! mass storage and transfer package type(GweDspType), pointer :: dsp => null() ! dispersion package - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: infmi => null() ! unit number FMI - integer(I4B), pointer :: inmvt => null() ! unit number MVT - integer(I4B), pointer :: inmst => null() ! unit number MST - integer(I4B), pointer :: inadv => null() ! unit number ADV - integer(I4B), pointer :: indsp => null() ! unit number DSP - integer(I4B), pointer :: inssm => null() ! unit number SSM - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: inobs => null() ! unit number OBS + !type(BudgetType), pointer :: budget => null() ! budget object + !integer(I4B), pointer :: inic => null() ! unit number IC + !integer(I4B), pointer :: infmi => null() ! unit number FMI + !integer(I4B), pointer :: inmvt => null() ! unit number MVT + !integer(I4B), pointer :: inmst => null() ! unit number MST + !integer(I4B), pointer :: inadv => null() ! unit number ADV + !integer(I4B), pointer :: indsp => null() ! unit number DSP + !integer(I4B), pointer :: inssm => null() ! unit number SSM + !integer(I4B), pointer :: inoc => null() ! unit number OC + !integer(I4B), pointer :: inobs => null() ! unit number OBS contains @@ -70,9 +54,9 @@ module GweModule procedure :: model_da => gwe_da procedure :: model_bdentry => gwe_bdentry - procedure :: allocate_scalars => allocate_scalars_gwe + procedure :: allocate_scalars procedure, private :: package_create - procedure, private :: ftype_check + !procedure, private :: ftype_check procedure :: get_iasym => gwe_get_iasym procedure, private :: gwe_ot_flow procedure, private :: gwe_ot_flowja @@ -105,6 +89,7 @@ subroutine gwe_cr(filename, id, modelname) use ListsModule, only: basemodellist use BaseModelModule, only: AddBaseModelToList use SimModule, only: store_error, count_errors + use NameFileModule, only: NameFileType use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CompilerVersion use MemoryManagerModule, only: mem_allocate @@ -123,7 +108,6 @@ subroutine gwe_cr(filename, id, modelname) use GweDspModule, only: dsp_cr use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr - use NameFileModule, only: NameFileType ! -- dummy character(len=*), intent(in) :: filename integer(I4B), intent(in) :: id @@ -138,6 +122,7 @@ subroutine gwe_cr(filename, id, modelname) class(BaseModelType), pointer :: model integer(I4B) :: nwords character(len=LINELENGTH), allocatable, dimension(:) :: words + cunit(10) = 'TMP6 ' ! ------------------------------------------------------------------------------ ! @@ -157,7 +142,7 @@ subroutine gwe_cr(filename, id, modelname) this%macronym = 'GWE' this%id = id ! - ! -- Instantiate generalized labels for later assignment + ! -- Instantiate generalized labels call tsplabels_cr(this%tsplab, this%name) ! ! -- Open namefile and set iout @@ -166,13 +151,12 @@ subroutine gwe_cr(filename, id, modelname) call namefile_obj%openlistfile(this%iout) ! ! -- Write header to model list file - call write_listfile_header(this%iout, 'GROUNDWATER ENERGY TRANSPORT '// & - 'MODEL (GWE)') + call write_listfile_header(this%iout, 'GROUNDWATER ENERGY TRANSPORT MODEL (GWE)') ! ! -- Open files call namefile_obj%openfiles(this%iout) ! - ! -- Process OPTIONS block + ! -- if (size(namefile_obj%opts) > 0) then write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' end if @@ -227,7 +211,7 @@ subroutine gwe_cr(filename, id, modelname) call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) ! ! -- Check to make sure that required ftype's have been specified - call this%ftype_check(namefile_obj, indis) + call this%TransportModelType%ftype_check(namefile_obj, indis) ! ! -- Create discretization object if (indis6 > 0) then @@ -253,11 +237,10 @@ subroutine gwe_cr(filename, id, modelname) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & - this%tsplab) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) - call tsp_obs_cr(this%obs, this%inobs) + call tsp_obs_cr(this%obs, this%inobs) ! ! -- Create stress packages ipakid = 1 @@ -384,6 +367,7 @@ subroutine gwe_mc(this, matrix_sln) ! -- Find the position of each connection in the global ia, ja structure ! and store them in idxglo. call this%dis%dis_mc(this%moffset, this%idxglo, matrix_sln) + ! if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, matrix_sln) ! ! -- Map any package connections @@ -846,8 +830,9 @@ subroutine gwe_ot_flow(this, icbcfl, ibudfl, icbcun) call this%gwe_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) - if (this%inssm > 0) call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, & - icbcun=icbcun) + if (this%inssm > 0) then + call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) + end if do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) @@ -866,8 +851,9 @@ subroutine gwe_ot_flow(this, icbcfl, ibudfl, icbcun) ! no need to print flowja ! no need to print mst ! no need to print fmi - if (this%inssm > 0) call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, & - icbcun=0) + if (this%inssm > 0) then + call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) + end if do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) @@ -1023,15 +1009,7 @@ subroutine gwe_da(this) end do ! ! -- Scalars - call mem_deallocate(this%inic) - call mem_deallocate(this%infmi) - call mem_deallocate(this%inadv) - call mem_deallocate(this%indsp) - call mem_deallocate(this%inssm) - call mem_deallocate(this%inmst) - call mem_deallocate(this%inmvt) - call mem_deallocate(this%inoc) - call mem_deallocate(this%inobs) + call this%TransportModelType%tsp_da() ! ! -- NumericalModelType call this%NumericalModelType%model_da() @@ -1093,11 +1071,12 @@ function gwe_get_iasym(this) result(iasym) packobj => GetBndFromList(this%bndlist, ip) if (packobj%iasym /= 0) iasym = 1 end do + ! ! -- return return end function gwe_get_iasym - subroutine allocate_scalars_gwe(this, modelname) + subroutine allocate_scalars(this, modelname) ! ****************************************************************************** ! allocate_scalars -- Allocate memory for non-allocatable members ! ****************************************************************************** @@ -1115,29 +1094,29 @@ subroutine allocate_scalars_gwe(this, modelname) call this%TransportModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class - call mem_allocate(this%inic, 'INIC', this%memoryPath) - call mem_allocate(this%infmi, 'INFMI', this%memoryPath) - call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) - call mem_allocate(this%inadv, 'INADV', this%memoryPath) - call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - call mem_allocate(this%inoc, 'INOC ', this%memoryPath) - call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + !call mem_allocate(this%inic, 'INIC', this%memoryPath) + !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) + !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) call mem_allocate(this%inmst, 'INMST', this%memoryPath) + !call mem_allocate(this%inadv, 'INADV', this%memoryPath) call mem_allocate(this%indsp, 'INDSP', this%memoryPath) - !! - this%inic = 0 - this%infmi = 0 - this%inmvt = 0 - this%inadv = 0 - this%inssm = 0 - this%inoc = 0 - this%inobs = 0 + !call mem_allocate(this%inssm, 'INSSM', this%memoryPath) + !call mem_allocate(this%inoc, 'INOC ', this%memoryPath) + !call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + ! + !this%inic = 0 + !this%infmi = 0 + !this%inmvt = 0 this%inmst = 0 + !this%inadv = 0 this%indsp = 0 + !this%inssm = 0 + !this%inoc = 0 + !this%inobs = 0 ! ! -- return return - end subroutine allocate_scalars_gwe + end subroutine allocate_scalars subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) @@ -1155,7 +1134,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! use GweLktModule, only: lkt_create use GweSfeModule, only: sfe_create ! use GweMwtModule, only: mwt_create -! use GweUztModule, only: uzt_create + use GweUzeModule, only: uze_create ! use ApiModule, only: api_create ! -- dummy class(GweModelType) :: this @@ -1189,9 +1168,9 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & !case('MWT6') ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) - !case('UZT6') - ! call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) + case('UZE6') + call uze_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%fmi, this%tsplab) !case('IST6') ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi, this%mst) diff --git a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 index 1cf4e912e0f..343b208e7b4 100644 --- a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 @@ -198,7 +198,20 @@ module GweDspInputModule type(InputParamDefinitionType), parameter :: & gwe_dsp_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 21ec6db02d0..f19bdb22fa0 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -701,7 +701,7 @@ subroutine sfe_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -759,7 +759,7 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -790,7 +790,7 @@ subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -817,9 +817,9 @@ subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd * this%cpw(n1) * this%rhow(n1) + if (present(hcofval)) hcofval = qbnd !* this%cpw(n1) * this%rhow(n1) ! ! -- return return diff --git a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 index c75fd75a284..073df218ef0 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 @@ -252,7 +252,20 @@ module GwfDisInputModule type(InputParamDefinitionType), parameter :: & gwf_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 index 696cb2cf032..0941b8562e7 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 @@ -684,7 +684,20 @@ module GwfNpfInputModule type(InputParamDefinitionType), parameter :: & gwf_npf_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 42488f88643..e65be8bf5cc 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -94,6 +94,7 @@ subroutine gwt_cr(filename, id, modelname) use ListsModule, only: basemodellist use BaseModelModule, only: AddBaseModelToList use SimModule, only: store_error, count_errors + use NameFileModule, only: NameFileType use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CompilerVersion use MemoryManagerModule, only: mem_allocate @@ -112,7 +113,7 @@ subroutine gwt_cr(filename, id, modelname) use GwtDspModule, only: dsp_cr use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr - use NameFileModule, only: NameFileType + ! -- dummy character(len=*), intent(in) :: filename integer(I4B), intent(in) :: id @@ -1102,25 +1103,25 @@ subroutine allocate_scalars(this, modelname) call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class - call mem_allocate(this%inic, 'INIC', this%memoryPath) - call mem_allocate(this%infmi, 'INFMI', this%memoryPath) - call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) + !call mem_allocate(this%inic, 'INIC', this%memoryPath) + !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) + !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) call mem_allocate(this%inmst, 'INMST', this%memoryPath) - call mem_allocate(this%inadv, 'INADV', this%memoryPath) + !call mem_allocate(this%inadv, 'INADV', this%memoryPath) call mem_allocate(this%indsp, 'INDSP', this%memoryPath) - call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - call mem_allocate(this%inoc, 'INOC ', this%memoryPath) - call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + !call mem_allocate(this%inssm, 'INSSM', this%memoryPath) + !call mem_allocate(this%inoc, 'INOC ', this%memoryPath) + !call mem_allocate(this%inobs, 'INOBS', this%memoryPath) ! - this%inic = 0 - this%infmi = 0 - this%inmvt = 0 + !this%inic = 0 + !this%infmi = 0 + !this%inmvt = 0 this%inmst = 0 - this%inadv = 0 + !this%inadv = 0 this%indsp = 0 - this%inssm = 0 - this%inoc = 0 - this%inobs = 0 + !this%inssm = 0 + !this%inoc = 0 + !this%inobs = 0 ! ! -- return return diff --git a/src/Model/GroundWaterTransport/gwt1dspidm.f90 b/src/Model/GroundWaterTransport/gwt1dspidm.f90 index 323346d5d56..c41fe0c3683 100644 --- a/src/Model/GroundWaterTransport/gwt1dspidm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dspidm.f90 @@ -162,7 +162,20 @@ module GwtDspInputModule type(InputParamDefinitionType), parameter :: & gwt_dsp_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 2c83c4caa8b..71de795efa9 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -127,7 +127,7 @@ module TspAptModule procedure :: bnd_ad => apt_ad procedure :: bnd_cf => apt_cf procedure :: bnd_fc => apt_fc - procedure, private :: apt_fc_expanded + procedure, public :: apt_fc_expanded ! kluge: Made public for uze on 3/3/2023 (reston) procedure :: pak_fc_expanded procedure, private :: apt_fc_nonexpanded procedure, private :: apt_cfupdate @@ -168,8 +168,8 @@ module TspAptModule procedure :: pak_setup_budobj procedure :: apt_fill_budobj procedure :: pak_fill_budobj - procedure, private :: apt_stor_term - procedure, private :: apt_tmvr_term + procedure, public :: apt_stor_term + procedure, public :: apt_tmvr_term procedure, private :: apt_fjf_term procedure, private :: apt_copy2flowp procedure, private :: apt_setup_tableobj @@ -906,10 +906,10 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(j) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudfjf)%flow(j) - ! TODO - Clean this out - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(j) * this%bndtype%rhow(j) - end if +!! ! TODO - Clean this out ! jiffylube: commented this out +!! if (associated(this%cpw).and.associated(this%rhow)) then +!! unitadj = this%bndtype%cpw(j) * this%bndtype%rhow(j) +!! end if if (qbnd <= DZERO) then omega = DONE else @@ -981,9 +981,9 @@ subroutine apt_cfupdate(this) omega = DZERO unitadj = DONE !TODO: Avoid checking whether solute or energy if (qbnd < DZERO) omega = DONE - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%cpw(j) * this%rhow(j) - end if +!! if (associated(this%cpw).and.associated(this%rhow)) then +!! unitadj = this%cpw(j) * this%rhow(j) ! jiffylube: kluge debug "!!" ? +!! end if this%hcof(j) = -(DONE - omega) * unitadj * qbnd this%rhs(j) = omega * unitadj * qbnd * this%xnewpak(n) end if @@ -1901,9 +1901,9 @@ subroutine apt_solve(this) unitadj = DONE ! Avoid checking whether solute or energy igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%cpw(j) * this%rhow(j) - end if +!! if (associated(this%cpw).and.associated(this%rhow)) then +!! unitadj = this%cpw(j) * this%rhow(j) ! jiffylube: kluge debug "!!" ? +!! end if if (qbnd <= DZERO) then ctmp = this%xnewpak(n) this%rhs(j) = unitadj * qbnd * ctmp @@ -1925,7 +1925,7 @@ subroutine apt_solve(this) end do end if ! - ! -- calulate the feature concentration/temperature + ! -- calculate the feature concentration/temperature do n = 1, this%ncv call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) ! @@ -2536,14 +2536,24 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval real(DP) :: v0, v1 real(DP) :: c0, c1 + real(DP) :: unitadj +! ----------------------------------------------------------------- + ! + ! -- TODO: these unitadj values should be cleaned-up as denoted in + ! uze_fc_expanded + if (associated(this%cpw).and.associated(this%rhow)) then + unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) + end if + unitadj = DONE ! jiffylube: kluge debug + ! n1 = ientry n2 = ientry call this%get_volumes(n1, v1, v0, delt) c0 = this%xoldpak(n1) c1 = this%xnewpak(n1) - if (present(rrate)) rrate = (-c1 * v1 / delt + c0 * v0 / delt) * this%cpw(n1) * this%rhow(n1) - if (present(rhsval)) rhsval = -c0 * v0 / delt * this%cpw(n1) * this%rhow(n1) - if (present(hcofval)) hcofval = -v1 / delt * this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = (-c1 * v1 / delt + c0 * v0 / delt) * unitadj + if (present(rhsval)) rhsval = -c0 * v0 / delt * unitadj + if (present(hcofval)) hcofval = -v1 / delt * unitadj ! ! -- return return @@ -2571,6 +2581,8 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & if (associated(this%cpw).and.associated(this%rhow)) then unitadj = this%cpw(ientry) * this%rhow(ientry) end if + unitadj = DONE ! jiffylube: kluge debug + ! ! -- Calculate MVR-related terms n1 = this%flowbudptr%budterm(this%idxbudtmvr)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudtmvr)%id2(ientry) @@ -2604,8 +2616,9 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ! -- If GWE package, adjust for thermal units unitadj = DONE ! TODO: Avoid checking whether solute or energy if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%cpw(ientry) * this%rhow(ientry) + unitadj = this%cpw(1) * this%rhow(1) end if + unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(ientry) @@ -2967,7 +2980,7 @@ subroutine apt_rp_obs(this) ' must be assigned to a feature with a unique boundname.' call store_error(errmsg) end if - case ('LKT', 'SFT', 'MWT', 'UZT') + case ('LKT', 'SFT', 'MWT', 'UZT', 'UZE') call this%rp_obs_budterm(obsrv, & this%flowbudptr%budterm(this%idxbudgwf)) case ('FLOW-JA-FACE') @@ -3052,7 +3065,7 @@ subroutine apt_bd_obs(this) if (this%iboundpak(jj) /= 0) then v = this%xnewpak(jj) end if - case ('LKT', 'SFT', 'MWT', 'UZT') + case ('LKT', 'SFT', 'MWT', 'UZT', 'UZE') n = this%flowbudptr%budterm(this%idxbudgwf)%id1(jj) if (this%iboundpak(n) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(jj) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index e18515807be..1c7950b6140 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -369,7 +369,7 @@ subroutine cnc_bd(this, model_budget) if (this%tsplab%tsptype /= 'GWE') then unitadj = DONE else - unitadj = this%cpw(n) * this%rhow(n) + unitadj = this%cpw(n) * this%rhow(n) ! jiffylube: kluge note - check use of unitadj in cnc end if ! do n = 1, size(this%ratecncin) diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index d724d589f6b..8ead6f52f17 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -356,7 +356,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! ! -- If GWE transport model type, adjust units to energy if (this%tsplab%tsptype == "GWE") then - unitadj = this%cpw(n) * this%rhow(n) + unitadj = this%cpw(n) * this%rhow(n) ! jiffylube: kluge note - check use of unitadj in ssm end if ! ! -- Add terms based on qbnd sign diff --git a/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 b/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 index d4bd43250ca..1048c83cfea 100644 --- a/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 +++ b/src/Model/ModelUtilities/SfrCrossSectionUtils.f90 @@ -382,7 +382,11 @@ subroutine get_cross_section_areas(npts, stations, heights, d, a) ! ! -- add the area below dmax if (dmax /= dmin .and. d > dmin) then - a(n) = a(n) + DHALF * (d - dmin) + if (d < dmax) then + a(n) = a(n) + DHALF * (d - dmin) * xlen + else + a(n) = a(n) + DHALF * (dmax - dmin) * xlen + end if end if end if end do diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 32e03b58d13..ed49c708108 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -39,7 +39,6 @@ module TransportModelModule type, extends(NumericalModelType) :: TransportModelType ! Generalized transport package types common to either GWT or GWE - class(*), pointer :: tspmst => null() !< flavor of MST package associated with this model type (GWT or GWE) type(TspAdvType), pointer :: adv => null() ! advection package type(TspFmiType), pointer :: fmi => null() ! flow model interface type(TspIcType), pointer :: ic => null() ! initial conditions package @@ -66,6 +65,7 @@ module TransportModelModule procedure, public :: ftype_check procedure, public :: tsp_cr procedure, public :: tsp_df + procedure, public :: tsp_da procedure, public :: tsp_ac procedure, public :: tsp_mc procedure, public :: tsp_ar @@ -91,7 +91,7 @@ module TransportModelModule 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - 'API6 ', ' ', 'SFE6 ', ' ', ' ', & ! 25 + 'API6 ', ' ', 'SFE6 ', 'UZE6 ', ' ', & ! 25 75*' '/ contains @@ -693,6 +693,35 @@ subroutine allocate_scalars(this, modelname) return end subroutine allocate_scalars + subroutine tsp_da(this) +! ****************************************************************************** +! tsp_da -- Deallocate +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(TransportModelType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Scalars + call mem_deallocate(this%inic) + call mem_deallocate(this%infmi) + call mem_deallocate(this%inadv) + call mem_deallocate(this%indsp) + call mem_deallocate(this%inssm) + call mem_deallocate(this%inmst) + call mem_deallocate(this%inmvt) + call mem_deallocate(this%inoc) + call mem_deallocate(this%inobs) + ! + ! -- return + return + end subroutine tsp_da + subroutine ftype_check(this, namefile_obj, indis) ! ****************************************************************************** ! ftype_check -- Check to make sure required input files have been specified diff --git a/src/Solution/NumericalSolution.f90 b/src/Solution/NumericalSolution.f90 index d2c9ad9c75b..5e01797ab03 100644 --- a/src/Solution/NumericalSolution.f90 +++ b/src/Solution/NumericalSolution.f90 @@ -2511,7 +2511,7 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) ! to enable set itestmat to 1 and recompile !------------------------------------------------------- itestmat = 0 - if (itestmat == 1) then + if (itestmat == 1 .and. this%id == 2) then write (fname, fmtfname) this%id, kper, kstp, kiter print *, 'Saving amat to: ', trim(adjustl(fname)) From 552fb7e6b1f8946a3e48ef8711e197fc17913dbf Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Thu, 16 Mar 2023 12:59:39 -0400 Subject: [PATCH 094/212] * removed nonexistent file LatHeatVapor.f90 from msvs project * fixed subscript in setting of unitadj in CNC --- msvs/mf6core.vfproj | 1 - src/Model/GroundWaterTransport/tsp1cnc1.f90 | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index be707443e30..c1fe3aa4dbf 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -152,7 +152,6 @@ - diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 1c7950b6140..03c9aab93aa 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -369,7 +369,7 @@ subroutine cnc_bd(this, model_budget) if (this%tsplab%tsptype /= 'GWE') then unitadj = DONE else - unitadj = this%cpw(n) * this%rhow(n) ! jiffylube: kluge note - check use of unitadj in cnc + unitadj = this%cpw(1) * this%rhow(1) ! jiffylube: kluge note - check use of unitadj in cnc end if ! do n = 1, size(this%ratecncin) From 999a510c20ca467f9fd779675a464db281ef7d98 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 22 Mar 2023 13:52:40 -0700 Subject: [PATCH 095/212] Some updates to the .dfn files associated with MST alterations and the addition of support for UZE --- doc/mf6io/mf6ivar/dfn/gwe-mst.dfn | 65 +++-- doc/mf6io/mf6ivar/dfn/gwe-uze.dfn | 438 ++++++++++++++++++++++++++++ doc/mf6io/mf6ivar/md/mf6ivar.md | 8 +- doc/mf6io/mf6ivar/mf6ivar.py | 1 + doc/mf6io/mf6ivar/tex/appendixA.tex | 1 + 5 files changed, 493 insertions(+), 20 deletions(-) create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-uze.dfn diff --git a/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn b/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn index 3a1934677ad..1e1bc7a1da8 100644 --- a/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwe-mst.dfn @@ -24,6 +24,14 @@ optional true longname activate zero-order decay description is a text keyword to indicate that zero-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. +block options +name latent_heat_vaporization +type keyword +reader urword +optional true +longname activate cooling associated with evaporation +description is a text keyword to indicate that cooling associated with evaporation will occur. Use of this keyword requires that LATHEATVAP are specified in the GRIDDATA block. While the MST package does not simulate evaporation, multiple other packages in a GWE simulation may. For example, evaporation may occur from the surface of streams or lakes. Owing to the energy consumed by the change in phase, the latent heat of vaporization is required. + # --------------------- gwe mst griddata --------------------- block griddata @@ -45,15 +53,6 @@ optional true longname aqueous phase decay rate coefficient description is the rate coefficient for first or zero-order decay for the aqueous phase of the mobile domain. A negative value indicates solute production. The dimensions of decay for first-order decay is one over time. The dimensions of decay for zero-order decay is mass per length cubed per time. decay will have no effect on simulation results unless either first- or zero-order decay is specified in the options block. -block griddata -name cpw -type double precision -shape (nodes) -reader readarray -layered true -longname heat capacity of water -description is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. - block griddata name cps type double precision @@ -64,20 +63,52 @@ longname heat capacity of the aquifer material description is the mass-based heat capacity of dry solids (aquifer material). Thus, enter value in units of J/kg/C block griddata -name rhow +name rhos type double precision shape (nodes) reader readarray layered true +longname density of aquifer material +description is a user-specified value of the density of aquifer material not considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. + +# --------------------- gwe mst packagedata --------------------- + +block packagedata +name packagedata +type recarray cpw rhow latheatvap +shape +reader urword +longname +description + +block packagedata +name cpw +type double precision +shape +tagged false +in_record true +reader urword +longname heat capacity of water +description is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. + +block packagedata +name rhow +type double precision +shape +tagged false +in_record true +reader urword longname density of water description is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 -block griddata -name rhos + +block packagedata +name latheatvap type double precision -shape (nodes) -reader readarray -layered true -longname density of aquifer material -description is a user-specified value of the density of aquifer material no considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. +shape +tagged false +in_record true +reader urword +longname latent heat of vaporization +description is the user-specified value for the latent heat of vaporization. Currently, it may be specified spatially to facilitate temperature-dependent alterations in its value, though this functionality needs to be re-thought (perhaps its needs something like the VSC package approach). Typical units are kJ/kg (which is the same as J/g). diff --git a/doc/mf6io/mf6ivar/dfn/gwe-uze.dfn b/doc/mf6io/mf6ivar/dfn/gwe-uze.dfn new file mode 100644 index 00000000000..1f272617b73 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-uze.dfn @@ -0,0 +1,438 @@ +# --------------------- gwe uze options --------------------- +# flopy multi-package + +block options +name flow_package_name +type string +shape +reader urword +optional true +longname keyword to specify name of corresponding flow package +description keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +block options +name auxiliary +type string +shape (naux) +reader urword +optional true +longname keyword to specify aux variables +description REPLACE auxnames {'{#1}': 'Groundwater Energy Transport'} + +block options +name flow_package_auxiliary_name +type string +shape +reader urword +optional true +longname keyword to specify name of concentration auxiliary variable in flow package +description keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'unsaturated zone flow'} + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'unsaturated zone flow'} + +block options +name print_temperature +type keyword +reader urword +optional true +longname print calculated temperatures to listing file +description REPLACE print_temperature {'{#1}': 'UZF cell', '{#2}': 'temperatures', '{#3}': 'TEMPERATURE'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'unsaturated zone'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save UZE cell flows to budget file +description REPLACE save_flows {'{#1}': 'unsaturated zone'} + +block options +name temperature_filerecord +type record temperature fileout tempfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name temperature +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname stage keyword +description keyword to specify that record corresponds to temperature. + +block options +name tempfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write temperature information. + +block options +name budget_filerecord +type record budget fileout budgetfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budget +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name budgetfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write budget information. + +block options +name budgetcsv_filerecord +type record budgetcsv fileout budgetcsvfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budgetcsv +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget CSV. + +block options +name budgetcsvfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +block options +name ts_filerecord +type record ts6 filein ts6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name ts6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname head keyword +description keyword to specify that record corresponds to a time-series file. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name ts6_filename +type string +preserve_case true +in_record true +reader urword +optional false +tagged false +longname file name of time series information +description REPLACE timeseriesfile {} + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description REPLACE obs6_filename {'{#1}': 'UZE'} + + +# --------------------- gwe uze packagedata --------------------- + +block packagedata +name packagedata +type recarray uzfno strt aux boundname +shape (maxbound) +reader urword +longname +description + +block packagedata +name uzfno +type integer +shape +tagged false +in_record true +reader urword +longname UZF cell number for this entry +description integer value that defines the UZF cell number associated with the specified PACKAGEDATA data on the line. UZFNO must be greater than zero and less than or equal to NUZFCELLS. Unsaturated zone flow information must be specified for every UZF cell or the program will terminate with an error. The program also will terminate with an error if information for a UZF cell is specified more than once. +numeric_index true + +block packagedata +name strt +type double precision +shape +tagged false +in_record true +reader urword +longname starting UZF cell temperature +description real value that defines the starting temperature for the unsaturated zone flow cell. + +block packagedata +name aux +type double precision +in_record true +tagged false +shape (naux) +reader urword +time_series true +optional true +longname auxiliary variables +description REPLACE aux {'{#1}': 'unsaturated zone flow'} + +block packagedata +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname UZF cell name +description REPLACE boundname {'{#1}': 'unsaturated zone flow'} + + +# --------------------- gwe uze period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name uzeperioddata +type recarray uzfno uzesetting +shape +reader urword +longname +description + +block period +name uzfno +type integer +shape +tagged false +in_record true +reader urword +longname unsaturated zone flow cell number for this entry +description integer value that defines the UZF cell number associated with the specified PERIOD data on the line. UZFNO must be greater than zero and less than or equal to NUZFCELLS. +numeric_index true + +block period +name uzesetting +type keystring status temperature infiltration uzet auxiliaryrecord +shape +tagged false +in_record true +reader urword +longname +description line of information that is parsed into a keyword and values. Keyword values that can be used to start the UZESETTING string include: STATUS, TEMPERATURE, INFILTRATION, UZET, and AUXILIARY. These settings are used to assign the temperature associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. + +block period +name status +type string +shape +tagged true +in_record true +reader urword +longname unsaturated zone flow cell temperature status +description keyword option to define UZF cell status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the UZF cell. If a UZF cell is inactive, then there will be no energy fluxes into or out of the UZF cell and the inactive value will be written for the UZF cell temperature. If a UZF cell is constant, then the temperature for the UZF cell will be fixed at the user specified value. + +block period +name temperature +type string +shape +tagged true +in_record true +time_series true +reader urword +longname unsaturated zone flow cell temperature +description real or character value that defines the temperature for the unsaturated zone flow cell. The specified TEMPERATURE is only applied if the unsaturated zone flow cell is a constant temperature cell. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name infiltration +type string +shape +tagged true +in_record true +reader urword +time_series true +longname infiltration temperature +description real or character value that defines the temperature of the infiltration $(^\circ C)$ for the UZF cell. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name uzet +type string +shape +tagged true +in_record true +reader urword +time_series true +longname unsaturated zone et temperature +description real or character value that states what fraction of the simulated unsaturated zone evapotranspiration is associated with evaporation. The evaporative losses from the unsaturated zone moisture content will have an evaporative cooling effect on the GWE cell from which the evaporation originated. If this value is larger than 1, then it will be reset to 1. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name auxiliaryrecord +type record auxiliary auxname auxval +shape +tagged +in_record true +reader urword +longname +description + +block period +name auxiliary +type keyword +shape +in_record true +reader urword +longname +description keyword for specifying auxiliary variable. + +block period +name auxname +type string +shape +tagged false +in_record true +reader urword +longname +description name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +block period +name auxval +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname auxiliary variable value +description value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. diff --git a/doc/mf6io/mf6ivar/md/mf6ivar.md b/doc/mf6io/mf6ivar/md/mf6ivar.md index 6261eefa1ae..4be9bb84c85 100644 --- a/doc/mf6io/mf6ivar/md/mf6ivar.md +++ b/doc/mf6io/mf6ivar/md/mf6ivar.md @@ -1250,12 +1250,14 @@ | GWE | MST | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that MST flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | | GWE | MST | OPTIONS | FIRST_ORDER_DECAY | KEYWORD | is a text keyword to indicate that first-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. | | GWE | MST | OPTIONS | ZERO_ORDER_DECAY | KEYWORD | is a text keyword to indicate that zero-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. | +| GWE | MST | OPTIONS | LATENT_HEAT_VAPORIZATION | KEYWORD | is a text keyword to indicate that cooling associated with evaporation will occur. Use of this keyword requires that LATHEATVAP are specified in the GRIDDATA block. While the MST package does not simulate evaporation, multiple other packages in a GWE simulation may. For example, evaporation may occur from the surface of streams or lakes. Owing to the energy consumed by the change in phase, the latent heat of vaporization is required. | | GWE | MST | GRIDDATA | POROSITY | DOUBLE PRECISION (NODES) | is the aquifer porosity. | | GWE | MST | GRIDDATA | DECAY | DOUBLE PRECISION (NODES) | is the rate coefficient for first or zero-order decay for the aqueous phase of the mobile domain. A negative value indicates solute production. The dimensions of decay for first-order decay is one over time. The dimensions of decay for zero-order decay is mass per length cubed per time. decay will have no effect on simulation results unless either first- or zero-order decay is specified in the options block. | -| GWE | MST | GRIDDATA | CPW | DOUBLE PRECISION (NODES) | is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. | | GWE | MST | GRIDDATA | CPS | DOUBLE PRECISION (NODES) | is the mass-based heat capacity of dry solids (aquifer material). Thus, enter value in units of J/kg/C | -| GWE | MST | GRIDDATA | RHOW | DOUBLE PRECISION (NODES) | is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 | -| GWE | MST | GRIDDATA | RHOS | DOUBLE PRECISION (NODES) | is a user-specified value of the density of aquifer material no considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. | +| GWE | MST | GRIDDATA | RHOS | DOUBLE PRECISION (NODES) | is a user-specified value of the density of aquifer material not considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. | +| GWE | MST | PACKAGEDATA | CPW | DOUBLE PRECISION | is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. | +| GWE | MST | PACKAGEDATA | RHOW | DOUBLE PRECISION | is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 | +| GWE | MST | PACKAGEDATA | LATHEATVAP | DOUBLE PRECISION | is the user-specified value for the latent heat of vaporization. Currently, it may be specified spatially to facilitate temperature-dependent alterations in its value, though this functionality needs to be re-thought (perhaps its needs something like the VSC package approach). Typical units are kJ/kg (which is the same as J/g). | | GWE | OC | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | | GWE | OC | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | | GWE | OC | OPTIONS | BUDGETFILE | STRING | name of the output file to write budget information. | diff --git a/doc/mf6io/mf6ivar/mf6ivar.py b/doc/mf6io/mf6ivar/mf6ivar.py index e63e7cca3f8..0ab1a16d613 100644 --- a/doc/mf6io/mf6ivar/mf6ivar.py +++ b/doc/mf6io/mf6ivar/mf6ivar.py @@ -703,6 +703,7 @@ def write_appendix(texdir, allblocks): 'gwe-src', 'gwe-ssm', 'gwe-tmp', + 'gwe-uze', 'utl-spc', 'utl-spca', 'utl-obs', diff --git a/doc/mf6io/mf6ivar/tex/appendixA.tex b/doc/mf6io/mf6ivar/tex/appendixA.tex index 5ce737ebc7f..e73c191b3a8 100644 --- a/doc/mf6io/mf6ivar/tex/appendixA.tex +++ b/doc/mf6io/mf6ivar/tex/appendixA.tex @@ -273,6 +273,7 @@ \hline GWE & MST & OPTIONS & yes \\ GWE & MST & GRIDDATA & no \\ +GWE & MST & PACKAGEDATA & yes \\ \hline GWE & OC & OPTIONS & yes \\ GWE & OC & PERIOD & yes \\ From 2f76c54147c427a2d7b83a8baffdf7c83833838a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 23 Mar 2023 10:27:51 -0700 Subject: [PATCH 096/212] Remove Cpw and Rhow from BoundaryPackage.f90. Both vars moved to new module located in src/Model/ModelUtilities --- msvs/mf6core.vfproj | 1 + src/Model/Connection/GweInterfaceModel.f90 | 6 +- src/Model/GroundWaterEnergy/gwe1.f90 | 44 ++-- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 17 +- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 188 ++++++++------- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 13 +- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 32 +-- src/Model/GroundWaterFlow/gwf3lak8.f90 | 6 +- src/Model/GroundWaterFlow/gwf3maw8.f90 | 6 +- src/Model/GroundWaterTransport/tsp1apt1.f90 | 34 +-- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 19 +- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 26 ++- src/Model/ModelUtilities/BoundaryPackage.f90 | 16 +- src/Model/ModelUtilities/GweInputData.f90 | 229 +++++++++++++++++++ 14 files changed, 434 insertions(+), 203 deletions(-) create mode 100644 src/Model/ModelUtilities/GweInputData.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index c1fe3aa4dbf..3e000695d07 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -145,6 +145,7 @@ + diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index b5d16db5755..6ba8254424c 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -83,7 +83,8 @@ subroutine gweifmod_cr(this, name, iout, gridConn) call disu_cr(this%dis, this%name, -1, this%iout) call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) + call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi, & + this%gwecommon) call tsp_obs_cr(this%obs, inobs) end subroutine gweifmod_cr @@ -185,8 +186,7 @@ subroutine gweifmod_ar(this) call this%adv%adv_ar(this%dis, this%ibound) end if if (this%indsp > 0) then - call this%dsp%dsp_ar(this%ibound, this%porosity, this%dsp%cpw, & - this%dsp%rhow) + call this%dsp%dsp_ar(this%ibound, this%porosity) end if end subroutine gweifmod_ar diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index adbd7166c9a..3e238db0544 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -12,6 +12,7 @@ module GweModule use GweDspModule, only: GweDspType use GweMstModule, only: GweMstType use BudgetModule, only: BudgetType + use GweInputDataModule, only: GweInputDataType use TransportModelModule use MatrixModule @@ -24,8 +25,9 @@ module GweModule type, extends(TransportModelType) :: GweModelType - type(GweMstType), pointer :: mst => null() ! mass storage and transfer package - type(GweDspType), pointer :: dsp => null() ! dispersion package + type(GweInputDataType), pointer :: gwecommon => null() !< container for data shared with multiple packages + type(GweMstType), pointer :: mst => null() !< mass storage and transfer package + type(GweDspType), pointer :: dsp => null() !< dispersion package !type(BudgetType), pointer :: budget => null() ! budget object !integer(I4B), pointer :: inic => null() ! unit number IC !integer(I4B), pointer :: infmi => null() ! unit number FMI @@ -64,6 +66,7 @@ module GweModule procedure, private :: gwe_ot_bdsummary procedure, private :: gwe_ot_obs procedure :: load_input_context => gwe_load_input_context + end type GweModelType ! -- Module variables constant for simulation @@ -108,6 +111,7 @@ subroutine gwe_cr(filename, id, modelname) use GweDspModule, only: dsp_cr use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr + use GweInputDataModule, only: gweshared_dat_cr ! -- dummy character(len=*), intent(in) :: filename integer(I4B), intent(in) :: id @@ -145,6 +149,9 @@ subroutine gwe_cr(filename, id, modelname) ! -- Instantiate generalized labels call tsplabels_cr(this%tsplab, this%name) ! + ! -- Instantiate shared data container + call gweshared_dat_cr(this%gwecommon) + ! ! -- Open namefile and set iout call namefile_obj%init(this%filename, 0) call namefile_obj%add_cunit(niunit, cunit) @@ -234,10 +241,13 @@ subroutine gwe_cr(filename, id, modelname) ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) - call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) + call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & + this%gwecommon) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) + call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi, & + this%gwecommon) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + this%tsplab, this%gwecommon) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) @@ -271,6 +281,7 @@ subroutine gwe_df(this) ! ------------------------------------------------------------------------------ ! -- modules use TspLabelsModule, only: setTspLabels + use GweInputDataModule, only: gweshared_dat_df ! -- dummy class(GweModelType) :: this ! -- local @@ -298,6 +309,9 @@ subroutine gwe_df(this) this%ia => this%dis%con%ia this%ja => this%dis%con%ja ! + ! -- Define shared data (cpw, rhow, latent heat of vaporization) + call this%gwecommon%gweshared_dat_df(this%neq) + ! ! -- Allocate model arrays, now that neq and nja are assigned call this%allocate_arrays() ! @@ -403,12 +417,9 @@ subroutine gwe_ar(this) if (this%inmvt > 0) call this%mvt%mvt_ar() if (this%inic > 0) call this%ic%ic_ar(this%x) if (this%inmst > 0) call this%mst%mst_ar(this%dis, this%ibound) - if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound, & - this%mst%cpw, this%mst%rhow) - if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity, & - this%mst%cpw, this%mst%rhow) - if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x, & - this%mst%cpw, this%mst%rhow) + if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound) + if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity) + if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! ! -- Call dis_ar to write binary grid file @@ -422,8 +433,7 @@ subroutine gwe_ar(this) do ip = 1, this%bndlist%Count() packobj => GetBndFromList(this%bndlist, ip) call packobj%set_pointers(this%dis%nodes, this%ibound, this%x, & - this%xold, this%flowja, this%mst%cpw, & - this%mst%rhow, this%mst%latheatvap) + this%xold, this%flowja) ! -- Read and allocate package call packobj%bnd_ar() end do @@ -986,6 +996,7 @@ subroutine gwe_da(this) call this%oc%oc_da() call this%obs%obs_da() call this%tsplab%tsplabels_da() + call this%gwecommon%gweshared_dat_da() ! ! -- Internal package objects deallocate (this%dis) @@ -1000,6 +1011,7 @@ subroutine gwe_da(this) deallocate (this%oc) deallocate (this%obs) deallocate (this%tsplab) + nullify (this%gwecommon) ! ! -- Boundary packages do ip = 1, this%bndlist%Count() @@ -1155,7 +1167,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & select case (filtyp) case ('TMP6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%tsplab) + pakname, this%tsplab, this%gwecommon) !case('SRC6') ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname) @@ -1164,13 +1176,13 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! pakname, this%fmi) case('SFE6') call sfe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab) + pakname, this%fmi, this%tsplab, this%gwecommon) !case('MWT6') ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) case('UZE6') call uze_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab) + pakname, this%fmi, this%tsplab, this%gwecommon) !case('IST6') ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi, this%mst) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 066cc95af7d..0e260fe6605 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -7,6 +7,7 @@ module GweDspModule use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr use GweDspOptionsModule, only: GweDspOptionsType + use GweInputDataModule, only: GweInputDataType use MatrixModule implicit none @@ -18,6 +19,7 @@ module GweDspModule integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWE model ibound type(TspFmiType), pointer :: fmi => null() ! pointer to GWE fmi object + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWE storage porosity ! TODO: Can remove diffc from GWE !real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell @@ -26,10 +28,8 @@ module GweDspModule real(DP), dimension(:), pointer, contiguous :: ath1 => null() ! transverse horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: ath2 => null() ! transverse horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity - real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water real(DP), dimension(:), pointer, contiguous :: ktw => null() ! thermal conductivity of water real(DP), dimension(:), pointer, contiguous :: kts => null() ! thermal conductivity of aquifer material - real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water !integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active integer(I4B), pointer :: ialh => null() ! longitudinal horizontal dispersivity data flag @@ -79,7 +79,7 @@ module GweDspModule contains - subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) + subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi, gwecommon) ! ****************************************************************************** ! dsp_cr -- Create a new DSP object ! ****************************************************************************** @@ -95,6 +95,7 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- formats character(len=*), parameter :: fmtdsp = & "(1x,/1x,'DSP-- THERMAL CONDUCTION AND DISPERSION PACKAGE, VERSION 1, ', & @@ -114,6 +115,7 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi) dspobj%inunit = inunit dspobj%iout = iout dspobj%fmi => fmi + dspobj%gwecommon => gwecommon ! ! -- Check if input file is open if (dspobj%inunit > 0) then @@ -226,7 +228,7 @@ subroutine dsp_mc(this, moffset, matrix_sln) return end subroutine dsp_mc - subroutine dsp_ar(this, ibound, porosity, cpw, rhow) + subroutine dsp_ar(this, ibound, porosity) ! ****************************************************************************** ! dsp_ar -- Allocate and Read ! ****************************************************************************** @@ -238,8 +240,6 @@ subroutine dsp_ar(this, ibound, porosity, cpw, rhow) class(GweDspType) :: this integer(I4B), dimension(:), pointer, contiguous :: ibound real(DP), dimension(:), pointer, contiguous :: porosity - real(DP), dimension(:), pointer, contiguous :: cpw - real(DP), dimension(:), pointer, contiguous :: rhow ! -- local ! -- formats character(len=*), parameter :: fmtdsp = & @@ -250,8 +250,6 @@ subroutine dsp_ar(this, ibound, porosity, cpw, rhow) ! -- dsp pointers to arguments that were passed in this%ibound => ibound this%porosity => porosity - this%cpw => cpw - this%rhow => rhow ! ! -- Return return @@ -534,6 +532,7 @@ subroutine dsp_da(this) ! ! -- deallocate objects if (this%ixt3d > 0) deallocate (this%xt3d) + nullify (this%gwecommon) ! ! -- deallocate scalars !call mem_deallocate(this%idiffc) @@ -830,7 +829,7 @@ subroutine calcdispellipse(this) if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) * & this%fmi%gwfsat(n) if (this%ikts > 0) ktbulk = ktbulk + (DONE - this%porosity(n)) * this%kts(n) - dstar = ktbulk / (this%cpw(n) * this%rhow(n)) + dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) ! ! -- Calculate the longitudal and transverse dispersivities al = DZERO diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index aa65cc04185..0425716c324 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -21,6 +21,7 @@ module GweMstModule use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType use TspFmiModule, only: TspFmiType + use GweInputDataModule, only: GweInputDataType implicit none public :: GweMstType @@ -37,12 +38,12 @@ module GweMstModule type, extends(NumericalPackageType) :: GweMstType ! ! -- storage - real(DP), dimension(:), pointer, contiguous :: porosity => null() !< porosity - real(DP), dimension(:), pointer, contiguous :: ratesto => null() !< rate of mobile storage - real(DP), dimension(:), pointer, contiguous :: cpw => null() !< heat capacity of water + real(DP), pointer :: cpw => null() !< heat capacity of water + real(DP), pointer :: rhow => null() !< density of water real(DP), dimension(:), pointer, contiguous :: cps => null() !< heat capacity of solid - real(DP), dimension(:), pointer, contiguous :: rhow => null() !< density of water real(DP), dimension(:), pointer, contiguous :: rhos => null() !< density of solid + real(DP), dimension(:), pointer, contiguous :: porosity => null() !< porosity + real(DP), dimension(:), pointer, contiguous :: ratesto => null() !< rate of mobile storage ! ! -- decay integer(I4B), pointer :: idcy => null() !< order of decay rate (0:none, 1:first, 2:zero) @@ -53,8 +54,9 @@ module GweMstModule ! ! -- misc integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound - real(DP), dimension(:), pointer, contiguous :: latheatvap => null() !< latent heat of vaporization type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + real(DP), pointer :: latheatvap => null() !< latent heat of vaporization contains @@ -72,6 +74,7 @@ module GweMstModule procedure, private :: allocate_arrays procedure, private :: read_options procedure, private :: read_data + procedure, private :: read_packagedata end type GweMstType @@ -82,13 +85,14 @@ module GweMstModule !! Create a new MST object !! !< - subroutine mst_cr(mstobj, name_model, inunit, iout, fmi) + subroutine mst_cr(mstobj, name_model, inunit, iout, fmi, gwecommon) ! -- dummy type(GweMstType), pointer :: mstobj !< unallocated new mst object to create character(len=*), intent(in) :: name_model !< name of the model integer(I4B), intent(in) :: inunit !< unit number of WEL package input file integer(I4B), intent(in) :: iout !< unit number of model listing file type(TspFmiType), intent(in), target :: fmi !< fmi package for this GWE model + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! ! -- Create the object allocate (mstobj) @@ -103,6 +107,7 @@ subroutine mst_cr(mstobj, name_model, inunit, iout, fmi) mstobj%inunit = inunit mstobj%iout = iout mstobj%fmi => fmi + mstobj%gwecommon => gwecommon ! ! -- Initialize block parser call mstobj%parser%Initialize(mstobj%inunit, mstobj%iout) @@ -118,6 +123,7 @@ end subroutine mst_cr !< subroutine mst_ar(this, dis, ibound) ! -- modules + use GweInputDataModule, only: set_gwe_dat_ptrs ! -- dummy class(GweMstType), intent(inout) :: this !< GweMstType object class(DisBaseType), pointer, intent(in) :: dis !< pointer to dis package @@ -141,9 +147,21 @@ subroutine mst_ar(this, dis, ibound) ! -- Allocate arrays call this%allocate_arrays(dis%nodes) ! - ! -- read the data block + ! -- read the gridded data call this%read_data() ! + ! -- read package data that is not gridded + call this%read_packagedata() + ! + ! -- set pointers for data required by other packages + if (this%ilhv == 1) then + call this%gwecommon%set_gwe_dat_ptrs(this%rhow, this%cpw, this%rhow, & + this%cpw, this%latheatvap) + else + call this%gwecommon%set_gwe_dat_ptrs(this%rhow, this%cpw, this%rhow, & + this%cpw) + end if + ! ! -- Return return end subroutine mst_ar @@ -221,7 +239,7 @@ subroutine mst_fc_sto(this, nodes, cold, nja, matrix_sln, idxglo, rhs) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- add terms to diagonal and rhs accumulators - term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow(n) * this%cpw(n)) + term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow * this%cpw) hhcof = -(vnew + term) * tled rrhs = -(vold + term) * tled * cold(n) idiag = this%dis%con%ia(n) @@ -350,7 +368,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) ! -- Calculate storage change do n = 1, nodes this%ratesto(n) = DZERO - unitadj = this%cpw(n) * this%rhow(n) + unitadj = this%cpw * this%rhow ! ! -- skip if transport inactive if (this%ibound(n) <= 0) cycle @@ -364,7 +382,7 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate - term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow(n) * this%cpw(n)) + term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow * this%cpw) hhcof = -(vwatnew + term) * tled rrhs = -(vwatold + term) * tled * cold(n) rate = hhcof * cnew(n) - rrhs @@ -455,7 +473,7 @@ subroutine mst_bd(this, isuppress_output, model_budget) ! ! -- for GWE, storage rate needs to have units adjusted do n = 1, size(this%ratesto) - this%ratesto(n) = this%ratesto(n) * this%cpw(n) * this%rhow(n) + this%ratesto(n) = this%ratesto(n) * this%cpw * this%rhow end do ! ! -- sto @@ -576,10 +594,16 @@ subroutine allocate_scalars(this) call this%NumericalPackageType%allocate_scalars() ! ! -- Allocate + call mem_allocate(this%cpw, 'CPW', this%memoryPath) + call mem_allocate(this%rhow, 'RHOW', this%memoryPath) + call mem_allocate(this%latheatvap, 'LATHEATVAP', this%memoryPath) call mem_allocate(this%idcy, 'IDCY', this%memoryPath) call mem_allocate(this%ilhv, 'ILHV', this%memoryPath) ! ! -- Initialize + this%cpw = DZERO + this%rhow = DZERO + this%latheatvap = DZERO this%idcy = 0 this%ilhv = 0 ! @@ -606,9 +630,7 @@ subroutine allocate_arrays(this, nodes) ! -- sto call mem_allocate(this%porosity, nodes, 'POROSITY', this%memoryPath) call mem_allocate(this%ratesto, nodes, 'RATESTO', this%memoryPath) - call mem_allocate(this%cpw, nodes, 'CPW', this%memoryPath) call mem_allocate(this%cps, nodes, 'CPS', this%memoryPath) - call mem_allocate(this%rhow, nodes, 'RHOW', this%memoryPath) call mem_allocate(this%rhos, nodes, 'RHOS', this%memoryPath) ! ! -- dcy @@ -622,20 +644,11 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%decaylast, nodes, 'DECAYLAST', this%memoryPath) end if ! - ! -- latent heat of vaporization - if (this%ilhv == 0) then - call mem_allocate(this%latheatvap, 1, 'LATHEATVAP', this%memoryPath) - else - call mem_allocate(this%latheatvap, nodes, 'LATHEATVAP', this%memoryPath) - end if - ! ! -- Initialize do n = 1, nodes this%porosity(n) = DZERO this%ratesto(n) = DZERO - this%cpw(n) = DZERO this%cps(n) = DZERO - this%rhow(n) = DZERO this%rhos(n) = DZERO end do do n = 1, size(this%decay) @@ -643,9 +656,6 @@ subroutine allocate_arrays(this, nodes) this%ratedcy(n) = DZERO this%decaylast(n) = DZERO end do - do n = 1, size(this%latheatvap) - this%latheatvap(n) = DZERO - end do ! ! -- Return return @@ -730,17 +740,14 @@ subroutine read_data(this) character(len=:), allocatable :: line integer(I4B) :: istart, istop, lloc, ierr logical :: isfound, endOfBlock - logical, dimension(10) :: lname - character(len=24), dimension(7) :: aname + logical, dimension(4) :: lname + character(len=24), dimension(4) :: aname ! -- formats ! -- data data aname(1)/' MOBILE DOMAIN POROSITY'/ data aname(2)/' DECAY RATE'/ - data aname(3)/' HEAT CAPACITY OF WATER'/ - data aname(4)/' HEAT CAPACITY OF SOLIDS'/ - data aname(5)/' DENSITY OF WATER'/ - data aname(6)/' DENSITY OF SOLIDS'/ - data aname(7)/'LATENT HEAT VAPORIZATION'/ + data aname(3)/' HEAT CAPACITY OF SOLIDS'/ + data aname(4)/' DENSITY OF SOLIDS'/ ! ! -- initialize isfound = .false. @@ -770,34 +777,16 @@ subroutine read_data(this) this%parser%iuactive, this%decay, & aname(2)) lname(2) = .true. - case ('CPW') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%cpw, & - aname(3)) - lname(3) = .true. case ('CPS') call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & this%parser%iuactive, this%cps, & - aname(4)) - lname(4) = .true. - case ('RHOW') - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%rhow, & - aname(5)) - lname(5) = .true. + aname(3)) + lname(3) = .true. case ('RHOS') call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & this%parser%iuactive, this%rhos, & - aname(6)) - lname(6) = .true. - case ('LATHEATVAP') - if (this%ilhv == 0) & - call mem_reallocate(this%latheatvap, this%dis%nodes, 'LATHEATVAP', & - trim(this%memoryPath)) - call this%dis%read_grid_array(line, lloc, istart, istop, this%iout, & - this%parser%iuactive, this%latheatvap, & - aname(7)) - lname(7) = .true. + aname(4)) + lname(4) = .true. case default write (errmsg, '(a,a)') 'UNKNOWN GRIDDATA TAG: ', trim(keyword) call store_error(errmsg) @@ -817,18 +806,10 @@ subroutine read_data(this) call store_error(errmsg) end if if (.not. lname(3)) then - write (errmsg, '(a)') 'CPW NOT SPECIFIED IN GRIDDATA BLOCK.' - call store_error(errmsg) - end if - if (.not. lname(4)) then write (errmsg, '(a)') 'CPS NOT SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) end if - if (.not. lname(5)) then - write (errmsg, '(a)') 'RHOW NOT SPECIFIED IN GRIDDATA BLOCK.' - call store_error(errmsg) - end if - if (.not. lname(6)) then + if (.not. lname(4)) then write (errmsg, '(a)') 'RHOS NOT SPECIFIED IN GRIDDATA BLOCK.' call store_error(errmsg) end if @@ -851,27 +832,6 @@ subroutine read_data(this) end if end if ! - ! -- Check for latent heat of vaporization. May be used by multiple packages - ! wherever evaporation occurs, is specified in mst instead of in multiple - ! GWE packages that simulate evaporation (SFE, LKE, UZE) - if (this%ilhv > 0) then - if (.not. lname(7)) then - write (errmsg, '(a)') 'EVAPORATION IS EXPECTED IN A GWE PACKAGE & - &BUT THE LATENT HEAT OF VAPORIZATION IS NOT SPECIFIED. LATHEATVAP & - &MUST BE SPECIFIED IN GRIDDATA BLOCK.' - call store_error(errmsg) - end if - else - if (lname(7)) then - write (warnmsg, '(a)') 'LATENT HEAT OF VAPORIZATION FOR CALCULATING & - &EVAPORATION IS SPECIFIED, BUT CORRESPONDING OPTION NOT SET IN & - &OPTIONS BLOCK. EVAPORATION CALCULATIONS WILL STILL USE LATHEATVAP & - &SPECIFIED IN GWE MST PACKAGE.' - call store_warning(warnmsg) - write (this%iout, '(1x,a)') 'WARNING. '//warnmsg - end if - end if - ! ! -- terminate if errors if (count_errors() > 0) then call this%parser%StoreErrorUnit() @@ -881,6 +841,66 @@ subroutine read_data(this) return end subroutine read_data + !> @ brief Read data for package + !! + !! Method to read data for the package. + !! + !< + subroutine read_packagedata(this) + ! -- modules + ! -- dummy + class(GweMstType) :: this !< GweMstType object + ! -- local + logical :: isfound + logical :: endOfBlock + integer(I4B) :: ierr + ! + call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, & + supportopenclose=.true.) + ! + ! -- parse locations block if detected + if (isfound) then + write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%packName))// & + ' PACKAGEDATA' + do + call this%parser%GetNextLine(endOfBlock) + if (endOfBlock) then + exit + end if + ! + ! -- get fluid constants + this%cpw = this%parser%GetDouble() + this%rhow = this%parser%GetDouble() + end do + end if + ! + ! -- Check for latent heat of vaporization. May be used by multiple packages + ! wherever evaporation occurs, is specified in mst instead of in multiple + ! GWE packages that simulate evaporation (SFE, LKE, UZE) + !if (this%ilhv > 0) then + ! if (.not. lname(7)) then + ! write (errmsg, '(a)') 'EVAPORATION IS EXPECTED IN A GWE PACKAGE & + ! &BUT THE LATENT HEAT OF VAPORIZATION IS NOT SPECIFIED. LATHEATVAP & + ! &MUST BE SPECIFIED IN GRIDDATA BLOCK.' + ! call store_error(errmsg) + ! end if + !else + ! if (lname(7)) then + ! write (warnmsg, '(a)') 'LATENT HEAT OF VAPORIZATION FOR CALCULATING & + ! &EVAPORATION IS SPECIFIED, BUT CORRESPONDING OPTION NOT SET IN & + ! &OPTIONS BLOCK. EVAPORATION CALCULATIONS WILL STILL USE LATHEATVAP & + ! &SPECIFIED IN GWE MST PACKAGE.' + ! call store_warning(warnmsg) + ! write (this%iout, '(1x,a)') 'WARNING. '//warnmsg + ! end if + !end if + + ! + ! -- Return + return + end subroutine read_packagedata + + !> @ brief Calculate zero-order decay rate and constrain if necessary !! !! Function to calculate the zero-order decay rate from the user specified diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index f19bdb22fa0..a0deb320277 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -42,6 +42,7 @@ module GweSfeModule use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 use TspLabelsModule, only: TspLabelsType + use GweInputDataModule, only: GweInputDataType use MatrixModule ! implicit none @@ -55,6 +56,8 @@ module GweSfeModule type, extends(TspAptType) :: GweSfeType + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr @@ -92,7 +95,7 @@ module GweSfeModule contains subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab) + fmi, tsplab, gwecommon) ! ****************************************************************************** ! sfe_create -- Create a New SFE Package ! ****************************************************************************** @@ -109,6 +112,7 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweSfeType), pointer :: sfeobj ! ------------------------------------------------------------------------------ @@ -143,6 +147,11 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature sfeobj%tsplab => tsplab ! + ! -- Store pointer to shared data module for accessing cpw, rhow + ! for the budget calculations, and for accessing the latent heat of + ! vaporization for evaporative cooling. + sfeobj%gwecommon => gwecommon + ! ! -- return return end subroutine sfe_create @@ -730,7 +739,7 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) - heatlat = this%bndType%rhow(n1) * this%latheatvap(n1) ! kg/m^3 * J/kg = J/m^3 + heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 3a8aa425f69..944dcc9c6d7 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -35,9 +35,11 @@ module GweUzeModule use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 use TspLabelsModule, only: TspLabelsType + use GweInputDataModule, only: GweInputDataType use MatrixModule + implicit none - + public uze_create character(len=*), parameter :: ftype = 'UZE' @@ -45,6 +47,8 @@ module GweUzeModule character(len=16) :: text = ' UZE' type, extends(TspAptType) :: GweUzeType + + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst integer(I4B), pointer :: idxbudinfl => null() ! index of uzf infiltration terms in flowbudptr integer(I4B), pointer :: idxbudrinf => null() ! index of rejected infiltration terms in flowbudptr @@ -80,7 +84,7 @@ module GweUzeModule contains subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab) + fmi, tsplab, gwecommon) ! ****************************************************************************** ! uze_create -- Create a New UZE Package ! ****************************************************************************** @@ -97,6 +101,7 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweUzeType), pointer :: uzeobj ! ------------------------------------------------------------------------------ @@ -131,6 +136,11 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature uzeobj%tsplab => tsplab ! + ! -- Store pointer to shared data module for accessing cpw, rhow + ! for the budget calculations, and for accessing the latent heat of + ! vaporization + uzeobj%gwecommon => gwecommon + ! ! -- return return end subroutine uze_create @@ -476,9 +486,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! physics it captures. For example, could be something like ! cpw_vol which denotes volume-based heat capacity. Its stored ! value would represent cpw * rhow - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! ! -- add infiltration contribution @@ -548,9 +555,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) !! call matrix_sln%add_value_pos(iposd, hcofval) iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(n) ! TO DO: convince ourselves that "n" is ok here, since it's not aloop over "j" - if (kper == 3 .and. kstp == 2) then - dummy = 2.2 - end if call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -991,9 +995,6 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbudinfl)%id1(ientry) @@ -1041,9 +1042,6 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbudrinf)%id1(ientry) @@ -1084,9 +1082,6 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded ! -- TODO: Latent heat will likely need to play a role here at some point - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbuduzet)%id1(ientry) @@ -1133,9 +1128,6 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbudritm)%id1(ientry) diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index 9a2c3a7df8c..25e4217d56a 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -4696,8 +4696,7 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja, & - cpw, rhow, latheatvap) + subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package ! has access to these things. @@ -4711,9 +4710,6 @@ subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja, & real(DP), dimension(:), pointer, contiguous :: xnew real(DP), dimension(:), pointer, contiguous :: xold real(DP), dimension(:), pointer, contiguous :: flowja - real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (for GWE model type) - real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (for GWE model type) - real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (used by GWE model type, not here) ! -- local ! ------------------------------------------------------------------------------ ! diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index d71b15ac67b..7d9cae2bcf3 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -3075,8 +3075,7 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja, & - cpw, rhow, latheatvap) + subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package ! has access to these things. @@ -3093,9 +3092,6 @@ subroutine maw_set_pointers(this, neq, ibound, xnew, xold, flowja, & real(DP), dimension(:), pointer, contiguous :: xnew real(DP), dimension(:), pointer, contiguous :: xold real(DP), dimension(:), pointer, contiguous :: flowja - real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (used by GWE model type, not here) - real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (used by GWE model type, not here) - real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (used by GWE model type, not here) ! -- local integer(I4B) :: n integer(I4B) :: istart, iend diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 71de795efa9..609901d11e4 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -1380,10 +1380,7 @@ subroutine apt_da(this) call mem_deallocate(this%idxbudaux) call mem_deallocate(this%idxbudssm) call mem_deallocate(this%nconcbudssm) - ! - ! -- nullify pointers - nullify(this%cpw) - nullify(this%rhow) + ! ! -- deallocate scalars in NumericalPackageType call this%BndType%bnd_da() @@ -2035,8 +2032,7 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & - latheatvap) + subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) ! ****************************************************************************** ! set_pointers -- Set pointers to model arrays and variables so that a package ! has access to these things. @@ -2050,26 +2046,13 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & real(DP), dimension(:), pointer, contiguous :: xnew real(DP), dimension(:), pointer, contiguous :: xold real(DP), dimension(:), pointer, contiguous :: flowja - real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (for GWE model type) - real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (for GWE model type) - real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (for GWE evaporation) ! ! -- local integer(I4B) :: istart, iend ! ------------------------------------------------------------------------------ ! ! -- call base BndType set_pointers - if (.not.present(cpw) .and. .not.present(rhow)) then - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) - else - if (.not.present(latheatvap)) then - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja, & - cpw, rhow) - else - call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja, & - cpw, rhow, latheatvap) - end if - end if + call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja) ! ! -- Set the pointers ! @@ -2541,9 +2524,6 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%bndtype%cpw(1) * this%bndtype%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! n1 = ientry @@ -2577,10 +2557,6 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ! ------------------------------------------------------------------------------ ! ! -- If GWE package, adjust for thermal units - unitadj = DONE ! TODO: Avoid checking whether solute or energy - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%cpw(ientry) * this%rhow(ientry) - end if unitadj = DONE ! jiffylube: kluge debug ! ! -- Calculate MVR-related terms @@ -2614,10 +2590,6 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ! ------------------------------------------------------------------------------ ! ! -- If GWE package, adjust for thermal units - unitadj = DONE ! TODO: Avoid checking whether solute or energy - if (associated(this%cpw).and.associated(this%rhow)) then - unitadj = this%cpw(1) * this%rhow(1) - end if unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(ientry) diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 03c9aab93aa..60a1081c88d 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -9,6 +9,7 @@ module TspCncModule use ObserveModule, only: ObserveType use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList + use GweInputDataModule, only: GweInputDataType use MatrixModule ! implicit none @@ -20,9 +21,14 @@ module TspCncModule character(len=LENPACKAGENAME) :: text = ' CNC' ! type, extends(BndType) :: TspCncType + + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + real(DP), dimension(:), pointer, contiguous :: ratecncin => null() !simulated flows into constant conc (excluding other concs) real(DP), dimension(:), pointer, contiguous :: ratecncout => null() !simulated flows out of constant conc (excluding to other concs) + contains + procedure :: bnd_rp => cnc_rp procedure :: bnd_ad => cnc_ad procedure :: bnd_ck => cnc_ck @@ -42,7 +48,7 @@ module TspCncModule contains subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - tsplab) + tsplab, gwecommon) ! ****************************************************************************** ! cnc_create -- Create a New Constant Concentration/Temperature Package ! Subroutine: (1) create new-style package @@ -60,6 +66,7 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspLabelsType), pointer :: tsplab + type(GweInputDataType), intent(in), target, optional :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(TspCncType), pointer :: cncobj ! ------------------------------------------------------------------------------ @@ -89,6 +96,11 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Give package access to the assigned labels based on dependent variable packobj%tsplab => tsplab ! + ! -- Give package access to the shared heat transport variables assigned in MST + if (present(gwecommon)) then + cncobj%gwecommon => gwecommon + end if + ! ! -- return return end subroutine cnc_create @@ -369,7 +381,7 @@ subroutine cnc_bd(this, model_budget) if (this%tsplab%tsptype /= 'GWE') then unitadj = DONE else - unitadj = this%cpw(1) * this%rhow(1) ! jiffylube: kluge note - check use of unitadj in cnc + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow end if ! do n = 1, size(this%ratecncin) @@ -405,6 +417,9 @@ subroutine cnc_da(this) call mem_deallocate(this%ratecncin) call mem_deallocate(this%ratecncout) ! + ! -- pointers + nullify (this%gwecommon) + ! ! -- return return end subroutine cnc_da diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 8ead6f52f17..089026ce674 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -17,6 +17,7 @@ module TspSsmModule use BaseDisModule, only: DisBaseType use TspFmiModule, only: TspFmiType use TspLabelsModule, only: TspLabelsType + use GweInputDataModule, only: GweInputDataType use TableModule, only: TableType, table_cr use GwtSpcModule, only: GwtSpcType use MatrixModule @@ -36,7 +37,9 @@ module TspSsmModule !! !< type, extends(NumericalPackageType) :: TspSsmType - + + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + integer(I4B), pointer :: nbound !< total number of flow boundaries in this time step integer(I4B), dimension(:), pointer, contiguous :: isrctype => null() !< source type 0 is unspecified, 1 is aux, 2 is auxmixed, 3 is ssmi, 4 is ssmimixed integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration @@ -81,7 +84,7 @@ module TspSsmModule !! and initializing the parser. !! !< - subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab) + subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, gwecommon) ! -- dummy type(TspSsmType), pointer :: ssmobj !< TspSsmType object character(len=*), intent(in) :: name_model !< name of the model @@ -89,6 +92,7 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab) integer(I4B), intent(in) :: iout !< fortran unit for output type(TspFmiType), intent(in), target :: fmi !< Transport FMI package type(TspLabelsType), intent(in), pointer :: tsplab !< TspLabelsType object + type(GweInputDataType), intent(in), target, optional :: gwecommon !< shared data container for use by multiple GWE packages ! ! -- Create the object allocate (ssmobj) @@ -111,6 +115,11 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab) ! package has access to the corresponding dependent variable type ssmobj%tsplab => tsplab ! + ! -- Give package access to the shared heat transport variables assigned in MST + if (present(gwecommon)) then + ssmobj%gwecommon => gwecommon + end if + ! ! -- Return return end subroutine ssm_cr @@ -140,7 +149,7 @@ end subroutine ssm_df !! options and data, and sets up the output table. !! !< - subroutine ssm_ar(this, dis, ibound, cnew, cpw, rhow) + subroutine ssm_ar(this, dis, ibound, cnew) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy @@ -148,8 +157,6 @@ subroutine ssm_ar(this, dis, ibound, cnew, cpw, rhow) class(DisBaseType), pointer, intent(in) :: dis !< discretization package integer(I4B), dimension(:), pointer, contiguous :: ibound !< GWT model ibound real(DP), dimension(:), pointer, contiguous :: cnew !< GWT model dependent variable - real(DP), dimension(:), pointer, contiguous, optional :: cpw !< GWE heat capacity paramter - real(DP), dimension(:), pointer, contiguous, optional :: rhow !< GWE fluid density paramter ! -- local ! -- formats character(len=*), parameter :: fmtssm = & @@ -163,8 +170,6 @@ subroutine ssm_ar(this, dis, ibound, cnew, cpw, rhow) this%dis => dis this%ibound => ibound this%cnew => cnew - if (present(cpw)) this%cpw => cpw - if (present(rhow)) this%rhow => rhow ! ! -- Check to make sure that there are flow packages if (this%fmi%nflowpack == 0) then @@ -356,7 +361,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! ! -- If GWE transport model type, adjust units to energy if (this%tsplab%tsptype == "GWE") then - unitadj = this%cpw(n) * this%rhow(n) ! jiffylube: kluge note - check use of unitadj in ssm + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow end if ! ! -- Add terms based on qbnd sign @@ -743,9 +748,8 @@ subroutine ssm_da(this) ! -- Scalars call mem_deallocate(this%nbound) ! - ! -- nullify pointers - nullify(this%cpw) - nullify(this%rhow) + ! -- Pointers + nullify (this%gwecommon) ! ! -- deallocate parent call this%NumericalPackageType%da() diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 4d293e4dbca..cdf5d98b4f8 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -111,11 +111,6 @@ module BndModule type(TableType), pointer :: inputtab => null() !< input table object type(TableType), pointer :: outputtab => null() !< output table object for package flows writtent to the model listing file type(TableType), pointer :: errortab => null() !< package error table - ! - ! -- physical parameters - real(DP), dimension(:), pointer, contiguous :: cpw => null() !< points to heat capacity specified in GWE MST package - real(DP), dimension(:), pointer, contiguous :: rhow => null() !< points to density of fluid specified in GWE MST package - real(DP), dimension(:), pointer, contiguous :: latheatvap => null() !< points to latent heat of vaporization in GWE MST package contains procedure :: bnd_df @@ -1210,8 +1205,7 @@ end subroutine pack_initialize !! variables. This base method should not need to be overridden. !! !< - subroutine set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & - latheatvap) + subroutine set_pointers(this, neq, ibound, xnew, xold, flowja) ! -- dummy variables class(BndType) :: this !< BndType object integer(I4B), pointer :: neq !< number of equations in the model @@ -1219,9 +1213,6 @@ subroutine set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & real(DP), dimension(:), pointer, contiguous :: xnew !< current dependent variable real(DP), dimension(:), pointer, contiguous :: xold !< previous dependent variable real(DP), dimension(:), pointer, contiguous :: flowja !< connection flow terms - real(DP), dimension(:), pointer, contiguous, optional :: cpw !< heat capacity of fluid (for GWE model type) - real(DP), dimension(:), pointer, contiguous, optional :: rhow !< density of fluid (for GWE model type) - real(DP), dimension(:), pointer, contiguous, optional :: latheatvap !< latent heat of vaporization (for GWE model type) ! ! -- Set the pointers this%neq => neq @@ -1230,11 +1221,6 @@ subroutine set_pointers(this, neq, ibound, xnew, xold, flowja, cpw, rhow, & this%xold => xold this%flowja => flowja ! - ! -- if part of a GWE simulation, need heat capacity(cpw) and density (rhow) - if (present(cpw)) this%cpw => cpw - if (present(rhow)) this%rhow => rhow - if (present(latheatvap)) this%latheatvap => latheatvap - ! ! -- return end subroutine set_pointers diff --git a/src/Model/ModelUtilities/GweInputData.f90 b/src/Model/ModelUtilities/GweInputData.f90 new file mode 100644 index 00000000000..1b6d7222177 --- /dev/null +++ b/src/Model/ModelUtilities/GweInputData.f90 @@ -0,0 +1,229 @@ +module GweInputDataModule + + use KindModule, only: I4B, DP + use ConstantsModule, only: DZERO, LENMEMPATH + + implicit none + private + public :: GweInputDataType + public :: gweshared_dat_cr + public :: gweshared_dat_df + public :: set_gwe_dat_ptrs + + !> Data for sharing among multiple packages. Originally read in from + !< the MST package + + type GweInputDataType + + ! dim + integer(I4B) :: nnodes !< number of cells + + ! strings + character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored + + ! mst data to be share across multiple packages + real(DP), pointer :: gwerhow => null() !< Density of water (for GWE purposes, a constant scalar) + real(DP), pointer :: gwecpw => null() !< Heat capacity of water (non-spatially varying) + real(DP), pointer :: gwelatheatvap => null() !< latent heat of vaporization + real(DP), dimension(:), pointer, contiguous :: gwerhos => null() !< Density of the aquifer material + real(DP), dimension(:), pointer, contiguous :: gwecps => null() !< Heat capacity of solids (spatially varying) + + contains + + ! -- public + procedure, public :: gweshared_dat_df + procedure, public :: set_gwe_dat_ptrs + procedure, public :: gweshared_dat_da + ! -- private + procedure, private :: allocate_shared_vars + procedure, private :: set_gwe_shared_scalars + procedure, private :: set_gwe_shared_arrays + + end type GweInputDataType + +contains + +!> @brief Allocate the shared data +!< + subroutine gweshared_dat_cr(this) + ! -- modules + ! -- dummy + type(GweInputDataType), pointer :: this !< the input data block + ! -- local +! ------------------------------------------------------------------- + ! + ! -- Create the object + allocate (this) + ! + ! -- return + return + end subroutine gweshared_dat_cr + +!> @brief Define the shared data +!< + subroutine gweshared_dat_df(this, nodes) + ! -- modules + ! -- dummy + class(GweInputDataType) :: this !< the input data block + integer(I4B), intent(in) :: nodes + ! -- local +! ------------------------------------------------------------------- + ! + ! -- Allocate variables + call this%allocate_shared_vars(nodes) + ! + ! -- return + return + end subroutine gweshared_dat_df + + !> @brief Define the information this object holds + !! + !! Allocate strings for storing label names + !! Intended to be analogous to allocate_scalars() + !! + !< + subroutine allocate_shared_vars(this, nodes) + ! -- modules + ! -- dummy + class(GweInputDataType) :: this !< TspLabelsType object + integer(I4B), intent(in) :: nodes + ! -- local + integer(I4B) :: i +! ------------------------------------------------------------------- + ! + allocate (this%gwecpw) + allocate (this%gwerhow) + allocate (this%gwelatheatvap) + allocate (this%gwerhos(nodes)) + allocate (this%gwecps(nodes)) + ! + ! -- Initialize values + this%gwecpw = DZERO + this%gwerhow = DZERO + this%gwelatheatvap = DZERO + do i=1, nodes + this%gwecps(i) = DZERO + this%gwerhos(i) = DZERO + end do + ! + ! -- return + return + end subroutine allocate_shared_vars + + + !> @brief Allocate and read data from MST + !! + !! MST data, including heat capacity of water (cpw), density of water + !! (rhow), latent heat of vaporization (latheatvap), heat capacity of + !! the aquifer material (cps), and density of the aquifer material + !! (rhow) is used among other packages and is therefore stored in a + !! separate class + subroutine set_gwe_dat_ptrs(this, gwerhow, gwecpw, gwerhos, gwecps, & + gwelatheatvap) + ! -- modules + ! -- dummy + class(GweInputDataType) :: this !< the input data block + real(DP), intent(in) :: gwerhow !< ptr to density of water specified in MST + real(DP), intent(in) :: gwecpw !< ptr to heat capacity of water specified in MST + real(DP), intent(in) :: gwerhos !< ptr to sptially-variably density of aquifer material specified in MST + real(DP), intent(in) :: gwecps !< ptr to sptially-variably heat capacity of aquifer material specified in MST + real(DP), intent(in), optional :: gwelatheatvap !< ptr to latent heat of vaporization specified in MST + ! ------------------------------------------------------------------- + ! + ! -- Allocate scalars + if (present(gwelatheatvap)) then + call this%set_gwe_shared_scalars(gwerhow, gwecpw, gwelatheatvap) + else + call this%set_gwe_shared_scalars(gwerhow, gwecpw) + end if + ! + ! -- Allocate arrays + call this%set_gwe_shared_arrays(gwerhos, gwecps) + ! + ! -- return + return + end subroutine set_gwe_dat_ptrs + + !> @brief Set pointers to scalars read by the MST package + !! for use by other packages + !! + !! Set pointers to GWE-related scalars and arrays for use + !! by multiple packages. For example, a package capable of + !! simulating evaporation will need access to latent heat of + !! of vaporization. + !! + !< + subroutine set_gwe_shared_scalars(this, gwerhow, gwecpw, gwelatheatvap) + ! -- modules + ! -- dummy + class(GweInputDataType) :: this !< GweInputDataType object + real(DP), intent(in) :: gwerhow + real(DP), intent(in) :: gwecpw + real(DP), intent(in), optional :: gwelatheatvap + ! -- local +! ------------------------------------------------------------------- + ! + ! -- Set the pointers + ! -- Fixed density of water to be used by GWE + this%gwerhow = gwerhow + ! -- Spatially constant heat capacity of water + this%gwecpw = gwecpw + ! -- Latent heat of vaporization + if (present(gwelatheatvap)) then + this%gwelatheatvap = gwelatheatvap + end if + ! + ! -- return + return + end subroutine set_gwe_shared_scalars + + !> @brief Set pointers to data arrays read by the MST package + !! for use by other packages + !! + !! Set pointers to GWE-related arrays for use + !! by multiple packages. + !! + !< + subroutine set_gwe_shared_arrays(this, gwerhos, gwecps) + ! -- modules + ! -- dummy + class(GweInputDataType) :: this !< GweInputDataType object + real(DP), intent(in) :: gwerhos + real(DP), intent(in) :: gwecps + ! -- local +! ------------------------------------------------------------------- + ! + ! -- Set the pointers + ! -- Spatially-variable density of aquifer solid material + this%gwerhos = gwerhos + ! -- Spatially-variable heat capacity of aquifer solid material + this%gwecps = gwecps + ! + ! -- return + return + end subroutine set_gwe_shared_arrays + + !> @ breif Deallocate memory + !! + !! Deallocate GWE shared data array memory + !! + !< + subroutine gweshared_dat_da(this) + ! -- modules + ! -- dummy + class(GweInputDataType) :: this !< the input data block + ! + ! -- Scalars + deallocate (this%gwelatheatvap) + deallocate (this%gwerhow) + deallocate (this%gwecpw) + ! + ! -- Arrays + deallocate (this%gwerhos) + deallocate (this%gwecps) + ! + ! -- return + return + end subroutine gweshared_dat_da + +end module GweInputDataModule From 5ddb427bd15bff0bc9f91cfe98bdb29f5a502a66 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 27 Mar 2023 09:41:25 -0700 Subject: [PATCH 097/212] Updates to energy src loading package for GWE --- src/Model/GroundWaterEnergy/gwe1.f90 | 12 ++++++------ src/Model/GroundWaterEnergy/gwe1src1.f90 | 15 +++++++++++++-- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 3e238db0544..d421fbaae34 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1142,7 +1142,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & use ConstantsModule, only: LINELENGTH use SimModule, only: store_error use TspCncModule, only: cnc_create -! use GweSrcModule, only: src_create + use GweSrcModule, only: src_create ! use GweLktModule, only: lkt_create use GweSfeModule, only: sfe_create ! use GweMwtModule, only: mwt_create @@ -1168,19 +1168,19 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & case ('TMP6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab, this%gwecommon) - !case('SRC6') - ! call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname) + case ('SRC6') + call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab, this%gwecommon) !case('LKT6') ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) - case('SFE6') + case ('SFE6') call sfe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%tsplab, this%gwecommon) !case('MWT6') ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) - case('UZE6') + case ('UZE6') call uze_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%tsplab, this%gwecommon) !case('IST6') diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index 5faeafa1be0..7cbe1958ef9 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -8,6 +8,7 @@ module GweSrcModule use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList use BlockParserModule, only: BlockParserType + use GweInputDataModule, only: GweInputDataType use MatrixModule ! implicit none @@ -19,7 +20,11 @@ module GweSrcModule character(len=16) :: text = ' SRC' ! type, extends(BndType) :: GweSrcType + + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + contains + procedure :: allocate_scalars => src_allocate_scalars procedure :: bnd_cf => src_cf procedure :: bnd_fc => src_fc @@ -35,7 +40,7 @@ module GweSrcModule contains subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - tsplab) + tsplab, gwecommon) ! ****************************************************************************** ! src_create -- Create a New Src Package ! Subroutine: (1) create new-style package @@ -53,6 +58,7 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspLabelsType), pointer :: tsplab + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweSrcType), pointer :: srcobj ! ------------------------------------------------------------------------------ @@ -82,6 +88,11 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! package has access to the assigned labels packobj%tsplab => tsplab ! + ! -- Store pointer to shared data module for accessing cpw, rhow + ! for the budget calculations, and for accessing the latent heat of + ! vaporization for evaporative cooling. + srcobj%gwecommon => gwecommon + ! ! -- return return end subroutine src_create @@ -168,7 +179,7 @@ subroutine src_cf(this, reset_mover) cycle end if q = this%bound(1, i) - this%rhs(i) = -q + this%rhs(i) = -q / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) end do ! return From 07682838c1e220f458b3fe71fd78d6763cbe4a74 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Tue, 4 Apr 2023 09:57:55 -0400 Subject: [PATCH 098/212] * Programmed uze budget calculations. This involved some relatively minor changes to apt, and very minor changes to the other advanced packages, as well. * Note that in the uze budget there are separate line items for recharge to the water table and thermal equilibration (two kinds of interaction with the gwe cell). In the gwe cell budget, those are combined in one uze line item. * Cleaned up application (or not) of unitadj in various heat-transport packages; in some places simply left notes about needed changes * Note that budget calculations in heat-transport packages other than uze do not all necessarily apply unitadj as needed yet. Uze overrides some apt budget routines so it can call them and then multiply the result by unitadj, which was minimally invasive to apt. But we'll want to go ahead and make unitadj avaiable to apt (perhaps as "ratefactor") and apply it directly there instead. For solute transport, ratefactor will simply be 1. --- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 17 +- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 9 +- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 331 ++++++++++++++++++-- src/Model/GroundWaterTransport/gwt1lkt1.f90 | 3 +- src/Model/GroundWaterTransport/gwt1mwt1.f90 | 3 +- src/Model/GroundWaterTransport/gwt1sft1.f90 | 3 +- src/Model/GroundWaterTransport/gwt1uzt1.f90 | 3 +- src/Model/GroundWaterTransport/tsp1apt1.f90 | 132 ++++---- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 2 +- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 17 +- 10 files changed, 411 insertions(+), 109 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 0425716c324..3dde422ad9f 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -365,10 +365,11 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) ! -- initialize tled = DONE / delt ! + unitadj = this%cpw * this%rhow + ! ! -- Calculate storage change do n = 1, nodes this%ratesto(n) = DZERO - unitadj = this%cpw * this%rhow ! ! -- skip if transport inactive if (this%ibound(n) <= 0) cycle @@ -382,10 +383,10 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate - term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow * this%cpw) + term = vsolid * (this%rhos(n) * this%cps(n)) / unitadj hhcof = -(vwatnew + term) * tled rrhs = -(vwatold + term) * tled * cold(n) - rate = hhcof * cnew(n) - rrhs + rate = (hhcof * cnew(n) - rrhs) * unitadj this%ratesto(n) = rate idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate @@ -471,11 +472,11 @@ subroutine mst_bd(this, isuppress_output, model_budget) real(DP) :: rin real(DP) :: rout ! - ! -- for GWE, storage rate needs to have units adjusted - do n = 1, size(this%ratesto) - this%ratesto(n) = this%ratesto(n) * this%cpw * this%rhow - end do - ! +!! ! -- for GWE, storage rate needs to have units adjusted +!! do n = 1, size(this%ratesto) +!! this%ratesto(n) = this%ratesto(n) * this%cpw * this%rhow +!! end do +!! ! ! -- sto call rate_accumulator(this%ratesto, rin, rout) call model_budget%addentry(rin, rout, delt, budtxt(1), & diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index a0deb320277..f8a62e84496 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -317,7 +317,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add evaporation contribution if (this%idxbudevap /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist - call this%sfe_evap_term(j, n1, n2, rrate, rhsval) !, hcofval) + call this%sfe_evap_term(j, n1, n2, rrate, rhsval) !, hcofval) ! kluge note: should include hcofval in the call; it'll be set to zero iloc = this%idxlocnode(n1) iposd = this%idxpakdiag(n1) call matrix_sln%add_value_pos(iposd, hcofval) @@ -522,12 +522,13 @@ end subroutine sfe_setup_budobj !> @brief Copy flow terms into this%budobj !< - subroutine sfe_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- modules ! -- dummy class(GweSfeType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local @@ -741,7 +742,7 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day - if (present(rhsval)) rhsval = -rrate + if (present(rhsval)) rhsval = -rrate ! kluge note: shouldn't this be divided by unitadj?? if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -768,7 +769,7 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) ! kluge note: yes, multiply by unitadj if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 944dcc9c6d7..1f9911ad29f 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -20,6 +20,7 @@ ! REJ-INF idxbudrinf REJ-INF q * cuze ! UZET idxbuduzet UZET q * cet ! REJ-INF-TO-MVR idxbudritm REJ-INF-TO-MVR q * cinfil? +! THERMAL-EQUIL idxbudtheq THERMAL-EQUIL residual ! -- terms from UZF that should be skipped @@ -54,6 +55,7 @@ module GweUzeModule integer(I4B), pointer :: idxbudrinf => null() ! index of rejected infiltration terms in flowbudptr integer(I4B), pointer :: idxbuduzet => null() ! index of unsat et terms in flowbudptr integer(I4B), pointer :: idxbudritm => null() ! index of rej infil to mover rate to mover terms in flowbudptr + integer(I4B), pointer :: idxbudtheq => null() ! index of thermal equilibration terms in flowbudptr real(DP), dimension(:), pointer, contiguous :: tempinfl => null() ! infiltration temperature real(DP), dimension(:), pointer, contiguous :: tempuzet => null() ! unsat et temperature @@ -64,6 +66,7 @@ module GweUzeModule procedure :: apt_allocate_arrays => uze_allocate_arrays procedure :: find_apt_package => find_uze_package procedure :: apt_fc_expanded => uze_fc_expanded + procedure :: apt_cfupdate => uze_cfupdate procedure :: pak_solve => uze_solve procedure :: pak_get_nbudterms => uze_get_nbudterms procedure :: pak_setup_budobj => uze_setup_budobj @@ -72,6 +75,11 @@ module GweUzeModule procedure :: uze_rinf_term procedure :: uze_uzet_term procedure :: uze_ritm_term + procedure :: uze_theq_term + procedure :: apt_stor_term => uze_stor_term + procedure :: apt_tmvr_term => uze_tmvr_term + procedure :: apt_fmvr_term => uze_fmvr_term + procedure :: apt_fjf_term => uze_fjf_term procedure :: pak_df_obs => uze_df_obs procedure :: pak_rp_obs => uze_rp_obs procedure :: pak_bd_obs => uze_bd_obs @@ -246,6 +254,9 @@ subroutine find_uze_package(this) case ('FROM-MVR') this%idxbudfmvr = ip this%idxbudssm(ip) = 0 + case ('THERMAL-EQUIL') + this%idxbudtheq= ip + this%idxbudssm(ip) = 0 case ('AUXILIARY') this%idxbudaux = ip this%idxbudssm(ip) = 0 @@ -256,6 +267,10 @@ subroutine find_uze_package(this) this%idxbudssm(ip) = icount icount = icount + 1 end select + ! + ! -- thermal equilibration term + this%idxbudtheq = this%flowbudptr%nbudterm + 1 + ! write (this%iout, '(a, i0, " = ", a,/, a, i0)') & ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist @@ -394,8 +409,8 @@ subroutine uze_mc(this, moffset, matrix_sln) !! ! to the host cell global row rather than the feature global row !! this%idxlocnode(n) = jglo ! to the host cell local row index rather than the feature local - ! row index ! jiffylube: LOCAL row - this%idxlocnode(n) = j ! jiffylube: LOCAL row + ! row index + this%idxlocnode(n) = j ! kluge note: do we want to introduce a new array instead of co-opting idxlocnode??? ! -- for connection ipos in list of feature-cell connections, ! global positions of feature-row diagonal and off-diagonal ! corresponding to the cell @@ -481,12 +496,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ------------------------------------------------------------------------------ ! ! -- TODO: This needs to be cleaned up, unitadj should be based on - ! scalars that are spatially constant. + ! scalars that are spatially constant. ! kluge note: done ! At some point, unitadj's name should be adapted to represent the ! physics it captures. For example, could be something like ! cpw_vol which denotes volume-based heat capacity. Its stored - ! value would represent cpw * rhow - unitadj = DONE ! jiffylube: kluge debug + ! value would represent cpw * rhow ! kluge note: unitadj no longer appears in this subroutine; this comment pertains to unitadj in general ! ! -- add infiltration contribution ! uze does not put feature balance coefficients in the row @@ -611,8 +625,8 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) !! -- add to gwf row for apt connection (recharge) !!ipossymd = this%idxsymdglo(j) !!ipossymoffd = this%idxsymoffdglo(j) - !!call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd * unitadj) - !!call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd * unitadj) + !!call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) + !!call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) end if end do ! @@ -629,8 +643,8 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end if iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row iposoffd = this%idxfjfoffdglo(j) !< position of feature-id2 column in feature id1's host-cell row - call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) + call matrix_sln%add_value_pos(iposd, omega * qbnd) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) end do end if ! @@ -638,7 +652,40 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine uze_fc_expanded - subroutine uze_solve(this) + subroutine uze_cfupdate(this) +! ****************************************************************************** +! uze_cfupdate -- calculate package hcof and rhs so gwt budget is calculated +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweUzeType) :: this + ! -- local + integer(I4B) :: j, n + real(DP) :: qbnd + real(DP) :: omega + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + ! + ! -- Calculate hcof and rhs terms so GWF exchanges are calculated correctly + ! -- go through each apt-gwf connection and calculate + ! rhs and hcof terms for gwt/gwe matrix rows + call this%TspAptType%apt_cfupdate() + ! + ! -- Apply scaling to units of energy per time + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + this%hcof(j) = this%hcof(j) * unitadj + this%rhs(j) = this%rhs(j) * unitadj + end do + ! + ! -- Return + return + end subroutine uze_cfupdate + + subroutine uze_solve(this) ! kluge note: no explicit solve for uze ! ****************************************************************************** ! uze_solve -- add terms specific to the unsaturated zone to the explicit ! unsaturated-zone solve @@ -706,12 +753,13 @@ function uze_get_nbudterms(this) result(nbudterms) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- Number of budget terms is 4 + ! -- Number of budget terms is 5 nbudterms = 0 if (this%idxbudinfl /= 0) nbudterms = nbudterms + 1 if (this%idxbudrinf /= 0) nbudterms = nbudterms + 1 if (this%idxbuduzet /= 0) nbudterms = nbudterms + 1 if (this%idxbudritm /= 0) nbudterms = nbudterms + 1 + if (this%idxbudtheq /= 0) nbudterms = nbudterms + 1 ! ! -- Return return @@ -731,8 +779,9 @@ subroutine uze_setup_budobj(this, idx) class(GweUzeType) :: this integer(I4B), intent(inout) :: idx ! -- local - integer(I4B) :: maxlist, naux + integer(I4B) :: maxlist, naux, n, n1, n2 character(len=LENBUDTXT) :: text + real(DP) :: q ! ------------------------------------------------------------------------------ ! ! -- @@ -794,14 +843,29 @@ subroutine uze_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) + end if + ! + ! -- + text = ' THERMAL-EQUIL' + idx = idx + 1 + ! -- use dimension of GWF term + maxlist = this%flowbudptr%budterm(this%idxbudgwf)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) ! ! -- return return end subroutine uze_setup_budobj - subroutine uze_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! uze_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -809,19 +873,27 @@ subroutine uze_fill_budobj(this, idx, x, ccratin, ccratout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use BudgetTermModule, only : LENBUDTXT ! kluge?? ! -- dummy class(GweUzeType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local - integer(I4B) :: j, n1, n2 - integer(I4B) :: nlist + integer(I4B) :: j, n1, n2, i + integer(I4B) :: nlist, nbudterm + integer(I4B) :: igwfnode + integer(I4B) :: idiag real(DP) :: q + real(DP) :: unitadj + character(len=LENBUDTXT) :: flowtype ! kluge?? ! -- formats ! ----------------------------------------------------------------------------- + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + ! -- INFILTRATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist @@ -868,6 +940,41 @@ subroutine uze_fill_budobj(this, idx, x, ccratin, ccratout) end do end if + ! -- THERMAL-EQUIL + ! -- processed last because it is calculated from the residual + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudgwf)%nlist + nbudterm = this%budobj%nbudterm + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + q = DZERO + n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + if (this%iboundpak(n1) /= 0) then + igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) + do i = 1, nbudterm + flowtype = this%budobj%budterm(i)%flowtype + select case (trim(adjustl(flowtype))) + case ('THERMAL-EQUIL') + ! skip + continue + case ('FLOW-JA-FACE') + ! skip + continue + case default + q = q - this%budobj%budterm(i)%flow(j) +!! write(6,*) flowtype, this%budobj%budterm(i)%flow(j) +!! flush(6) + end select + end do + call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + ! -- for gwe cell budget + this%simvals(n1) = this%simvals(n1) - q + idiag = this%dis%con%ia(igwfnode) + flowja(idiag) = flowja(idiag) - q + end if + end do + ! ! -- return return @@ -895,12 +1002,14 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudrinf, 'IDXBUDRINF', this%memoryPath) call mem_allocate(this%idxbuduzet, 'IDXBUDUZET', this%memoryPath) call mem_allocate(this%idxbudritm, 'IDXBUDRITM', this%memoryPath) + call mem_allocate(this%idxbudtheq, 'IDXBUDTHEQ', this%memoryPath) ! ! -- Initialize this%idxbudinfl = 0 this%idxbudrinf = 0 this%idxbuduzet = 0 this%idxbudritm = 0 + this%idxbudtheq = 0 ! ! -- Return return @@ -958,6 +1067,7 @@ subroutine uze_da(this) call mem_deallocate(this%idxbudrinf) call mem_deallocate(this%idxbuduzet) call mem_deallocate(this%idxbudritm) + call mem_deallocate(this%idxbudtheq) ! ! -- deallocate time series call mem_deallocate(this%tempinfl) @@ -995,7 +1105,7 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - unitadj = DONE ! jiffylube: kluge debug + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow ! n1 = this%flowbudptr%budterm(this%idxbudinfl)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudinfl)%id2(ientry) @@ -1011,8 +1121,10 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & r = -qbnd * ctmp end if if (present(rrate)) rrate = qbnd * ctmp * unitadj - if (present(rhsval)) rhsval = r * unitadj - if (present(hcofval)) hcofval = h * unitadj +!! if (present(rhsval)) rhsval = r * unitadj +!! if (present(hcofval)) hcofval = h * unitadj + if (present(rhsval)) rhsval = r + if (present(hcofval)) hcofval = h ! ! -- return return @@ -1042,15 +1154,17 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - unitadj = DONE ! jiffylube: kluge debug + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow ! n1 = this%flowbudptr%budterm(this%idxbudrinf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudrinf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrinf)%flow(ientry) ctmp = this%tempinfl(n1) if (present(rrate)) rrate = ctmp * qbnd * unitadj - if (present(rhsval)) rhsval = DZERO * unitadj - if (present(hcofval)) hcofval = qbnd * unitadj +!! if (present(rhsval)) rhsval = DZERO * unitadj +!! if (present(hcofval)) hcofval = qbnd * unitadj + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd ! ! -- return return @@ -1082,7 +1196,7 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded ! -- TODO: Latent heat will likely need to play a role here at some point - unitadj = DONE ! jiffylube: kluge debug + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow ! n1 = this%flowbudptr%budterm(this%idxbuduzet)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbuduzet)%id2(ientry) @@ -1097,8 +1211,10 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & if (present(rrate)) & rrate = (omega * qbnd * this%xnewpak(n1) + & (DONE - omega) * qbnd * ctmp) * unitadj ! jiffylube: added parens so unitadj multiplies the whole expression - if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * unitadj - if (present(hcofval)) hcofval = omega * qbnd * unitadj +!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * unitadj +!! if (present(hcofval)) hcofval = omega * qbnd * unitadj + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp + if (present(hcofval)) hcofval = omega * qbnd ! ! -- return return @@ -1128,20 +1244,170 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & ! ! -- TODO: these unitadj values should be cleaned-up as denoted in ! uze_fc_expanded - unitadj = DONE ! jiffylube: kluge debug + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow ! n1 = this%flowbudptr%budterm(this%idxbudritm)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudritm)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudritm)%flow(ientry) ctmp = this%tempinfl(n1) if (present(rrate)) rrate = ctmp * qbnd * unitadj - if (present(rhsval)) rhsval = DZERO * unitadj - if (present(hcofval)) hcofval = qbnd * unitadj +!! if (present(rhsval)) rhsval = DZERO * unitadj +!! if (present(hcofval)) hcofval = qbnd * unitadj + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd ! ! -- return return end subroutine uze_ritm_term + subroutine uze_theq_term(this, ientry, n1, n2, rrate, & ! kluge note: not used??? + rhsval, hcofval) +! ****************************************************************************** +! uze_theq_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp + real(DP) :: h, r + real(DP) :: unitadj + integer(I4B) :: idiag +! ------------------------------------------------------------------------------ + ! + ! -- TODO: these unitadj values should be cleaned-up as denoted in + ! uze_fc_expanded + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + ! +!! n1 = this%flowbudptr%budterm(this%idxbudtheq)%id1(ientry) +!! n2 = this%flowbudptr%budterm(this%idxbudtheq)%id2(ientry) + n1 = ientry ! kluge note: is this right in general??? + h = DZERO + idiag = this%dis%con%ia(n1) + r = this%flowja(idiag) + if (present(rrate)) rrate = r * unitadj +!! if (present(rhsval)) rhsval = r * unitadj +!! if (present(hcofval)) hcofval = h * unitadj + if (present(rhsval)) rhsval = r + if (present(hcofval)) hcofval = h + ! + ! -- return + return + end subroutine uze_theq_term + + subroutine uze_stor_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) + ! -- modules + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: unitadj +! ----------------------------------------------------------------- + ! + call this%TspAptType%apt_stor_term(ientry, n1, n2, rrate, & + rhsval, hcofval) + ! + ! -- Apply scaling to units of energy per time + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + if (present(rrate)) rrate = rrate * unitadj + ! + ! -- return + return + end subroutine uze_stor_term + + subroutine uze_tmvr_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) + ! -- modules + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + ! + call this%TspAptType%apt_tmvr_term(ientry, n1, n2, rrate, & + rhsval, hcofval) + ! + ! -- Apply scaling to units of energy per time + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + if (present(rrate)) rrate = rrate * unitadj + ! + ! -- return + return + end subroutine uze_tmvr_term + + subroutine uze_fmvr_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) + ! -- modules + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + ! + call this%TspAptType%apt_fmvr_term(ientry, n1, n2, rrate, & + rhsval, hcofval) + ! + ! -- Apply scaling to units of energy per time + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + if (present(rrate)) rrate = rrate * unitadj + ! + ! -- return + return + end subroutine uze_fmvr_term + + subroutine uze_fjf_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) + ! -- modules + ! -- dummy + class(GweUzeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: unitadj +! ------------------------------------------------------------------------------ + ! + call this%TspAptType%apt_fjf_term(ientry, n1, n2, rrate, & + rhsval, hcofval) + ! + ! -- Apply scaling to units of energy per time + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + if (present(rrate)) rrate = rrate * unitadj + ! + ! -- return + return + end subroutine uze_fjf_term + subroutine uze_df_obs(this) ! ****************************************************************************** ! uze_df_obs -- obs are supported? @@ -1212,6 +1478,11 @@ subroutine uze_df_obs(this) call this%obs%StoreObsType('rej-inf-to-mvr', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('thermal-equil', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! return end subroutine uze_df_obs @@ -1237,6 +1508,8 @@ subroutine uze_rp_obs(this, obsrv, found) call this%rp_obs_byfeature(obsrv) case ('REJ-INF-TO-MVR') call this%rp_obs_byfeature(obsrv) + case ('THERMAL-EQUIL') + call this%rp_obs_byfeature(obsrv) case default found = .false. end select @@ -1279,6 +1552,10 @@ subroutine uze_bd_obs(this, obstypeid, jj, v, found) if (this%iboundpak(jj) /= 0 .and. this%idxbudritm > 0) then call this%uze_ritm_term(jj, n1, n2, v) end if + case ('THERMAL-EQUIL') + if (this%iboundpak(jj) /= 0 .and. this%idxbudtheq > 0) then + call this%uze_theq_term(jj, n1, n2, v) + end if case default found = .false. end select diff --git a/src/Model/GroundWaterTransport/gwt1lkt1.f90 b/src/Model/GroundWaterTransport/gwt1lkt1.f90 index f2d15e64feb..1b7d79b56f0 100644 --- a/src/Model/GroundWaterTransport/gwt1lkt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1lkt1.f90 @@ -553,7 +553,7 @@ subroutine lkt_setup_budobj(this, idx) return end subroutine lkt_setup_budobj - subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! lkt_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -565,6 +565,7 @@ subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout) class(GwtLktType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local diff --git a/src/Model/GroundWaterTransport/gwt1mwt1.f90 b/src/Model/GroundWaterTransport/gwt1mwt1.f90 index e29487a121b..312b2cfb267 100644 --- a/src/Model/GroundWaterTransport/gwt1mwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mwt1.f90 @@ -491,7 +491,7 @@ subroutine mwt_setup_budobj(this, idx) return end subroutine mwt_setup_budobj - subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! mwt_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -503,6 +503,7 @@ subroutine mwt_fill_budobj(this, idx, x, ccratin, ccratout) class(GwtMwtType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 5a186dfb6aa..3ff467e202c 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -521,7 +521,7 @@ subroutine sft_setup_budobj(this, idx) return end subroutine sft_setup_budobj - subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! sft_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -533,6 +533,7 @@ subroutine sft_fill_budobj(this, idx, x, ccratin, ccratout) class(GwtSftType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local diff --git a/src/Model/GroundWaterTransport/gwt1uzt1.f90 b/src/Model/GroundWaterTransport/gwt1uzt1.f90 index 4a246054e3a..26da029874a 100644 --- a/src/Model/GroundWaterTransport/gwt1uzt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1uzt1.f90 @@ -484,7 +484,7 @@ subroutine uzt_setup_budobj(this, idx) return end subroutine uzt_setup_budobj - subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! uzt_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -496,6 +496,7 @@ subroutine uzt_fill_budobj(this, idx, x, ccratin, ccratout) class(GwtUztType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 609901d11e4..32ebc050043 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -76,6 +76,8 @@ module TspAptModule integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file integer(I4B), pointer :: ncv => null() !< number of control volumes integer(I4B), pointer :: igwfaptpak => null() !< package number of corresponding this package + integer(I4B), pointer :: idxprepak => null() !< budget-object index that precedes package-specific budget objects + integer(I4B), pointer :: idxlastpak => null() !< budget-object index of last package-specific budget object real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration (or temperature) integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< map position in global rhs and x array of pack entry integer(I4B), dimension(:), pointer, contiguous :: idxpakdiag => null() !< map diag position of feature in global amat @@ -127,10 +129,10 @@ module TspAptModule procedure :: bnd_ad => apt_ad procedure :: bnd_cf => apt_cf procedure :: bnd_fc => apt_fc - procedure, public :: apt_fc_expanded ! kluge: Made public for uze on 3/3/2023 (reston) + procedure, public :: apt_fc_expanded ! kluge note: Made public for uze on 3/3/2023 (reston) procedure :: pak_fc_expanded procedure, private :: apt_fc_nonexpanded - procedure, private :: apt_cfupdate + procedure, public :: apt_cfupdate ! kluge note: made public for uze procedure :: apt_check_valid procedure :: apt_set_stressperiod procedure :: pak_set_stressperiod @@ -170,7 +172,8 @@ module TspAptModule procedure :: pak_fill_budobj procedure, public :: apt_stor_term procedure, public :: apt_tmvr_term - procedure, private :: apt_fjf_term + procedure, public :: apt_fmvr_term ! kluge note: new subroutine, public for uze + procedure, public :: apt_fjf_term ! kluge note: made public for uze procedure, private :: apt_copy2flowp procedure, private :: apt_setup_tableobj @@ -830,12 +833,10 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: cold real(DP) :: qbnd real(DP) :: omega - real(DP) :: unitadj real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval ! ------------------------------------------------------------------------------ - unitadj = DONE !TODO: Avoid checking whether solute or energy ! ! -- call the specific method for the advanced transport package, such as ! what would be overridden by @@ -889,14 +890,14 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to apt row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) + call matrix_sln%add_value_pos(iposd, omega * qbnd) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) ! ! -- add to gwf row for apt connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd * unitadj) - call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd * unitadj) + call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) + call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) end if end do ! @@ -906,10 +907,6 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(j) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudfjf)%flow(j) -!! ! TODO - Clean this out ! jiffylube: commented this out -!! if (associated(this%cpw).and.associated(this%rhow)) then -!! unitadj = this%bndtype%cpw(j) * this%bndtype%rhow(j) -!! end if if (qbnd <= DZERO) then omega = DONE else @@ -917,8 +914,8 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end if iposd = this%idxfjfdglo(j) iposoffd = this%idxfjfoffdglo(j) - call matrix_sln%add_value_pos(iposd, omega * qbnd * unitadj) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd * unitadj) + call matrix_sln%add_value_pos(iposd, omega * qbnd) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) end do end if ! @@ -966,7 +963,6 @@ subroutine apt_cfupdate(this) integer(I4B) :: j, n real(DP) :: qbnd real(DP) :: omega - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! ! -- Calculate hcof and rhs terms so GWF exchanges are calculated correctly @@ -979,13 +975,9 @@ subroutine apt_cfupdate(this) if (this%iboundpak(n) /= 0) then qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) omega = DZERO - unitadj = DONE !TODO: Avoid checking whether solute or energy if (qbnd < DZERO) omega = DONE -!! if (associated(this%cpw).and.associated(this%rhow)) then -!! unitadj = this%cpw(j) * this%rhow(j) ! jiffylube: kluge debug "!!" ? -!! end if - this%hcof(j) = -(DONE - omega) * unitadj * qbnd - this%rhs(j) = omega * unitadj * qbnd * this%xnewpak(n) + this%hcof(j) = -(DONE - omega) * qbnd + this%rhs(j) = omega * qbnd * this%xnewpak(n) end if end do ! @@ -1035,7 +1027,7 @@ subroutine apt_cq(this, x, flowja, iadv) call this%apt_copy2flowp() ! ! -- fill the budget object - call this%apt_fill_budobj(x) + call this%apt_fill_budobj(x, flowja) ! ! -- return return @@ -1168,6 +1160,8 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudfmvr, 'IDXBUDFMVR', this%memoryPath) call mem_allocate(this%idxbudaux, 'IDXBUDAUX', this%memoryPath) call mem_allocate(this%nconcbudssm, 'NCONCBUDSSM', this%memoryPath) + call mem_allocate(this%idxprepak, 'IDXPREPAK', this%memoryPath) + call mem_allocate(this%idxlastpak, 'IDXLASTPAK', this%memoryPath) ! ! -- Initialize this%iauxfpconc = 0 @@ -1185,6 +1179,8 @@ subroutine allocate_scalars(this) this%idxbudfmvr = 0 this%idxbudaux = 0 this%nconcbudssm = 0 + this%idxprepak = 0 + this%idxlastpak = 0 ! ! -- set this package as causing asymmetric matrix terms this%iasym = 1 @@ -1380,6 +1376,8 @@ subroutine apt_da(this) call mem_deallocate(this%idxbudaux) call mem_deallocate(this%idxbudssm) call mem_deallocate(this%nconcbudssm) + call mem_deallocate(this%idxprepak) + call mem_deallocate(this%idxlastpak) ! ! -- deallocate scalars in NumericalPackageType @@ -1861,7 +1859,6 @@ subroutine apt_solve(this) real(DP) :: ctmp real(DP) :: c1, qbnd real(DP) :: hcofval, rhsval - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! ! -- first initialize dbuff @@ -1895,20 +1892,16 @@ subroutine apt_solve(this) n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) this%hcof(j) = DZERO this%rhs(j) = DZERO - unitadj = DONE ! Avoid checking whether solute or energy igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) -!! if (associated(this%cpw).and.associated(this%rhow)) then -!! unitadj = this%cpw(j) * this%rhow(j) ! jiffylube: kluge debug "!!" ? -!! end if if (qbnd <= DZERO) then ctmp = this%xnewpak(n) - this%rhs(j) = unitadj * qbnd * ctmp + this%rhs(j) = qbnd * ctmp else ctmp = this%xnew(igwfnode) - this%hcof(j) = -qbnd * unitadj + this%hcof(j) = -qbnd end if - c1 = unitadj * qbnd * ctmp + c1 = qbnd * ctmp this%dbuff(n) = this%dbuff(n) + c1 end do ! @@ -2230,7 +2223,9 @@ subroutine apt_setup_budobj(this) end do ! ! -- Reserve space for the package specific terms + this%idxprepak = idx call this%pak_setup_budobj(idx) + this%idxlastpak = idx ! ! -- text = ' STORAGE' @@ -2341,7 +2336,7 @@ subroutine pak_setup_budobj(this, idx) return end subroutine pak_setup_budobj - subroutine apt_fill_budobj(this, x) + subroutine apt_fill_budobj(this, x, flowja) ! ****************************************************************************** ! apt_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -2353,6 +2348,7 @@ subroutine apt_fill_budobj(this, x) ! -- dummy class(TspAptType) :: this real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja ! -- local integer(I4B) :: naux real(DP), dimension(:), allocatable :: auxvartmp @@ -2410,8 +2406,11 @@ subroutine apt_fill_budobj(this, x) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! -- individual package terms - call this%pak_fill_budobj(idx, x, ccratin, ccratout) +!! ! -- individual package terms +!! call this%pak_fill_budobj(idx, x, ccratin, ccratout) + ! -- skip individual package terms for now and process them last + ! -- in case they depend on the other terms (as for uze) + idx = this%idxlastpak ! -- STORAGE idx = idx + 1 @@ -2443,8 +2442,10 @@ subroutine apt_fill_budobj(this, x) idx = idx + 1 nlist = this%ncv call this%budobj%budterm(idx)%reset(nlist) - do n1 = 1, nlist - q = this%qmfrommvr(n1) +!! do n1 = 1, nlist +!! q = this%qmfrommvr(n1) + do j = 1, nlist + call this%apt_fmvr_term(j, n1, n2, q) call this%budobj%budterm(idx)%update_term(n1, n1, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do @@ -2474,6 +2475,10 @@ subroutine apt_fill_budobj(this, x) deallocate (auxvartmp) end if ! + ! -- individual package terms processed last + idx = this%idxprepak + call this%pak_fill_budobj(idx, x, flowja, ccratin, ccratout) + ! ! --Terms are filled, now accumulate them for this time step call this%budobj%accumulate_terms() ! @@ -2481,7 +2486,7 @@ subroutine apt_fill_budobj(this, x) return end subroutine apt_fill_budobj - subroutine pak_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine pak_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! pak_fill_budobj -- copy flow terms into this%budobj, must be overridden ! ****************************************************************************** @@ -2493,6 +2498,7 @@ subroutine pak_fill_budobj(this, idx, x, ccratin, ccratout) class(TspAptType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local @@ -2519,21 +2525,16 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval real(DP) :: v0, v1 real(DP) :: c0, c1 - real(DP) :: unitadj ! ----------------------------------------------------------------- ! - ! -- TODO: these unitadj values should be cleaned-up as denoted in - ! uze_fc_expanded - unitadj = DONE ! jiffylube: kluge debug - ! n1 = ientry n2 = ientry call this%get_volumes(n1, v1, v0, delt) c0 = this%xoldpak(n1) c1 = this%xnewpak(n1) - if (present(rrate)) rrate = (-c1 * v1 / delt + c0 * v0 / delt) * unitadj - if (present(rhsval)) rhsval = -c0 * v0 / delt * unitadj - if (present(hcofval)) hcofval = -v1 / delt * unitadj + if (present(rrate)) rrate = -c1 * v1 / delt + c0 * v0 / delt + if (present(rhsval)) rhsval = -c0 * v0 / delt + if (present(hcofval)) hcofval = -v1 / delt ! ! -- return return @@ -2553,25 +2554,45 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: unitadj ! ------------------------------------------------------------------------------ - ! - ! -- If GWE package, adjust for thermal units - unitadj = DONE ! jiffylube: kluge debug ! ! -- Calculate MVR-related terms n1 = this%flowbudptr%budterm(this%idxbudtmvr)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudtmvr)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudtmvr)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = unitadj * ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd * unitadj + if (present(hcofval)) hcofval = qbnd ! ! -- return return end subroutine apt_tmvr_term + subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) + ! -- modules + ! -- dummy + class(TspAptType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval +! ------------------------------------------------------------------------------ + ! + ! -- Calculate MVR-related terms + n1 = ientry + n2 = n1 + if (present(rrate)) rrate = this%qmfrommvr(n1) + if (present(rhsval)) rhsval = this%qmfrommvr(n1) + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine apt_fmvr_term + subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- modules @@ -2586,11 +2607,7 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: unitadj ! ------------------------------------------------------------------------------ - ! - ! -- If GWE package, adjust for thermal units - unitadj = DONE ! jiffylube: kluge debug ! n1 = this%flowbudptr%budterm(this%idxbudfjf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudfjf)%id2(ientry) @@ -2600,7 +2617,7 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & else ctmp = this%xnewpak(n2) end if - if (present(rrate)) rrate = unitadj * ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -3059,7 +3076,8 @@ subroutine apt_bd_obs(this) end if case ('FROM-MVR') if (this%iboundpak(jj) /= 0 .and. this%idxbudfmvr > 0) then - v = this%qmfrommvr(jj) +!! v = this%qmfrommvr(jj) + call this%apt_fmvr_term(jj, n1, n2, v) end if case ('TO-MVR') if (this%idxbudtmvr > 0) then diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 60a1081c88d..cf83c16495b 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -378,7 +378,7 @@ subroutine cnc_bd(this, model_budget) isuppress_output = 0 ! ! -- for GWE model types, storage rate needs to have units adjusted - if (this%tsplab%tsptype /= 'GWE') then + if (this%tsplab%tsptype /= 'GWE') then ! kluge note: best to avoid checks like this if possible unitadj = DONE else unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 089026ce674..13af5db1197 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -312,7 +312,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & rhstmp = DZERO ctmp = DZERO qbnd = DZERO - unitadj = DONE +!! unitadj = DONE ! ! -- retrieve node number, qbnd and iauxpos n = this%fmi%gwfpackages(ipackage)%nodelist(ientry) @@ -359,11 +359,11 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & end if end if ! - ! -- If GWE transport model type, adjust units to energy - if (this%tsplab%tsptype == "GWE") then - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - end if - ! +!! ! -- If GWE transport model type, adjust units to energy +!! if (this%tsplab%tsptype == "GWE") then +!! unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow +!! end if +!! ! ! -- Add terms based on qbnd sign if (qbnd <= DZERO) then hcoftmp = qbnd * omega @@ -378,10 +378,11 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & if (present(hcofval)) hcofval = hcoftmp if (present(rhsval)) rhsval = rhstmp if (present(rrate)) then - if (this%tsplab%tsptype /= 'GWE') then + if (this%tsplab%tsptype /= 'GWE') then ! kluge note: best to avoid checks like this if possible rrate = hcoftmp * ctmp - rhstmp else - rrate = hcoftmp * ctmp * unitadj - rhstmp * unitadj + unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow + rrate = (hcoftmp * ctmp - rhstmp) * unitadj endif end if if (present(cssm)) cssm = ctmp From 277fe6f7a7640eed84f1a21c6747079418b36272 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Wed, 5 Apr 2023 15:07:49 -0400 Subject: [PATCH 099/212] * Replaced unitadj with eqnsclfac (governing equaiton scale factor), which now originates in TransportModel, is given the appropriate value by gwt and gwe, and is passed (via pointers) to the packages that use it * Some minor eqnsclfac issue remain (marked with kluge notes), and not certain all packages that need eqnsclfac have it yet - need to check * Refactored thermal-equilibration term calculations in terms of an updated/fixed subroutine uze_theq_term --- src/Model/GroundWaterEnergy/gwe1.f90 | 15 +- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 12 +- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 12 +- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 159 ++++++-------------- src/Model/GroundWaterTransport/gwt1.f90 | 9 +- src/Model/GroundWaterTransport/tsp1apt1.f90 | 2 +- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 19 +-- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 22 +-- src/Model/ModelUtilities/GweInputData.f90 | 2 +- src/Model/TransportModel.f90 | 7 +- 10 files changed, 99 insertions(+), 160 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index d421fbaae34..225b4ac1734 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -242,12 +242,12 @@ subroutine gwe_cr(filename, id, modelname) call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & - this%gwecommon) + this%eqnsclfac, this%gwecommon) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi, & this%gwecommon) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & - this%tsplab, this%gwecommon) + this%tsplab, this%eqnsclfac, this%gwecommon) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) @@ -422,6 +422,9 @@ subroutine gwe_ar(this) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! + ! -- Set governing equation scale factor + this%eqnsclfac = this%gwecommon%gwerhow * this%gwecommon%gwecpw + ! ! -- Call dis_ar to write binary grid file !call this%dis%dis_ar(this%npf%icelltype) ! @@ -1167,7 +1170,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & select case (filtyp) case ('TMP6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%tsplab, this%gwecommon) + pakname, this%tsplab, this%eqnsclfac, this%gwecommon) case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab, this%gwecommon) @@ -1176,13 +1179,15 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! pakname, this%fmi) case ('SFE6') call sfe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab, this%gwecommon) + pakname, this%fmi, this%tsplab, this%eqnsclfac, & + this%gwecommon) !case('MWT6') ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) case ('UZE6') call uze_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab, this%gwecommon) + pakname, this%fmi, this%tsplab, this%eqnsclfac, & + this%gwecommon) !case('IST6') ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi, this%mst) diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 3dde422ad9f..dff9c25f669 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -57,6 +57,7 @@ module GweMstModule type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst real(DP), pointer :: latheatvap => null() !< latent heat of vaporization + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =rhow*cpw for energy contains @@ -85,13 +86,14 @@ module GweMstModule !! Create a new MST object !! !< - subroutine mst_cr(mstobj, name_model, inunit, iout, fmi, gwecommon) + subroutine mst_cr(mstobj, name_model, inunit, iout, fmi, eqnsclfac, gwecommon) ! -- dummy type(GweMstType), pointer :: mstobj !< unallocated new mst object to create character(len=*), intent(in) :: name_model !< name of the model integer(I4B), intent(in) :: inunit !< unit number of WEL package input file integer(I4B), intent(in) :: iout !< unit number of model listing file type(TspFmiType), intent(in), target :: fmi !< fmi package for this GWE model + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! ! -- Create the object @@ -107,6 +109,7 @@ subroutine mst_cr(mstobj, name_model, inunit, iout, fmi, gwecommon) mstobj%inunit = inunit mstobj%iout = iout mstobj%fmi => fmi + mstobj%eqnsclfac => eqnsclfac mstobj%gwecommon => gwecommon ! ! -- Initialize block parser @@ -360,13 +363,10 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) real(DP) :: tled real(DP) :: vwatnew, vwatold, vcell, vsolid, term real(DP) :: hhcof, rrhs - real(DP) :: unitadj ! ! -- initialize tled = DONE / delt ! - unitadj = this%cpw * this%rhow - ! ! -- Calculate storage change do n = 1, nodes this%ratesto(n) = DZERO @@ -383,10 +383,10 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate - term = vsolid * (this%rhos(n) * this%cps(n)) / unitadj + term = vsolid * (this%rhos(n) * this%cps(n)) / this%eqnsclfac hhcof = -(vwatnew + term) * tled rrhs = -(vwatold + term) * tled * cold(n) - rate = (hhcof * cnew(n) - rrhs) * unitadj + rate = (hhcof * cnew(n) - rrhs) * this%eqnsclfac this%ratesto(n) = rate idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index f8a62e84496..f9c62a01a26 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -95,7 +95,7 @@ module GweSfeModule contains subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab, gwecommon) + fmi, tsplab, eqnsclfac, gwecommon) ! ****************************************************************************** ! sfe_create -- Create a New SFE Package ! ****************************************************************************** @@ -112,6 +112,7 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweSfeType), pointer :: sfeobj @@ -147,6 +148,9 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature sfeobj%tsplab => tsplab ! + ! -- Store pointer to governing equation scale factor + sfeobj%eqnsclfac => eqnsclfac + ! ! -- Store pointer to shared data module for accessing cpw, rhow ! for the budget calculations, and for accessing the latent heat of ! vaporization for evaporative cooling. @@ -734,7 +738,6 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: heatlat - real(DP) :: unitadj ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) @@ -742,7 +745,7 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day - if (present(rhsval)) rhsval = -rrate ! kluge note: shouldn't this be divided by unitadj?? + if (present(rhsval)) rhsval = -rrate ! kluge note: shouldn't this be divided by this%eqnsclfac?? if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -763,13 +766,12 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: unitadj ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudroff)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) ! kluge note: yes, multiply by unitadj + if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) ! kluge note: yes, multiply by this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 1f9911ad29f..30795521b15 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -92,7 +92,7 @@ module GweUzeModule contains subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab, gwecommon) + fmi, tsplab, eqnsclfac, gwecommon) ! ****************************************************************************** ! uze_create -- Create a New UZE Package ! ****************************************************************************** @@ -109,6 +109,7 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweUzeType), pointer :: uzeobj @@ -144,6 +145,9 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature uzeobj%tsplab => tsplab ! + ! -- Store pointer to governing equation scale factor + uzeobj%eqnsclfac => eqnsclfac + ! ! -- Store pointer to shared data module for accessing cpw, rhow ! for the budget calculations, and for accessing the latent heat of ! vaporization @@ -488,19 +492,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: cold real(DP) :: qbnd real(DP) :: omega - real(DP) :: unitadj real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval real(DP) :: dummy ! ------------------------------------------------------------------------------ - ! - ! -- TODO: This needs to be cleaned up, unitadj should be based on - ! scalars that are spatially constant. ! kluge note: done - ! At some point, unitadj's name should be adapted to represent the - ! physics it captures. For example, could be something like - ! cpw_vol which denotes volume-based heat capacity. Its stored - ! value would represent cpw * rhow ! kluge note: unitadj no longer appears in this subroutine; this comment pertains to unitadj in general ! ! -- add infiltration contribution ! uze does not put feature balance coefficients in the row @@ -666,7 +662,6 @@ subroutine uze_cfupdate(this) integer(I4B) :: j, n real(DP) :: qbnd real(DP) :: omega - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! ! -- Calculate hcof and rhs terms so GWF exchanges are calculated correctly @@ -675,10 +670,9 @@ subroutine uze_cfupdate(this) call this%TspAptType%apt_cfupdate() ! ! -- Apply scaling to units of energy per time - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - this%hcof(j) = this%hcof(j) * unitadj - this%rhs(j) = this%rhs(j) * unitadj + this%hcof(j) = this%hcof(j) * this%eqnsclfac + this%rhs(j) = this%rhs(j) * this%eqnsclfac end do ! ! -- Return @@ -873,7 +867,6 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use BudgetTermModule, only : LENBUDTXT ! kluge?? ! -- dummy class(GweUzeType) :: this integer(I4B), intent(inout) :: idx @@ -887,13 +880,9 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) integer(I4B) :: igwfnode integer(I4B) :: idiag real(DP) :: q - real(DP) :: unitadj - character(len=LENBUDTXT) :: flowtype ! kluge?? ! -- formats ! ----------------------------------------------------------------------------- - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - ! -- INFILTRATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist @@ -944,31 +933,13 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- processed last because it is calculated from the residual idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudgwf)%nlist - nbudterm = this%budobj%nbudterm call this%budobj%budterm(idx)%reset(nlist) - do j = 1, nlist - q = DZERO - n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) - if (this%iboundpak(n1) /= 0) then - igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) - do i = 1, nbudterm - flowtype = this%budobj%budterm(i)%flowtype - select case (trim(adjustl(flowtype))) - case ('THERMAL-EQUIL') - ! skip - continue - case ('FLOW-JA-FACE') - ! skip - continue - case default - q = q - this%budobj%budterm(i)%flow(j) -!! write(6,*) flowtype, this%budobj%budterm(i)%flow(j) -!! flush(6) - end select - end do - call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) - call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) - ! -- for gwe cell budget + do j = 1, nlist + call this%uze_theq_term(j, n1, igwfnode, q) + call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + if (this%iboundpak(n1) /= 0) then + ! -- contribution to gwe cell budget this%simvals(n1) = this%simvals(n1) - q idiag = this%dis%con%ia(igwfnode) flowja(idiag) = flowja(idiag) - q @@ -1100,13 +1071,8 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & real(DP) :: qbnd real(DP) :: ctmp real(DP) :: h, r - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! - ! -- TODO: these unitadj values should be cleaned-up as denoted in - ! uze_fc_expanded - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - ! n1 = this%flowbudptr%budterm(this%idxbudinfl)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudinfl)%id2(ientry) ! -- note that qbnd is negative for negative infiltration @@ -1120,9 +1086,7 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & h = DZERO r = -qbnd * ctmp end if - if (present(rrate)) rrate = qbnd * ctmp * unitadj -!! if (present(rhsval)) rhsval = r * unitadj -!! if (present(hcofval)) hcofval = h * unitadj + if (present(rrate)) rrate = qbnd * ctmp * this%eqnsclfac if (present(rhsval)) rhsval = r if (present(hcofval)) hcofval = h ! @@ -1149,20 +1113,13 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! - ! -- TODO: these unitadj values should be cleaned-up as denoted in - ! uze_fc_expanded - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - ! n1 = this%flowbudptr%budterm(this%idxbudrinf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudrinf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrinf)%flow(ientry) ctmp = this%tempinfl(n1) - if (present(rrate)) rrate = ctmp * qbnd * unitadj -!! if (present(rhsval)) rhsval = DZERO * unitadj -!! if (present(hcofval)) hcofval = qbnd * unitadj + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! @@ -1190,14 +1147,8 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & real(DP) :: qbnd real(DP) :: ctmp real(DP) :: omega - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! - ! -- TODO: these unitadj values should be cleaned-up as denoted in - ! uze_fc_expanded - ! -- TODO: Latent heat will likely need to play a role here at some point - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - ! n1 = this%flowbudptr%budterm(this%idxbuduzet)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbuduzet)%id2(ientry) ! -- note that qbnd is negative for uzet @@ -1210,9 +1161,7 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & end if if (present(rrate)) & rrate = (omega * qbnd * this%xnewpak(n1) + & - (DONE - omega) * qbnd * ctmp) * unitadj ! jiffylube: added parens so unitadj multiplies the whole expression -!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * unitadj -!! if (present(hcofval)) hcofval = omega * qbnd * unitadj + (DONE - omega) * qbnd * ctmp) * this%eqnsclfac if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! @@ -1239,20 +1188,13 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! - ! -- TODO: these unitadj values should be cleaned-up as denoted in - ! uze_fc_expanded - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - ! n1 = this%flowbudptr%budterm(this%idxbudritm)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudritm)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudritm)%flow(ientry) ctmp = this%tempinfl(n1) - if (present(rrate)) rrate = ctmp * qbnd * unitadj -!! if (present(rhsval)) rhsval = DZERO * unitadj -!! if (present(hcofval)) hcofval = qbnd * unitadj + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! @@ -1260,45 +1202,48 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & return end subroutine uze_ritm_term - subroutine uze_theq_term(this, ientry, n1, n2, rrate, & ! kluge note: not used??? - rhsval, hcofval) + subroutine uze_theq_term(this, ientry, n1, n2, rrate) ! ****************************************************************************** ! uze_theq_term ! ****************************************************************************** ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT ! -- dummy class(GweUzeType) :: this integer(I4B), intent(in) :: ientry integer(I4B), intent(inout) :: n1 integer(I4B), intent(inout) :: n2 - real(DP), intent(inout), optional :: rrate - real(DP), intent(inout), optional :: rhsval - real(DP), intent(inout), optional :: hcofval + real(DP), intent(inout) :: rrate ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: h, r - real(DP) :: unitadj - integer(I4B) :: idiag + real(DP) :: r + integer(I4B) :: i + character(len=LENBUDTXT) :: flowtype ! ------------------------------------------------------------------------------ - ! - ! -- TODO: these unitadj values should be cleaned-up as denoted in - ! uze_fc_expanded - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - ! -!! n1 = this%flowbudptr%budterm(this%idxbudtheq)%id1(ientry) -!! n2 = this%flowbudptr%budterm(this%idxbudtheq)%id2(ientry) - n1 = ientry ! kluge note: is this right in general??? - h = DZERO - idiag = this%dis%con%ia(n1) - r = this%flowja(idiag) - if (present(rrate)) rrate = r * unitadj -!! if (present(rhsval)) rhsval = r * unitadj -!! if (present(hcofval)) hcofval = h * unitadj - if (present(rhsval)) rhsval = r - if (present(hcofval)) hcofval = h + ! + r = DZERO + n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudgwf)%id2(ientry) + if (this%iboundpak(n1) /= 0) then + do i = 1, this%budobj%nbudterm + flowtype = this%budobj%budterm(i)%flowtype + select case (trim(adjustl(flowtype))) + case ('THERMAL-EQUIL') + ! skip + continue + case ('FLOW-JA-FACE') + ! skip + continue + case default + r = r - this%budobj%budterm(i)%flow(ientry) + end select + end do + end if + rrate = r ! ! -- return return @@ -1316,15 +1261,13 @@ subroutine uze_stor_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: rhsval real(DP), intent(inout), optional :: hcofval ! -- local - real(DP) :: unitadj ! ----------------------------------------------------------------- ! call this%TspAptType%apt_stor_term(ientry, n1, n2, rrate, & rhsval, hcofval) ! ! -- Apply scaling to units of energy per time - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - if (present(rrate)) rrate = rrate * unitadj + if (present(rrate)) rrate = rrate * this%eqnsclfac ! ! -- return return @@ -1342,15 +1285,13 @@ subroutine uze_tmvr_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: rhsval real(DP), intent(inout), optional :: hcofval ! -- local - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! call this%TspAptType%apt_tmvr_term(ientry, n1, n2, rrate, & rhsval, hcofval) ! ! -- Apply scaling to units of energy per time - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - if (present(rrate)) rrate = rrate * unitadj + if (present(rrate)) rrate = rrate * this%eqnsclfac ! ! -- return return @@ -1368,15 +1309,13 @@ subroutine uze_fmvr_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: rhsval real(DP), intent(inout), optional :: hcofval ! -- local - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! call this%TspAptType%apt_fmvr_term(ientry, n1, n2, rrate, & rhsval, hcofval) ! ! -- Apply scaling to units of energy per time - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - if (present(rrate)) rrate = rrate * unitadj + if (present(rrate)) rrate = rrate * this%eqnsclfac ! ! -- return return @@ -1394,15 +1333,13 @@ subroutine uze_fjf_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: rhsval real(DP), intent(inout), optional :: hcofval ! -- local - real(DP) :: unitadj ! ------------------------------------------------------------------------------ ! call this%TspAptType%apt_fjf_term(ientry, n1, n2, rrate, & rhsval, hcofval) ! ! -- Apply scaling to units of energy per time - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - if (present(rrate)) rrate = rrate * unitadj + if (present(rrate)) rrate = rrate * this%eqnsclfac ! ! -- return return diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index e65be8bf5cc..b004919ce52 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -9,7 +9,7 @@ module GwtModule use KindModule, only: DP, I4B use InputOutputModule, only: ParseLine, upcase - use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC + use ConstantsModule, only: LENFTYPE, DZERO, DONE, LENPAKLOC use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType use BaseModelModule, only: BaseModelType @@ -242,7 +242,7 @@ subroutine gwt_cr(filename, id, modelname) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) @@ -413,6 +413,9 @@ subroutine gwt_ar(this) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! + ! -- Set governing equation scale factor + this%eqnsclfac = DONE + ! ! -- Call dis_ar to write binary grid file !call this%dis%dis_ar(this%npf%icelltype) ! @@ -1165,7 +1168,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & select case (filtyp) case ('CNC6') call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%tsplab) + pakname, this%tsplab, this%eqnsclfac) case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 32ebc050043..47107fcb6d4 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -108,6 +108,7 @@ module TspAptModule integer(I4B), pointer :: nconcbudssm => null() !< number of concbudssm terms (columns) real(DP), dimension(:, :), pointer, contiguous :: concbudssm => null() !< user specified concentrations (or temperatures) for flow terms real(DP), dimension(:), pointer, contiguous :: qmfrommvr => null() !< a mass or energy flow coming from the mover that needs to be added + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy ! ! -- pointer to flow package boundary type(BndType), pointer :: flowpackagebnd => null() @@ -1378,7 +1379,6 @@ subroutine apt_da(this) call mem_deallocate(this%nconcbudssm) call mem_deallocate(this%idxprepak) call mem_deallocate(this%idxlastpak) - ! ! -- deallocate scalars in NumericalPackageType call this%BndType%bnd_da() diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index cf83c16495b..671aa53a6a7 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -26,6 +26,7 @@ module TspCncModule real(DP), dimension(:), pointer, contiguous :: ratecncin => null() !simulated flows into constant conc (excluding other concs) real(DP), dimension(:), pointer, contiguous :: ratecncout => null() !simulated flows out of constant conc (excluding to other concs) + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy contains @@ -48,7 +49,7 @@ module TspCncModule contains subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - tsplab, gwecommon) + tsplab, eqnsclfac, gwecommon) ! ****************************************************************************** ! cnc_create -- Create a New Constant Concentration/Temperature Package ! Subroutine: (1) create new-style package @@ -66,6 +67,7 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target, optional :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(TspCncType), pointer :: cncobj @@ -96,6 +98,9 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Give package access to the assigned labels based on dependent variable packobj%tsplab => tsplab ! + ! -- Give access to governing equation scale factor + cncobj%eqnsclfac => eqnsclfac + ! ! -- Give package access to the shared heat transport variables assigned in MST if (present(gwecommon)) then cncobj%gwecommon => gwecommon @@ -373,22 +378,14 @@ subroutine cnc_bd(this, model_budget) real(DP) :: ratout real(DP) :: dum integer(I4B) :: isuppress_output - real(DP) :: unitadj ! ------------------------------------------------------------------------------ isuppress_output = 0 ! - ! -- for GWE model types, storage rate needs to have units adjusted - if (this%tsplab%tsptype /= 'GWE') then ! kluge note: best to avoid checks like this if possible - unitadj = DONE - else - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - end if - ! do n = 1, size(this%ratecncin) - this%ratecncin(n) = this%ratecncin(n) * unitadj + this%ratecncin(n) = this%ratecncin(n) * this%eqnsclfac end do do n = 1, size(this%ratecncout) - this%ratecncout(n) = this%ratecncout(n) * unitadj + this%ratecncout(n) = this%ratecncout(n) * this%eqnsclfac end do ! call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index 13af5db1197..f5612ef521f 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -50,6 +50,7 @@ module TspSsmModule type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object type(TableType), pointer :: outputtab => null() !< output table object type(GwtSpcType), dimension(:), pointer :: ssmivec => null() !< array of stress package concentration objects + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy contains @@ -84,7 +85,8 @@ module TspSsmModule !! and initializing the parser. !! !< - subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, gwecommon) + subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, eqnsclfac, & + gwecommon) ! -- dummy type(TspSsmType), pointer :: ssmobj !< TspSsmType object character(len=*), intent(in) :: name_model !< name of the model @@ -92,6 +94,7 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, gwecommon) integer(I4B), intent(in) :: iout !< fortran unit for output type(TspFmiType), intent(in), target :: fmi !< Transport FMI package type(TspLabelsType), intent(in), pointer :: tsplab !< TspLabelsType object + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target, optional :: gwecommon !< shared data container for use by multiple GWE packages ! ! -- Create the object @@ -107,6 +110,7 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, gwecommon) ssmobj%inunit = inunit ssmobj%iout = iout ssmobj%fmi => fmi + ssmobj%eqnsclfac => eqnsclfac ! ! -- Initialize block parser call ssmobj%parser%Initialize(ssmobj%inunit, ssmobj%iout) @@ -305,14 +309,12 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & real(DP) :: omega real(DP) :: hcoftmp real(DP) :: rhstmp - real(DP) :: unitadj ! ! -- initialize hcoftmp = DZERO rhstmp = DZERO ctmp = DZERO qbnd = DZERO -!! unitadj = DONE ! ! -- retrieve node number, qbnd and iauxpos n = this%fmi%gwfpackages(ipackage)%nodelist(ientry) @@ -359,11 +361,6 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & end if end if ! -!! ! -- If GWE transport model type, adjust units to energy -!! if (this%tsplab%tsptype == "GWE") then -!! unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow -!! end if -!! ! ! -- Add terms based on qbnd sign if (qbnd <= DZERO) then hcoftmp = qbnd * omega @@ -377,14 +374,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! -- set requested values if (present(hcofval)) hcofval = hcoftmp if (present(rhsval)) rhsval = rhstmp - if (present(rrate)) then - if (this%tsplab%tsptype /= 'GWE') then ! kluge note: best to avoid checks like this if possible - rrate = hcoftmp * ctmp - rhstmp - else - unitadj = this%gwecommon%gwecpw * this%gwecommon%gwerhow - rrate = (hcoftmp * ctmp - rhstmp) * unitadj - endif - end if + if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) * this%eqnsclfac if (present(cssm)) cssm = ctmp if (present(qssm)) qssm = qbnd ! diff --git a/src/Model/ModelUtilities/GweInputData.f90 b/src/Model/ModelUtilities/GweInputData.f90 index 1b6d7222177..f4ccdf288fa 100644 --- a/src/Model/ModelUtilities/GweInputData.f90 +++ b/src/Model/ModelUtilities/GweInputData.f90 @@ -166,7 +166,7 @@ subroutine set_gwe_shared_scalars(this, gwerhow, gwecpw, gwelatheatvap) ! -- Set the pointers ! -- Fixed density of water to be used by GWE this%gwerhow = gwerhow - ! -- Spatially constant heat capacity of water + ! -- Spatially constant heat capacity of water ! kluge note: "specific heat" (which is heat capacity per unit mass) is probably the more correct term this%gwecpw = gwecpw ! -- Latent heat of vaporization if (present(gwelatheatvap)) then diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index ed49c708108..e7bc8bd5d69 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -57,6 +57,7 @@ module TransportModelModule integer(I4B), pointer :: inobs => null() ! unit number OBS integer(I4B), pointer :: inmst => null() ! unit number MST integer(I4B), pointer :: indsp => null() ! unit number DSP + real(DP), pointer :: eqnsclfac => null() !< constant factor by which all terms in the model's governing equation are scaled (divided) for formulation and solution contains @@ -220,7 +221,8 @@ subroutine tsp_cr(this, filename, id, modelname) call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + this%tsplab, this%eqnsclfac) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) @@ -680,6 +682,7 @@ subroutine allocate_scalars(this, modelname) call mem_allocate(this%inssm, 'INSSM', this%memoryPath) call mem_allocate(this%inoc, 'INOC ', this%memoryPath) call mem_allocate(this%inobs, 'INOBS', this%memoryPath) + call mem_allocate(this%eqnsclfac, 'EQNSCLFAC', this%memoryPath) ! this%inic = 0 this%infmi = 0 @@ -688,6 +691,7 @@ subroutine allocate_scalars(this, modelname) this%inssm = 0 this%inoc = 0 this%inobs = 0 + this%eqnsclfac = DZERO ! ! -- return return @@ -717,6 +721,7 @@ subroutine tsp_da(this) call mem_deallocate(this%inmvt) call mem_deallocate(this%inoc) call mem_deallocate(this%inobs) + call mem_deallocate(this%eqnsclfac) ! ! -- return return From f8ed4f99d516dfca2cd39f9ba0e53b8aba3c37cd Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Wed, 5 Apr 2023 15:25:47 -0400 Subject: [PATCH 100/212] * Got rid of the overriding subroutines in uze that existed solely to apply the scale factor and now have apt apply the scale factor directly --- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 132 -------------------- src/Model/GroundWaterTransport/tsp1apt1.f90 | 14 ++- 2 files changed, 8 insertions(+), 138 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 30795521b15..9fac47b84e0 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -66,7 +66,6 @@ module GweUzeModule procedure :: apt_allocate_arrays => uze_allocate_arrays procedure :: find_apt_package => find_uze_package procedure :: apt_fc_expanded => uze_fc_expanded - procedure :: apt_cfupdate => uze_cfupdate procedure :: pak_solve => uze_solve procedure :: pak_get_nbudterms => uze_get_nbudterms procedure :: pak_setup_budobj => uze_setup_budobj @@ -76,10 +75,6 @@ module GweUzeModule procedure :: uze_uzet_term procedure :: uze_ritm_term procedure :: uze_theq_term - procedure :: apt_stor_term => uze_stor_term - procedure :: apt_tmvr_term => uze_tmvr_term - procedure :: apt_fmvr_term => uze_fmvr_term - procedure :: apt_fjf_term => uze_fjf_term procedure :: pak_df_obs => uze_df_obs procedure :: pak_rp_obs => uze_rp_obs procedure :: pak_bd_obs => uze_bd_obs @@ -648,37 +643,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine uze_fc_expanded - subroutine uze_cfupdate(this) -! ****************************************************************************** -! uze_cfupdate -- calculate package hcof and rhs so gwt budget is calculated -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - ! -- dummy - class(GweUzeType) :: this - ! -- local - integer(I4B) :: j, n - real(DP) :: qbnd - real(DP) :: omega -! ------------------------------------------------------------------------------ - ! - ! -- Calculate hcof and rhs terms so GWF exchanges are calculated correctly - ! -- go through each apt-gwf connection and calculate - ! rhs and hcof terms for gwt/gwe matrix rows - call this%TspAptType%apt_cfupdate() - ! - ! -- Apply scaling to units of energy per time - do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - this%hcof(j) = this%hcof(j) * this%eqnsclfac - this%rhs(j) = this%rhs(j) * this%eqnsclfac - end do - ! - ! -- Return - return - end subroutine uze_cfupdate - subroutine uze_solve(this) ! kluge note: no explicit solve for uze ! ****************************************************************************** ! uze_solve -- add terms specific to the unsaturated zone to the explicit @@ -1249,102 +1213,6 @@ subroutine uze_theq_term(this, ientry, n1, n2, rrate) return end subroutine uze_theq_term - subroutine uze_stor_term(this, ientry, n1, n2, rrate, & - rhsval, hcofval) - ! -- modules - ! -- dummy - class(GweUzeType) :: this - integer(I4B), intent(in) :: ientry - integer(I4B), intent(inout) :: n1 - integer(I4B), intent(inout) :: n2 - real(DP), intent(inout), optional :: rrate - real(DP), intent(inout), optional :: rhsval - real(DP), intent(inout), optional :: hcofval - ! -- local -! ----------------------------------------------------------------- - ! - call this%TspAptType%apt_stor_term(ientry, n1, n2, rrate, & - rhsval, hcofval) - ! - ! -- Apply scaling to units of energy per time - if (present(rrate)) rrate = rrate * this%eqnsclfac - ! - ! -- return - return - end subroutine uze_stor_term - - subroutine uze_tmvr_term(this, ientry, n1, n2, rrate, & - rhsval, hcofval) - ! -- modules - ! -- dummy - class(GweUzeType) :: this - integer(I4B), intent(in) :: ientry - integer(I4B), intent(inout) :: n1 - integer(I4B), intent(inout) :: n2 - real(DP), intent(inout), optional :: rrate - real(DP), intent(inout), optional :: rhsval - real(DP), intent(inout), optional :: hcofval - ! -- local -! ------------------------------------------------------------------------------ - ! - call this%TspAptType%apt_tmvr_term(ientry, n1, n2, rrate, & - rhsval, hcofval) - ! - ! -- Apply scaling to units of energy per time - if (present(rrate)) rrate = rrate * this%eqnsclfac - ! - ! -- return - return - end subroutine uze_tmvr_term - - subroutine uze_fmvr_term(this, ientry, n1, n2, rrate, & - rhsval, hcofval) - ! -- modules - ! -- dummy - class(GweUzeType) :: this - integer(I4B), intent(in) :: ientry - integer(I4B), intent(inout) :: n1 - integer(I4B), intent(inout) :: n2 - real(DP), intent(inout), optional :: rrate - real(DP), intent(inout), optional :: rhsval - real(DP), intent(inout), optional :: hcofval - ! -- local -! ------------------------------------------------------------------------------ - ! - call this%TspAptType%apt_fmvr_term(ientry, n1, n2, rrate, & - rhsval, hcofval) - ! - ! -- Apply scaling to units of energy per time - if (present(rrate)) rrate = rrate * this%eqnsclfac - ! - ! -- return - return - end subroutine uze_fmvr_term - - subroutine uze_fjf_term(this, ientry, n1, n2, rrate, & - rhsval, hcofval) - ! -- modules - ! -- dummy - class(GweUzeType) :: this - integer(I4B), intent(in) :: ientry - integer(I4B), intent(inout) :: n1 - integer(I4B), intent(inout) :: n2 - real(DP), intent(inout), optional :: rrate - real(DP), intent(inout), optional :: rhsval - real(DP), intent(inout), optional :: hcofval - ! -- local -! ------------------------------------------------------------------------------ - ! - call this%TspAptType%apt_fjf_term(ientry, n1, n2, rrate, & - rhsval, hcofval) - ! - ! -- Apply scaling to units of energy per time - if (present(rrate)) rrate = rrate * this%eqnsclfac - ! - ! -- return - return - end subroutine uze_fjf_term - subroutine uze_df_obs(this) ! ****************************************************************************** ! uze_df_obs -- obs are supported? diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 47107fcb6d4..d30bf429231 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -977,8 +977,8 @@ subroutine apt_cfupdate(this) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) omega = DZERO if (qbnd < DZERO) omega = DONE - this%hcof(j) = -(DONE - omega) * qbnd - this%rhs(j) = omega * qbnd * this%xnewpak(n) + this%hcof(j) = -(DONE - omega) * qbnd * this%eqnsclfac + this%rhs(j) = omega * qbnd * this%xnewpak(n) * this%eqnsclfac end if end do ! @@ -2532,7 +2532,9 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & call this%get_volumes(n1, v1, v0, delt) c0 = this%xoldpak(n1) c1 = this%xnewpak(n1) - if (present(rrate)) rrate = -c1 * v1 / delt + c0 * v0 / delt + if (present(rrate)) then + rrate = (-c1 * v1 / delt + c0 * v0 / delt) * this%eqnsclfac + end if if (present(rhsval)) rhsval = -c0 * v0 / delt if (present(hcofval)) hcofval = -v1 / delt ! @@ -2561,7 +2563,7 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudtmvr)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudtmvr)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! @@ -2585,7 +2587,7 @@ subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & ! -- Calculate MVR-related terms n1 = ientry n2 = n1 - if (present(rrate)) rrate = this%qmfrommvr(n1) + if (present(rrate)) rrate = this%qmfrommvr(n1) * this%eqnsclfac if (present(rhsval)) rhsval = this%qmfrommvr(n1) if (present(hcofval)) hcofval = DZERO ! @@ -2617,7 +2619,7 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & else ctmp = this%xnewpak(n2) end if - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! From 1de53f33732f3e21673315f79b82a7676f9b82bc Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 6 Apr 2023 14:20:19 -0700 Subject: [PATCH 101/212] Some preliminary work on LKE --- doc/mf6io/mf6ivar/dfn/gwe-lke.dfn | 459 ++++++++ doc/mf6io/mf6ivar/dfn/gwt-lkt.dfn | 4 +- msvs/mf6core.vfproj | 1 + src/Model/GroundWaterEnergy/gwe1.f90 | 2 +- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 1221 ++++++++++++++++++++++ 5 files changed, 1684 insertions(+), 3 deletions(-) create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-lke.dfn create mode 100644 src/Model/GroundWaterEnergy/gwe1lke1.f90 diff --git a/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn b/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn new file mode 100644 index 00000000000..df2a049f7d0 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn @@ -0,0 +1,459 @@ +# --------------------- gwe lke options --------------------- +# flopy multi-package + +block options +name flow_package_name +type string +shape +reader urword +optional true +longname keyword to specify name of corresponding flow package +description keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +block options +name auxiliary +type string +shape (naux) +reader urword +optional true +longname keyword to specify aux variables +description REPLACE auxnames {'{#1}': 'Groundwater Energy Transport'} + +block options +name flow_package_auxiliary_name +type string +shape +reader urword +optional true +longname keyword to specify name of temperature auxiliary variable in flow package +description keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated temperatures from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'lake'} + +block options +name latentheatvapor +type double precision +reader urword +optional true +longname latent heat of vaporation of water +description latent heat of vaporization of water. For freshwater at 25$^{\circ}C$, the latent heat of vaporization is approximately 2,450.0 kJ/kg in SI units. Between 0 and 100$^{\circ}C$, latent heat of vaporization may vary by as much as 10 percent, but is held constant in the initial release of the GWE model. By default, the latent heat of vaporization is 2,450.0 kJ/kg. +default_value 2545 + + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'lake'} + +block options +name print_temperature +type keyword +reader urword +optional true +longname print calculated temperatures to listing file +description REPLACE print_temperature {'{#1}': 'lake', '{#2}': 'temperature', '{#3}': 'TEMPERATURE'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'lake'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save lake flows to budget file +description REPLACE save_flows {'{#1}': 'lake'} + +block options +name temperature_filerecord +type record temperature fileout tempfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name temperature +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname stage keyword +description keyword to specify that record corresponds to temperature. + +block options +name tempfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write temperature information. + +block options +name budget_filerecord +type record budget fileout budgetfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budget +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name budgetfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write budget information. + +block options +name budgetcsv_filerecord +type record budgetcsv fileout budgetcsvfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budgetcsv +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget CSV. + +block options +name budgetcsvfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +block options +name ts_filerecord +type record ts6 filein ts6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name ts6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname head keyword +description keyword to specify that record corresponds to a time-series file. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name ts6_filename +type string +preserve_case true +in_record true +reader urword +optional false +tagged false +longname file name of time series information +description REPLACE timeseriesfile {} + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description REPLACE obs6_filename {'{#1}': 'LKE'} + + +# --------------------- gwe lke packagedata --------------------- + +block packagedata +name packagedata +type recarray lakeno strt aux boundname +shape (maxbound) +reader urword +longname +description + +block packagedata +name lakeno +type integer +shape +tagged false +in_record true +reader urword +longname lake number for this entry +description integer value that defines the lake number associated with the specified PACKAGEDATA data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. Lake information must be specified for every lake or the program will terminate with an error. The program will also terminate with an error if information for a lake is specified more than once. +numeric_index true + +block packagedata +name strt +type double precision +shape +tagged false +in_record true +reader urword +longname starting lake temperature +description real value that defines the starting temperature for the lake. + +block packagedata +name aux +type double precision +in_record true +tagged false +shape (naux) +reader urword +time_series true +optional true +longname auxiliary variables +description REPLACE aux {'{#1}': 'lake'} + +block packagedata +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname lake name +description REPLACE boundname {'{#1}': 'lake'} + + +# --------------------- gwe lke period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name lakeperioddata +type recarray lakeno laksetting +shape +reader urword +longname +description + +block period +name lakeno +type integer +shape +tagged false +in_record true +reader urword +longname lake number for this entry +description integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. +numeric_index true + +block period +name laksetting +type keystring status temperature rainfall evaporation runoff ext-inflow auxiliaryrecord +shape +tagged false +in_record true +reader urword +longname +description line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated temperature of the lake. + +block period +name status +type string +shape +tagged true +in_record true +reader urword +longname lake temperature status +description keyword option to define lake status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the lake. If a lake is inactive, then there will be no solute mass fluxes into or out of the lake and the inactive value will be written for the lake temperature. If a lake is constant, then the temperature for the lake will be fixed at the user specified value. + +block period +name temperature +type string +shape +tagged true +in_record true +time_series true +reader urword +longname lake temperature +description real or character value that defines the temperature for the lake. The specified TEMPERATURE is only applied if the lake is a constant temperature lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name rainfall +type string +shape +tagged true +in_record true +reader urword +time_series true +longname rainfall temperature +description real or character value that defines the rainfall temperature for the lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name runoff +type string +shape +tagged true +in_record true +reader urword +time_series true +longname runoff temperature +description real or character value that defines the temperature of runoff for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name ext-inflow +type string +shape +tagged true +in_record true +reader urword +time_series true +longname ext-inflow temperature +description real or character value that defines the temperature of external inflow for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name auxiliaryrecord +type record auxiliary auxname auxval +shape +tagged +in_record true +reader urword +longname +description + +block period +name auxiliary +type keyword +shape +in_record true +reader urword +longname +description keyword for specifying auxiliary variable. + +block period +name auxname +type string +shape +tagged false +in_record true +reader urword +longname +description name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +block period +name auxval +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname auxiliary variable value +description value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. diff --git a/doc/mf6io/mf6ivar/dfn/gwt-lkt.dfn b/doc/mf6io/mf6ivar/dfn/gwt-lkt.dfn index 44fb4422ca6..52bcbb0c534 100644 --- a/doc/mf6io/mf6ivar/dfn/gwt-lkt.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwt-lkt.dfn @@ -50,7 +50,7 @@ name print_concentration type keyword reader urword optional true -longname print calculated stages to listing file +longname print calculated concentrations to listing file description REPLACE print_concentration {'{#1}': 'lake', '{#2}': 'concentration', '{#3}': 'CONCENTRATION'} block options @@ -352,7 +352,7 @@ tagged false in_record true reader urword longname -description line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, CONCENTRATION, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the concentration of associated with the corresponding flow terms. Concentrations cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated concentration of the lake. +description line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, CONCENTRATION, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the concentration associated with the corresponding flow terms. Concentrations cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated concentration of the lake. block period name status diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 3e000695d07..02a69549671 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -81,6 +81,7 @@ + diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index d421fbaae34..83d2fcb6032 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1171,7 +1171,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab, this%gwecommon) - !case('LKT6') + !case('LKE6') ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi) case ('SFE6') diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 new file mode 100644 index 00000000000..c2baa17e1d3 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -0,0 +1,1221 @@ +! -- Lake Energy Transport Module +! -- todo: what to do about reactions in lake? Decay? +! -- todo: save the lke temperatures into the lak aux variable? +! +! LAK flows (lakbudptr) index var LKT term Transport Type +!--------------------------------------------------------------------------------- + +! -- terms from LAK that will be handled by parent APT Package +! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv +! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf +! STORAGE (aux VOLUME) idxbudsto none used for cv volumes +! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) +! TO-MVR idxbudtmvr TO-MVR q * cfeat + +! -- LAK terms +! RAINFALL idxbudrain RAINFALL q * crain +! EVAPORATION idxbudevap EVAPORATION cfeat null() !< pointer to shared gwe data used by multiple packages but set in mst + + integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr + integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr + integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr + integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr + integer(I4B), pointer :: idxbudwdrl => null() ! index of withdrawal terms in flowbudptr + integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + + real(DP), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature + real(DP), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature + real(DP), dimension(:), pointer, contiguous :: temproff => null() ! runoff temperature + real(DP), dimension(:), pointer, contiguous :: tempiflw => null() ! inflow temperature + + contains + + procedure :: bnd_da => lke_da + procedure :: allocate_scalars + procedure :: apt_allocate_arrays => lke_allocate_arrays + procedure :: find_apt_package => find_lke_package + procedure :: pak_fc_expanded => lke_fc_expanded + procedure :: pak_solve => lke_solve + procedure :: pak_get_nbudterms => lke_get_nbudterms + procedure :: pak_setup_budobj => lke_setup_budobj + procedure :: pak_fill_budobj => lke_fill_budobj + procedure :: lke_rain_term + procedure :: lke_evap_term + procedure :: lke_roff_term + procedure :: lke_iflw_term + procedure :: lke_wdrl_term + procedure :: lke_outf_term + procedure :: pak_df_obs => lke_df_obs + procedure :: pak_rp_obs => lke_rp_obs + procedure :: pak_bd_obs => lke_bd_obs + procedure :: pak_set_stressperiod => lke_set_stressperiod + + end type GweLkeType + +contains + + subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + fmi, tsplab, gwecommon) +! ****************************************************************************** +! mwt_create -- Create a New MWT Package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages + ! -- local + type(GweLkeType), pointer :: lktobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate (lktobj) + packobj => lktobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call lktobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + + ! -- Store pointer to flow model interface. When the GwfGwt exchange is + ! created, it sets fmi%bndlist so that the GWT model has access to all + ! the flow packages + lktobj%fmi => fmi + ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + lkeobj%tsplab => tsplab + ! + ! -- Store pointer to shared data module for accessing cpw, rhow + ! for the budget calculations, and for accessing the latent heat of + ! vaporization for evaporative cooling. + lkeobj%gwecommon => gwecommon + ! + ! -- return + return + end subroutine lke_create + + subroutine find_lke_package(this) +! ****************************************************************************** +! find corresponding lkt package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweLkeType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + class(BndType), pointer :: packobj + integer(I4B) :: ip, icount + integer(I4B) :: nbudterm + logical :: found +! ------------------------------------------------------------------------------ + ! + ! -- Initialize found to false, and error later if flow package cannot + ! be found + found = .false. + ! + ! -- If user is specifying flows in a binary budget file, then set up + ! the budget file reader, otherwise set a pointer to the flow package + ! budobj + if (this%fmi%flows_from_file) then + call this%fmi%set_aptbudobj_pointer(this%flowpackagename, this%flowbudptr) + if (associated(this%flowbudptr)) found = .true. + ! + else + if (associated(this%fmi%gwfbndlist)) then + ! -- Look through gwfbndlist for a flow package with the same name as + ! this transport package name + do ip = 1, this%fmi%gwfbndlist%Count() + packobj => GetBndFromList(this%fmi%gwfbndlist, ip) + if (packobj%packName == this%flowpackagename) then + found = .true. + ! + ! -- store BndType pointer to packobj, and then + ! use the select type to point to the budobj in flow package + this%flowpackagebnd => packobj + select type (packobj) + type is (LakType) + this%flowbudptr => packobj%budobj + end select + end if + if (found) exit + end do + end if + end if + ! + ! -- error if flow package not found + if (.not. found) then + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + ! + ! -- allocate space for idxbudssm, which indicates whether this is a + ! special budget term or one that is a general source and sink + nbudterm = this%flowbudptr%nbudterm + call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) + ! + ! -- Process budget terms and identify special budget terms + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv + icount = 1 + do ip = 1, this%flowbudptr%nbudterm + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') + this%idxbudfjf = ip + this%idxbudssm(ip) = 0 + case ('GWF') + this%idxbudgwf = ip + this%idxbudssm(ip) = 0 + case ('STORAGE') + this%idxbudsto = ip + this%idxbudssm(ip) = 0 + case ('RAINFALL') + this%idxbudrain = ip + this%idxbudssm(ip) = 0 + case ('EVAPORATION') + this%idxbudevap = ip + this%idxbudssm(ip) = 0 + case ('RUNOFF') + this%idxbudroff = ip + this%idxbudssm(ip) = 0 + case ('EXT-INFLOW') + this%idxbudiflw = ip + this%idxbudssm(ip) = 0 + case ('WITHDRAWAL') + this%idxbudwdrl = ip + this%idxbudssm(ip) = 0 + case ('EXT-OUTFLOW') + this%idxbudoutf = ip + this%idxbudssm(ip) = 0 + case ('TO-MVR') + this%idxbudtmvr = ip + this%idxbudssm(ip) = 0 + case ('FROM-MVR') + this%idxbudfmvr = ip + this%idxbudssm(ip) = 0 + case ('AUXILIARY') + this%idxbudaux = ip + this%idxbudssm(ip) = 0 + case default + ! + ! -- set idxbudssm equal to a column index for where the temperatures + ! are stored in the tempbud(nbudssm, ncv) array + this%idxbudssm(ip) = icount + icount = icount + 1 + end select + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & + ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & + ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist + end do + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' + ! + ! -- Return + return + end subroutine find_lke_package + + subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) +! ****************************************************************************** +! lke_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() +! in order to add matrix terms specifically for LKT +! **************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweLkeType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + class(MatrixBaseType), pointer :: matrix_sln + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: iloc + integer(I4B) :: iposd + real(DP) :: rrate + real(DP) :: rhsval + real(DP) :: hcofval +! ------------------------------------------------------------------------------ + ! + ! -- add rainfall contribution + if (this%idxbudrain /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist + call this%lke_rain_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add evaporation contribution + if (this%idxbudevap /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist + call this%lke_evap_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add runoff contribution + if (this%idxbudroff /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist + call this%lke_roff_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add inflow contribution + if (this%idxbudiflw /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist + call this%lke_iflw_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add withdrawal contribution + if (this%idxbudwdrl /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudwdrl)%nlist + call this%lke_wdrl_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add outflow contribution + if (this%idxbudoutf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist + call this%lke_outf_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- Return + return + end subroutine lke_fc_expanded + + subroutine lke_solve(this) +! ****************************************************************************** +! lke_solve -- add terms specific to lakes to the explicit lake solve +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + ! -- local + integer(I4B) :: j + integer(I4B) :: n1, n2 + real(DP) :: rrate +! ------------------------------------------------------------------------------ + ! + ! -- add rainfall contribution + if (this%idxbudrain /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist + call this%lke_rain_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add evaporation contribution + if (this%idxbudevap /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist + call this%lke_evap_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add runoff contribution + if (this%idxbudroff /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist + call this%lke_roff_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add inflow contribution + if (this%idxbudiflw /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist + call this%lke_iflw_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add withdrawal contribution + if (this%idxbudwdrl /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudwdrl)%nlist + call this%lke_wdrl_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add outflow contribution + if (this%idxbudoutf /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist + call this%lke_outf_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- Return + return + end subroutine lke_solve + + function lke_get_nbudterms(this) result(nbudterms) +! ****************************************************************************** +! lke_get_nbudterms -- function to return the number of budget terms just for +! this package. This overrides function in parent. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweLkeType) :: this + ! -- return + integer(I4B) :: nbudterms + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Number of budget terms is 6 + nbudterms = 6 + ! + ! -- Return + return + end function lke_get_nbudterms + + subroutine lke_setup_budobj(this, idx) +! ****************************************************************************** +! lke_setup_budobj -- Set up the budget object that stores all the lake flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(inout) :: idx + ! -- local + integer(I4B) :: maxlist, naux + character(len=LENBUDTXT) :: text +! ------------------------------------------------------------------------------ + ! + ! -- + text = ' RAINFALL' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EVAPORATION' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' RUNOFF' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-INFLOW' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' WITHDRAWAL' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudwdrl)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- + text = ' EXT-OUTFLOW' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! + ! -- return + return + end subroutine lke_setup_budobj + + subroutine lke_fill_budobj(this, idx, x, ccratin, ccratout) +! ****************************************************************************** +! lke_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(inout) :: idx + real(DP), dimension(:), intent(in) :: x + real(DP), intent(inout) :: ccratin + real(DP), intent(inout) :: ccratout + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: nlist + real(DP) :: q + ! -- formats +! ----------------------------------------------------------------------------- + + ! -- RAIN + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%lke_rain_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- EVAPORATION + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%lke_evap_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- RUNOFF + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%lke_roff_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- EXT-INFLOW + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%lke_iflw_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- WITHDRAWAL + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudwdrl)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%lke_wdrl_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- EXT-OUTFLOW + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%lke_outf_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! + ! -- return + return + end subroutine lke_fill_budobj + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweLkeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%memoryPath) + call mem_allocate(this%idxbudevap, 'IDXBUDEVAP', this%memoryPath) + call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath) + call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) + call mem_allocate(this%idxbudwdrl, 'IDXBUDWDRL', this%memoryPath) + call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) + ! + ! -- Initialize + this%idxbudrain = 0 + this%idxbudevap = 0 + this%idxbudroff = 0 + this%idxbudiflw = 0 + this%idxbudwdrl = 0 + this%idxbudoutf = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine lke_allocate_arrays(this) +! ****************************************************************************** +! lke_allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweLkeType), intent(inout) :: this + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- time series + call mem_allocate(this%temprain, this%ncv, 'TEMPRAIN', this%memoryPath) + call mem_allocate(this%tempevap, this%ncv, 'TEMPEVAP', this%memoryPath) + call mem_allocate(this%temproff, this%ncv, 'TEMPROFF', this%memoryPath) + call mem_allocate(this%tempiflw, this%ncv, 'TEMPIFLW', this%memoryPath) + ! + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() + ! + ! -- Initialize + do n = 1, this%ncv + this%temprain(n) = DZERO + this%tempevap(n) = DZERO + this%temproff(n) = DZERO + this%tempiflw(n) = DZERO + end do + ! + ! + ! -- Return + return + end subroutine lke_allocate_arrays + + subroutine lke_da(this) +! ****************************************************************************** +! lke_da +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweLkeType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- deallocate scalars + call mem_deallocate(this%idxbudrain) + call mem_deallocate(this%idxbudevap) + call mem_deallocate(this%idxbudroff) + call mem_deallocate(this%idxbudiflw) + call mem_deallocate(this%idxbudwdrl) + call mem_deallocate(this%idxbudoutf) + ! + ! -- deallocate time series + call mem_deallocate(this%temprain) + call mem_deallocate(this%tempevap) + call mem_deallocate(this%temproff) + call mem_deallocate(this%tempiflw) + ! + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() + ! + ! -- Return + return + end subroutine lke_da + + subroutine lke_rain_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! lke_rain_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudrain)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) + ctmp = this%temprain(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine lke_rain_term + + subroutine lke_evap_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! lke_evap_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp + real(DP) :: omega +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) + ! -- note that qbnd is negative for evap + qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) + ctmp = this%tempevap(n1) + if (this%xnewpak(n1) < ctmp) then + omega = DONE + else + omega = DZERO + end if + if (present(rrate)) & + rrate = omega * qbnd * this%xnewpak(n1) + & + (DONE - omega) * qbnd * ctmp + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp + if (present(hcofval)) hcofval = omega * qbnd + ! + ! -- return + return + end subroutine lke_evap_term + + subroutine lke_roff_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! lke_roff_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudroff)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) + ctmp = this%temproff(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine lke_roff_term + + subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! lke_iflw_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudiflw)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) + ctmp = this%tempiflw(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO + ! + ! -- return + return + end subroutine lke_iflw_term + + subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! lke_wdrl_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudwdrl)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudwdrl)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudwdrl)%flow(ientry) + ctmp = this%xnewpak(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine lke_wdrl_term + + subroutine lke_outf_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! lke_outf_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudoutf)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) + ctmp = this%xnewpak(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine lke_outf_term + + subroutine lke_df_obs(this) +! ****************************************************************************** +! lke_df_obs -- obs are supported? +! -- Store observation type supported by APT package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweLkeType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for temperature observation type. + call this%obs%StoreObsType('temperature', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for flow between features, such as lake to lake. + call this%obs%StoreObsType('flow-ja-face', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID12 + ! + ! -- Store obs type and assign procedure pointer + ! for from-mvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for to-mvr observation type. + call this%obs%StoreObsType('to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for constant observation type. + call this%obs%StoreObsType('constant', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type: lkt + call this%obs%StoreObsType('lkt', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID12 + ! + ! -- Store obs type and assign procedure pointer + ! for rainfall observation type. + call this%obs%StoreObsType('rainfall', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for evaporation observation type. + call this%obs%StoreObsType('evaporation', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for runoff observation type. + call this%obs%StoreObsType('runoff', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for inflow observation type. + call this%obs%StoreObsType('ext-inflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for withdrawal observation type. + call this%obs%StoreObsType('withdrawal', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for ext-outflow observation type. + call this%obs%StoreObsType('ext-outflow', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + return + end subroutine lke_df_obs + + !> @brief Process package specific obs + !! + !! Method to process specific observations for this package. + !! + !< + subroutine lke_rp_obs(this, obsrv, found) + ! -- dummy + class(GweLkeType), intent(inout) :: this !< package class + type(ObserveType), intent(inout) :: obsrv !< observation object + logical, intent(inout) :: found !< indicate whether observation was found + ! -- local + ! + found = .true. + select case (obsrv%ObsTypeId) + case ('RAINFALL') + call this%rp_obs_byfeature(obsrv) + case ('EVAPORATION') + call this%rp_obs_byfeature(obsrv) + case ('RUNOFF') + call this%rp_obs_byfeature(obsrv) + case ('EXT-INFLOW') + call this%rp_obs_byfeature(obsrv) + case ('WITHDRAWAL') + call this%rp_obs_byfeature(obsrv) + case ('EXT-OUTFLOW') + call this%rp_obs_byfeature(obsrv) + case ('TO-MVR') + call this%rp_obs_budterm(obsrv, & + this%flowbudptr%budterm(this%idxbudtmvr)) + case default + found = .false. + end select + ! + return + end subroutine lke_rp_obs + + subroutine lke_bd_obs(this, obstypeid, jj, v, found) +! ****************************************************************************** +! lke_bd_obs -- calculate observation value and pass it back to APT +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweLkeType), intent(inout) :: this + character(len=*), intent(in) :: obstypeid + real(DP), intent(inout) :: v + integer(I4B), intent(in) :: jj + logical, intent(inout) :: found + ! -- local + integer(I4B) :: n1, n2 +! ------------------------------------------------------------------------------ + ! + found = .true. + select case (obstypeid) + case ('RAINFALL') + if (this%iboundpak(jj) /= 0) then + call this%lke_rain_term(jj, n1, n2, v) + end if + case ('EVAPORATION') + if (this%iboundpak(jj) /= 0) then + call this%lke_evap_term(jj, n1, n2, v) + end if + case ('RUNOFF') + if (this%iboundpak(jj) /= 0) then + call this%lke_roff_term(jj, n1, n2, v) + end if + case ('EXT-INFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lke_iflw_term(jj, n1, n2, v) + end if + case ('WITHDRAWAL') + if (this%iboundpak(jj) /= 0) then + call this%lke_wdrl_term(jj, n1, n2, v) + end if + case ('EXT-OUTFLOW') + if (this%iboundpak(jj) /= 0) then + call this%lke_outf_term(jj, n1, n2, v) + end if + case default + found = .false. + end select + ! + return + end subroutine lke_bd_obs + + subroutine lke_set_stressperiod(this, itemno, keyword, found) +! ****************************************************************************** +! lke_set_stressperiod -- Set a stress period attribute for using keywords. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TimeSeriesManagerModule, only: read_value_or_time_series_adv + ! -- dummy + class(GweLkeType), intent(inout) :: this + integer(I4B), intent(in) :: itemno + character(len=*), intent(in) :: keyword + logical, intent(inout) :: found + ! -- local + character(len=LINELENGTH) :: text + integer(I4B) :: ierr + integer(I4B) :: jj + real(DP), pointer :: bndElem => null() + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! RAINFALL + ! EVAPORATION + ! RUNOFF + ! EXT-INFLOW + ! WITHDRAWAL + ! + found = .true. + select case (keyword) + case ('RAINFALL') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%temprain(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RAINFALL') + case ('EVAPORATION') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%tempevap(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EVAPORATION') + case ('RUNOFF') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%temproff(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RUNOFF') + case ('EXT-INFLOW') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%tempiflw(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'EXT-INFLOW') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. + end select + ! +999 continue + ! + ! -- return + return + end subroutine lke_set_stressperiod + +end module GweLkeModule From d8121fa0b86e9a9ba0f7c18d67402466e69511c5 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 7 Apr 2023 10:17:11 -0700 Subject: [PATCH 102/212] Add clarity to common.dfn about maximum auxiliary variable name length --- doc/mf6io/mf6ivar/dfn/common.dfn | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/mf6io/mf6ivar/dfn/common.dfn b/doc/mf6io/mf6ivar/dfn/common.dfn index 0fd5220c2f0..27d34e80b85 100644 --- a/doc/mf6io/mf6ivar/dfn/common.dfn +++ b/doc/mf6io/mf6ivar/dfn/common.dfn @@ -1,7 +1,7 @@ # constants from bcoptions.tex that are used to construct mf6 input variable descriptions name auxnames -description defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +description defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. name auxmultname description name of auxiliary variable to be used as multiplier of {#1}. From 7667d32053386fce94f1f17467817211046b0ae9 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Wed, 12 Apr 2023 08:57:49 -0400 Subject: [PATCH 103/212] * Refactored heat transport such that governing eqn is NOT divided through by rhow*cpw * Other scale-factor-related updates in gwe packages; not all packages are done but most are * No testing other than our two uze example variants - will need to put all packages through their paces --- src/Model/Connection/GweInterfaceModel.f90 | 5 +- src/Model/Connection/GwtInterfaceModel.f90 | 3 +- src/Model/GroundWaterEnergy/gwe1.f90 | 5 +- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 37 +++++++++----- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 13 ++--- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 43 ++++++++-------- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 25 +++++----- src/Model/GroundWaterEnergy/gwe1src1.f90 | 3 +- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 25 ++++++---- src/Model/GroundWaterTransport/gwt1.f90 | 14 ++++-- src/Model/GroundWaterTransport/tsp1adv1.f90 | 11 +++-- src/Model/GroundWaterTransport/tsp1apt1.f90 | 54 +++++++++++++-------- src/Model/GroundWaterTransport/tsp1cnc1.f90 | 18 +++---- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 11 +++-- src/Model/TransportModel.f90 | 5 +- 15 files changed, 168 insertions(+), 104 deletions(-) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 6ba8254424c..27d9082d0f7 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -82,9 +82,10 @@ subroutine gweifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) - call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & + this%eqnsclfac) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi, & - this%gwecommon) + this%eqnsclfac, this%gwecommon) call tsp_obs_cr(this%obs, inobs) end subroutine gweifmod_cr diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 2991e665622..522f2bbea92 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -82,7 +82,8 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) - call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi) + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & + this%eqnsclfac) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) call tsp_obs_cr(this%obs, inobs) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 4acba7f00be..dca84995907 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -243,9 +243,10 @@ subroutine gwe_cr(filename, id, modelname) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + this%eqnsclfac) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi, & - this%gwecommon) + this%eqnsclfac, this%gwecommon) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, this%gwecommon) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 0e260fe6605..3187e019cfb 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -55,6 +55,7 @@ module GweDspModule integer(I4B), pointer :: iangle1 => null() ! flag indicating angle1 is available integer(I4B), pointer :: iangle2 => null() ! flag indicating angle2 is available integer(I4B), pointer :: iangle3 => null() ! flag indicating angle3 is available + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =rhow*cpw for energy contains @@ -79,7 +80,7 @@ module GweDspModule contains - subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi, gwecommon) + subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi, eqnsclfac, gwecommon) ! ****************************************************************************** ! dsp_cr -- Create a new DSP object ! ****************************************************************************** @@ -95,6 +96,7 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi, gwecommon) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- formats character(len=*), parameter :: fmtdsp = & @@ -115,6 +117,7 @@ subroutine dsp_cr(dspobj, name_model, inunit, iout, fmi, gwecommon) dspobj%inunit = inunit dspobj%iout = iout dspobj%fmi => fmi + dspobj%eqnsclfac => eqnsclfac dspobj%gwecommon => gwecommon ! ! -- Check if input file is open @@ -364,7 +367,7 @@ subroutine dsp_cq(this, cnew, flowja) real(DP), intent(inout), dimension(:) :: flowja ! -- local integer(I4B) :: n, m, ipos, isympos - real(DP) :: dnm + real(DP) :: dnm, qnm ! ------------------------------------------------------------------------------ ! ! -- Calculate dispersion and add to flowja @@ -378,7 +381,9 @@ subroutine dsp_cq(this, cnew, flowja) if (this%fmi%ibdgwfsat0(m) == 0) cycle isympos = this%dis%con%jas(ipos) dnm = this%dispcoef(isympos) - flowja(ipos) = flowja(ipos) + dnm * (cnew(m) - cnew(n)) +!! qnm = dnm * (cnew(m) - cnew(n)) * this%eqnsclfac + qnm = dnm * (cnew(m) - cnew(n)) + flowja(ipos) = flowja(ipos) + qnm end do end do end if @@ -777,7 +782,7 @@ subroutine calcdispellipse(this) real(DP) :: alh, alv, ath1, ath2, atv, a real(DP) :: al, at1, at2 real(DP) :: qzoqsquared - real(DP) :: dstar +!! real(DP) :: dstar real(DP) :: ktbulk ! TODO: Implement additional options for characterizing ktbulk (see Markle refs) real(DP) :: qsw ! ------------------------------------------------------------------------------ @@ -821,7 +826,7 @@ subroutine calcdispellipse(this) end if ! ! -- calculate - dstar = DZERO +!! dstar = DZERO !if (this%idiffc > 0) then ! dstar = this%diffc(n) * this%porosity(n) !end if @@ -829,7 +834,13 @@ subroutine calcdispellipse(this) if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) * & this%fmi%gwfsat(n) if (this%ikts > 0) ktbulk = ktbulk + (DONE - this%porosity(n)) * this%kts(n) - dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) +!! ! -- The division by rhow*cpw below is done to render dstar in the form +!! ! -- of a thermal diffusivity, and not because the governing equation +!! ! -- is scaled by rhow*cpw. Because of this conceptual distinction, +!! ! -- ktbulk is divided by the explicitly calculated product rhow*cpw, +!! ! -- and not by the equivalent scale factor eqnsclfac, even though it +!! ! -- should make no practical difference in the result. +!! dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) ! kluge note eqnsclfac, define product ! ! -- Calculate the longitudal and transverse dispersivities al = DZERO @@ -843,10 +854,14 @@ subroutine calcdispellipse(this) end if ! ! -- Calculate and save the diagonal components of the dispersion tensor - qsw = q * this%fmi%gwfsat(n) - this%d11(n) = al * qsw + dstar - this%d22(n) = at1 * qsw + dstar - this%d33(n) = at2 * qsw + dstar +!! qsw = q * this%fmi%gwfsat(n) +!! this%d11(n) = al * qsw + dstar +!! this%d22(n) = at1 * qsw + dstar +!! this%d33(n) = at2 * qsw + dstar + qsw = q * this%fmi%gwfsat(n) * this%eqnsclfac + this%d11(n) = al * qsw + ktbulk + this%d22(n) = at1 * qsw + ktbulk + this%d33(n) = at2 * qsw + ktbulk ! ! -- Angles of rotation if velocity based dispersion tensor if (this%idisp > 0) then @@ -913,7 +928,7 @@ subroutine calcdispcoef(this) ! -- set iavgmeth = 1 to use arithmetic averaging for effective dispersion iavgmeth = 1 ! - ! -- Proces connections + ! -- Process connections nodes = size(this%d11) do n = 1, nodes if (this%fmi%ibdgwfsat0(n) == 0) cycle diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index c2baa17e1d3..3a1ff3c237d 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -115,19 +115,19 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & type(TspLabelsType), pointer :: tsplab type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local - type(GweLkeType), pointer :: lktobj + type(GweLkeType), pointer :: lkeobj ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables - allocate (lktobj) - packobj => lktobj + allocate (lkeobj) + packobj => lkeobj ! ! -- create name and memory path call packobj%set_names(ibcnum, namemodel, pakname, ftype) packobj%text = text ! ! -- allocate scalars - call lktobj%allocate_scalars() + call lkeobj%allocate_scalars() ! ! -- initialize package call packobj%pack_initialize() @@ -142,7 +142,7 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Store pointer to flow model interface. When the GwfGwt exchange is ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages - lktobj%fmi => fmi + lkeobj%fmi => fmi ! ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature @@ -567,7 +567,7 @@ subroutine lke_setup_budobj(this, idx) return end subroutine lke_setup_budobj - subroutine lke_fill_budobj(this, idx, x, ccratin, ccratout) + subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! ****************************************************************************** ! lke_fill_budobj -- copy flow terms into this%budobj ! ****************************************************************************** @@ -579,6 +579,7 @@ subroutine lke_fill_budobj(this, idx, x, ccratin, ccratout) class(GweLkeType) :: this integer(I4B), intent(inout) :: idx real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index dff9c25f669..f48a39968c3 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -242,9 +242,12 @@ subroutine mst_fc_sto(this, nodes, cold, nja, matrix_sln, idxglo, rhs) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- add terms to diagonal and rhs accumulators - term = vsolid * (this%rhos(n) * this%cps(n)) / (this%rhow * this%cpw) - hhcof = -(vnew + term) * tled - rrhs = -(vold + term) * tled * cold(n) +!! term = vsolid * (this%rhos(n) * this%cps(n)) / this%eqnsclfac +!! hhcof = -(vnew + term) * tled +!! rrhs = -(vold + term) * tled * cold(n) + term = (this%rhos(n) * this%cps(n)) * vsolid + hhcof = -(this%eqnsclfac * vnew + term) * tled + rrhs = -(this%eqnsclfac * vold + term) * tled * cold(n) idiag = this%dis%con%ia(n) call matrix_sln%add_value_pos(idxglo(idiag), hhcof) rhs(n) = rhs(n) + rrhs @@ -294,9 +297,11 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & idiag = this%dis%con%ia(n) if (this%idcy == 1) then ! - ! -- first order decay rate is a function of temperature, so add + ! -- first order decay rate is a function of temperature, so add ! kluge note: do we need/want first-order decay for temperature??? ! to left hand side - hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) +!! hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) ! kluge note: this term should NOT be divided by eqnsclfac for fc purposes because rhow*cpw is already effectively divided out + hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) & + * this%eqnsclfac call matrix_sln%add_value_pos(idxglo(idiag), hhcof) elseif (this%idcy == 2) then ! @@ -304,6 +309,7 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & ! from the user-specified rate to prevent negative temperatures ! kluge note: think through negative temps decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & kiter, cold(n), cnew(n), delt) +!! decay_rate = decay_rate / this%eqnsclfac ! kluge note: this term does get divided by eqnsclfac for fc purposes because it should start out being a rate of energy this%decaylast(n) = decay_rate rrhs = decay_rate * vcell * swtpdt * this%porosity(n) rhs(n) = rhs(n) + rrhs @@ -383,10 +389,14 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate - term = vsolid * (this%rhos(n) * this%cps(n)) / this%eqnsclfac - hhcof = -(vwatnew + term) * tled - rrhs = -(vwatold + term) * tled * cold(n) - rate = (hhcof * cnew(n) - rrhs) * this%eqnsclfac +!! term = vsolid * (this%rhos(n) * this%cps(n)) / this%eqnsclfac +!! hhcof = -(vwatnew + term) * tled +!! rrhs = -(vwatold + term) * tled * cold(n) +!! rate = (hhcof * cnew(n) - rrhs) * this%eqnsclfac + term = (this%rhos(n) * this%cps(n)) * vsolid + hhcof = -(this%eqnsclfac * vwatnew + term) * tled + rrhs = -(this%eqnsclfac * vwatold + term) * tled * cold(n) + rate = hhcof * cnew(n) - rrhs this%ratesto(n) = rate idiag = this%dis%con%ia(n) flowja(idiag) = flowja(idiag) + rate @@ -401,7 +411,7 @@ end subroutine mst_cq_sto !! Method to calculate decay terms for the package. !! !< - subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) + subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) ! kluge note: this handles only decay in water; need to add zero-order (but not first-order?) decay in solid ! -- modules use TdisModule, only: delt ! -- dummy @@ -436,12 +446,12 @@ subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) rate = DZERO hhcof = DZERO rrhs = DZERO - if (this%idcy == 1) then - hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) + if (this%idcy == 1) then ! kluge note: do we need/want first-order decay for temperature??? + hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) * this%eqnsclfac elseif (this%idcy == 2) then decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & 0, cold(n), cnew(n), delt) - rrhs = decay_rate * vcell * swtpdt * this%porosity(n) + rrhs = decay_rate * vcell * swtpdt * this%porosity(n) ! kluge note: this term does NOT get multiplied by eqnsclfac for cq purposes because it should already be a rate of energy end if rate = hhcof * cnew(n) - rrhs this%ratedcy(n) = rate @@ -472,11 +482,6 @@ subroutine mst_bd(this, isuppress_output, model_budget) real(DP) :: rin real(DP) :: rout ! -!! ! -- for GWE, storage rate needs to have units adjusted -!! do n = 1, size(this%ratesto) -!! this%ratesto(n) = this%ratesto(n) * this%cpw * this%rhow -!! end do -!! ! ! -- sto call rate_accumulator(this%ratesto, rin, rout) call model_budget%addentry(rin, rout, delt, budtxt(1), & @@ -933,7 +938,7 @@ function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & ! temperature, so reduce the rate if it would result in ! removing more energy than is in the cell. ! kluge note: think through if (kiter == 1) then - decay_rate = min(decay_rate_usr, cold / delt) + decay_rate = min(decay_rate_usr, cold / delt) ! kluge note: actually want to use rhow*cpw*cold and rhow*cpw*cnew for rates here and below else decay_rate = decay_rate_last if (cnew < DZERO) then diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index f9c62a01a26..02438740fe2 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -321,7 +321,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add evaporation contribution if (this%idxbudevap /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist - call this%sfe_evap_term(j, n1, n2, rrate, rhsval) !, hcofval) ! kluge note: should include hcofval in the call; it'll be set to zero + call this%sfe_evap_term(j, n1, n2, rrate, rhsval, hcofval) ! kluge note: included hcofval in the call; it'll be set to zero iloc = this%idxlocnode(n1) iposd = this%idxpakdiag(n1) call matrix_sln%add_value_pos(iposd, hcofval) @@ -715,8 +715,8 @@ subroutine sfe_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) - if (present(rhsval)) rhsval = -rrate + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac ! kluge note: think about budget / sensible heat issue + if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -743,9 +743,10 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) - heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 - if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day - if (present(rhsval)) rhsval = -rrate ! kluge note: shouldn't this be divided by this%eqnsclfac?? + heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 (kluge note) + if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day (kluge note) +!! if (present(rhsval)) rhsval = -rrate / this%eqnsclfac ! kluge note: divided by eqnsclfac for fc purposes because rrate is in terms of energy + if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -771,8 +772,8 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) ! kluge note: yes, multiply by this%eqnsclfac - if (present(rhsval)) rhsval = -rrate + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -802,8 +803,8 @@ subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) - if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) - if (present(rhsval)) rhsval = -rrate + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -829,9 +830,9 @@ subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd !* this%cpw(n1) * this%rhow(n1) + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd !* this%cpw(n1) * this%rhow(n1) + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index 7cbe1958ef9..4d85fc32cae 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -179,7 +179,8 @@ subroutine src_cf(this, reset_mover) cycle end if q = this%bound(1, i) - this%rhs(i) = -q / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) +!! this%rhs(i) = -q / this%eqnsclfac + this%rhs(i) = -q end do ! return diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 9fac47b84e0..235acb8e699 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -588,7 +588,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add from mover contribution if (this%idxbudfmvr /= 0) then do n = 1, this%ncv - rhsval = this%qmfrommvr(n) + rhsval = this%qmfrommvr(n) ! kluge note: presumably already in terms of energy iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index rhs(iloc) = rhs(iloc) - rhsval end do @@ -634,8 +634,9 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end if iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row iposoffd = this%idxfjfoffdglo(j) !< position of feature-id2 column in feature id1's host-cell row - call matrix_sln%add_value_pos(iposd, omega * qbnd) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) + call matrix_sln%add_value_pos(iposd, omega * qbnd * this%eqnsclfac) + call matrix_sln%add_value_pos(iposoffd, & + (DONE - omega) * qbnd * this%eqnsclfac) end do end if ! @@ -1051,8 +1052,10 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & r = -qbnd * ctmp end if if (present(rrate)) rrate = qbnd * ctmp * this%eqnsclfac - if (present(rhsval)) rhsval = r - if (present(hcofval)) hcofval = h +!! if (present(rhsval)) rhsval = r +!! if (present(hcofval)) hcofval = h + if (present(rhsval)) rhsval = r * this%eqnsclfac + if (present(hcofval)) hcofval = h * this%eqnsclfac ! ! -- return return @@ -1085,7 +1088,8 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & ctmp = this%tempinfl(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd +!! if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return @@ -1126,8 +1130,10 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & if (present(rrate)) & rrate = (omega * qbnd * this%xnewpak(n1) + & (DONE - omega) * qbnd * ctmp) * this%eqnsclfac - if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp - if (present(hcofval)) hcofval = omega * qbnd +!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp +!! if (present(hcofval)) hcofval = omega * qbnd + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * this%eqnsclfac + if (present(hcofval)) hcofval = omega * qbnd * this%eqnsclfac ! ! -- return return @@ -1160,7 +1166,8 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & ctmp = this%tempinfl(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd +!! if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index b004919ce52..c34a42210cd 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -240,9 +240,11 @@ subroutine gwt_cr(filename, id, modelname) call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + this%eqnsclfac) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + this%tsplab, this%eqnsclfac) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) @@ -413,7 +415,13 @@ subroutine gwt_ar(this) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) ! - ! -- Set governing equation scale factor + ! -- Set governing equation scale factor. Note that this scale factor + ! -- cannot be set arbitrarily. For solute transport, it must be set + ! -- to 1. Setting it to a different value will NOT automatically + ! -- scale all the terms of the governing equation correctly by that + ! -- value. This is because much of the coding in the associated + ! -- packages implicitly assumes the governing equation for solute + ! -- transport is scaled by 1. (effectively unscaled). this%eqnsclfac = DONE ! ! -- Call dis_ar to write binary grid file diff --git a/src/Model/GroundWaterTransport/tsp1adv1.f90 b/src/Model/GroundWaterTransport/tsp1adv1.f90 index fd7e8e6e9e7..750b0d106bc 100644 --- a/src/Model/GroundWaterTransport/tsp1adv1.f90 +++ b/src/Model/GroundWaterTransport/tsp1adv1.f90 @@ -20,6 +20,7 @@ module TspAdvModule type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object real(DP), dimension(:), pointer, contiguous :: cpw => null() ! pointer to GWE heat capacity of water real(DP), dimension(:), pointer, contiguous :: rhow => null() ! fixed density of water + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy contains @@ -40,7 +41,7 @@ module TspAdvModule contains - subroutine adv_cr(advobj, name_model, inunit, iout, fmi) + subroutine adv_cr(advobj, name_model, inunit, iout, fmi, eqnsclfac) ! ****************************************************************************** ! adv_cr -- Create a new ADV object ! ****************************************************************************** @@ -53,6 +54,7 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -68,6 +70,7 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi) advobj%inunit = inunit advobj%iout = iout advobj%fmi => fmi + advobj%eqnsclfac => eqnsclfac ! ! -- Return return @@ -160,7 +163,8 @@ subroutine adv_fc(this, nodes, matrix_sln, idxglo, cnew, rhs) if (this%dis%con%mask(ipos) == 0) cycle m = this%dis%con%ja(ipos) if (this%ibound(m) == 0) cycle - qnm = this%fmi%gwfflowja(ipos) +!! qnm = this%fmi%gwfflowja(ipos) + qnm = this%fmi%gwfflowja(ipos) * this%eqnsclfac omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) call matrix_sln%add_value_pos(idxglo(ipos), qnm * (DONE - omega)) call matrix_sln%add_value_pos(idxglo(idiag), qnm * omega) @@ -277,6 +281,7 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) if (smooth > DZERO) then alimiter = DTWO * smooth / (DONE + smooth) qtvd = DHALF * alimiter * qnm * (cnew(idn) - cnew(iup)) + qtvd = qtvd * this%eqnsclfac end if end if ! @@ -311,7 +316,7 @@ subroutine adv_cq(this, cnew, flowja) do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1 m = this%dis%con%ja(ipos) if (this%ibound(m) == 0) cycle - qnm = this%fmi%gwfflowja(ipos) + qnm = this%fmi%gwfflowja(ipos) * this%eqnsclfac omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & qnm * (DONE - omega) * cnew(m) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index d30bf429231..974503c0c44 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -832,7 +832,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B) :: iposd, iposoffd integer(I4B) :: ipossymd, ipossymoffd real(DP) :: cold - real(DP) :: qbnd + real(DP) :: qbnd, qbndscld real(DP) :: omega real(DP) :: rrate real(DP) :: rhsval @@ -870,7 +870,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add from mover contribution if (this%idxbudfmvr /= 0) then do n = 1, this%ncv - rhsval = this%qmfrommvr(n) + rhsval = this%qmfrommvr(n) ! kluge note: presumably already in terms of energy for heat transport??? iloc = this%idxlocnode(n) rhs(iloc) = rhs(iloc) - rhsval end do @@ -887,18 +887,23 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) omega = DZERO if (qbnd < DZERO) omega = DONE + qbndscld = qbnd * this%eqnsclfac ! ! -- add to apt row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, omega * qbnd) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) +!! call matrix_sln%add_value_pos(iposd, omega * qbnd) +!! call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) + call matrix_sln%add_value_pos(iposd, omega * qbndscld) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbndscld) ! ! -- add to gwf row for apt connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) - call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) +!! call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) +!! call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) + call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbndscld) + call matrix_sln%add_value_pos(ipossymoffd, -omega * qbndscld) end if end do ! @@ -913,10 +918,13 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) else omega = DZERO end if + qbndscld = qbnd * this%eqnsclfac iposd = this%idxfjfdglo(j) iposoffd = this%idxfjfoffdglo(j) - call matrix_sln%add_value_pos(iposd, omega * qbnd) - call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) +!! call matrix_sln%add_value_pos(iposd, omega * qbnd) +!! call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) + call matrix_sln%add_value_pos(iposd, omega * qbndscld) + call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbndscld) end do end if ! @@ -1881,7 +1889,7 @@ subroutine apt_solve(this) ! -- add from mover contribution if (this%idxbudfmvr /= 0) then do n1 = 1, size(this%qmfrommvr) - rrate = this%qmfrommvr(n1) + rrate = this%qmfrommvr(n1) ! kluge note: presumably in terms of energy already for heat transport??? this%dbuff(n1) = this%dbuff(n1) + rrate end do end if @@ -1896,12 +1904,12 @@ subroutine apt_solve(this) qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) if (qbnd <= DZERO) then ctmp = this%xnewpak(n) - this%rhs(j) = qbnd * ctmp + this%rhs(j) = qbnd * ctmp * this%eqnsclfac else ctmp = this%xnew(igwfnode) - this%hcof(j) = -qbnd + this%hcof(j) = -qbnd * this%eqnsclfac end if - c1 = qbnd * ctmp + c1 = qbnd * ctmp * this%eqnsclfac this%dbuff(n) = this%dbuff(n) + c1 end do ! @@ -2418,7 +2426,7 @@ subroutine apt_fill_budobj(this, x, flowja) allocate (auxvartmp(1)) do n1 = 1, this%ncv call this%get_volumes(n1, v1, v0, delt) - auxvartmp(1) = v1 * this%xnewpak(n1) + auxvartmp(1) = v1 * this%xnewpak(n1) ! kluge note: does this need a factor of eqnsclfac??? q = this%qsto(n1) call this%budobj%budterm(idx)%update_term(n1, n1, q, auxvartmp) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) @@ -2443,9 +2451,9 @@ subroutine apt_fill_budobj(this, x, flowja) nlist = this%ncv call this%budobj%budterm(idx)%reset(nlist) !! do n1 = 1, nlist -!! q = this%qmfrommvr(n1) +!! q = this%qmfrommvr(n1) ! kluge note: presumably in terms of energy already for heat transport??? do j = 1, nlist - call this%apt_fmvr_term(j, n1, n2, q) + call this%apt_fmvr_term(j, n1, n2, q) ! kluge note: don't really need to do this in apt_fmvr_term now, since no override by uze call this%budobj%budterm(idx)%update_term(n1, n1, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do @@ -2535,8 +2543,10 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & if (present(rrate)) then rrate = (-c1 * v1 / delt + c0 * v0 / delt) * this%eqnsclfac end if - if (present(rhsval)) rhsval = -c0 * v0 / delt - if (present(hcofval)) hcofval = -v1 / delt +!! if (present(rhsval)) rhsval = -c0 * v0 / delt +!! if (present(hcofval)) hcofval = -v1 / delt + if (present(rhsval)) rhsval = -c0 * v0 * this%eqnsclfac / delt + if (present(hcofval)) hcofval = -v1 * this%eqnsclfac / delt ! ! -- return return @@ -2565,7 +2575,8 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ctmp = this%xnewpak(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd +!! if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return @@ -2587,7 +2598,9 @@ subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & ! -- Calculate MVR-related terms n1 = ientry n2 = n1 - if (present(rrate)) rrate = this%qmfrommvr(n1) * this%eqnsclfac +!! if (present(rrate)) rrate = this%qmfrommvr(n1) * this%eqnsclfac + if (present(rrate)) rrate = this%qmfrommvr(n1) ! presumably in terms of energy already for heat transport??? +!! if (present(rhsval)) rhsval = this%qmfrommvr(n1) * this%eqnsclfac if (present(rhsval)) rhsval = this%qmfrommvr(n1) if (present(hcofval)) hcofval = DZERO ! @@ -2620,7 +2633,8 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ctmp = this%xnewpak(n2) end if if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac - if (present(rhsval)) rhsval = -rrate +!! if (present(rhsval)) rhsval = -rrate + if (present(rhsval)) rhsval = -rrate * this%eqnsclfac if (present(hcofval)) hcofval = DZERO ! ! -- return diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/GroundWaterTransport/tsp1cnc1.f90 index 671aa53a6a7..abe2b3ecf0e 100644 --- a/src/Model/GroundWaterTransport/tsp1cnc1.f90 +++ b/src/Model/GroundWaterTransport/tsp1cnc1.f90 @@ -330,7 +330,7 @@ subroutine cnc_cq(this, x, flowja, iadv) ! -- Calculate the flow rate into the cell. do ipos = this%dis%con%ia(node) + 1, & this%dis%con%ia(node + 1) - 1 - q = flowja(ipos) + q = flowja(ipos) ! klughe note: flowja should already be in terms of energy for heat transport rate = rate - q ! -- only accumulate chin and chout for active ! connected cells @@ -380,14 +380,14 @@ subroutine cnc_bd(this, model_budget) integer(I4B) :: isuppress_output ! ------------------------------------------------------------------------------ isuppress_output = 0 - ! - do n = 1, size(this%ratecncin) - this%ratecncin(n) = this%ratecncin(n) * this%eqnsclfac - end do - do n = 1, size(this%ratecncout) - this%ratecncout(n) = this%ratecncout(n) * this%eqnsclfac - end do - ! +!! ! +!! do n = 1, size(this%ratecncin) +!! this%ratecncin(n) = this%ratecncin(n) * this%eqnsclfac +!! end do +!! do n = 1, size(this%ratecncout) +!! this%ratecncout(n) = this%ratecncout(n) * this%eqnsclfac +!! end do +!! ! call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratecncout(1:this%nbound), ratout, dum) call model_budget%addentry(ratin, ratout, delt, this%text, & diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index f5612ef521f..61b91137e1f 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -339,7 +339,7 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ctmp = this%cnew(n) omega = DONE ! lhs if (ctmp < DZERO) then - omega = DZERO ! concentration is negative, so set mass flux to zero + omega = DZERO ! concentration is negative, so set mass flux to zero ! kluge note: think this through for temperature end if end if else @@ -363,9 +363,11 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! ! -- Add terms based on qbnd sign if (qbnd <= DZERO) then - hcoftmp = qbnd * omega +!! hcoftmp = qbnd * omega + hcoftmp = qbnd * omega * this%eqnsclfac else - rhstmp = -qbnd * ctmp * (DONE - omega) +!! rhstmp = -qbnd * ctmp * (DONE - omega) + rhstmp = -qbnd * ctmp * (DONE - omega) * this%eqnsclfac end if ! ! -- end of active ibound @@ -374,7 +376,8 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! -- set requested values if (present(hcofval)) hcofval = hcoftmp if (present(rhsval)) rhsval = rhstmp - if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) * this%eqnsclfac +!! if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) * this%eqnsclfac + if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) if (present(cssm)) cssm = ctmp if (present(qssm)) qssm = qbnd ! diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index e7bc8bd5d69..2abe3b2b829 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -97,7 +97,7 @@ module TransportModelModule contains - subroutine tsp_cr(this, filename, id, modelname) + subroutine tsp_cr(this, filename, id, modelname) ! kluge note: not used/needed ! -- modules use SimModule, only: store_error use MemoryManagerModule, only: mem_allocate @@ -220,7 +220,8 @@ subroutine tsp_cr(this, filename, id, modelname) ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + this%eqnsclfac) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) From bf9a52a465352eeafa6d887b20c35e765c98cd63 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Wed, 12 Apr 2023 15:53:44 -0400 Subject: [PATCH 104/212] * Made what should be all the remaining (at least for now) scale-factor-related updates in heat-transport packages * As noted earlier, thorough testing is needed --- src/Exchange/GweGweExchange.f90 | 1 + src/Exchange/GwtGwtExchange.f90 | 1 + src/Model/Connection/GweInterfaceModel.f90 | 3 +- src/Model/Connection/GwtInterfaceModel.f90 | 3 +- src/Model/GroundWaterEnergy/gwe1.f90 | 6 ++- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 55 ++++++++++++--------- src/Model/GroundWaterTransport/gwt1.f90 | 6 ++- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 20 +++++--- src/Model/GroundWaterTransport/tsp1mvt1.f90 | 13 +++-- src/Model/TransportModel.f90 | 6 ++- 10 files changed, 73 insertions(+), 41 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index dcb445aa9a9..86a1e0a6112 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -945,6 +945,7 @@ subroutine read_mvt(this, iout) ! for gwtmodel1 so that a call to save flows has an associated dis ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwemodel1%fmi, & + this%gwemodel1%eqnsclfac, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & fmi2=this%gwemodel2%fmi) diff --git a/src/Exchange/GwtGwtExchange.f90 b/src/Exchange/GwtGwtExchange.f90 index 0e9dfc8c6f3..5aa7ef313d4 100644 --- a/src/Exchange/GwtGwtExchange.f90 +++ b/src/Exchange/GwtGwtExchange.f90 @@ -945,6 +945,7 @@ subroutine read_mvt(this, iout) ! for gwtmodel1 so that a call to save flows has an associated dis ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwtmodel1%fmi, & + this%gwtmodel1%eqnsclfac, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & fmi2=this%gwtmodel2%fmi) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 27d9082d0f7..18af3c3a17b 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -81,7 +81,8 @@ subroutine gweifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & + this%eqnsclfac) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi, & diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 522f2bbea92..46c76140976 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -81,7 +81,8 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & + this%eqnsclfac) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index dca84995907..8f48e329d45 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -240,7 +240,8 @@ subroutine gwe_cr(filename, id, modelname) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + this%eqnsclfac) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & @@ -249,7 +250,8 @@ subroutine gwe_cr(filename, id, modelname) this%eqnsclfac, this%gwecommon) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, this%gwecommon) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + this%eqnsclfac) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index 3a1ff3c237d..00ffaa57da9 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -96,7 +96,7 @@ module GweLkeModule contains subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab, gwecommon) + fmi, tsplab, eqnsclfac, gwecommon) ! ****************************************************************************** ! mwt_create -- Create a New MWT Package ! ****************************************************************************** @@ -113,6 +113,7 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweLkeType), pointer :: lkeobj @@ -139,8 +140,8 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ncolbnd = 1 packobj%iscloc = 1 - ! -- Store pointer to flow model interface. When the GwfGwt exchange is - ! created, it sets fmi%bndlist so that the GWT model has access to all + ! -- Store pointer to flow model interface. When the GwfGwe exchange is + ! created, it sets fmi%bndlist so that the GWE model has access to all ! the flow packages lkeobj%fmi => fmi ! @@ -148,6 +149,9 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature lkeobj%tsplab => tsplab ! + ! -- Store pointer to governing equation scale factor + lkeobj%eqnsclfac => eqnsclfac + ! ! -- Store pointer to shared data module for accessing cpw, rhow ! for the budget calculations, and for accessing the latent heat of ! vaporization for evaporative cooling. @@ -787,7 +791,7 @@ subroutine lke_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -813,24 +817,29 @@ subroutine lke_evap_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval ! -- local real(DP) :: qbnd - real(DP) :: ctmp - real(DP) :: omega +!! real(DP) :: ctmp +!! real(DP) :: omega + real(DP) :: heatlat ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) - ctmp = this%tempevap(n1) - if (this%xnewpak(n1) < ctmp) then - omega = DONE - else - omega = DZERO - end if - if (present(rrate)) & - rrate = omega * qbnd * this%xnewpak(n1) + & - (DONE - omega) * qbnd * ctmp - if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp - if (present(hcofval)) hcofval = omega * qbnd +!! ctmp = this%tempevap(n1) +!! if (this%xnewpak(n1) < ctmp) then +!! omega = DONE +!! else +!! omega = DZERO +!! end if +!! if (present(rrate)) & +!! rrate = omega * qbnd * this%xnewpak(n1) + & +!! (DONE - omega) * qbnd * ctmp +!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp +!! if (present(hcofval)) hcofval = omega * qbnd + heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 (kluge note) + if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day (kluge note) + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO ! ! -- return return @@ -860,7 +869,7 @@ subroutine lke_roff_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -892,7 +901,7 @@ subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -924,9 +933,9 @@ subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudwdrl)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudwdrl)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return @@ -956,9 +965,9 @@ subroutine lke_outf_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index c34a42210cd..26d7bc7830d 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -238,14 +238,16 @@ subroutine gwt_cr(filename, id, modelname) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + this%eqnsclfac) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + this%eqnsclfac) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index f3fc98aaf2c..b5a97ea6dd9 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -57,7 +57,8 @@ module TspFmiModule integer(I4B), pointer :: iumvr => null() !< unit number GWF mover budget file integer(I4B), pointer :: nflowpack => null() !< number of GWF flow packages integer(I4B), dimension(:), pointer, contiguous :: igwfmvrterm => null() !< flag to indicate that gwf package is a mover term - type(BudgetFileReaderType) :: bfr !< budget file reader + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy + type(BudgetFileReaderType) :: bfr !< budget file reader type(HeadFileReaderType) :: hfr !< head file reader type(PackageBudgetType), dimension(:), allocatable :: gwfpackages !< used to get flows between a package and gwf type(BudgetObjectType), pointer :: mvrbudobj => null() !< pointer to the mover budget budget object @@ -99,7 +100,7 @@ module TspFmiModule contains - subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) + subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) ! ****************************************************************************** ! fmi_cr -- Create a new FMI object ! ****************************************************************************** @@ -112,6 +113,7 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspLabelsType), pointer, intent(in) :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -137,6 +139,9 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) ! -- Give package access to the assigned labels based on dependent variable fmiobj%tsplab => tsplab ! + ! -- Store pointer to governing equation scale factor + fmiobj%eqnsclfac => eqnsclfac + ! ! -- Return return end subroutine fmi_cr @@ -350,6 +355,7 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) real(DP), intent(inout), dimension(nodes) :: rhs ! -- local integer(I4B) :: n, idiag, idiag_sln + real(DP) :: qcorr ! ------------------------------------------------------------------------------ ! ! -- Calculate the flow imbalance error and make a correction for it @@ -360,7 +366,9 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) do n = 1, nodes idiag = this%dis%con%ia(n) idiag_sln = idxglo(idiag) - call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag)) +!! call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag)) + qcorr = -this%gwfflowja(idiag) * this%eqnsclfac + call matrix_sln%add_value_pos(idiag_sln, qcorr) end do end if ! @@ -394,7 +402,7 @@ subroutine fmi_cq(this, cnew, flowja) rate = DZERO idiag = this%dis%con%ia(n) if (this%ibound(n) > 0) then - rate = -this%gwfflowja(idiag) * cnew(n) + rate = -this%gwfflowja(idiag) * cnew(n) * this%eqnsclfac end if this%flowcorrect(n) = rate flowja(idiag) = flowja(idiag) + rate @@ -725,8 +733,8 @@ subroutine set_active_status(this, cnew) flownm = this%gwfflowja(ipos) if (flownm > 0) then if (this%ibound(m) /= 0) then - crewet = crewet + cnew(m) * flownm - tflow = tflow + this%gwfflowja(ipos) + crewet = crewet + cnew(m) * flownm ! kluge note: apparently no need to multiply flows by eqnsclfac + tflow = tflow + this%gwfflowja(ipos) ! since it will divide out below anyway end if end if end do diff --git a/src/Model/GroundWaterTransport/tsp1mvt1.f90 b/src/Model/GroundWaterTransport/tsp1mvt1.f90 index a65b689e4f4..74b7b384d11 100644 --- a/src/Model/GroundWaterTransport/tsp1mvt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1mvt1.f90 @@ -28,6 +28,7 @@ module TspMvtModule integer(I4B), pointer :: maxpackages !< max number of packages integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy type(TspFmiType), pointer :: fmi1 => null() !< pointer to fmi object for model 1 type(TspFmiType), pointer :: fmi2 => null() !< pointer to fmi object for model 2 (set to fmi1 for single model) type(BudgetType), pointer :: budget => null() !< mover transport budget object (used to write balance table) @@ -62,8 +63,8 @@ module TspMvtModule contains - subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & - gwfmodelname2, fmi2) + subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge note: does this need tsplab? + gwfmodelname1, gwfmodelname2, fmi2) ! ****************************************************************************** ! mvt_cr -- Create a new initial conditions object ! ****************************************************************************** @@ -76,6 +77,7 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi1 + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor character(len=*), intent(in), optional :: gwfmodelname1 character(len=*), intent(in), optional :: gwfmodelname2 type(TspFmiType), intent(in), target, optional :: fmi2 @@ -113,6 +115,9 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & ! -- create the budget object call budgetobject_cr(mvt%budobj, 'TRANSPORT MOVER') ! + ! -- Store pointer to governing equation scale factor + mvt%eqnsclfac => eqnsclfac + ! ! -- Return return end subroutine mvt_cr @@ -313,7 +318,7 @@ subroutine mvt_fc(this, cnew1, cnew2) ! water into the same receiver if (fmi_rc%iatp(irc) /= 0) then fmi_rc%datp(irc)%qmfrommvr(id2) = fmi_rc%datp(irc)%qmfrommvr(id2) - & - q * cp + q * cp * this%eqnsclfac end if end do end if @@ -862,7 +867,7 @@ subroutine mvt_fill_budobj(this, cnew1, cnew2) ! -- Calculate solute mover rate rate = DZERO if (fmi_rc%iatp(irc) /= 0) then - rate = -q * cp + rate = -q * cp * this%eqnsclfac end if ! ! -- add the rate to the budterm diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 2abe3b2b829..e9b40a4179c 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -219,12 +219,14 @@ subroutine tsp_cr(this, filename, id, modelname) ! kluge note: not used/needed ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + this%eqnsclfac) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & this%eqnsclfac) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + this%eqnsclfac) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! From 69a4ad5d03920065fac2237ea04b8e9c41f03637 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Thu, 13 Apr 2023 10:45:38 -0400 Subject: [PATCH 105/212] * Programmed streambed conduction terms into formulate and budget in sfe * Thermal conductance is not yet calculated and is temporarily set to zero, so the new terms currently should have no effect on the solution * Compiles and runs, but haven't tried a test that uses sfe --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 79 +++++++++++++++++++-- src/Model/GroundWaterTransport/tsp1apt1.f90 | 4 +- 2 files changed, 75 insertions(+), 8 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 02438740fe2..8b8437c84ef 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -3,22 +3,23 @@ ! -- todo: save the sfe temperature into the sfr aux variable? (perhaps needed for GWT-GWE exchanges) ! -- todo: calculate the sfr VISC aux variable using temperature? ! -! SFR flows (sfrbudptr) index var SFE term Transport Type +! SFR flows (sfrbudptr) index var SFE term Transport Type ! kluge note: "SFE flows", etc? !--------------------------------------------------------------------------------- ! -- terms from SFR that will be handled by parent APT Package ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes -! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) +! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) ! kluge note: include rhow*cpw in comments for various terms ! TO-MVR idxbudtmvr TO-MVR q * tfeat ! -- SFR terms ! RAINFALL idxbudrain RAINFALL q * train -! EVAPORATION idxbudevap EVAPORATION tfeat null() ! index of runoff terms in flowbudptr integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + integer(I4B), pointer :: idxbudsbcd => null() ! index of streambed conduction terms in flowbudptr real(DP), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature real(DP), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature @@ -258,6 +260,9 @@ subroutine find_sfe_package(this) case ('EXT-OUTFLOW') this%idxbudoutf = ip this%idxbudssm(ip) = 0 + case ('STRMBD-COND') + this%idxbudsbcd = ip + this%idxbudssm(ip) = 0 case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 @@ -299,12 +304,14 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B), dimension(:), intent(in) :: idxglo class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: j, n1, n2 + integer(I4B) :: j, n1, n2, n integer(I4B) :: iloc - integer(I4B) :: iposd + integer(I4B) :: iposd, iposoffd + integer(I4B) :: ipossymd, ipossymoffd real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval + real(DP) :: ctherm ! kluge? ! ------------------------------------------------------------------------------ ! ! -- add rainfall contribution @@ -362,13 +369,37 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end do end if ! + ! -- add streambed conduction contribution + do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + ! + ! -- set n to feature number and process if active feature + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + if (this%iboundpak(n) /= 0) then + ! + ! -- set acoef and rhs to negative so they are relative to sfe and not gwe + ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance + ! + ! -- add to sfe row + iposd = this%idxdglo(j) + iposoffd = this%idxoffdglo(j) + call matrix_sln%add_value_pos(iposd, ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposoffd, -ctherm) + ! + ! -- add to gwe row for sfe connection + ipossymd = this%idxsymdglo(j) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymd, -ctherm) + call matrix_sln%add_value_pos(ipossymoffd, ctherm) + end if + end do + ! ! -- Return return end subroutine sfe_fc_expanded !> @ brief Add terms specific to sfr to the explicit sfr solve !< - subroutine sfe_solve(this) + subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/useful if there's streambed conduction??? ! -- dummy class(GweSfeType) :: this ! -- local @@ -417,6 +448,8 @@ subroutine sfe_solve(this) end do end if ! + ! kluge note: explicit streambed conduction terms??? + ! ! -- Return return end subroutine sfe_solve @@ -520,6 +553,19 @@ subroutine sfe_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! + ! -- + text = ' STRMBD-COND' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudsbcd)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! ! -- return return end subroutine sfe_setup_budobj @@ -538,7 +584,9 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- local integer(I4B) :: j, n1, n2 integer(I4B) :: nlist + integer(I4B) :: igwfnode real(DP) :: q + real(DP) :: ctherm ! kluge? ! -- formats ! ----------------------------------------------------------------------------- @@ -592,6 +640,22 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do + ! -- STRMBD-COND + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do j = 1, this%flowbudptr%budterm(this%idxbudsbcd)%nlist + q = DZERO + n1 = this%flowbudptr%budterm(this%idxbudsbcd)%id1(j) + if (this%iboundpak(n1) /= 0) then + igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) + ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct + q = -q ! flip sign so relative to advanced package feature + end if + call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + ! ! -- return return @@ -620,6 +684,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath) call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) + call mem_allocate(this%idxbudsbcd, 'IDXBUDSBCD', this%memoryPath) ! ! -- Initialize this%idxbudrain = 0 @@ -627,6 +692,7 @@ subroutine allocate_scalars(this) this%idxbudroff = 0 this%idxbudiflw = 0 this%idxbudoutf = 0 + this%idxbudsbcd = 0 ! ! -- Return return @@ -681,6 +747,7 @@ subroutine sfe_da(this) call mem_deallocate(this%idxbudroff) call mem_deallocate(this%idxbudiflw) call mem_deallocate(this%idxbudoutf) + call mem_deallocate(this%idxbudsbcd) ! ! -- deallocate time series call mem_deallocate(this%temprain) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 974503c0c44..6407cedd4b3 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -12,12 +12,12 @@ ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes -! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) +! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) ! kluge note: rhow*cpw also applies to various terms for heat transport ! TO-MVR idxbudtmvr TO-MVR q * cfeat ! -- generalized source/sink terms (except ET?) ! RAINFALL idxbudrain RAINFALL q * crain -! EVAPORATION idxbudevap EVAPORATION cfeat Date: Mon, 17 Apr 2023 09:48:10 -0700 Subject: [PATCH 106/212] minor fixes post GWE/develop merge. More fixes needed. --- src/Model/GroundWaterTransport/gwt1.f90 | 345 ++++++++++++------------ src/Model/TransportModel.f90 | 288 ++++++++++++++++++-- 2 files changed, 447 insertions(+), 186 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 17c46314b3f..c3d1d494377 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -58,7 +58,7 @@ module GwtModule procedure :: model_da => gwt_da procedure :: model_bdentry => gwt_bdentry - procedure :: allocate_scalars + procedure :: allocate_gwt_scalars procedure, private :: package_create !procedure, private :: ftype_check procedure :: get_iasym => gwt_get_iasym @@ -67,10 +67,10 @@ module GwtModule procedure, private :: gwt_ot_dv procedure, private :: gwt_ot_bdsummary procedure, private :: gwt_ot_obs - procedure, private :: create_packages + procedure, private :: create_gwt_specific_packages procedure, private :: create_bndpkgs - procedure, private :: create_lstfile - procedure, private :: log_namfile_options + !procedure, private :: create_lstfile + !procedure, private :: log_namfile_options end type GwtModelType ! -- Module variables constant for simulation @@ -101,20 +101,20 @@ subroutine gwt_cr(filename, id, modelname) use SimVariablesModule, only: idm_context use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr - use TspLabelsModule, only: tsplabels_cr + !use TspLabelsModule, only: tsplabels_cr !use SimModule, only: store_error, count_errors !use NameFileModule, only: NameFileType !use CompilerVersion - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use TspIcModule, only: ic_cr - use TspFmiModule, only: fmi_cr - use TspAdvModule, only: adv_cr - use TspSsmModule, only: ssm_cr - use TspMvtModule, only: mvt_cr - use TspOcModule, only: oc_cr - use TspObsModule, only: tsp_obs_cr + !use GwfDisModule, only: dis_cr + !use GwfDisvModule, only: disv_cr + !use GwfDisuModule, only: disu_cr + !use TspIcModule, only: ic_cr + !use TspFmiModule, only: fmi_cr + !use TspAdvModule, only: adv_cr + !use TspSsmModule, only: ssm_cr + !use TspMvtModule, only: mvt_cr + !use TspOcModule, only: oc_cr + !use TspObsModule, only: tsp_obs_cr use GwtMstModule, only: mst_cr use GwtDspModule, only: dsp_cr ! -- dummy @@ -122,7 +122,7 @@ subroutine gwt_cr(filename, id, modelname) integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local - integer(I4B) :: indis, indis6, indisu6, indisv6 + integer(I4B) :: indis !, indis6, indisu6, indisv6 integer(I4B) :: ipakid, i, j, iu, ipaknum character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname @@ -142,48 +142,52 @@ subroutine gwt_cr(filename, id, modelname) ! -- Set memory path before allocation in memory manager can be done this%memoryPath = create_mem_path(modelname) ! - call this%allocate_scalars(modelname) + call this%allocate_tsp_scalars(modelname) + call this%allocate_gwt_scalars(modelname) model => this call AddBaseModelToList(basemodellist, model) ! ! -- Assign values - this%filename = filename - this%name = modelname - this%macronym = 'GWT' - this%id = id + !this%filename = filename + !this%name = modelname + !this%macronym = 'GWT' + !this%id = id + ! + ! -- Call parent class routine + call this%tsp_cr(filename, id, modelname, 'GWT', indis) ! ! -- set input model namfile memory path - input_mempath = create_mem_path(modelname, 'NAM', idm_context) + !input_mempath = create_mem_path(modelname, 'NAM', idm_context) ! ! -- copy option params from input context - call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) - call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & - found%print_input) - call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & - found%print_flows) - call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) + !call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) + !call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & + ! found%print_input) + !call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & + ! found%print_flows) + !call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) ! ! -- create the list file - call this%create_lstfile(lst_fname, filename, found%list) + !call this%create_lstfile(lst_fname, filename, found%list) ! ! -- activate save_flows if found - if (found%save_flows) then - this%ipakcb = -1 - end if + !if (found%save_flows) then + ! this%ipakcb = -1 + !end if ! ! -- Instantiate generalized labels - call tsplabels_cr(this%tsplab, this%name) + !call tsplabels_cr(this%tsplab, this%name) ! ! -- log set options - if (this%iout > 0) then - call this%log_namfile_options(found) - end if + !if (this%iout > 0) then + ! call this%log_namfile_options(found) + !end if ! ! -- Create utility objects - call budget_cr(this%budget, this%name, this%tsplab) + !call budget_cr(this%budget, this%name, this%tsplab) ! ! -- create model packages - call this%create_packages() + call this%create_gwt_specific_packages(indis) ! ! -- return return @@ -1017,7 +1021,7 @@ function gwt_get_iasym(this) result(iasym) return end function gwt_get_iasym - subroutine allocate_scalars(this, modelname) + subroutine allocate_gwt_scalars(this, modelname) ! ****************************************************************************** ! allocate_scalars -- Allocate memory for non-allocatable members ! ****************************************************************************** @@ -1032,9 +1036,9 @@ subroutine allocate_scalars(this, modelname) ! ------------------------------------------------------------------------------ ! ! -- allocate members from parent class - call this%NumericalModelType%allocate_scalars(modelname) + !call this%NumericalModelType%allocate_scalars(modelname) ! - ! -- allocate members that are part of model class + ! -- allocate additional members specific to GWT model type !call mem_allocate(this%inic, 'INIC', this%memoryPath) !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) @@ -1057,7 +1061,7 @@ subroutine allocate_scalars(this, modelname) ! ! -- return return - end subroutine allocate_scalars + end subroutine allocate_gwt_scalars subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) @@ -1281,7 +1285,7 @@ end subroutine create_bndpkgs !> @brief Source package info and begin to process !< - subroutine create_packages(this) + subroutine create_gwt_specific_packages(this, indis) ! -- modules use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CharacterStringModule, only: CharacterStringType @@ -1289,20 +1293,21 @@ subroutine create_packages(this) use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use TspIcModule, only: ic_cr - use TspFmiModule, only: fmi_cr + !use GwfDisModule, only: dis_cr + !use GwfDisvModule, only: disv_cr + !use GwfDisuModule, only: disu_cr + !use TspIcModule, only: ic_cr + !use TspFmiModule, only: fmi_cr use GwtMstModule, only: mst_cr - use TspAdvModule, only: adv_cr + !use TspAdvModule, only: adv_cr use GwtDspModule, only: dsp_cr - use TspSsmModule, only: ssm_cr - use TspMvtModule, only: mvt_cr - use TspOcModule, only: oc_cr - use TspObsModule, only: tsp_obs_cr + !use TspSsmModule, only: ssm_cr + !use TspMvtModule, only: mvt_cr + !use TspOcModule, only: oc_cr + !use TspObsModule, only: tsp_obs_cr ! -- dummy class(GwtModelType) :: this + integer(I4B), intent(in) :: indis ! -- local type(CharacterStringType), dimension(:), contiguous, & pointer :: pkgtypes => null() @@ -1319,7 +1324,7 @@ subroutine create_packages(this) integer(I4B), pointer :: inunit integer(I4B), dimension(:), allocatable :: bndpkgs integer(I4B) :: n - integer(I4B) :: indis = 0 ! DIS enabled flag + !integer(I4B) :: indis = 0 ! DIS enabled flag character(len=LENMEMPATH) :: mempathdsp = '' ! ! -- set input memory paths, input/model and input/model/namfile @@ -1341,34 +1346,34 @@ subroutine create_packages(this) ! ! -- create dis package as it is a prerequisite for other packages select case (pkgtype) - case ('DIS6') - indis = 1 - call dis_cr(this%dis, this%name, mempath, indis, this%iout) - case ('DISV6') - indis = 1 - call disv_cr(this%dis, this%name, mempath, indis, this%iout) - case ('DISU6') - indis = 1 - call disu_cr(this%dis, this%name, mempath, indis, this%iout) - case ('IC6') - this%inic = inunit - case ('FMI6') - this%infmi = inunit - case ('MVT6') - this%inmvt = inunit + !case ('DIS6') + ! indis = 1 + ! call dis_cr(this%dis, this%name, mempath, indis, this%iout) + !case ('DISV6') + ! indis = 1 + ! call disv_cr(this%dis, this%name, mempath, indis, this%iout) + !case ('DISU6') + ! indis = 1 + ! call disu_cr(this%dis, this%name, mempath, indis, this%iout) + !case ('IC6') + ! this%inic = inunit + !case ('FMI6') + ! this%infmi = inunit + !case ('MVT6') + ! this%inmvt = inunit case ('MST6') this%inmst = inunit - case ('ADV6') - this%inadv = inunit + !case ('ADV6') + ! this%inadv = inunit case ('DSP6') this%indsp = 1 mempathdsp = mempath - case ('SSM6') - this%inssm = inunit - case ('OC6') - this%inoc = inunit - case ('OBS6') - this%inobs = inunit + !case ('SSM6') + ! this%inssm = inunit + !case ('OC6') + ! this%inoc = inunit + !case ('OBS6') + ! this%inobs = inunit case ('CNC6', 'SRC6', 'LKT6', 'SFT6', & 'MWT6', 'UZT6', 'IST6', 'API6') call expandarray(bndpkgs) @@ -1379,106 +1384,106 @@ subroutine create_packages(this) end do ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + !call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + !call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, this%eqnsclfac) + !call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, this%eqnsclfac) call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) - call oc_cr(this%oc, this%name, this%inoc, this%iout) - call tsp_obs_cr(this%obs, this%inobs) + !call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) + !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + !call oc_cr(this%oc, this%name, this%inoc, this%iout) + !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified call this%ftype_check(indis) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) - end subroutine create_packages - - subroutine create_lstfile(this, lst_fname, model_fname, defined) - ! -- modules - use KindModule, only: LGP - use InputOutputModule, only: openfile, getunit - ! -- dummy - class(GwtModelType) :: this - character(len=*), intent(inout) :: lst_fname - character(len=*), intent(in) :: model_fname - logical(LGP), intent(in) :: defined - ! -- local - integer(I4B) :: i, istart, istop - ! - ! -- set list file name if not provided - if (.not. defined) then - ! - ! -- initialize - lst_fname = ' ' - istart = 0 - istop = len_trim(model_fname) - ! - ! -- identify '.' character position from back of string - do i = istop, 1, -1 - if (model_fname(i:i) == '.') then - istart = i - exit - end if - end do - ! - ! -- if not found start from string end - if (istart == 0) istart = istop + 1 - ! - ! -- set list file name - lst_fname = model_fname(1:istart) - istop = istart + 3 - lst_fname(istart:istop) = '.lst' - end if - ! - ! -- create the list file - this%iout = getunit() - call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') - ! - ! -- write list file header - call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') - ! - ! -- return - return - end subroutine create_lstfile - - !> @brief Write model namfile options to list file - !< - subroutine log_namfile_options(this, found) - use GwfNamInputModule, only: GwfNamParamFoundType - class(GwtModelType) :: this - type(GwfNamParamFoundType), intent(in) :: found - - write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' - - if (found%newton) then - write (this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method enabled for the model.' - if (found%under_relaxation) then - write (this%iout, '(4x,a,a)') & - 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & - 'elevation of the model will be applied to the model.' - end if - end if - - if (found%print_input) then - write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - 'FOR ALL MODEL STRESS PACKAGES' - end if - - if (found%print_flows) then - write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - 'FOR ALL MODEL PACKAGES' - end if - - if (found%save_flows) then - write (this%iout, '(4x,a)') & - 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - end if - - write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' - end subroutine log_namfile_options + end subroutine create_gwt_specific_packages + + !subroutine create_lstfile(this, lst_fname, model_fname, defined) + ! ! -- modules + ! use KindModule, only: LGP + ! use InputOutputModule, only: openfile, getunit + ! ! -- dummy + ! class(GwtModelType) :: this + ! character(len=*), intent(inout) :: lst_fname + ! character(len=*), intent(in) :: model_fname + ! logical(LGP), intent(in) :: defined + ! ! -- local + ! integer(I4B) :: i, istart, istop + ! ! + ! ! -- set list file name if not provided + ! if (.not. defined) then + ! ! + ! ! -- initialize + ! lst_fname = ' ' + ! istart = 0 + ! istop = len_trim(model_fname) + ! ! + ! ! -- identify '.' character position from back of string + ! do i = istop, 1, -1 + ! if (model_fname(i:i) == '.') then + ! istart = i + ! exit + ! end if + ! end do + ! ! + ! ! -- if not found start from string end + ! if (istart == 0) istart = istop + 1 + ! ! + ! ! -- set list file name + ! lst_fname = model_fname(1:istart) + ! istop = istart + 3 + ! lst_fname(istart:istop) = '.lst' + ! end if + ! ! + ! ! -- create the list file + ! this%iout = getunit() + ! call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') + ! ! + ! ! -- write list file header + ! call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') + ! ! + ! ! -- return + ! return + !end subroutine create_lstfile + + !!> @brief Write model namfile options to list file + !!< + !subroutine log_namfile_options(this, found) + ! use GwfNamInputModule, only: GwfNamParamFoundType + ! class(GwtModelType) :: this + ! type(GwfNamParamFoundType), intent(in) :: found + ! + ! write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + ! + ! if (found%newton) then + ! write (this%iout, '(4x,a)') & + ! 'NEWTON-RAPHSON method enabled for the model.' + ! if (found%under_relaxation) then + ! write (this%iout, '(4x,a,a)') & + ! 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & + ! 'elevation of the model will be applied to the model.' + ! end if + ! end if + ! + ! if (found%print_input) then + ! write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + ! 'FOR ALL MODEL STRESS PACKAGES' + ! end if + ! + ! if (found%print_flows) then + ! write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + ! 'FOR ALL MODEL PACKAGES' + ! end if + ! + ! if (found%save_flows) then + ! write (this%iout, '(4x,a)') & + ! 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + ! end if + ! + ! write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' + !end subroutine log_namfile_options end module GwtModule diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 338a0a3f59b..8ff406c88f0 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -11,7 +11,7 @@ module TransportModelModule use KindModule, only: DP, I4B use InputOutputModule, only: ParseLine use VersionModule, only: write_listfile_header - use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC + use ConstantsModule, only: LENFTYPE, DZERO, LENPAKLOC, LENMEMPATH use SimVariablesModule, only: errmsg use NumericalModelModule, only: NumericalModelType use NumericalPackageModule, only: NumericalPackageType @@ -62,7 +62,7 @@ module TransportModelModule contains ! -- public - procedure :: allocate_scalars + procedure :: allocate_tsp_scalars procedure, public :: ftype_check procedure, public :: tsp_cr procedure, public :: tsp_df @@ -82,6 +82,9 @@ module TransportModelModule procedure, private :: tsp_ot_flowja procedure, private :: tsp_ot_dv procedure, private :: tsp_ot_bdsummary + procedure, private :: create_lstfile + procedure, private :: create_packages + procedure, private :: log_namfile_options end type TransportModelType @@ -97,11 +100,15 @@ module TransportModelModule contains - subroutine tsp_cr(this, filename, id, modelname) ! kluge note: not used/needed + subroutine tsp_cr(this, filename, id, modelname, macronym, indis) ! kluge note: not used/needed ! -- modules use SimModule, only: store_error use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path + use MemoryManagerExtModule, only: mem_set_value + use SimVariablesModule, only: idm_context + use GwfNamInputModule, only: GwfNamParamFoundType + use TspLabelsModule, only: tsplabels_cr use GwfDisModule, only: dis_cr use GwfDisvModule, only: disv_cr use GwfDisuModule, only: disu_cr @@ -120,21 +127,63 @@ subroutine tsp_cr(this, filename, id, modelname) ! kluge note: not used/needed class(TransportModelType) :: this character(len=*), intent(in) :: filename integer(I4B), intent(in) :: id + integer(I4B), intent(inout) :: indis character(len=*), intent(in) :: modelname + character(len=*), intent(in) :: macronym ! -- local class(*), pointer :: mstobjPtr !type(NameFileType) :: namefile_obj - integer(I4B) :: indis, indis6, indisu6, indisv6 + !integer(I4B) :: indis, indis6, indisu6, indisv6 character(len=LINELENGTH) :: errmsg + character(len=LENMEMPATH) :: input_mempath integer(I4B) :: nwords integer(I4B) :: i character(len=LINELENGTH), allocatable, dimension(:) :: words + character(len=LINELENGTH) :: lst_fname + type(GwfNamParamFoundType) :: found ! ------------------------------------------------------------------------------ + ! + ! -- Set memory path before allocation in memory manager can be done + !this%memoryPath = create_mem_path(modelname) ! ! -- Assign values this%filename = filename this%name = modelname this%id = id + this%macronym = macronym + ! + ! -- set input model namfile memory path + input_mempath = create_mem_path(modelname, 'NAM', idm_context) + ! + ! -- copy option params from input context + call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) + call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & + found%print_input) + call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & + found%print_flows) + call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) + ! + ! -- create the list file + call this%create_lstfile(lst_fname, filename, found%list) + ! + ! -- activate save_flows if found + if (found%save_flows) then + this%ipakcb = -1 + end if + ! + ! -- Instantiate generalized labels + call tsplabels_cr(this%tsplab, this%name) + ! + ! -- log set options + if (this%iout > 0) then + call this%log_namfile_options(found) + end if + ! + ! -- Create utility objects + call budget_cr(this%budget, this%name, this%tsplab) + ! + ! -- create model packages + call this%create_packages(indis) ! ! -- Open namefile and set iout !call namefile_obj%init(this%filename, 0) @@ -215,18 +264,18 @@ subroutine tsp_cr(this, filename, id, modelname) ! kluge note: not used/needed !end if ! ! -- Create utility objects - call budget_cr(this%budget, this%name, this%tsplab) + !call budget_cr(this%budget, this%name, this%tsplab) ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & - this%eqnsclfac) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & - this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) - call oc_cr(this%oc, this%name, this%inoc, this%iout) - call tsp_obs_cr(this%obs, this%inobs) + !call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + !call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + !call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + ! this%eqnsclfac) + !call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + ! this%tsplab, this%eqnsclfac) + !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + !call oc_cr(this%oc, this%name, this%inoc, this%iout) + !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Return return @@ -658,7 +707,7 @@ subroutine tsp_ot_bdsummary(this, ibudfl, ipflag) end subroutine tsp_ot_bdsummary - subroutine allocate_scalars(this, modelname) + subroutine allocate_tsp_scalars(this, modelname) ! ****************************************************************************** ! allocate_scalars -- Allocate memory for non-allocatable members ! ****************************************************************************** @@ -696,7 +745,7 @@ subroutine allocate_scalars(this, modelname) ! ! -- return return - end subroutine allocate_scalars + end subroutine allocate_tsp_scalars subroutine tsp_da(this) ! ****************************************************************************** @@ -771,6 +820,213 @@ subroutine ftype_check(this, indis) ! -- return return end subroutine ftype_check + + subroutine create_lstfile(this, lst_fname, model_fname, defined) + ! -- modules + use KindModule, only: LGP + use InputOutputModule, only: openfile, getunit + ! -- dummy + class(TransportModelType) :: this + character(len=*), intent(inout) :: lst_fname + character(len=*), intent(in) :: model_fname + logical(LGP), intent(in) :: defined + ! -- local + integer(I4B) :: i, istart, istop + ! + ! -- set list file name if not provided + if (.not. defined) then + ! + ! -- initialize + lst_fname = ' ' + istart = 0 + istop = len_trim(model_fname) + ! + ! -- identify '.' character position from back of string + do i = istop, 1, -1 + if (model_fname(i:i) == '.') then + istart = i + exit + end if + end do + ! + ! -- if not found start from string end + if (istart == 0) istart = istop + 1 + ! + ! -- set list file name + lst_fname = model_fname(1:istart) + istop = istart + 3 + lst_fname(istart:istop) = '.lst' + end if + ! + ! -- create the list file + this%iout = getunit() + call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') + ! + ! -- write list file header + call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') + ! + ! -- return + return + end subroutine create_lstfile + + !> @brief Write model namfile options to list file + !< + subroutine log_namfile_options(this, found) + use GwfNamInputModule, only: GwfNamParamFoundType + class(TransportModelType) :: this + type(GwfNamParamFoundType), intent(in) :: found + write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' + + if (found%newton) then + write (this%iout, '(4x,a)') & + 'NEWTON-RAPHSON method enabled for the model.' + if (found%under_relaxation) then + write (this%iout, '(4x,a,a)') & + 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & + 'elevation of the model will be applied to the model.' + end if + end if + + if (found%print_input) then + write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & + 'FOR ALL MODEL STRESS PACKAGES' + end if + + if (found%print_flows) then + write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & + 'FOR ALL MODEL PACKAGES' + end if + + if (found%save_flows) then + write (this%iout, '(4x,a)') & + 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' + end if + + write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' + end subroutine log_namfile_options + + !> @brief Source package info and begin to process + !< + subroutine create_packages(this, indis) + ! -- modules + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME + use CharacterStringModule, only: CharacterStringType + use ArrayHandlersModule, only: expandarray + use MemoryManagerModule, only: mem_setptr + use MemoryHelperModule, only: create_mem_path + use SimVariablesModule, only: idm_context + use GwfDisModule, only: dis_cr + use GwfDisvModule, only: disv_cr + use GwfDisuModule, only: disu_cr + use TspIcModule, only: ic_cr + use TspFmiModule, only: fmi_cr + !use GwtMstModule, only: mst_cr + use TspAdvModule, only: adv_cr + !use GwtDspModule, only: dsp_cr + use TspSsmModule, only: ssm_cr + use TspMvtModule, only: mvt_cr + use TspOcModule, only: oc_cr + use TspObsModule, only: tsp_obs_cr + ! -- dummy + class(TransportModelType) :: this + integer(I4B), intent(inout) :: indis ! DIS enabled flag + ! -- local + type(CharacterStringType), dimension(:), contiguous, & + pointer :: pkgtypes => null() + type(CharacterStringType), dimension(:), contiguous, & + pointer :: pkgnames => null() + type(CharacterStringType), dimension(:), contiguous, & + pointer :: mempaths => null() + integer(I4B), dimension(:), contiguous, & + pointer :: inunits => null() + character(len=LENMEMPATH) :: model_mempath + character(len=LENFTYPE) :: pkgtype + character(len=LENPACKAGENAME) :: pkgname + character(len=LENMEMPATH) :: mempath + integer(I4B), pointer :: inunit + integer(I4B), dimension(:), allocatable :: bndpkgs + integer(I4B) :: n + character(len=LENMEMPATH) :: mempathdsp = '' + ! + ! -- Initialize + indis = 0 + ! + ! -- set input memory paths, input/model and input/model/namfile + model_mempath = create_mem_path(component=this%name, context=idm_context) + ! + ! -- set pointers to model path package info + call mem_setptr(pkgtypes, 'PKGTYPES', model_mempath) + call mem_setptr(pkgnames, 'PKGNAMES', model_mempath) + call mem_setptr(mempaths, 'MEMPATHS', model_mempath) + call mem_setptr(inunits, 'INUNITS', model_mempath) + ! + do n = 1, size(pkgtypes) + ! + ! attributes for this input package + pkgtype = pkgtypes(n) + pkgname = pkgnames(n) + mempath = mempaths(n) + inunit => inunits(n) + ! + ! -- create dis package as it is a prerequisite for other packages + select case (pkgtype) + case ('DIS6') + indis = 1 + call dis_cr(this%dis, this%name, mempath, indis, this%iout) + case ('DISV6') + indis = 1 + call disv_cr(this%dis, this%name, mempath, indis, this%iout) + case ('DISU6') + indis = 1 + call disu_cr(this%dis, this%name, mempath, indis, this%iout) + case ('IC6') + this%inic = inunit + case ('FMI6') + this%infmi = inunit + case ('MVT6') + this%inmvt = inunit + !case ('MST6') + ! this%inmst = inunit + case ('ADV6') + this%inadv = inunit + !case ('DSP6') + ! this%indsp = 1 + ! mempathdsp = mempath + case ('SSM6') + this%inssm = inunit + case ('OC6') + this%inoc = inunit + case ('OBS6') + this%inobs = inunit + !case ('CNC6', 'SRC6', 'LKT6', 'SFT6', & + ! 'MWT6', 'UZT6', 'IST6', 'API6') + ! call expandarray(bndpkgs) + ! bndpkgs(size(bndpkgs)) = n + !case default + ! TODO + end select + end do + ! + ! -- Create packages that are tied directly to model + call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + !call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, this%eqnsclfac) + !call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, this%fmi) + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call oc_cr(this%oc, this%name, this%inoc, this%iout) + call tsp_obs_cr(this%obs, this%inobs) + ! + ! -- Check to make sure that required ftype's have been specified + !call this%ftype_check(indis) + ! + !call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) + ! + ! -- return + return + end subroutine create_packages + end module TransportModelModule From 93408b4af95bf6214cf992e1808bd642a570cbda Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Mon, 17 Apr 2023 12:50:06 -0400 Subject: [PATCH 107/212] Revert "* Programmed streambed conduction terms into formulate and budget in sfe" This reverts commit 69a4ad5d03920065fac2237ea04b8e9c41f03637. --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 79 ++------------------- src/Model/GroundWaterTransport/tsp1apt1.f90 | 4 +- 2 files changed, 8 insertions(+), 75 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 8b8437c84ef..02438740fe2 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -3,23 +3,22 @@ ! -- todo: save the sfe temperature into the sfr aux variable? (perhaps needed for GWT-GWE exchanges) ! -- todo: calculate the sfr VISC aux variable using temperature? ! -! SFR flows (sfrbudptr) index var SFE term Transport Type ! kluge note: "SFE flows", etc? +! SFR flows (sfrbudptr) index var SFE term Transport Type !--------------------------------------------------------------------------------- ! -- terms from SFR that will be handled by parent APT Package ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes -! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) ! kluge note: include rhow*cpw in comments for various terms +! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) ! TO-MVR idxbudtmvr TO-MVR q * tfeat ! -- SFR terms ! RAINFALL idxbudrain RAINFALL q * train -! EVAPORATION idxbudevap EVAPORATION tfeat null() ! index of runoff terms in flowbudptr integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr - integer(I4B), pointer :: idxbudsbcd => null() ! index of streambed conduction terms in flowbudptr real(DP), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature real(DP), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature @@ -260,9 +258,6 @@ subroutine find_sfe_package(this) case ('EXT-OUTFLOW') this%idxbudoutf = ip this%idxbudssm(ip) = 0 - case ('STRMBD-COND') - this%idxbudsbcd = ip - this%idxbudssm(ip) = 0 case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 @@ -304,14 +299,12 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B), dimension(:), intent(in) :: idxglo class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: j, n1, n2, n + integer(I4B) :: j, n1, n2 integer(I4B) :: iloc - integer(I4B) :: iposd, iposoffd - integer(I4B) :: ipossymd, ipossymoffd + integer(I4B) :: iposd real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval - real(DP) :: ctherm ! kluge? ! ------------------------------------------------------------------------------ ! ! -- add rainfall contribution @@ -369,37 +362,13 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end do end if ! - ! -- add streambed conduction contribution - do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - ! - ! -- set n to feature number and process if active feature - n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) - if (this%iboundpak(n) /= 0) then - ! - ! -- set acoef and rhs to negative so they are relative to sfe and not gwe - ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance - ! - ! -- add to sfe row - iposd = this%idxdglo(j) - iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, ctherm) ! kluge note: make sure the signs on ctherm are correct here and below - call matrix_sln%add_value_pos(iposoffd, -ctherm) - ! - ! -- add to gwe row for sfe connection - ipossymd = this%idxsymdglo(j) - ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, -ctherm) - call matrix_sln%add_value_pos(ipossymoffd, ctherm) - end if - end do - ! ! -- Return return end subroutine sfe_fc_expanded !> @ brief Add terms specific to sfr to the explicit sfr solve !< - subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/useful if there's streambed conduction??? + subroutine sfe_solve(this) ! -- dummy class(GweSfeType) :: this ! -- local @@ -448,8 +417,6 @@ subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/ end do end if ! - ! kluge note: explicit streambed conduction terms??? - ! ! -- Return return end subroutine sfe_solve @@ -553,19 +520,6 @@ subroutine sfe_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- - text = ' STRMBD-COND' - idx = idx + 1 - maxlist = this%flowbudptr%budterm(this%idxbudsbcd)%maxlist - naux = 0 - call this%budobj%budterm(idx)%initialize(text, & - this%name_model, & - this%packName, & - this%name_model, & - this%packName, & - maxlist, .false., .false., & - naux) - ! ! -- return return end subroutine sfe_setup_budobj @@ -584,9 +538,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- local integer(I4B) :: j, n1, n2 integer(I4B) :: nlist - integer(I4B) :: igwfnode real(DP) :: q - real(DP) :: ctherm ! kluge? ! -- formats ! ----------------------------------------------------------------------------- @@ -640,22 +592,6 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! -- STRMBD-COND - idx = idx + 1 - call this%budobj%budterm(idx)%reset(this%maxbound) - do j = 1, this%flowbudptr%budterm(this%idxbudsbcd)%nlist - q = DZERO - n1 = this%flowbudptr%budterm(this%idxbudsbcd)%id1(j) - if (this%iboundpak(n1) /= 0) then - igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) - ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance - q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct - q = -q ! flip sign so relative to advanced package feature - end if - call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) - call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) - end do - ! ! -- return return @@ -684,7 +620,6 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath) call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) - call mem_allocate(this%idxbudsbcd, 'IDXBUDSBCD', this%memoryPath) ! ! -- Initialize this%idxbudrain = 0 @@ -692,7 +627,6 @@ subroutine allocate_scalars(this) this%idxbudroff = 0 this%idxbudiflw = 0 this%idxbudoutf = 0 - this%idxbudsbcd = 0 ! ! -- Return return @@ -747,7 +681,6 @@ subroutine sfe_da(this) call mem_deallocate(this%idxbudroff) call mem_deallocate(this%idxbudiflw) call mem_deallocate(this%idxbudoutf) - call mem_deallocate(this%idxbudsbcd) ! ! -- deallocate time series call mem_deallocate(this%temprain) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 6407cedd4b3..974503c0c44 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -12,12 +12,12 @@ ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes -! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) ! kluge note: rhow*cpw also applies to various terms for heat transport +! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) ! TO-MVR idxbudtmvr TO-MVR q * cfeat ! -- generalized source/sink terms (except ET?) ! RAINFALL idxbudrain RAINFALL q * crain -! EVAPORATION idxbudevap EVAPORATION cfeat Date: Mon, 17 Apr 2023 12:51:12 -0400 Subject: [PATCH 108/212] Revert "* Made what should be all the remaining (at least for now) scale-factor-related updates in heat-transport packages" This reverts commit bf9a52a465352eeafa6d887b20c35e765c98cd63. --- src/Exchange/GweGweExchange.f90 | 1 - src/Exchange/GwtGwtExchange.f90 | 1 - src/Model/Connection/GweInterfaceModel.f90 | 3 +- src/Model/Connection/GwtInterfaceModel.f90 | 3 +- src/Model/GroundWaterEnergy/gwe1.f90 | 6 +-- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 55 +++++++++------------ src/Model/GroundWaterTransport/gwt1.f90 | 6 +-- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 20 +++----- src/Model/GroundWaterTransport/tsp1mvt1.f90 | 13 ++--- src/Model/TransportModel.f90 | 6 +-- 10 files changed, 41 insertions(+), 73 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index 86a1e0a6112..dcb445aa9a9 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -945,7 +945,6 @@ subroutine read_mvt(this, iout) ! for gwtmodel1 so that a call to save flows has an associated dis ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwemodel1%fmi, & - this%gwemodel1%eqnsclfac, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & fmi2=this%gwemodel2%fmi) diff --git a/src/Exchange/GwtGwtExchange.f90 b/src/Exchange/GwtGwtExchange.f90 index 5aa7ef313d4..0e9dfc8c6f3 100644 --- a/src/Exchange/GwtGwtExchange.f90 +++ b/src/Exchange/GwtGwtExchange.f90 @@ -945,7 +945,6 @@ subroutine read_mvt(this, iout) ! for gwtmodel1 so that a call to save flows has an associated dis ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwtmodel1%fmi, & - this%gwtmodel1%eqnsclfac, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & fmi2=this%gwtmodel2%fmi) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 18af3c3a17b..27d9082d0f7 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -81,8 +81,7 @@ subroutine gweifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & - this%eqnsclfac) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi, & diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 46c76140976..522f2bbea92 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -81,8 +81,7 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & - this%eqnsclfac) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, -dsp_unit, this%iout, this%fmi) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 8f48e329d45..dca84995907 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -240,8 +240,7 @@ subroutine gwe_cr(filename, id, modelname) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & - this%eqnsclfac) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & @@ -250,8 +249,7 @@ subroutine gwe_cr(filename, id, modelname) this%eqnsclfac, this%gwecommon) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, this%gwecommon) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & - this%eqnsclfac) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index 00ffaa57da9..3a1ff3c237d 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -96,7 +96,7 @@ module GweLkeModule contains subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab, eqnsclfac, gwecommon) + fmi, tsplab, gwecommon) ! ****************************************************************************** ! mwt_create -- Create a New MWT Package ! ****************************************************************************** @@ -113,7 +113,6 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab - real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweLkeType), pointer :: lkeobj @@ -140,8 +139,8 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ncolbnd = 1 packobj%iscloc = 1 - ! -- Store pointer to flow model interface. When the GwfGwe exchange is - ! created, it sets fmi%bndlist so that the GWE model has access to all + ! -- Store pointer to flow model interface. When the GwfGwt exchange is + ! created, it sets fmi%bndlist so that the GWT model has access to all ! the flow packages lkeobj%fmi => fmi ! @@ -149,9 +148,6 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature lkeobj%tsplab => tsplab ! - ! -- Store pointer to governing equation scale factor - lkeobj%eqnsclfac => eqnsclfac - ! ! -- Store pointer to shared data module for accessing cpw, rhow ! for the budget calculations, and for accessing the latent heat of ! vaporization for evaporative cooling. @@ -791,7 +787,7 @@ subroutine lke_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -817,29 +813,24 @@ subroutine lke_evap_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval ! -- local real(DP) :: qbnd -!! real(DP) :: ctmp -!! real(DP) :: omega - real(DP) :: heatlat + real(DP) :: ctmp + real(DP) :: omega ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) -!! ctmp = this%tempevap(n1) -!! if (this%xnewpak(n1) < ctmp) then -!! omega = DONE -!! else -!! omega = DZERO -!! end if -!! if (present(rrate)) & -!! rrate = omega * qbnd * this%xnewpak(n1) + & -!! (DONE - omega) * qbnd * ctmp -!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp -!! if (present(hcofval)) hcofval = omega * qbnd - heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 (kluge note) - if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day (kluge note) - if (present(rhsval)) rhsval = -rrate - if (present(hcofval)) hcofval = DZERO + ctmp = this%tempevap(n1) + if (this%xnewpak(n1) < ctmp) then + omega = DONE + else + omega = DZERO + end if + if (present(rrate)) & + rrate = omega * qbnd * this%xnewpak(n1) + & + (DONE - omega) * qbnd * ctmp + if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp + if (present(hcofval)) hcofval = omega * qbnd ! ! -- return return @@ -869,7 +860,7 @@ subroutine lke_roff_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -901,7 +892,7 @@ subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -933,9 +924,9 @@ subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudwdrl)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudwdrl)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd * this%eqnsclfac + if (present(hcofval)) hcofval = qbnd ! ! -- return return @@ -965,9 +956,9 @@ subroutine lke_outf_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac + if (present(rrate)) rrate = ctmp * qbnd if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd * this%eqnsclfac + if (present(hcofval)) hcofval = qbnd ! ! -- return return diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 26d7bc7830d..c34a42210cd 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -238,16 +238,14 @@ subroutine gwt_cr(filename, id, modelname) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & - this%eqnsclfac) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & - this%eqnsclfac) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index b5a97ea6dd9..f3fc98aaf2c 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -57,8 +57,7 @@ module TspFmiModule integer(I4B), pointer :: iumvr => null() !< unit number GWF mover budget file integer(I4B), pointer :: nflowpack => null() !< number of GWF flow packages integer(I4B), dimension(:), pointer, contiguous :: igwfmvrterm => null() !< flag to indicate that gwf package is a mover term - real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy - type(BudgetFileReaderType) :: bfr !< budget file reader + type(BudgetFileReaderType) :: bfr !< budget file reader type(HeadFileReaderType) :: hfr !< head file reader type(PackageBudgetType), dimension(:), allocatable :: gwfpackages !< used to get flows between a package and gwf type(BudgetObjectType), pointer :: mvrbudobj => null() !< pointer to the mover budget budget object @@ -100,7 +99,7 @@ module TspFmiModule contains - subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) + subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) ! ****************************************************************************** ! fmi_cr -- Create a new FMI object ! ****************************************************************************** @@ -113,7 +112,6 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspLabelsType), pointer, intent(in) :: tsplab - real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -139,9 +137,6 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) ! -- Give package access to the assigned labels based on dependent variable fmiobj%tsplab => tsplab ! - ! -- Store pointer to governing equation scale factor - fmiobj%eqnsclfac => eqnsclfac - ! ! -- Return return end subroutine fmi_cr @@ -355,7 +350,6 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) real(DP), intent(inout), dimension(nodes) :: rhs ! -- local integer(I4B) :: n, idiag, idiag_sln - real(DP) :: qcorr ! ------------------------------------------------------------------------------ ! ! -- Calculate the flow imbalance error and make a correction for it @@ -366,9 +360,7 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) do n = 1, nodes idiag = this%dis%con%ia(n) idiag_sln = idxglo(idiag) -!! call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag)) - qcorr = -this%gwfflowja(idiag) * this%eqnsclfac - call matrix_sln%add_value_pos(idiag_sln, qcorr) + call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag)) end do end if ! @@ -402,7 +394,7 @@ subroutine fmi_cq(this, cnew, flowja) rate = DZERO idiag = this%dis%con%ia(n) if (this%ibound(n) > 0) then - rate = -this%gwfflowja(idiag) * cnew(n) * this%eqnsclfac + rate = -this%gwfflowja(idiag) * cnew(n) end if this%flowcorrect(n) = rate flowja(idiag) = flowja(idiag) + rate @@ -733,8 +725,8 @@ subroutine set_active_status(this, cnew) flownm = this%gwfflowja(ipos) if (flownm > 0) then if (this%ibound(m) /= 0) then - crewet = crewet + cnew(m) * flownm ! kluge note: apparently no need to multiply flows by eqnsclfac - tflow = tflow + this%gwfflowja(ipos) ! since it will divide out below anyway + crewet = crewet + cnew(m) * flownm + tflow = tflow + this%gwfflowja(ipos) end if end if end do diff --git a/src/Model/GroundWaterTransport/tsp1mvt1.f90 b/src/Model/GroundWaterTransport/tsp1mvt1.f90 index 74b7b384d11..a65b689e4f4 100644 --- a/src/Model/GroundWaterTransport/tsp1mvt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1mvt1.f90 @@ -28,7 +28,6 @@ module TspMvtModule integer(I4B), pointer :: maxpackages !< max number of packages integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file - real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy type(TspFmiType), pointer :: fmi1 => null() !< pointer to fmi object for model 1 type(TspFmiType), pointer :: fmi2 => null() !< pointer to fmi object for model 2 (set to fmi1 for single model) type(BudgetType), pointer :: budget => null() !< mover transport budget object (used to write balance table) @@ -63,8 +62,8 @@ module TspMvtModule contains - subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge note: does this need tsplab? - gwfmodelname1, gwfmodelname2, fmi2) + subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & + gwfmodelname2, fmi2) ! ****************************************************************************** ! mvt_cr -- Create a new initial conditions object ! ****************************************************************************** @@ -77,7 +76,6 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge not integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi1 - real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor character(len=*), intent(in), optional :: gwfmodelname1 character(len=*), intent(in), optional :: gwfmodelname2 type(TspFmiType), intent(in), target, optional :: fmi2 @@ -115,9 +113,6 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge not ! -- create the budget object call budgetobject_cr(mvt%budobj, 'TRANSPORT MOVER') ! - ! -- Store pointer to governing equation scale factor - mvt%eqnsclfac => eqnsclfac - ! ! -- Return return end subroutine mvt_cr @@ -318,7 +313,7 @@ subroutine mvt_fc(this, cnew1, cnew2) ! water into the same receiver if (fmi_rc%iatp(irc) /= 0) then fmi_rc%datp(irc)%qmfrommvr(id2) = fmi_rc%datp(irc)%qmfrommvr(id2) - & - q * cp * this%eqnsclfac + q * cp end if end do end if @@ -867,7 +862,7 @@ subroutine mvt_fill_budobj(this, cnew1, cnew2) ! -- Calculate solute mover rate rate = DZERO if (fmi_rc%iatp(irc) /= 0) then - rate = -q * cp * this%eqnsclfac + rate = -q * cp end if ! ! -- add the rate to the budterm diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index e9b40a4179c..2abe3b2b829 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -219,14 +219,12 @@ subroutine tsp_cr(this, filename, id, modelname) ! kluge note: not used/needed ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & - this%eqnsclfac) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & this%eqnsclfac) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & - this%eqnsclfac) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! From d06ef65cd7e698ff799c7a2d3324842a02b9392e Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Mon, 17 Apr 2023 15:19:55 -0400 Subject: [PATCH 109/212] * Temporary workaround in idm-related syntax for the sake of old Intel compiler compatibility * Redo scale-factor related updates that were in two recently reversed commits --- src/Exchange/GweGweExchange.f90 | 1 + src/Exchange/GwtGwtExchange.f90 | 1 + src/Model/Connection/GweInterfaceModel.f90 | 3 +- src/Model/Connection/GwtInterfaceModel.f90 | 3 +- src/Model/GroundWaterEnergy/gwe1.f90 | 6 +- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 55 +++++++------ src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 79 +++++++++++++++++-- .../GroundWaterTransport/gwt1dis1idm.f90 | 15 +++- src/Model/GroundWaterTransport/tsp1apt1.f90 | 4 +- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 18 +++-- src/Model/GroundWaterTransport/tsp1mvt1.f90 | 13 ++- src/Model/TransportModel.f90 | 6 +- 12 files changed, 157 insertions(+), 47 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index 09c09a045cc..82c1ce4ae19 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -947,6 +947,7 @@ subroutine read_mvt(this, iout) ! for gwtmodel1 so that a call to save flows has an associated dis ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwemodel1%fmi, & + this%gwemodel1%eqnsclfac, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & fmi2=this%gwemodel2%fmi) diff --git a/src/Exchange/GwtGwtExchange.f90 b/src/Exchange/GwtGwtExchange.f90 index 5469d5a27e5..980697ee7f8 100644 --- a/src/Exchange/GwtGwtExchange.f90 +++ b/src/Exchange/GwtGwtExchange.f90 @@ -947,6 +947,7 @@ subroutine read_mvt(this, iout) ! for gwtmodel1 so that a call to save flows has an associated dis ! object. call mvt_cr(this%mvt, this%name, this%inmvt, iout, this%gwtmodel1%fmi, & + this%gwtmodel1%eqnsclfac, & gwfmodelname1=this%gwfmodelname1, & gwfmodelname2=this%gwfmodelname2, & fmi2=this%gwtmodel2%fmi) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index c90ba41ecd7..032ac0f786c 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -81,7 +81,8 @@ subroutine gweifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, '', -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & + this%eqnsclfac) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, '', -dsp_unit, this%iout, this%fmi, & diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index b751bad4e5b..517bb52f6da 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -81,7 +81,8 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, '', -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & + this%eqnsclfac) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, '', -dsp_unit, this%iout, this%fmi) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 4a6595d05f6..cde78c48f1d 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1382,7 +1382,8 @@ subroutine create_packages(this) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + this%eqnsclfac) ! kluge note: some are already created in TransportModel??? call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & @@ -1391,7 +1392,8 @@ subroutine create_packages(this) this%fmi, this%eqnsclfac, this%gwecommon) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, this%gwecommon) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + this%eqnsclfac) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index bd2040e3e2d..e7e374314cb 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -96,7 +96,7 @@ module GweLkeModule contains subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab, gwecommon) + fmi, tsplab, eqnsclfac, gwecommon) ! ****************************************************************************** ! mwt_create -- Create a New MWT Package ! ****************************************************************************** @@ -113,6 +113,7 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(GweLkeType), pointer :: lkeobj @@ -139,8 +140,8 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ncolbnd = 1 packobj%iscloc = 1 - ! -- Store pointer to flow model interface. When the GwfGwt exchange is - ! created, it sets fmi%bndlist so that the GWT model has access to all + ! -- Store pointer to flow model interface. When the GwfGwe exchange is + ! created, it sets fmi%bndlist so that the GWE model has access to all ! the flow packages lkeobj%fmi => fmi ! @@ -148,6 +149,9 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature lkeobj%tsplab => tsplab ! + ! -- Store pointer to governing equation scale factor + lkeobj%eqnsclfac => eqnsclfac + ! ! -- Store pointer to shared data module for accessing cpw, rhow ! for the budget calculations, and for accessing the latent heat of ! vaporization for evaporative cooling. @@ -787,7 +791,7 @@ subroutine lke_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -813,24 +817,29 @@ subroutine lke_evap_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval ! -- local real(DP) :: qbnd - real(DP) :: ctmp - real(DP) :: omega +!! real(DP) :: ctmp +!! real(DP) :: omega + real(DP) :: heatlat ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) - ctmp = this%tempevap(n1) - if (this%xnewpak(n1) < ctmp) then - omega = DONE - else - omega = DZERO - end if - if (present(rrate)) & - rrate = omega * qbnd * this%xnewpak(n1) + & - (DONE - omega) * qbnd * ctmp - if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp - if (present(hcofval)) hcofval = omega * qbnd +!! ctmp = this%tempevap(n1) +!! if (this%xnewpak(n1) < ctmp) then +!! omega = DONE +!! else +!! omega = DZERO +!! end if +!! if (present(rrate)) & +!! rrate = omega * qbnd * this%xnewpak(n1) + & +!! (DONE - omega) * qbnd * ctmp +!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp +!! if (present(hcofval)) hcofval = omega * qbnd + heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 (kluge note) + if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day (kluge note) + if (present(rhsval)) rhsval = -rrate + if (present(hcofval)) hcofval = DZERO ! ! -- return return @@ -860,7 +869,7 @@ subroutine lke_roff_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -892,7 +901,7 @@ subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -924,9 +933,9 @@ subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudwdrl)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudwdrl)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return @@ -956,9 +965,9 @@ subroutine lke_outf_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 8c13c2bbd91..9d8faea04a5 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -3,22 +3,23 @@ ! -- todo: save the sfe temperature into the sfr aux variable? (perhaps needed for GWT-GWE exchanges) ! -- todo: calculate the sfr VISC aux variable using temperature? ! -! SFR flows (sfrbudptr) index var SFE term Transport Type +! SFR flows (sfrbudptr) index var SFE term Transport Type ! kluge note: "SFE flows", etc? !--------------------------------------------------------------------------------- ! -- terms from SFR that will be handled by parent APT Package ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes -! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) +! FROM-MVR idxbudfmvr FROM-MVR q * tmpext = this%qfrommvr(:) ! kluge note: include rhow*cpw in comments for various terms ! TO-MVR idxbudtmvr TO-MVR q * tfeat ! -- SFR terms ! RAINFALL idxbudrain RAINFALL q * train -! EVAPORATION idxbudevap EVAPORATION tfeat null() ! index of runoff terms in flowbudptr integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + integer(I4B), pointer :: idxbudsbcd => null() ! index of streambed conduction terms in flowbudptr real(DP), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature real(DP), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature @@ -258,6 +260,9 @@ subroutine find_sfe_package(this) case ('EXT-OUTFLOW') this%idxbudoutf = ip this%idxbudssm(ip) = 0 + case ('STRMBD-COND') + this%idxbudsbcd = ip + this%idxbudssm(ip) = 0 case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 @@ -299,12 +304,14 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B), dimension(:), intent(in) :: idxglo class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: j, n1, n2 + integer(I4B) :: j, n1, n2, n integer(I4B) :: iloc - integer(I4B) :: iposd + integer(I4B) :: iposd, iposoffd + integer(I4B) :: ipossymd, ipossymoffd real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval + real(DP) :: ctherm ! kluge? ! ------------------------------------------------------------------------------ ! ! -- add rainfall contribution @@ -362,13 +369,37 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end do end if ! + ! -- add streambed conduction contribution + do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + ! + ! -- set n to feature number and process if active feature + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + if (this%iboundpak(n) /= 0) then + ! + ! -- set acoef and rhs to negative so they are relative to sfe and not gwe + ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance + ! + ! -- add to sfe row + iposd = this%idxdglo(j) + iposoffd = this%idxoffdglo(j) + call matrix_sln%add_value_pos(iposd, ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposoffd, -ctherm) + ! + ! -- add to gwe row for sfe connection + ipossymd = this%idxsymdglo(j) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymd, -ctherm) + call matrix_sln%add_value_pos(ipossymoffd, ctherm) + end if + end do + ! ! -- Return return end subroutine sfe_fc_expanded !> @ brief Add terms specific to sfr to the explicit sfr solve !< - subroutine sfe_solve(this) + subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/useful if there's streambed conduction??? ! -- dummy class(GweSfeType) :: this ! -- local @@ -417,6 +448,8 @@ subroutine sfe_solve(this) end do end if ! + ! kluge note: explicit streambed conduction terms??? + ! ! -- Return return end subroutine sfe_solve @@ -520,6 +553,19 @@ subroutine sfe_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! + ! -- + text = ' STRMBD-COND' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudsbcd)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + ! ! -- return return end subroutine sfe_setup_budobj @@ -538,7 +584,9 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- local integer(I4B) :: j, n1, n2 integer(I4B) :: nlist + integer(I4B) :: igwfnode real(DP) :: q + real(DP) :: ctherm ! kluge? ! -- formats ! ----------------------------------------------------------------------------- @@ -592,6 +640,22 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do + ! -- STRMBD-COND + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do j = 1, this%flowbudptr%budterm(this%idxbudsbcd)%nlist + q = DZERO + n1 = this%flowbudptr%budterm(this%idxbudsbcd)%id1(j) + if (this%iboundpak(n1) /= 0) then + igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) + ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct + q = -q ! flip sign so relative to advanced package feature + end if + call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + ! ! -- return return @@ -620,6 +684,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath) call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) + call mem_allocate(this%idxbudsbcd, 'IDXBUDSBCD', this%memoryPath) ! ! -- Initialize this%idxbudrain = 0 @@ -627,6 +692,7 @@ subroutine allocate_scalars(this) this%idxbudroff = 0 this%idxbudiflw = 0 this%idxbudoutf = 0 + this%idxbudsbcd = 0 ! ! -- Return return @@ -681,6 +747,7 @@ subroutine sfe_da(this) call mem_deallocate(this%idxbudroff) call mem_deallocate(this%idxbudiflw) call mem_deallocate(this%idxbudoutf) + call mem_deallocate(this%idxbudsbcd) ! ! -- deallocate time series call mem_deallocate(this%temprain) diff --git a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 index b80694384aa..dda32a6b3a1 100644 --- a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 @@ -256,7 +256,20 @@ module GwtDisInputModule type(InputParamDefinitionType), parameter :: & gwt_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 71308c7ac01..e518c3e36c4 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -12,12 +12,12 @@ ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes -! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) +! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:) ! kluge note: rhow*cpw also applies to various terms for heat transport ! TO-MVR idxbudtmvr TO-MVR q * cfeat ! -- generalized source/sink terms (except ET?) ! RAINFALL idxbudrain RAINFALL q * crain -! EVAPORATION idxbudevap EVAPORATION cfeat null() !< unit number GWF mover budget file integer(I4B), pointer :: nflowpack => null() !< number of GWF flow packages integer(I4B), dimension(:), pointer, contiguous :: igwfmvrterm => null() !< flag to indicate that gwf package is a mover term + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy type(BudgetFileReaderType) :: bfr !< budget file reader type(HeadFileReaderType) :: hfr !< head file reader type(PackageBudgetType), dimension(:), allocatable :: gwfpackages !< used to get flows between a package and gwf @@ -99,7 +100,7 @@ module TspFmiModule contains - subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) + subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) ! ****************************************************************************** ! fmi_cr -- Create a new FMI object ! ****************************************************************************** @@ -112,6 +113,7 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspLabelsType), pointer, intent(in) :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! ------------------------------------------------------------------------------ ! ! -- Create the object @@ -137,6 +139,9 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab) ! -- Give package access to the assigned labels based on dependent variable fmiobj%tsplab => tsplab ! + ! -- Store pointer to governing equation scale factor + fmiobj%eqnsclfac => eqnsclfac + ! ! -- Return return end subroutine fmi_cr @@ -350,6 +355,7 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) real(DP), intent(inout), dimension(nodes) :: rhs ! -- local integer(I4B) :: n, idiag, idiag_sln + real(DP) :: qcorr ! ------------------------------------------------------------------------------ ! ! -- Calculate the flow imbalance error and make a correction for it @@ -360,7 +366,9 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) do n = 1, nodes idiag = this%dis%con%ia(n) idiag_sln = idxglo(idiag) - call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag)) +!! call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag)) + qcorr = -this%gwfflowja(idiag) * this%eqnsclfac + call matrix_sln%add_value_pos(idiag_sln, qcorr) end do end if ! @@ -394,7 +402,7 @@ subroutine fmi_cq(this, cnew, flowja) rate = DZERO idiag = this%dis%con%ia(n) if (this%ibound(n) > 0) then - rate = -this%gwfflowja(idiag) * cnew(n) + rate = -this%gwfflowja(idiag) * cnew(n) * this%eqnsclfac end if this%flowcorrect(n) = rate flowja(idiag) = flowja(idiag) + rate @@ -725,8 +733,8 @@ subroutine set_active_status(this, cnew) flownm = this%gwfflowja(ipos) if (flownm > 0) then if (this%ibound(m) /= 0) then - crewet = crewet + cnew(m) * flownm - tflow = tflow + this%gwfflowja(ipos) + crewet = crewet + cnew(m) * flownm ! kluge note: apparently no need to multiply flows by eqnsclfac + tflow = tflow + this%gwfflowja(ipos) ! since it will divide out below anyway end if end if end do diff --git a/src/Model/GroundWaterTransport/tsp1mvt1.f90 b/src/Model/GroundWaterTransport/tsp1mvt1.f90 index bb231358a1b..c2a6a9d9268 100644 --- a/src/Model/GroundWaterTransport/tsp1mvt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1mvt1.f90 @@ -28,6 +28,7 @@ module TspMvtModule integer(I4B), pointer :: maxpackages !< max number of packages integer(I4B), pointer :: ibudgetout => null() !< unit number for budget output file integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy type(TspFmiType), pointer :: fmi1 => null() !< pointer to fmi object for model 1 type(TspFmiType), pointer :: fmi2 => null() !< pointer to fmi object for model 2 (set to fmi1 for single model) type(BudgetType), pointer :: budget => null() !< mover transport budget object (used to write balance table) @@ -62,8 +63,8 @@ module TspMvtModule contains - subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & - gwfmodelname2, fmi2) + subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge note: does this need tsplab? + gwfmodelname1, gwfmodelname2, fmi2) ! ****************************************************************************** ! mvt_cr -- Create a new initial conditions object ! ****************************************************************************** @@ -76,6 +77,7 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout type(TspFmiType), intent(in), target :: fmi1 + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor character(len=*), intent(in), optional :: gwfmodelname1 character(len=*), intent(in), optional :: gwfmodelname2 type(TspFmiType), intent(in), target, optional :: fmi2 @@ -113,6 +115,9 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, gwfmodelname1, & ! -- create the budget object call budgetobject_cr(mvt%budobj, 'TRANSPORT MOVER') ! + ! -- Store pointer to governing equation scale factor + mvt%eqnsclfac => eqnsclfac + ! ! -- Return return end subroutine mvt_cr @@ -313,7 +318,7 @@ subroutine mvt_fc(this, cnew1, cnew2) ! water into the same receiver if (fmi_rc%iatp(irc) /= 0) then fmi_rc%datp(irc)%qmfrommvr(id2) = fmi_rc%datp(irc)%qmfrommvr(id2) - & - q * cp + q * cp * this%eqnsclfac end if end do end if @@ -864,7 +869,7 @@ subroutine mvt_fill_budobj(this, cnew1, cnew2) ! -- Calculate solute mover rate rate = DZERO if (fmi_rc%iatp(irc) /= 0) then - rate = -q * cp + rate = -q * cp * this%eqnsclfac end if ! ! -- add the rate to the budterm diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 8ff406c88f0..284a5066716 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -1010,12 +1010,14 @@ subroutine create_packages(this, indis) ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + this%eqnsclfac) !call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, this%eqnsclfac) !call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, this%fmi) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + this%eqnsclfac) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! From 64835e0e24a9a1dd655962ed93c1106d2a91ea82 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 05:58:57 -0700 Subject: [PATCH 110/212] More post-merge reconciliation --- src/Model/GroundWaterTransport/gwt1.f90 | 4 ++-- src/Model/GroundWaterTransport/gwt1lkt1.f90 | 12 +++++++++++- src/Model/GroundWaterTransport/gwt1sft1.f90 | 6 +++++- src/Model/GroundWaterTransport/tsp1apt1.f90 | 8 ++++---- 4 files changed, 22 insertions(+), 8 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index c3d1d494377..ef5c5eb9ce5 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -1107,10 +1107,10 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & pakname, this%tsplab) case ('LKT6') call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('SFT6') call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('MWT6') call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) diff --git a/src/Model/GroundWaterTransport/gwt1lkt1.f90 b/src/Model/GroundWaterTransport/gwt1lkt1.f90 index a4ac3791cc4..593bfc498d6 100644 --- a/src/Model/GroundWaterTransport/gwt1lkt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1lkt1.f90 @@ -42,6 +42,7 @@ module GwtLktModule use ObserveModule, only: ObserveType use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType use MatrixBaseModule implicit none @@ -93,7 +94,7 @@ module GwtLktModule contains subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi) + fmi, tsplab, eqnsclfac) ! ****************************************************************************** ! mwt_create -- Create a New MWT Package ! ****************************************************************************** @@ -109,6 +110,8 @@ subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! -- local type(GwtLktType), pointer :: lktobj ! ------------------------------------------------------------------------------ @@ -139,6 +142,13 @@ subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages lktobj%fmi => fmi ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + lktobj%tsplab => tsplab + ! + ! -- Store pointer to governing equation scale factor + lktobj%eqnsclfac => eqnsclfac + ! ! -- return return end subroutine lkt_create diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 9e306d35ec4..f956d08ba1e 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -91,7 +91,7 @@ module GwtSftModule contains subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi, tsplab) + fmi, tsplab, eqnsclfac) ! ****************************************************************************** ! sft_create -- Create a New SFT Package ! ****************************************************************************** @@ -108,6 +108,7 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! -- local type(GwtSftType), pointer :: sftobj ! ------------------------------------------------------------------------------ @@ -138,6 +139,9 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages sftobj%fmi => fmi ! + ! -- Store pointer to governing equation scale factor + sftobj%eqnsclfac => eqnsclfac + ! ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature sftobj%tsplab => tsplab diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index e518c3e36c4..75e811e9702 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -2153,7 +2153,7 @@ subroutine apt_setup_budobj(this) integer(I4B) :: idx logical :: ordered_id1 real(DP) :: q - character(len=LENBUDTXT) :: text + character(len=LENBUDTXT) :: text, textt character(len=LENBUDTXT), dimension(1) :: auxtxt ! ------------------------------------------------------------------------------ ! @@ -2240,8 +2240,8 @@ subroutine apt_setup_budobj(this) idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudsto)%maxlist naux = 1 - write(text, '(a)') padl(this%tsplab%depvarunit, 16) - auxtxt(1) = text ! ' MASS' or ' ENERGY' + write(textt, '(a)') padl(this%tsplab%depvarunit, 16) + auxtxt(1) = textt ! ' MASS' or ' ENERGY' call this%budobj%budterm(idx)%initialize(text, & this%name_model, & this%packName, & @@ -3057,7 +3057,7 @@ subroutine apt_bd_obs(this) logical :: found ! ------------------------------------------------------------------------------ ! - ! -- Write simulated values for all LAK observations + ! -- Write simulated values for all Advanced Package observations if (this%obs%npakobs > 0) then call this%obs%obs_bd_clear() do i = 1, this%obs%npakobs From a427d9fbf131027c41966ae5b9a4b610637cef9b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 10:33:39 -0700 Subject: [PATCH 111/212] GWE support in idm --- src/Utilities/Idm/ModelPackageInputs.f90 | 32 +++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/src/Utilities/Idm/ModelPackageInputs.f90 b/src/Utilities/Idm/ModelPackageInputs.f90 index 25ea01001a6..e25580a72e6 100644 --- a/src/Utilities/Idm/ModelPackageInputs.f90 +++ b/src/Utilities/Idm/ModelPackageInputs.f90 @@ -16,7 +16,7 @@ module ModelPackageInputsModule implicit none private - public :: NIUNIT_GWF, NIUNIT_GWT + public :: NIUNIT_GWF, NIUNIT_GWT, NIUNIT_GWE public :: ModelPackageInputsType ! -- GWF base package types, ordered for memload @@ -52,9 +52,26 @@ module ModelPackageInputsModule &'SFT6 ', 'MWT6 ', 'UZT6 ', 'API6 ', ' ', & ! 10 &40*' '/ ! 50 + ! -- GWE base package types, ordered for memload + integer(I4B), parameter :: GWE_NBASEPKG = 50 + character(len=LENPACKAGETYPE), dimension(GWE_NBASEPKG) :: GWE_BASEPKG + data GWE_BASEPKG/'DIS6 ', 'DISV6', 'DISU6', ' ', ' ', & ! 5 + &'IC6 ', 'FMI6 ', 'MST6 ', 'ADV6 ', ' ', & ! 10 + &'DSP6 ', 'SSM6 ', 'MVT6 ', 'OC6 ', ' ', & ! 15 + &'OBS6 ', ' ', ' ', ' ', ' ', & ! 20 + &30*' '/ ! 50 + + ! -- GWE multi package types, ordered for memload + integer(I4B), parameter :: GWE_NMULTIPKG = 50 + character(len=LENPACKAGETYPE), dimension(GWE_NMULTIPKG) :: GWE_MULTIPKG + data GWE_MULTIPKG/'TMP6 ', 'SRC6 ', 'LKE6 ', ' ', ' ', & ! 5 + &'SFE6 ', 'MWE6 ', 'UZE6 ', 'API6 ', ' ', & ! 10 + &40*' '/ ! 50 + ! -- size of supported model package arrays integer(I4B), parameter :: NIUNIT_GWF = GWF_NBASEPKG + GWF_NMULTIPKG integer(I4B), parameter :: NIUNIT_GWT = GWT_NBASEPKG + GWT_NMULTIPKG + integer(I4B), parameter :: NIUNIT_GWE = GWE_NBASEPKG + GWE_NMULTIPKG !> @brief derived type for loadable package type !! @@ -145,6 +162,11 @@ subroutine supported_model_packages(mtype, pkgtypes, numpkgs) allocate (pkgtypes(numpkgs)) pkgtypes = [GWT_BASEPKG, GWT_MULTIPKG] ! + case ('GWTE') + numpkgs = GWE_NBASEPKG + GWE_NMULTIPKG + allocate (pkgtypes(numpkgs)) + pkgtypes = [GWE_BASEPKG, GWE_MULTIPKG] + ! case default end select ! @@ -216,6 +238,14 @@ function multi_pkg_type(mtype_component, ptype_component, pkgtype) & end if end do ! + case ('GWE') + do n = 1, GWE_NMULTIPKG + if (GWE_MULTIPKG(n) == pkgtype) then + multi_pkg = .true. + exit + end if + end do + ! case default end select end if From e029f58d7337fac01b3e2a71796ee21d358785ac Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 10:35:08 -0700 Subject: [PATCH 112/212] More reconciliation post gwe/develop merge catch-up --- src/Model/GroundWaterEnergy/gwe1.f90 | 331 ++++++++++++----------- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 3 +- src/Model/GroundWaterTransport/gwt1.f90 | 3 +- src/Model/TransportModel.f90 | 21 +- 4 files changed, 187 insertions(+), 171 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index cde78c48f1d..d53af36fd83 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -22,13 +22,13 @@ module GweModule public :: gwe_cr public :: GweModelType public :: CastAsGweModel - + public :: niunit + type, extends(TransportModelType) :: GweModelType type(GweInputDataType), pointer :: gwecommon => null() !< container for data shared with multiple packages type(GweMstType), pointer :: mst => null() !< mass storage and transfer package type(GweDspType), pointer :: dsp => null() !< dispersion package - !type(BudgetType), pointer :: budget => null() ! budget object !integer(I4B), pointer :: inic => null() ! unit number IC !integer(I4B), pointer :: infmi => null() ! unit number FMI !integer(I4B), pointer :: inmvt => null() ! unit number MVT @@ -56,7 +56,7 @@ module GweModule procedure :: model_da => gwe_da procedure :: model_bdentry => gwe_bdentry - procedure :: allocate_scalars + procedure :: allocate_gwe_scalars procedure, private :: package_create !procedure, private :: ftype_check procedure :: get_iasym => gwe_get_iasym @@ -65,10 +65,10 @@ module GweModule procedure, private :: gwe_ot_dv procedure, private :: gwe_ot_bdsummary procedure, private :: gwe_ot_obs - procedure, private :: create_packages + procedure, private :: create_gwe_specific_packages procedure, private :: create_bndpkgs - procedure, private :: create_lstfile - procedure, private :: log_namfile_options + !procedure, private :: create_lstfile + !procedure, private :: log_namfile_options end type GweModelType @@ -121,7 +121,7 @@ subroutine gwe_cr(filename, id, modelname) integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local - integer(I4B) :: indis, indis6, indisu6, indisv6 + integer(I4B) :: indis !, indis6, indisu6, indisv6 integer(I4B) :: ipakid, i, j, iu, ipaknum character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname @@ -141,51 +141,54 @@ subroutine gwe_cr(filename, id, modelname) ! -- Set memory path before allocation in memory manager can be done this%memoryPath = create_mem_path(modelname) ! - call this%allocate_scalars(modelname) + call this%allocate_tsp_scalars(modelname) model => this call AddBaseModelToList(basemodellist, model) ! ! -- Assign values - this%filename = filename - this%name = modelname - this%macronym = 'GWE' - this%id = id + !this%filename = filename + !this%name = modelname + !this%macronym = 'GWE' + !this%id = id + ! + ! -- Instantiate shared data container + call gweshared_dat_cr(this%gwecommon) + ! + ! -- Call parent class routine + call this%tsp_cr(filename, id, modelname, 'GWE', indis, this%gwecommon) ! ! -- set input model namfile memory path - input_mempath = create_mem_path(modelname, 'NAM', idm_context) + !input_mempath = create_mem_path(modelname, 'NAM', idm_context) ! ! -- copy option params from input context - call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) - call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & - found%print_input) - call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & - found%print_flows) - call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) + !call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) + !call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & + ! found%print_input) + !call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & + ! found%print_flows) + !call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) ! ! -- create the list file - call this%create_lstfile(lst_fname, filename, found%list) + !call this%create_lstfile(lst_fname, filename, found%list) ! ! -- activate save_flows if found - if (found%save_flows) then - this%ipakcb = -1 - end if + !if (found%save_flows) then + ! this%ipakcb = -1 + !end if ! ! -- Instantiate generalized labels - call tsplabels_cr(this%tsplab, this%name) - ! - ! -- Instantiate shared data container - call gweshared_dat_cr(this%gwecommon) + !call tsplabels_cr(this%tsplab, this%name) ! ! -- log set options - if (this%iout > 0) then - call this%log_namfile_options(found) - end if + !if (this%iout > 0) then + ! call this%log_namfile_options(found) + !end if ! ! -- Create utility objects - call budget_cr(this%budget, this%name, this%tsplab) + !call budget_cr(this%budget, this%name, this%tsplab) ! ! -- create model packages - call this%create_packages() + call this%create_gwe_specific_packages(indis) ! ! -- return return @@ -201,6 +204,7 @@ subroutine gwe_df(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules + use ModelPackageInputsModule, only: NIUNIT_GWE use TspLabelsModule, only: setTspLabels use GweInputDataModule, only: gweshared_dat_df ! -- dummy @@ -1018,7 +1022,7 @@ function gwe_get_iasym(this) result(iasym) return end function gwe_get_iasym - subroutine allocate_scalars(this, modelname) + subroutine allocate_gwe_scalars(this, modelname) ! ****************************************************************************** ! allocate_scalars -- Allocate memory for non-allocatable members ! ****************************************************************************** @@ -1058,7 +1062,7 @@ subroutine allocate_scalars(this, modelname) ! ! -- return return - end subroutine allocate_scalars + end subroutine allocate_gwe_scalars subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) @@ -1283,7 +1287,7 @@ end subroutine create_bndpkgs !> @brief Source package info and begin to process !< - subroutine create_packages(this) + subroutine create_gwe_specific_packages(this, indis) ! -- modules use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CharacterStringModule, only: CharacterStringType @@ -1291,20 +1295,21 @@ subroutine create_packages(this) use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use TspIcModule, only: ic_cr - use TspFmiModule, only: fmi_cr + !use GwfDisModule, only: dis_cr + !use GwfDisvModule, only: disv_cr + !use GwfDisuModule, only: disu_cr + !use TspIcModule, only: ic_cr + !use TspFmiModule, only: fmi_cr use GweMstModule, only: mst_cr - use TspAdvModule, only: adv_cr + !use TspAdvModule, only: adv_cr use GweDspModule, only: dsp_cr - use TspSsmModule, only: ssm_cr - use TspMvtModule, only: mvt_cr - use TspOcModule, only: oc_cr - use TspObsModule, only: tsp_obs_cr + !use TspSsmModule, only: ssm_cr + !use TspMvtModule, only: mvt_cr + !use TspOcModule, only: oc_cr + !use TspObsModule, only: tsp_obs_cr ! -- dummy class(GweModelType) :: this + integer(I4B), intent(in) :: indis ! -- local type(CharacterStringType), dimension(:), contiguous, & pointer :: pkgtypes => null() @@ -1321,7 +1326,7 @@ subroutine create_packages(this) integer(I4B), pointer :: inunit integer(I4B), dimension(:), allocatable :: bndpkgs integer(I4B) :: n - integer(I4B) :: indis = 0 ! DIS enabled flag + !integer(I4B) :: indis = 0 ! DIS enabled flag character(len=LENMEMPATH) :: mempathdsp = '' ! ! -- set input memory paths, input/model and input/model/namfile @@ -1343,34 +1348,34 @@ subroutine create_packages(this) ! ! -- create dis package as it is a prerequisite for other packages select case (pkgtype) - case ('DIS6') - indis = 1 - call dis_cr(this%dis, this%name, mempath, indis, this%iout) - case ('DISV6') - indis = 1 - call disv_cr(this%dis, this%name, mempath, indis, this%iout) - case ('DISU6') - indis = 1 - call disu_cr(this%dis, this%name, mempath, indis, this%iout) - case ('IC6') - this%inic = inunit - case ('FMI6') - this%infmi = inunit - case ('MVT6') - this%inmvt = inunit + !case ('DIS6') + ! indis = 1 + ! call dis_cr(this%dis, this%name, mempath, indis, this%iout) + !case ('DISV6') + ! indis = 1 + ! call disv_cr(this%dis, this%name, mempath, indis, this%iout) + !case ('DISU6') + ! indis = 1 + ! call disu_cr(this%dis, this%name, mempath, indis, this%iout) + !case ('IC6') + ! this%inic = inunit + !case ('FMI6') + ! this%infmi = inunit + !case ('MVT6') + ! this%inmvt = inunit case ('MST6') this%inmst = inunit - case ('ADV6') - this%inadv = inunit - case ('DSP6') + !case ('ADV6') + ! this%inadv = inunit + case ('DSP6') this%indsp = 1 mempathdsp = mempath - case ('SSM6') - this%inssm = inunit - case ('OC6') - this%inoc = inunit - case ('OBS6') - this%inobs = inunit + !case ('SSM6') + ! this%inssm = inunit + !case ('OC6') + ! this%inoc = inunit + !case ('OBS6') + ! this%inobs = inunit case ('TMP6', 'SRC6', 'LKE6', 'SFE6', & 'MWE6', 'UZE6', ' ', 'API6') call expandarray(bndpkgs) @@ -1381,112 +1386,112 @@ subroutine create_packages(this) end do ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & - this%eqnsclfac) ! kluge note: some are already created in TransportModel??? + !call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) + !call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + ! this%eqnsclfac) ! kluge note: some are already created in TransportModel??? call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & - this%eqnsclfac) + !call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + ! this%eqnsclfac) call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & this%fmi, this%eqnsclfac, this%gwecommon) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, this%gwecommon) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & - this%eqnsclfac) - call oc_cr(this%oc, this%name, this%inoc, this%iout) - call tsp_obs_cr(this%obs, this%inobs) + !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + ! this%eqnsclfac) + !call oc_cr(this%oc, this%name, this%inoc, this%iout) + !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified call this%ftype_check(indis) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) - end subroutine create_packages - - subroutine create_lstfile(this, lst_fname, model_fname, defined) - ! -- modules - use KindModule, only: LGP - use InputOutputModule, only: openfile, getunit - ! -- dummy - class(GweModelType) :: this - character(len=*), intent(inout) :: lst_fname - character(len=*), intent(in) :: model_fname - logical(LGP), intent(in) :: defined - ! -- local - integer(I4B) :: i, istart, istop - ! - ! -- set list file name if not provided - if (.not. defined) then - ! - ! -- initialize - lst_fname = ' ' - istart = 0 - istop = len_trim(model_fname) - ! - ! -- identify '.' character position from back of string - do i = istop, 1, -1 - if (model_fname(i:i) == '.') then - istart = i - exit - end if - end do - ! - ! -- if not found start from string end - if (istart == 0) istart = istop + 1 - ! - ! -- set list file name - lst_fname = model_fname(1:istart) - istop = istart + 3 - lst_fname(istart:istop) = '.lst' - end if - ! - ! -- create the list file - this%iout = getunit() - call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') - ! - ! -- write list file header - call write_listfile_header(this%iout, 'GROUNDWATER ENERGY TRANSPORT MODEL (GWE)') - ! - ! -- return - return - end subroutine create_lstfile - - !> @brief Write model namfile options to list file - !< - subroutine log_namfile_options(this, found) - use GwfNamInputModule, only: GwfNamParamFoundType - class(GweModelType) :: this - type(GwfNamParamFoundType), intent(in) :: found - - write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' - - if (found%newton) then - write (this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method enabled for the model.' - if (found%under_relaxation) then - write (this%iout, '(4x,a,a)') & - 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & - 'elevation of the model will be applied to the model.' - end if - end if + end subroutine create_gwe_specific_packages - if (found%print_input) then - write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - 'FOR ALL MODEL STRESS PACKAGES' - end if - - if (found%print_flows) then - write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - 'FOR ALL MODEL PACKAGES' - end if - - if (found%save_flows) then - write (this%iout, '(4x,a)') & - 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - end if +! subroutine create_lstfile(this, lst_fname, model_fname, defined) +! ! -- modules +! use KindModule, only: LGP +! use InputOutputModule, only: openfile, getunit +! ! -- dummy +! class(GweModelType) :: this +! character(len=*), intent(inout) :: lst_fname +! character(len=*), intent(in) :: model_fname +! logical(LGP), intent(in) :: defined +! ! -- local +! integer(I4B) :: i, istart, istop +! ! +! ! -- set list file name if not provided +! if (.not. defined) then +! ! +! ! -- initialize +! lst_fname = ' ' +! istart = 0 +! istop = len_trim(model_fname) +! ! +! ! -- identify '.' character position from back of string +! do i = istop, 1, -1 +! if (model_fname(i:i) == '.') then +! istart = i +! exit +! end if +! end do +! ! +! ! -- if not found start from string end +! if (istart == 0) istart = istop + 1 +! ! +! ! -- set list file name +! lst_fname = model_fname(1:istart) +! istop = istart + 3 +! lst_fname(istart:istop) = '.lst' +! end if +! ! +! ! -- create the list file +! this%iout = getunit() +! call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') +! ! +! ! -- write list file header +! call write_listfile_header(this%iout, 'GROUNDWATER ENERGY TRANSPORT MODEL (GWE)') +! ! +! ! -- return +! return +! end subroutine create_lstfile +! +! !> @brief Write model namfile options to list file +! !< +! subroutine log_namfile_options(this, found) +! use GwfNamInputModule, only: GwfNamParamFoundType +! class(GweModelType) :: this +! type(GwfNamParamFoundType), intent(in) :: found +! +! write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' +! +! if (found%newton) then +! write (this%iout, '(4x,a)') & +! 'NEWTON-RAPHSON method enabled for the model.' +! if (found%under_relaxation) then +! write (this%iout, '(4x,a,a)') & +! 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & +! 'elevation of the model will be applied to the model.' +! end if +! end if +! +! if (found%print_input) then +! write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & +! 'FOR ALL MODEL STRESS PACKAGES' +! end if +! +! if (found%print_flows) then +! write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & +! 'FOR ALL MODEL PACKAGES' +! end if +! +! if (found%save_flows) then +! write (this%iout, '(4x,a)') & +! 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' +! end if - write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' - end subroutine log_namfile_options +! write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' +! end subroutine log_namfile_options end module GweModule diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 17b934dc849..8ea8fb4f5e1 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -80,7 +80,8 @@ module GweDspModule contains - subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi, eqnsclfac, gwecommon) + subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi, & + eqnsclfac, gwecommon) ! ****************************************************************************** ! dsp_cr -- Create a new DSP object ! ****************************************************************************** diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index ef5c5eb9ce5..00d3e83cc26 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -712,7 +712,8 @@ subroutine gwt_ot(this) ! -- Override ibudfl and idvprint flags for nonconvergence ! and end of period ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & + this%icnvg, endofperiod) ! ! Calculate and save observations call this%gwt_ot_obs() diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 284a5066716..5faa2327298 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -27,6 +27,7 @@ module TransportModelModule use TspOcModule, only: TspOcType use TspObsModule, only: TspObsType use BudgetModule, only: BudgetType + use GweInputDataModule, only: GweInputDataType use MatrixBaseModule implicit none @@ -100,7 +101,7 @@ module TransportModelModule contains - subroutine tsp_cr(this, filename, id, modelname, macronym, indis) ! kluge note: not used/needed + subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! kluge note: not used/needed ! -- modules use SimModule, only: store_error use MemoryManagerModule, only: mem_allocate @@ -130,6 +131,7 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis) ! kluge note: integer(I4B), intent(inout) :: indis character(len=*), intent(in) :: modelname character(len=*), intent(in) :: macronym + type(GweInputDataType), intent(in), optional :: gwecommon !< shared data container for use by multiple GWE packages ! -- local class(*), pointer :: mstobjPtr !type(NameFileType) :: namefile_obj @@ -183,7 +185,11 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis) ! kluge note: call budget_cr(this%budget, this%name, this%tsplab) ! ! -- create model packages - call this%create_packages(indis) + if (present(gwecommon)) then + call this%create_packages(indis, gwecommon) + else + call this%create_packages(indis) + end if ! ! -- Open namefile and set iout !call namefile_obj%init(this%filename, 0) @@ -908,7 +914,7 @@ end subroutine log_namfile_options !> @brief Source package info and begin to process !< - subroutine create_packages(this, indis) + subroutine create_packages(this, indis, gwecommon) ! -- modules use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CharacterStringModule, only: CharacterStringType @@ -931,6 +937,7 @@ subroutine create_packages(this, indis) ! -- dummy class(TransportModelType) :: this integer(I4B), intent(inout) :: indis ! DIS enabled flag + type(GweInputDataType), intent(in), optional :: gwecommon !< shared data container for use by multiple GWE packages ! -- local type(CharacterStringType), dimension(:), contiguous, & pointer :: pkgtypes => null() @@ -1013,10 +1020,12 @@ subroutine create_packages(this, indis) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & this%eqnsclfac) !call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, this%eqnsclfac) + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + this%eqnsclfac) !call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & + call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + this%tsplab, this%eqnsclfac, gwecommon) + call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & this%eqnsclfac) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) From 14cf908fbf0f7042e3ba98e99342d3d5763f147f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 13:49:58 -0700 Subject: [PATCH 113/212] Some IDM related updates for running GWE autotests with the post update-merge GWE code base --- msvs/mf6core.vfproj | 3 +- src/Model/GroundWaterEnergy/gwe1idm.f90 | 187 ++++++++++++++++++ src/Utilities/Idm/ModelPackageInputs.f90 | 2 +- src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 | 8 +- src/Utilities/Idm/selector/IdmDfnSelector.f90 | 15 ++ .../Idm/selector/IdmGweDfnSelector.f90 | 96 +++++++++ utils/idmloader/scripts/dfn2f90.py | 4 + 7 files changed, 312 insertions(+), 3 deletions(-) create mode 100644 src/Model/GroundWaterEnergy/gwe1idm.f90 create mode 100644 src/Utilities/Idm/selector/IdmGweDfnSelector.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index a1da46d585c..b0080392e72 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -124,7 +124,7 @@ - + @@ -283,6 +283,7 @@ + diff --git a/src/Model/GroundWaterEnergy/gwe1idm.f90 b/src/Model/GroundWaterEnergy/gwe1idm.f90 new file mode 100644 index 00000000000..5b0466e6e63 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1idm.f90 @@ -0,0 +1,187 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** +module GweNamInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwe_nam_param_definitions + public gwe_nam_aggregate_definitions + public gwe_nam_block_definitions + public GweNamParamFoundType + public gwe_nam_multi_package + + type GweNamParamFoundType + logical :: list = .false. + logical :: print_input = .false. + logical :: print_flows = .false. + logical :: save_flows = .false. + logical :: ftype = .false. + logical :: fname = .false. + logical :: pname = .false. + end type GweNamParamFoundType + + logical :: gwe_nam_multi_package = .false. + + type(InputParamDefinitionType), parameter :: & + gwenam_list = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'OPTIONS', & ! block + 'LIST', & ! tag name + 'LIST', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwenam_print_input = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'OPTIONS', & ! block + 'PRINT_INPUT', & ! tag name + 'PRINT_INPUT', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwenam_print_flows = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'OPTIONS', & ! block + 'PRINT_FLOWS', & ! tag name + 'PRINT_FLOWS', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwenam_save_flows = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'OPTIONS', & ! block + 'SAVE_FLOWS', & ! tag name + 'SAVE_FLOWS', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwenam_ftype = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'PACKAGES', & ! block + 'FTYPE', & ! tag name + 'FTYPE', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwenam_fname = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'PACKAGES', & ! block + 'FNAME', & ! tag name + 'FNAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .true., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwenam_pname = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'PACKAGES', & ! block + 'PNAME', & ! tag name + 'PNAME', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_nam_param_definitions(*) = & + [ & + gwenam_list, & + gwenam_print_input, & + gwenam_print_flows, & + gwenam_save_flows, & + gwenam_ftype, & + gwenam_fname, & + gwenam_pname & + ] + + type(InputParamDefinitionType), parameter :: & + gwenam_packages = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'NAM', & ! subcomponent + 'PACKAGES', & ! block + 'PACKAGES', & ! tag name + 'PACKAGES', & ! fortran variable + 'RECARRAY FTYPE FNAME PNAME', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_nam_aggregate_definitions(*) = & + [ & + gwenam_packages & + ] + + type(InputBlockDefinitionType), parameter :: & + gwe_nam_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'PACKAGES', & ! blockname + .true., & ! required + .true., & ! aggregate + .false. & ! block_variable + ) & + ] + +end module GweNamInputModule diff --git a/src/Utilities/Idm/ModelPackageInputs.f90 b/src/Utilities/Idm/ModelPackageInputs.f90 index e25580a72e6..575e9066ad8 100644 --- a/src/Utilities/Idm/ModelPackageInputs.f90 +++ b/src/Utilities/Idm/ModelPackageInputs.f90 @@ -162,7 +162,7 @@ subroutine supported_model_packages(mtype, pkgtypes, numpkgs) allocate (pkgtypes(numpkgs)) pkgtypes = [GWT_BASEPKG, GWT_MULTIPKG] ! - case ('GWTE') + case ('GWE6') numpkgs = GWE_NBASEPKG + GWE_NMULTIPKG allocate (pkgtypes(numpkgs)) pkgtypes = [GWE_BASEPKG, GWE_MULTIPKG] diff --git a/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 b/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 index 4e844c23fed..b6025d8f784 100644 --- a/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 +++ b/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 @@ -68,7 +68,7 @@ subroutine input_load(pkgtype, & component_name, subcomponent_name, & inunit, iout) character(len=*), intent(in) :: pkgtype !< pkgtype to load, such as DIS6, DISV6, NPF6 - character(len=*), intent(in) :: component_type !< component type, such as GWF or GWT + character(len=*), intent(in) :: component_type !< component type, such as GWF, GWT or GWE character(len=*), intent(in) :: subcomponent_type !< subcomponent type, such as DIS or NPF character(len=*), intent(in) :: component_name !< component name, such as MYGWFMODEL character(len=*), intent(in) :: subcomponent_name !< subcomponent name, such as MYWELLPACKAGE @@ -269,6 +269,12 @@ subroutine model_load(mtype, mfname, mname, iout) ! call modelpkgs_load(mtype, mfname, mname, iout) ! + case ('GWE6') + ! + call input_load('GWE6', 'GWE', 'NAM', mname, 'NAM', inunit, iout) + ! + call modelpkgs_load(mtype, mfname, mname, iout) + ! case default write (errmsg, '(a,a,a,a,a)') & 'Unknown simulation model type & diff --git a/src/Utilities/Idm/selector/IdmDfnSelector.f90 b/src/Utilities/Idm/selector/IdmDfnSelector.f90 index a3e13b0ead0..fbb92a90edf 100644 --- a/src/Utilities/Idm/selector/IdmDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmDfnSelector.f90 @@ -14,6 +14,11 @@ module IdmDfnSelectorModule gwt_block_definitions, & gwt_idm_multi_package, & gwt_idm_integrated + use IdmGweDfnSelectorModule, only: gwe_param_definitions, & + gwe_aggregate_definitions, & + gwe_block_definitions, & + gwe_idm_multi_package, & + gwe_idm_integrated use IdmSimDfnSelectorModule, only: sim_param_definitions, & sim_aggregate_definitions, & sim_block_definitions, & @@ -40,6 +45,8 @@ function param_definitions(component, subcomponent) result(input_definition) input_definition => gwf_param_definitions(subcomponent) case ('GWT') input_definition => gwt_param_definitions(subcomponent) + case ('GWE') + input_definition => gwe_param_definitions(subcomponent) case ('SIM') input_definition => sim_param_definitions(subcomponent) case default @@ -57,6 +64,8 @@ function aggregate_definitions(component, subcomponent) result(input_definition) input_definition => gwf_aggregate_definitions(subcomponent) case ('GWT') input_definition => gwt_aggregate_definitions(subcomponent) + case ('GWE') + input_definition => gwe_aggregate_definitions(subcomponent) case ('SIM') input_definition => sim_aggregate_definitions(subcomponent) case default @@ -74,6 +83,8 @@ function block_definitions(component, subcomponent) result(input_definition) input_definition => gwf_block_definitions(subcomponent) case ('GWT') input_definition => gwt_block_definitions(subcomponent) + case ('GWE') + input_definition => gwe_block_definitions(subcomponent) case ('SIM') input_definition => sim_block_definitions(subcomponent) case default @@ -90,6 +101,8 @@ function idm_multi_package(component, subcomponent) result(multi_package) multi_package = gwf_idm_multi_package(subcomponent) case ('GWT') multi_package = gwt_idm_multi_package(subcomponent) + case ('GWE') + multi_package = gwe_idm_multi_package(subcomponent) case ('SIM') multi_package = sim_idm_multi_package(subcomponent) case default @@ -110,6 +123,8 @@ function idm_integrated(component, subcomponent) result(integrated) integrated = gwf_idm_integrated(subcomponent) case ('GWT') integrated = gwt_idm_integrated(subcomponent) + case ('GWE') + integrated = gwe_idm_integrated(subcomponent) case ('SIM') integrated = sim_idm_integrated(subcomponent) case default diff --git a/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 b/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 new file mode 100644 index 00000000000..c92458b82e9 --- /dev/null +++ b/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 @@ -0,0 +1,96 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** +module IdmGweDfnSelectorModule + + use SimModule, only: store_error + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + use GweNamInputModule, only: gwe_nam_param_definitions, & + gwe_nam_aggregate_definitions, & + gwe_nam_block_definitions, & + gwe_nam_multi_package + + implicit none + private + public :: gwe_param_definitions + public :: gwe_aggregate_definitions + public :: gwe_block_definitions + public :: gwe_idm_multi_package + public :: gwe_idm_integrated + +contains + + subroutine set_param_pointer(input_dfn, input_dfn_target) + type(InputParamDefinitionType), dimension(:), pointer :: input_dfn + type(InputParamDefinitionType), dimension(:), target :: input_dfn_target + input_dfn => input_dfn_target + end subroutine set_param_pointer + + subroutine set_block_pointer(input_dfn, input_dfn_target) + type(InputBlockDefinitionType), dimension(:), pointer :: input_dfn + type(InputBlockDefinitionType), dimension(:), target :: input_dfn_target + input_dfn => input_dfn_target + end subroutine set_block_pointer + + function gwe_param_definitions(subcomponent) result(input_definition) + character(len=*), intent(in) :: subcomponent + type(InputParamDefinitionType), dimension(:), pointer :: input_definition + nullify (input_definition) + select case (subcomponent) + case ('NAM') + call set_param_pointer(input_definition, gwe_nam_param_definitions) + case default + end select + return + end function gwe_param_definitions + + function gwe_aggregate_definitions(subcomponent) result(input_definition) + character(len=*), intent(in) :: subcomponent + type(InputParamDefinitionType), dimension(:), pointer :: input_definition + nullify (input_definition) + select case (subcomponent) + case ('NAM') + call set_param_pointer(input_definition, gwe_nam_aggregate_definitions) + case default + end select + return + end function gwe_aggregate_definitions + + function gwe_block_definitions(subcomponent) result(input_definition) + character(len=*), intent(in) :: subcomponent + type(InputBlockDefinitionType), dimension(:), pointer :: input_definition + nullify (input_definition) + select case (subcomponent) + case ('NAM') + call set_block_pointer(input_definition, gwe_nam_block_definitions) + case default + end select + return + end function gwe_block_definitions + + function gwe_idm_multi_package(subcomponent) result(multi_package) + character(len=*), intent(in) :: subcomponent + logical :: multi_package + select case (subcomponent) + case ('NAM') + multi_package = gwe_nam_multi_package + case default + call store_error('Idm selector subcomponent not found; '//& + &'component="GWE"'//& + &', subcomponent="'//trim(subcomponent)//'".', .true.) + end select + return + end function gwe_idm_multi_package + + function gwe_idm_integrated(subcomponent) result(integrated) + character(len=*), intent(in) :: subcomponent + logical :: integrated + integrated = .false. + select case (subcomponent) + case ('NAM') + integrated = .true. + case default + end select + return + end function gwe_idm_integrated + +end module IdmGweDfnSelectorModule diff --git a/utils/idmloader/scripts/dfn2f90.py b/utils/idmloader/scripts/dfn2f90.py index f96ffe0f52d..5a7d2587e23 100644 --- a/utils/idmloader/scripts/dfn2f90.py +++ b/utils/idmloader/scripts/dfn2f90.py @@ -837,6 +837,10 @@ def _write_master_integration(self, fh=None): Path("../../../doc/mf6io/mf6ivar/dfn", "gwt-nam.dfn"), Path("../../../src/Model/GroundWaterTransport", "gwt1idm.f90"), ], + [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwe-nam.dfn"), + Path("../../../src/Model/GroundWaterEnergy", "gwe1idm.f90"), + ], [ Path("../../../doc/mf6io/mf6ivar/dfn", "sim-nam.dfn"), Path("../../../src", "simnamidm.f90"), From 00a64b9d8bddcb466f83d261ab2f3d3421bbb265 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 13:51:53 -0700 Subject: [PATCH 114/212] Update to a GWE autotest --- autotest/test_gwe_dsp.py | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/autotest/test_gwe_dsp.py b/autotest/test_gwe_dsp.py index b3281f37ca9..6af6c0d9b32 100644 --- a/autotest/test_gwe_dsp.py +++ b/autotest/test_gwe_dsp.py @@ -34,10 +34,9 @@ msg += " pip install flopy" raise Exception(msg) -import targets -from framework import testing_framework -from simulation import Simulation +from framework import TestFramework +from simulation import TestSimulation # Base simulation and model name and workspace @@ -94,6 +93,11 @@ dispersivity = 1.0 dmcoef = 3.2519e-7 # Molecular diffusion coefficient +# Set some static heat transport related model parameter values +cpw = 4183.0 +rhow = 1000.0 +lhv = 2454.0 + # Set solver parameter values (and related) nouter, ninner = 100, 300 hclose, rclose, relax = 1e-6, 1e-6, 1.0 @@ -232,8 +236,8 @@ def build_model(idx, dir): head_filerecord="{}.hds".format(gwfname), budget_filerecord="{}.cbc".format(gwfname), headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], - saverecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], - printrecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], ) # Instantiating MODFLOW 6 groundwater transport package @@ -264,6 +268,7 @@ def build_model(idx, dir): # Instantiating MODFLOW 6 transport discretization package flopy.mf6.ModflowGwedis( gwe, + nogrb=True, nlay=nlay, nrow=nrow, ncol=ncol, @@ -308,10 +313,9 @@ def build_model(idx, dir): gwe, save_flows=True, porosity=prsity, - cpw=4183.0, cps=760.0, - rhow=1000.0, rhos=1500.0, + packagedata=[cpw, rhow, lhv], filename="{}.mst".format(gwename), ) @@ -338,8 +342,8 @@ def build_model(idx, dir): temperatureprintrecord=[ ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") ], - saverecord=[("TEMPERATURE", "LAST"), ("BUDGET", "LAST")], - printrecord=[("TEMPERATURE", "LAST"), ("BUDGET", "LAST")], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], ) # Instantiating MODFLOW 6 flow-transport exchange mechanism @@ -487,10 +491,10 @@ def eval_model(sim): ) def test_mf6model(idx, dir): # initialize testing framework - test = testing_framework() + test = TestFramework() # build the model - test.build_mf6_models(build_model, idx, dir) + test.build(build_model, idx, dir) # run the test model test.run_mf6(Simulation(dir, exfunc=eval_model, idxsim=idx)) @@ -498,7 +502,7 @@ def test_mf6model(idx, dir): def main(): # initialize testing framework - test = testing_framework() + test = TestFramework() # run the test model for idx, dir in enumerate(exdirs): From c6c2d01443e03d7402593e2eeb0eefdead440731 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 16:01:18 -0700 Subject: [PATCH 115/212] Virtual gwe model support (not sure how I was able to run the autotests before) --- src/Distributed/VirtualDataContainer.f90 | 14 +- src/Distributed/VirtualGweExchange.f90 | 109 +++++++++++++ src/Distributed/VirtualGweModel.f90 | 199 +++++++++++++++++++++++ 3 files changed, 318 insertions(+), 4 deletions(-) create mode 100644 src/Distributed/VirtualGweExchange.f90 create mode 100644 src/Distributed/VirtualGweModel.f90 diff --git a/src/Distributed/VirtualDataContainer.f90 b/src/Distributed/VirtualDataContainer.f90 index 1a49f66b8d7..a3923980136 100644 --- a/src/Distributed/VirtualDataContainer.f90 +++ b/src/Distributed/VirtualDataContainer.f90 @@ -16,10 +16,13 @@ module VirtualDataContainerModule integer(I4B), public, parameter :: VDC_UNKNOWN_TYPE = 0 integer(I4B), public, parameter :: VDC_GWFMODEL_TYPE = 1 integer(I4B), public, parameter :: VDC_GWTMODEL_TYPE = 2 - integer(I4B), public, parameter :: VDC_GWFEXG_TYPE = 3 - integer(I4B), public, parameter :: VDC_GWTEXG_TYPE = 4 - integer(I4B), public, parameter :: VDC_GWFMVR_TYPE = 5 - integer(I4B), public, parameter :: VDC_GWTMVT_TYPE = 6 + integer(I4B), public, parameter :: VDC_GWEMODEL_TYPE = 3 + integer(I4B), public, parameter :: VDC_GWFEXG_TYPE = 4 + integer(I4B), public, parameter :: VDC_GWTEXG_TYPE = 5 + integer(I4B), public, parameter :: VDC_GWEEXG_TYPE = 6 + integer(I4B), public, parameter :: VDC_GWFMVR_TYPE = 7 + integer(I4B), public, parameter :: VDC_GWTMVT_TYPE = 8 + integer(I4B), public, parameter :: VDC_GWEMVT_TYPE = 9 !> @brief Wrapper for virtual data containers !! @@ -446,10 +449,13 @@ function VDC_TYPE_TO_STR(cntr_type) result(cntr_str) if (cntr_type == VDC_UNKNOWN_TYPE) then; cntr_str = "unknown" else if (cntr_type == VDC_GWFMODEL_TYPE) then; cntr_str = "GWF Model" else if (cntr_type == VDC_GWTMODEL_TYPE) then; cntr_str = "GWT Model" + else if (cntr_type == VDC_GWEMODEL_TYPE) then; cntr_str = "GWE Model" else if (cntr_type == VDC_GWFEXG_TYPE) then; cntr_str = "GWF Exchange" else if (cntr_type == VDC_GWTEXG_TYPE) then; cntr_str = "GWT Exchange" + else if (cntr_type == VDC_GWEEXG_TYPE) then; cntr_str = "GWE Exchange" else if (cntr_type == VDC_GWFMVR_TYPE) then; cntr_str = "GWF Mover" else if (cntr_type == VDC_GWTMVT_TYPE) then; cntr_str = "GWT Mover" + else if (cntr_type == VDC_GWEMVT_TYPE) then; cntr_str = "GWE Mover" else; cntr_str = "Undefined" end if diff --git a/src/Distributed/VirtualGweExchange.f90 b/src/Distributed/VirtualGweExchange.f90 new file mode 100644 index 00000000000..2cb9b6483c2 --- /dev/null +++ b/src/Distributed/VirtualGweExchange.f90 @@ -0,0 +1,109 @@ +module VirtualGweExchangeModule + use KindModule, only: I4B + use SimStagesModule + use VirtualBaseModule + use VirtualDataListsModule, only: virtual_exchange_list + use VirtualDataContainerModule, only: VDC_GWEEXG_TYPE + use VirtualExchangeModule + implicit none + private + + public :: add_virtual_gwe_exchange + + type, public, extends(VirtualExchangeType) :: VirtualGweExchangeType + type(VirtualDbl1dType), pointer :: gwfsimvals => null() + contains + procedure :: create => vtx_create + procedure :: destroy => vtx_destroy + procedure :: prepare_stage => vtx_prepare_stage + ! private + procedure, private :: init_virtual_data + procedure, private :: allocate_data + procedure, private :: deallocate_data + end type VirtualGweExchangeType + +contains + +!> @brief Add a virtual GWE-GWE exchange to the simulation +!< + subroutine add_virtual_gwe_exchange(name, exchange_id, model1_id, model2_id) + character(len=*) :: name + integer(I4B) :: exchange_id + integer(I4B) :: model1_id + integer(I4B) :: model2_id + ! local + class(VirtualGweExchangeType), pointer :: v_exg + class(*), pointer :: obj_ptr + + allocate (v_exg) + call v_exg%create(name, exchange_id, model1_id, model2_id) + + obj_ptr => v_exg + call virtual_exchange_list%Add(obj_ptr) + + end subroutine add_virtual_gwe_exchange + +!> @brief Create a virtual GWE-GWE exchange +!< + subroutine vtx_create(this, name, exg_id, m1_id, m2_id) + class(VirtualGweExchangeType) :: this + character(len=*) :: name + integer(I4B) :: exg_id + integer(I4B) :: m1_id + integer(I4B) :: m2_id + + ! create base + call this%VirtualExchangeType%create(name, exg_id, m1_id, m2_id) + this%container_type = VDC_GWEEXG_TYPE + + call this%allocate_data() + call this%init_virtual_data() + + end subroutine vtx_create + + subroutine init_virtual_data(this) + class(VirtualGweExchangeType) :: this + + call this%set(this%gwfsimvals%base(), 'GWFSIMVALS', '', MAP_ALL_TYPE) + + end subroutine init_virtual_data + + subroutine vtx_prepare_stage(this, stage) + class(VirtualGweExchangeType) :: this + integer(I4B) :: stage + ! local + integer(I4B) :: nexg + + ! prepare base exchange data items + call this%VirtualExchangeType%prepare_stage(stage) + + if (stage == STG_BFR_CON_AR) then + nexg = this%nexg%get() + call this%map(this%gwfsimvals%base(), nexg, (/STG_BFR_EXG_AD/)) + end if + + end subroutine vtx_prepare_stage + + subroutine vtx_destroy(this) + class(VirtualGweExchangeType) :: this + + call this%VirtualExchangeType%destroy() + call this%deallocate_data() + + end subroutine vtx_destroy + + subroutine allocate_data(this) + class(VirtualGweExchangeType) :: this + + allocate (this%gwfsimvals) + + end subroutine allocate_data + + subroutine deallocate_data(this) + class(VirtualGweExchangeType) :: this + + deallocate (this%gwfsimvals) + + end subroutine deallocate_data + +end module VirtualGweExchangeModule diff --git a/src/Distributed/VirtualGweModel.f90 b/src/Distributed/VirtualGweModel.f90 new file mode 100644 index 00000000000..2d606195d7a --- /dev/null +++ b/src/Distributed/VirtualGweModel.f90 @@ -0,0 +1,199 @@ +module VirtualGweModelModule + use KindModule, only: I4B + use SimStagesModule + use VirtualBaseModule + use VirtualDataContainerModule, only: VDC_GWEMODEL_TYPE + use VirtualModelModule + use NumericalModelModule, only: NumericalModelType + implicit none + private + + public :: add_virtual_gwe_model + + type, extends(VirtualModelType) :: VirtualGweModelType + ! DSP + type(VirtualIntType), pointer :: dsp_idiffc => null() + type(VirtualIntType), pointer :: dsp_idisp => null() + type(VirtualDbl1dType), pointer :: dsp_diffc => null() + type(VirtualDbl1dType), pointer :: dsp_alh => null() + type(VirtualDbl1dType), pointer :: dsp_alv => null() + type(VirtualDbl1dType), pointer :: dsp_ath1 => null() + type(VirtualDbl1dType), pointer :: dsp_ath2 => null() + type(VirtualDbl1dType), pointer :: dsp_atv => null() + ! FMI + type(VirtualDbl1dType), pointer :: fmi_gwfhead => null() + type(VirtualDbl1dType), pointer :: fmi_gwfsat => null() + type(VirtualDbl2dType), pointer :: fmi_gwfspdis => null() + type(VirtualDbl1dType), pointer :: fmi_gwfflowja => null() + ! MST + type(VirtualDbl1dType), pointer :: mst_porosity => null() + ! GWE Model fields + type(VirtualIntType), pointer :: indsp => null() + type(VirtualIntType), pointer :: inmst => null() + contains + ! public + procedure :: create => vgwe_create + procedure :: prepare_stage => vgwe_prepare_stage + procedure :: destroy => vgwe_destroy + ! private + procedure, private :: init_virtual_data + procedure, private :: allocate_data + procedure, private :: deallocate_data + end type VirtualGweModelType + +contains + + subroutine add_virtual_gwe_model(model_id, model_name, model) + use VirtualDataListsModule, only: virtual_model_list + integer(I4B) :: model_id !< global model id + character(len=*) :: model_name !< model name + class(NumericalModelType), pointer :: model !< the actual model (can be null() when remote) + ! local + class(VirtualGweModelType), pointer :: virtual_gwe_model + class(*), pointer :: obj + + allocate (virtual_gwe_model) + call virtual_gwe_model%create(model_name, model_id, model) + + obj => virtual_gwe_model + call virtual_model_list%Add(obj) + + end subroutine add_virtual_gwe_model + + subroutine vgwe_create(this, name, id, model) + class(VirtualGweModelType) :: this + character(len=*) :: name + integer(I4B) :: id + class(NumericalModelType), pointer :: model + + ! create base + call this%VirtualModelType%create(name, id, model) + this%container_type = VDC_GWEMODEL_TYPE + + call this%allocate_data() + call this%init_virtual_data() + + end subroutine vgwe_create + + subroutine init_virtual_data(this) + class(VirtualGweModelType) :: this + + !call this%set(this%dsp_idiffc%base(), 'IDIFFC', 'DSP', MAP_ALL_TYPE) + call this%set(this%dsp_idisp%base(), 'IDISP', 'DSP', MAP_ALL_TYPE) + !call this%set(this%dsp_diffc%base(), 'DIFFC', 'DSP', MAP_NODE_TYPE) + call this%set(this%dsp_alh%base(), 'ALH', 'DSP', MAP_NODE_TYPE) + call this%set(this%dsp_alv%base(), 'ALV', 'DSP', MAP_NODE_TYPE) + call this%set(this%dsp_ath1%base(), 'ATH1', 'DSP', MAP_NODE_TYPE) + call this%set(this%dsp_ath2%base(), 'ATH2', 'DSP', MAP_NODE_TYPE) + call this%set(this%dsp_atv%base(), 'ATV', 'DSP', MAP_NODE_TYPE) + call this%set(this%fmi_gwfhead%base(), 'GWFHEAD', 'FMI', MAP_NODE_TYPE) + call this%set(this%fmi_gwfsat%base(), 'GWFSAT', 'FMI', MAP_NODE_TYPE) + call this%set(this%fmi_gwfspdis%base(), 'GWFSPDIS', 'FMI', MAP_NODE_TYPE) + call this%set(this%fmi_gwfflowja%base(), 'GWFFLOWJA', 'FMI', MAP_NODE_TYPE) + call this%set(this%mst_porosity%base(), 'POROSITY', 'MST', MAP_NODE_TYPE) + call this%set(this%indsp%base(), 'INDSP', '', MAP_ALL_TYPE) + call this%set(this%inmst%base(), 'INMST', '', MAP_ALL_TYPE) + + end subroutine init_virtual_data + + subroutine vgwe_prepare_stage(this, stage) + class(VirtualGweModelType) :: this + integer(I4B) :: stage + ! local + integer(I4B) :: nr_nodes, nr_conns + + ! prepare base (=numerical) model data items + call this%VirtualModelType%prepare_stage(stage) + + nr_nodes = 0 + nr_conns = 0 + + if (stage == STG_AFT_MDL_DF) then + + !call this%map(this%dsp_idiffc%base(), (/STG_AFT_MDL_DF/)) + call this%map(this%dsp_idisp%base(), (/STG_AFT_MDL_DF/)) + call this%map(this%indsp%base(), (/STG_AFT_MDL_DF/)) + call this%map(this%inmst%base(), (/STG_AFT_MDL_DF/)) + + else if (stage == STG_BFR_CON_AR) then + + call this%map(this%x%base(), nr_nodes, & + (/STG_BFR_CON_AR, STG_BFR_EXG_AD, STG_BFR_EXG_CF/)) + call this%map(this%ibound%base(), nr_nodes, (/STG_BFR_CON_AR/)) + + !if (this%dsp_idiffc%get() > 0) then + ! call this%map(this%dsp_diffc%base(), nr_nodes, (/STG_BFR_CON_AR/)) + !end if + + if (this%dsp_idisp%get() > 0) then + call this%map(this%dsp_alh%base(), nr_nodes, (/STG_BFR_CON_AR/)) + call this%map(this%dsp_alv%base(), nr_nodes, (/STG_BFR_CON_AR/)) + call this%map(this%dsp_ath1%base(), nr_nodes, (/STG_BFR_CON_AR/)) + call this%map(this%dsp_ath2%base(), nr_nodes, (/STG_BFR_CON_AR/)) + call this%map(this%dsp_atv%base(), nr_nodes, (/STG_BFR_CON_AR/)) + end if + + call this%map(this%fmi_gwfhead%base(), nr_nodes, (/STG_BFR_EXG_AD/)) + call this%map(this%fmi_gwfsat%base(), nr_nodes, (/STG_BFR_EXG_AD/)) + call this%map(this%fmi_gwfspdis%base(), 3, nr_nodes, (/STG_BFR_EXG_AD/)) + call this%map(this%fmi_gwfflowja%base(), nr_conns, (/STG_BFR_EXG_AD/)) + + if (this%indsp%get() > 0 .and. this%inmst%get() > 0) then + call this%map(this%mst_porosity%base(), nr_nodes, (/STG_AFT_CON_AR/)) + end if + + end if + + end subroutine vgwe_prepare_stage + + subroutine allocate_data(this) + class(VirtualGweModelType) :: this + + !allocate (this%dsp_idiffc) + allocate (this%dsp_idisp) + !allocate (this%dsp_diffc) + allocate (this%dsp_alh) + allocate (this%dsp_alv) + allocate (this%dsp_ath1) + allocate (this%dsp_ath2) + allocate (this%dsp_atv) + allocate (this%fmi_gwfhead) + allocate (this%fmi_gwfsat) + allocate (this%fmi_gwfspdis) + allocate (this%fmi_gwfflowja) + allocate (this%mst_porosity) + allocate (this%indsp) + allocate (this%inmst) + + end subroutine allocate_data + + subroutine deallocate_data(this) + class(VirtualGweModelType) :: this + + !deallocate (this%dsp_idiffc) + deallocate (this%dsp_idisp) + !deallocate (this%dsp_diffc) + deallocate (this%dsp_alh) + deallocate (this%dsp_alv) + deallocate (this%dsp_ath1) + deallocate (this%dsp_ath2) + deallocate (this%dsp_atv) + deallocate (this%fmi_gwfhead) + deallocate (this%fmi_gwfsat) + deallocate (this%fmi_gwfspdis) + deallocate (this%fmi_gwfflowja) + deallocate (this%mst_porosity) + deallocate (this%indsp) + deallocate (this%inmst) + + end subroutine deallocate_data + + subroutine vgwe_destroy(this) + class(VirtualGweModelType) :: this + + call this%VirtualModelType%destroy() + call this%deallocate_data() + + end subroutine vgwe_destroy + +end module VirtualGweModelModule From 1d2c28e8baae1c3a34dd9ddca6494740320c2514 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 18 Apr 2023 16:19:38 -0700 Subject: [PATCH 116/212] More post gwe/develop merge debugging --- src/Model/GroundWaterEnergy/gwe1.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index d53af36fd83..d7fad6b4662 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1395,8 +1395,8 @@ subroutine create_gwe_specific_packages(this, indis) ! this%eqnsclfac) call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & this%fmi, this%eqnsclfac, this%gwecommon) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & - this%tsplab, this%eqnsclfac, this%gwecommon) + !call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & + ! this%tsplab, this%eqnsclfac, this%gwecommon) !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & ! this%eqnsclfac) !call oc_cr(this%oc, this%name, this%inoc, this%iout) From 46a015cacbfedfe6411193571945882692cb3eec Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 06:38:26 -0700 Subject: [PATCH 117/212] Some more shuffling around of code between gwe.f90 & gwt.f90 and the generalized transport class (transportModel.f90) --- src/Model/GroundWaterEnergy/gwe1.f90 | 432 ++++++++++++------------ src/Model/GroundWaterTransport/gwt1.f90 | 429 +++++++++++------------ src/Model/TransportModel.f90 | 23 +- 3 files changed, 451 insertions(+), 433 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index d7fad6b4662..6d9d333117c 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -32,9 +32,9 @@ module GweModule !integer(I4B), pointer :: inic => null() ! unit number IC !integer(I4B), pointer :: infmi => null() ! unit number FMI !integer(I4B), pointer :: inmvt => null() ! unit number MVT - !integer(I4B), pointer :: inmst => null() ! unit number MST + integer(I4B), pointer :: inmst => null() ! unit number MST !integer(I4B), pointer :: inadv => null() ! unit number ADV - !integer(I4B), pointer :: indsp => null() ! unit number DSP + integer(I4B), pointer :: indsp => null() ! unit number DSP !integer(I4B), pointer :: inssm => null() ! unit number SSM !integer(I4B), pointer :: inoc => null() ! unit number OC !integer(I4B), pointer :: inobs => null() ! unit number OBS @@ -60,11 +60,11 @@ module GweModule procedure, private :: package_create !procedure, private :: ftype_check procedure :: get_iasym => gwe_get_iasym - procedure, private :: gwe_ot_flow - procedure, private :: gwe_ot_flowja - procedure, private :: gwe_ot_dv - procedure, private :: gwe_ot_bdsummary - procedure, private :: gwe_ot_obs + !procedure, private :: gwe_ot_flow + !procedure, private :: gwe_ot_flowja + !procedure, private :: gwe_ot_dv + !procedure, private :: gwe_ot_bdsummary + !procedure, private :: gwe_ot_obs procedure, private :: create_gwe_specific_packages procedure, private :: create_bndpkgs !procedure, private :: create_lstfile @@ -142,6 +142,7 @@ subroutine gwe_cr(filename, id, modelname) this%memoryPath = create_mem_path(modelname) ! call this%allocate_tsp_scalars(modelname) + call this%allocate_gwe_scalars(modelname) model => this call AddBaseModelToList(basemodellist, model) ! @@ -683,217 +684,220 @@ subroutine gwe_ot(this) use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(GweModelType) :: this - ! -- local - integer(I4B) :: idvsave - integer(I4B) :: idvprint - integer(I4B) :: icbcfl - integer(I4B) :: icbcun - integer(I4B) :: ibudfl - integer(I4B) :: ipflag - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & - &I0,' OF STRESS PERIOD ',I0,'****')" +! ! -- local +! integer(I4B) :: idvsave +! integer(I4B) :: idvprint +! integer(I4B) :: icbcfl +! integer(I4B) :: icbcun +! integer(I4B) :: ibudfl +! integer(I4B) :: ipflag +! ! -- formats +! character(len=*), parameter :: fmtnocnvg = & +! "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & +! &I0,' OF STRESS PERIOD ',I0,'****')" ! ------------------------------------------------------------------------------ ! - ! -- Set write and print flags - idvsave = 0 - idvprint = 0 - icbcfl = 0 - ibudfl = 0 - if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 - if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 - if (this%oc%oc_save('BUDGET')) icbcfl = 1 - if (this%oc%oc_print('BUDGET')) ibudfl = 1 - icbcun = this%oc%oc_save_unit('BUDGET') - ! - ! -- Override ibudfl and idvprint flags for nonconvergence - ! and end of period - ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & - this%icnvg, endofperiod) - ! - ! Calculate and save observations - call this%gwe_ot_obs() - ! - ! Save and print flows - call this%gwe_ot_flow(icbcfl, ibudfl, icbcun) - ! - ! Save and print dependent variables - call this%gwe_ot_dv(idvsave, idvprint, ipflag) - ! - ! Print budget summaries - call this%gwe_ot_bdsummary(ibudfl, ipflag) - ! - ! -- Timing Output; if any dependendent variables or budgets - ! are printed, then ipflag is set to 1. - if (ipflag == 1) call tdis_ot(this%iout) - ! - ! -- Write non-convergence message - if (this%icnvg == 0) then - write (this%iout, fmtnocnvg) kstp, kper - end if + ! -- Call parent class _ot routines. + call this%tsp_ot(this%inmst) +! ! +! ! -- Set write and print flags +! idvsave = 0 +! idvprint = 0 +! icbcfl = 0 +! ibudfl = 0 +! if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 +! if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 +! if (this%oc%oc_save('BUDGET')) icbcfl = 1 +! if (this%oc%oc_print('BUDGET')) ibudfl = 1 +! icbcun = this%oc%oc_save_unit('BUDGET') +! ! +! ! -- Override ibudfl and idvprint flags for nonconvergence +! ! and end of period +! ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) +! idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & +! this%icnvg, endofperiod) +! ! +! ! Calculate and save observations +! call this%gwe_ot_obs() +! ! +! ! Save and print flows +! call this%gwe_ot_flow(icbcfl, ibudfl, icbcun) +! ! +! ! Save and print dependent variables +! call this%gwe_ot_dv(idvsave, idvprint, ipflag) +! ! +! ! Print budget summaries +! call this%gwe_ot_bdsummary(ibudfl, ipflag) +! ! +! ! -- Timing Output; if any dependendent variables or budgets +! ! are printed, then ipflag is set to 1. +! if (ipflag == 1) call tdis_ot(this%iout) +! ! +! ! -- Write non-convergence message +! if (this%icnvg == 0) then +! write (this%iout, fmtnocnvg) kstp, kper +! end if ! ! -- Return return end subroutine gwe_ot - - subroutine gwe_ot_obs(this) - class(GweModelType) :: this - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Calculate and save observations - call this%obs%obs_bd() - call this%obs%obs_ot() - - ! -- Calculate and save package obserations - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_bd_obs() - call packobj%bnd_ot_obs() - end do - - end subroutine gwe_ot_obs - - subroutine gwe_ot_flow(this, icbcfl, ibudfl, icbcun) - class(GweModelType) :: this - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Save GWE flows - call this%gwe_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) - if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) - if (this%inssm > 0) then - call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) - end if - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) - end do - - ! -- Save advanced package flows - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) - end do - if (this%inmvt > 0) then - call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) - end if - - ! -- Print GWF flows - ! no need to print flowja - ! no need to print mst - ! no need to print fmi - if (this%inssm > 0) then - call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) - end if - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) - end do - - ! -- Print advanced package flows - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) - end do - if (this%inmvt > 0) then - call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) - end if - - end subroutine gwe_ot_flow - - subroutine gwe_ot_flowja(this, nja, flowja, icbcfl, icbcun) -! ****************************************************************************** -! gwe_ot_flowja -- Write intercell flows -! ****************************************************************************** ! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GweModelType) :: this - integer(I4B), intent(in) :: nja - real(DP), dimension(nja), intent(in) :: flowja - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: icbcun - ! -- local - integer(I4B) :: ibinun - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Set unit number for binary output - if (this%ipakcb < 0) then - ibinun = icbcun - elseif (this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - end if - if (icbcfl == 0) ibinun = 0 - ! - ! -- Write the face flows if requested - if (ibinun /= 0) then - call this%dis%record_connection_array(flowja, ibinun, this%iout) - end if - ! - ! -- Return - return - end subroutine gwe_ot_flowja - - subroutine gwe_ot_dv(this, idvsave, idvprint, ipflag) - class(GweModelType) :: this - integer(I4B), intent(in) :: idvsave - integer(I4B), intent(in) :: idvprint - integer(I4B), intent(inout) :: ipflag - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Print advanced package dependent variables - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_dv(idvsave, idvprint) - end do - - ! -- save head and print head - call this%oc%oc_ot(ipflag) - - end subroutine gwe_ot_dv - - subroutine gwe_ot_bdsummary(this, ibudfl, ipflag) - use TdisModule, only: kstp, kper, totim - class(GweModelType) :: this - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(inout) :: ipflag - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! - ! -- Package budget summary - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) - end do - - ! -- mover budget summary - if (this%inmvt > 0) then - call this%mvt%mvt_ot_bdsummary(ibudfl) - end if - - ! -- model budget summary - if (ibudfl /= 0) then - ipflag = 1 - call this%budget%budget_ot(kstp, kper, this%iout) - end if - - ! -- Write to budget csv - call this%budget%writecsv(totim) - - end subroutine gwe_ot_bdsummary +! subroutine gwe_ot_obs(this) +! class(GweModelType) :: this +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! -- Calculate and save observations +! call this%obs%obs_bd() +! call this%obs%obs_ot() +! +! ! -- Calculate and save package obserations +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_bd_obs() +! call packobj%bnd_ot_obs() +! end do +! +! end subroutine gwe_ot_obs +! +! subroutine gwe_ot_flow(this, icbcfl, ibudfl, icbcun) +! class(GweModelType) :: this +! integer(I4B), intent(in) :: icbcfl +! integer(I4B), intent(in) :: ibudfl +! integer(I4B), intent(in) :: icbcun +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! -- Save GWE flows +! call this%gwe_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) +! if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) +! if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) +! if (this%inssm > 0) then +! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) +! end if +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) +! end do +! +! ! -- Save advanced package flows +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) +! end do +! if (this%inmvt > 0) then +! call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) +! end if +! +! ! -- Print GWF flows +! ! no need to print flowja +! ! no need to print mst +! ! no need to print fmi +! if (this%inssm > 0) then +! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) +! end if +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) +! end do +! +! ! -- Print advanced package flows +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) +! end do +! if (this%inmvt > 0) then +! call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) +! end if +! +! end subroutine gwe_ot_flow +! +! subroutine gwe_ot_flowja(this, nja, flowja, icbcfl, icbcun) +!! ****************************************************************************** +!! gwe_ot_flowja -- Write intercell flows +!! ****************************************************************************** +!! +!! SPECIFICATIONS: +!! ------------------------------------------------------------------------------ +! ! -- dummy +! class(GweModelType) :: this +! integer(I4B), intent(in) :: nja +! real(DP), dimension(nja), intent(in) :: flowja +! integer(I4B), intent(in) :: icbcfl +! integer(I4B), intent(in) :: icbcun +! ! -- local +! integer(I4B) :: ibinun +! ! -- formats +!! ------------------------------------------------------------------------------ +! ! +! ! -- Set unit number for binary output +! if (this%ipakcb < 0) then +! ibinun = icbcun +! elseif (this%ipakcb == 0) then +! ibinun = 0 +! else +! ibinun = this%ipakcb +! end if +! if (icbcfl == 0) ibinun = 0 +! ! +! ! -- Write the face flows if requested +! if (ibinun /= 0) then +! call this%dis%record_connection_array(flowja, ibinun, this%iout) +! end if +! ! +! ! -- Return +! return +! end subroutine gwe_ot_flowja +! +! subroutine gwe_ot_dv(this, idvsave, idvprint, ipflag) +! class(GweModelType) :: this +! integer(I4B), intent(in) :: idvsave +! integer(I4B), intent(in) :: idvprint +! integer(I4B), intent(inout) :: ipflag +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! -- Print advanced package dependent variables +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_dv(idvsave, idvprint) +! end do +! +! ! -- save head and print head +! call this%oc%oc_ot(ipflag) +! +! end subroutine gwe_ot_dv +! +! subroutine gwe_ot_bdsummary(this, ibudfl, ipflag) +! use TdisModule, only: kstp, kper, totim +! class(GweModelType) :: this +! integer(I4B), intent(in) :: ibudfl +! integer(I4B), intent(inout) :: ipflag +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! +! ! -- Package budget summary +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) +! end do +! +! ! -- mover budget summary +! if (this%inmvt > 0) then +! call this%mvt%mvt_ot_bdsummary(ibudfl) +! end if +! +! ! -- model budget summary +! if (ibudfl /= 0) then +! ipflag = 1 +! call this%budget%budget_ot(kstp, kper, this%iout) +! end if +! +! ! -- Write to budget csv +! call this%budget%writecsv(totim) +! +! end subroutine gwe_ot_bdsummary subroutine gwe_da(this) ! ****************************************************************************** @@ -912,6 +916,10 @@ subroutine gwe_da(this) integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Scalars + call mem_deallocate(this%inmst) + call mem_deallocate(this%indsp) ! ! -- Deallocate idm memory call memorylist_remove(this%name, 'NAM', idm_context) @@ -1403,7 +1411,7 @@ subroutine create_gwe_specific_packages(this, indis) !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified - call this%ftype_check(indis) + call this%ftype_check(indis, this%inmst) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 00d3e83cc26..abf0020d30f 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -34,9 +34,9 @@ module GwtModule ! integer(I4B), pointer :: inic => null() ! unit number IC ! integer(I4B), pointer :: infmi => null() ! unit number FMI ! integer(I4B), pointer :: inmvt => null() ! unit number MVT - ! integer(I4B), pointer :: inmst => null() ! unit number MST + integer(I4B), pointer :: inmst => null() ! unit number MST ! integer(I4B), pointer :: inadv => null() ! unit number ADV - ! integer(I4B), pointer :: indsp => null() ! unit number DSP + integer(I4B), pointer :: indsp => null() ! unit number DSP ! integer(I4B), pointer :: inssm => null() ! unit number SSM ! integer(I4B), pointer :: inoc => null() ! unit number OC ! integer(I4B), pointer :: inobs => null() ! unit number OBS @@ -62,11 +62,11 @@ module GwtModule procedure, private :: package_create !procedure, private :: ftype_check procedure :: get_iasym => gwt_get_iasym - procedure, private :: gwt_ot_flow - procedure, private :: gwt_ot_flowja - procedure, private :: gwt_ot_dv - procedure, private :: gwt_ot_bdsummary - procedure, private :: gwt_ot_obs + !procedure, private :: gwt_ot_flow + !procedure, private :: gwt_ot_flowja + !procedure, private :: gwt_ot_dv + !procedure, private :: gwt_ot_bdsummary + !procedure, private :: gwt_ot_obs procedure, private :: create_gwt_specific_packages procedure, private :: create_bndpkgs !procedure, private :: create_lstfile @@ -686,216 +686,219 @@ subroutine gwt_ot(this) ! -- dummy class(GwtModelType) :: this ! -- local - integer(I4B) :: idvsave - integer(I4B) :: idvprint - integer(I4B) :: icbcfl - integer(I4B) :: icbcun - integer(I4B) :: ibudfl - integer(I4B) :: ipflag - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & - &I0,' OF STRESS PERIOD ',I0,'****')" +! integer(I4B) :: idvsave +! integer(I4B) :: idvprint +! integer(I4B) :: icbcfl +! integer(I4B) :: icbcun +! integer(I4B) :: ibudfl +! integer(I4B) :: ipflag +! ! -- formats +! character(len=*), parameter :: fmtnocnvg = & +! "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & +! &I0,' OF STRESS PERIOD ',I0,'****')" ! ------------------------------------------------------------------------------ ! - ! -- Set write and print flags - idvsave = 0 - idvprint = 0 - icbcfl = 0 - ibudfl = 0 - if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 - if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 - if (this%oc%oc_save('BUDGET')) icbcfl = 1 - if (this%oc%oc_print('BUDGET')) ibudfl = 1 - icbcun = this%oc%oc_save_unit('BUDGET') - ! - ! -- Override ibudfl and idvprint flags for nonconvergence - ! and end of period - ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & - this%icnvg, endofperiod) - ! - ! Calculate and save observations - call this%gwt_ot_obs() - ! - ! Save and print flows - call this%gwt_ot_flow(icbcfl, ibudfl, icbcun) - ! - ! Save and print dependent variables - call this%gwt_ot_dv(idvsave, idvprint, ipflag) - ! - ! Print budget summaries - call this%gwt_ot_bdsummary(ibudfl, ipflag) - ! - ! -- Timing Output; if any dependendent variables or budgets - ! are printed, then ipflag is set to 1. - if (ipflag == 1) call tdis_ot(this%iout) - ! - ! -- Write non-convergence message - if (this%icnvg == 0) then - write (this%iout, fmtnocnvg) kstp, kper - end if + ! -- Call parent class _ot routines. + call this%tsp_ot(this%inmst) +! ! +! ! -- Set write and print flags +! idvsave = 0 +! idvprint = 0 +! icbcfl = 0 +! ibudfl = 0 +! if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 +! if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 +! if (this%oc%oc_save('BUDGET')) icbcfl = 1 +! if (this%oc%oc_print('BUDGET')) ibudfl = 1 +! icbcun = this%oc%oc_save_unit('BUDGET') +! ! +! ! -- Override ibudfl and idvprint flags for nonconvergence +! ! and end of period +! ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) +! idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & +! this%icnvg, endofperiod) +! ! +! ! Calculate and save observations +! call this%gwt_ot_obs() +! ! +! ! Save and print flows +! call this%gwt_ot_flow(icbcfl, ibudfl, icbcun) +! ! +! ! Save and print dependent variables +! call this%gwt_ot_dv(idvsave, idvprint, ipflag) +! ! +! ! Print budget summaries +! call this%gwt_ot_bdsummary(ibudfl, ipflag) +! ! +! ! -- Timing Output; if any dependendent variables or budgets +! ! are printed, then ipflag is set to 1. +! if (ipflag == 1) call tdis_ot(this%iout) +! ! +! ! -- Write non-convergence message +! if (this%icnvg == 0) then +! write (this%iout, fmtnocnvg) kstp, kper +! end if ! ! -- Return return end subroutine gwt_ot - - subroutine gwt_ot_obs(this) - class(GwtModelType) :: this - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Calculate and save observations - call this%obs%obs_bd() - call this%obs%obs_ot() - - ! -- Calculate and save package obserations - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_bd_obs() - call packobj%bnd_ot_obs() - end do - - end subroutine gwt_ot_obs - - subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) - class(GwtModelType) :: this - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Save GWT flows - call this%gwt_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) - if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) - if (this%inssm > 0) then - call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) - end if - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) - end do - - ! -- Save advanced package flows - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) - end do - if (this%inmvt > 0) then - call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) - end if - - ! -- Print GWF flows - ! no need to print flowja - ! no need to print mst - ! no need to print fmi - if (this%inssm > 0) then - call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) - end if - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) - end do - - ! -- Print advanced package flows - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) - end do - if (this%inmvt > 0) then - call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) - end if - - end subroutine gwt_ot_flow - - subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) -! ****************************************************************************** -! gwt_ot_flowja -- Write intercell flows -! ****************************************************************************** ! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwtModelType) :: this - integer(I4B), intent(in) :: nja - real(DP), dimension(nja), intent(in) :: flowja - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: icbcun - ! -- local - integer(I4B) :: ibinun - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Set unit number for binary output - if (this%ipakcb < 0) then - ibinun = icbcun - elseif (this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - end if - if (icbcfl == 0) ibinun = 0 - ! - ! -- Write the face flows if requested - if (ibinun /= 0) then - call this%dis%record_connection_array(flowja, ibinun, this%iout) - end if - ! - ! -- Return - return - end subroutine gwt_ot_flowja - - subroutine gwt_ot_dv(this, idvsave, idvprint, ipflag) - class(GwtModelType) :: this - integer(I4B), intent(in) :: idvsave - integer(I4B), intent(in) :: idvprint - integer(I4B), intent(inout) :: ipflag - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Print advanced package dependent variables - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_dv(idvsave, idvprint) - end do - - ! -- save head and print head - call this%oc%oc_ot(ipflag) - - end subroutine gwt_ot_dv - - subroutine gwt_ot_bdsummary(this, ibudfl, ipflag) - use TdisModule, only: kstp, kper, totim - class(GwtModelType) :: this - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(inout) :: ipflag - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! - ! -- Package budget summary - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) - end do - - ! -- mover budget summary - if (this%inmvt > 0) then - call this%mvt%mvt_ot_bdsummary(ibudfl) - end if - - ! -- model budget summary - if (ibudfl /= 0) then - ipflag = 1 - call this%budget%budget_ot(kstp, kper, this%iout) - end if - - ! -- Write to budget csv - call this%budget%writecsv(totim) - - end subroutine gwt_ot_bdsummary +! subroutine gwt_ot_obs(this) +! class(GwtModelType) :: this +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! -- Calculate and save observations +! call this%obs%obs_bd() +! call this%obs%obs_ot() +! +! ! -- Calculate and save package obserations +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_bd_obs() +! call packobj%bnd_ot_obs() +! end do +! +! end subroutine gwt_ot_obs +! +! subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) +! class(GwtModelType) :: this +! integer(I4B), intent(in) :: icbcfl +! integer(I4B), intent(in) :: ibudfl +! integer(I4B), intent(in) :: icbcun +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! -- Save GWT flows +! call this%gwt_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) +! if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) +! if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) +! if (this%inssm > 0) then +! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) +! end if +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) +! end do +! +! ! -- Save advanced package flows +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) +! end do +! if (this%inmvt > 0) then +! call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) +! end if +! +! ! -- Print GWF flows +! ! no need to print flowja +! ! no need to print mst +! ! no need to print fmi +! if (this%inssm > 0) then +! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) +! end if +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) +! end do +! +! ! -- Print advanced package flows +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) +! end do +! if (this%inmvt > 0) then +! call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) +! end if +! +! end subroutine gwt_ot_flow +! +! subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) +!! ****************************************************************************** +!! gwt_ot_flowja -- Write intercell flows +!! ****************************************************************************** +!! +!! SPECIFICATIONS: +!! ------------------------------------------------------------------------------ +! ! -- dummy +! class(GwtModelType) :: this +! integer(I4B), intent(in) :: nja +! real(DP), dimension(nja), intent(in) :: flowja +! integer(I4B), intent(in) :: icbcfl +! integer(I4B), intent(in) :: icbcun +! ! -- local +! integer(I4B) :: ibinun +! ! -- formats +!! ------------------------------------------------------------------------------ +! ! +! ! -- Set unit number for binary output +! if (this%ipakcb < 0) then +! ibinun = icbcun +! elseif (this%ipakcb == 0) then +! ibinun = 0 +! else +! ibinun = this%ipakcb +! end if +! if (icbcfl == 0) ibinun = 0 +! ! +! ! -- Write the face flows if requested +! if (ibinun /= 0) then +! call this%dis%record_connection_array(flowja, ibinun, this%iout) +! end if +! ! +! ! -- Return +! return +! end subroutine gwt_ot_flowja +! +! subroutine gwt_ot_dv(this, idvsave, idvprint, ipflag) +! class(GwtModelType) :: this +! integer(I4B), intent(in) :: idvsave +! integer(I4B), intent(in) :: idvprint +! integer(I4B), intent(inout) :: ipflag +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! -- Print advanced package dependent variables +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_dv(idvsave, idvprint) +! end do +! +! ! -- save head and print head +! call this%oc%oc_ot(ipflag) +! +! end subroutine gwt_ot_dv +! +! subroutine gwt_ot_bdsummary(this, ibudfl, ipflag) +! use TdisModule, only: kstp, kper, totim +! class(GwtModelType) :: this +! integer(I4B), intent(in) :: ibudfl +! integer(I4B), intent(inout) :: ipflag +! class(BndType), pointer :: packobj +! integer(I4B) :: ip +! +! ! +! ! -- Package budget summary +! do ip = 1, this%bndlist%Count() +! packobj => GetBndFromList(this%bndlist, ip) +! call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) +! end do +! +! ! -- mover budget summary +! if (this%inmvt > 0) then +! call this%mvt%mvt_ot_bdsummary(ibudfl) +! end if +! +! ! -- model budget summary +! if (ibudfl /= 0) then +! ipflag = 1 +! call this%budget%budget_ot(kstp, kper, this%iout) +! end if +! +! ! -- Write to budget csv +! call this%budget%writecsv(totim) +! +! end subroutine gwt_ot_bdsummary subroutine gwt_da(this) ! ****************************************************************************** @@ -914,6 +917,10 @@ subroutine gwt_da(this) integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Scalars + call mem_deallocate(this%inmst) + call mem_deallocate(this%indsp) ! ! -- Deallocate idm memory call memorylist_remove(this%name, 'NAM', idm_context) @@ -1396,7 +1403,7 @@ subroutine create_gwt_specific_packages(this, indis) !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified - call this%ftype_check(indis) + call this%ftype_check(indis, this%inmst) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel.f90 index 5faa2327298..0101c60c3e8 100644 --- a/src/Model/TransportModel.f90 +++ b/src/Model/TransportModel.f90 @@ -56,8 +56,8 @@ module TransportModelModule integer(I4B), pointer :: inssm => null() ! unit number SSM integer(I4B), pointer :: inoc => null() ! unit number OC integer(I4B), pointer :: inobs => null() ! unit number OBS - integer(I4B), pointer :: inmst => null() ! unit number MST - integer(I4B), pointer :: indsp => null() ! unit number DSP + !integer(I4B), pointer :: inmst => null() ! unit number MST + !integer(I4B), pointer :: indsp => null() ! unit number DSP real(DP), pointer :: eqnsclfac => null() !< constant factor by which all terms in the model's governing equation are scaled (divided) for formulation and solution contains @@ -490,7 +490,7 @@ subroutine tsp_bd(this, icnvg, isuppress_output) return end subroutine tsp_bd - subroutine tsp_ot(this) + subroutine tsp_ot(this, inmst) ! ****************************************************************************** ! tsp_ot -- Transport Model Output ! ****************************************************************************** @@ -501,6 +501,7 @@ subroutine tsp_ot(this) use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(TransportModelType) :: this + integer(I4B), intent(in) :: inmst ! -- local integer(I4B) :: idvsave integer(I4B) :: idvprint @@ -534,7 +535,7 @@ subroutine tsp_ot(this) call this%tsp_ot_obs() ! ! Save and print flows - call this%tsp_ot_flow(icbcfl, ibudfl, icbcun) + call this%tsp_ot_flow(icbcfl, ibudfl, icbcun, inmst) ! ! Save and print dependent variables call this%tsp_ot_dv(idvsave, idvprint, ipflag) @@ -573,17 +574,18 @@ subroutine tsp_ot_obs(this) end subroutine tsp_ot_obs - subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun) + subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun, inmst) class(TransportModelType) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: ibudfl integer(I4B), intent(in) :: icbcun + integer(I4B), intent(in) :: inmst class(BndType), pointer :: packobj integer(I4B) :: ip ! ------------------------------------------------------------------------------ ! -- Save TSP flows call this%tsp_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if (this%inmst > 0) call this%tsp_ot_flowja(this%nja, this%flowja, & + if (inmst > 0) call this%tsp_ot_flowja(this%nja, this%flowja, & icbcfl, icbcun) if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) if (this%inssm > 0) then @@ -771,9 +773,9 @@ subroutine tsp_da(this) call mem_deallocate(this%inic) call mem_deallocate(this%infmi) call mem_deallocate(this%inadv) - call mem_deallocate(this%indsp) + !call mem_deallocate(this%indsp) call mem_deallocate(this%inssm) - call mem_deallocate(this%inmst) + !call mem_deallocate(this%inmst) call mem_deallocate(this%inmvt) call mem_deallocate(this%inoc) call mem_deallocate(this%inobs) @@ -783,7 +785,7 @@ subroutine tsp_da(this) return end subroutine tsp_da - subroutine ftype_check(this, indis) + subroutine ftype_check(this, indis, inmst) ! ****************************************************************************** ! ftype_check -- Check to make sure required input files have been specified ! ****************************************************************************** @@ -796,6 +798,7 @@ subroutine ftype_check(this, indis) ! -- dummy class(TransportModelType) :: this integer(I4B), intent(in) :: indis + integer(I4B), intent(in) :: inmst ! -- local character(len=LINELENGTH) :: errmsg ! ------------------------------------------------------------------------------ @@ -811,7 +814,7 @@ subroutine ftype_check(this, indis) 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' call store_error(errmsg) end if - if (this%inmst == 0) then + if (inmst == 0) then write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & &PACKAGE NOT SPECIFIED.' call store_error(errmsg) From 740ec79aedc1f2d55018732c7d82875acae03bb8 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 12:31:00 -0700 Subject: [PATCH 118/212] IDM-related catch up on GWE branch --- msvs/mf6core.vfproj | 6 + src/Model/GroundWaterEnergy/gwe1dis1idm.f90 | 285 +++++++++ src/Model/GroundWaterEnergy/gwe1disu1idm.f90 | 588 ++++++++++++++++++ src/Model/GroundWaterEnergy/gwe1disv1idm.f90 | 438 +++++++++++++ src/Model/GroundWaterEnergy/gwe1dspidm.f90 | 43 +- src/Model/GroundWaterFlow/gwf3dis8idm.f90 | 15 +- src/Model/GroundWaterFlow/gwf3npf8idm.f90 | 15 +- .../GroundWaterTransport/gwt1dis1idm.f90 | 15 +- src/Model/GroundWaterTransport/gwt1dspidm.f90 | 15 +- .../Idm/selector/IdmGweDfnSelector.f90 | 56 ++ 10 files changed, 1386 insertions(+), 90 deletions(-) create mode 100644 src/Model/GroundWaterEnergy/gwe1dis1idm.f90 create mode 100644 src/Model/GroundWaterEnergy/gwe1disu1idm.f90 create mode 100644 src/Model/GroundWaterEnergy/gwe1disv1idm.f90 diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index b0080392e72..5c3cf673ca5 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -85,6 +85,8 @@ + + @@ -123,7 +125,11 @@ + + + + diff --git a/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 b/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 new file mode 100644 index 00000000000..f7a6d4266e5 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 @@ -0,0 +1,285 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** +module GweDisInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwe_dis_param_definitions + public gwe_dis_aggregate_definitions + public gwe_dis_block_definitions + public GweDisParamFoundType + public gwe_dis_multi_package + + type GweDisParamFoundType + logical :: length_units = .false. + logical :: nogrb = .false. + logical :: xorigin = .false. + logical :: yorigin = .false. + logical :: angrot = .false. + logical :: nlay = .false. + logical :: nrow = .false. + logical :: ncol = .false. + logical :: delr = .false. + logical :: delc = .false. + logical :: top = .false. + logical :: botm = .false. + logical :: idomain = .false. + end type GweDisParamFoundType + + logical :: gwe_dis_multi_package = .false. + + type(InputParamDefinitionType), parameter :: & + gwedis_length_units = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'LENGTH_UNITS', & ! tag name + 'LENGTH_UNITS', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_nogrb = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'NOGRB', & ! tag name + 'NOGRB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_xorigin = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'XORIGIN', & ! tag name + 'XORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_yorigin = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'YORIGIN', & ! tag name + 'YORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_angrot = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'OPTIONS', & ! block + 'ANGROT', & ! tag name + 'ANGROT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_nlay = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'DIMENSIONS', & ! block + 'NLAY', & ! tag name + 'NLAY', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_nrow = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'DIMENSIONS', & ! block + 'NROW', & ! tag name + 'NROW', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_ncol = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'DIMENSIONS', & ! block + 'NCOL', & ! tag name + 'NCOL', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_delr = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'DELR', & ! tag name + 'DELR', & ! fortran variable + 'DOUBLE1D', & ! type + 'NCOL', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_delc = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'DELC', & ! tag name + 'DELC', & ! fortran variable + 'DOUBLE1D', & ! type + 'NROW', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_top = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'TOP', & ! tag name + 'TOP', & ! fortran variable + 'DOUBLE2D', & ! type + 'NCOL NROW', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_botm = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'BOTM', & ! tag name + 'BOTM', & ! fortran variable + 'DOUBLE3D', & ! type + 'NCOL NROW NLAY', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedis_idomain = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DIS', & ! subcomponent + 'GRIDDATA', & ! block + 'IDOMAIN', & ! tag name + 'IDOMAIN', & ! fortran variable + 'INTEGER3D', & ! type + 'NCOL NROW NLAY', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_dis_param_definitions(*) = & + [ & + gwedis_length_units, & + gwedis_nogrb, & + gwedis_xorigin, & + gwedis_yorigin, & + gwedis_angrot, & + gwedis_nlay, & + gwedis_nrow, & + gwedis_ncol, & + gwedis_delr, & + gwedis_delc, & + gwedis_top, & + gwedis_botm, & + gwedis_idomain & + ] + + type(InputParamDefinitionType), parameter :: & + gwe_dis_aggregate_definitions(*) = & + [ & + InputParamDefinitionType :: & + ] + + type(InputBlockDefinitionType), parameter :: & + gwe_dis_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ) & + ] + +end module GweDisInputModule diff --git a/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 b/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 new file mode 100644 index 00000000000..33616c11189 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1disu1idm.f90 @@ -0,0 +1,588 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** +module GweDisuInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwe_disu_param_definitions + public gwe_disu_aggregate_definitions + public gwe_disu_block_definitions + public GweDisuParamFoundType + public gwe_disu_multi_package + + type GweDisuParamFoundType + logical :: length_units = .false. + logical :: nogrb = .false. + logical :: xorigin = .false. + logical :: yorigin = .false. + logical :: angrot = .false. + logical :: voffsettol = .false. + logical :: nodes = .false. + logical :: nja = .false. + logical :: nvert = .false. + logical :: top = .false. + logical :: bot = .false. + logical :: area = .false. + logical :: idomain = .false. + logical :: iac = .false. + logical :: ja = .false. + logical :: ihc = .false. + logical :: cl12 = .false. + logical :: hwva = .false. + logical :: angldegx = .false. + logical :: iv = .false. + logical :: xv = .false. + logical :: yv = .false. + logical :: icell2d = .false. + logical :: xc = .false. + logical :: yc = .false. + logical :: ncvert = .false. + logical :: icvert = .false. + end type GweDisuParamFoundType + + logical :: gwe_disu_multi_package = .false. + + type(InputParamDefinitionType), parameter :: & + gwedisu_length_units = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'LENGTH_UNITS', & ! tag name + 'LENGTH_UNITS', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_nogrb = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'NOGRB', & ! tag name + 'NOGRB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_xorigin = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'XORIGIN', & ! tag name + 'XORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_yorigin = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'YORIGIN', & ! tag name + 'YORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_angrot = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'ANGROT', & ! tag name + 'ANGROT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_voffsettol = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'OPTIONS', & ! block + 'VERTICAL_OFFSET_TOLERANCE', & ! tag name + 'VOFFSETTOL', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_nodes = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'DIMENSIONS', & ! block + 'NODES', & ! tag name + 'NODES', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_nja = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'DIMENSIONS', & ! block + 'NJA', & ! tag name + 'NJA', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_nvert = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'DIMENSIONS', & ! block + 'NVERT', & ! tag name + 'NVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_top = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'TOP', & ! tag name + 'TOP', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_bot = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'BOT', & ! tag name + 'BOT', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_area = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'AREA', & ! tag name + 'AREA', & ! fortran variable + 'DOUBLE1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_idomain = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'GRIDDATA', & ! block + 'IDOMAIN', & ! tag name + 'IDOMAIN', & ! fortran variable + 'INTEGER1D', & ! type + 'NODES', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_iac = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'IAC', & ! tag name + 'IAC', & ! fortran variable + 'INTEGER1D', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_ja = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'JA', & ! tag name + 'JA', & ! fortran variable + 'INTEGER1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_ihc = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'IHC', & ! tag name + 'IHC', & ! fortran variable + 'INTEGER1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_cl12 = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'CL12', & ! tag name + 'CL12', & ! fortran variable + 'DOUBLE1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_hwva = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'HWVA', & ! tag name + 'HWVA', & ! fortran variable + 'DOUBLE1D', & ! type + 'NJA', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_angldegx = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CONNECTIONDATA', & ! block + 'ANGLDEGX', & ! tag name + 'ANGLDEGX', & ! fortran variable + 'DOUBLE1D', & ! type + 'NJA', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_iv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'IV', & ! tag name + 'IV', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_xv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'XV', & ! tag name + 'XV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_yv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'YV', & ! tag name + 'YV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_icell2d = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'ICELL2D', & ! tag name + 'ICELL2D', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_xc = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'XC', & ! tag name + 'XC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_yc = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'YC', & ! tag name + 'YC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_ncvert = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'NCVERT', & ! tag name + 'NCVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_icvert = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'ICVERT', & ! tag name + 'ICVERT', & ! fortran variable + 'INTEGER1D', & ! type + 'NCVERT', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_disu_param_definitions(*) = & + [ & + gwedisu_length_units, & + gwedisu_nogrb, & + gwedisu_xorigin, & + gwedisu_yorigin, & + gwedisu_angrot, & + gwedisu_voffsettol, & + gwedisu_nodes, & + gwedisu_nja, & + gwedisu_nvert, & + gwedisu_top, & + gwedisu_bot, & + gwedisu_area, & + gwedisu_idomain, & + gwedisu_iac, & + gwedisu_ja, & + gwedisu_ihc, & + gwedisu_cl12, & + gwedisu_hwva, & + gwedisu_angldegx, & + gwedisu_iv, & + gwedisu_xv, & + gwedisu_yv, & + gwedisu_icell2d, & + gwedisu_xc, & + gwedisu_yc, & + gwedisu_ncvert, & + gwedisu_icvert & + ] + + type(InputParamDefinitionType), parameter :: & + gwedisu_vertices = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'VERTICES', & ! block + 'VERTICES', & ! tag name + 'VERTICES', & ! fortran variable + 'RECARRAY IV XV YV', & ! type + 'NVERT', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisu_cell2d = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISU', & ! subcomponent + 'CELL2D', & ! block + 'CELL2D', & ! tag name + 'CELL2D', & ! fortran variable + 'RECARRAY ICELL2D XC YC NCVERT ICVERT', & ! type + 'NODES', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_disu_aggregate_definitions(*) = & + [ & + gwedisu_vertices, & + gwedisu_cell2d & + ] + + type(InputBlockDefinitionType), parameter :: & + gwe_disu_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'CONNECTIONDATA', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'VERTICES', & ! blockname + .true., & ! required + .true., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'CELL2D', & ! blockname + .true., & ! required + .true., & ! aggregate + .false. & ! block_variable + ) & + ] + +end module GweDisuInputModule diff --git a/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 b/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 new file mode 100644 index 00000000000..a9f5b40e523 --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1disv1idm.f90 @@ -0,0 +1,438 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** +module GweDisvInputModule + use InputDefinitionModule, only: InputParamDefinitionType, & + InputBlockDefinitionType + private + public gwe_disv_param_definitions + public gwe_disv_aggregate_definitions + public gwe_disv_block_definitions + public GweDisvParamFoundType + public gwe_disv_multi_package + + type GweDisvParamFoundType + logical :: length_units = .false. + logical :: nogrb = .false. + logical :: xorigin = .false. + logical :: yorigin = .false. + logical :: angrot = .false. + logical :: nlay = .false. + logical :: ncpl = .false. + logical :: nvert = .false. + logical :: top = .false. + logical :: botm = .false. + logical :: idomain = .false. + logical :: iv = .false. + logical :: xv = .false. + logical :: yv = .false. + logical :: icell2d = .false. + logical :: xc = .false. + logical :: yc = .false. + logical :: ncvert = .false. + logical :: icvert = .false. + end type GweDisvParamFoundType + + logical :: gwe_disv_multi_package = .false. + + type(InputParamDefinitionType), parameter :: & + gwedisv_length_units = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'LENGTH_UNITS', & ! tag name + 'LENGTH_UNITS', & ! fortran variable + 'STRING', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_nogrb = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'NOGRB', & ! tag name + 'NOGRB', & ! fortran variable + 'KEYWORD', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_xorigin = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'XORIGIN', & ! tag name + 'XORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_yorigin = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'YORIGIN', & ! tag name + 'YORIGIN', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_angrot = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'OPTIONS', & ! block + 'ANGROT', & ! tag name + 'ANGROT', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_nlay = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'DIMENSIONS', & ! block + 'NLAY', & ! tag name + 'NLAY', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_ncpl = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'DIMENSIONS', & ! block + 'NCPL', & ! tag name + 'NCPL', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_nvert = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'DIMENSIONS', & ! block + 'NVERT', & ! tag name + 'NVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_top = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'GRIDDATA', & ! block + 'TOP', & ! tag name + 'TOP', & ! fortran variable + 'DOUBLE1D', & ! type + 'NCPL', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_botm = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'GRIDDATA', & ! block + 'BOTM', & ! tag name + 'BOTM', & ! fortran variable + 'DOUBLE2D', & ! type + 'NLAY NCPL', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_idomain = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'GRIDDATA', & ! block + 'IDOMAIN', & ! tag name + 'IDOMAIN', & ! fortran variable + 'INTEGER2D', & ! type + 'NLAY NCPL', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .true. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_iv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'IV', & ! tag name + 'IV', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_xv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'XV', & ! tag name + 'XV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_yv = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'YV', & ! tag name + 'YV', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_icell2d = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'ICELL2D', & ! tag name + 'ICELL2D', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_xc = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'XC', & ! tag name + 'XC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_yc = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'YC', & ! tag name + 'YC', & ! fortran variable + 'DOUBLE', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_ncvert = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'NCVERT', & ! tag name + 'NCVERT', & ! fortran variable + 'INTEGER', & ! type + '', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_icvert = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'ICVERT', & ! tag name + 'ICVERT', & ! fortran variable + 'INTEGER1D', & ! type + 'NCVERT', & ! shape + .true., & ! required + .true., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_disv_param_definitions(*) = & + [ & + gwedisv_length_units, & + gwedisv_nogrb, & + gwedisv_xorigin, & + gwedisv_yorigin, & + gwedisv_angrot, & + gwedisv_nlay, & + gwedisv_ncpl, & + gwedisv_nvert, & + gwedisv_top, & + gwedisv_botm, & + gwedisv_idomain, & + gwedisv_iv, & + gwedisv_xv, & + gwedisv_yv, & + gwedisv_icell2d, & + gwedisv_xc, & + gwedisv_yc, & + gwedisv_ncvert, & + gwedisv_icvert & + ] + + type(InputParamDefinitionType), parameter :: & + gwedisv_vertices = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'VERTICES', & ! block + 'VERTICES', & ! tag name + 'VERTICES', & ! fortran variable + 'RECARRAY IV XV YV', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwedisv_cell2d = InputParamDefinitionType & + ( & + 'GWE', & ! component + 'DISV', & ! subcomponent + 'CELL2D', & ! block + 'CELL2D', & ! tag name + 'CELL2D', & ! fortran variable + 'RECARRAY ICELL2D XC YC NCVERT ICVERT', & ! type + '', & ! shape + .true., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) + + type(InputParamDefinitionType), parameter :: & + gwe_disv_aggregate_definitions(*) = & + [ & + gwedisv_vertices, & + gwedisv_cell2d & + ] + + type(InputBlockDefinitionType), parameter :: & + gwe_disv_block_definitions(*) = & + [ & + InputBlockDefinitionType( & + 'OPTIONS', & ! blockname + .false., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'DIMENSIONS', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'GRIDDATA', & ! blockname + .true., & ! required + .false., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'VERTICES', & ! blockname + .true., & ! required + .true., & ! aggregate + .false. & ! block_variable + ), & + InputBlockDefinitionType( & + 'CELL2D', & ! blockname + .true., & ! required + .true., & ! aggregate + .false. & ! block_variable + ) & + ] + +end module GweDisvInputModule diff --git a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 index 343b208e7b4..02c585f6b24 100644 --- a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 @@ -1,3 +1,4 @@ +! ** Do Not Modify! MODFLOW 6 system generated file. ** module GweDspInputModule use InputDefinitionModule, only: InputParamDefinitionType, & InputBlockDefinitionType @@ -6,11 +7,11 @@ module GweDspInputModule public gwe_dsp_aggregate_definitions public gwe_dsp_block_definitions public GweDspParamFoundType + public gwe_dsp_multi_package type GweDspParamFoundType logical :: xt3d_off = .false. logical :: xt3d_rhs = .false. - !logical :: diffc = .false. logical :: alh = .false. logical :: alv = .false. logical :: ath1 = .false. @@ -20,6 +21,8 @@ module GweDspInputModule logical :: kts = .false. end type GweDspParamFoundType + logical :: gwe_dsp_multi_package = .false. + type(InputParamDefinitionType), parameter :: & gwedsp_xt3d_off = InputParamDefinitionType & ( & @@ -52,22 +55,6 @@ module GweDspInputModule .false. & ! layered ) - !type(InputParamDefinitionType), parameter :: & - ! gwtdsp_diffc = InputParamDefinitionType & - ! ( & - ! 'GWT', & ! component - ! 'DSP', & ! subcomponent - ! 'GRIDDATA', & ! block - ! 'DIFFC', & ! tag name - ! 'DIFFC', & ! fortran variable - ! 'DOUBLE1D', & ! type - ! 'NODES', & ! shape - ! .false., & ! required - ! .false., & ! multi-record - ! .false., & ! preserve case - ! .true. & ! layered - ! ) - type(InputParamDefinitionType), parameter :: & gwedsp_alh = InputParamDefinitionType & ( & @@ -185,7 +172,6 @@ module GweDspInputModule [ & gwedsp_xt3d_off, & gwedsp_xt3d_rhs, & - !gwtdsp_diffc, & gwedsp_alh, & gwedsp_alv, & gwedsp_ath1, & @@ -198,20 +184,7 @@ module GweDspInputModule type(InputParamDefinitionType), parameter :: & gwe_dsp_aggregate_definitions(*) = & [ & - InputParamDefinitionType & - ( & - '', & ! component - '', & ! subcomponent - '', & ! block - '', & ! tag name - '', & ! fortran variable - '', & ! type - '', & ! shape - .false., & ! required - .false., & ! multi-record - .false., & ! preserve case - .false. & ! layered - ) & + InputParamDefinitionType :: & ] type(InputBlockDefinitionType), parameter :: & @@ -220,12 +193,14 @@ module GweDspInputModule InputBlockDefinitionType( & 'OPTIONS', & ! blockname .false., & ! required - .false. & ! aggregate + .false., & ! aggregate + .false. & ! block_variable ), & InputBlockDefinitionType( & 'GRIDDATA', & ! blockname .false., & ! required - .false. & ! aggregate + .false., & ! aggregate + .false. & ! block_variable ) & ] diff --git a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 index 0c8d8cd90b1..ff33cf24725 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 @@ -256,20 +256,7 @@ module GwfDisInputModule type(InputParamDefinitionType), parameter :: & gwf_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType & - ( & - '', & ! component - '', & ! subcomponent - '', & ! block - '', & ! tag name - '', & ! fortran variable - '', & ! type - '', & ! shape - .false., & ! required - .false., & ! multi-record - .false., & ! preserve case - .false. & ! layered - ) & + InputParamDefinitionType :: & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 index 79fe5bee186..87d2825bed2 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 @@ -688,20 +688,7 @@ module GwfNpfInputModule type(InputParamDefinitionType), parameter :: & gwf_npf_aggregate_definitions(*) = & [ & - InputParamDefinitionType & - ( & - '', & ! component - '', & ! subcomponent - '', & ! block - '', & ! tag name - '', & ! fortran variable - '', & ! type - '', & ! shape - .false., & ! required - .false., & ! multi-record - .false., & ! preserve case - .false. & ! layered - ) & + InputParamDefinitionType :: & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 index dda32a6b3a1..b80694384aa 100644 --- a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 @@ -256,20 +256,7 @@ module GwtDisInputModule type(InputParamDefinitionType), parameter :: & gwt_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType & - ( & - '', & ! component - '', & ! subcomponent - '', & ! block - '', & ! tag name - '', & ! fortran variable - '', & ! type - '', & ! shape - .false., & ! required - .false., & ! multi-record - .false., & ! preserve case - .false. & ! layered - ) & + InputParamDefinitionType :: & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/gwt1dspidm.f90 b/src/Model/GroundWaterTransport/gwt1dspidm.f90 index 0f9e3c29e1d..63b8cfeeb46 100644 --- a/src/Model/GroundWaterTransport/gwt1dspidm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dspidm.f90 @@ -166,20 +166,7 @@ module GwtDspInputModule type(InputParamDefinitionType), parameter :: & gwt_dsp_aggregate_definitions(*) = & [ & - InputParamDefinitionType & - ( & - '', & ! component - '', & ! subcomponent - '', & ! block - '', & ! tag name - '', & ! fortran variable - '', & ! type - '', & ! shape - .false., & ! required - .false., & ! multi-record - .false., & ! preserve case - .false. & ! layered - ) & + InputParamDefinitionType :: & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 b/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 index c92458b82e9..e0aa27c9197 100644 --- a/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 +++ b/src/Utilities/Idm/selector/IdmGweDfnSelector.f90 @@ -4,6 +4,22 @@ module IdmGweDfnSelectorModule use SimModule, only: store_error use InputDefinitionModule, only: InputParamDefinitionType, & InputBlockDefinitionType + use GweDisInputModule, only: gwe_dis_param_definitions, & + gwe_dis_aggregate_definitions, & + gwe_dis_block_definitions, & + gwe_dis_multi_package + use GweDisuInputModule, only: gwe_disu_param_definitions, & + gwe_disu_aggregate_definitions, & + gwe_disu_block_definitions, & + gwe_disu_multi_package + use GweDisvInputModule, only: gwe_disv_param_definitions, & + gwe_disv_aggregate_definitions, & + gwe_disv_block_definitions, & + gwe_disv_multi_package + use GweDspInputModule, only: gwe_dsp_param_definitions, & + gwe_dsp_aggregate_definitions, & + gwe_dsp_block_definitions, & + gwe_dsp_multi_package use GweNamInputModule, only: gwe_nam_param_definitions, & gwe_nam_aggregate_definitions, & gwe_nam_block_definitions, & @@ -36,6 +52,14 @@ function gwe_param_definitions(subcomponent) result(input_definition) type(InputParamDefinitionType), dimension(:), pointer :: input_definition nullify (input_definition) select case (subcomponent) + case ('DIS') + call set_param_pointer(input_definition, gwe_dis_param_definitions) + case ('DISU') + call set_param_pointer(input_definition, gwe_disu_param_definitions) + case ('DISV') + call set_param_pointer(input_definition, gwe_disv_param_definitions) + case ('DSP') + call set_param_pointer(input_definition, gwe_dsp_param_definitions) case ('NAM') call set_param_pointer(input_definition, gwe_nam_param_definitions) case default @@ -48,6 +72,14 @@ function gwe_aggregate_definitions(subcomponent) result(input_definition) type(InputParamDefinitionType), dimension(:), pointer :: input_definition nullify (input_definition) select case (subcomponent) + case ('DIS') + call set_param_pointer(input_definition, gwe_dis_aggregate_definitions) + case ('DISU') + call set_param_pointer(input_definition, gwe_disu_aggregate_definitions) + case ('DISV') + call set_param_pointer(input_definition, gwe_disv_aggregate_definitions) + case ('DSP') + call set_param_pointer(input_definition, gwe_dsp_aggregate_definitions) case ('NAM') call set_param_pointer(input_definition, gwe_nam_aggregate_definitions) case default @@ -60,6 +92,14 @@ function gwe_block_definitions(subcomponent) result(input_definition) type(InputBlockDefinitionType), dimension(:), pointer :: input_definition nullify (input_definition) select case (subcomponent) + case ('DIS') + call set_block_pointer(input_definition, gwe_dis_block_definitions) + case ('DISU') + call set_block_pointer(input_definition, gwe_disu_block_definitions) + case ('DISV') + call set_block_pointer(input_definition, gwe_disv_block_definitions) + case ('DSP') + call set_block_pointer(input_definition, gwe_dsp_block_definitions) case ('NAM') call set_block_pointer(input_definition, gwe_nam_block_definitions) case default @@ -71,6 +111,14 @@ function gwe_idm_multi_package(subcomponent) result(multi_package) character(len=*), intent(in) :: subcomponent logical :: multi_package select case (subcomponent) + case ('DIS') + multi_package = gwe_dis_multi_package + case ('DISU') + multi_package = gwe_disu_multi_package + case ('DISV') + multi_package = gwe_disv_multi_package + case ('DSP') + multi_package = gwe_dsp_multi_package case ('NAM') multi_package = gwe_nam_multi_package case default @@ -86,6 +134,14 @@ function gwe_idm_integrated(subcomponent) result(integrated) logical :: integrated integrated = .false. select case (subcomponent) + case ('DIS') + integrated = .true. + case ('DISU') + integrated = .true. + case ('DISV') + integrated = .true. + case ('DSP') + integrated = .true. case ('NAM') integrated = .true. case default From 2d95c15e273383a4b3000b221f232a6f20ba8d5c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 12:31:49 -0700 Subject: [PATCH 119/212] Testing framework syntax has been updated. Will need to do similar updates across all GWE autotests --- autotest/test_gwe_dsp.py | 44 +++++++++++----------------------------- 1 file changed, 12 insertions(+), 32 deletions(-) diff --git a/autotest/test_gwe_dsp.py b/autotest/test_gwe_dsp.py index 6af6c0d9b32..3d86abd9f88 100644 --- a/autotest/test_gwe_dsp.py +++ b/autotest/test_gwe_dsp.py @@ -358,7 +358,7 @@ def build_model(idx, dir): return sim, None -def eval_model(sim): +def eval_transport(sim): print("evaluating results...") # read transport results from GWE model @@ -486,36 +486,16 @@ def eval_model(sim): # - No need to change any code below @pytest.mark.parametrize( - "idx, dir", - list(enumerate(exdirs)), + "idx, name", + list(enumerate(ex)), ) -def test_mf6model(idx, dir): - # initialize testing framework +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) test = TestFramework() - - # build the model - test.build(build_model, idx, dir) - - # run the test model - test.run_mf6(Simulation(dir, exfunc=eval_model, idxsim=idx)) - - -def main(): - # initialize testing framework - test = TestFramework() - - # run the test model - for idx, dir in enumerate(exdirs): - - test.build_mf6_models(build_model, idx, dir) - sim = Simulation(dir, exfunc=eval_model, idxsim=idx) - test.run_mf6(sim) - - -if __name__ == "__main__": - # Heat Transport in 1-dimension - # print message - print(f"standalone run of {os.path.basename(__file__)}") - - # run main routine - main() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_transport, idxsim=idx + ), + ws, + ) From 6559433c391b76975403e1e74df3a6d2fc1c9e21 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 12:33:07 -0700 Subject: [PATCH 120/212] Even though GweDspGridData.f90 hasn't been a part of the .proj file for sometime, it was never removed from the repo --- src/Model/ModelUtilities/GweDspGridData.f90 | 63 --------------------- 1 file changed, 63 deletions(-) delete mode 100644 src/Model/ModelUtilities/GweDspGridData.f90 diff --git a/src/Model/ModelUtilities/GweDspGridData.f90 b/src/Model/ModelUtilities/GweDspGridData.f90 deleted file mode 100644 index a8ae4a5bcaf..00000000000 --- a/src/Model/ModelUtilities/GweDspGridData.f90 +++ /dev/null @@ -1,63 +0,0 @@ -module GweDspGridDataModule - use KindModule, only: DP, I4B - implicit none - private - -!> @brief data structure and helpers for passing dsp grid data -!< into the package, as opposed to reading from file - type, public :: GweDspGridDataType - real(DP), dimension(:), pointer, contiguous :: diffc => null() !< molecular diffusion coefficient for each cell - real(DP), dimension(:), pointer, contiguous :: alh => null() !< longitudinal horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: alv => null() !< longitudinal vertical dispersivity - real(DP), dimension(:), pointer, contiguous :: ath1 => null() !< transverse horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: ath2 => null() !< transverse horizontal dispersivity - real(DP), dimension(:), pointer, contiguous :: atv => null() !< transverse vertical dispersivity - real(DP), dimension(:), pointer, contiguous :: ktw => null() !< thermal conductivity of water - real(DP), dimension(:), pointer, contiguous :: kts => null() !< thermal conductivity of solids - real(DP), dimension(:), pointer, contiguous :: cpw => null() !< heat capacity of water from mst - real(DP), dimension(:), pointer, contiguous :: rhow => null() !< density of water from mst - contains - procedure, pass(this) :: construct - procedure, pass(this) :: destroy - end type GweDspGridDataType - -contains - -!> @brief allocate data structure -!< - subroutine construct(this, nodes) - class(GweDspGridDataType) :: this - integer(I4B) :: nodes - - allocate (this%diffc(nodes)) - allocate (this%alh(nodes)) - allocate (this%alv(nodes)) - allocate (this%ath1(nodes)) - allocate (this%ath2(nodes)) - allocate (this%atv(nodes)) - allocate (this%ktw(nodes)) - allocate (this%kts(nodes)) - allocate (this%cpw(nodes)) - allocate (this%rhow(nodes)) - - end subroutine construct - -!> @brief clean up -!< - subroutine destroy(this) - class(GweDspGridDataType) :: this - - deallocate (this%diffc) - deallocate (this%alh) - deallocate (this%alv) - deallocate (this%ath1) - deallocate (this%ath2) - deallocate (this%atv) - deallocate (this%ktw) - deallocate (this%kts) - deallocate (this%cpw) - deallocate (this%rhow) - - end subroutine destroy - -end module GweDspGridDataModule From 86c55305d25a071b64bda673666f6e2432766045 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 12:33:32 -0700 Subject: [PATCH 121/212] 1 more IDM related change --- utils/idmloader/scripts/dfn2f90.py | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/utils/idmloader/scripts/dfn2f90.py b/utils/idmloader/scripts/dfn2f90.py index 5a7d2587e23..a96a46a5f73 100644 --- a/utils/idmloader/scripts/dfn2f90.py +++ b/utils/idmloader/scripts/dfn2f90.py @@ -825,10 +825,26 @@ def _write_master_integration(self, fh=None): Path("../../../doc/mf6io/mf6ivar/dfn", "gwt-disv.dfn"), Path("../../../src/Model/GroundWaterTransport", "gwt1disv1idm.f90"), ], + [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwe-dis.dfn"), + Path("../../../src/Model/GroundWaterEnergy", "gwe1dis1idm.f90"), + ], + [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwe-disu.dfn"), + Path("../../../src/Model/GroundWaterEnergy", "gwe1disu1idm.f90"), + ], + [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwe-disv.dfn"), + Path("../../../src/Model/GroundWaterEnergy", "gwe1disv1idm.f90"), + ], [ Path("../../../doc/mf6io/mf6ivar/dfn", "gwt-dsp.dfn"), Path("../../../src/Model/GroundWaterTransport", "gwt1dspidm.f90"), ], + [ + Path("../../../doc/mf6io/mf6ivar/dfn", "gwe-dsp.dfn"), + Path("../../../src/Model/GroundWaterEnergy", "gwe1dspidm.f90"), + ], [ Path("../../../doc/mf6io/mf6ivar/dfn", "gwf-nam.dfn"), Path("../../../src/Model/GroundWaterFlow", "gwf3idm.f90"), From d479d7b217ca9e1dcfdd72ba26c18c352d741431 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 12:35:26 -0700 Subject: [PATCH 122/212] Some virtual model changes while trying to track down the idiffc error that's coming up in GWE. Even though idiffc doesn't exist in any of the GWE src file, the model is still looking for it in the virtual model stuff for some reason. --- src/Distributed/VirtualGweModel.f90 | 4 ++-- src/SimulationCreate.f90 | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/Distributed/VirtualGweModel.f90 b/src/Distributed/VirtualGweModel.f90 index 2d606195d7a..332f2fac678 100644 --- a/src/Distributed/VirtualGweModel.f90 +++ b/src/Distributed/VirtualGweModel.f90 @@ -12,9 +12,9 @@ module VirtualGweModelModule type, extends(VirtualModelType) :: VirtualGweModelType ! DSP - type(VirtualIntType), pointer :: dsp_idiffc => null() + !type(VirtualIntType), pointer :: dsp_idiffc => null() type(VirtualIntType), pointer :: dsp_idisp => null() - type(VirtualDbl1dType), pointer :: dsp_diffc => null() + !type(VirtualDbl1dType), pointer :: dsp_diffc => null() type(VirtualDbl1dType), pointer :: dsp_alh => null() type(VirtualDbl1dType), pointer :: dsp_alv => null() type(VirtualDbl1dType), pointer :: dsp_ath1 => null() diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index 0e7f1d209d8..6854e6e11f2 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -218,9 +218,11 @@ subroutine models_create() use SimVariablesModule, only: idm_context use GwfModule, only: gwf_cr use GwtModule, only: gwt_cr + use GweModule, only: gwe_cr use NumericalModelModule, only: NumericalModelType, GetNumericalModelFromList use VirtualGwfModelModule, only: add_virtual_gwf_model use VirtualGwtModelModule, only: add_virtual_gwt_model + use VirtualGweModelModule, only: add_virtual_gwe_model use ConstantsModule, only: LENMODELNAME ! -- dummy ! -- locals @@ -297,6 +299,16 @@ subroutine models_create() model_loc_idx(n) = im end if call add_virtual_gwt_model(n, model_names(n), num_model) + case ('GWE6') + if (model_ranks(n) == proc_id) then + im = im + 1 + write (iout, '(4x,2a,i0,a)') trim(model_type), " model ", & + n, " will be created" + call gwe_cr(fname, n, model_names(n)) + num_model => GetNumericalModelFromList(basemodellist, im) + model_loc_idx(n) = im + end if + call add_virtual_gwt_model(n, model_names(n), num_model) case default write (errmsg, '(4x,a,a)') & '****ERROR. UNKNOWN SIMULATION MODEL: ', & @@ -328,9 +340,11 @@ subroutine exchanges_create() use SimVariablesModule, only: idm_context use GwfGwfExchangeModule, only: gwfexchange_create use GwfGwtExchangeModule, only: gwfgwt_cr + use GwfGweExchangeModule, only: gwfgwe_cr use GwtGwtExchangeModule, only: gwtexchange_create use VirtualGwfExchangeModule, only: add_virtual_gwf_exchange use VirtualGwtExchangeModule, only: add_virtual_gwt_exchange + use VirtualGweExchangeModule, only: add_virtual_gwe_exchange ! -- dummy ! -- locals character(len=LENMEMPATH) :: input_mempath @@ -415,6 +429,10 @@ subroutine exchanges_create() if (both_local) then call gwfgwt_cr(fname, exg_id, m1_id, m2_id) end if + case ('GWF6-GWE6') + if (both_local) then + call gwfgwe_cr(fname, exg_id, m1_id, m2_id) + end if case ('GWT6-GWT6') write (exg_name, '(a,i0)') 'GWT-GWT_', exg_id if (.not. both_remote) then From 5cd36ff75118476ab028d9d47e214932ad03e372 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 19 Apr 2023 12:37:34 -0700 Subject: [PATCH 123/212] diffc not needed in GWE, removing from DSP .dfn file. Still doesn't solve current idiffc issue thrown by GWE --- doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn b/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn index bf979a9b31e..84a1cb29099 100644 --- a/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwe-dsp.dfn @@ -20,16 +20,6 @@ description add xt3d terms to right-hand side, when possible. This option uses # --------------------- gwe dsp griddata --------------------- -block griddata -name diffc -type double precision -shape (nodes) -reader readarray -layered true -optional true -longname effective molecular diffusion coefficient -description effective molecular diffusion coefficient. - block griddata name alh type double precision From 059cc711c30c156efa403ce46be5e93fd889aa7c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 21 Apr 2023 09:44:57 -0700 Subject: [PATCH 124/212] Why this was like trying to find a piece of hay in a needle stack, I don't know, but I had a difficult time tracking this one down. --- src/SimulationCreate.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index 6854e6e11f2..f92a0a1e7f7 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -308,7 +308,7 @@ subroutine models_create() num_model => GetNumericalModelFromList(basemodellist, im) model_loc_idx(n) = im end if - call add_virtual_gwt_model(n, model_names(n), num_model) + call add_virtual_gwe_model(n, model_names(n), num_model) case default write (errmsg, '(4x,a,a)') & '****ERROR. UNKNOWN SIMULATION MODEL: ', & From 1840f56bd1e13d56405bb5c71cba7bd71633ff42 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 5 May 2023 12:42:38 -0700 Subject: [PATCH 125/212] Kts & Ktw should not necessitate alv/alh requirement --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 8ea8fb4f5e1..1936a470209 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -723,8 +723,6 @@ subroutine source_griddata(this) if (found%alv) this%idisp = this%idisp + 1 if (found%ath1) this%idisp = this%idisp + 1 if (found%ath2) this%idisp = this%idisp + 1 - if (found%ktw) this%idisp = this%idisp + 1 - if (found%kts) this%idisp = this%idisp + 1 ! ! -- manage dispersion arrays if (this%idisp > 0) then From 8a0ce058ab723d93115ca69141133d09dc12a098 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 5 May 2023 13:52:15 -0700 Subject: [PATCH 126/212] Was causing double allocation of variables at the transport model level --- src/Model/GroundWaterEnergy/gwe1.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 6d9d333117c..64723ef2ae9 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1045,7 +1045,7 @@ subroutine allocate_gwe_scalars(this, modelname) ! ------------------------------------------------------------------------------ ! ! -- allocate members from parent class - call this%NumericalModelType%allocate_scalars(modelname) + !call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class !call mem_allocate(this%inic, 'INIC', this%memoryPath) From a17e2f6d74632be93fc18ddd8265f41594a616a3 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 16 May 2023 15:04:53 -0700 Subject: [PATCH 127/212] Check in some recent SFE changes after re-testing UZE autotest that was broken --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 49 +++++++++++++++------ src/Model/GroundWaterTransport/tsp1apt1.f90 | 46 +++++++++++++++---- src/Model/GroundWaterTransport/tsp1fmi1.f90 | 3 +- src/Utilities/BudgetObject.f90 | 2 +- 4 files changed, 77 insertions(+), 23 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 9d8faea04a5..76ec52f76bf 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -241,6 +241,7 @@ subroutine find_sfe_package(this) this%idxbudssm(ip) = 0 case ('GWF') this%idxbudgwf = ip + this%idxbudsbcd = ip this%idxbudssm(ip) = 0 case ('STORAGE') this%idxbudsto = ip @@ -260,9 +261,6 @@ subroutine find_sfe_package(this) case ('EXT-OUTFLOW') this%idxbudoutf = ip this%idxbudssm(ip) = 0 - case ('STRMBD-COND') - this%idxbudsbcd = ip - this%idxbudssm(ip) = 0 case ('TO-MVR') this%idxbudtmvr = ip this%idxbudssm(ip) = 0 @@ -308,10 +306,14 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B) :: iloc integer(I4B) :: iposd, iposoffd integer(I4B) :: ipossymd, ipossymoffd + integer(I4B) :: auxpos real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval real(DP) :: ctherm ! kluge? + real(DP) :: wa !< wetted area + real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: s !< thickness of conductive streambed material ! ------------------------------------------------------------------------------ ! ! -- add rainfall contribution @@ -377,19 +379,23 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%iboundpak(n) /= 0) then ! ! -- set acoef and rhs to negative so they are relative to sfe and not gwe - ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + ktf = this%ktf(j) + s = this%rbthcnd(j) + ctherm = ktf * wa / s ! ! -- add to sfe row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, ctherm) ! kluge note: make sure the signs on ctherm are correct here and below - call matrix_sln%add_value_pos(iposoffd, -ctherm) + call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposoffd, ctherm) ! ! -- add to gwe row for sfe connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, -ctherm) - call matrix_sln%add_value_pos(ipossymoffd, ctherm) + call matrix_sln%add_value_pos(ipossymd, ctherm) + call matrix_sln%add_value_pos(ipossymoffd, -ctherm) end if end do ! @@ -484,7 +490,9 @@ subroutine sfe_setup_budobj(this, idx) class(GweSfeType) :: this integer(I4B), intent(inout) :: idx ! -- local + integer(I4B) :: n, n1, n2 integer(I4B) :: maxlist, naux + real(DP) :: q character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! @@ -553,8 +561,8 @@ subroutine sfe_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- - text = ' STRMBD-COND' + ! -- conduction through the wetted streambed + text = ' STREAMBED-COND' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudsbcd)%maxlist naux = 0 @@ -565,6 +573,13 @@ subroutine sfe_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) + call this%budobj%budterm(idx)%reset(maxlist) + q = DZERO + do n = 1, maxlist + n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(n) + n2 = this%flowbudptr%budterm(this%idxbudgwf)%id2(n) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + end do ! ! -- return return @@ -585,8 +600,12 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) integer(I4B) :: j, n1, n2 integer(I4B) :: nlist integer(I4B) :: igwfnode + integer(I4B) :: auxpos real(DP) :: q - real(DP) :: ctherm ! kluge? + real(DP) :: ctherm + real(DP) :: wa !< wetted area + real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- @@ -648,9 +667,13 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) n1 = this%flowbudptr%budterm(this%idxbudsbcd)%id1(j) if (this%iboundpak(n1) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) - ctherm = 0d0 ! kluge note: temporary placeholder until we can calculate an actual thermal conductance + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + ktf = this%ktf(j) + s = this%rbthcnd(j) + ctherm = ktf * wa / s q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct - q = -q ! flip sign so relative to advanced package feature + !q = -q ! flip sign so relative to advanced package feature end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 75e811e9702..92fbe7edc28 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -79,6 +79,8 @@ module TspAptModule integer(I4B), pointer :: idxprepak => null() !< budget-object index that precedes package-specific budget objects integer(I4B), pointer :: idxlastpak => null() !< budget-object index of last package-specific budget object real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration (or temperature) + real(DP), dimension(:), pointer, contiguous :: ktf => null() !< thermal conductivity between the apt and groundwater cell + real(DP), dimension(:), pointer, contiguous :: rbthcnd => null() !< thickness of streambed material through with thermal conduction occurs integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< map position in global rhs and x array of pack entry integer(I4B), dimension(:), pointer, contiguous :: idxpakdiag => null() !< map diag position of feature in global amat integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !< map position in global array of package diagonal row entries @@ -1334,6 +1336,8 @@ subroutine apt_da(this) call mem_deallocate(this%qsto) call mem_deallocate(this%ccterm) call mem_deallocate(this%strt) + call mem_deallocate(this%ktf) + call mem_deallocate(this%rbthcnd) call mem_deallocate(this%lauxvar) call mem_deallocate(this%xoldpak) if (this%imatrows == 0) then @@ -1626,6 +1630,8 @@ subroutine apt_read_cvs(this) ! ! -- allocate apt data call mem_allocate(this%strt, this%ncv, 'STRT', this%memoryPath) + call mem_allocate(this%ktf, this%ncv, 'KTF', this%memoryPath) + call mem_allocate(this%rbthcnd, this%ncv, 'RBTHCND', this%memoryPath) call mem_allocate(this%lauxvar, this%naux, this%ncv, 'LAUXVAR', & this%memoryPath) ! @@ -1640,8 +1646,11 @@ subroutine apt_read_cvs(this) allocate (this%featname(this%ncv)) ! ditch after boundnames allocated?? !allocate(this%status(this%ncv)) ! + ! - initialize variables do n = 1, this%ncv this%strt(n) = DEP20 + this%ktf(n) = DZERO + this%rbthcnd(n) = DZERO this%lauxvar(:, n) = DZERO this%xoldpak(n) = DEP20 if (this%imatrows == 0) then @@ -1682,13 +1691,22 @@ subroutine apt_read_cvs(this) call store_error(errmsg) cycle end if - + ! ! -- increment nboundchk nboundchk(n) = nboundchk(n) + 1 - + ! ! -- strt this%strt(n) = this%parser%GetDouble() - + ! + ! -- if GWE model, read additional thermal conductivity terms + if (this%tsplab%tsptype == 'GWE') then + ! skip for UZE + if (trim(adjustl(this%text)) /= 'UZE') then + this%ktf(n) = this%parser%GetDouble() + this%rbthcnd(n) = this%parser%GetDouble() + end if + end if + ! ! -- get aux data do iaux = 1, this%naux call this%parser%GetString(caux(iaux)) @@ -1718,7 +1736,7 @@ subroutine apt_read_cvs(this) this%tsManager, this%iprpak, & this%auxname(jj)) end do - + ! nlak = nlak + 1 end do ! @@ -2153,6 +2171,7 @@ subroutine apt_setup_budobj(this) integer(I4B) :: idx logical :: ordered_id1 real(DP) :: q + character(len=LENBUDTXT) :: bddim_opt character(len=LENBUDTXT) :: text, textt character(len=LENBUDTXT), dimension(1) :: auxtxt ! ------------------------------------------------------------------------------ @@ -2163,9 +2182,10 @@ subroutine apt_setup_budobj(this) nlen = this%flowbudptr%budterm(this%idxbudfjf)%maxlist end if ! - ! -- Determine the number of lake budget terms. These are fixed for - ! the simulation and cannot change - ! -- the first 3 is for GWF, STORAGE, and CONSTANT + ! -- Determine the number of budget terms associated with apt. + ! These are fixed for the simulation and cannot change + ! + ! -- The first 3 are for GWF, STORAGE, and CONSTANT nbudterm = 3 ! ! -- add terms for the specific package @@ -2173,6 +2193,14 @@ subroutine apt_setup_budobj(this) ! ! -- add one for flow-ja-face if (nlen > 0) nbudterm = nbudterm + 1 + ! + ! -- add one for shared wetted area facilitating conduction in SFE, LKE, + ! and MWE (but not UZE) in GWE model + if (this%tsplab%tsptype == 'GWE') then + if (adjustl(trim(this%text)) /= 'UZE') then + if (nlen > 0) nbudterm = nbudterm + 1 + end if + end if ! ! -- add for mover terms and auxiliary if (this%idxbudtmvr /= 0) nbudterm = nbudterm + 1 @@ -2181,8 +2209,10 @@ subroutine apt_setup_budobj(this) ! ! -- set up budobj call budgetobject_cr(this%budobj, this%packName) + ! + bddim_opt=this%tsplab%depvarunitabbrev call this%budobj%budgetobject_df(this%ncv, nbudterm, 0, 0, & - bddim_opt='M', ibudcsv=this%ibudcsv) + bddim_opt=bddim_opt, ibudcsv=this%ibudcsv) idx = 0 ! ! -- Go through and set up each budget term diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/GroundWaterTransport/tsp1fmi1.f90 index c055f2651fe..889e9777dc8 100644 --- a/src/Model/GroundWaterTransport/tsp1fmi1.f90 +++ b/src/Model/GroundWaterTransport/tsp1fmi1.f90 @@ -198,7 +198,8 @@ subroutine fmi_df(this, dis, inssm, idryinactive) call this%initialize_gwfterms_from_bfr() end if ! - ! -- If GWF-GWT exchange is active, then setup gwfterms from bndlist + ! -- If GWF-GWT (or GWF-GWE) exchange is active, then setup gwfterms from + ! bndlist if (.not. this%flows_from_file) then call this%initialize_gwfterms_from_gwfbndlist() end if diff --git a/src/Utilities/BudgetObject.f90 b/src/Utilities/BudgetObject.f90 index 35836bf50b6..d7824340ecb 100644 --- a/src/Utilities/BudgetObject.f90 +++ b/src/Utilities/BudgetObject.f90 @@ -149,7 +149,7 @@ subroutine budgetobject_df(this, ncv, nbudterm, iflowja, nsto, & ! ! -- Set the budget dimension if (present(bddim_opt)) then - bddim = bddim_opt + bddim = trim(bddim_opt) else bddim = 'L**3' end if From cb9573d8fcd5639538686d0c128ab5a4d7fedc4f Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Fri, 19 May 2023 08:55:48 -0400 Subject: [PATCH 128/212] * temporary idm syntax workaround for old Intel compiler * fix calculation of THERMAL-EQUIL budget component in UZE --- src/Model/GroundWaterEnergy/gwe1dis1idm.f90 | 15 ++- src/Model/GroundWaterEnergy/gwe1dspidm.f90 | 15 ++- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 103 +++++++++++++++++- src/Model/GroundWaterFlow/gwf3dis8idm.f90 | 15 ++- src/Model/GroundWaterFlow/gwf3npf8idm.f90 | 15 ++- .../GroundWaterTransport/gwt1dis1idm.f90 | 15 ++- src/Model/GroundWaterTransport/gwt1dspidm.f90 | 15 ++- 7 files changed, 181 insertions(+), 12 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 b/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 index f7a6d4266e5..6e1ae424d55 100644 --- a/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dis1idm.f90 @@ -256,7 +256,20 @@ module GweDisInputModule type(InputParamDefinitionType), parameter :: & gwe_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 index 02c585f6b24..ec5dfee43b8 100644 --- a/src/Model/GroundWaterEnergy/gwe1dspidm.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dspidm.f90 @@ -184,7 +184,20 @@ module GweDspInputModule type(InputParamDefinitionType), parameter :: & gwe_dsp_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index e9c611d55f5..8023c94a252 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -840,14 +840,94 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local - integer(I4B) :: j, n1, n2, i - integer(I4B) :: nlist, nbudterm + integer(I4B) :: j, n1, n2, i, indx + integer(I4B) :: nlist, nbudterm, nlen integer(I4B) :: igwfnode integer(I4B) :: idiag real(DP) :: q + real(DP), dimension(:), allocatable :: budresid ! -- formats ! ----------------------------------------------------------------------------- + allocate(budresid(this%ncv)) + do n1 = 1, this%ncv + budresid(n1) = DZERO + end do + + indx = 0 + + ! -- FLOW JA FACE into budresid + nlen = 0 + if (this%idxbudfjf /= 0) then + nlen = this%flowbudptr%budterm(this%idxbudfjf)%maxlist + end if + if (nlen > 0) then + indx = indx + 1 + nlist = this%budobj%budterm(indx)%nlist + do j = 1, nlist + n1 = this%budobj%budterm(indx)%id1(j) + n2 = this%budobj%budterm(indx)%id2(j) + if (n1 < n2) then + q = this%budobj%budterm(indx)%flow(j) + budresid(n1) = budresid(n1) + q + budresid(n2) = budresid(n2) - q + end if + end do + end if + + ! -- GWF (LEAKAGE) into budresid + indx = indx + 1 + nlist = this%budobj%budterm(indx)%nlist + do j = 1, nlist + n1 = this%budobj%budterm(indx)%id1(j) + q = this%budobj%budterm(indx)%flow(j) + budresid(n1) = budresid(n1) + q + end do + + ! -- skip individual package terms + indx = this%idxlastpak + + ! -- STORAGE into budresid + indx = indx + 1 + do n1 = 1, this%ncv + q = this%budobj%budterm(indx)%flow(n1) + budresid(n1) = budresid(n1) + q + end do + + ! -- TO MOVER into budresid + if (this%idxbudtmvr /= 0) then + indx = indx + 1 + nlist = this%budobj%budterm(indx)%nlist + do j = 1, nlist + n1 = this%budobj%budterm(indx)%id1(j) + q = this%budobj%budterm(indx)%flow(j) + budresid(n1) = budresid(n1) + q + end do + end if + + ! -- FROM MOVER into budresid + if (this%idxbudfmvr /= 0) then + indx = indx + 1 + nlist = this%budobj%budterm(indx)%nlist + do j = 1, nlist + n1 = this%budobj%budterm(indx)%id1(j) + q = this%budobj%budterm(indx)%flow(j) + budresid(n1) = budresid(n1) + q + end do + end if + + ! -- CONSTANT FLOW into budresid + indx = indx + 1 + do n1 = 1, this%ncv + q = this%budobj%budterm(indx)%flow(n1) + budresid(n1) = budresid(n1) + q + end do + + ! -- AUXILIARY VARIABLES into budresid + ! -- (No flows associated with these) + + ! -- individual package terms processed last + ! -- INFILTRATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist @@ -856,6 +936,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%uze_infl_term(j, n1, n2, q) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + budresid(n1) = budresid(n1) + q end do ! -- REJ-INF @@ -867,6 +948,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%uze_rinf_term(j, n1, n2, q) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + budresid(n1) = budresid(n1) + q end do end if @@ -879,6 +961,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%uze_uzet_term(j, n1, n2, q) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + budresid(n1) = budresid(n1) + q end do end if @@ -891,6 +974,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%uze_ritm_term(j, n1, n2, q) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + budresid(n1) = budresid(n1) + q end do end if @@ -900,7 +984,10 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) nlist = this%flowbudptr%budterm(this%idxbudgwf)%nlist call this%budobj%budterm(idx)%reset(nlist) do j = 1, nlist - call this%uze_theq_term(j, n1, igwfnode, q) + n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) + q = - budresid(n1) +!! call this%uze_theq_term(j, n1, igwfnode, q) call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) if (this%iboundpak(n1) /= 0) then @@ -911,6 +998,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if end do + deallocate(budresid) ! ! -- return return @@ -1206,9 +1294,12 @@ subroutine uze_theq_term(this, ientry, n1, n2, rrate) case ('THERMAL-EQUIL') ! skip continue - case ('FLOW-JA-FACE') - ! skip - continue +!! case ('FLOW-JA-FACE') +!! ! skip +!! continue +!! case ('GWF') +!! ! skip +!! continue case default r = r - this%budobj%budterm(i)%flow(ientry) end select diff --git a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 index ff33cf24725..0c8d8cd90b1 100644 --- a/src/Model/GroundWaterFlow/gwf3dis8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3dis8idm.f90 @@ -256,7 +256,20 @@ module GwfDisInputModule type(InputParamDefinitionType), parameter :: & gwf_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 index 87d2825bed2..79fe5bee186 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8idm.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8idm.f90 @@ -688,7 +688,20 @@ module GwfNpfInputModule type(InputParamDefinitionType), parameter :: & gwf_npf_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 index b80694384aa..dda32a6b3a1 100644 --- a/src/Model/GroundWaterTransport/gwt1dis1idm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dis1idm.f90 @@ -256,7 +256,20 @@ module GwtDisInputModule type(InputParamDefinitionType), parameter :: & gwt_dis_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & diff --git a/src/Model/GroundWaterTransport/gwt1dspidm.f90 b/src/Model/GroundWaterTransport/gwt1dspidm.f90 index 63b8cfeeb46..0f9e3c29e1d 100644 --- a/src/Model/GroundWaterTransport/gwt1dspidm.f90 +++ b/src/Model/GroundWaterTransport/gwt1dspidm.f90 @@ -166,7 +166,20 @@ module GwtDspInputModule type(InputParamDefinitionType), parameter :: & gwt_dsp_aggregate_definitions(*) = & [ & - InputParamDefinitionType :: & + InputParamDefinitionType & + ( & + '', & ! component + '', & ! subcomponent + '', & ! block + '', & ! tag name + '', & ! fortran variable + '', & ! type + '', & ! shape + .false., & ! required + .false., & ! multi-record + .false., & ! preserve case + .false. & ! layered + ) & ] type(InputBlockDefinitionType), parameter :: & From cc13084690f81114bfefde2e02e692bc72ac73a5 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Fri, 19 May 2023 10:45:34 -0400 Subject: [PATCH 129/212] clean up some uze budget code --- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 8023c94a252..67664d1a44e 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -253,9 +253,6 @@ subroutine find_uze_package(this) case ('FROM-MVR') this%idxbudfmvr = ip this%idxbudssm(ip) = 0 - case ('THERMAL-EQUIL') - this%idxbudtheq= ip - this%idxbudssm(ip) = 0 case ('AUXILIARY') this%idxbudaux = ip this%idxbudssm(ip) = 0 @@ -267,15 +264,15 @@ subroutine find_uze_package(this) icount = icount + 1 end select ! - ! -- thermal equilibration term - this%idxbudtheq = this%flowbudptr%nbudterm + 1 - ! write (this%iout, '(a, i0, " = ", a,/, a, i0)') & ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist end do write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! + ! -- thermal equilibration term + this%idxbudtheq = this%flowbudptr%nbudterm + 1 + ! ! -- Return return end subroutine find_uze_package From 35c3b3648790c76ae49a13794b7f4a687d27fed2 Mon Sep 17 00:00:00 2001 From: Alden Provost Date: Fri, 19 May 2023 10:59:41 -0400 Subject: [PATCH 130/212] work on streambed conduction in sfe budget --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 76ec52f76bf..6e9fb6856bc 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -241,7 +241,7 @@ subroutine find_sfe_package(this) this%idxbudssm(ip) = 0 case ('GWF') this%idxbudgwf = ip - this%idxbudsbcd = ip +!! this%idxbudsbcd = ip this%idxbudssm(ip) = 0 case ('STORAGE') this%idxbudsto = ip @@ -283,6 +283,9 @@ subroutine find_sfe_package(this) end do write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! + ! -- streambed conduction term + this%idxbudsbcd = this%flowbudptr%nbudterm + 1 + ! ! -- Return return end subroutine find_sfe_package @@ -600,6 +603,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) integer(I4B) :: j, n1, n2 integer(I4B) :: nlist integer(I4B) :: igwfnode + integer(I4B) :: idiag integer(I4B) :: auxpos real(DP) :: q real(DP) :: ctherm @@ -677,6 +681,12 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + if (this%iboundpak(n1) /= 0) then + ! -- contribution to gwe cell budget + this%simvals(n1) = this%simvals(n1) - q + idiag = this%dis%con%ia(igwfnode) + flowja(idiag) = flowja(idiag) - q + end if end do ! From 2ce48fd9755a3863ef8690dd15e290bbdd45788f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 19 May 2023 09:37:16 -0700 Subject: [PATCH 131/212] Some work on LKE --- src/Model/GroundWaterEnergy/gwe1.f90 | 9 +- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 113 ++++++++++++++++++++--- 2 files changed, 103 insertions(+), 19 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 64723ef2ae9..110f94aa023 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1085,7 +1085,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & use SimModule, only: store_error use TspCncModule, only: cnc_create use GweSrcModule, only: src_create -! use GweLktModule, only: lkt_create + use GweLkeModule, only: lke_create use GweSfeModule, only: sfe_create ! use GweMwtModule, only: mwt_create use GweUzeModule, only: uze_create @@ -1113,9 +1113,10 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab, this%gwecommon) - !case('LKE6') - ! call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) + case('LKE6') + call lke_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%fmi, this%tsplab, this%eqnsclfac, & + this%gwecommon) case ('SFE6') call sfe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%tsplab, this%eqnsclfac, & diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index e7e374314cb..525d840df6a 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -19,6 +19,7 @@ ! EXT-INFLOW idxbudiflw EXT-INFLOW q * ciflw ! WITHDRAWAL idxbudwdrl WITHDRAWAL q * cfeat ! EXT-OUTFLOW idxbudoutf EXT-OUTFLOW q * cfeat +! LAKEBED-COND idxbudlbcd LAKEBED-COND ! kluge note: expression for this ! -- terms from a flow file that should be skipped ! CONSTANT none none none @@ -63,6 +64,7 @@ module GweLkeModule integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr integer(I4B), pointer :: idxbudwdrl => null() ! index of withdrawal terms in flowbudptr integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr + integer(I4B), pointer :: idxbudlbcd => null() ! index of lakebed conduction terms in flowbudptr real(DP), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature real(DP), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature @@ -240,6 +242,7 @@ subroutine find_lke_package(this) this%idxbudssm(ip) = 0 case ('GWF') this%idxbudgwf = ip + this%idxbudlbcd = ip this%idxbudssm(ip) = 0 case ('STORAGE') this%idxbudsto = ip @@ -304,12 +307,18 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B), dimension(:), intent(in) :: idxglo class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: j, n1, n2 + integer(I4B) :: j, n, n1, n2 integer(I4B) :: iloc - integer(I4B) :: iposd + integer(I4B) :: iposd, iposoffd + integer(I4B) :: ipossymd, ipossymoffd + integer(I4B) :: auxpos real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval + real(DP) :: ctherm !< thermal conductance + real(DP) :: wa !< wetted area + real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: s !< thickness of conductive streambed material ! ------------------------------------------------------------------------------ ! ! -- add rainfall contribution @@ -378,6 +387,34 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end do end if ! + ! -- add lakebed conduction contribution + do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + ! + ! -- set n to feature number and process if active feature + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + if (this%iboundpak(n) /= 0) then + ! + ! -- set acoef and rhs to negative so they are relative to sfe and not gwe + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + ktf = this%ktf(j) + s = this%rbthcnd(j) + ctherm = ktf * wa / s + ! + ! -- add to sfe row + iposd = this%idxdglo(j) + iposoffd = this%idxoffdglo(j) + call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposoffd, ctherm) + ! + ! -- add to gwe row for sfe connection + ipossymd = this%idxsymdglo(j) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymd, ctherm) + call matrix_sln%add_value_pos(ipossymoffd, -ctherm) + end if + end do + ! ! -- Return return end subroutine lke_fc_expanded @@ -485,7 +522,9 @@ subroutine lke_setup_budobj(this, idx) class(GweLkeType) :: this integer(I4B), intent(inout) :: idx ! -- local + integer(I4B) :: n, n1, n2 integer(I4B) :: maxlist, naux + real(DP) :: q character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! @@ -567,17 +606,33 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! + ! -- conduction through the wetted lakebed + text = ' LAKEBED-COND' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudlbcd)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + call this%budobj%budterm(idx)%reset(maxlist) + q = DZERO + do n = 1, maxlist + n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(n) + n2 = this%flowbudptr%budterm(this%idxbudgwf)%id2(n) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + end do + ! ! -- return return end subroutine lke_setup_budobj + !> @brief Copy flow terms into this%budobj + !< subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! lke_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweLkeType) :: this @@ -589,10 +644,16 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- local integer(I4B) :: j, n1, n2 integer(I4B) :: nlist + integer(I4B) :: igwfnode + integer(I4B) :: auxpos real(DP) :: q + real(DP) :: ctherm !< thermal conductance + real(DP) :: wa !< wetted area + real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- RAIN idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist @@ -602,7 +663,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EVAPORATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist @@ -612,7 +673,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- RUNOFF idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist @@ -622,7 +683,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-INFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist @@ -632,7 +693,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- WITHDRAWAL idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudwdrl)%nlist @@ -642,7 +703,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-OUTFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist @@ -652,7 +713,26 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! + ! -- LAKEBED-COND + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do j = 1, this%flowbudptr%budterm(this%idxbudlbcd)%nlist + q = DZERO + n1 = this%flowbudptr%budterm(this%idxbudlbcd)%id1(j) + if (this%iboundpak(n1) /= 0) then + igwfnode = this%flowbudptr%budterm(this%idxbudlbcd)%id2(j) + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + ktf = this%ktf(j) + s = this%rbthcnd(j) + ctherm = ktf * wa / s + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct + !q = -q ! flip sign so relative to advanced package feature + end if + call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do ! ! -- return return @@ -682,6 +762,7 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath) call mem_allocate(this%idxbudwdrl, 'IDXBUDWDRL', this%memoryPath) call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath) + call mem_allocate(this%idxbudlbcd, 'IDXBUDLBCD', this%memoryPath) ! ! -- Initialize this%idxbudrain = 0 @@ -690,6 +771,7 @@ subroutine allocate_scalars(this) this%idxbudiflw = 0 this%idxbudwdrl = 0 this%idxbudoutf = 0 + this%idxbudlbcd = 0 ! ! -- Return return @@ -753,6 +835,7 @@ subroutine lke_da(this) call mem_deallocate(this%idxbudiflw) call mem_deallocate(this%idxbudwdrl) call mem_deallocate(this%idxbudoutf) + call mem_deallocate(this%idxbudlbcd) ! ! -- deallocate time series call mem_deallocate(this%temprain) From aad427cb2a2965070b55d226c1ac64907d98e93d Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 19 May 2023 16:11:43 -0700 Subject: [PATCH 132/212] Get the SFE example with conduction working again, fix a sign convension sfe_fc_expanded for getting the correct groundwater temperature changes associated with conduction. --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 16 +++++++++----- src/Model/GroundWaterTransport/tsp1apt1.f90 | 23 ++++++++++++--------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 6e9fb6856bc..6a12f83babc 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -284,7 +284,7 @@ subroutine find_sfe_package(this) write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! ! -- streambed conduction term - this%idxbudsbcd = this%flowbudptr%nbudterm + 1 + this%idxbudsbcd = this%idxbudgwf ! ! -- Return return @@ -397,8 +397,8 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to gwe row for sfe connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, ctherm) - call matrix_sln%add_value_pos(ipossymoffd, -ctherm) + call matrix_sln%add_value_pos(ipossymd, -ctherm) + call matrix_sln%add_value_pos(ipossymoffd, ctherm) end if end do ! @@ -477,8 +477,14 @@ function sfe_get_nbudterms(this) result(nbudterms) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- Number of budget terms is 6 - nbudterms = 5 + ! -- Number of budget terms is 6: + ! 1. rainfall + ! 2. evaporation + ! 3. runoff + ! 4. ext-inflow + ! 5. ext-outflow + ! 6. streambed-cond + nbudterms = 6 ! ! -- Return return diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 92fbe7edc28..b9ed5d304f4 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -2175,6 +2175,9 @@ subroutine apt_setup_budobj(this) character(len=LENBUDTXT) :: text, textt character(len=LENBUDTXT), dimension(1) :: auxtxt ! ------------------------------------------------------------------------------ + ! + ! -- Initialize nbudterm + nbudterm = 0 ! ! -- Determine if there are flow-ja-face terms nlen = 0 @@ -2185,22 +2188,22 @@ subroutine apt_setup_budobj(this) ! -- Determine the number of budget terms associated with apt. ! These are fixed for the simulation and cannot change ! - ! -- The first 3 are for GWF, STORAGE, and CONSTANT - nbudterm = 3 + ! -- add one if flow-ja-face present + if (this%idxbudfjf /= 0) nbudterm = nbudterm + 1 + ! + ! -- All the APT packages have GWF, STORAGE, and CONSTANT + nbudterm = nbudterm + 3 ! ! -- add terms for the specific package nbudterm = nbudterm + this%pak_get_nbudterms() - ! - ! -- add one for flow-ja-face - if (nlen > 0) nbudterm = nbudterm + 1 ! ! -- add one for shared wetted area facilitating conduction in SFE, LKE, ! and MWE (but not UZE) in GWE model - if (this%tsplab%tsptype == 'GWE') then - if (adjustl(trim(this%text)) /= 'UZE') then - if (nlen > 0) nbudterm = nbudterm + 1 - end if - end if + !if (this%tsplab%tsptype == 'GWE') then + ! if (adjustl(trim(this%text)) /= 'UZE') then + ! if (nlen > 0) nbudterm = nbudterm + 1 + ! end if + !end if ! ! -- add for mover terms and auxiliary if (this%idxbudtmvr /= 0) nbudterm = nbudterm + 1 From 3b9d84772de5c811e5ef8caa77ad6c42d81041ae Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 22 May 2023 11:49:32 -0700 Subject: [PATCH 133/212] Some fixes in SFE, get the LKE budget working correctly --- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 30 ++++++++++++++------- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 8 +++--- src/Model/GroundWaterTransport/tsp1apt1.f90 | 4 +-- 3 files changed, 26 insertions(+), 16 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index 525d840df6a..fb6fbcf3447 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -397,8 +397,8 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- set acoef and rhs to negative so they are relative to sfe and not gwe auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) - ktf = this%ktf(j) - s = this%rbthcnd(j) + ktf = this%ktf(n) + s = this%rbthcnd(n) ctherm = ktf * wa / s ! ! -- add to sfe row @@ -410,8 +410,8 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to gwe row for sfe connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) - call matrix_sln%add_value_pos(ipossymd, ctherm) - call matrix_sln%add_value_pos(ipossymoffd, -ctherm) + call matrix_sln%add_value_pos(ipossymd, -ctherm) + call matrix_sln%add_value_pos(ipossymoffd, ctherm) end if end do ! @@ -502,8 +502,11 @@ function lke_get_nbudterms(this) result(nbudterms) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- Number of budget terms is 6 - nbudterms = 6 + ! -- Number of budget terms is 7 + ! 1) rainfall; 2) evap; 3) runoff; 4) ext-inflow; 5) withdrawl; + ! 6) ext-outflow; 7) lakebed-cond + ! + nbudterms = 7 ! ! -- Return return @@ -645,6 +648,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) integer(I4B) :: j, n1, n2 integer(I4B) :: nlist integer(I4B) :: igwfnode + integer(I4B) :: idiag integer(I4B) :: auxpos real(DP) :: q real(DP) :: ctherm !< thermal conductance @@ -724,14 +728,20 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) igwfnode = this%flowbudptr%budterm(this%idxbudlbcd)%id2(j) auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) - ktf = this%ktf(j) - s = this%rbthcnd(j) + ktf = this%ktf(n1) + s = this%rbthcnd(n1) ctherm = ktf * wa / s q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct !q = -q ! flip sign so relative to advanced package feature end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + if (this%iboundpak(n1) /= 0) then + ! -- contribution to gwe cell budget + this%simvals(n1) = this%simvals(n1) - q + idiag = this%dis%con%ia(igwfnode) + flowja(idiag) = flowja(idiag) - q + end if end do ! ! -- return @@ -1103,8 +1113,8 @@ subroutine lke_df_obs(this) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! ! -- Store obs type and assign procedure pointer - ! for observation type: lkt - call this%obs%StoreObsType('lkt', .true., indx) + ! for observation type: lke + call this%obs%StoreObsType('lke', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID12 ! ! -- Store obs type and assign procedure pointer diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 6a12f83babc..fef9c171b14 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -384,8 +384,8 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- set acoef and rhs to negative so they are relative to sfe and not gwe auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) - ktf = this%ktf(j) - s = this%rbthcnd(j) + ktf = this%ktf(n) + s = this%rbthcnd(n) ctherm = ktf * wa / s ! ! -- add to sfe row @@ -679,8 +679,8 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) - ktf = this%ktf(j) - s = this%rbthcnd(j) + ktf = this%ktf(n1) + s = this%rbthcnd(n1) ctherm = ktf * wa / s q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct !q = -q ! flip sign so relative to advanced package feature diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index b9ed5d304f4..fc6de9f0f16 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -3018,7 +3018,7 @@ subroutine apt_rp_obs(this) ' must be assigned to a feature with a unique boundname.' call store_error(errmsg) end if - case ('LKT', 'SFT', 'MWT', 'UZT', 'UZE') + case ('LKT', 'SFT', 'MWT', 'UZT', 'UZE', 'LKE', 'SFE') call this%rp_obs_budterm(obsrv, & this%flowbudptr%budterm(this%idxbudgwf)) case ('FLOW-JA-FACE') @@ -3103,7 +3103,7 @@ subroutine apt_bd_obs(this) if (this%iboundpak(jj) /= 0) then v = this%xnewpak(jj) end if - case ('LKT', 'SFT', 'MWT', 'UZT', 'UZE') + case ('LKT', 'SFT', 'MWT', 'UZT', 'LKE', 'SFE', 'MWE', 'UZE') n = this%flowbudptr%budterm(this%idxbudgwf)%id1(jj) if (this%iboundpak(n) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(jj) From ee471361235d4791de121c427e820a2866ea1723 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 23 May 2023 09:17:51 -0700 Subject: [PATCH 134/212] Dfn file modifications that need to be checked in --- doc/mf6io/mf6ivar/dfn/gwe-lke.dfn | 44 +++++++++++++++++++++++-------- doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn | 22 +++++++++++++++- 2 files changed, 54 insertions(+), 12 deletions(-) diff --git a/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn b/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn index df2a049f7d0..b59b50420b2 100644 --- a/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwe-lke.dfn @@ -37,16 +37,6 @@ optional true longname description REPLACE boundnames {'{#1}': 'lake'} -block options -name latentheatvapor -type double precision -reader urword -optional true -longname latent heat of vaporation of water -description latent heat of vaporization of water. For freshwater at 25$^{\circ}C$, the latent heat of vaporization is approximately 2,450.0 kJ/kg in SI units. Between 0 and 100$^{\circ}C$, latent heat of vaporization may vary by as much as 10 percent, but is held constant in the initial release of the GWE model. By default, the latent heat of vaporization is 2,450.0 kJ/kg. -default_value 2545 - - block options name print_input type keyword @@ -269,7 +259,7 @@ description REPLACE obs6_filename {'{#1}': 'LKE'} block packagedata name packagedata -type recarray lakeno strt aux boundname +type recarray lakeno strt ktf rbthcnd aux boundname shape (maxbound) reader urword longname @@ -296,6 +286,26 @@ reader urword longname starting lake temperature description real value that defines the starting temperature for the lake. +block packagedata +name ktf +type double precision +shape +tagged false +in_record true +reader urword +longname boundary thermal conductivity +description is the thermal conductivity of the of the interface between the aquifer cell and the lake. + +block packagedata +name rbthcnd +type double precision +shape +tagged false +in_record true +reader urword +longname streambed thickness +description real value that defines the thickness of the lakebed material through which conduction occurs. Must be greater than 0. + block packagedata name aux type double precision @@ -396,6 +406,18 @@ time_series true longname rainfall temperature description real or character value that defines the rainfall temperature for the lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. +block period +name evaporation +type string +shape +tagged true +in_record true +reader urword +time_series true +longname evaporation temperature +description real or character value that defines the temperature of evaporated water $(^{\circ}C)$ for the reach. If this temperature value is larger than the simulated temperature in the reach, then the evaporated water will be removed at the same temperature as the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + + block period name runoff type string diff --git a/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn b/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn index d960f2d07ab..610e3911ff1 100644 --- a/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn +++ b/doc/mf6io/mf6ivar/dfn/gwe-sfe.dfn @@ -259,7 +259,7 @@ description REPLACE obs6_filename {'{#1}': 'SFT'} block packagedata name packagedata -type recarray rno strt aux boundname +type recarray rno strt ktf rbthcnd aux boundname shape (maxbound) reader urword longname @@ -286,6 +286,26 @@ reader urword longname starting reach temperature description real value that defines the starting temperature for the reach. +block packagedata +name ktf +type double precision +shape +tagged false +in_record true +reader urword +longname boundary thermal conductivity +description is the thermal conductivity of the of the interface between the aquifer cell and the stream reach. + +block packagedata +name rbthcnd +type double precision +shape +tagged false +in_record true +reader urword +longname streambed thickness +description real value that defines the thickness of the streambed material through which conduction occurs. Must be greater than 0. + block packagedata name aux type double precision From 0d92ea7e692bf2e664a31c8c17a56e2b51467184 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 23 May 2023 09:19:58 -0700 Subject: [PATCH 135/212] Some preliminary work on MWE --- doc/mf6io/mf6ivar/dfn/gwe-disu.dfn | 277 ++++++ doc/mf6io/mf6ivar/dfn/gwe-mwe.dfn | 447 ++++++++++ doc/mf6io/mf6ivar/mf6ivar.py | 3 + msvs/mf6core.vfproj | 1 + src/Model/GroundWaterEnergy/gwe1.f90 | 21 +- src/Model/GroundWaterEnergy/gwe1mwe1.f90 | 1010 ++++++++++++++++++++++ 6 files changed, 1749 insertions(+), 10 deletions(-) create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-disu.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-mwe.dfn create mode 100644 src/Model/GroundWaterEnergy/gwe1mwe1.f90 diff --git a/doc/mf6io/mf6ivar/dfn/gwe-disu.dfn b/doc/mf6io/mf6ivar/dfn/gwe-disu.dfn new file mode 100644 index 00000000000..ec86d0852c7 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-disu.dfn @@ -0,0 +1,277 @@ +# --------------------- gwe disu options --------------------- + +block options +name length_units +type string +reader urword +optional true +longname model length units +description is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. + +block options +name nogrb +type keyword +reader urword +optional true +longname do not write binary grid file +description keyword to deactivate writing of the binary grid file. + +block options +name xorigin +type double precision +reader urword +optional true +longname x-position origin of the model grid coordinate system +description x-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name yorigin +type double precision +reader urword +optional true +longname y-position origin of the model grid coordinate system +description y-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name angrot +type double precision +reader urword +optional true +longname rotation angle +description counter-clockwise rotation angle (in degrees) of the model grid coordinate system relative to a real-world coordinate system. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +block options +name vertical_offset_tolerance +type double precision +reader urword +optional true +default_value 0.0 +longname vertical length dimension for top and bottom checking +description checks are performed to ensure that the top of a cell is not higher than the bottom of an overlying cell. This option can be used to specify the tolerance that is used for checking. If top of a cell is above the bottom of an overlying cell by a value less than this tolerance, then the program will not terminate with an error. The default value is zero. This option should generally not be used. +mf6internal voffsettol + +# --------------------- gwe disu dimensions --------------------- + +block dimensions +name nodes +type integer +reader urword +optional false +longname number of layers +description is the number of cells in the model grid. + +block dimensions +name nja +type integer +reader urword +optional false +longname number of columns +description is the sum of the number of connections and NODES. When calculating the total number of connections, the connection between cell n and cell m is considered to be different from the connection between cell m and cell n. Thus, NJA is equal to the total number of connections, including n to m and m to n, and the total number of cells. + +block dimensions +name nvert +type integer +reader urword +optional true +longname number of vertices +description is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. NVERT and the accompanying VERTICES and CELL2D blocks should be specified for most simulations. If the XT3D or SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package, then this information is required. + +# --------------------- gwe disu griddata --------------------- + +block griddata +name top +type double precision +shape (nodes) +reader readarray +longname cell top elevation +description is the top elevation for each cell in the model grid. + +block griddata +name bot +type double precision +shape (nodes) +reader readarray +longname cell bottom elevation +description is the bottom elevation for each cell. + +block griddata +name area +type double precision +shape (nodes) +reader readarray +longname cell surface area +description is the cell surface area (in plan view). + +block griddata +name idomain +type integer +shape (nodes) +reader readarray +layered false +optional true +longname idomain existence array +description is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1 or greater, the cell exists in the simulation. IDOMAIN values of -1 cannot be specified for the DISU Package. + +# --------------------- gwe disu connectiondata --------------------- + +block connectiondata +name iac +type integer +shape (nodes) +reader readarray +longname number of cell connections +description is the number of connections (plus 1) for each cell. The sum of all the entries in IAC must be equal to NJA. + +block connectiondata +name ja +type integer +shape (nja) +reader readarray +longname grid connectivity +description is a list of cell number (n) followed by its connecting cell numbers (m) for each of the m cells connected to cell n. The number of values to provide for cell n is IAC(n). This list is sequentially provided for the first to the last cell. The first value in the list must be cell n itself, and the remaining cells must be listed in an increasing order (sorted from lowest number to highest). Note that the cell and its connections are only supplied for the GWE cells and their connections to the other GWE cells. Also note that the JA list input may be divided such that every node and its connectivity list can be on a separate line for ease in readability of the file. To further ease readability of the file, the node number of the cell whose connectivity is subsequently listed, may be expressed as a negative number, the sign of which is subsequently converted to positive by the code. +numeric_index true +jagged_array iac + +block connectiondata +name ihc +type integer +shape (nja) +reader readarray +longname connection type +description is an index array indicating the direction between node n and all of its m connections. If IHC = 0 then cell n and cell m are connected in the vertical direction. Cell n overlies cell m if the cell number for n is less than m; cell m overlies cell n if the cell number for m is less than n. If IHC = 1 then cell n and cell m are connected in the horizontal direction. If IHC = 2 then cell n and cell m are connected in the horizontal direction, and the connection is vertically staggered. A vertically staggered connection is one in which a cell is horizontally connected to more than one cell in a horizontal connection. +jagged_array iac + +block connectiondata +name cl12 +type double precision +shape (nja) +reader readarray +longname connection lengths +description is the array containing connection lengths between the center of cell n and the shared face with each adjacent m cell. +jagged_array iac + +block connectiondata +name hwva +type double precision +shape (nja) +reader readarray +longname connection lengths +description is a symmetric array of size NJA. For horizontal connections, entries in HWVA are the horizontal width perpendicular to flow. For vertical connections, entries in HWVA are the vertical area for flow. Thus, values in the HWVA array contain dimensions of both length and area. Entries in the HWVA array have a one-to-one correspondence with the connections specified in the JA array. Likewise, there is a one-to-one correspondence between entries in the HWVA array and entries in the IHC array, which specifies the connection type (horizontal or vertical). Entries in the HWVA array must be symmetric; the program will terminate with an error if the value for HWVA for an n to m connection does not equal the value for HWVA for the corresponding n to m connection. +jagged_array iac + +block connectiondata +name angldegx +type double precision +optional true +shape (nja) +reader readarray +longname angle of face normal to connection +description is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells. The angle varies between zero and 360.0 degrees, where zero degrees points in the positive x-axis direction, and 90 degrees points in the positive y-axis direction. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package, if the XT3D option is used in the NPF Package, or if the SAVE\_SPECIFIC\_DISCHARGE option is specifed in the NPF Package. ANGLDEGX does not need to be specified if these conditions are not met. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. +jagged_array iac + +# --------------------- gwe disu vertices --------------------- + +block vertices +name vertices +type recarray iv xv yv +shape (nvert) +reader urword +optional false +longname vertices data +description + +block vertices +name iv +type integer +in_record true +tagged false +reader urword +optional false +longname vertex number +description is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. +numeric_index true + +block vertices +name xv +type double precision +in_record true +tagged false +reader urword +optional false +longname x-coordinate for vertex +description is the x-coordinate for the vertex. + +block vertices +name yv +type double precision +in_record true +tagged false +reader urword +optional false +longname y-coordinate for vertex +description is the y-coordinate for the vertex. + + +# --------------------- gwe disu cell2d --------------------- + +block cell2d +name cell2d +type recarray icell2d xc yc ncvert icvert +shape (nodes) +reader urword +optional false +longname cell2d data +description + +block cell2d +name icell2d +type integer +in_record true +tagged false +reader urword +optional false +longname cell2d number +description is the cell2d number. Records in the CELL2D block must be listed in consecutive order from 1 to NODES. +numeric_index true + +block cell2d +name xc +type double precision +in_record true +tagged false +reader urword +optional false +longname x-coordinate for cell center +description is the x-coordinate for the cell center. + +block cell2d +name yc +type double precision +in_record true +tagged false +reader urword +optional false +longname y-coordinate for cell center +description is the y-coordinate for the cell center. + +block cell2d +name ncvert +type integer +in_record true +tagged false +reader urword +optional false +longname number of cell vertices +description is the number of vertices required to define the cell. There may be a different number of vertices for each cell. + +block cell2d +name icvert +type integer +shape (ncvert) +in_record true +tagged false +reader urword +optional false +longname array of vertex numbers +description is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. +numeric_index true diff --git a/doc/mf6io/mf6ivar/dfn/gwe-mwe.dfn b/doc/mf6io/mf6ivar/dfn/gwe-mwe.dfn new file mode 100644 index 00000000000..c805b6533fe --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-mwe.dfn @@ -0,0 +1,447 @@ +# --------------------- gwe mwe options --------------------- +# flopy multi-package + +block options +name flow_package_name +type string +shape +reader urword +optional true +longname keyword to specify name of corresponding flow package +description keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +block options +name auxiliary +type string +shape (naux) +reader urword +optional true +longname keyword to specify aux variables +description REPLACE auxnames {'{#1}': 'Groundwater Energy Transport'} + +block options +name flow_package_auxiliary_name +type string +shape +reader urword +optional true +longname keyword to specify name of temperature auxiliary variable in flow package +description keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated temperatures from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'well'} + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'well'} + +block options +name print_temperature +type keyword +reader urword +optional true +longname print calculated temperatures to listing file +description REPLACE print_temperature {'{#1}': 'well', '{#2}': 'temperature', '{#3}': 'TEMPERATURE'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'well'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save well flows to budget file +description REPLACE save_flows {'{#1}': 'well'} + +block options +name temperature_filerecord +type record temperature fileout tempfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name temperature +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname stage keyword +description keyword to specify that record corresponds to temperature. + +block options +name tempfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write temperature information. + +block options +name budget_filerecord +type record budget fileout budgetfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budget +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name budgetfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write budget information. + +block options +name budgetcsv_filerecord +type record budgetcsv fileout budgetcsvfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budgetcsv +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget CSV. + +block options +name budgetcsvfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +block options +name ts_filerecord +type record ts6 filein ts6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name ts6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname head keyword +description keyword to specify that record corresponds to a time-series file. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name ts6_filename +type string +preserve_case true +in_record true +reader urword +optional false +tagged false +longname file name of time series information +description REPLACE timeseriesfile {} + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description REPLACE obs6_filename {'{#1}': 'MWE'} + + +# --------------------- gwe mwe packagedata --------------------- + +block packagedata +name packagedata +type recarray mawno strt ktf fthk aux boundname +shape (maxbound) +reader urword +longname +description + +block packagedata +name mawno +type integer +shape +tagged false +in_record true +reader urword +longname well number for this entry +description integer value that defines the well number associated with the specified PACKAGEDATA data on the line. MAWNO must be greater than zero and less than or equal to NMAWWELLS. Well information must be specified for every well or the program will terminate with an error. The program will also terminate with an error if information for a well is specified more than once. +numeric_index true + +block packagedata +name strt +type double precision +shape +tagged false +in_record true +reader urword +longname starting well temperature +description real value that defines the starting temperature for the well. + +block packagedata +name ktf +type double precision +shape +tagged false +in_record true +reader urword +longname thermal conductivity of the feature +description is the thermal conductivity of the of the interface between the aquifer cell and the feature. + +block packagedata +name fthk +type double precision +shape +tagged false +in_record true +reader urword +longname thickness of the well feature +description real value that defines the thickness of the material through which conduction occurs. Must be greater than 0. + +block packagedata +name aux +type double precision +in_record true +tagged false +shape (naux) +reader urword +time_series true +optional true +longname auxiliary variables +description REPLACE aux {'{#1}': 'well'} + +block packagedata +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname well name +description REPLACE boundname {'{#1}': 'well'} + + +# --------------------- gwe mwe period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name mweperioddata +type recarray mawno mwesetting +shape +reader urword +longname +description + +block period +name mawno +type integer +shape +tagged false +in_record true +reader urword +longname well number for this entry +description integer value that defines the well number associated with the specified PERIOD data on the line. MAWNO must be greater than zero and less than or equal to NMAWWELLS. +numeric_index true + +block period +name mwesetting +type keystring status temperature rate auxiliaryrecord +shape +tagged false +in_record true +reader urword +longname +description line of information that is parsed into a keyword and values. Keyword values that can be used to start the MWESETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature of associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Multi-Aquifer Well Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the well at the calculated temperature of the well. + +block period +name status +type string +shape +tagged true +in_record true +reader urword +longname well temperature status +description keyword option to define well status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the well. If a well is inactive, then there will be no solute mass fluxes into or out of the well and the inactive value will be written for the well temperature. If a well is constant, then the temperature for the well will be fixed at the user specified value. + +block period +name temperature +type string +shape +tagged true +in_record true +time_series true +reader urword +longname well temperature +description real or character value that defines the temperature for the well. The specified TEMPERATURE is only applied if the well is a constant temperature well. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name rate +type string +shape +tagged true +in_record true +reader urword +time_series true +longname well injection temperature +description real or character value that defines the injection solute temperature $^{\circ}C$ for the well. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name auxiliaryrecord +type record auxiliary auxname auxval +shape +tagged +in_record true +reader urword +longname +description + +block period +name auxiliary +type keyword +shape +in_record true +reader urword +longname +description keyword for specifying auxiliary variable. + +block period +name auxname +type string +shape +tagged false +in_record true +reader urword +longname +description name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +block period +name auxval +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname auxiliary variable value +description value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. diff --git a/doc/mf6io/mf6ivar/mf6ivar.py b/doc/mf6io/mf6ivar/mf6ivar.py index d2c014290aa..ffbe2b50142 100644 --- a/doc/mf6io/mf6ivar/mf6ivar.py +++ b/doc/mf6io/mf6ivar/mf6ivar.py @@ -695,10 +695,13 @@ def write_appendix(texdir, allblocks): 'gwe-adv', 'gwe-dis', 'gwe-disv', + 'gwe-disu', 'gwe-dsp', 'gwe-fmi', 'gwe-ic', + 'gwe-lke', 'gwe-mst', + 'gwe-mwe', 'gwe-oc', 'gwe-sfe', 'gwe-src', diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 5c3cf673ca5..44279c722bf 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -133,6 +133,7 @@ + diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 110f94aa023..1d890448754 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -1087,7 +1087,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & use GweSrcModule, only: src_create use GweLkeModule, only: lke_create use GweSfeModule, only: sfe_create -! use GweMwtModule, only: mwt_create + use GweMweModule, only: mwe_create use GweUzeModule, only: uze_create ! use ApiModule, only: api_create ! -- dummy @@ -1113,21 +1113,22 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & case ('SRC6') call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%tsplab, this%gwecommon) - case('LKE6') + case ('LKE6') call lke_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%tsplab, this%eqnsclfac, & - this%gwecommon) + this%gwecommon) case ('SFE6') call sfe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab, this%eqnsclfac, & - this%gwecommon) - !case('MWT6') - ! call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac, & + this%gwecommon) + case ('MWE6') + call mwe_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%fmi, this%tsplab, this%eqnsclfac, & + this%gwecommon) case ('UZE6') call uze_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi, this%tsplab, this%eqnsclfac, & - this%gwecommon) + pakname, this%fmi, this%tsplab, this%eqnsclfac, & + this%gwecommon) !case('IST6') ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname, this%fmi, this%mst) diff --git a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 new file mode 100644 index 00000000000..1020b985d0b --- /dev/null +++ b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 @@ -0,0 +1,1010 @@ +! -- Multi-Aquifer Well Energy Transport Module +! -- todo: save the mwe temperature into the mwe aux variable? +! -- todo: calculate the maw DENSE aux variable using temperature? +! +! MAW flows (flowbudptr) index var MWE term Transport Type +!--------------------------------------------------------------------------------- + +! -- terms from MAW that will be handled by parent APT Package +! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv (note that this doesn't exist for MAW) +! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf +! STORAGE (aux VOLUME) idxbudsto none used for cv volumes +! FROM-MVR idxbudfmvr FROM-MVR q * text = this%qfrommvr(:) +! TO-MVR idxbudtmvr TO-MVR q * tfeat + +! -- MAW terms +! RATE idxbudrate RATE q < 0: q * twell, else q * tuser +! FW-RATE idxbudfwrt FW-RATE q * twell +! RATE-TO-MVR idxbudrtmv RATE-TO-MVR q * twell +! FW-RATE-TO-MVR idxbudfrtm FW-RATE-TO-MVR q * twell +! WELL-AQUIFER CONDUCTION idxbudmwcd MW-CONDUCTION K_t_f * WetArea / thickness + +! -- terms from MAW that should be skipped +! CONSTANT-TO-MVR ? CONSTANT-TO-MVR q * twell + +! -- terms from a flow file that should be skipped +! CONSTANT none none none +! AUXILIARY none none none + +! -- terms that are written to the energy transport budget file +! none none STORAGE (aux ENER) dE/dt +! none none AUXILIARY none +! none none CONSTANT accumulate +! +! +module GweMweModule + + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LINELENGTH + use SimModule, only: store_error + use BndModule, only: BndType, GetBndFromList + use TspFmiModule, only: TspFmiType + use MawModule, only: MawType + use ObserveModule, only: ObserveType + use TspAptModule, only: TspAptType, apt_process_obsID, & + apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType + use GweInputDataModule, only: GweInputDataType + use MatrixBaseModule + + implicit none + + public mwe_create + + character(len=*), parameter :: ftype = 'MWE' + character(len=*), parameter :: flowtype = 'MAW' + character(len=16) :: text = ' MWE' + + type, extends(TspAptType) :: GweMweType + + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + + integer(I4B), pointer :: idxbudrate => null() ! index of well rate terms in flowbudptr + integer(I4B), pointer :: idxbudfwrt => null() ! index of flowing well rate terms in flowbudptr + integer(I4B), pointer :: idxbudrtmv => null() ! index of rate to mover terms in flowbudptr + integer(I4B), pointer :: idxbudfrtm => null() ! index of flowing well rate to mover terms in flowbudptr + integer(I4B), pointer :: idxbudmwcd => null() ! index of well bore conduction terms in flowbudptr + real(DP), dimension(:), pointer, contiguous :: temprate => null() ! well rate temperature + + contains + + procedure :: bnd_da => mwe_da + procedure :: allocate_scalars + procedure :: apt_allocate_arrays => mwe_allocate_arrays + procedure :: find_apt_package => find_mwe_package + procedure :: pak_fc_expanded => mwe_fc_expanded + procedure :: pak_solve => mwe_solve + procedure :: pak_get_nbudterms => mwe_get_nbudterms + procedure :: pak_setup_budobj => mwe_setup_budobj + procedure :: pak_fill_budobj => mwe_fill_budobj + procedure :: mwe_rate_term + procedure :: mwe_fwrt_term + procedure :: mwe_rtmv_term + procedure :: mwe_frtm_term + procedure :: pak_df_obs => mwe_df_obs + procedure :: pak_rp_obs => mwe_rp_obs + procedure :: pak_bd_obs => mwe_bd_obs + procedure :: pak_set_stressperiod => mwe_set_stressperiod + + end type GweMweType + +contains + + subroutine mwe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & + fmi, tsplab, eqnsclfac, gwecommon) +! ****************************************************************************** +! mwe_create -- Create a New MWE Package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(BndType), pointer :: packobj + integer(I4B), intent(in) :: id + integer(I4B), intent(in) :: ibcnum + integer(I4B), intent(in) :: inunit + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: namemodel + character(len=*), intent(in) :: pakname + type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor + type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages + ! -- local + type(GweMweType), pointer :: mweobj +! ------------------------------------------------------------------------------ + ! + ! -- allocate the object and assign values to object variables + allocate (mweobj) + packobj => mweobj + ! + ! -- create name and memory path + call packobj%set_names(ibcnum, namemodel, pakname, ftype) + packobj%text = text + ! + ! -- allocate scalars + call mweobj%allocate_scalars() + ! + ! -- initialize package + call packobj%pack_initialize() + + packobj%inunit = inunit + packobj%iout = iout + packobj%id = id + packobj%ibcnum = ibcnum + packobj%ncolbnd = 1 + packobj%iscloc = 1 + + ! -- Store pointer to flow model interface. When the GwfGwe exchange is + ! created, it sets fmi%bndlist so that the GWE model has access to all + ! the flow packages + mweobj%fmi => fmi + ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + mweobj%tsplab => tsplab + ! + ! -- Store pointer to governing equation scale factor + mweobj%eqnsclfac => eqnsclfac + ! + ! -- Store pointer to shared data module for accessing cpw, rhow + ! for the budget calculations, and for accessing the latent heat of + ! vaporization for evaporative cooling. + mweobj%gwecommon => gwecommon + ! + ! -- return + return + end subroutine mwe_create + + subroutine find_mwe_package(this) +! ****************************************************************************** +! find corresponding mwe package +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweMweType) :: this + ! -- local + character(len=LINELENGTH) :: errmsg + class(BndType), pointer :: packobj + integer(I4B) :: ip, icount + integer(I4B) :: nbudterm + logical :: found +! ------------------------------------------------------------------------------ + ! + ! -- Initialize found to false, and error later if flow package cannot + ! be found + found = .false. + ! + ! -- If user is specifying flows in a binary budget file, then set up + ! the budget file reader, otherwise set a pointer to the flow package + ! budobj + if (this%fmi%flows_from_file) then + call this%fmi%set_aptbudobj_pointer(this%flowpackagename, this%flowbudptr) + if (associated(this%flowbudptr)) found = .true. + ! + else + if (associated(this%fmi%gwfbndlist)) then + ! -- Look through gwfbndlist for a flow package with the same name as + ! this transport package name + do ip = 1, this%fmi%gwfbndlist%Count() + packobj => GetBndFromList(this%fmi%gwfbndlist, ip) + if (packobj%packName == this%flowpackagename) then + found = .true. + ! + ! -- store BndType pointer to packobj, and then + ! use the select type to point to the budobj in flow package + this%flowpackagebnd => packobj + select type (packobj) + type is (MawType) + this%flowbudptr => packobj%budobj + end select + end if + if (found) exit + end do + end if + end if + ! + ! -- error if flow package not found + if (.not. found) then + write (errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '& + &//trim(adjustl(this%flowpackagename))//'.' + call store_error(errmsg) + call this%parser%StoreErrorUnit() + end if + ! + ! -- allocate space for idxbudssm, which indicates whether this is a + ! special budget term or one that is a general source and sink + nbudterm = this%flowbudptr%nbudterm + call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath) + ! + ! -- Process budget terms and identify special budget terms + write (this%iout, '(/, a, a)') & + 'PROCESSING '//ftype//' INFORMATION FOR ', this%packName + write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE' + write (this%iout, '(a, i0)') & + ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv + icount = 1 + do ip = 1, this%flowbudptr%nbudterm + select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype))) + case ('FLOW-JA-FACE') + this%idxbudfjf = ip + this%idxbudssm(ip) = 0 + case ('GWF') + this%idxbudgwf = ip + this%idxbudssm(ip) = 0 + case ('STORAGE') + this%idxbudsto = ip + this%idxbudssm(ip) = 0 + case ('RATE') + this%idxbudrate = ip + this%idxbudssm(ip) = 0 + case ('FW-RATE') + this%idxbudfwrt = ip + this%idxbudssm(ip) = 0 + case ('RATE-TO-MVR') + this%idxbudrtmv = ip + this%idxbudssm(ip) = 0 + case ('FW-RATE-TO-MVR') + this%idxbudfrtm = ip + this%idxbudssm(ip) = 0 + case ('TO-MVR') + this%idxbudtmvr = ip + this%idxbudssm(ip) = 0 + case ('FROM-MVR') + this%idxbudfmvr = ip + this%idxbudssm(ip) = 0 + case ('AUXILIARY') + this%idxbudaux = ip + this%idxbudssm(ip) = 0 + case default + ! + ! -- set idxbudssm equal to a column index for where the tempeartures + ! are stored in the tempbud(nbudssm, ncv) array + this%idxbudssm(ip) = icount + icount = icount + 1 + end select + write (this%iout, '(a, i0, " = ", a,/, a, i0)') & + ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), & + ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist + end do + write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' + ! + ! -- Return + return + end subroutine find_mwe_package + + subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) +! ****************************************************************************** +! mwe_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() +! in order to add matrix terms specifically for this package +! **************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweMweType) :: this + real(DP), dimension(:), intent(inout) :: rhs + integer(I4B), dimension(:), intent(in) :: ia + integer(I4B), dimension(:), intent(in) :: idxglo + class(MatrixBaseType), pointer :: matrix_sln + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: iloc + integer(I4B) :: iposd + real(DP) :: rrate + real(DP) :: rhsval + real(DP) :: hcofval +! ------------------------------------------------------------------------------ + ! + ! -- add puping rate contribution + if (this%idxbudrate /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrate)%nlist + call this%mwe_rate_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add flowing well rate contribution + if (this%idxbudfwrt /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudfwrt)%nlist + call this%mwe_fwrt_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add rate to mover contribution + if (this%idxbudrtmv /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrtmv)%nlist + call this%mwe_rtmv_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- add puping rate contribution + if (this%idxbudfrtm /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudfrtm)%nlist + call this%mwe_frtm_term(j, n1, n2, rrate, rhsval, hcofval) + iloc = this%idxlocnode(n1) + iposd = this%idxpakdiag(n1) + call matrix_sln%add_value_pos(iposd, hcofval) + rhs(iloc) = rhs(iloc) + rhsval + end do + end if + ! + ! -- Return + return + end subroutine mwe_fc_expanded + + subroutine mwe_solve(this) +! ****************************************************************************** +! mwe_solve -- add terms specific to multi-aquifer wells to the explicit multi- +! aquifer well solve +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweMweType) :: this + ! -- local + integer(I4B) :: j + integer(I4B) :: n1, n2 + real(DP) :: rrate +! ------------------------------------------------------------------------------ + ! + ! -- add well pumping contribution + if (this%idxbudrate /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrate)%nlist + call this%mwe_rate_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add flowing well rate contribution + if (this%idxbudfwrt /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudfwrt)%nlist + call this%mwe_fwrt_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add well pumping rate to mover contribution + if (this%idxbudrtmv /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudrtmv)%nlist + call this%mwe_rtmv_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- add flowing well rate to mover contribution + if (this%idxbudfrtm /= 0) then + do j = 1, this%flowbudptr%budterm(this%idxbudfrtm)%nlist + call this%mwe_frtm_term(j, n1, n2, rrate) + this%dbuff(n1) = this%dbuff(n1) + rrate + end do + end if + ! + ! -- Return + return + end subroutine mwe_solve + + function mwe_get_nbudterms(this) result(nbudterms) +! ****************************************************************************** +! mwe_get_nbudterms -- function to return the number of budget terms just for +! this package. This overrides function in parent. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweMweType) :: this + ! -- return + integer(I4B) :: nbudterms + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- Number of budget terms is 4 + nbudterms = 1 + if (this%idxbudfwrt /= 0) nbudterms = nbudterms + 1 + if (this%idxbudrtmv /= 0) nbudterms = nbudterms + 1 + if (this%idxbudfrtm /= 0) nbudterms = nbudterms + 1 + ! + ! -- Return + return + end function mwe_get_nbudterms + + subroutine mwe_setup_budobj(this, idx) +! ****************************************************************************** +! mwe_setup_budobj -- Set up the budget object that stores all the multi- +! aquifer well flows +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LENBUDTXT + ! -- dummy + class(GweMweType) :: this + integer(I4B), intent(inout) :: idx + ! -- local + integer(I4B) :: maxlist, naux + character(len=LENBUDTXT) :: text +! ------------------------------------------------------------------------------ + ! + ! -- + text = ' RATE' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudrate)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + + ! + ! -- + if (this%idxbudfwrt /= 0) then + text = ' FW-RATE' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudfwrt)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + + ! + ! -- + if (this%idxbudrtmv /= 0) then + text = ' RATE-TO-MVR' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudrtmv)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + + ! + ! -- + if (this%idxbudfrtm /= 0) then + text = ' FW-RATE-TO-MVR' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudfrtm)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + end if + + ! + ! -- return + return + end subroutine mwe_setup_budobj + + subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) +! ****************************************************************************** +! mwe_fill_budobj -- copy flow terms into this%budobj +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweMweType) :: this + integer(I4B), intent(inout) :: idx + real(DP), dimension(:), intent(in) :: x + real(DP), dimension(:), contiguous, intent(inout) :: flowja + real(DP), intent(inout) :: ccratin + real(DP), intent(inout) :: ccratout + ! -- local + integer(I4B) :: j, n1, n2 + integer(I4B) :: nlist + real(DP) :: q + ! -- formats +! ----------------------------------------------------------------------------- + + ! -- RATE + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudrate)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%mwe_rate_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + + ! -- FW-RATE + if (this%idxbudfwrt /= 0) then + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudfwrt)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%mwe_fwrt_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + end if + + ! -- RATE-TO-MVR + if (this%idxbudrtmv /= 0) then + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudrtmv)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%mwe_rtmv_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + end if + + ! -- FW-RATE-TO-MVR + if (this%idxbudfrtm /= 0) then + idx = idx + 1 + nlist = this%flowbudptr%budterm(this%idxbudfrtm)%nlist + call this%budobj%budterm(idx)%reset(nlist) + do j = 1, nlist + call this%mwe_frtm_term(j, n1, n2, q) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + end do + end if + + ! + ! -- return + return + end subroutine mwe_fill_budobj + + subroutine allocate_scalars(this) +! ****************************************************************************** +! allocate_scalars +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweMweType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- allocate scalars in TspAptType + call this%TspAptType%allocate_scalars() + ! + ! -- Allocate + call mem_allocate(this%idxbudrate, 'IDXBUDRATE', this%memoryPath) + call mem_allocate(this%idxbudfwrt, 'IDXBUDFWRT', this%memoryPath) + call mem_allocate(this%idxbudrtmv, 'IDXBUDRTMV', this%memoryPath) + call mem_allocate(this%idxbudfrtm, 'IDXBUDFRTM', this%memoryPath) + ! + ! -- Initialize + this%idxbudrate = 0 + this%idxbudfwrt = 0 + this%idxbudrtmv = 0 + this%idxbudfrtm = 0 + ! + ! -- Return + return + end subroutine allocate_scalars + + subroutine mwe_allocate_arrays(this) +! ****************************************************************************** +! mwe_allocate_arrays +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_allocate + ! -- dummy + class(GweMweType), intent(inout) :: this + ! -- local + integer(I4B) :: n +! ------------------------------------------------------------------------------ + ! + ! -- time series + call mem_allocate(this%temprate, this%ncv, 'TEMPRATE', this%memoryPath) + ! + ! -- call standard TspAptType allocate arrays + call this%TspAptType%apt_allocate_arrays() + ! + ! -- Initialize + do n = 1, this%ncv + this%temprate(n) = DZERO + end do + ! + ! + ! -- Return + return + end subroutine mwe_allocate_arrays + + subroutine mwe_da(this) +! ****************************************************************************** +! mwe_da +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use MemoryManagerModule, only: mem_deallocate + ! -- dummy + class(GweMweType) :: this + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- deallocate scalars + call mem_deallocate(this%idxbudrate) + call mem_deallocate(this%idxbudfwrt) + call mem_deallocate(this%idxbudrtmv) + call mem_deallocate(this%idxbudfrtm) + ! + ! -- deallocate time series + call mem_deallocate(this%temprate) + ! + ! -- deallocate scalars in TspAptType + call this%TspAptType%bnd_da() + ! + ! -- Return + return + end subroutine mwe_da + + subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! mwe_rate_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweMweType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp + real(DP) :: h, r +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudrate)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudrate)%id2(ientry) + ! -- note that qbnd is negative for extracting well + qbnd = this%flowbudptr%budterm(this%idxbudrate)%flow(ientry) + if (qbnd < DZERO) then + ctmp = this%xnewpak(n1) + h = qbnd + r = DZERO + else + ctmp = this%temprate(n1) + h = DZERO + r = -qbnd * ctmp + end if + if (present(rrate)) rrate = qbnd * ctmp + if (present(rhsval)) rhsval = r + if (present(hcofval)) hcofval = h + ! + ! -- return + return + end subroutine mwe_rate_term + + subroutine mwe_fwrt_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! mwe_fwrt_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweMweType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudfwrt)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudfwrt)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudfwrt)%flow(ientry) + ctmp = this%xnewpak(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine mwe_fwrt_term + + subroutine mwe_rtmv_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! mwe_rtmv_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweMweType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudrtmv)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudrtmv)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudrtmv)%flow(ientry) + ctmp = this%xnewpak(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine mwe_rtmv_term + + subroutine mwe_frtm_term(this, ientry, n1, n2, rrate, & + rhsval, hcofval) +! ****************************************************************************** +! mwe_frtm_term +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweMweType) :: this + integer(I4B), intent(in) :: ientry + integer(I4B), intent(inout) :: n1 + integer(I4B), intent(inout) :: n2 + real(DP), intent(inout), optional :: rrate + real(DP), intent(inout), optional :: rhsval + real(DP), intent(inout), optional :: hcofval + ! -- local + real(DP) :: qbnd + real(DP) :: ctmp +! ------------------------------------------------------------------------------ + n1 = this%flowbudptr%budterm(this%idxbudfrtm)%id1(ientry) + n2 = this%flowbudptr%budterm(this%idxbudfrtm)%id2(ientry) + qbnd = this%flowbudptr%budterm(this%idxbudfrtm)%flow(ientry) + ctmp = this%xnewpak(n1) + if (present(rrate)) rrate = ctmp * qbnd + if (present(rhsval)) rhsval = DZERO + if (present(hcofval)) hcofval = qbnd + ! + ! -- return + return + end subroutine mwe_frtm_term + + subroutine mwe_df_obs(this) +! ****************************************************************************** +! mwe_df_obs -- obs are supported? +! -- Store observation type supported by APT package. +! -- Overrides BndType%bnd_df_obs +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(GweMweType) :: this + ! -- local + integer(I4B) :: indx +! ------------------------------------------------------------------------------ + ! + ! -- Store obs type and assign procedure pointer + ! for temperature observation type. + call this%obs%StoreObsType('temperature', .false., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- flow-ja-face not supported for MWE + !call this%obs%StoreObsType('flow-ja-face', .true., indx) + !this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for from-mvr observation type. + call this%obs%StoreObsType('from-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- to-mvr not supported for mwe + !call this%obs%StoreObsType('to-mvr', .true., indx) + !this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for storage observation type. + call this%obs%StoreObsType('storage', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for constant observation type. + call this%obs%StoreObsType('constant', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type: mwe + call this%obs%StoreObsType('mwe', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID12 + ! + ! -- Store obs type and assign procedure pointer + ! for rate observation type. + call this%obs%StoreObsType('rate', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('fw-rate', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('rate-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + ! -- Store obs type and assign procedure pointer + ! for observation type. + call this%obs%StoreObsType('fw-rate-to-mvr', .true., indx) + this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID + ! + return + end subroutine mwe_df_obs + + !> @brief Process package specific obs + !! + !! Method to process specific observations for this package. + !! + !< + subroutine mwe_rp_obs(this, obsrv, found) + ! -- dummy + class(GweMweType), intent(inout) :: this !< package class + type(ObserveType), intent(inout) :: obsrv !< observation object + logical, intent(inout) :: found !< indicate whether observation was found + ! -- local + ! + found = .true. + select case (obsrv%ObsTypeId) + case ('RATE') + call this%rp_obs_byfeature(obsrv) + case ('FW-RATE') + call this%rp_obs_byfeature(obsrv) + case ('RATE-TO-MVR') + call this%rp_obs_byfeature(obsrv) + case ('FW-RATE-TO-MVR') + call this%rp_obs_byfeature(obsrv) + case default + found = .false. + end select + ! + return + end subroutine mwe_rp_obs + + subroutine mwe_bd_obs(this, obstypeid, jj, v, found) +! ****************************************************************************** +! mwe_bd_obs -- calculate observation value and pass it back to APT +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- dummy + class(GweMweType), intent(inout) :: this + character(len=*), intent(in) :: obstypeid + real(DP), intent(inout) :: v + integer(I4B), intent(in) :: jj + logical, intent(inout) :: found + ! -- local + integer(I4B) :: n1, n2 +! ------------------------------------------------------------------------------ + ! + found = .true. + select case (obstypeid) + case ('RATE') + if (this%iboundpak(jj) /= 0) then + call this%mwe_rate_term(jj, n1, n2, v) + end if + case ('FW-RATE') + if (this%iboundpak(jj) /= 0 .and. this%idxbudfwrt > 0) then + call this%mwe_fwrt_term(jj, n1, n2, v) + end if + case ('RATE-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudrtmv > 0) then + call this%mwe_rtmv_term(jj, n1, n2, v) + end if + case ('FW-RATE-TO-MVR') + if (this%iboundpak(jj) /= 0 .and. this%idxbudfrtm > 0) then + call this%mwe_frtm_term(jj, n1, n2, v) + end if + case default + found = .false. + end select + ! + return + end subroutine mwe_bd_obs + + subroutine mwe_set_stressperiod(this, itemno, keyword, found) +! ****************************************************************************** +! mwe_set_stressperiod -- Set a stress period attribute for using keywords. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + use TimeSeriesManagerModule, only: read_value_or_time_series_adv + ! -- dummy + class(GweMweType), intent(inout) :: this + integer(I4B), intent(in) :: itemno + character(len=*), intent(in) :: keyword + logical, intent(inout) :: found + ! -- local + character(len=LINELENGTH) :: text + integer(I4B) :: ierr + integer(I4B) :: jj + real(DP), pointer :: bndElem => null() + ! -- formats +! ------------------------------------------------------------------------------ + ! + ! RATE + ! + found = .true. + select case (keyword) + case ('RATE') + ierr = this%apt_check_valid(itemno) + if (ierr /= 0) then + goto 999 + end if + call this%parser%GetString(text) + jj = 1 + bndElem => this%temprate(itemno) + call read_value_or_time_series_adv(text, itemno, jj, bndElem, & + this%packName, 'BND', this%tsManager, & + this%iprpak, 'RATE') + case default + ! + ! -- keyword not recognized so return to caller with found = .false. + found = .false. + end select + ! +999 continue + ! + ! -- return + return + end subroutine mwe_set_stressperiod + +end module GweMweModule From 2087a12b9678aecd394de5f63a217da1e7536850 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 23 May 2023 15:07:39 -0700 Subject: [PATCH 136/212] Get MWT caught up --- src/Model/GroundWaterTransport/gwt1.f90 | 3 ++- src/Model/GroundWaterTransport/gwt1mwt1.f90 | 12 +++++++++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index abf0020d30f..e7f2a6dfe86 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -101,6 +101,7 @@ subroutine gwt_cr(filename, id, modelname) use SimVariablesModule, only: idm_context use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr + use TspLabelsModule, only: tsplabels_cr !use TspLabelsModule, only: tsplabels_cr !use SimModule, only: store_error, count_errors !use NameFileModule, only: NameFileType @@ -1121,7 +1122,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('MWT6') call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('UZT6') call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) diff --git a/src/Model/GroundWaterTransport/gwt1mwt1.f90 b/src/Model/GroundWaterTransport/gwt1mwt1.f90 index 6c5951208be..264a2861b79 100644 --- a/src/Model/GroundWaterTransport/gwt1mwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mwt1.f90 @@ -43,6 +43,7 @@ module GwtMwtModule use ObserveModule, only: ObserveType use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType use MatrixBaseModule implicit none @@ -86,7 +87,7 @@ module GwtMwtModule contains subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi) + fmi, tsplab, eqnsclfac) ! ****************************************************************************** ! mwt_create -- Create a New MWT Package ! ****************************************************************************** @@ -102,6 +103,8 @@ subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! -- local type(GwtMwtType), pointer :: mwtobj ! ------------------------------------------------------------------------------ @@ -132,6 +135,13 @@ subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages mwtobj%fmi => fmi ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + mwtobj%tsplab => tsplab + ! + ! -- Store pointer to governing equation scale factor + mwtobj%eqnsclfac => eqnsclfac + ! ! -- return return end subroutine mwt_create From b4191b76ef0bb87e872a0fdb4ea44cd054b675e9 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 24 May 2023 12:10:56 -0700 Subject: [PATCH 137/212] Minor variable name cleanup --- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 4 +-- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 30 +++++++++------------ src/Model/GroundWaterTransport/tsp1apt1.f90 | 18 +++++-------- 3 files changed, 21 insertions(+), 31 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index fb6fbcf3447..9b7728886d5 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -398,7 +398,7 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) ktf = this%ktf(n) - s = this%rbthcnd(n) + s = this%rfeatthk(n) ctherm = ktf * wa / s ! ! -- add to sfe row @@ -729,7 +729,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) ktf = this%ktf(n1) - s = this%rbthcnd(n1) + s = this%rfeatthk(n1) ctherm = ktf * wa / s q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct !q = -q ! flip sign so relative to advanced package feature diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index fef9c171b14..48b7a9ed20a 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -94,16 +94,12 @@ module GweSfeModule end type GweSfeType -contains + contains + !> @brief Create a new sfe package + !< subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac, gwecommon) -! ****************************************************************************** -! sfe_create -- Create a New SFE Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -241,7 +237,6 @@ subroutine find_sfe_package(this) this%idxbudssm(ip) = 0 case ('GWF') this%idxbudgwf = ip -!! this%idxbudsbcd = ip this%idxbudssm(ip) = 0 case ('STORAGE') this%idxbudsto = ip @@ -305,7 +300,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B), dimension(:), intent(in) :: idxglo class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: j, n1, n2, n + integer(I4B) :: j, n, n1, n2 integer(I4B) :: iloc integer(I4B) :: iposd, iposoffd integer(I4B) :: ipossymd, ipossymoffd @@ -385,7 +380,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) ktf = this%ktf(n) - s = this%rbthcnd(n) + s = this%rfeatthk(n) ctherm = ktf * wa / s ! ! -- add to sfe row @@ -618,7 +613,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- RAIN idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist @@ -628,7 +623,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EVAPORATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist @@ -638,7 +633,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- RUNOFF idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist @@ -648,7 +643,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-INFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist @@ -658,7 +653,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-OUTFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist @@ -668,7 +663,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- STRMBD-COND idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) @@ -680,7 +675,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) ktf = this%ktf(n1) - s = this%rbthcnd(n1) + s = this%rfeatthk(n1) ctherm = ktf * wa / s q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct !q = -q ! flip sign so relative to advanced package feature @@ -694,7 +689,6 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) flowja(idiag) = flowja(idiag) - q end if end do - ! ! -- return return diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index fc6de9f0f16..62b0252e52b 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -80,7 +80,7 @@ module TspAptModule integer(I4B), pointer :: idxlastpak => null() !< budget-object index of last package-specific budget object real(DP), dimension(:), pointer, contiguous :: strt => null() !< starting feature concentration (or temperature) real(DP), dimension(:), pointer, contiguous :: ktf => null() !< thermal conductivity between the apt and groundwater cell - real(DP), dimension(:), pointer, contiguous :: rbthcnd => null() !< thickness of streambed material through with thermal conduction occurs + real(DP), dimension(:), pointer, contiguous :: rfeatthk => null() !< thickness of streambed/lakebed/filter-pack material through which thermal conduction occurs integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< map position in global rhs and x array of pack entry integer(I4B), dimension(:), pointer, contiguous :: idxpakdiag => null() !< map diag position of feature in global amat integer(I4B), dimension(:), pointer, contiguous :: idxdglo => null() !< map position in global array of package diagonal row entries @@ -184,13 +184,9 @@ module TspAptModule contains + !> @brief Add package connection to matrix + !< subroutine apt_ac(this, moffset, sparse) -! ****************************************************************************** -! bnd_ac -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use MemoryManagerModule, only: mem_setptr use SparseModule, only: sparsematrix ! -- dummy @@ -1337,7 +1333,7 @@ subroutine apt_da(this) call mem_deallocate(this%ccterm) call mem_deallocate(this%strt) call mem_deallocate(this%ktf) - call mem_deallocate(this%rbthcnd) + call mem_deallocate(this%rfeatthk) call mem_deallocate(this%lauxvar) call mem_deallocate(this%xoldpak) if (this%imatrows == 0) then @@ -1631,7 +1627,7 @@ subroutine apt_read_cvs(this) ! -- allocate apt data call mem_allocate(this%strt, this%ncv, 'STRT', this%memoryPath) call mem_allocate(this%ktf, this%ncv, 'KTF', this%memoryPath) - call mem_allocate(this%rbthcnd, this%ncv, 'RBTHCND', this%memoryPath) + call mem_allocate(this%rfeatthk, this%ncv, 'RFEATTHK', this%memoryPath) call mem_allocate(this%lauxvar, this%naux, this%ncv, 'LAUXVAR', & this%memoryPath) ! @@ -1650,7 +1646,7 @@ subroutine apt_read_cvs(this) do n = 1, this%ncv this%strt(n) = DEP20 this%ktf(n) = DZERO - this%rbthcnd(n) = DZERO + this%rfeatthk(n) = DZERO this%lauxvar(:, n) = DZERO this%xoldpak(n) = DEP20 if (this%imatrows == 0) then @@ -1703,7 +1699,7 @@ subroutine apt_read_cvs(this) ! skip for UZE if (trim(adjustl(this%text)) /= 'UZE') then this%ktf(n) = this%parser%GetDouble() - this%rbthcnd(n) = this%parser%GetDouble() + this%rfeatthk(n) = this%parser%GetDouble() end if end if ! From e5f0750db126661444a77af48d4c7e842840ef6a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 24 May 2023 12:12:11 -0700 Subject: [PATCH 138/212] Some fixes in MWE for getting the budget terms looking better --- src/Model/GroundWaterEnergy/gwe1mwe1.f90 | 217 +++++++++++++++-------- 1 file changed, 141 insertions(+), 76 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 index 1020b985d0b..77d02218059 100644 --- a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 @@ -156,13 +156,9 @@ subroutine mwe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & return end subroutine mwe_create + !> @brief find corresponding mwe package + !< subroutine find_mwe_package(this) -! ****************************************************************************** -! find corresponding mwe package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -273,18 +269,19 @@ subroutine find_mwe_package(this) end do write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION' ! + ! -- streambed conduction term + this%idxbudmwcd = this%idxbudgwf + ! ! -- Return return end subroutine find_mwe_package + !> @brief Add matrix terms related to MWE + !! + !! This routine is called from TspAptType%apt_fc_expanded() in + !! order to add matrix terms specifically for MWE + !< subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! mwe_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for this package -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweMweType) :: this @@ -293,12 +290,18 @@ subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) integer(I4B), dimension(:), intent(in) :: idxglo class(MatrixBaseType), pointer :: matrix_sln ! -- local - integer(I4B) :: j, n1, n2 + integer(I4B) :: j, n, n1, n2 integer(I4B) :: iloc - integer(I4B) :: iposd + integer(I4B) :: iposd, iposoffd + integer(I4B) :: ipossymd, ipossymoffd + integer(I4B) :: auxpos real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval + real(DP) :: ctherm ! kluge? + real(DP) :: wa !< wetted area + real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: s !< thickness of conductive wellbore material ! ------------------------------------------------------------------------------ ! ! -- add puping rate contribution @@ -345,6 +348,34 @@ subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) end do end if ! + ! -- add wellbore conduction contribution + do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + ! + ! -- set n to feature number and process if active features + n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) + if (this%iboundpak(n) /= 0) then + ! + ! -- set acoef and rhs to negative so they are relative to mwe and not gwe + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + ktf = this%ktf(n) + s = this%rfeatthk(n) + ctherm = ktf * wa / s + ! + ! -- add to mwe row + iposd = this%idxdglo(j) + iposoffd = this%idxoffdglo(j) + call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposoffd, ctherm) + ! + ! -- add to gwe row for mwe connection + ipossymd = this%idxsymdglo(j) + ipossymoffd = this%idxsymoffdglo(j) + call matrix_sln%add_value_pos(ipossymd, -ctherm) + call matrix_sln%add_value_pos(ipossymoffd, ctherm) + end if + end do + ! ! -- Return return end subroutine mwe_fc_expanded @@ -417,11 +448,12 @@ function mwe_get_nbudterms(this) result(nbudterms) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- Number of budget terms is 4 - nbudterms = 1 + ! -- Number of potential budget terms is 5 + nbudterms = 1 ! RATE if (this%idxbudfwrt /= 0) nbudterms = nbudterms + 1 if (this%idxbudrtmv /= 0) nbudterms = nbudterms + 1 if (this%idxbudfrtm /= 0) nbudterms = nbudterms + 1 + if (this%idxbudmwcd /= 0) nbudterms = nbudterms + 1 ! ! -- Return return @@ -441,11 +473,13 @@ subroutine mwe_setup_budobj(this, idx) class(GweMweType) :: this integer(I4B), intent(inout) :: idx ! -- local + integer(I4B) :: n, n1, n2 integer(I4B) :: maxlist, naux + real(DP) :: q character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- user-specified rate text = ' RATE' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrate)%maxlist @@ -457,9 +491,8 @@ subroutine mwe_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - ! - ! -- + ! -- flowing well rate if (this%idxbudfwrt /= 0) then text = ' FW-RATE' idx = idx + 1 @@ -473,9 +506,8 @@ subroutine mwe_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- + ! -- user-specified flow rate to mover if (this%idxbudrtmv /= 0) then text = ' RATE-TO-MVR' idx = idx + 1 @@ -489,9 +521,8 @@ subroutine mwe_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- + ! -- flowing well rate to mover if (this%idxbudfrtm /= 0) then text = ' FW-RATE-TO-MVR' idx = idx + 1 @@ -505,19 +536,34 @@ subroutine mwe_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - + ! + ! -- conduction through wellbore (and/or filter pack) + text = ' WELLBORE-COND' + idx = idx + 1 + maxlist = this%flowbudptr%budterm(this%idxbudmwcd)%maxlist + naux = 0 + call this%budobj%budterm(idx)%initialize(text, & + this%name_model, & + this%packName, & + this%name_model, & + this%packName, & + maxlist, .false., .false., & + naux) + call this%budobj%budterm(idx)%reset(maxlist) + q = DZERO + do n = 1, maxlist + n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(n) + n2 = this%flowbudptr%budterm(this%idxbudgwf)%id2(n) + call this%budobj%budterm(idx)%update_term(n1, n2, q) + end do ! ! -- return return end subroutine mwe_setup_budobj + !> @brief Copy flow terms into this%budobj + !< subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! mwe_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweMweType) :: this @@ -529,10 +575,17 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- local integer(I4B) :: j, n1, n2 integer(I4B) :: nlist + integer(I4B) :: igwfnode + integer(I4B) :: idiag + integer(I4B) :: auxpos real(DP) :: q + real(DP) :: ctherm + real(DP) :: wa !< wetted area + real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- RATE idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrate)%nlist @@ -542,7 +595,7 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- FW-RATE if (this%idxbudfwrt /= 0) then idx = idx + 1 @@ -554,7 +607,7 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- RATE-TO-MVR if (this%idxbudrtmv /= 0) then idx = idx + 1 @@ -566,7 +619,7 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- FW-RATE-TO-MVR if (this%idxbudfrtm /= 0) then idx = idx + 1 @@ -578,7 +631,32 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! + ! -- WELLBORE-COND + idx = idx + 1 + call this%budobj%budterm(idx)%reset(this%maxbound) + do j = 1, this%flowbudptr%budterm(this%idxbudmwcd)%nlist + q = DZERO + n1 = this%flowbudptr%budterm(this%idxbudmwcd)%id1(j) + if (this%iboundpak(n1) /= 0) then + igwfnode = this%flowbudptr%budterm(this%idxbudmwcd)%id2(j) + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + ktf = this%ktf(n1) + s = this%rfeatthk(n1) + ctherm = ktf * wa / s + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct + !q = -q ! flip sign so relative to advanced package feature + end if + call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) + call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) + if (this%iboundpak(n1) /= 0) then + ! -- contribution to gwe cell budget + this%simvals(n1) = this%simvals(n1) - q + idiag = this%dis%con%ia(igwfnode) + flowja(idiag) = flowja(idiag) - q + end if + end do ! ! -- return return @@ -606,12 +684,14 @@ subroutine allocate_scalars(this) call mem_allocate(this%idxbudfwrt, 'IDXBUDFWRT', this%memoryPath) call mem_allocate(this%idxbudrtmv, 'IDXBUDRTMV', this%memoryPath) call mem_allocate(this%idxbudfrtm, 'IDXBUDFRTM', this%memoryPath) + call mem_allocate(this%idxbudmwcd, 'IDXBUDMWCD', this%memoryPath) ! ! -- Initialize this%idxbudrate = 0 this%idxbudfwrt = 0 this%idxbudrtmv = 0 this%idxbudfrtm = 0 + this%idxbudmwcd = 0 ! ! -- Return return @@ -648,13 +728,9 @@ subroutine mwe_allocate_arrays(this) return end subroutine mwe_allocate_arrays + !> @brief Deallocate memory associated with MWE package + !< subroutine mwe_da(this) -! ****************************************************************************** -! mwe_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -667,6 +743,7 @@ subroutine mwe_da(this) call mem_deallocate(this%idxbudfwrt) call mem_deallocate(this%idxbudrtmv) call mem_deallocate(this%idxbudfrtm) + call mem_deallocate(this%idxbudmwcd) ! ! -- deallocate time series call mem_deallocate(this%temprate) @@ -678,14 +755,11 @@ subroutine mwe_da(this) return end subroutine mwe_da + !> @brief Thermal transport matrix term(s) associcated with a user-specified + !! flow rate (mwe_rate_term) + !< subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwe_rate_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweMweType) :: this integer(I4B), intent(in) :: ientry @@ -701,7 +775,7 @@ subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudrate)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudrate)%id2(ientry) - ! -- note that qbnd is negative for extracting well + ! -- note that qbnd is negative for an extracting well qbnd = this%flowbudptr%budterm(this%idxbudrate)%flow(ientry) if (qbnd < DZERO) then ctmp = this%xnewpak(n1) @@ -712,22 +786,19 @@ subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & h = DZERO r = -qbnd * ctmp end if - if (present(rrate)) rrate = qbnd * ctmp - if (present(rhsval)) rhsval = r - if (present(hcofval)) hcofval = h + if (present(rrate)) rrate = qbnd * ctmp * this%eqnsclfac + if (present(rhsval)) rhsval = r * this%eqnsclfac + if (present(hcofval)) hcofval = h * this%eqnsclfac ! ! -- return return end subroutine mwe_rate_term + !> @brief Thermal transport matrix term(s) associcated with a flowing- + !! well rater term (mwe_fwrt_term) + !< subroutine mwe_fwrt_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwe_fwrt_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweMweType) :: this integer(I4B), intent(in) :: ientry @@ -744,22 +815,19 @@ subroutine mwe_fwrt_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudfwrt)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudfwrt)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return end subroutine mwe_fwrt_term + !> @brief Thermal transport matrix term(s) associcated with pumped-water- + !! to-mover term (mwe_rtmv_term) + !< subroutine mwe_rtmv_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwe_rtmv_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweMweType) :: this integer(I4B), intent(in) :: ientry @@ -776,22 +844,19 @@ subroutine mwe_rtmv_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrtmv)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrtmv)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return end subroutine mwe_rtmv_term + !> @brief Thermal transport matrix term(s) associcated with the flowing- + !! well-rate-to-mover term (mwe_frtm_term) + !< subroutine mwe_frtm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwe_frtm_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweMweType) :: this integer(I4B), intent(in) :: ientry @@ -808,9 +873,9 @@ subroutine mwe_frtm_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudfrtm)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudfrtm)%flow(ientry) ctmp = this%xnewpak(n1) - if (present(rrate)) rrate = ctmp * qbnd + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO - if (present(hcofval)) hcofval = qbnd + if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return From e899f82c38b9c46f7c193bd854d2f9b2b0d37f87 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 24 May 2023 14:11:04 -0700 Subject: [PATCH 139/212] Small fix in MWE for getting the output associated with PRINT_BUDGET to index correctly --- src/Model/GroundWaterEnergy/gwe1mwe1.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 index 77d02218059..12c8fc900f7 100644 --- a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 @@ -652,7 +652,7 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) if (this%iboundpak(n1) /= 0) then ! -- contribution to gwe cell budget - this%simvals(n1) = this%simvals(n1) - q + this%simvals(j) = this%simvals(j) - q idiag = this%dis%con%ia(igwfnode) flowja(idiag) = flowja(idiag) - q end if From fb24605a6cb66225aac80c45093bcf9639364bdb Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 30 May 2023 15:43:47 -0700 Subject: [PATCH 140/212] Add error msg to avoid 'divide by zero' error --- src/Model/GroundWaterTransport/tsp1apt1.f90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 62b0252e52b..7fdb057b8d7 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -1700,6 +1700,13 @@ subroutine apt_read_cvs(this) if (trim(adjustl(this%text)) /= 'UZE') then this%ktf(n) = this%parser%GetDouble() this%rfeatthk(n) = this%parser%GetDouble() + if (this%rfeatthk(n) >= DZERO) then + write (errmsg, '(4x,a)') & + '****ERROR. Specified thickness used for thermal & + &conduction MUST BE > 0 else divide by zero error occurs' + call store_error(errmsg) + cycle + end if end if end if ! From 7cfba8a996a855821ab8fd9bb0f6cc237987bfbe Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 30 May 2023 15:51:46 -0700 Subject: [PATCH 141/212] wrong evaluation on previous commit --- src/Model/GroundWaterTransport/tsp1apt1.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/GroundWaterTransport/tsp1apt1.f90 index 7fdb057b8d7..2c0b30aa02c 100644 --- a/src/Model/GroundWaterTransport/tsp1apt1.f90 +++ b/src/Model/GroundWaterTransport/tsp1apt1.f90 @@ -1700,7 +1700,7 @@ subroutine apt_read_cvs(this) if (trim(adjustl(this%text)) /= 'UZE') then this%ktf(n) = this%parser%GetDouble() this%rfeatthk(n) = this%parser%GetDouble() - if (this%rfeatthk(n) >= DZERO) then + if (this%rfeatthk(n) <= DZERO) then write (errmsg, '(4x,a)') & '****ERROR. Specified thickness used for thermal & &conduction MUST BE > 0 else divide by zero error occurs' From c606a9932df667c63e875797dc8cd743c9cb368c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 31 May 2023 13:54:24 -0700 Subject: [PATCH 142/212] Redoing some SSM changes that were stomped on during the last update from the develop branch (GWE branch was six commits behind develop) --- src/Model/GroundWaterTransport/tsp1ssm1.f90 | 115 ++++++++++++-------- 1 file changed, 72 insertions(+), 43 deletions(-) diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/GroundWaterTransport/tsp1ssm1.f90 index d671a7cbc6a..4e1021c1a64 100644 --- a/src/Model/GroundWaterTransport/tsp1ssm1.f90 +++ b/src/Model/GroundWaterTransport/tsp1ssm1.f90 @@ -1,11 +1,11 @@ -!> @brief This module contains the GwtSsm Module +!> @brief This module contains the TspSsm Module !! !! This module contains the code for handling sources and sinks !! associated with groundwater flow model stress packages. !! !! todo: need observations for SSM terms !< -module GwtSsmModule +module TspSsmModule use KindModule, only: DP, I4B, LGP use ConstantsModule, only: DONE, DZERO, LENAUXNAME, LENFTYPE, & @@ -15,13 +15,15 @@ module GwtSsmModule use SimVariablesModule, only: errmsg use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType + use TspLabelsModule, only: TspLabelsType + use GweInputDataModule, only: GweInputDataType use TableModule, only: TableType, table_cr use GwtSpcModule, only: GwtSpcType use MatrixBaseModule implicit none - public :: GwtSsmType + public :: TspSsmType public :: ssm_cr character(len=LENFTYPE) :: ftype = 'SSM' @@ -34,16 +36,21 @@ module GwtSsmModule !! equation. !! !< - type, extends(NumericalPackageType) :: GwtSsmType - + type, extends(NumericalPackageType) :: TspSsmType + + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst + integer(I4B), pointer :: nbound !< total number of flow boundaries in this time step integer(I4B), dimension(:), pointer, contiguous :: isrctype => null() !< source type 0 is unspecified, 1 is aux, 2 is auxmixed, 3 is ssmi, 4 is ssmimixed integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound real(DP), dimension(:), pointer, contiguous :: cnew => null() !< pointer to gwt%x - type(GwtFmiType), pointer :: fmi => null() !< pointer to fmi object + real(DP), dimension(:), pointer, contiguous :: cpw => null() !< pointer to gwe%cpw + real(DP), dimension(:), pointer, contiguous :: rhow => null() !< pointer to gwe%rhow + type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object type(TableType), pointer :: outputtab => null() !< output table object type(GwtSpcType), dimension(:), pointer :: ssmivec => null() !< array of stress package concentration objects + real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy contains @@ -68,7 +75,7 @@ module GwtSsmModule procedure, private :: set_ssmivec procedure, private :: get_ssm_conc - end type GwtSsmType + end type TspSsmType contains @@ -78,13 +85,17 @@ module GwtSsmModule !! and initializing the parser. !! !< - subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) + subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, eqnsclfac, & + gwecommon) ! -- dummy - type(GwtSsmType), pointer :: ssmobj !< GwtSsmType object + type(TspSsmType), pointer :: ssmobj !< TspSsmType object character(len=*), intent(in) :: name_model !< name of the model integer(I4B), intent(in) :: inunit !< fortran unit for input integer(I4B), intent(in) :: iout !< fortran unit for output - type(GwtFmiType), intent(in), target :: fmi !< GWT FMI package + type(TspFmiType), intent(in), target :: fmi !< Transport FMI package + type(TspLabelsType), intent(in), pointer :: tsplab !< TspLabelsType object + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor + type(GweInputDataType), intent(in), target, optional :: gwecommon !< shared data container for use by multiple GWE packages ! ! -- Create the object allocate (ssmobj) @@ -99,10 +110,20 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi) ssmobj%inunit = inunit ssmobj%iout = iout ssmobj%fmi => fmi + ssmobj%eqnsclfac => eqnsclfac ! ! -- Initialize block parser call ssmobj%parser%Initialize(ssmobj%inunit, ssmobj%iout) ! + ! -- Store pointer to labels associated with the current model so that the + ! package has access to the corresponding dependent variable type + ssmobj%tsplab => tsplab + ! + ! -- Give package access to the shared heat transport variables assigned in MST + if (present(gwecommon)) then + ssmobj%gwecommon => gwecommon + end if + ! ! -- Return return end subroutine ssm_cr @@ -118,7 +139,7 @@ subroutine ssm_df(this) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local ! -- formats ! @@ -136,7 +157,7 @@ subroutine ssm_ar(this, dis, ibound, cnew) ! -- modules use MemoryManagerModule, only: mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object class(DisBaseType), pointer, intent(in) :: dis !< discretization package integer(I4B), dimension(:), pointer, contiguous :: ibound !< GWT model ibound real(DP), dimension(:), pointer, contiguous :: cnew !< GWT model dependent variable @@ -193,7 +214,7 @@ end subroutine ssm_ar subroutine ssm_rp(this) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -224,7 +245,7 @@ end subroutine ssm_rp subroutine ssm_ad(this) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -272,7 +293,7 @@ end subroutine ssm_ad subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & cssm, qssm) ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType + class(TspSsmType) :: this !< TspSsmType integer(I4B), intent(in) :: ipackage !< package number integer(I4B), intent(in) :: ientry !< bound number real(DP), intent(out), optional :: rrate !< calculated mass flow rate @@ -342,9 +363,11 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! ! -- Add terms based on qbnd sign if (qbnd <= DZERO) then - hcoftmp = qbnd * omega +!! hcoftmp = qbnd * omega + hcoftmp = qbnd * omega * this%eqnsclfac else - rhstmp = -qbnd * ctmp * (DONE - omega) +!! rhstmp = -qbnd * ctmp * (DONE - omega) + rhstmp = -qbnd * ctmp * (DONE - omega) * this%eqnsclfac end if ! ! -- end of active ibound @@ -353,7 +376,8 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! -- set requested values if (present(hcofval)) hcofval = hcoftmp if (present(rhsval)) rhsval = rhstmp - if (present(rrate)) rrate = hcoftmp * ctmp - rhstmp +!! if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) * this%eqnsclfac + if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) if (present(cssm)) cssm = ctmp if (present(qssm)) qssm = qbnd ! @@ -361,19 +385,20 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & return end subroutine ssm_term - !> @ brief Provide bound concentration and mixed flag + !> @ brief Provide bound concentration (or temperature) and mixed flag !! - !! SSM concentrations can be provided in auxiliary variables or - !! through separate SPC files. If not provided, the default - !! concentration is zero. This single routine provides the SSM - !! bound concentration based on these different approaches. - !! The mixed flag indicates whether or not + !! SSM concentrations and temperatures can be provided in auxiliary variables + !! or through separate SPC files. If not provided, the default + !! concentration (or temperature) is zero. This single routine provides + !! the SSM bound concentration (or temperature) based on these different + !! approaches. The mixed flag indicates whether or not the boundary as a + !! mixed type. !! !< subroutine get_ssm_conc(this, ipackage, ientry, nbound_flow, conc, & lauxmixed) ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType + class(TspSsmType) :: this !< TspSsmType integer(I4B), intent(in) :: ipackage !< package number integer(I4B), intent(in) :: ientry !< bound number integer(I4B), intent(in) :: nbound_flow !< size of flow package bound list @@ -409,7 +434,7 @@ end subroutine get_ssm_conc subroutine ssm_fc(this, matrix_sln, idxglo, rhs) ! -- modules ! -- dummy - class(GwtSsmType) :: this + class(TspSsmType) :: this class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in), dimension(:) :: idxglo real(DP), intent(inout), dimension(:) :: rhs @@ -456,7 +481,7 @@ end subroutine ssm_fc subroutine ssm_cq(this, flowja) ! -- modules ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object real(DP), dimension(:), contiguous, intent(inout) :: flowja !< flow across each face in the model grid ! -- local integer(I4B) :: ip @@ -498,7 +523,7 @@ subroutine ssm_bd(this, isuppress_output, model_budget) use TdisModule, only: delt use BudgetModule, only: BudgetType ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object integer(I4B), intent(in) :: isuppress_output !< flag to suppress output type(BudgetType), intent(inout) :: model_budget !< budget object for the GWT model ! -- local @@ -556,7 +581,7 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) use TdisModule, only: kstp, kper use ConstantsModule, only: LENPACKAGENAME, LENBOUNDNAME, LENAUXNAME, DZERO ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object integer(I4B), intent(in) :: icbcfl !< flag for writing binary budget terms integer(I4B), intent(in) :: ibudfl !< flag for printing budget terms to list file integer(I4B), intent(in) :: icbcun !< fortran unit number for binary budget file @@ -685,7 +710,7 @@ subroutine ssm_da(this) ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: ip type(GwtSpcType), pointer :: ssmiptr @@ -719,6 +744,9 @@ subroutine ssm_da(this) ! -- Scalars call mem_deallocate(this%nbound) ! + ! -- Pointers + nullify (this%gwecommon) + ! ! -- deallocate parent call this%NumericalPackageType%da() ! @@ -735,7 +763,7 @@ subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local ! ! -- allocate scalars in NumericalPackageType @@ -760,7 +788,7 @@ subroutine allocate_arrays(this) ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy - class(GwtSsmType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local integer(I4B) :: nflowpack integer(I4B) :: i @@ -791,7 +819,7 @@ end subroutine allocate_arrays subroutine read_options(this) ! -- modules ! -- dummy - class(GwtSSMType) :: this !< GwtSsmType object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword integer(I4B) :: ierr @@ -842,7 +870,7 @@ end subroutine read_options !< subroutine read_data(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! ! -- read and process required SOURCES block call this%read_sources_aux() @@ -860,7 +888,7 @@ end subroutine read_data !< subroutine read_sources_aux(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword character(len=20) :: srctype @@ -963,7 +991,7 @@ end subroutine read_sources_aux !< subroutine read_sources_fileinput(this) ! -- dummy - class(GwtSsmtype) :: this !< GwtSsmtype object + class(TspSsmType) :: this !< TspSsmType object ! -- local character(len=LINELENGTH) :: keyword character(len=LINELENGTH) :: keyword2 @@ -1084,7 +1112,7 @@ end subroutine read_sources_fileinput !< subroutine set_iauxpak(this, ip, packname) ! -- dummy - class(GwtSsmtype), intent(inout) :: this !< GwtSsmtype + class(TspSsmType), intent(inout) :: this !< TspSsmType integer(I4B), intent(in) :: ip !< package number character(len=*), intent(in) :: packname !< name of package ! -- local @@ -1129,7 +1157,7 @@ subroutine set_ssmivec(this, ip, packname) ! -- module use InputOutputModule, only: openfile, getunit ! -- dummy - class(GwtSsmtype), intent(inout) :: this !< GwtSsmtype + class(TspSsmType), intent(inout) :: this !< TspSsmType integer(I4B), intent(in) :: ip !< package number character(len=*), intent(in) :: packname !< name of package ! -- local @@ -1147,8 +1175,9 @@ subroutine set_ssmivec(this, ip, packname) call ssmiptr%initialize(this%dis, ip, inunit, this%iout, this%name_model, & trim(packname)) - write (this%iout, '(4x, a, a, a, a)') 'USING SPC INPUT FILE ', & - trim(filename), ' TO SET CONCENTRATIONS FOR PACKAGE ', trim(packname) + write (this%iout, '(4x, a, a, a, a, a)') 'USING SPC INPUT FILE ', & + trim(filename), ' TO SET ',trim(this%tsplab%depvartype),'S FOR PACKAGE ', & + trim(packname) ! ! -- return return @@ -1161,7 +1190,7 @@ end subroutine set_ssmivec !< subroutine pak_setup_outputtab(this) ! -- dummy - class(GwtSsmtype), intent(inout) :: this + class(TspSsmType), intent(inout) :: this ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text @@ -1203,4 +1232,4 @@ subroutine pak_setup_outputtab(this) return end subroutine pak_setup_outputtab -end module GwtSsmModule +end module TspSsmModule From 173e697dcf25df853448e8b5b8456502d90912f1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 1 Jun 2023 07:04:56 -0700 Subject: [PATCH 143/212] Adding lake conduction autotest --- autotest/test_gwe_lke_conduction.py | 761 ++++++++++++++++++++++++++++ 1 file changed, 761 insertions(+) create mode 100644 autotest/test_gwe_lke_conduction.py diff --git a/autotest/test_gwe_lke_conduction.py b/autotest/test_gwe_lke_conduction.py new file mode 100644 index 00000000000..54746e8a49e --- /dev/null +++ b/autotest/test_gwe_lke_conduction.py @@ -0,0 +1,761 @@ +# Simple single lake model. Lake cut into top two layers of a 5 layer +# model. Model is loosely based on the first example problem in +# Merritt and Konikow (2000) which also is one of the MT3D-USGS test +# problems. This test developed to isolate lake-aquifer interaction; +# no SFR or other advanced packages. Problem set up to have only +# conductive exchange with groundwater, then groundwater pass-through: +# that is, gw inflow on the left side, gw outflow on the +# right side of the lake. +# +# starting groundwater temperature: 4.0 +# left chd boundary inflow temperature: 4.0 +# starting lake temperature: 20.0 +# + +import os + +import numpy as np +import pytest +import flopy +from framework import TestFramework +from simulation import TestSimulation + + +def process_line(line): + m_arr = line.strip().split() + if any("=" in itm and len(itm) > 1 for itm in m_arr): + m_arr = [float(itm.split("=")[-1]) if len(itm.split("=")) > 1 else itm for itm in m_arr] + nm = m_arr[-2] + else: + nm = m_arr[-3] + val = m_arr[-1] + return {nm: float(val)} + +def get_bud(fname, srchStr): + in_bud_lst = {} + out_bud_lst = {} + with open(fname, "r") as f: + for line in f: + if srchStr in line: + # Read the package budget + line = next(f) + while not "TOTAL IN =" in line: + if "=" in line: + in_bud_lst.update(process_line(line)) + + line = next(f) + + # Get "total in" + dct = process_line(line) + T_in = dct["IN"] + + line = next(f) + while not "TOTAL OUT =" in line: + if "=" in line: + out_bud_lst.update(process_line(line)) + + line = next(f) + + # Get "total out" + dct = process_line(line) + T_out = dct["OUT"] + + break + + return T_in, T_out, in_bud_lst, out_bud_lst + +def trenddetector(list_of_index, array_of_data, order=1): + result = np.polyfit(list_of_index, list(array_of_data), order) + slope = result[-2] + return float(slope) + + +ex = [ + "lke-conductn", + "lke-conductm", + "lke-conductr" +] +# +# The last letter in the names above indicates the following +# n = "no lk/gw exchange" +# m = "mixed" (i.e., convection one direction, conductive gradient the other direction?) +# r = "reversed thermal gradients (warm gw, cold lake) + +strt_gw_temp = [4.0, 4.0, 20.0] +strt_lk_temp = [20.0, 20.0, 4.0] +lak_leakance = [0.0, 1., 1.] +strt_lk_stg = [33.75, 33.75, 33.75] +lkbdthkcnd = [0.0001, 0.0001, 0.0001] # Thickness to consider for feature/gw conduction + +# Model units +length_units = "m" +time_units = "days" + +# model domain and grid definition +delr = [ + 76.2, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 152.4, + 152.4, + 152.4, + 152.4, + 152.4, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 76.2, +] + +delc = [ + 76.2, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 152.4, + 152.4, + 152.4, + 152.4, + 152.4, + 304.8, + 304.8, + 304.8, + 304.8, + 304.8, + 76.2, +] + +fixedstrthds = [ + 35.052, + 34.9267, + 34.7216, + 34.5062, + 34.2755, + 34.0237, + 33.8143, + 33.6657, + 33.5077, + 33.3394, + 33.1599, + 32.8728, + 32.4431, + 31.9632, + 31.4353, + 30.8627, + 30.48, +] + +nrow = len(delc) +ncol = len(delr) +top = np.ones((nrow, ncol)) * 35.6616 +bot1 = np.ones_like(top) * 32.6136 +bot2 = np.ones_like(top) * 29.5656 +bot3 = np.ones_like(top) * 26.5176 +bot4 = np.ones_like(top) * 23.4696 +bot5 = np.ones_like(top) * 20.4216 +botm = np.array([bot1, bot2, bot3, bot4, bot5]) +nlay = botm.shape[0] +ibound = np.ones_like(botm) + +# deactive gw cells where lake cells are active +ibound[0, 6:11, 6:11] = 0 # layer 1 +ibound[1, 7:10, 7:10] = 0 # layer 2 + +strthd = np.zeros_like(ibound) +for j in np.arange(ncol): + strthd[:, :, j] = fixedstrthds[j] + +# setup lake array +lakibnd = np.zeros_like(ibound) +lakibnd[0] = 1 - ibound[0] # layer 1 +lakibnd[1] = 1 - ibound[1] # layer 2 + +# NPF parameters +k11 = 9.144 # = 30 ft/day +k33 = 0.9144 # = 30 ft/day +ss = 3e-4 +sy = 0.20 +hani = 1 +laytyp = 1 + +# Package boundary conditions +chdl = 35.052 +chdr = 30.48 +viscref = 8.904e-4 + +# time params +transient = {0: True} +nstp = [10] +tsmult = [1.0] +perlen = [5000] + +# solver params +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-3, 1e-4, 0.97 + +# Transport related parameters +al = 1 # longitudinal dispersivity ($m$) +ath1 = al # horizontal transverse dispersivity +atv = al # vertical transverse dispersivity +mixelm = 0 # Upstream vs TVD (Upstream selected) +porosity = 0.20 # porosity (unitless) +K_therm = 2.0 # Thermal conductivity # ($W/m/C$) +rhow = 1000 # Density of water ($kg/m^3$) +rhos = 2650 # Density of the aquifer material ($kg/m^3$) +Cpw = 4180 # Heat Capacity of water ($J/kg/C$) +Cps = 880 # Heat capacity of the solids ($J/kg/C$) +lhv = 2454000.0 # Latent heat of vaporization ($J/kg$) +K_therm_lakebed = 1.5 # Thermal conductivity of the lakebed material ($W/m/C$) + + +# +# MODFLOW 6 flopy GWF & GWE simulation object (sim) is returned +# + +def build_model(idx, dir): + global lak_lkup_dict + + # Base simulation and model name and workspace + ws = dir + name = ex[idx] + + print("Building model...{}".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwename = "gwe-" + name + + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" + ) + + tdis_rc = [] + for i in range(len(nstp)): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + flopy.mf6.ModflowTdis( + sim, nper=len(nstp), perioddata=tdis_rc, time_units=time_units + ) + + gwf = flopy.mf6.ModflowGwf( + sim, modelname=gwfname, save_flows=True, newtonoptions="newton" + ) + + # Instantiating solver + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="cooley", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(ims, [gwfname]) + + # Instantiate discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=ibound, + filename="{}.dis".format(gwfname), + ) + + # Instantiate node property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=1, # >0 means saturated thickness varies with computed head + k=k11, + k33=k33, + ) + + # Instantiate storage package + flopy.mf6.ModflowGwfsto( + gwf, + save_flows=False, + iconvert=laytyp, + ss=ss, + sy=sy, + transient=transient, + ) + + # Instantiate initial conditions package + flopy.mf6.ModflowGwfic(gwf, strt=strthd) + + # Instantiate output control package + flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{gwfname}.cbc", + head_filerecord=f"{gwfname}.hds", + headprintrecord=[("COLUMNS", 17, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "LAST")], + ) + + # Instantiate constant head package + # (for driving gw flow from left to right) + chdlistl = [] + chdlistr = [] + for k in np.arange(nlay): + for i in np.arange(nrow): + # left side + if botm[k, i, 0] <= chdl: + chdlistl.append([(k, i, 0), chdl, strt_gw_temp[idx]]) + # right side + if botm[k, i, -1] <= chdr: + chdlistr.append([(k, i, ncol - 1), chdr, 10.0]) + + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chdlistl, + print_input=True, + print_flows=True, + save_flows=False, + pname="CHD-L", + auxiliary="TEMPERATURE", + filename=f"{gwfname}.left.chd", + ) + + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chdlistr, + print_input=True, + print_flows=True, + save_flows=False, + pname="CHD-R", + auxiliary="TEMPERATURE", + filename=f"{gwfname}.right.chd", + ) + + # Instantiate lake package + lakeconnectiondata = [] + nlakecon = [0] # Expand this to [0, 0, ...] for each additional lake + ilakconn = -1 + lak_lkup_dict = {} + for k in [0, 1]: + for i in range(nrow): + for j in range(ncol): + if lakibnd[k, i, j] == 0: + continue + else: + ilak = int(lakibnd[k, i, j] - 1) + # back + if i > 0: + if ( + lakibnd[k, i - 1, j] == 0 + and ibound[k, i - 1, j] == 1 + ): + ilakconn += 1 + # by setting belev==telev, MF6 will automatically + # re-assign elevations based on cell dimensions + h = [ + ilak, # + ilakconn, # + (k, i - 1, j), # + "horizontal", # + lak_leakance[idx], # + 0.0, # + 0.0, # + delc[i] / 2.0, # + delr[j], # + ] + lakeconnectiondata.append(h) + lak_lkup_dict.update({ilakconn: (k, i, j)}) + + # left + if j > 0: + if ( + lakibnd[k, i, j - 1] == 0 + and ibound[k, i, j - 1] == 1 + ): + ilakconn += 1 + h = [ + ilak, + ilakconn, + (k, i, j - 1), + "horizontal", + lak_leakance[idx], + 0.0, + 0.0, + delr[j] / 2.0, + delc[i], + ] + lakeconnectiondata.append(h) + lak_lkup_dict.update({ilakconn: (k, i, j)}) + + # right + if j < ncol - 1: + if ( + lakibnd[k, i, j + 1] == 0 + and ibound[k, i, j + 1] == 1 + ): + ilakconn += 1 + h = [ + ilak, + ilakconn, + (k, i, j + 1), + "horizontal", + lak_leakance[idx], + 0.0, + 0.0, + delr[j] / 2.0, + delc[i], + ] + lakeconnectiondata.append(h) + lak_lkup_dict.update({ilakconn: (k, i, j)}) + + # front + if i < nrow - 1: + if ( + lakibnd[k, i + 1, j] == 0 + and ibound[k, i + 1, j] == 1 + ): + ilakconn += 1 + h = [ + ilak, + ilakconn, + (k, i + 1, j), + "horizontal", + lak_leakance[idx], + 0.0, + 0.0, + delc[i] / 2.0, + delr[j], + ] + lakeconnectiondata.append(h) + lak_lkup_dict.update({ilakconn: (k, i, j)}) + + # vertical + if lakibnd[k, i, j] == 1 and ibound[k + 1, i, j] == 1: + ilakconn += 1 + v = [ + ilak, + ilakconn, + (k + 1, i, j), + "vertical", + lak_leakance[idx], + 0.0, + 0.0, + 0.0, + 0.0, + ] + lakeconnectiondata.append(v) + lak_lkup_dict.update({ilakconn: (k, i, j)}) + + strtStg = strt_lk_stg[idx] + lakpackagedata = [[0, strtStg, len(lakeconnectiondata), strt_lk_temp[idx], "lake1"]] + lak_pkdat_dict = {"filename": "lak_pakdata.in", "data": lakpackagedata} + + lakeperioddata = { + 0: [ + ] + } + + lak_obs = { + "{}.lakeobs".format(gwfname): [ + ("lakestage", "stage", "lake1"), + ("gwexchng", "lak", "lake1"), + ] + } + lak = flopy.mf6.ModflowGwflak( + gwf, + auxiliary="TEMPERATURE", + time_conversion=86400.0, + print_stage=True, + print_flows=True, + budget_filerecord=gwfname + ".lak.bud", + length_conversion=1.0, + mover=False, + pname="LAK-1", + boundnames=True, + nlakes=len(lakpackagedata), + noutlets=0, + packagedata=lak_pkdat_dict, + connectiondata=lakeconnectiondata, + perioddata=lakeperioddata, + observations=lak_obs, + filename="{}.lak".format(gwfname), + ) + + # pull in the tabfile defining the lake stage, vol, & surface area + fname = os.path.join("data", "vsc04-laktab", "stg-vol-surfarea.dat") + tabinput = [] + with open(fname, "r") as f: + # peel off the hdr line + hdr = next(f) + for line in f: + m_arr = line.strip().split(",") + # , , , + tabinput.append([float(m_arr[0]), m_arr[1], m_arr[2]]) + + tab6_filename = "{}.laktab".format(gwfname) + flopy.mf6.ModflowUtllaktab( + gwf, + nrow=len(tabinput), + ncol=3, + table=tabinput, + filename=tab6_filename, + pname="LAK_tab", + parent_file=lak, + ) + + # Create GWE model + # ---------------- + gwe = flopy.mf6.ModflowGwe( + sim, modelname=gwename, model_nam_file="{}.nam".format(gwename) + ) + gwe.name_file.save_flows = True + + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename=f"{gwename}.ims", + ) + sim.register_ims_package(imsgwe, [gwename]) + + # Instantiating MODFLOW 6 enregy transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=ibound, + filename="{}.dis".format(gwename), + ) + + # Instantiating MODFLOW 6 energy transport initial temperatures + strttemp = strt_gw_temp[idx] + flopy.mf6.ModflowGweic( + gwe, strt=strttemp, filename="{}.ic".format(gwename) + ) + + # Instantiate mobile storage and transfer package + flopy.mf6.ModflowGwemst( + gwe, + porosity=porosity, + cps=Cps, + rhos=rhos, + packagedata=[Cpw, rhow, lhv], + pname='MST-1', + filename=f"{gwename}.mst" + ) + + # Instantiating MODFLOW 6 energy transport advection package + if mixelm == 0: + scheme = "UPSTREAM" + elif mixelm == -1: + scheme = "TVD" + else: + raise Exception() + + # Instantiate advection package + flopy.mf6.ModflowGweadv( + gwe, scheme=scheme, filename="{}.adv".format(gwename) + ) + + # Instantiate dispersion package + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=True, + ktw=0.5918, + kts=0.2700, + filename="{}.dsp".format(gwename) + ) + + # Instantiate source/sink mixing package + sourcerecarray = [ + ("CHD-L", "AUX", "TEMPERATURE"), + ("CHD-R", "AUX", "TEMPERATURE"), + ] + flopy.mf6.ModflowGwessm( + gwe, sources=sourcerecarray, filename=f"{gwename}.ssm" + ) + + # Instantiating MODFLOW 6 transport output control package + flopy.mf6.ModflowGweoc( + gwe, + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 17, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + filename="{}.oc".format(gwename), + ) + + # Instantiating MODFLOW 6 lake energy transport (lke) package + lkepackagedata = [(0, strt_lk_temp[idx], K_therm_lakebed, lkbdthkcnd[idx], "lake1")] + + #lkeperioddata = {0: [(0, "STATUS", "CONSTANT"), (0, "TEMPERATURE", 4.0)]} + + # note: for specifying lake number, use fortran indexing! + lke_obs = { + "{}.lakobs".format(gwename): [ + ("resTemp", "temperature", 1), + ("resGwEnerExchng", "lke", "lake1"), + ] + } + + flopy.mf6.ModflowGwelke( + gwe, # Set time_conversion for use with Manning's eqn. + flow_package_name="LAK-1", + flow_package_auxiliary_name="TEMPERATURE", + budget_filerecord=gwename + ".lke.bud", + boundnames=True, + save_flows=True, + print_input=True, + print_flows=False, + print_temperature=True, + packagedata=lkepackagedata, + #lakeperioddata=lkeperioddata, + observations=lke_obs, + pname="LKE-1", + filename="{}.lke".format(gwename), + ) + + # GWF-GWE exchange + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename=f"{name}.gwfgwe", + ) + + return sim, None + + +def eval_results(sim): + print("evaluating results...") + + # read flow results from model + name = ex[sim.idxsim] + gwename = "gwe-" + name + + # Retrieve simulated temperature for the lake + fname = gwename + ".lakobs" + lktemp_file = os.path.join(sim.simpath, fname) + lktemp = np.genfromtxt(lktemp_file, names=True, delimiter=",") + lktemp = lktemp['RESTEMP'].astype(float).reshape((lktemp.size, 1)) + + # Retrieve groundwater temperatures + fname = gwename + ".ucn" + fname = os.path.join(sim.simpath, fname) + assert os.path.isfile(fname) + gwtempobj = flopy.utils.HeadFile(fname, precision="double", text="TEMPERATURE") + gwe_temps = gwtempobj.get_alldata() + + # gw exchng (item 'GWF') should be zero in heat transport budget + srchStr = "LKE-1 BUDGET FOR ENTIRE MODEL AT END OF TIME STEP 1, STRESS PERIOD 1" + fname = gwename + ".lst" + fname = os.path.join(sim.simpath, fname) + + # Retrieve budget + T_in, T_out, in_bud_lst, out_bud_lst = get_bud(fname, srchStr) + assert np.isclose(T_in, T_out, atol=0.1), \ + "There is a heat budget discrepancy where there shouldn't be" + + msg1 = "Budget item 'GWF' should be 0.0 for this scenario" + msg2 = "Thermal conduction is occurring in the wrong direction based " \ + "on the thermal gradient between the lake and groundwater system" + msg3 = "There should be a cooling trend in the lake based on heat loss " \ + "to the groundwater system" + msg4 = "There should be a warming trend in the groundwater adjacent " \ + "to the lake" + msg5 = "Budget item 'GWF' should reflect heat entering the lake " \ + "(via gw/sw exchange)" + msg6 = "Budget item 'GWF' should reflect heat exiting the lake " \ + "(via gw/sw exchange)" + + if name[-1] == 'n': + + assert in_bud_lst['GWF'] == 0.0, msg1 + assert out_bud_lst['GWF'] == 0.0, msg1 + + + if name[-1] != 'n': + + assert in_bud_lst['GWF'] > 0.0, msg5 + assert out_bud_lst['GWF'] > 0.0, msg6 + + # Determine gw/sfe temperature gradient direction + if lktemp[0] > gwe_temps[0, 0, 0, 0]: + # conduction will be from lake to gw cells + assert in_bud_lst["LAKEBED-COND"] == 0.0, msg2 + assert out_bud_lst["LAKEBED-COND"] > 0.0, msg2 + + slp = trenddetector(np.arange(len(lktemp)), lktemp) + # Lake should be cooling through conductive exchange with cold gw + assert slp < 0.0, msg3 + + slp = trenddetector(np.arange(lktemp.shape[0]), gwe_temps[:, 1, 8, 11]) + # gw should be warming through conductive exchange with a warm lake + assert slp > 0.0, msg4 + + else: # thermally reversed scenario (cold lake, warm gw) + + # conduction will be from gw cells to lake + assert in_bud_lst["LAKEBED-COND"] > 0.0, msg2 + assert out_bud_lst["LAKEBED-COND"] == 0.0, msg2 + + slp = trenddetector(np.arange(len(lktemp)), lktemp) + # Lake should be warming through conductive exchange with warm gw + assert slp > 0.0, msg3 + + slp = trenddetector(np.arange(lktemp.shape[0]), gwe_temps[:, 1, 8, 11]) + # gw should be cooling through conductive exchange with a cold lake + assert slp < 0.0, msg4 + + + +# - No need to change any code below +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_results, idxsim=idx + ), + ws, + ) From bf0a67f9f80c8c0fba500302c014c5a1913afcba Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 1 Jun 2023 07:09:42 -0700 Subject: [PATCH 144/212] Adding streambed thermal conduction autotest --- autotest/test_gwe_sfe_strmbedcond.py | 753 +++++++++++++++++++++++++++ 1 file changed, 753 insertions(+) create mode 100644 autotest/test_gwe_sfe_strmbedcond.py diff --git a/autotest/test_gwe_sfe_strmbedcond.py b/autotest/test_gwe_sfe_strmbedcond.py new file mode 100644 index 00000000000..d51e3a5c775 --- /dev/null +++ b/autotest/test_gwe_sfe_strmbedcond.py @@ -0,0 +1,753 @@ +# Test conduction between an advanced package feature, in this case stream +# reaches with varying channel geometries and the host GWE gw cells. +# This test should include: +# - no gw-sw interaction +# - with gw-sw interaction +# - hot gw cell warming an upstream reach +# - thermally hot stream water warming host gw cells +# + +import os + +import flopy +import numpy as np +import pytest +import math +from framework import TestFramework +from simulation import TestSimulation + +ex = [ + "sfe-conductn", + "sfe-conducti", + "sfe-conducto", + "sfe-conductm" +] +# +# The last letter in the names above indicates the following +# n = "no gw/sw exchange" +# i = "gwf into strm" +# o = "strm to gw" +# m = "mixed" (i.e., convection one direction, conductive gradient the other direction?) + +k11 = 500. +rhk = [0.0, k11, k11, k11] +strt_gw_temp = [4.0, 4.0, 4.0, 20.0] +strm_temp = [18.0, 18.0, 20.0, 4.0] +chd_condition = ['n', 'i', 'o', 'm'] +surf_Q_in = [[8.64, 0.], [8640.0, 0.], [8640.0, 0.], [8640.0, 0.]] # 86400 m^3/d = 1 m^3/s = 35.315 cfs + +def get_x_frac(x_coord1, rwid): + x_xsec1 = [val / rwid for val in x_coord1] + return x_xsec1 + + +def get_xy_pts(x, y, rwid): + x_xsec1 = get_x_frac(x, rwid) + x_sec_tab = [[xx, hh] for xx, hh, in zip(x_xsec1, y)] + return x_sec_tab + + +# Model units +length_units = "m" +time_units = "days" + +# model domain and grid definition +Lx = 90.0 +Ly = 90.0 +nrow = 3 +ncol = 3 +nlay = 1 +delr = Lx / ncol +delc = Ly / nrow +xmax = ncol * delr +ymax = nrow * delc +X, Y = np.meshgrid( + np.linspace(delr / 2, xmax - delr / 2, ncol), + np.linspace(ymax - delc / 2, 0 + delc / 2, nrow), +) +ibound = np.ones((nlay, nrow, ncol)) +# Because eqn uses negative values in the Y direction, need to do a little manipulation +Y_m = -1 * np.flipud(Y) +top = np.array( + [ + [101.50, 101.25, 101.00], + [101.25, 101.00, 100.75], + [101.50, 101.25, 101.00], + ] +) + +botm = np.array( + [ + [98.5, 98.25, 98.0], + [98.25, 98.0, 97.75], + [98.5, 98.25, 98.0], + ] +) +strthd = 98.75 +chd_on = True + +# NPF parameters +ss = 0.00001 +sy = 0.20 +hani = 1 +laytyp = 1 + +# Package boundary conditions +sfr_evaprate = 0.1 +rwid = [9.0, 10.0, 20] +# Channel geometry: trapezoidal +x_sec_tab1 = get_xy_pts( + [0.0, 2.0, 4.0, 5.0, 7.0, 9.0], + [0.66666667, 0.33333333, 0.0, 0.0, 0.33333333, 0.66666667], + rwid[0], +) + +x_sec_tab2 = get_xy_pts( + [0.0, 2.0, 4.0, 6.0, 8.0, 10.0], + [0.5, 0.25, 0.0, 0.0, 0.25, 0.5], + rwid[1], +) + +x_sec_tab3 = get_xy_pts( + [0.0, 4.0, 8.0, 12.0, 16.0, 20.0], + [0.33333333, 0.16666667, 0.0, 0.0, 0.16666667, 0.33333333], + rwid[2], +) +x_sec_tab = [x_sec_tab1, x_sec_tab2, x_sec_tab3] + +def calc_wp(j, stg): + if j < 1: + rise = 1 / 3 + run = 2 + bot_wid = 1. + elif j < 2: + rise = 1 / 4 + run = 2 + bot_wid = 2. + else: + rise = 1 / 6 + run = 4 + bot_wid = 4. + + ang = math.atan2(rise, run) + hyp_len = stg / math.sin(ang) + wp = hyp_len * 2 + bot_wid + + return wp + +def process_line(line): + m_arr = line.strip().split() + if any("=" in itm and len(itm) > 1 for itm in m_arr): + m_arr = [float(itm.split("=")[-1]) if len(itm.split("=")) > 1 else itm for itm in m_arr] + nm = m_arr[-2] + else: + nm = m_arr[-3] + val = m_arr[-1] + return {nm: float(val)} + +def get_bud(fname, srchStr): + in_bud_lst = {} + out_bud_lst = {} + with open(fname, "r") as f: + for line in f: + if srchStr in line: + # Read the package budget + line = next(f) + while not "TOTAL IN =" in line: + if "=" in line: + in_bud_lst.update(process_line(line)) + + line = next(f) + + # Get "total in" + dct = process_line(line) + T_in = dct["IN"] + + line = next(f) + while not "TOTAL OUT =" in line: + if "=" in line: + out_bud_lst.update(process_line(line)) + + line = next(f) + + # Get "total out" + dct = process_line(line) + T_out = dct["OUT"] + + break + + return T_in, T_out, in_bud_lst, out_bud_lst + +def trenddetector(list_of_index, array_of_data, order=1): + result = np.polyfit(list_of_index, list(array_of_data), order) + slope = result[-2] + return float(slope) + +# Transport related parameters +porosity = sy # porosity (unitless) +K_therm = 2.0 # Thermal conductivity # ($W/m/C$) +rhow = 1000 # Density of water ($kg/m^3$) +rhos = 2650 # Density of the aquifer material ($kg/m^3$) +Cpw = 4180 # Heat capacity of water ($J/kg/C$) +Cps = 880 # Heat capacity of the solids ($J/kg/C$) +lhv = 2454000.0 # Latent heat of vaporization ($J/kg$) +K_therm_strmbed = [1.5, 1.75, 2.0] # Thermal conductivity of the streambed material ($W/m/C$) +rbthcnd = [0.0001, 0.0001, 0.0001, 0.0001] + +# time params +steady = {0: False, 1: False} +transient = {0: True, 1: True} +nstp = [1, 1] +tsmult = [1, 1] +perlen = [1, 1] + +nouter, ninner = 1000, 300 +hclose, rclose, relax = 1e-3, 1e-4, 0.97 + +# +# MODFLOW 6 flopy GWF object +# + + +def build_model(idx, dir): + # Base simulation and model name and workspace + ws = dir + name = ex[idx] + + print("Building model...{}".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwename = "gwe-" + name + + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" + ) + + # Instantiating time discretization + tdis_rc = [] + for i in range(len(nstp)): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + flopy.mf6.ModflowTdis( + sim, nper=len(nstp), perioddata=tdis_rc, time_units=time_units + ) + + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + newtonoptions="newton", + ) + + # Instantiating solver + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="cooley", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(ims, [gwfname]) + + # Instantiate discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + ) + + # Instantiate node property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_specific_discharge=True, + icelltype=1, # >0 means saturated thickness varies with computed head + k=k11, + ) + + # Instantiate storage package + flopy.mf6.ModflowGwfsto( + gwf, + save_flows=False, + iconvert=laytyp, + ss=ss, + sy=sy, + steady_state=steady, + transient=transient, + ) + + # Instantiate initial conditions package + flopy.mf6.ModflowGwfic(gwf, strt=strthd) + + # Instantiate output control package + flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{gwfname}.cbc", + head_filerecord=f"{gwfname}.hds", + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # Instantiate constant head boundary package + if chd_condition[idx] == 'n': + chdelev1 = top[0, 0] - 3.0 + chdelev2 = top[0, -1] - 3.0 + elif chd_condition[idx] == 'i': + chdelev1 = top[0, 0] - 0.05 + chdelev2 = top[0, -1] - 0.05 + elif chd_condition[idx] == 'o': + chdelev1 = top[0, 0] - 3.0 + chdelev2 = top[0, -1] - 3.0 + elif chd_condition[idx] == 'm': + chdelev1 = top[0, 0] - 3.0 # convection from stream to gw, + chdelev2 = top[0, -1] - 3.0 # conduction from gw to strm + + # Instatiate constant head boundary package + if chd_on: + chdlist1 = [ + [(0, 0, 0), chdelev1, strt_gw_temp[idx]], + [(0, 0, ncol - 1), chdelev2, strt_gw_temp[idx]], + [(0, nrow - 1, 0), chdelev1, strt_gw_temp[idx]], + [(0, nrow - 1, ncol - 1), chdelev2, strt_gw_temp[idx]], + ] + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chdlist1, + print_input=True, + print_flows=True, + save_flows=False, + pname="CHD-1", + auxiliary="TEMPERATURE", + filename=f"{gwfname}.chd", + ) + + # Instantiate streamflow routing package + # Determine the middle row and store in rMid (account for 0-base) + rMid = 1 + # sfr data + nreaches = ncol + rlen = delr + roughness = 0.035 + rbth = 1.0 + strmbd_hk = rhk[idx] + strm_up = 100.25 + strm_dn = 99 + slope = (strm_up - strm_dn) / ((ncol - 1) * delr) / 10 # divide by 10 to further reduce slop + ustrf = 1.0 + ndv = 0 + strm_incision = 1.0 + + # use trapezoidal cross-section for channel geometry + sfr_xsec_tab_nm1 = "{}.xsec.tab1".format(gwfname) + sfr_xsec_tab_nm2 = "{}.xsec.tab2".format(gwfname) + sfr_xsec_tab_nm3 = "{}.xsec.tab3".format(gwfname) + sfr_xsec_tab_nm = [sfr_xsec_tab_nm1, sfr_xsec_tab_nm2, sfr_xsec_tab_nm3] + crosssections = [] + for n in range(nreaches): + # 3 reaches, 3 cross section types + crosssections.append([n, sfr_xsec_tab_nm[n]]) + + # Setup the tables + for n in range(len(x_sec_tab)): + flopy.mf6.ModflowUtlsfrtab( + gwf, + nrow=len(x_sec_tab[n]), + ncol=2, + table=x_sec_tab[n], + filename=sfr_xsec_tab_nm[n], + pname=f"sfrxsectable" + str(n + 1), + ) + + packagedata = [] + for irch in range(nreaches): + nconn = 1 + if 0 < irch < nreaches - 1: + nconn += 1 + rp = [ + irch, + (0, rMid, irch), + rlen, + rwid[irch], + slope, + top[rMid, irch] - strm_incision, + rbth, + strmbd_hk, + roughness, + nconn, + ustrf, + ndv, + ] + packagedata.append(rp) + + connectiondata = [] + for irch in range(nreaches): + rc = [irch] + if irch > 0: + rc.append(irch - 1) + if irch < nreaches - 1: + rc.append(-(irch + 1)) + connectiondata.append(rc) + + sfr_perioddata = {} + for t in np.arange(len(surf_Q_in[idx])): + sfrbndx = [] + for i in np.arange(nreaches): + if i == 0: + sfrbndx.append([i, "INFLOW", surf_Q_in[idx][t]]) + #sfrbndx.append([i, "EVAPORATION", sfr_evaprate]) + + sfr_perioddata.update({t: sfrbndx}) + + # Instantiate SFR observation points + sfr_obs = { + "{}.sfr.obs.csv".format(gwfname): [ + ("rch1_depth", "depth", 1), + ("rch2_depth", "depth", 2), + ("rch3_depth", "depth", 3), + ], + "digits": 8, + "print_input": True, + "filename": name + ".sfr.obs", + } + + budpth = f"{gwfname}.sfr.cbc" + flopy.mf6.ModflowGwfsfr( + gwf, + save_flows=True, + print_stage=True, + print_flows=True, + print_input=True, + length_conversion=1.0, + time_conversion=86400, + budget_filerecord=budpth, + mover=False, + nreaches=nreaches, + packagedata=packagedata, + connectiondata=connectiondata, + crosssections=crosssections, + perioddata=sfr_perioddata, + observations=sfr_obs, + pname="SFR-1", + filename="{}.sfr".format(gwfname), + ) + + # -------------------------------------------------- + # Setup the GWE model for simulating heat transport + # -------------------------------------------------- + gwe = flopy.mf6.ModflowGwe(sim, modelname=gwename) + + # Instantiating solver for GWT + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename), + ) + sim.register_ims_package(imsgwe, [gwename]) + + # Instantiating DIS for GWE + flopy.mf6.ModflowGwedis( + gwe, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + pname="DIS", + filename="{}.dis".format(gwename), + ) + + # Instantiate Mobile Storage and Transfer package + flopy.mf6.ModflowGwemst( + gwe, + save_flows=True, + porosity=porosity, + cps=Cps, + rhos=rhos, + packagedata=[Cpw, rhow, lhv], + pname="MST", + filename="{}.mst".format(gwename), + ) + + # Instantiate Energy Transport Initial Conditions package + flopy.mf6.ModflowGweic(gwe, strt=strt_gw_temp[idx]) + + # Instantiate Advection package + flopy.mf6.ModflowGweadv(gwe, scheme="UPSTREAM") + + # Instantiate Dispersion package (also handles conduction) + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=True, + ktw=0.5918, + kts=0.2700, + filename="{}.dsp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + # [b/c at least one boundary back is active (SFR), ssm must be on] + sourcerecarray = [("CHD-1", "AUX", "TEMPERATURE")] + flopy.mf6.ModflowGwessm( + gwe, sources=sourcerecarray, filename="{}.ssm".format(gwename) + ) + + # Instantiate Streamflow Energy Transport package + sfepackagedata = [] + for irno in range(ncol): + t = (irno, strm_temp[idx], K_therm_strmbed[irno], rbthcnd[idx]) + sfepackagedata.append(t) + + sfeperioddata = [] + for irno in range(ncol): + if irno == 0: + sfeperioddata.append((irno, "INFLOW", strm_temp[idx])) + #sfeperioddata.append((irno, sfr_applied_bnd[idx], sfe_applied_temp[idx])) + + flopy.mf6.modflow.ModflowGwesfe( + gwe, + boundnames=False, + save_flows=True, + print_input=False, + print_flows=False, + print_temperature=True, + temperature_filerecord=gwename + ".sfe.bin", + budget_filerecord=gwename + ".sfe.bud", + packagedata=sfepackagedata, + reachperioddata=sfeperioddata, + flow_package_name="SFR-1", + pname="SFE-1", + filename="{}.sfe".format(gwename), + ) + + # Instantiate Output Control package for transport + flopy.mf6.ModflowGweoc( + gwe, + temperature_filerecord="{}.ucn".format(gwename), + saverecord=[("TEMPERATURE", "ALL")], + temperatureprintrecord=[("COLUMNS", 3, "WIDTH", 20, "DIGITS", 8, "GENERAL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + filename="{}.oc".format(gwename), + ) + + # Instantiate Gwf-Gwe Exchange package + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename="{}.gwfgwe".format(gwename), + ) + + return sim, None + + +def eval_results(sim): + print("evaluating results...") + + # read flow results from model + name = ex[sim.idxsim] + gwfname = "gwf-" + name + + fname = gwfname + ".sfr.cbc" + fname = os.path.join(sim.simpath, fname) + assert os.path.isfile(fname) + + sfrobj = flopy.utils.binaryfile.CellBudgetFile(fname, precision="double") + sfr_wetted_interface_area = sfrobj.get_data(text="gwf") + + # Retrieve simulated stage of each reach + sfr_pth0 = os.path.join(sim.simpath, f"{gwfname}.sfr.obs.csv") + sfrstg = np.genfromtxt(sfr_pth0, names=True, delimiter=",") + + # Extract shared wetted interfacial areas + shared_area = [] + for t in range(len(sfr_wetted_interface_area)): + sp_area = [] + for i in range(ncol): + sp_area.append(sfr_wetted_interface_area[t][i][3]) + + shared_area.append(sp_area) + + shared_area = np.array(shared_area) + + # Calculate wetted streambed area for comparison + for j, stg in enumerate(list(sfrstg[0])[1:]): + wp = calc_wp(j, stg) + wa = wp * delr + msg = ( + "Wetted streambed area for reach " + str(j) + + "in stress period 1 does not match explicitly-calculated answer" + ) + assert np.isclose(wa, shared_area[0, j], atol=1e-4), msg + + msg = ( + "Wetted streambed area of all reaches should be zero in stess " + "period 2" + ) + for val in list(sfrstg[1])[1:]: + assert val == 0.0, msg + + # Sub-scenario checks + # initialize search term + srchStr = "SFE-1 BUDGET FOR ENTIRE MODEL AT END OF TIME STEP 1, STRESS PERIOD 1" + fname = "gwe-" + name + ".lst" + fname = os.path.join(sim.simpath, fname) + + # gw exchng (item 'GWF') should be zero in heat transport budget + T_in, T_out, in_bud_lst, out_bud_lst = get_bud(fname, srchStr) + assert np.isclose(T_in, T_out, atol=0.1), "There is a heat budget discrepancy" + + # Get temperature of streamwater + fname1 = "gwe-" + name + ".sfe.bin" + fname1 = os.path.join(sim.simpath, fname1) + sfeobj = flopy.utils.HeadFile(fname1, precision='double', text="TEMPERATURE") + sfe_temps = sfeobj.get_alldata() + + # Get temperature of gw + fname2 = "gwe-" + name + ".ucn" + fname2 = os.path.join(sim.simpath, fname2) + gwobj = flopy.utils.HeadFile(fname2, precision='double', text="TEMPERATURE") + gw_temps = gwobj.get_alldata() + + msg1 = "Budget item 'GWF' should be 0.0 for this scenario" + msg2 = "Thermal conduction is occurring in the wrong direction" + msg3 = "There should be a decreasing temperatures trend in " \ + "downstream direction owing to conductive losses" + msg4 = "There should be an increasing temperature trend in " \ + "the row of cells hosting the stream owing to increasing " \ + "conductive losses from the stream to the aquifer " \ + "(i.e., greater shared wetted areas)" + if name[-1] == 'n': # no gw/sw convective exchange, simulates conductive exchange only + + assert in_bud_lst['GWF'] == 0.0, msg1 + assert out_bud_lst['GWF'] == 0.0, msg1 + + # Determine gw/sfe temperature gradient direction + if sfe_temps[0, 0, 0, 0] > gw_temps[0, 0, 0, 0]: + # conduction will be from stream to gw + assert in_bud_lst["STREAMBED-COND"] == 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] > 0.0, msg2 + + slp = trenddetector(np.arange(0, sfe_temps.shape[-1]), sfe_temps[0, 0, 0, :]) + assert slp < 0.0, msg3 + + slp = trenddetector(np.arange(0, gw_temps.shape[-2]), gw_temps[0, 0, 1, :]) + assert slp > 0.0, msg4 + + else: + assert in_bud_lst["STREAMBED-COND"] > 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] == 0.0, msg2 + + # streamflow gain from aquifer ("into stream") + if name[-1] == 'i': + + msg = "Budget item 'GWF' should reflect heat entering stream" + assert in_bud_lst['GWF'] > 0.0, msg + assert out_bud_lst['GWF'] == 0.0, msg + + # Determine gw/sfe temperature gradient direction + if sfe_temps[0, 0, 0, 0] > gw_temps[0, 0, 0, 0]: + # conduction will be from stream to gw + assert in_bud_lst["STREAMBED-COND"] == 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] > 0.0, msg2 + + slp = trenddetector(np.arange(0, sfe_temps.shape[-1]), sfe_temps[0, 0, 0, :]) + assert slp < 0.0, msg3 + + slp = trenddetector(np.arange(0, gw_temps.shape[-2]), gw_temps[0, 0, 1, :]) + assert slp > 0.0, msg4 + + else: + assert in_bud_lst["STREAMBED-COND"] > 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] == 0.0, msg2 + + # streamflow loss to aquifer ("out of stream") + if name[-1] == 'o': + + msg = "Budget item 'GWF' should reflect heat exiting stream" + assert in_bud_lst['GWF'] == 0.0, msg + assert out_bud_lst['GWF'] > 0.0, msg + + # Determine gw/sfe temperature gradient direction + if sfe_temps[0, 0, 0, 0] > gw_temps[0, 0, 0, 0]: + # conduction will be from stream to gw + assert in_bud_lst["STREAMBED-COND"] == 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] > 0.0, msg2 + + slp = trenddetector(np.arange(0, sfe_temps.shape[-1]), sfe_temps[0, 0, 0, :]) + assert slp < 0.0, msg3 + + slp = trenddetector(np.arange(0, gw_temps.shape[-2]), gw_temps[0, 0, 1, :]) + assert slp < 0.0, msg4 + + else: + assert in_bud_lst["STREAMBED-COND"] > 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] == 0.0, msg2 + + # Reverse temperature gradient (cold stream, warm aquifer) + # Loss of streamwater to aquifer + # Thus, convection from strm to gw, conduction from gw to strm + if name[-1] == 'm': # 'm' for mixed + + msg = "Budget item 'GWF' should reflect heat exiting stream" + assert in_bud_lst['GWF'] == 0.0, msg + assert out_bud_lst['GWF'] > 0.0, msg + + # Determine gw/sfe temperature gradient direction + if sfe_temps[0, 0, 0, 0] > gw_temps[0, 0, 0, 0]: + # conduction will be from stream to gw + assert in_bud_lst["STREAMBED-COND"] == 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] > 0.0, msg2 + + else: + assert in_bud_lst["STREAMBED-COND"] > 0.0, msg2 + assert out_bud_lst["STREAMBED-COND"] == 0.0, msg2 + + slp = trenddetector(np.arange(0, sfe_temps.shape[-1]), sfe_temps[0, 0, 0, :]) + assert slp > 0.0, msg3 + + slp = trenddetector(np.arange(0, gw_temps.shape[-2]), gw_temps[0, 0, 1, :]) + assert slp > 0.0, msg4 + + +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_results, idxsim=idx + ), + ws, + ) From 312ac94560e7376990fd63d30a8942c40da79193 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 1 Jun 2023 16:10:28 -0700 Subject: [PATCH 145/212] Adding well bore (MAW) conductive exchange with aquifer autotest --- autotest/test_gwe_lke_conduction.py | 2 +- autotest/test_gwe_mwe_conduction.py | 557 ++++++++++++++++++++++++++++ 2 files changed, 558 insertions(+), 1 deletion(-) create mode 100644 autotest/test_gwe_mwe_conduction.py diff --git a/autotest/test_gwe_lke_conduction.py b/autotest/test_gwe_lke_conduction.py index 54746e8a49e..dd06872fc3a 100644 --- a/autotest/test_gwe_lke_conduction.py +++ b/autotest/test_gwe_lke_conduction.py @@ -5,7 +5,7 @@ # no SFR or other advanced packages. Problem set up to have only # conductive exchange with groundwater, then groundwater pass-through: # that is, gw inflow on the left side, gw outflow on the -# right side of the lake. +# right side of the lake. # # starting groundwater temperature: 4.0 # left chd boundary inflow temperature: 4.0 diff --git a/autotest/test_gwe_mwe_conduction.py b/autotest/test_gwe_mwe_conduction.py new file mode 100644 index 00000000000..b380fdecf59 --- /dev/null +++ b/autotest/test_gwe_mwe_conduction.py @@ -0,0 +1,557 @@ +# Test mwe package. Looks at wetted area of well for calculating +# heat conduction exchange. This test is related to test_gwf_maw06.py but +# with some further customization for testing GWE capabilities. +# - Test has 0 flow conductance with gw cells in layers 1-3 +# - Test uses MAW to inject water into layer 4 (bottom layer) +# - Test includes conductive exchng only between MWE feature and +# layers 1 to 3 +# - Water extracted by normal WEL features in bottom corners of model +# - Water table saturates only ~1/2 of top layer; therefore +# conductive exchange + +import os + +import flopy +import numpy as np +import pytest +from framework import TestFramework +from simulation import TestSimulation + + +def process_line(line): + m_arr = line.strip().split() + if any("=" in itm and len(itm) > 1 for itm in m_arr): + m_arr = [float(itm.split("=")[-1]) if len(itm.split("=")) > 1 else itm for itm in m_arr] + nm = m_arr[-2] + else: + nm = m_arr[-3] + val = m_arr[-1] + return {nm: float(val)} + +def get_bud(fname, srchStr): + in_bud_lst = {} + out_bud_lst = {} + with open(fname, "r") as f: + for line in f: + if srchStr in line: + # Read the package budget + line = next(f) + while not "TOTAL IN =" in line: + if "=" in line: + in_bud_lst.update(process_line(line)) + + line = next(f) + + # Get "total in" + dct = process_line(line) + T_in = dct["IN"] + + line = next(f) + while not "TOTAL OUT =" in line: + if "=" in line: + out_bud_lst.update(process_line(line)) + + line = next(f) + + # Get "total out" + dct = process_line(line) + T_out = dct["OUT"] + + break + + return T_in, T_out, in_bud_lst, out_bud_lst + +def get_welbore_heat_flow(fname, srchStr): + ener_Q = [] + with open(fname, "r") as f: + for line in f: + if srchStr in line: + # Read an established format + for i in np.arange(3): # read & discard 3 lines + line = next(f) + for i in np.arange(4): # read & digest 4 lines of needed output + line = next(f) + m_arr = line.strip().split() + ener_Q.append([int(m_arr[0]), float(m_arr[2])]) + break + + return np.array(ener_Q) + +def trenddetector(list_of_index, array_of_data, order=1): + result = np.polyfit(list_of_index, list(array_of_data), order) + slope = result[-2] + return float(slope) + +ex = ["mwe_01"] +mawstrt = 3.5 + +# Flow related parameters +lx = 70.0 +ly = 70.0 +nlay = 4 +nrow = 7 +ncol = 7 +nper = 1 +delc = ly / nrow +delr = lx / ncol +top = 4.0 +botm = [3.0, 2.0, 1.0, 0.0] +strt = 3.5 +transient = {0: True} + +perlen = [10.0] +nstp = [10] +tsmult = [1.0] + +Kh = [1.0, 1.0, 1e-6, 100] +Kv = [1.0, 1.0, 1e-6, 100] + +Sy = 0.3 +Ss = 0.0 + +# Transport related parameters +mixelm = 0 # Upstream vs TVD (Upstream selected) +strttemp = 1.0 # Initial temperature ($^{\circ}C$) +porosity = Sy # porosity (unitless) +ktw = 0.5918 # Thermal Conductivity of Water ($W/m/^{\circ}C$) +kts = 0.2700 # Thermal Conductivity of Aquifer Solids ($W/m/^{\circ}C$) +rhow = 1000 # Density of water ($kg/m^3$) +rhos = 2650 # Density of the aquifer material ($kg/m^3$) +Cpw = 4180 # Heat Capacity of water ($J/kg/C$) +Cps = 880 # Heat capacity of the solids ($J/kg/C$) +lhv = 2454000.0 # Latent heat of vaporization ($J/kg$) +K_therm_maw = 1.5 # Thermal conductivity of the lakebed material ($W/m/C$) +wthkcnd = 0.01 +mawradius = 0.1 +mawbottom = 0.0 + +# Solver settings +nouter, ninner = 700, 10 +hclose, rclose, relax = 1e-8, 1e-6, 0.97 + + +def build_model(idx, dir): + + tdis_rc = [] + for i in range(nper): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + name = ex[idx] + + # Instantiate MODFLOW 6 simulation + ws = dir + sim = flopy.mf6.MFSimulation( + sim_name=name, version="mf6", exe_name="mf6", sim_ws=ws + ) + + # Instantiate Time Discretization package + flopy.mf6.ModflowTdis( + sim, time_units="DAYS", nper=nper, perioddata=tdis_rc + ) + + # Instantiate Groundwater Flow model + gwfname = "gwf-" + name + gwename = "gwe-" + name + newtonoptions = "NEWTON UNDER_RELAXATION" + gwf = flopy.mf6.ModflowGwf( + sim, modelname=gwfname, newtonoptions=newtonoptions + ) + + ims = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="SIMPLE", + under_relaxation_gamma=0.1, + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename=f"{gwfname}.ims", + ) + sim.register_ims_package(ims, [gwfname]) + + # Instantiate Discretization package + flopy.mf6.ModflowGwfdis( + gwf, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + length_units="METERS", + pname="DIS", + filename=f"{gwfname}.dis", + ) + + # Instantiate Initial Conditions package + flopy.mf6.ModflowGwfic( + gwf, + strt=strt, + pname="IC", + filename=f"{gwfname}.ic", + ) + + # Instantiate Node Property Flow package + flopy.mf6.ModflowGwfnpf( + gwf, + xt3doptions=False, + save_flows=True, + save_specific_discharge=True, + icelltype=1, + k=Kh, + k33=Kv, + pname="NPF", + filename = f"{gwfname}.npf", + ) + + # Instantiate Storage package + flopy.mf6.ModflowGwfsto( + gwf, + sy=Sy, + ss=Ss, + iconvert=1, + transient=transient, + pname="STO", + filename=f"{gwfname}.sto", + ) + + # Instantiate Well package (for extracting MAW-injected water) + wellist = [] + for i in [0, nrow - 1]: + for j in [0, ncol - 1]: + wellist.append([(nlay - 1, i, j), -7.0, 0.01]) + + flopy.mf6.ModflowGwfwel( + gwf, + stress_period_data=wellist, + print_input=True, + print_flows=True, + save_flows=False, + pname="WEL", + auxiliary="TEMPERATURE", + filename=f"{gwfname}.wel", + ) + + # Instantiate Multi-Aquifer Well package (injects water) + mstrt = mawstrt + mawcondeqn = "SPECIFIED" + mawngwfnodes = nlay + # + mawpackagedata = [ + [0, mawradius, mawbottom, mstrt, mawcondeqn, mawngwfnodes] + ] + # + conncond = [0.0, 0.0, 0.0, 1000.0] + mawconnectiondata = [ + [0, icon, (icon, 3, 3), top, mawbottom, conncond[icon], -999.0] + for icon in range(nlay) + ] + # + mawperioddata = [ + [0, "STATUS", "ACTIVE"], + [0, "RATE", 28.0] + ] + maw = flopy.mf6.ModflowGwfmaw( + gwf, + print_input=True, + print_head=True, + print_flows=True, + save_flows=True, + head_filerecord=f"{gwfname}.maw.bin", + budget_filerecord=f"{gwfname}.maw.cbc", + packagedata=mawpackagedata, + connectiondata=mawconnectiondata, + perioddata=mawperioddata, + pname="MAW-1", + ) + opth = f"{gwfname}.maw.obs" + obsdata = { + f"{gwfname}.maw.obs.csv": [ + ("whead", "head", (0,)), + ] + } + maw.obs.initialize( + filename=opth, digits=20, print_input=True, continuous=obsdata + ) + + # Instantiate Output Control package + flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{gwfname}.cbc", + head_filerecord=f"{gwfname}.hds", + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[ + ( + "HEAD", + "ALL", + ), + ( + "BUDGET", + "ALL", + ), + ], + printrecord=[ + ( + "HEAD", + "ALL", + ), + ( + "BUDGET", + "ALL", + ), + ], + ) + + # Create GWE model + # ---------------- + gwe = flopy.mf6.ModflowGwe( + sim, modelname=gwename, model_nam_file="{}.nam".format(gwename) + ) + gwe.name_file.save_flows = True + + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="ALL", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename=f"{gwename}.ims", + ) + sim.register_ims_package(imsgwe, [gwename]) + + # Instantiating MODFLOW 6 enregy transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + pname="DIS", + filename="{}.dis".format(gwename), + ) + + # Instantiating MODFLOW 6 energy transport initial temperatures + flopy.mf6.ModflowGweic( + gwe, strt=strttemp, filename="{}.ic".format(gwename) + ) + + # Instantiate mobile storage and transfer package + flopy.mf6.ModflowGwemst( + gwe, + porosity=porosity, + cps=Cps, + rhos=rhos, + packagedata=[Cpw, rhow, lhv], + pname='MST-1', + filename=f"{gwename}.mst" + ) + + # Instantiating MODFLOW 6 energy transport advection package + if mixelm == 0: + scheme = "UPSTREAM" + elif mixelm == -1: + scheme = "TVD" + else: + raise Exception() + + # Instantiate advection package + flopy.mf6.ModflowGweadv( + gwe, + scheme=scheme, + pname='ADV', + filename="{}.adv".format(gwename) + ) + + # Instantiate dispersion package + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=True, + ktw=0.5918, + kts=0.2700, + filename="{}.dsp".format(gwename) + ) + + # Instantiate source/sink mixing package + sourcerecarray = [ + ("WEL", "AUX", "TEMPERATURE"), + ] + flopy.mf6.ModflowGwessm( + gwe, sources=sourcerecarray, filename=f"{gwename}.ssm" + ) + + # Instantiating MODFLOW 6 transport output control package + flopy.mf6.ModflowGweoc( + gwe, + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 17, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + filename="{}.oc".format(gwename), + ) + + # Instantiating MODFLOW 6 multi-well energy transport (mwe) package + # ,, , , + mwepackagedata = [(0, 1.0, K_therm_maw, wthkcnd, "well1")] + + mweperioddata = {0: [(0, "RATE", 40.0)]} + + # note: for specifying lake number, use fortran indexing! + mwe_obs = { + "{}.mweobs".format(gwename): [ + ("MweTemp", "temperature", 1), + ] + } + + flopy.mf6.ModflowGwemwe( + gwe, + flow_package_name="MAW-1", + budget_filerecord=gwename + ".mwe.bud", + boundnames=True, + save_flows=True, + print_input=True, + print_flows=True, + print_temperature=True, + packagedata=mwepackagedata, + mweperioddata=mweperioddata, + observations=mwe_obs, + pname="MWE-1", + filename="{}.mwe".format(gwename), + ) + + # Instantiate GWF-GWE exchange + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename=f"{name}.gwfgwe", + ) + + return sim, None + + +def eval_results(sim): + print("evaluating results...") + + top_local = [4.0, 3.0, 2.0, 1.0] + botm_local = [3.0, 2.0, 1.0, 0.0] + + # calculate volume of water and make sure it is conserved + name = ex[sim.idxsim] + gwfname = "gwf-" + name + fname = gwfname + ".maw.bin" + fname = os.path.join(sim.simpath, fname) + assert os.path.isfile(fname) + bobj = flopy.utils.HeadFile(fname, text="HEAD") + stage = bobj.get_alldata().flatten() + + name = ex[sim.idxsim] + gwfname = "gwf-" + name + fname = gwfname + ".maw.cbc" + fname = os.path.join(sim.simpath, fname) + assert os.path.isfile(fname) + bobj = flopy.utils.CellBudgetFile(fname, precision='double') + gwfarea = bobj.get_data(text='GWF') + + # Retrieve simulated temperature for the multi-aquifer well + gwename = "gwe-" + name + fname = gwename + ".mweobs" + mwtemp_file = os.path.join(sim.simpath, fname) + assert os.path.isfile(mwtemp_file) + mwtemp = np.genfromtxt(mwtemp_file, names=True, delimiter=",") + mwtemp = mwtemp['MWETEMP'].astype(float).reshape((mwtemp.size, 1)) + + # Retrieve gw temperatures + fname = gwename + ".ucn" + fname = os.path.join(sim.simpath, fname) + assert os.path.isfile(fname) + gwtempobj = flopy.utils.HeadFile(fname, precision="double", text="TEMPERATURE") + gwe_temps = gwtempobj.get_alldata() + + # Calculate conductive exchange external to MF6 and compare to MF6 values + # Evaluates first time step only + wellbore_cnd_time1 = [] + for i in np.arange(nlay): + if stage[0] > top_local[i]: + thk = top_local[i] - botm_local[i] + elif stage[0] > botm_local[i]: + thk = stage[0] - botm_local[i] + else: + thk = 0 + + # Check that MF6 (GWF) wellbore wetted area matches explicitly calc + + + wa = 2 * mawradius * np.pi * thk + welborecnd = K_therm_maw * wa / wthkcnd + gw_temp = gwe_temps[0, i, 3, 3] + deltaT = mwtemp[0][0] - gw_temp + + wellbore_cnd_time1.append(welborecnd * deltaT) + + # Retrieve budget + fname = os.path.join(sim.simpath, gwename + '.lst') + srchStr = "MWE-1 BUDGET FOR ENTIRE MODEL AT END OF TIME STEP 1, " \ + "STRESS PERIOD 1" + T_in, T_out, in_bud_lst, out_bud_lst = get_bud(fname, srchStr) + assert np.isclose(T_in, T_out, atol=0.1), \ + "There is a heat budget discrepancy where there shouldn't be" + + msg1 = "Conductive heat exchanges calculated explicitly and by MF6 " \ + "do not match" + msg2 = "Individually summing well bore 'heat flows' is not matching " \ + "the global budget heat flow into the aquifer" + msg3 = "Groundwater should be warming, but isn't" + + # Get MF6 saved wellbore heat "flows" + srchStr = "MWE PACKAGE (MWE-1) FLOW RATES PERIOD 1 STEP 1" + wbcnd_mf6 = get_welbore_heat_flow(fname, srchStr) + + # Check top 3 layers (4th layer handled different) + for i in np.arange(nlay-1): + assert np.isclose(wbcnd_mf6[i, 1], round(wellbore_cnd_time1[i], 4)), msg1 + + # Layer 4 "heat flow" includes convection and conduction, compare + # "heat flow" from all layers to global budget line item 'IN: GWF' + glob_bud_gw_in = out_bud_lst['GWF'] + out_bud_lst['WELLBORE-COND'] + mwe_out = wbcnd_mf6.sum(axis=0)[1] + assert np.isclose(mwe_out, glob_bud_gw_in, rtol=1e-9), msg2 + + # Ensure that temperatures near the injection point are rising + slp = trenddetector(np.arange(gwe_temps.shape[0]), gwe_temps[:, 3, 3, 3]) + assert slp > 0.0, msg3 + +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_results, idxsim=idx + ), + ws, + ) From ee54ccb3a4b3010260a51b708371860d30c73ecc Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 09:37:59 -0700 Subject: [PATCH 146/212] Reorganization of generalized transport model files --- msvs/mf6core.vfproj | 25 ++++++++++--------- .../tsp1.f90} | 0 .../tsp1adv1.f90 | 0 .../tsp1apt1.f90 | 0 .../tsp1cnc1.f90 | 0 .../tsp1fmi1.f90 | 0 .../tsp1ic1.f90 | 0 .../tsp1mvt1.f90 | 0 .../tsp1obs1.f90 | 0 .../tsp1oc1.f90 | 0 .../tsp1ssm1.f90 | 0 11 files changed, 13 insertions(+), 12 deletions(-) rename src/Model/{TransportModel.f90 => TransportModel/tsp1.f90} (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1adv1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1apt1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1cnc1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1fmi1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1ic1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1mvt1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1obs1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1oc1.f90 (100%) rename src/Model/{GroundWaterTransport => TransportModel}/tsp1ssm1.f90 (100%) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 44279c722bf..f9e719a42fd 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -186,16 +186,7 @@ - - - - - - - - - - + @@ -220,11 +211,21 @@ + + + + + + + + + + + - - + diff --git a/src/Model/TransportModel.f90 b/src/Model/TransportModel/tsp1.f90 similarity index 100% rename from src/Model/TransportModel.f90 rename to src/Model/TransportModel/tsp1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1adv1.f90 b/src/Model/TransportModel/tsp1adv1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1adv1.f90 rename to src/Model/TransportModel/tsp1adv1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1apt1.f90 b/src/Model/TransportModel/tsp1apt1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1apt1.f90 rename to src/Model/TransportModel/tsp1apt1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1cnc1.f90 b/src/Model/TransportModel/tsp1cnc1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1cnc1.f90 rename to src/Model/TransportModel/tsp1cnc1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1fmi1.f90 b/src/Model/TransportModel/tsp1fmi1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1fmi1.f90 rename to src/Model/TransportModel/tsp1fmi1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1ic1.f90 b/src/Model/TransportModel/tsp1ic1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1ic1.f90 rename to src/Model/TransportModel/tsp1ic1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1mvt1.f90 b/src/Model/TransportModel/tsp1mvt1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1mvt1.f90 rename to src/Model/TransportModel/tsp1mvt1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1obs1.f90 b/src/Model/TransportModel/tsp1obs1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1obs1.f90 rename to src/Model/TransportModel/tsp1obs1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1oc1.f90 b/src/Model/TransportModel/tsp1oc1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1oc1.f90 rename to src/Model/TransportModel/tsp1oc1.f90 diff --git a/src/Model/GroundWaterTransport/tsp1ssm1.f90 b/src/Model/TransportModel/tsp1ssm1.f90 similarity index 100% rename from src/Model/GroundWaterTransport/tsp1ssm1.f90 rename to src/Model/TransportModel/tsp1ssm1.f90 From 0135f6a414be06a5c0355d15111444efd54de1d6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 10:36:08 -0700 Subject: [PATCH 147/212] gwe.f90 doxygen --- src/Model/GroundWaterEnergy/gwe1.f90 | 679 +++------------------------ 1 file changed, 75 insertions(+), 604 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 1d890448754..e78a8112d61 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -29,15 +29,8 @@ module GweModule type(GweInputDataType), pointer :: gwecommon => null() !< container for data shared with multiple packages type(GweMstType), pointer :: mst => null() !< mass storage and transfer package type(GweDspType), pointer :: dsp => null() !< dispersion package - !integer(I4B), pointer :: inic => null() ! unit number IC - !integer(I4B), pointer :: infmi => null() ! unit number FMI - !integer(I4B), pointer :: inmvt => null() ! unit number MVT integer(I4B), pointer :: inmst => null() ! unit number MST - !integer(I4B), pointer :: inadv => null() ! unit number ADV integer(I4B), pointer :: indsp => null() ! unit number DSP - !integer(I4B), pointer :: inssm => null() ! unit number SSM - !integer(I4B), pointer :: inoc => null() ! unit number OC - !integer(I4B), pointer :: inobs => null() ! unit number OBS contains @@ -58,39 +51,17 @@ module GweModule procedure :: allocate_gwe_scalars procedure, private :: package_create - !procedure, private :: ftype_check procedure :: get_iasym => gwe_get_iasym - !procedure, private :: gwe_ot_flow - !procedure, private :: gwe_ot_flowja - !procedure, private :: gwe_ot_dv - !procedure, private :: gwe_ot_bdsummary - !procedure, private :: gwe_ot_obs procedure, private :: create_gwe_specific_packages procedure, private :: create_bndpkgs - !procedure, private :: create_lstfile - !procedure, private :: log_namfile_options end type GweModelType - ! -- Module variables constant for simulation - !integer(I4B), parameter :: NIUNIT=100 - !character(len=LENFTYPE), dimension(NIUNIT) :: cunit - !data cunit/ 'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 - ! 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 - ! 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 - ! 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - ! 'API6 ', ' ', ' ', ' ', ' ', & ! 25 - ! 75 * ' '/ - contains + !> @brief Create a new groundwater energy transport model object + !< subroutine gwe_cr(filename, id, modelname) -! ****************************************************************************** -! gwe_cr -- Create a new groundwater energy transport model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ListsModule, only: basemodellist use BaseModelModule, only: AddBaseModelToList @@ -101,8 +72,6 @@ subroutine gwe_cr(filename, id, modelname) use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr - !use SimModule, only: store_error, count_errors - !use NameFileModule, only: NameFileType use GwfDisModule, only: dis_cr use GwfDisvModule, only: disv_cr use GwfDisuModule, only: disu_cr @@ -121,11 +90,10 @@ subroutine gwe_cr(filename, id, modelname) integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local - integer(I4B) :: indis !, indis6, indisu6, indisv6 + integer(I4B) :: indis integer(I4B) :: ipakid, i, j, iu, ipaknum character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname - !type(NameFileType) :: namefile_obj type(GweModelType), pointer :: this class(BaseModelType), pointer :: model character(len=LENMEMPATH) :: input_mempath @@ -146,48 +114,12 @@ subroutine gwe_cr(filename, id, modelname) model => this call AddBaseModelToList(basemodellist, model) ! - ! -- Assign values - !this%filename = filename - !this%name = modelname - !this%macronym = 'GWE' - !this%id = id - ! ! -- Instantiate shared data container call gweshared_dat_cr(this%gwecommon) ! ! -- Call parent class routine call this%tsp_cr(filename, id, modelname, 'GWE', indis, this%gwecommon) ! - ! -- set input model namfile memory path - !input_mempath = create_mem_path(modelname, 'NAM', idm_context) - ! - ! -- copy option params from input context - !call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) - !call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & - ! found%print_input) - !call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & - ! found%print_flows) - !call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) - ! - ! -- create the list file - !call this%create_lstfile(lst_fname, filename, found%list) - ! - ! -- activate save_flows if found - !if (found%save_flows) then - ! this%ipakcb = -1 - !end if - ! - ! -- Instantiate generalized labels - !call tsplabels_cr(this%tsplab, this%name) - ! - ! -- log set options - !if (this%iout > 0) then - ! call this%log_namfile_options(found) - !end if - ! - ! -- Create utility objects - !call budget_cr(this%budget, this%name, this%tsplab) - ! ! -- create model packages call this%create_gwe_specific_packages(indis) ! @@ -195,15 +127,14 @@ subroutine gwe_cr(filename, id, modelname) return end subroutine gwe_cr + !> @brief Define packages of the GWE model + !! + !! This subroutine defines a gwe model type. Steps include: + !! - call df routines for each package + !! - set variables and pointers + !! + !< subroutine gwe_df(this) -! ****************************************************************************** -! gwe_df -- Define packages of the model -! Subroutine: (1) call df routines for each package -! (2) set variables and pointers -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ModelPackageInputsModule, only: NIUNIT_GWE use TspLabelsModule, only: setTspLabels @@ -256,13 +187,9 @@ subroutine gwe_df(this) return end subroutine gwe_df + !> @brief Add the internal connections of this model to the sparse matrix + !< subroutine gwe_ac(this, sparse) -! ****************************************************************************** -! gwe_ac -- Add the internal connections of this model to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix ! -- dummy @@ -288,14 +215,10 @@ subroutine gwe_ac(this, sparse) return end subroutine gwe_ac + !> @brief Map the positions of this model's connections in the numerical + !! solution coefficient matrix. + !< subroutine gwe_mc(this, matrix_sln) -! ****************************************************************************** -! gwe_mc -- Map the positions of this models connections in the -! numerical solution coefficient matrix. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweModelType) :: this class(MatrixBaseType), pointer :: matrix_sln !< global system matrix @@ -320,15 +243,13 @@ subroutine gwe_mc(this, matrix_sln) return end subroutine gwe_mc + !> @brief GroundWater Energy Transport Model Allocate and Read + !! + !! This subroutine: + !! - allocates and reads packages that are part of this model, + !! - allocates memory for arrays used by this model object + !< subroutine gwe_ar(this) -! ****************************************************************************** -! gwe_ar -- GroundWater Energy Transport Model Allocate and Read -! Subroutine: (1) allocates and reads packages part of this model, -! (2) allocates memory for arrays part of this model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: DHNOFLO ! -- dummy @@ -371,14 +292,10 @@ subroutine gwe_ar(this) return end subroutine gwe_ar + !> @brief GroundWater Energy Transport Model Read and Prepare + !! + !! This subroutine calls the attached packages' read and prepare routines subroutine gwe_rp(this) -! ****************************************************************************** -! gwe_rp -- GroundWater Energy Transport Model Read and Prepare -! Subroutine: (1) calls package read and prepare routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: readnewdata ! -- dummy @@ -408,14 +325,11 @@ subroutine gwe_rp(this) return end subroutine gwe_rp + !> @brief GroundWater Energy Transport Model Time Step Advance + !! + !! This subroutine calls the attached packages' advance subroutines + !< subroutine gwe_ad(this) -! ****************************************************************************** -! gwe_ad -- GroundWater Energy Transport Model Time Step Advance -! Subroutine: (1) calls package advance subroutines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimVariablesModule, only: isimcheck, iFailedStepRetry ! -- dummy @@ -468,13 +382,12 @@ subroutine gwe_ad(this) return end subroutine gwe_ad + !> @brief GroundWater Energy Transport Model calculate coefficients + !! + !! This subroutine calls the attached packages' calculate coefficients + !! subroutines + !< subroutine gwe_cf(this, kiter) -! ****************************************************************************** -! gwe_cf -- GroundWater Energy Transport Model calculate coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweModelType) :: this @@ -494,13 +407,12 @@ subroutine gwe_cf(this, kiter) return end subroutine gwe_cf + !> @brief GroundWater Energy Transport Model fill coefficients + !! + !! This subroutine calls the attached packages' fill coefficients + !! subroutines + !< subroutine gwe_fc(this, kiter, matrix_sln, inwtflag) -! ****************************************************************************** -! gwe_fc -- GroundWater Energy Transport Model fill coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweModelType) :: this @@ -544,14 +456,12 @@ subroutine gwe_fc(this, kiter, matrix_sln, inwtflag) return end subroutine gwe_fc + !> @brief GroundWater Energy Transport Model Final Convergence Check + !! + !! If MVR/MVT is active, this subroutine calls the MVR convergence check + !! subroutines. + !< subroutine gwe_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) -! ****************************************************************************** -! gwe_cc -- GroundWater Energy Transport Model Final Convergence Check -! Subroutine: (1) calls package cc routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweModelType) :: this integer(I4B), intent(in) :: innertot @@ -562,32 +472,21 @@ subroutine gwe_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) integer(I4B), intent(inout) :: ipak real(DP), intent(inout) :: dpak ! -- local - !class(BndType), pointer :: packobj - !integer(I4B) :: ip ! -- formats ! ------------------------------------------------------------------------------ ! ! -- If mover is on, then at least 2 outers required if (this%inmvt > 0) call this%mvt%mvt_cc(kiter, iend, icnvgmod, cpak, dpak) ! - ! -- Call package cc routines - !do ip = 1, this%bndlist%Count() - ! packobj => GetBndFromList(this%bndlist, ip) - ! call packobj%bnd_cc(iend, icnvg, hclose, rclose) - !enddo - ! ! -- return return end subroutine gwe_cc + !> @brief Groundwater energy transport model calculate flow + !! + !! This subroutine calls the attached packages' intercell flows (flow ja) + !< subroutine gwe_cq(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwe_cq --Groundwater energy transport model calculate flow -! Subroutine: (1) Calculate intercell flows (flowja) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: csr_diagsum ! -- dummy @@ -633,15 +532,12 @@ subroutine gwe_cq(this, icnvg, isuppress_output) return end subroutine gwe_cq + !> @brief GroundWater Energy Transport Model Budget + !! + !! This subroutine: + !! - calculates intercell flows (flowja) + !! - calculates package contributions to the model budget subroutine gwe_bd(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwe_bd --GroundWater Energy Transport Model Budget -! Subroutine: (1) Calculate intercell flows (flowja) -! (2) Calculate package contributions to model budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use ConstantsModule, only: DZERO ! -- dummy class(GweModelType) :: this @@ -673,239 +569,31 @@ subroutine gwe_bd(this, icnvg, isuppress_output) return end subroutine gwe_bd + !> @brief GroundWater Energy Transport Model Output + !! + !! This subroutine calls the parent class's output routine. + !< subroutine gwe_ot(this) -! ****************************************************************************** -! gwe_ot -- GroundWater Energy Transport Model Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(GweModelType) :: this -! ! -- local -! integer(I4B) :: idvsave -! integer(I4B) :: idvprint -! integer(I4B) :: icbcfl -! integer(I4B) :: icbcun -! integer(I4B) :: ibudfl -! integer(I4B) :: ipflag -! ! -- formats -! character(len=*), parameter :: fmtnocnvg = & -! "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & -! &I0,' OF STRESS PERIOD ',I0,'****')" + ! -- local + ! -- formats ! ------------------------------------------------------------------------------ ! ! -- Call parent class _ot routines. call this%tsp_ot(this%inmst) -! ! -! ! -- Set write and print flags -! idvsave = 0 -! idvprint = 0 -! icbcfl = 0 -! ibudfl = 0 -! if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 -! if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 -! if (this%oc%oc_save('BUDGET')) icbcfl = 1 -! if (this%oc%oc_print('BUDGET')) ibudfl = 1 -! icbcun = this%oc%oc_save_unit('BUDGET') -! ! -! ! -- Override ibudfl and idvprint flags for nonconvergence -! ! and end of period -! ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) -! idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & -! this%icnvg, endofperiod) -! ! -! ! Calculate and save observations -! call this%gwe_ot_obs() -! ! -! ! Save and print flows -! call this%gwe_ot_flow(icbcfl, ibudfl, icbcun) -! ! -! ! Save and print dependent variables -! call this%gwe_ot_dv(idvsave, idvprint, ipflag) -! ! -! ! Print budget summaries -! call this%gwe_ot_bdsummary(ibudfl, ipflag) -! ! -! ! -- Timing Output; if any dependendent variables or budgets -! ! are printed, then ipflag is set to 1. -! if (ipflag == 1) call tdis_ot(this%iout) -! ! -! ! -- Write non-convergence message -! if (this%icnvg == 0) then -! write (this%iout, fmtnocnvg) kstp, kper -! end if ! ! -- Return return end subroutine gwe_ot -! -! subroutine gwe_ot_obs(this) -! class(GweModelType) :: this -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -- Calculate and save observations -! call this%obs%obs_bd() -! call this%obs%obs_ot() -! -! ! -- Calculate and save package obserations -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_bd_obs() -! call packobj%bnd_ot_obs() -! end do -! -! end subroutine gwe_ot_obs -! -! subroutine gwe_ot_flow(this, icbcfl, ibudfl, icbcun) -! class(GweModelType) :: this -! integer(I4B), intent(in) :: icbcfl -! integer(I4B), intent(in) :: ibudfl -! integer(I4B), intent(in) :: icbcun -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -- Save GWE flows -! call this%gwe_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) -! if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) -! if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) -! if (this%inssm > 0) then -! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) -! end if -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) -! end do -! -! ! -- Save advanced package flows -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) -! end do -! if (this%inmvt > 0) then -! call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) -! end if -! -! ! -- Print GWF flows -! ! no need to print flowja -! ! no need to print mst -! ! no need to print fmi -! if (this%inssm > 0) then -! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) -! end if -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) -! end do -! -! ! -- Print advanced package flows -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) -! end do -! if (this%inmvt > 0) then -! call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) -! end if -! -! end subroutine gwe_ot_flow -! -! subroutine gwe_ot_flowja(this, nja, flowja, icbcfl, icbcun) -!! ****************************************************************************** -!! gwe_ot_flowja -- Write intercell flows -!! ****************************************************************************** -!! -!! SPECIFICATIONS: -!! ------------------------------------------------------------------------------ -! ! -- dummy -! class(GweModelType) :: this -! integer(I4B), intent(in) :: nja -! real(DP), dimension(nja), intent(in) :: flowja -! integer(I4B), intent(in) :: icbcfl -! integer(I4B), intent(in) :: icbcun -! ! -- local -! integer(I4B) :: ibinun -! ! -- formats -!! ------------------------------------------------------------------------------ -! ! -! ! -- Set unit number for binary output -! if (this%ipakcb < 0) then -! ibinun = icbcun -! elseif (this%ipakcb == 0) then -! ibinun = 0 -! else -! ibinun = this%ipakcb -! end if -! if (icbcfl == 0) ibinun = 0 -! ! -! ! -- Write the face flows if requested -! if (ibinun /= 0) then -! call this%dis%record_connection_array(flowja, ibinun, this%iout) -! end if -! ! -! ! -- Return -! return -! end subroutine gwe_ot_flowja -! -! subroutine gwe_ot_dv(this, idvsave, idvprint, ipflag) -! class(GweModelType) :: this -! integer(I4B), intent(in) :: idvsave -! integer(I4B), intent(in) :: idvprint -! integer(I4B), intent(inout) :: ipflag -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -- Print advanced package dependent variables -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_dv(idvsave, idvprint) -! end do -! -! ! -- save head and print head -! call this%oc%oc_ot(ipflag) -! -! end subroutine gwe_ot_dv -! -! subroutine gwe_ot_bdsummary(this, ibudfl, ipflag) -! use TdisModule, only: kstp, kper, totim -! class(GweModelType) :: this -! integer(I4B), intent(in) :: ibudfl -! integer(I4B), intent(inout) :: ipflag -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -! ! -- Package budget summary -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) -! end do -! -! ! -- mover budget summary -! if (this%inmvt > 0) then -! call this%mvt%mvt_ot_bdsummary(ibudfl) -! end if -! -! ! -- model budget summary -! if (ibudfl /= 0) then -! ipflag = 1 -! call this%budget%budget_ot(kstp, kper, this%iout) -! end if -! -! ! -- Write to budget csv -! call this%budget%writecsv(totim) -! -! end subroutine gwe_ot_bdsummary + !> @brief Deallocate + !! + !! Deallocate memmory at conclusion of model run + !< subroutine gwe_da(this) -! ****************************************************************************** -! gwe_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate use MemoryManagerExtModule, only: memorylist_remove @@ -978,7 +666,6 @@ end subroutine gwe_da !! a method for the gwe model object so that the exchange object could add its !! contributions. !! - !! (1) adds the entry to the budget object !< subroutine gwe_bdentry(this, budterm, budtxt, rowlabel) ! -- modules @@ -1030,56 +717,38 @@ function gwe_get_iasym(this) result(iasym) return end function gwe_get_iasym + !> Allocate memory for non-allocatable members + !! + !! A subroutine for allocating the scalars specific to the GWE model type. + !! Additional scalars used by the parent class are allocated by the parent + !! class. + !< subroutine allocate_gwe_scalars(this, modelname) -! ****************************************************************************** -! allocate_scalars -- Allocate memory for non-allocatable members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy class(GweModelType) :: this character(len=*), intent(in) :: modelname ! ------------------------------------------------------------------------------ - ! - ! -- allocate members from parent class - !call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate members that are part of model class - !call mem_allocate(this%inic, 'INIC', this%memoryPath) - !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) - !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) call mem_allocate(this%inmst, 'INMST', this%memoryPath) - !call mem_allocate(this%inadv, 'INADV', this%memoryPath) call mem_allocate(this%indsp, 'INDSP', this%memoryPath) - !call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - !call mem_allocate(this%inoc, 'INOC ', this%memoryPath) - !call mem_allocate(this%inobs, 'INOBS', this%memoryPath) ! - !this%inic = 0 - !this%infmi = 0 - !this%inmvt = 0 this%inmst = 0 - !this%inadv = 0 this%indsp = 0 - !this%inssm = 0 - !this%inoc = 0 - !this%inobs = 0 ! ! -- return return end subroutine allocate_gwe_scalars + !> @brief Create boundary condition packages for this model + !! + !! This subroutine calls the package create routines for packages activated + !! by the user. + !< subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) -! ****************************************************************************** -! package_create -- Create boundary condition packages for this model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error @@ -1129,9 +798,6 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & call uze_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%tsplab, this%eqnsclfac, & this%gwecommon) - !case('IST6') - ! call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - ! pakname, this%fmi, this%mst) !case('API6') ! call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & ! pakname) @@ -1157,74 +823,8 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & return end subroutine package_create -! subroutine ftype_check(this, namefile_obj, indis) -! ****************************************************************************** -! ftype_check -- Check to make sure required input files have been specified -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ -! ! -- modules -! use ConstantsModule, only: LINELENGTH -! use SimModule, only: store_error, count_errors -! !use NameFileModule, only: NameFileType -! ! -- dummy -! class(GweModelType) :: this -! type(NameFileType), intent(in) :: namefile_obj -! integer(I4B), intent(in) :: indis -! ! -- local -! character(len=LINELENGTH) :: errmsg -! integer(I4B) :: i, iu -! character(len=LENFTYPE), dimension(10) :: nodupftype = & -! &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', & -! &'ADV6 ', 'DSP6 ', 'SSM6 ', 'OC6 ', 'OBS6 '/) -! ------------------------------------------------------------------------------ -! ! -! ! -- Check for IC6, DIS(u), and MST. Stop if not present. -! if (this%inic == 0) then -! write (errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT '// & -! 'SPECIFIED.' -! call store_error(errmsg) -! end if -! if (indis == 0) then -! write (errmsg, '(1x,a)') & -! 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! if (this%inmst == 0) then -! write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & -! &PACKAGE NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! if (count_errors() > 0) then -! write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! ! -! ! -- Check to make sure that some GWE packages are not specified more -! ! than once -! do i = 1, size(nodupftype) -! call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) -! if (iu > 0) then -! write (errmsg, '(1x, a, a, a)') & -! 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & -! ' NOT ALLOWED FOR GWE MODEL.' -! call store_error(errmsg) -! end if -! end do -! ! -! ! -- Stop if errors -! if (count_errors() > 0) then -! write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & -! trim(namefile_obj%filename) -! call store_error(errmsg, terminate=.TRUE.) -! end if -! ! -! ! -- return -! return -! end subroutine ftype_check - !> @brief Cast to GweModelType + !< function CastAsGweModel(model) result(gwemodel) class(*), pointer :: model !< The object to be cast class(GweModelType), pointer :: gwemodel !< The GWE model @@ -1305,18 +905,8 @@ subroutine create_gwe_specific_packages(this, indis) use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context - !use GwfDisModule, only: dis_cr - !use GwfDisvModule, only: disv_cr - !use GwfDisuModule, only: disu_cr - !use TspIcModule, only: ic_cr - !use TspFmiModule, only: fmi_cr use GweMstModule, only: mst_cr - !use TspAdvModule, only: adv_cr use GweDspModule, only: dsp_cr - !use TspSsmModule, only: ssm_cr - !use TspMvtModule, only: mvt_cr - !use TspOcModule, only: oc_cr - !use TspObsModule, only: tsp_obs_cr ! -- dummy class(GweModelType) :: this integer(I4B), intent(in) :: indis @@ -1358,59 +948,25 @@ subroutine create_gwe_specific_packages(this, indis) ! ! -- create dis package as it is a prerequisite for other packages select case (pkgtype) - !case ('DIS6') - ! indis = 1 - ! call dis_cr(this%dis, this%name, mempath, indis, this%iout) - !case ('DISV6') - ! indis = 1 - ! call disv_cr(this%dis, this%name, mempath, indis, this%iout) - !case ('DISU6') - ! indis = 1 - ! call disu_cr(this%dis, this%name, mempath, indis, this%iout) - !case ('IC6') - ! this%inic = inunit - !case ('FMI6') - ! this%infmi = inunit - !case ('MVT6') - ! this%inmvt = inunit case ('MST6') this%inmst = inunit - !case ('ADV6') - ! this%inadv = inunit case ('DSP6') this%indsp = 1 mempathdsp = mempath - !case ('SSM6') - ! this%inssm = inunit - !case ('OC6') - ! this%inoc = inunit - !case ('OBS6') - ! this%inobs = inunit case ('TMP6', 'SRC6', 'LKE6', 'SFE6', & 'MWE6', 'UZE6', ' ', 'API6') call expandarray(bndpkgs) bndpkgs(size(bndpkgs)) = n case default ! TODO - end select + end select end do ! ! -- Create packages that are tied directly to model - !call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - !call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & - ! this%eqnsclfac) ! kluge note: some are already created in TransportModel??? call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) - !call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & - ! this%eqnsclfac) call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & this%fmi, this%eqnsclfac, this%gwecommon) - !call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & - ! this%tsplab, this%eqnsclfac, this%gwecommon) - !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & - ! this%eqnsclfac) - !call oc_cr(this%oc, this%name, this%inoc, this%iout) - !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified call this%ftype_check(indis, this%inmst) @@ -1419,89 +975,4 @@ subroutine create_gwe_specific_packages(this, indis) end subroutine create_gwe_specific_packages -! subroutine create_lstfile(this, lst_fname, model_fname, defined) -! ! -- modules -! use KindModule, only: LGP -! use InputOutputModule, only: openfile, getunit -! ! -- dummy -! class(GweModelType) :: this -! character(len=*), intent(inout) :: lst_fname -! character(len=*), intent(in) :: model_fname -! logical(LGP), intent(in) :: defined -! ! -- local -! integer(I4B) :: i, istart, istop -! ! -! ! -- set list file name if not provided -! if (.not. defined) then -! ! -! ! -- initialize -! lst_fname = ' ' -! istart = 0 -! istop = len_trim(model_fname) -! ! -! ! -- identify '.' character position from back of string -! do i = istop, 1, -1 -! if (model_fname(i:i) == '.') then -! istart = i -! exit -! end if -! end do -! ! -! ! -- if not found start from string end -! if (istart == 0) istart = istop + 1 -! ! -! ! -- set list file name -! lst_fname = model_fname(1:istart) -! istop = istart + 3 -! lst_fname(istart:istop) = '.lst' -! end if -! ! -! ! -- create the list file -! this%iout = getunit() -! call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') -! ! -! ! -- write list file header -! call write_listfile_header(this%iout, 'GROUNDWATER ENERGY TRANSPORT MODEL (GWE)') -! ! -! ! -- return -! return -! end subroutine create_lstfile -! -! !> @brief Write model namfile options to list file -! !< -! subroutine log_namfile_options(this, found) -! use GwfNamInputModule, only: GwfNamParamFoundType -! class(GweModelType) :: this -! type(GwfNamParamFoundType), intent(in) :: found -! -! write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' -! -! if (found%newton) then -! write (this%iout, '(4x,a)') & -! 'NEWTON-RAPHSON method enabled for the model.' -! if (found%under_relaxation) then -! write (this%iout, '(4x,a,a)') & -! 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & -! 'elevation of the model will be applied to the model.' -! end if -! end if -! -! if (found%print_input) then -! write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & -! 'FOR ALL MODEL STRESS PACKAGES' -! end if -! -! if (found%print_flows) then -! write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & -! 'FOR ALL MODEL PACKAGES' -! end if -! -! if (found%save_flows) then -! write (this%iout, '(4x,a)') & -! 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' -! end if - -! write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' -! end subroutine log_namfile_options - end module GweModule From c4bc174b66faac2c65c2564c1471d5d049f4fcd6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 10:54:04 -0700 Subject: [PATCH 148/212] gwe1sfe1.f90 doxygen compliance --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 43 +++++++++++------------- 1 file changed, 20 insertions(+), 23 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 48b7a9ed20a..0fcaf5ebb89 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -3,7 +3,7 @@ ! -- todo: save the sfe temperature into the sfr aux variable? (perhaps needed for GWT-GWE exchanges) ! -- todo: calculate the sfr VISC aux variable using temperature? ! -! SFR flows (sfrbudptr) index var SFE term Transport Type ! kluge note: "SFE flows", etc? +! SFR flows (sfrbudptr) index var SFE term Transport Type !--------------------------------------------------------------------------------- ! -- terms from SFR that will be handled by parent APT Package @@ -158,13 +158,9 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & return end subroutine sfe_create + !> @brief Find corresponding sfe package + !< subroutine find_sfe_package(this) -! ****************************************************************************** -! find corresponding sfe package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -308,7 +304,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval - real(DP) :: ctherm ! kluge? + real(DP) :: ctherm real(DP) :: wa !< wetted area real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive streambed material @@ -386,7 +382,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to sfe row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposd, -ctherm) call matrix_sln%add_value_pos(iposoffd, ctherm) ! ! -- add to gwe row for sfe connection @@ -672,13 +668,13 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) n1 = this%flowbudptr%budterm(this%idxbudsbcd)%id1(j) if (this%iboundpak(n1) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) - auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' + ! for now, there is only 1 aux variable under 'GWF' + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) ktf = this%ktf(n1) s = this%rfeatthk(n1) ctherm = ktf * wa / s - q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct - !q = -q ! flip sign so relative to advanced package feature + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) @@ -694,13 +690,10 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) return end subroutine sfe_fill_budobj + !> @brief Allocate scalars specific to the streamflow energy transport (SFE) + !! package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -731,7 +724,8 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars - !> @brief Allocate arrays + !> @brief Allocate arrays specific to the streamflow energy transport (SFE) + !! package. !< subroutine sfe_allocate_arrays(this) ! -- modules @@ -764,7 +758,7 @@ subroutine sfe_allocate_arrays(this) return end subroutine sfe_allocate_arrays - !> @brief Deallocate + !> @brief Deallocate !< subroutine sfe_da(this) ! -- modules @@ -843,9 +837,9 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) - heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 (kluge note) - if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day (kluge note) -!! if (present(rhsval)) rhsval = -rrate / this%eqnsclfac ! kluge note: divided by eqnsclfac for fc purposes because rrate is in terms of energy + heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap + if (present(rrate)) rrate = qbnd * heatlat + !!if (present(rhsval)) rhsval = -rrate / this%eqnsclfac ! kluge note: divided by eqnsclfac for fc purposes because rrate is in terms of energy if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -912,6 +906,9 @@ subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) end subroutine sfe_iflw_term !> @brief Outflow term + !! + !! Accounts for the energy leaving the model, for example, energy exiting the + !! model domain via a flow in a stream channel. !< subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- dummy From dafe2cb866dcfa0bb909b1460b9a5e738f55e524 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 11:37:25 -0700 Subject: [PATCH 149/212] gwe1src1.f90 doxygen compliance --- src/Model/GroundWaterEnergy/gwe1src1.f90 | 95 ++++++++++-------------- 1 file changed, 40 insertions(+), 55 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index bf7beb18f2d..c9284d59a45 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -39,16 +39,14 @@ module GweSrcModule contains + !> @brief Create an energy source loading package + !! + !! This subroutine: + !! - creates new-style package + !! - points bndobj to the new package + !< subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & tsplab, gwecommon) -! ****************************************************************************** -! src_create -- Create a New Src Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -97,13 +95,9 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & return end subroutine src_create + !> @brief Deallocate memory + !< subroutine src_da(this) -! ****************************************************************************** -! src_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -119,13 +113,11 @@ subroutine src_da(this) 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(GweSrcType) :: this @@ -142,15 +134,13 @@ subroutine src_allocate_scalars(this) 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, reset_mover) -! ****************************************************************************** -! src_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no sources -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweSrcType) :: this logical, intent(in), optional :: reset_mover @@ -179,19 +169,18 @@ subroutine src_cf(this, reset_mover) cycle end if q = this%bound(1, i) -!! this%rhs(i) = -q / this%eqnsclfac +!! this%rhs(i) = -q / this%eqnsclfac ! kluge Ask Alden if this can be deleted this%rhs(i) = -q end do ! return end subroutine src_cf + !> @brief Add matrix terms related to specified energy 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(GweSrcType) :: this @@ -226,13 +215,12 @@ subroutine src_fc(this, rhs, ia, idxglo, matrix_sln) 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: ! ------------------------------------------------------------------------------ class(GweSrcType), intent(inout) :: this ! ------------------------------------------------------------------------------ @@ -259,14 +247,13 @@ subroutine define_listlabel(this) end subroutine define_listlabel ! -- Procedures related to observations + ! + !> @brief Support function for specified energy 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 class(GweSrcType) :: this @@ -275,14 +262,13 @@ logical function src_obs_supported(this) 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 @@ -303,7 +289,6 @@ subroutine src_df_obs(this) end subroutine src_df_obs ! -- Procedure related to time series - subroutine src_rp_ts(this) ! -- Assign tsLink%Text appropriately for ! all time series in use by package. From 798f1022a62565ac7c126060f7d57ea7cfbb47e0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 14:19:51 -0700 Subject: [PATCH 150/212] gwe1uze1.f90 doxygen compliance --- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 384 +++++++++-------------- 1 file changed, 144 insertions(+), 240 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 67664d1a44e..dacaad05d07 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -86,14 +86,10 @@ module GweUzeModule contains + !> @breif Create a new UZE package + !< subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac, gwecommon) -! ****************************************************************************** -! uze_create -- Create a New UZE Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -152,13 +148,9 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & return end subroutine uze_create + !> @brief Find corresponding uze package + !< subroutine find_uze_package(this) -! ****************************************************************************** -! find corresponding uze package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -277,15 +269,13 @@ subroutine find_uze_package(this) return end subroutine find_uze_package + !> @brief Add package connection to matrix. + !! + !! Overrides apt_ac to fold the UZE heat balance terms into the row + !! corresponding to the host cell and enforce thermal equilibrium between + !! UZE and the GWE cell. + !< subroutine uze_ac(this, moffset, sparse) -! ****************************************************************************** -! uze_ac -- Add package connection to matrix. Overrides apt_ac to fold the -! UZE heat balance terms into the row corresponding to the host cell -! and enforce thermal equilibrium between UZE and the GWE cell. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use MemoryManagerModule, only: mem_setptr use SparseModule, only: sparsematrix ! -- dummy @@ -316,7 +306,7 @@ subroutine uze_ac(this, moffset, sparse) ! ! -- add uze-to-gwe connections. For uze, this particular do loop ! is the same as its counterpart in apt_ac. - ! nlist: number of gwe cells with a connection to at least one uze object + ! nlist: number of gwe cells with a connection to at least one uze object do i = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(i) !< uze object position within uze object list jj = this%flowbudptr%budterm(this%idxbudgwf)%id2(i) !< position of gwe cell to which uze feature is connected @@ -339,16 +329,14 @@ subroutine uze_ac(this, moffset, sparse) jglo = moffset + this%dis%nodes + this%ioffset + jj !< global position of connected uze feature ! -- if connected uze feature is upstream, find cell that hosts currently ! considered uze feature and add connection to that cell's row -!! if (jj < n) then ! presumes that deeper uze object has id with larger integer - do ii = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist !< uze object id among uze objects - idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(ii) !< uze object position within uze object list - idxjj = this%flowbudptr%budterm(this%idxbudgwf)%id2(ii) !< position of gwe cell to which uze feature is connected - idxnglo = moffset + this%dis%nodes + this%ioffset + idxn !< uze feature global position - idxjglo = moffset + idxjj !< gwe cell global position - if (nglo == idxnglo) exit - end do - call sparse%addconnection(idxjglo, jglo, 1) -!! end if + do ii = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist !< uze object id among uze objects + idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(ii) !< uze object position within uze object list + idxjj = this%flowbudptr%budterm(this%idxbudgwf)%id2(ii) !< position of gwe cell to which uze feature is connected + idxnglo = moffset + this%dis%nodes + this%ioffset + idxn !< uze feature global position + idxjglo = moffset + idxjj !< gwe cell global position + if (nglo == idxnglo) exit + end do + call sparse%addconnection(idxjglo, jglo, 1) end do end if end if @@ -357,13 +345,9 @@ subroutine uze_ac(this, moffset, sparse) return end subroutine uze_ac + !> @brief Map package connection to matrix + !< subroutine uze_mc(this, moffset, matrix_sln) -! ****************************************************************************** -! uze_mc -- map package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use SparseModule, only: sparsematrix ! -- dummy class(GweUzeType), intent(inout) :: this @@ -375,7 +359,6 @@ subroutine uze_mc(this, moffset, matrix_sln) integer(I4B) :: ipos, idxpos ! -- format ! ------------------------------------------------------------------------------ - ! ! ! -- allocate memory for index arrays call this%apt_allocate_index_arrays() @@ -390,7 +373,6 @@ subroutine uze_mc(this, moffset, matrix_sln) ! ! -- feature diagonal in global matrix do n = 1, this%ncv -!! this%idxlocnode(n) = this%dis%nodes + this%ioffset + n iglo = moffset + this%dis%nodes + this%ioffset + n this%idxpakdiag(n) = matrix_sln%get_position_diag(iglo) end do @@ -402,11 +384,9 @@ subroutine uze_mc(this, moffset, matrix_sln) iglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index jglo = j + moffset !< cell row index ! -- Note that this is where idxlocnode is set for uze; it is set -!! ! to the host cell global row rather than the feature global row -!! this%idxlocnode(n) = jglo ! to the host cell local row index rather than the feature local ! row index - this%idxlocnode(n) = j ! kluge note: do we want to introduce a new array instead of co-opting idxlocnode??? + this%idxlocnode(n) = j ! kluge note: do we want to introduce a new array instead of co-opting idxlocnode??? ! -- for connection ipos in list of feature-cell connections, ! global positions of feature-row diagonal and off-diagonal ! corresponding to the cell @@ -436,22 +416,19 @@ subroutine uze_mc(this, moffset, matrix_sln) jglo = moffset + this%dis%nodes + this%ioffset + j !< global position of connected uze feature ! -- if connected uze feature is upstream, find cell that hosts currently ! considered uze feature and map connection to that cell's row -!! if (j < n) then ! jiffylube: determine ordering of features; is id1 always upstream of id2? - do idxpos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist - idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(idxpos) !< feature number - idxj = this%flowbudptr%budterm(this%idxbudgwf)%id2(idxpos) !< cell number - ! jiffylube: should be able to base search simply on (idxn == n) - idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature row index - idxiglo = moffset + idxj !< cell row index - if (idxjglo == iglo) exit - end do - ! -- for connection ipos in list of feature-feature connections, - ! global positions of host-cell-row entries corresponding to - ! (in the same columns as) the feature-id1-row diagonal and the - ! feature-id1-row off-diagonal corresponding to feature id2 - this%idxfjfdglo(ipos) = matrix_sln%get_position_diag(idxiglo) - this%idxfjfoffdglo(ipos) = matrix_sln%get_position(idxiglo, jglo) -!! end if + do idxpos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist + idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(idxpos) !< feature number + idxj = this%flowbudptr%budterm(this%idxbudgwf)%id2(idxpos) !< cell number) + idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature row index + idxiglo = moffset + idxj !< cell row index + if (idxjglo == iglo) exit + end do + ! -- for connection ipos in list of feature-feature connections, + ! global positions of host-cell-row entries corresponding to + ! (in the same columns as) the feature-id1-row diagonal and the + ! feature-id1-row off-diagonal corresponding to feature id2 + this%idxfjfdglo(ipos) = matrix_sln%get_position_diag(idxiglo) + this%idxfjfoffdglo(ipos) = matrix_sln%get_position(idxiglo, jglo) end do end if end if @@ -460,14 +437,12 @@ subroutine uze_mc(this, moffset, matrix_sln) return end subroutine uze_mc + !> @brief Add matrix terms related to UZE + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for this package + !< subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! uze_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for this package -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kper, kstp ! -- dummy @@ -498,8 +473,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) do j = 1, this%flowbudptr%budterm(this%idxbudinfl)%nlist call this%uze_infl_term(j, n1, n2, rrate, rhsval, hcofval) iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index -!! iposd = this%idxpakdiag(n1) -!! call matrix_sln%add_value_pos(iposd, hcofval) ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -511,8 +484,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) do j = 1, this%flowbudptr%budterm(this%idxbudrinf)%nlist call this%uze_rinf_term(j, n1, n2, rrate, rhsval, hcofval) iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index -!! iposd = this%idxpakdiag(n1) -!! call matrix_sln%add_value_pos(iposd, hcofval) ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -524,8 +495,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) do j = 1, this%flowbudptr%budterm(this%idxbuduzet)%nlist call this%uze_uzet_term(j, n1, n2, rrate, rhsval, hcofval) iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index -!! iposd = this%idxpakdiag(n1) -!! call matrix_sln%add_value_pos(iposd, hcofval) ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -537,8 +506,6 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) do j = 1, this%flowbudptr%budterm(this%idxbudritm)%nlist call this%uze_ritm_term(j, n1, n2, rrate, rhsval, hcofval) iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index -!! iposd = this%idxpakdiag(n1) -!! call matrix_sln%add_value_pos(iposd, hcofval) ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -551,12 +518,8 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- mass (or energy) storage in features do n = 1, this%ncv cold = this%xoldpak(n) -!! iloc = this%idxlocnode(n) -!! iposd = this%idxpakdiag(n) -!! call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) -!! call matrix_sln%add_value_pos(iposd, hcofval) iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index - ipossymoffd = this%idxsymoffdglo(n) ! TO DO: convince ourselves that "n" is ok here, since it's not aloop over "j" + ipossymoffd = this%idxsymoffdglo(n) call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -566,17 +529,12 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudtmvr /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudtmvr)%nlist call this%apt_tmvr_term(j, n1, n2, rrate, rhsval, hcofval) -!! iloc = this%idxlocnode(n1) -!! iposd = this%idxpakdiag(n1) -!! -!! NOTE: originally was iposd, but changed to idxsymdglo on the first -!! modification. It was later realized we needed idxsymoffdglo. -!! (If this works, consider changing 'ipossymd' to 'ipossymoffd' -!! -!! call matrix_sln%add_value_pos(iposd, hcofval) + !NOTE: originally was iposd, but changed to idxsymdglo on the first + ! modification. It was later realized we needed idxsymoffdglo. + ! (If this works, consider changing 'ipossymd' to 'ipossymoffd' + ! iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index -!! iposd = this%idxpakdiag(n1) - ipossymoffd = this%idxsymoffdglo(j) !< TODO: Need + ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do @@ -598,23 +556,12 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) if (this%iboundpak(n) /= 0) then ! -!! ! -- set acoef and rhs to negative so they are relative to apt and not gwt -!! qbnd = this%flowbudptr%budterm(this%idxbudgwf)%flow(j) ! jiffylube: shouldn't need these 3 lines -!! omega = DZERO -!! if (qbnd < DZERO) omega = DONE -!! ! ! -- this code altered from its counterpart appearing in apt; this equates ! uze temperature to cell temperature using the feature's row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) call matrix_sln%add_value_pos(iposd, DONE) call matrix_sln%add_value_pos(iposoffd, -DONE) - ! - !! -- add to gwf row for apt connection (recharge) - !!ipossymd = this%idxsymdglo(j) - !!ipossymoffd = this%idxsymoffdglo(j) - !!call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) - !!call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) end if end do ! @@ -629,7 +576,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) else omega = DZERO end if - iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row + iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row iposoffd = this%idxfjfoffdglo(j) !< position of feature-id2 column in feature id1's host-cell row call matrix_sln%add_value_pos(iposd, omega * qbnd * this%eqnsclfac) call matrix_sln%add_value_pos(iposoffd, & @@ -641,14 +588,12 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine uze_fc_expanded - subroutine uze_solve(this) ! kluge note: no explicit solve for uze -! ****************************************************************************** -! uze_solve -- add terms specific to the unsaturated zone to the explicit -! unsaturated-zone solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> @brief Explicit solve + !! + !! There should be no explicit solve for uze. However, if there were, then + !! this subroutine would add terms specific to the unsaturated zone to the + !! explicit unsaturated-zone solve + subroutine uze_solve(this) ! -- dummy class(GweUzeType) :: this ! -- local @@ -693,14 +638,12 @@ subroutine uze_solve(this) ! kluge note: no explicit solve for uze return end subroutine uze_solve + !> @brief Return the number of UZE-specific budget terms + !! + !! Function to return the number of budget terms just for this package. + !! This overrides function in parent. + !< function uze_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! uze_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweUzeType) :: this @@ -721,14 +664,12 @@ function uze_get_nbudterms(this) result(nbudterms) return end function uze_get_nbudterms + !> @brief Setup budget object + !! + !! Set up the budget object that stores all the unsaturated-zone + !! flows + !< subroutine uze_setup_budobj(this, idx) -! ****************************************************************************** -! uze_setup_budobj -- Set up the budget object that stores all the unsaturated- -! zone flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -740,7 +681,7 @@ subroutine uze_setup_budobj(this, idx) real(DP) :: q ! ------------------------------------------------------------------------------ ! - ! -- + ! -- Infiltration text = ' INFILTRATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudinfl)%maxlist @@ -752,9 +693,8 @@ subroutine uze_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - ! - ! -- + ! -- Rejected infiltration (Hortonian flow) if (this%idxbudrinf /= 0) then text = ' REJ-INF' idx = idx + 1 @@ -768,9 +708,8 @@ subroutine uze_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- + ! -- Evapotranspiration from the unsaturated zone if (this%idxbuduzet /= 0) then text = ' UZET' idx = idx + 1 @@ -784,9 +723,8 @@ subroutine uze_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- + ! -- Rejected infiltration that is subsequently transferred by MVR if (this%idxbudritm /= 0) then text = ' INF-REJ-TO-MVR' idx = idx + 1 @@ -799,10 +737,9 @@ subroutine uze_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - end if ! - ! -- + ! -- Energy transferred to solid phase by the thermal equilibrium assumption text = ' THERMAL-EQUIL' idx = idx + 1 ! -- use dimension of GWF term @@ -815,19 +752,16 @@ subroutine uze_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - ! ! -- return return end subroutine uze_setup_budobj + !> @brief Fill UZE budget object + !! + !! Copy flow terms into this%budobj + !< subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! uze_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweUzeType) :: this @@ -845,14 +779,14 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP), dimension(:), allocatable :: budresid ! -- formats ! ----------------------------------------------------------------------------- - + ! allocate(budresid(this%ncv)) do n1 = 1, this%ncv budresid(n1) = DZERO end do - + ! indx = 0 - + ! ! -- FLOW JA FACE into budresid nlen = 0 if (this%idxbudfjf /= 0) then @@ -871,7 +805,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if end do end if - + ! ! -- GWF (LEAKAGE) into budresid indx = indx + 1 nlist = this%budobj%budterm(indx)%nlist @@ -880,17 +814,17 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) q = this%budobj%budterm(indx)%flow(j) budresid(n1) = budresid(n1) + q end do - + ! ! -- skip individual package terms indx = this%idxlastpak - + ! ! -- STORAGE into budresid indx = indx + 1 do n1 = 1, this%ncv q = this%budobj%budterm(indx)%flow(n1) budresid(n1) = budresid(n1) + q end do - + ! ! -- TO MOVER into budresid if (this%idxbudtmvr /= 0) then indx = indx + 1 @@ -901,7 +835,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) budresid(n1) = budresid(n1) + q end do end if - + ! ! -- FROM MOVER into budresid if (this%idxbudfmvr /= 0) then indx = indx + 1 @@ -912,19 +846,19 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) budresid(n1) = budresid(n1) + q end do end if - + ! ! -- CONSTANT FLOW into budresid indx = indx + 1 do n1 = 1, this%ncv q = this%budobj%budterm(indx)%flow(n1) budresid(n1) = budresid(n1) + q end do - + ! ! -- AUXILIARY VARIABLES into budresid ! -- (No flows associated with these) - + ! ! -- individual package terms processed last - + ! ! -- INFILTRATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist @@ -935,7 +869,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) budresid(n1) = budresid(n1) + q end do - + ! ! -- REJ-INF if (this%idxbudrinf /= 0) then idx = idx + 1 @@ -948,7 +882,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) budresid(n1) = budresid(n1) + q end do end if - + ! ! -- UZET if (this%idxbuduzet /= 0) then idx = idx + 1 @@ -961,7 +895,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) budresid(n1) = budresid(n1) + q end do end if - + ! ! -- REJ-INF-TO-MVR if (this%idxbudritm /= 0) then idx = idx + 1 @@ -974,7 +908,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) budresid(n1) = budresid(n1) + q end do end if - + ! ! -- THERMAL-EQUIL ! -- processed last because it is calculated from the residual idx = idx + 1 @@ -984,7 +918,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) q = - budresid(n1) -!! call this%uze_theq_term(j, n1, igwfnode, q) + call this%uze_theq_term(j, n1, igwfnode, q) call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) if (this%iboundpak(n1) /= 0) then @@ -994,20 +928,18 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) flowja(idiag) = flowja(idiag) - q end if end do - + ! deallocate(budresid) ! ! -- return return end subroutine uze_fill_budobj + !> @brief Allocate scalars + !! + !! Allocate scalars specific to UZE package + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -1036,13 +968,11 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays + !! + !! Allocate arrays used by the UZE package + !< subroutine uze_allocate_arrays(this) -! ****************************************************************************** -! uze_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -1069,13 +999,9 @@ subroutine uze_allocate_arrays(this) return end subroutine uze_allocate_arrays + !> @brief Deallocate memory + !< subroutine uze_da(this) -! ****************************************************************************** -! uze_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -1101,14 +1027,13 @@ subroutine uze_da(this) return end subroutine uze_da + !> @brief Infiltration term + !! + !! Accounts for energy added to the subsurface via infiltration, for example, + !! energy entering the model domain via rainfall or irrigation. + !< subroutine uze_infl_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uze_infl_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweUzeType) :: this integer(I4B), intent(in) :: ientry @@ -1137,8 +1062,6 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & r = -qbnd * ctmp end if if (present(rrate)) rrate = qbnd * ctmp * this%eqnsclfac -!! if (present(rhsval)) rhsval = r -!! if (present(hcofval)) hcofval = h if (present(rhsval)) rhsval = r * this%eqnsclfac if (present(hcofval)) hcofval = h * this%eqnsclfac ! @@ -1146,14 +1069,15 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & return end subroutine uze_infl_term + !> @brief Rejected infiltration term + !! + !! Accounts for energy that is added to the model from specifying an + !! infiltration rate and temperature, but is subsequently removed from + !! the model as that portion of the infiltration that is rejected (and + !! transferred to another advanced package via the MVR/MVT packages. + !< subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uze_rinf_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweUzeType) :: this integer(I4B), intent(in) :: ientry @@ -1173,21 +1097,19 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & ctmp = this%tempinfl(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO -!! if (present(hcofval)) hcofval = qbnd if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! ! -- return return end subroutine uze_rinf_term - subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & - rhsval, hcofval) -! ****************************************************************************** -! uze_uzet_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> @brief Evapotranspiration from the unsaturated-zone term + !! + !! Accounts for thermal cooling in the unsaturated zone as a result of + !! evapotranspiration from the unsaturated zone. Amount of water converted + !! to vapor phase (UZET) determined by GWF model + !< + subroutine uze_uzet_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- dummy class(GweUzeType) :: this integer(I4B), intent(in) :: ientry @@ -1215,8 +1137,6 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & if (present(rrate)) & rrate = (omega * qbnd * this%xnewpak(n1) + & (DONE - omega) * qbnd * ctmp) * this%eqnsclfac -!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp -!! if (present(hcofval)) hcofval = omega * qbnd if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * this%eqnsclfac if (present(hcofval)) hcofval = omega * qbnd * this%eqnsclfac ! @@ -1224,14 +1144,15 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, & return end subroutine uze_uzet_term + !> @brief Rejected infiltration to MVR/MVT term + !! + !! Accounts for energy that is added to the model from specifying an + !! infiltration rate and temperature, but does not infiltrate into the + !! subsurface. This subroutine is called when the rejected infiltration + !! is transferred to another advanced package via the MVR/MVT packages. + !< subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uze_ritm_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweUzeType) :: this integer(I4B), intent(in) :: ientry @@ -1258,13 +1179,12 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & return end subroutine uze_ritm_term + !> @brief Heat transferred through thermal equilibrium with the solid phase + !! + !! Accounts for the transfer of energy from the liquid phase to the solid + !! phase as a result of the instantaneous thermal equilibrium assumption. + !< subroutine uze_theq_term(this, ientry, n1, n2, rrate) -! ****************************************************************************** -! uze_theq_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -1291,12 +1211,6 @@ subroutine uze_theq_term(this, ientry, n1, n2, rrate) case ('THERMAL-EQUIL') ! skip continue -!! case ('FLOW-JA-FACE') -!! ! skip -!! continue -!! case ('GWF') -!! ! skip -!! continue case default r = r - this%budobj%budterm(i)%flow(ientry) end select @@ -1308,15 +1222,13 @@ subroutine uze_theq_term(this, ientry, n1, n2, rrate) return end subroutine uze_theq_term + !> @brief Define UZE Observation + !! + !! This subroutine: + !! - Stores observation types supported by the parent APT package. + !! - Overrides BndType%bnd_df_obs + !< subroutine uze_df_obs(this) -! ****************************************************************************** -! uze_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweUzeType) :: this @@ -1387,9 +1299,9 @@ subroutine uze_df_obs(this) end subroutine uze_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. + !! !< subroutine uze_rp_obs(this, obsrv, found) ! -- dummy @@ -1417,13 +1329,9 @@ subroutine uze_rp_obs(this, obsrv, found) return end subroutine uze_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine uze_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! uze_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweUzeType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -1463,13 +1371,9 @@ subroutine uze_bd_obs(this, obstypeid, jj, v, found) return end subroutine uze_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine uze_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! uze_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GweUzeType), intent(inout) :: this From 34036eee51183890eedbdd995359679a13f261c1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 15:24:30 -0700 Subject: [PATCH 151/212] gwe1lke1.f90 doxygen compliance. A few touch-ups in gwe1sfe1.f90 --- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 217 ++++++++--------------- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 39 ++-- 2 files changed, 96 insertions(+), 160 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index 9b7728886d5..4e0756d2ffb 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -97,14 +97,10 @@ module GweLkeModule contains + !> @brief Create a new lke package + !< subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac, gwecommon) -! ****************************************************************************** -! mwt_create -- Create a New MWT Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -163,13 +159,9 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & return end subroutine lke_create - subroutine find_lke_package(this) -! ****************************************************************************** -! find corresponding lkt package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> @brief Find corresponding lke package + !< + subroutine find_lke_package(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -291,14 +283,13 @@ subroutine find_lke_package(this) return end subroutine find_lke_package + !> @brief Add matrix terms related to LKE + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for LKE + !! + !< subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! lke_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for LKT -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweLkeType) :: this @@ -419,13 +410,9 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine lke_fc_expanded + !> @ brief Add terms specific to lakes to the explicit lake solve + !< subroutine lke_solve(this) -! ****************************************************************************** -! lke_solve -- add terms specific to lakes to the explicit lake solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this ! -- local @@ -486,14 +473,11 @@ subroutine lke_solve(this) return end subroutine lke_solve + !> @brief Function to return the number of budget terms just for this package. + !! + !! This overrides a function in the parent class. + !< function lke_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! lke_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweLkeType) :: this @@ -503,8 +487,13 @@ function lke_get_nbudterms(this) result(nbudterms) ! ------------------------------------------------------------------------------ ! ! -- Number of budget terms is 7 - ! 1) rainfall; 2) evap; 3) runoff; 4) ext-inflow; 5) withdrawl; - ! 6) ext-outflow; 7) lakebed-cond + ! 1) rainfall + ! 2) evap + ! 3) runoff + ! 4) ext-inflow + ! 5) withdrawl + ! 6) ext-outflow + ! 7) lakebed-cond ! nbudterms = 7 ! @@ -512,13 +501,9 @@ function lke_get_nbudterms(this) result(nbudterms) return end function lke_get_nbudterms + !> @brief Set up the budget object that stores all the lake flows + !< subroutine lke_setup_budobj(this, idx) -! ****************************************************************************** -! lke_setup_budobj -- Set up the budget object that stores all the lake flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -531,7 +516,7 @@ subroutine lke_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- Addition of heat associated with rainfall text = ' RAINFALL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist @@ -544,7 +529,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Evaporative cooling from lake surface text = ' EVAPORATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist @@ -557,7 +542,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Addition of heat associated with runoff added to the lake text = ' RUNOFF' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist @@ -570,7 +555,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Addition of heat associated with user-specified inflow to the lake text = ' EXT-INFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist @@ -583,7 +568,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Removal of heat associated with user-specified withdrawal from lake text = ' WITHDRAWAL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudwdrl)%maxlist @@ -596,7 +581,8 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Removal of heat associated with outflow from lake that leaves + ! model domain text = ' EXT-OUTFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist @@ -609,7 +595,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- conduction through the wetted lakebed + ! -- Conductive exchange of heat through the wetted lakebed text = ' LAKEBED-COND' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudlbcd)%maxlist @@ -748,13 +734,10 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) return end subroutine lke_fill_budobj + !> @brief Allocate scalars specific to the lake energy transport (LKE) + !! package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -787,13 +770,10 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays specific to the lake energy transport (LKE) + !! package. + !< subroutine lke_allocate_arrays(this) -! ****************************************************************************** -! lke_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -824,13 +804,9 @@ subroutine lke_allocate_arrays(this) return end subroutine lke_allocate_arrays + !> @brief Deallocate + !< subroutine lke_da(this) -! ****************************************************************************** -! lke_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -860,14 +836,10 @@ subroutine lke_da(this) return end subroutine lke_da + !> @brief Rain term + !< subroutine lke_rain_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lke_rain_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this integer(I4B), intent(in) :: ientry @@ -892,14 +864,10 @@ subroutine lke_rain_term(this, ientry, n1, n2, rrate, & return end subroutine lke_rain_term + !> @brief Evaporative term + !< subroutine lke_evap_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lke_evap_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this integer(I4B), intent(in) :: ientry @@ -910,27 +878,14 @@ subroutine lke_evap_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval ! -- local real(DP) :: qbnd -!! real(DP) :: ctmp -!! real(DP) :: omega real(DP) :: heatlat ! ------------------------------------------------------------------------------ n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry) ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) -!! ctmp = this%tempevap(n1) -!! if (this%xnewpak(n1) < ctmp) then -!! omega = DONE -!! else -!! omega = DZERO -!! end if -!! if (present(rrate)) & -!! rrate = omega * qbnd * this%xnewpak(n1) + & -!! (DONE - omega) * qbnd * ctmp -!! if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp -!! if (present(hcofval)) hcofval = omega * qbnd - heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap ! kg/m^3 * J/kg = J/m^3 (kluge note) - if (present(rrate)) rrate = qbnd * heatlat !m^3/day * J/m^3 = J/day (kluge note) + heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap + if (present(rrate)) rrate = qbnd * heatlat if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! @@ -938,14 +893,10 @@ subroutine lke_evap_term(this, ientry, n1, n2, rrate, & return end subroutine lke_evap_term + !> @brief Runoff term + !< subroutine lke_roff_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lke_roff_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this integer(I4B), intent(in) :: ientry @@ -970,14 +921,13 @@ subroutine lke_roff_term(this, ientry, n1, n2, rrate, & return end subroutine lke_roff_term + !> @brief Inflow Term + !! + !! Accounts for energy flowing into a lake from a connected stream, for + !! example. + !< subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lke_iflw_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this integer(I4B), intent(in) :: ientry @@ -1002,14 +952,13 @@ subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & return end subroutine lke_iflw_term + !> @brief Specified withdrawal term + !! + !! Accounts for energy associated with energy removed when water is withdrawn + !! from a lake or group of lakes. + !< subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lke_wdrl_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this integer(I4B), intent(in) :: ientry @@ -1034,14 +983,13 @@ subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & return end subroutine lke_wdrl_term + !> @brief Outflow term + !! + !! Accounts for the energy leaving a lake, for example, energy exiting a + !! lake via a flow in a stream channel. + !< subroutine lke_outf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lke_outf_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType) :: this integer(I4B), intent(in) :: ientry @@ -1066,15 +1014,12 @@ subroutine lke_outf_term(this, ientry, n1, n2, rrate, & return end subroutine lke_outf_term + !> @brief Defined observation types + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !< subroutine lke_df_obs(this) -! ****************************************************************************** -! lke_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweLkeType) :: this @@ -1151,9 +1096,9 @@ subroutine lke_df_obs(this) end subroutine lke_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. + !! !< subroutine lke_rp_obs(this, obsrv, found) ! -- dummy @@ -1186,13 +1131,9 @@ subroutine lke_rp_obs(this, obsrv, found) return end subroutine lke_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine lke_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! lke_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweLkeType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -1236,13 +1177,9 @@ subroutine lke_bd_obs(this, obstypeid, jj, v, found) return end subroutine lke_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine lke_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! lke_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GweLkeType), intent(inout) :: this diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 0fcaf5ebb89..e4142047b7a 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -282,10 +282,10 @@ subroutine find_sfe_package(this) end subroutine find_sfe_package !> @brief Add matrix terms related to SFE - !! - !! This will be called from TspAptType%apt_fc_expanded() - !! in order to add matrix terms specifically for SFE - !! + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for SFE + !! !< subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- modules @@ -455,10 +455,9 @@ subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/ end subroutine sfe_solve !> @brief Function to return the number of budget terms just for this package. - !! - !! This overrides function in parent. - !! - !< + !! + !! This overrides a function in the parent class. + !< function sfe_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy @@ -876,9 +875,9 @@ end subroutine sfe_roff_term !> @brief Inflow Term !! - !! Accounts for energy added externally, for example, energy entering the - !! model domain via a specified flow in a stream channel. - !! + !! Accounts for energy added via streamflow entering into a stream channel; + !! for example, energy entering the model domain via a specified flow in a + !! stream channel. !< subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- dummy @@ -907,8 +906,8 @@ end subroutine sfe_iflw_term !> @brief Outflow term !! - !! Accounts for the energy leaving the model, for example, energy exiting the - !! model domain via a flow in a stream channel. + !! Accounts for the energy leaving a stream channel, for example, energy exiting the + !! model domain via a flow in a stream channel flowing out of the active domain. !< subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- dummy @@ -936,10 +935,10 @@ subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) end subroutine sfe_outf_term !> @brief Observations - !! - !! Store the observation type supported by the APT package and overide - !! BndType%bnd_df_obs - !! + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !! !< subroutine sfe_df_obs(this) ! -- modules @@ -1013,9 +1012,9 @@ subroutine sfe_df_obs(this) end subroutine sfe_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. + !! !< subroutine sfe_rp_obs(this, obsrv, found) ! -- dummy From 219e66ec198375d3372b3015f5f6b3e2db47755a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 17:45:57 -0700 Subject: [PATCH 152/212] gwe1mst1.f90 doxygen compliance (was mostly already done) --- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 62 +++--------------------- 1 file changed, 8 insertions(+), 54 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 22d82ea06ff..d5b8f1b7d29 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -81,10 +81,9 @@ module GweMstModule contains - !> @ brief Create a new package object - !! - !! Create a new MST object + !> @ brief Create a new MST object !! + !! Create a new MST package !< subroutine mst_cr(mstobj, name_model, inunit, iout, fmi, eqnsclfac, gwecommon) ! -- dummy @@ -122,7 +121,6 @@ end subroutine mst_cr !> @ brief Allocate and read method for package !! !! Method to allocate and read static data for the package. - !! !< subroutine mst_ar(this, dis, ibound) ! -- modules @@ -172,7 +170,6 @@ end subroutine mst_ar !> @ brief Fill coefficient method for package !! !! Method to calculate and fill coefficients for the package. - !! !< subroutine mst_fc(this, nodes, cold, nja, matrix_sln, idxglo, cnew, & rhs, kiter) @@ -205,7 +202,6 @@ end subroutine mst_fc !> @ brief Fill storage coefficient method for package !! !! Method to calculate and fill storage coefficients for the package. - !! !< subroutine mst_fc_sto(this, nodes, cold, nja, matrix_sln, idxglo, rhs) ! -- modules @@ -242,9 +238,6 @@ subroutine mst_fc_sto(this, nodes, cold, nja, matrix_sln, idxglo, rhs) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- add terms to diagonal and rhs accumulators -!! term = vsolid * (this%rhos(n) * this%cps(n)) / this%eqnsclfac -!! hhcof = -(vnew + term) * tled -!! rrhs = -(vold + term) * tled * cold(n) term = (this%rhos(n) * this%cps(n)) * vsolid hhcof = -(this%eqnsclfac * vnew + term) * tled rrhs = -(this%eqnsclfac * vold + term) * tled * cold(n) @@ -260,7 +253,6 @@ end subroutine mst_fc_sto !> @ brief Fill decay coefficient method for package !! !! Method to calculate and fill decay coefficients for the package. - !! !< subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & idxglo, rhs, kiter) @@ -299,9 +291,8 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & ! ! -- first order decay rate is a function of temperature, so add ! kluge note: do we need/want first-order decay for temperature??? ! to left hand side -!! hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) ! kluge note: this term should NOT be divided by eqnsclfac for fc purposes because rhow*cpw is already effectively divided out - hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) & - * this%eqnsclfac + hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) & + * this%eqnsclfac call matrix_sln%add_value_pos(idxglo(idiag), hhcof) elseif (this%idcy == 2) then ! @@ -309,7 +300,8 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & ! from the user-specified rate to prevent negative temperatures ! kluge note: think through negative temps decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & kiter, cold(n), cnew(n), delt) -!! decay_rate = decay_rate / this%eqnsclfac ! kluge note: this term does get divided by eqnsclfac for fc purposes because it should start out being a rate of energy + ! -- This term does get divided by eqnsclfac for fc purposes because it + ! should start out being a rate of energy this%decaylast(n) = decay_rate rrhs = decay_rate * vcell * swtpdt * this%porosity(n) rhs(n) = rhs(n) + rrhs @@ -324,7 +316,6 @@ end subroutine mst_fc_dcy !> @ brief Calculate flows for package !! !! Method to calculate flows for the package. - !! !< subroutine mst_cq(this, nodes, cnew, cold, flowja) ! -- modules @@ -351,7 +342,6 @@ end subroutine mst_cq !> @ brief Calculate storage terms for package !! !! Method to calculate storage terms for the package. - !! !< subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) ! -- modules @@ -389,10 +379,6 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate -!! term = vsolid * (this%rhos(n) * this%cps(n)) / this%eqnsclfac -!! hhcof = -(vwatnew + term) * tled -!! rrhs = -(vwatold + term) * tled * cold(n) -!! rate = (hhcof * cnew(n) - rrhs) * this%eqnsclfac term = (this%rhos(n) * this%cps(n)) * vsolid hhcof = -(this%eqnsclfac * vwatnew + term) * tled rrhs = -(this%eqnsclfac * vwatold + term) * tled * cold(n) @@ -409,7 +395,6 @@ end subroutine mst_cq_sto !> @ brief Calculate decay terms for package !! !! Method to calculate decay terms for the package. - !! !< subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) ! kluge note: this handles only decay in water; need to add zero-order (but not first-order?) decay in solid ! -- modules @@ -467,7 +452,6 @@ end subroutine mst_cq_dcy !> @ brief Calculate budget terms for package !! !! Method to calculate budget terms for the package. - !! !< subroutine mst_bd(this, isuppress_output, model_budget) ! -- modules @@ -501,7 +485,6 @@ end subroutine mst_bd !> @ brief Output flow terms for package !! !! Method to output terms for the package. - !! !< subroutine mst_ot_flow(this, icbcfl, icbcun) ! -- dummy @@ -549,7 +532,6 @@ end subroutine mst_ot_flow !> @ brief Deallocate !! !! Method to deallocate memory for the package. - !! !< subroutine mst_da(this) ! -- modules @@ -587,7 +569,6 @@ end subroutine mst_da !> @ brief Allocate scalar variables for package !! !! Method to allocate scalar variables for the package. - !! !< subroutine allocate_scalars(this) ! -- modules @@ -620,7 +601,6 @@ end subroutine allocate_scalars !> @ brief Allocate arrays for package !! !! Method to allocate arrays for the package. - !! !< subroutine allocate_arrays(this, nodes) ! -- modules @@ -670,7 +650,6 @@ end subroutine allocate_arrays !> @ brief Read options for package !! !! Method to read options for the package. - !! !< subroutine read_options(this) ! -- modules @@ -733,7 +712,6 @@ end subroutine read_options !> @ brief Read data for package !! !! Method to read data for the package. - !! !< subroutine read_data(this) ! -- modules @@ -850,7 +828,6 @@ end subroutine read_data !> @ brief Read data for package !! !! Method to read data for the package. - !! !< subroutine read_packagedata(this) ! -- modules @@ -879,41 +856,18 @@ subroutine read_packagedata(this) this%rhow = this%parser%GetDouble() end do end if - ! - ! -- Check for latent heat of vaporization. May be used by multiple packages - ! wherever evaporation occurs, is specified in mst instead of in multiple - ! GWE packages that simulate evaporation (SFE, LKE, UZE) - !if (this%ilhv > 0) then - ! if (.not. lname(7)) then - ! write (errmsg, '(a)') 'EVAPORATION IS EXPECTED IN A GWE PACKAGE & - ! &BUT THE LATENT HEAT OF VAPORIZATION IS NOT SPECIFIED. LATHEATVAP & - ! &MUST BE SPECIFIED IN GRIDDATA BLOCK.' - ! call store_error(errmsg) - ! end if - !else - ! if (lname(7)) then - ! write (warnmsg, '(a)') 'LATENT HEAT OF VAPORIZATION FOR CALCULATING & - ! &EVAPORATION IS SPECIFIED, BUT CORRESPONDING OPTION NOT SET IN & - ! &OPTIONS BLOCK. EVAPORATION CALCULATIONS WILL STILL USE LATHEATVAP & - ! &SPECIFIED IN GWE MST PACKAGE.' - ! call store_warning(warnmsg) - ! write (this%iout, '(1x,a)') 'WARNING. '//warnmsg - ! end if - !end if - ! ! -- Return return end subroutine read_packagedata - !> @ brief Calculate zero-order decay rate and constrain if necessary !! !! Function to calculate the zero-order decay rate from the user specified !! decay rate. If the decay rate is positive, then the decay rate must !! be constrained so that more energy is not removed than is available. - !! Without this constraint, negative temperatures could result from ! kluge note: modified wording from mass/conc but need to think this through (no freezing) - !! zero-order decay. + !! Without this constraint, negative temperatures could result from + !! zero-order decay (no freezing). !< function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & cold, cnew, delt) result(decay_rate) From e1f93f1453c2bf68f750817a7b7781b02a1fbab6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 20:47:34 -0700 Subject: [PATCH 153/212] gwe1dsp1.f90 doxygen compliance --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 210 ++++++++--------------- 1 file changed, 72 insertions(+), 138 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 1936a470209..eb9517b3f1d 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -21,8 +21,6 @@ module GweDspModule type(TspFmiType), pointer :: fmi => null() ! pointer to GWE fmi object type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst real(DP), dimension(:), pointer, contiguous :: porosity => null() ! pointer to GWE storage porosity - ! TODO: Can remove diffc from GWE - !real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity real(DP), dimension(:), pointer, contiguous :: alv => null() ! longitudinal vertical dispersivity real(DP), dimension(:), pointer, contiguous :: ath1 => null() ! transverse horizontal dispersivity @@ -30,7 +28,6 @@ module GweDspModule real(DP), dimension(:), pointer, contiguous :: atv => null() ! transverse vertical dispersivity real(DP), dimension(:), pointer, contiguous :: ktw => null() ! thermal conductivity of water real(DP), dimension(:), pointer, contiguous :: kts => null() ! thermal conductivity of aquifer material - !integer(I4B), pointer :: idiffc => null() ! flag indicating diffusion is active integer(I4B), pointer :: idisp => null() ! flag indicating mechanical dispersion is active integer(I4B), pointer :: ialh => null() ! longitudinal horizontal dispersivity data flag integer(I4B), pointer :: ialv => null() ! longitudinal vertical dispersivity data flag @@ -80,14 +77,12 @@ module GweDspModule contains + !> @brief Create a new DSP object + !! + !! Create a new MST package + !< subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi, & eqnsclfac, gwecommon) -! ****************************************************************************** -! dsp_cr -- Create a new DSP object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use KindModule, only: LGP use MemoryManagerExtModule, only: mem_set_value @@ -141,13 +136,11 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi, & return end subroutine dsp_cr + !> @brief Define MST object + !! + !! Define the MST package + !< subroutine dsp_df(this, dis, dspOptions) -! ****************************************************************************** -! dsp_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweDspType) :: this @@ -192,9 +185,13 @@ subroutine dsp_df(this, dis, dspOptions) return end subroutine dsp_df + !> @brief Add connections to DSP + !! + !! Add connections for extended neighbors to the sparse matrix + !< subroutine dsp_ac(this, moffset, sparse) ! ****************************************************************************** -! dsp_ac -- Add connections for extended neighbors to the sparse matrix +! dsp_ac -- ! ****************************************************************************** ! ! SPECIFICATIONS: @@ -216,13 +213,11 @@ subroutine dsp_ac(this, moffset, sparse) return end subroutine dsp_ac + !> @brief Map DSP connections + !! + !! Map connections and construct iax, jax, and idxglox + !< subroutine dsp_mc(this, moffset, matrix_sln) -! ****************************************************************************** -! dsp_mc -- Map connections and construct iax, jax, and idxglox -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -239,13 +234,11 @@ subroutine dsp_mc(this, moffset, matrix_sln) return end subroutine dsp_mc + !> @brief Allocate and read method for package + !! + !! Method to allocate and read static data for the package. + !< subroutine dsp_ar(this, ibound, porosity) -! ****************************************************************************** -! dsp_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweDspType) :: this @@ -266,13 +259,9 @@ subroutine dsp_ar(this, ibound, porosity) return end subroutine dsp_ar + !> @brief Advance method for the package + !< subroutine dsp_ad(this) -! ****************************************************************************** -! dsp_ad -- Advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper ! -- dummy @@ -308,13 +297,11 @@ subroutine dsp_ad(this) return end subroutine dsp_ad + !> @brief Fill coefficient method for package + !! + !! Method to calculate and fill coefficients for the package. + !< subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) -! ****************************************************************************** -! dsp_fc -- Calculate coefficients and fill amat and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweDspType) :: this @@ -361,13 +348,11 @@ subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) return end subroutine dsp_fc + !> @ brief Calculate flows for package + !! + !! Method to calculate dispersion contribution to flowja + !< subroutine dsp_cq(this, cnew, flowja) -! ****************************************************************************** -! dsp_cq -- Calculate dispersion contribution to flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweDspType) :: this @@ -400,13 +385,11 @@ subroutine dsp_cq(this, cnew, flowja) return end subroutine dsp_cq - subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> @ brief Allocate scalar variables for package + !! + !! Method to allocate scalar variables for the package. + !< + subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -419,7 +402,6 @@ subroutine allocate_scalars(this) call this%NumericalPackageType%allocate_scalars() ! ! -- Allocate - !call mem_allocate(this%idiffc, 'IDIFFC', this%memoryPath) call mem_allocate(this%idisp, 'IDISP', this%memoryPath) call mem_allocate(this%ialh, 'IALH', this%memoryPath) call mem_allocate(this%ialv, 'IALV', this%memoryPath) @@ -438,7 +420,6 @@ subroutine allocate_scalars(this) call mem_allocate(this%ikts, 'IKTS', this%memoryPath) ! ! -- Initialize - !this%idiffc = 0 this%idisp = 0 this%ialh = 0 this%ialv = 0 @@ -458,15 +439,13 @@ subroutine allocate_scalars(this) ! ! -- Return return - end subroutine allocate_scalars + end subroutine allocate_scalars + !> @ brief Allocate arrays for package + !! + !! Method to allocate arrays for the package. + !< subroutine allocate_arrays(this, nodes) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -482,7 +461,6 @@ subroutine allocate_arrays(this, nodes) call mem_allocate(this%ath1, nodes, 'ATH1', trim(this%memoryPath)) call mem_allocate(this%ath2, nodes, 'ATH2', trim(this%memoryPath)) call mem_allocate(this%atv, nodes, 'ATV', trim(this%memoryPath)) - !call mem_allocate(this%diffc, nodes, 'DIFFC', trim(this%memoryPath)) call mem_allocate(this%d11, nodes, 'D11', trim(this%memoryPath)) call mem_allocate(this%d22, nodes, 'D22', trim(this%memoryPath)) call mem_allocate(this%d33, nodes, 'D33', trim(this%memoryPath)) @@ -504,13 +482,11 @@ subroutine allocate_arrays(this, nodes) return end subroutine allocate_arrays + !> @ brief Deallocate + !! + !! Method to deallocate memory for the package. + !< subroutine dsp_da(this) -! ****************************************************************************** -! dsp_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate use MemoryManagerExtModule, only: memorylist_remove @@ -530,7 +506,6 @@ subroutine dsp_da(this) call mem_deallocate(this%ath1) call mem_deallocate(this%ath2, 'ATH2', trim(this%memoryPath)) call mem_deallocate(this%atv, 'ATV', trim(this%memoryPath)) - !call mem_deallocate(this%diffc) call mem_deallocate(this%d11) call mem_deallocate(this%d22) call mem_deallocate(this%d33) @@ -548,7 +523,6 @@ subroutine dsp_da(this) nullify (this%gwecommon) ! ! -- deallocate scalars - !call mem_deallocate(this%idiffc) call mem_deallocate(this%idisp) call mem_deallocate(this%ialh) call mem_deallocate(this%ialv) @@ -579,20 +553,16 @@ subroutine log_options(this, found) use GweDspInputModule, only: GweDspParamFoundType class(GweDspType) :: this type(GweDspParamFoundType), intent(in) :: found - + ! write (this%iout, '(1x,a)') 'Setting DSP Options' write (this%iout, '(4x,a,i0)') 'XT3D formulation [0=INACTIVE, 1=ACTIVE, & &3=ACTIVE RHS] set to: ', this%ixt3d write (this%iout, '(1x,a,/)') 'End Setting DSP Options' end subroutine log_options + !> @brief Update simulation mempath options + !< subroutine source_options(this) -! ****************************************************************************** -! source_options -- update simulation mempath options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules !use KindModule, only: LGP use MemoryManagerExtModule, only: mem_set_value @@ -628,52 +598,45 @@ subroutine log_griddata(this, found) use GweDspInputModule, only: GweDspParamFoundType class(GweDspType) :: this type(GweDspParamFoundType), intent(in) :: found - + ! write (this%iout, '(1x,a)') 'Setting DSP Griddata' - - !if (found%diffc) then - ! write (this%iout, '(4x,a)') 'DIFFC set from input file' - !end if - + ! if (found%alh) then write (this%iout, '(4x,a)') 'ALH set from input file' end if - + ! if (found%alv) then write (this%iout, '(4x,a)') 'ALV set from input file' end if - + ! if (found%ath1) then write (this%iout, '(4x,a)') 'ATH1 set from input file' end if - + ! if (found%ath2) then write (this%iout, '(4x,a)') 'ATH2 set from input file' end if - + ! if (found%atv) then write (this%iout, '(4x,a)') 'ATV set from input file' end if - + ! if (found%ktw) then write (this%iout, '(4x,a)') 'KTW set from input file' end if - + ! if (found%kts) then write (this%iout, '(4x,a)') 'KTS set from input file' end if - + ! write (this%iout, '(1x,a,/)') 'End Setting DSP Griddata' - + ! + ! -- Return + return end subroutine log_griddata + !> @brief Update DSP simulation data from input mempath subroutine source_griddata(this) -! ****************************************************************************** -! source_griddata -- update dsp simulation data from input mempath -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error use MemoryManagerModule, only: mem_reallocate, mem_reassignptr @@ -694,7 +657,6 @@ subroutine source_griddata(this) if (this%dis%nodes < this%dis%nodesuser) map => this%dis%nodeuser ! ! -- update defaults with idm sourced values - !call mem_set_value(this%diffc, 'DIFFC', input_mempath, map, found%diffc) call mem_set_value(this%alh, 'ALH', this%input_mempath, map, found%alh) call mem_set_value(this%alv, 'ALV', this%input_mempath, map, found%alv) call mem_set_value(this%ath1, 'ATH1', this%input_mempath, map, found%ath1) @@ -704,7 +666,6 @@ subroutine source_griddata(this) call mem_set_value(this%kts, 'KTS', this%input_mempath, map, found%kts) ! ! -- set active flags - !if (found%diffc) this%idiffc = 1 if (found%alh) this%ialh = 1 if (found%alv) this%ialv = 1 if (found%ath1) this%iath1 = 1 @@ -713,11 +674,6 @@ subroutine source_griddata(this) if (found%ktw) this%iktw = 1 if (found%kts) this%ikts = 1 ! - ! -- reallocate diffc if not found - !if (.not. found%diffc) then - ! call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) - !end if - ! ! -- set this%idisp flag if (found%alh) this%idisp = this%idisp + 1 if (found%alv) this%idisp = this%idisp + 1 @@ -760,13 +716,8 @@ subroutine source_griddata(this) return end subroutine source_griddata + !> @brief Calculate dispersion coefficients subroutine calcdispellipse(this) -! ****************************************************************************** -! calcdispellipse -- Calculate dispersion coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweDspType) :: this @@ -776,7 +727,6 @@ subroutine calcdispellipse(this) real(DP) :: alh, alv, ath1, ath2, atv, a real(DP) :: al, at1, at2 real(DP) :: qzoqsquared -!! real(DP) :: dstar real(DP) :: ktbulk ! TODO: Implement additional options for characterizing ktbulk (see Markle refs) real(DP) :: qsw ! ------------------------------------------------------------------------------ @@ -820,21 +770,18 @@ subroutine calcdispellipse(this) end if ! ! -- calculate -!! dstar = DZERO - !if (this%idiffc > 0) then - ! dstar = this%diffc(n) * this%porosity(n) - !end if ktbulk = DZERO if (this%iktw > 0) ktbulk = ktbulk + this%porosity(n) * this%ktw(n) * & this%fmi%gwfsat(n) if (this%ikts > 0) ktbulk = ktbulk + (DONE - this%porosity(n)) * this%kts(n) -!! ! -- The division by rhow*cpw below is done to render dstar in the form -!! ! -- of a thermal diffusivity, and not because the governing equation -!! ! -- is scaled by rhow*cpw. Because of this conceptual distinction, -!! ! -- ktbulk is divided by the explicitly calculated product rhow*cpw, -!! ! -- and not by the equivalent scale factor eqnsclfac, even though it -!! ! -- should make no practical difference in the result. -!! dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) ! kluge note eqnsclfac, define product + ! + ! -- The division by rhow*cpw below is done to render dstar in the form + ! of a thermal diffusivity, and not because the governing equation + ! is scaled by rhow*cpw. Because of this conceptual distinction, + ! ktbulk is divided by the explicitly calculated product rhow*cpw, + ! and not by the equivalent scale factor eqnsclfac, even though it + ! should make no practical difference in the result. + dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) ! kluge note eqnsclfac, define product ! ! -- Calculate the longitudal and transverse dispersivities al = DZERO @@ -848,10 +795,6 @@ subroutine calcdispellipse(this) end if ! ! -- Calculate and save the diagonal components of the dispersion tensor -!! qsw = q * this%fmi%gwfsat(n) -!! this%d11(n) = al * qsw + dstar -!! this%d22(n) = at1 * qsw + dstar -!! this%d33(n) = at2 * qsw + dstar qsw = q * this%fmi%gwfsat(n) * this%eqnsclfac this%d11(n) = al * qsw + ktbulk this%d22(n) = at1 * qsw + ktbulk @@ -859,11 +802,6 @@ subroutine calcdispellipse(this) ! ! -- Angles of rotation if velocity based dispersion tensor if (this%idisp > 0) then - ! - ! -- angles of rotation from model coordinates to direction of velocity - ! qx / q = cos(a1) * cos(a2) - ! qy / q = sin(a1) * cos(a2) - ! qz / q = sin(a2) ! ! -- angle3 is zero this%angle3(n) = DZERO @@ -897,13 +835,9 @@ subroutine calcdispellipse(this) return end subroutine calcdispellipse + !> @brief Calculate dispersion coefficients + !< subroutine calcdispcoef(this) -! ****************************************************************************** -! calcdispcoef -- Calculate dispersion coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use GwfNpfModule, only: hyeff_calc ! -- dummy From 8e07188fa9f5164e4ba475786cdda88534d6b060 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 2 Jun 2023 20:48:21 -0700 Subject: [PATCH 154/212] tsp1adv1.f90 doxygen compliance --- src/Model/TransportModel/tsp1adv1.f90 | 116 +++++++++++--------------- 1 file changed, 48 insertions(+), 68 deletions(-) diff --git a/src/Model/TransportModel/tsp1adv1.f90 b/src/Model/TransportModel/tsp1adv1.f90 index 50aaac620d0..5e3b1e5ca8c 100644 --- a/src/Model/TransportModel/tsp1adv1.f90 +++ b/src/Model/TransportModel/tsp1adv1.f90 @@ -41,13 +41,11 @@ module TspAdvModule contains + !> @ brief Create a new ADV object + !! + !! Create a new ADV package + !< subroutine adv_cr(advobj, name_model, inunit, iout, fmi, eqnsclfac) -! ****************************************************************************** -! adv_cr -- Create a new ADV object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(TspAdvType), pointer :: advobj character(len=*), intent(in) :: name_model @@ -76,13 +74,19 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi, eqnsclfac) return end subroutine adv_cr + !> @brief Define ADV object + !! + !! Define the ADV package + !< subroutine adv_df(this, adv_options) + ! -- dummy class(TspAdvType) :: this type(TspAdvOptionsType), optional, intent(in) :: adv_options !< the optional options, for when not constructing from file - ! local + ! -- local character(len=*), parameter :: fmtadv = & "(1x,/1x,'ADV-- ADVECTION PACKAGE, VERSION 1, 8/25/2017', & &' INPUT READ FROM UNIT ', i0, //)" +! ------------------------------------------------------------------------------ ! ! -- Read or set advection options if (.not. present(adv_options)) then @@ -101,16 +105,16 @@ subroutine adv_df(this, adv_options) ! --set options from input arg this%iadvwt = adv_options%iAdvScheme end if - + ! + ! -- Return + return end subroutine adv_df + !> @brief Allocate and read method for package + !! + !! Method to allocate and read static data for the ADV package. + !< subroutine adv_ar(this, dis, ibound, cpw, rhow) -! ****************************************************************************** -! adv_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAdvType) :: this @@ -134,13 +138,11 @@ subroutine adv_ar(this, dis, ibound, cpw, rhow) return end subroutine adv_ar + !> @brief Fill coefficient method for ADV package + !! + !! Method to calculate coefficients and fill amat and rhs. + !< subroutine adv_fc(this, nodes, matrix_sln, idxglo, cnew, rhs) -! ****************************************************************************** -! adv_fc -- Calculate coefficients and fill amat and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAdvType) :: this @@ -183,13 +185,12 @@ subroutine adv_fc(this, nodes, matrix_sln, idxglo, cnew, rhs) return end subroutine adv_fc + !> @brief Calculate TVD + !! + !! Use explicit scheme to calculate the advective component of transport. + !! TVD is an acronym for Total-Variation Diminishing + !< subroutine advtvd(this, n, cnew, rhs) -! ****************************************************************************** -! advtvd -- Calculate TVD -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAdvType) :: this @@ -216,13 +217,12 @@ subroutine advtvd(this, n, cnew, rhs) return end subroutine advtvd + !> @brief Calculate TVD + !! + !! Use explicit scheme to calculate the advective component of transport. + !! TVD is an acronym for Total-Variation Diminishing + !< function advqtvd(this, n, m, iposnm, cnew) result(qtvd) -! ****************************************************************************** -! advqtvd -- Calculate TVD -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: DPREC ! -- return @@ -289,13 +289,9 @@ function advqtvd(this, n, m, iposnm, cnew) result(qtvd) return end function advqtvd + !> @brief Calculate advection contribution to flowja + !< subroutine adv_cq(this, cnew, flowja) -! ****************************************************************************** -! adv_cq -- Calculate advection contribution to flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAdvType) :: this @@ -330,13 +326,8 @@ subroutine adv_cq(this, cnew, flowja) return end subroutine adv_cq + !> @brief Add TVD contribution to flowja subroutine advtvd_bd(this, cnew, flowja) -! ****************************************************************************** -! advtvd_bd -- Add TVD contribution to flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAdvType) :: this @@ -364,13 +355,9 @@ subroutine advtvd_bd(this, cnew, flowja) return end subroutine advtvd_bd + !> @brief Deallocate memory + !< subroutine adv_da(this) -! ****************************************************************************** -! adv_da -- Deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -396,13 +383,10 @@ subroutine adv_da(this) return end subroutine adv_da + !> @brief Allocate scalars specific to the streamflow energy transport (SFE) + !! package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy @@ -426,13 +410,11 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Read options + !! + !! Read the options block + !< subroutine read_options(this) -! ****************************************************************************** -! read_options -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error @@ -493,13 +475,11 @@ subroutine read_options(this) return end subroutine read_options + !> @ brief Advection weight + !! + !! Calculate the advection weight + !< function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) -! ****************************************************************************** -! adv_weight -- calculate advection weight -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- return real(DP) :: omega ! -- dummy From b8bef9678d5ac4487b3226f1cd3e2898fb746af0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 08:18:37 -0700 Subject: [PATCH 155/212] tsp1.f90 doxygen compliance. Touch-up in gwe1dsp1.f90 --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 5 +- src/Model/TransportModel/tsp1.f90 | 343 +++++++---------------- 2 files changed, 107 insertions(+), 241 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index eb9517b3f1d..75030a73456 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -636,6 +636,7 @@ subroutine log_griddata(this, found) end subroutine log_griddata !> @brief Update DSP simulation data from input mempath + !< subroutine source_griddata(this) ! -- modules use SimModule, only: count_errors, store_error @@ -714,9 +715,10 @@ subroutine source_griddata(this) ! ! -- Return return - end subroutine source_griddata + end subroutine source_griddata !> @brief Calculate dispersion coefficients + !< subroutine calcdispellipse(this) ! -- modules ! -- dummy @@ -728,6 +730,7 @@ subroutine calcdispellipse(this) real(DP) :: al, at1, at2 real(DP) :: qzoqsquared real(DP) :: ktbulk ! TODO: Implement additional options for characterizing ktbulk (see Markle refs) + real(DP) :: dstar real(DP) :: qsw ! ------------------------------------------------------------------------------ ! diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 0101c60c3e8..746e782ddb3 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -56,8 +56,6 @@ module TransportModelModule integer(I4B), pointer :: inssm => null() ! unit number SSM integer(I4B), pointer :: inoc => null() ! unit number OC integer(I4B), pointer :: inobs => null() ! unit number OBS - !integer(I4B), pointer :: inmst => null() ! unit number MST - !integer(I4B), pointer :: indsp => null() ! unit number DSP real(DP), pointer :: eqnsclfac => null() !< constant factor by which all terms in the model's governing equation are scaled (divided) for formulation and solution contains @@ -101,7 +99,11 @@ module TransportModelModule contains - subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! kluge note: not used/needed + !> @brief Create a new generalized transport model object + !! + !! Create a new transport model that will be further refined into GWT or GWE + !< + subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! -- modules use SimModule, only: store_error use MemoryManagerModule, only: mem_allocate @@ -122,7 +124,6 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! use TspSsmModule, only: ssm_cr use BudgetModule, only: budget_cr use ConstantsModule, only: LINELENGTH - !use NameFileModule, only: NameFileType use InputOutputModule, only: upcase ! -- dummy class(TransportModelType) :: this @@ -134,8 +135,6 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! type(GweInputDataType), intent(in), optional :: gwecommon !< shared data container for use by multiple GWE packages ! -- local class(*), pointer :: mstobjPtr - !type(NameFileType) :: namefile_obj - !integer(I4B) :: indis, indis6, indisu6, indisv6 character(len=LINELENGTH) :: errmsg character(len=LENMEMPATH) :: input_mempath integer(I4B) :: nwords @@ -144,9 +143,6 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! character(len=LINELENGTH) :: lst_fname type(GwfNamParamFoundType) :: found ! ------------------------------------------------------------------------------ - ! - ! -- Set memory path before allocation in memory manager can be done - !this%memoryPath = create_mem_path(modelname) ! ! -- Assign values this%filename = filename @@ -191,127 +187,30 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! call this%create_packages(indis) end if ! - ! -- Open namefile and set iout - !call namefile_obj%init(this%filename, 0) - !call namefile_obj%add_cunit(niunit, cunit) - !call namefile_obj%openlistfile(this%iout) - ! - ! -- Write header to model list file - !call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') - ! - ! -- Open files - !call namefile_obj%openfiles(this%iout) - ! - ! -- - !if (size(namefile_obj%opts) > 0) then - ! write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' - !end if - ! - ! -- parse options in the gwt name file - !do i = 1, size(namefile_obj%opts) - ! call ParseLine(namefile_obj%opts(i), nwords, words) - ! call upcase(words(1)) - ! select case (words(1)) - ! case ('PRINT_INPUT') - ! this%iprpak = 1 - ! write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - ! 'FOR ALL MODEL STRESS PACKAGES' - ! case ('PRINT_FLOWS') - ! this%iprflow = 1 - ! write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - ! 'FOR ALL MODEL PACKAGES' - ! case ('SAVE_FLOWS') - ! this%ipakcb = -1 - ! write (this%iout, '(4x,a)') & - ! 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - ! case default - ! write (errmsg, '(4x,a,a,a,a)') & - ! 'UNKNOWN GWT NAMEFILE (', & - ! trim(adjustl(this%filename)), ') OPTION: ', & - ! trim(adjustl(namefile_obj%opts(i))) - ! call store_error(errmsg, terminate=.TRUE.) - ! end select - !end do - ! - ! -- Assign unit numbers to attached modules, and remove - ! -- from unitnumber (by specifying 1 for iremove) - ! - !indis = 0 - !indis6 = 0 - !indisu6 = 0 - !indisv6 = 0 - !call namefile_obj%get_unitnumber('DIS6', indis6, 1) - !if (indis6 > 0) indis = indis6 - !if (indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1) - !if (indisu6 > 0) indis = indisu6 - !if (indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1) - !if (indisv6 > 0) indis = indisv6 - !call namefile_obj%get_unitnumber('ADV6', this%inadv, 1) - !call namefile_obj%get_unitnumber('FMI6', this%infmi, 1) - !call namefile_obj%get_unitnumber('IC6', this%inic, 1) - !call namefile_obj%get_unitnumber('MVT6', this%inmvt, 1) - !call namefile_obj%get_unitnumber('OBS6', this%inobs, 1) - !call namefile_obj%get_unitnumber('OC6', this%inoc, 1) - !call namefile_obj%get_unitnumber('SSM6', this%inssm, 1) - ! - ! -- Check to make sure that required ftype's have been specified - !call this%ftype_check(namefile_obj, indis) - ! - ! -- Create discretization object - !if (indis6 > 0) then - ! call this%load_input_context('DIS6', this%name, 'DIS', indis, this%iout) - ! call dis_cr(this%dis, this%name, indis, this%iout) - !elseif (indisu6 > 0) then - ! call this%load_input_context('DISU6', this%name, 'DISU', indis, this%iout) - ! call disu_cr(this%dis, this%name, indis, this%iout) - !elseif (indisv6 > 0) then - ! call this%load_input_context('DISV6', this%name, 'DISV', indis, this%iout) - ! call disv_cr(this%dis, this%name, indis, this%iout) - !end if - ! - ! -- Create utility objects - !call budget_cr(this%budget, this%name, this%tsplab) - ! - ! -- Create packages that are tied directly to model - !call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - !call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) - !call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & - ! this%eqnsclfac) - !call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & - ! this%tsplab, this%eqnsclfac) - !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) - !call oc_cr(this%oc, this%name, this%inoc, this%iout) - !call tsp_obs_cr(this%obs, this%inobs) - ! ! -- Return return end subroutine tsp_cr + !> @brief Generalized transport model define model + !! + !! This subroutine extended by either GWT or GWE. This routine calls the + !! define (df) routines for each attached package and sets variables and + !! pointers. + !< subroutine tsp_df(this) -! ****************************************************************************** -! gwt_df -- Define packages of the model -! Subroutine: (1) call df routines for each package -! (2) set variables and pointers -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy variables class(TransportModelType) :: this ! - ! -- Function extended by either GWT or GWE - ! ! -- return return end subroutine tsp_df + !> @brief Generalized transport model add connections + !! + !! This subroutine extended by either GWT or GWE. This routine adds the + !! internal connections of this model to the sparse matrix + !< subroutine tsp_ac(this, sparse) -! ****************************************************************************** -! gwt_ac -- Add the internal connections of this model to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix ! -- dummy variables @@ -319,88 +218,76 @@ subroutine tsp_ac(this, sparse) type(sparsematrix), intent(inout) :: sparse ! -- local ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- return return end subroutine tsp_ac + !> @brief Generalized transport model map coefficients + !! + !! This subroutine extended by either GWT or GWE. This routine maps the + !! positions of this models connections in the numerical solution coefficient + !! matrix. + !< subroutine tsp_mc(this, matrix_sln) -! ****************************************************************************** -! gwt_mc -- Map the positions of this models connections in the -! numerical solution coefficient matrix. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TransportModelType) :: this class(MatrixBaseType), pointer :: matrix_sln !< global system matrix ! -- local ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- return return end subroutine tsp_mc + !> @brief Generalized transport model allocate and read + !! + !! This subroutine extended by either GWT or GWE. This routine calls + !! the allocate and reads (ar) routines of attached packages and allocates + !! memory for arrays required by the model object. + !< subroutine tsp_ar(this) -! ****************************************************************************** -! gwt_ar -- GroundWater Transport Model Allocate and Read -! Subroutine: (1) allocates and reads packages part of this model, -! (2) allocates memory for arrays part of this model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy variables class(TransportModelType) :: this ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- return return end subroutine tsp_ar + !> @brief Generalized transport model read and prepare + !! + !! This subroutine extended by either GWT or GWE. This routine calls + !! the read and prepare (rp) routines of attached packages. + !< subroutine tsp_rp(this) -! ****************************************************************************** -! gwt_rp -- GroundWater Transport Model Read and Prepare -! Subroutine: (1) calls package read and prepare routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy variables class(TransportModelType) :: this ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- Return return end subroutine tsp_rp + !> @brief Generalized transport model time step advance + !! + !! This subroutine extended by either GWT or GWE. This routine calls + !! the advance time step (ad) routines of attached packages. + !< subroutine tsp_ad(this) -! ****************************************************************************** -! gwt_ad -- GroundWater Transport Model Time Step Advance -! Subroutine: (1) calls package advance subroutines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy variables class(TransportModelType) :: this ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- return return end subroutine tsp_ad + !> @brief Generalized transport model fill coefficients + !! + !! This subroutine extended by either GWT or GWE. This routine calls + !! the fill coefficients (fc) routines of attached packages. + !< subroutine tsp_fc(this, kiter, matrix_sln, inwtflag) ! ****************************************************************************** ! gwt_fc -- GroundWater Transport Model fill coefficients @@ -414,21 +301,17 @@ subroutine tsp_fc(this, kiter, matrix_sln, inwtflag) class(MatrixBaseType), pointer :: matrix_sln integer(I4B), intent(in) :: inwtflag ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- return return end subroutine tsp_fc + !> @brief Generalized transport model final convergence check + !! + !! This subroutine extended by either GWT or GWE. This routine calls + !! the convergence check (cc) routines of attached packages. + !< subroutine tsp_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) -! ****************************************************************************** -! gwt_cc -- GroundWater Transport Model Final Convergence Check -! Subroutine: (1) calls package cc routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TransportModelType) :: this integer(I4B), intent(in) :: innertot @@ -440,21 +323,17 @@ subroutine tsp_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) real(DP), intent(inout) :: dpak ! -- local ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- return return end subroutine tsp_cc + !> @brief Generalized transport model calculate flows + !! + !! This subroutine extended by either GWT or GWE. This routine calculates + !! intercell flows (flowja) + !< subroutine tsp_cq(this, icnvg, isuppress_output) -! ****************************************************************************** -! tsp_cq -- Transport model calculate flow -! Subroutine: (1) Calculate intercell flows (flowja) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy variables class(TransportModelType) :: this integer(I4B), intent(in) :: icnvg @@ -462,41 +341,32 @@ subroutine tsp_cq(this, icnvg, isuppress_output) ! -- local integer(I4B) :: i ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- Return return end subroutine tsp_cq + !> @brief Generalized transport model budget + !! + !! This subroutine extended by either GWT or GWE. This routine calculates + !! package contributions to model budget + !< subroutine tsp_bd(this, icnvg, isuppress_output) -! ****************************************************************************** -! tsp_bd --GroundWater Transport Model Budget -! Subroutine: (1) Calculate intercell flows (flowja) -! (2) Calculate package contributions to model budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TransportModelType) :: this integer(I4B), intent(in) :: icnvg integer(I4B), intent(in) :: isuppress_output ! ------------------------------------------------------------------------------ - ! - ! -- Function extended by either GWT or GWE ! ! -- Return return end subroutine tsp_bd + !> @brief Generalized transport model output routine + !! + !! Generalized transport model output + !< subroutine tsp_ot(this, inmst) -! ****************************************************************************** -! tsp_ot -- Transport Model Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy @@ -556,6 +426,10 @@ subroutine tsp_ot(this, inmst) return end subroutine tsp_ot + !> @brief Generalized transport model output routine + !! + !! Calculate and save observations + !< subroutine tsp_ot_obs(this) class(TransportModelType) :: this class(BndType), pointer :: packobj @@ -574,6 +448,10 @@ subroutine tsp_ot_obs(this) end subroutine tsp_ot_obs + !> @brief Generalized transport model output routine + !! + !! Save and print flows + !< subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun, inmst) class(TransportModelType) :: this integer(I4B), intent(in) :: icbcfl @@ -628,13 +506,11 @@ subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun, inmst) end subroutine tsp_ot_flow + !> @brief Generalized transport model output routine + !! + !! Write intercell flows for the transport model + !< subroutine tsp_ot_flowja(this, nja, flowja, icbcfl, icbcun) -! ****************************************************************************** -! gwt_ot_flowja -- Write intercell flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TransportModelType) :: this integer(I4B), intent(in) :: nja @@ -665,6 +541,10 @@ subroutine tsp_ot_flowja(this, nja, flowja, icbcfl, icbcun) return end subroutine tsp_ot_flowja + !> @brief Generalized tranpsort model output routine + !! + !! Loop through attached packages saving and printing dependent variables + !< subroutine tsp_ot_dv(this, idvsave, idvprint, ipflag) class(TransportModelType) :: this integer(I4B), intent(in) :: idvsave @@ -681,9 +561,15 @@ subroutine tsp_ot_dv(this, idvsave, idvprint, ipflag) ! -- save head and print head call this%oc%oc_ot(ipflag) - + ! + ! -- Return + return end subroutine tsp_ot_dv + !> @brief Generalized tranpsort model output budget summary + !! + !! Loop through attached packages and write budget summaries + !< subroutine tsp_ot_bdsummary(this, ibudfl, ipflag) use TdisModule, only: kstp, kper, totim class(TransportModelType) :: this @@ -712,16 +598,16 @@ subroutine tsp_ot_bdsummary(this, ibudfl, ipflag) ! -- Write to budget csv call this%budget%writecsv(totim) - + ! + ! -- Return + return end subroutine tsp_ot_bdsummary + !> @brief Allocate scalar variables for transport model + !! + !! Method to allocate memory for non-allocatable members. + !< subroutine allocate_tsp_scalars(this, modelname) -! ****************************************************************************** -! allocate_scalars -- Allocate memory for non-allocatable members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -755,13 +641,11 @@ subroutine allocate_tsp_scalars(this, modelname) return end subroutine allocate_tsp_scalars + !> @brief Deallocate memory + !! + !! Deallocate memmory at conclusion of model run + !< subroutine tsp_da(this) -! ****************************************************************************** -! tsp_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -773,9 +657,7 @@ subroutine tsp_da(this) call mem_deallocate(this%inic) call mem_deallocate(this%infmi) call mem_deallocate(this%inadv) - !call mem_deallocate(this%indsp) call mem_deallocate(this%inssm) - !call mem_deallocate(this%inmst) call mem_deallocate(this%inmvt) call mem_deallocate(this%inoc) call mem_deallocate(this%inobs) @@ -785,13 +667,11 @@ subroutine tsp_da(this) return end subroutine tsp_da + !> @brief Generalized tranpsort model routine + !! + !! Check to make sure required input files have been specified + !< subroutine ftype_check(this, indis, inmst) -! ****************************************************************************** -! ftype_check -- Check to make sure required input files have been specified -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_filename @@ -830,6 +710,8 @@ subroutine ftype_check(this, indis, inmst) return end subroutine ftype_check + !> @brief Create listing output file + !< subroutine create_lstfile(this, lst_fname, model_fname, defined) ! -- modules use KindModule, only: LGP @@ -878,7 +760,7 @@ subroutine create_lstfile(this, lst_fname, model_fname, defined) return end subroutine create_lstfile - !> @brief Write model namfile options to list file + !> @brief Write model name file options to list file !< subroutine log_namfile_options(this, found) use GwfNamInputModule, only: GwfNamParamFoundType @@ -930,9 +812,7 @@ subroutine create_packages(this, indis, gwecommon) use GwfDisuModule, only: disu_cr use TspIcModule, only: ic_cr use TspFmiModule, only: fmi_cr - !use GwtMstModule, only: mst_cr use TspAdvModule, only: adv_cr - !use GwtDspModule, only: dsp_cr use TspSsmModule, only: ssm_cr use TspMvtModule, only: mvt_cr use TspOcModule, only: oc_cr @@ -996,23 +876,14 @@ subroutine create_packages(this, indis, gwecommon) this%infmi = inunit case ('MVT6') this%inmvt = inunit - !case ('MST6') - ! this%inmst = inunit case ('ADV6') this%inadv = inunit - !case ('DSP6') - ! this%indsp = 1 - ! mempathdsp = mempath case ('SSM6') this%inssm = inunit case ('OC6') this%inoc = inunit case ('OBS6') this%inobs = inunit - !case ('CNC6', 'SRC6', 'LKT6', 'SFT6', & - ! 'MWT6', 'UZT6', 'IST6', 'API6') - ! call expandarray(bndpkgs) - ! bndpkgs(size(bndpkgs)) = n !case default ! TODO end select @@ -1022,10 +893,8 @@ subroutine create_packages(this, indis, gwecommon) call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & this%eqnsclfac) - !call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & this%eqnsclfac) - !call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, this%fmi) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, gwecommon) call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi, & @@ -1033,14 +902,8 @@ subroutine create_packages(this, indis, gwecommon) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! - ! -- Check to make sure that required ftype's have been specified - !call this%ftype_check(indis) - ! - !call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) - ! ! -- return return end subroutine create_packages - end module TransportModelModule From 5034a2643afaede8a12b637b3424772ee2829b52 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 11:06:19 -0700 Subject: [PATCH 156/212] tsp1apt1.f90 doxygen compliance. Touch-up in gwe1lke1.f90 --- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 22 +- src/Model/TransportModel/tsp1apt1.f90 | 639 +++++++++-------------- 2 files changed, 255 insertions(+), 406 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index 4e0756d2ffb..3a7c5b550d2 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -155,7 +155,7 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! vaporization for evaporative cooling. lkeobj%gwecommon => gwecommon ! - ! -- return + ! -- Return return end subroutine lke_create @@ -481,7 +481,7 @@ function lke_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy class(GweLkeType) :: this - ! -- return + ! -- Return integer(I4B) :: nbudterms ! -- local ! ------------------------------------------------------------------------------ @@ -615,7 +615,7 @@ subroutine lke_setup_budobj(this, idx) call this%budobj%budterm(idx)%update_term(n1, n2, q) end do ! - ! -- return + ! -- Return return end subroutine lke_setup_budobj @@ -730,7 +730,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if end do ! - ! -- return + ! -- Return return end subroutine lke_fill_budobj @@ -860,7 +860,7 @@ subroutine lke_rain_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lke_rain_term @@ -889,7 +889,7 @@ subroutine lke_evap_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lke_evap_term @@ -917,7 +917,7 @@ subroutine lke_roff_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lke_roff_term @@ -948,7 +948,7 @@ subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lke_iflw_term @@ -979,7 +979,7 @@ subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine lke_wdrl_term @@ -1010,7 +1010,7 @@ subroutine lke_outf_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine lke_outf_term @@ -1254,7 +1254,7 @@ subroutine lke_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine lke_set_stressperiod diff --git a/src/Model/TransportModel/tsp1apt1.f90 b/src/Model/TransportModel/tsp1apt1.f90 index 2c0b30aa02c..76fb1e4b58f 100644 --- a/src/Model/TransportModel/tsp1apt1.f90 +++ b/src/Model/TransportModel/tsp1apt1.f90 @@ -132,10 +132,10 @@ module TspAptModule procedure :: bnd_ad => apt_ad procedure :: bnd_cf => apt_cf procedure :: bnd_fc => apt_fc - procedure, public :: apt_fc_expanded ! kluge note: Made public for uze on 3/3/2023 (reston) + procedure, public :: apt_fc_expanded ! Made public for uze procedure :: pak_fc_expanded procedure, private :: apt_fc_nonexpanded - procedure, public :: apt_cfupdate ! kluge note: made public for uze + procedure, public :: apt_cfupdate ! Made public for uze procedure :: apt_check_valid procedure :: apt_set_stressperiod procedure :: pak_set_stressperiod @@ -175,8 +175,8 @@ module TspAptModule procedure :: pak_fill_budobj procedure, public :: apt_stor_term procedure, public :: apt_tmvr_term - procedure, public :: apt_fmvr_term ! kluge note: new subroutine, public for uze - procedure, public :: apt_fjf_term ! kluge note: made public for uze + procedure, public :: apt_fmvr_term ! Made public for uze + procedure, public :: apt_fjf_term ! Made public for uze procedure, private :: apt_copy2flowp procedure, private :: apt_setup_tableobj @@ -235,13 +235,9 @@ subroutine apt_ac(this, moffset, sparse) return end subroutine apt_ac + !> @brief Advanced package transport map package connections to matrix + !< subroutine apt_mc(this, moffset, matrix_sln) -! ****************************************************************************** -! apt_mc -- map package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use SparseModule, only: sparsematrix ! -- dummy class(TspAptType), intent(inout) :: this @@ -252,7 +248,6 @@ subroutine apt_mc(this, moffset, matrix_sln) integer(I4B) :: ipos ! -- format ! ------------------------------------------------------------------------------ - ! ! ! -- allocate memory for index arrays call this%apt_allocate_index_arrays() @@ -301,17 +296,13 @@ subroutine apt_mc(this, moffset, matrix_sln) end if end if ! - ! -- return + ! -- Return return end subroutine apt_mc + !> @brief Advanced package transport allocate and read (ar) routine + !< subroutine apt_ar(this) -! ****************************************************************************** -! apt_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType), intent(inout) :: this @@ -378,15 +369,11 @@ subroutine apt_ar(this) return end subroutine apt_ar + !> @brief Advanced package transport read and prepare (rp) routine + !! + !! This subroutine calls the attached packages' read and prepare routines. + !< subroutine apt_rp(this) -! ****************************************************************************** -! apt_rp -- Read and Prepare -! Subroutine: (1) read itmp -! (2) read new boundaries if itmp>0 -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TdisModule, only: kper, nper ! -- dummy class(TspAptType), intent(inout) :: this @@ -500,18 +487,16 @@ subroutine apt_rp(this) this%nodelist(n) = igwfnode end do ! - ! -- return + ! -- Return return end subroutine apt_rp + !> @brief Advanced package transport set stress period routine. + !! + !! Set a stress period attribute for an advanced transport package feature + !! (itemno) using keywords. + !< subroutine apt_set_stressperiod(this, itemno) -! ****************************************************************************** -! apt_set_stressperiod -- Set a stress period attribute for feature (itemno) -! using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- module use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy @@ -607,14 +592,12 @@ subroutine apt_set_stressperiod(this, itemno) return end subroutine apt_set_stressperiod + !> @brief Advanced package transport set stress period routine. + !! + !! Set a stress period attribute for an individual package. This routine + !! must be overridden. + !< subroutine pak_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! pak_set_stressperiod -- Set a stress period attribute for individual package. -! This must be overridden. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspAptType), intent(inout) :: this integer(I4B), intent(in) :: itemno @@ -634,11 +617,11 @@ subroutine pak_set_stressperiod(this, itemno, keyword, found) return end subroutine pak_set_stressperiod + !> @brief Advanced package transport routine + !! + !! Determine if a valid feature number has been specified. + !< function apt_check_valid(this, itemno) result(ierr) -! ****************************************************************************** -! apt_check_valid -- Determine if a valid feature number has been -! specified. -! ****************************************************************************** ! -- return integer(I4B) :: ierr ! -- dummy @@ -656,13 +639,11 @@ function apt_check_valid(this, itemno) result(ierr) end if end function apt_check_valid + !> @brief Advanced package transport routine + !! + !! Add package connections to matrix + !< subroutine apt_ad(this) -! ****************************************************************************** -! apt_ad -- Add package connection to matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimVariablesModule, only: iFailedStepRetry ! -- dummy @@ -715,15 +696,14 @@ subroutine apt_ad(this) ! "current" value. call this%obs%obs_ad() ! - ! -- return + ! -- Return return end subroutine apt_ad !> @ brief Formulate the package hcof and rhs terms. !! - !! For the APT Package, the sole purpose here is to - !! reset the qmfrommvr term. - !! + !! For the APT Package, the sole purpose here is to reset the qmfrommvr + !! term. !< subroutine apt_cf(this, reset_mover) ! -- modules @@ -746,13 +726,11 @@ subroutine apt_cf(this, reset_mover) return end subroutine apt_cf + !> @brief Advanced package transport fill coefficient (fc) method + !! + !! Method to calculate and fill coefficients for an advanced transport package. + !< subroutine apt_fc(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! apt_fc -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -774,14 +752,12 @@ subroutine apt_fc(this, rhs, ia, idxglo, matrix_sln) return end subroutine apt_fc + !> @brief Advanced package transport fill coefficient (fc) method + !! + !! Routine to formulate the nonexpanded matrix case in which feature + !! concentrations (or temperatures) are solved explicitly + !< subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! apt_fc_nonexpanded -- formulate for the nonexpanded a matrix case in which -! feature concentrations (or temperatures) are solved explicitly -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -809,14 +785,12 @@ subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine apt_fc_nonexpanded + !> @brief Advanced package transport fill coefficient (fc) method + !! + !! Routine to formulate the expanded matrix case in which new rows are added + !! to the system of equations for each advanced package transport feature + !< subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! apt_fc_expanded -- formulate for the expanded matrix case in which new -! rows are added to the system of equations for each feature -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -890,16 +864,12 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to apt row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) -!! call matrix_sln%add_value_pos(iposd, omega * qbnd) -!! call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) call matrix_sln%add_value_pos(iposd, omega * qbndscld) call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbndscld) ! ! -- add to gwf row for apt connection ipossymd = this%idxsymdglo(j) ipossymoffd = this%idxsymoffdglo(j) -!! call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbnd) -!! call matrix_sln%add_value_pos(ipossymoffd, -omega * qbnd) call matrix_sln%add_value_pos(ipossymd, -(DONE - omega) * qbndscld) call matrix_sln%add_value_pos(ipossymoffd, -omega * qbndscld) end if @@ -919,8 +889,6 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) qbndscld = qbnd * this%eqnsclfac iposd = this%idxfjfdglo(j) iposoffd = this%idxfjfoffdglo(j) -!! call matrix_sln%add_value_pos(iposd, omega * qbnd) -!! call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbnd) call matrix_sln%add_value_pos(iposd, omega * qbndscld) call matrix_sln%add_value_pos(iposoffd, (DONE - omega) * qbndscld) end do @@ -930,14 +898,12 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine apt_fc_expanded + !> @brief Advanced package transport fill coefficient (fc) method + !! + !! Routine to allow a subclass advanced transport package to inject + !! terms into the matrix assembly. This method must be overridden. + !< subroutine pak_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! pak_fc_expanded -- allow a subclass advanced transport package to inject -! terms into the matrix assembly. This method must be overridden. -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -956,13 +922,12 @@ subroutine pak_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine pak_fc_expanded + !> @brief Advanced package transport routine + !! + !! Calculate advanced package transport hcof and rhs so transport budget is + !! calculated. + !< subroutine apt_cfupdate(this) -! ****************************************************************************** -! apt_cfupdate -- calculate package hcof and rhs so gwt budget is calculated -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -992,13 +957,11 @@ subroutine apt_cfupdate(this) return end subroutine apt_cfupdate + !> @brief Advanced package transport calculate flows (cq) routine + !! + !! Calculate flows for the advanced package transport feature + !< subroutine apt_cq(this, x, flowja, iadv) -! ****************************************************************************** -! apt_cq -- Calculate flows for the feature -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType), intent(inout) :: this @@ -1036,10 +999,12 @@ subroutine apt_cq(this, x, flowja, iadv) ! -- fill the budget object call this%apt_fill_budobj(x, flowja) ! - ! -- return + ! -- Return return end subroutine apt_cq + !> @brief Save advanced package flows routine + !< subroutine apt_ot_package_flows(this, icbcfl, ibudfl) use TdisModule, only: kstp, kper, delt, pertim, totim class(TspAptType) :: this @@ -1062,9 +1027,12 @@ subroutine apt_ot_package_flows(this, icbcfl, ibudfl) if (ibudfl /= 0 .and. this%iprflow /= 0) then call this%budobj%write_flowtable(this%dis, kstp, kper) end if - + ! + ! -- Return + return end subroutine apt_ot_package_flows + subroutine apt_ot_dv(this, idvsave, idvprint) ! -- modules use ConstantsModule, only: LENBUDTXT @@ -1117,9 +1085,13 @@ subroutine apt_ot_dv(this, idvsave, idvprint) call this%dvtab%add_term(this%xnewpak(n)) end do end if - + ! + ! -- Return + return end subroutine apt_ot_dv + !> @brief Print advanced package transport dependent variables + !< subroutine apt_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! -- module use TdisModule, only: totim @@ -1132,14 +1104,13 @@ subroutine apt_ot_bdsummary(this, kstp, kper, iout, ibudfl) ! call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim) ! - ! -- return + ! -- Return return end subroutine apt_ot_bdsummary !> @ brief Allocate scalars !! - !! Allocate scalar variables for this package - !! + !! Allocate scalar variables for an advanced package !< subroutine allocate_scalars(this) ! -- modules @@ -1198,9 +1169,7 @@ end subroutine allocate_scalars !> @ brief Allocate index arrays !! - !! Allocate arrays that map to locations in the - !! numerical solution - !! + !! Allocate arrays that map to locations in the numerical solution !< subroutine apt_allocate_index_arrays(this) ! -- modules @@ -1209,7 +1178,7 @@ subroutine apt_allocate_index_arrays(this) class(TspAptType), intent(inout) :: this ! -- local integer(I4B) :: n - + ! if (this%imatrows /= 0) then ! ! -- count number of flow-ja-face connections @@ -1253,13 +1222,14 @@ subroutine apt_allocate_index_arrays(this) call mem_allocate(this%idxfjfoffdglo, 0, 'IDXFJFOFFDGLO', & this%memoryPath) end if + ! + ! -- Return return end subroutine apt_allocate_index_arrays !> @ brief Allocate arrays !! - !! Allocate package arrays - !! + !! Allocate advanced package transport arrays !< subroutine apt_allocate_arrays(this) ! -- modules @@ -1318,7 +1288,6 @@ end subroutine apt_allocate_arrays !> @ brief Deallocate memory !! !! Deallocate memory associated with this package - !! !< subroutine apt_da(this) ! -- modules @@ -1395,13 +1364,9 @@ subroutine apt_da(this) return end subroutine apt_da + !> @brief Find corresponding advanced package transport package + !< subroutine find_apt_package(this) -! ****************************************************************************** -! find corresponding flow package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -1417,15 +1382,11 @@ subroutine find_apt_package(this) return end subroutine find_apt_package + !> @brief Set options specific to the TspAptType + !! + !! This routine overrides BndType%bnd_options + !< subroutine apt_options(this, option, found) -! ****************************************************************************** -! apt_options -- set options specific to TspAptType -! -! apt_options overrides BndType%bnd_options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use ConstantsModule, only: MAXCHARLEN, DZERO use OpenSpecModule, only: access, form use InputOutputModule, only: urword, getunit, openfile @@ -1514,17 +1475,13 @@ subroutine apt_options(this, option, found) found = .false. end select ! - ! -- return + ! -- Return return end subroutine apt_options + !> @brief Determine dimensions for this advanced package + !< subroutine apt_read_dimensions(this) -! ****************************************************************************** -! apt_read_dimensions -- Determine dimensions for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspAptType), intent(inout) :: this ! -- local @@ -1588,17 +1545,13 @@ subroutine apt_read_dimensions(this) ! -- setup the conc table object call this%apt_setup_tableobj() ! - ! -- return + ! -- Return return end subroutine apt_read_dimensions + !> @brief Read feature information for this advanced package + !< subroutine apt_read_cvs(this) -! ****************************************************************************** -! apt_read_cvs -- Read feature information for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use TimeSeriesManagerModule, only: read_value_or_time_series_adv @@ -1754,7 +1707,7 @@ subroutine apt_read_cvs(this) call store_error(errmsg) end if end do - + ! write (this%iout, '(1x,a)') & 'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' else @@ -1774,17 +1727,13 @@ subroutine apt_read_cvs(this) ! -- deallocate local storage for nboundchk deallocate (nboundchk) ! - ! -- return + ! -- Return return end subroutine apt_read_cvs + !> @brief Read the initial parameters for an advanced package + !< subroutine apt_read_initial_attr(this) -! ****************************************************************************** -! apt_read_initial_attr -- Read the initial parameters for this package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use ConstantsModule, only: LINELENGTH use BudgetModule, only: budget_cr ! -- dummy @@ -1792,56 +1741,16 @@ subroutine apt_read_initial_attr(this) ! -- local !character(len=LINELENGTH) :: text integer(I4B) :: j, n - !integer(I4B) :: nn - !integer(I4B) :: idx - !real(DP) :: endtim - !real(DP) :: top - !real(DP) :: bot - !real(DP) :: k - !real(DP) :: area - !real(DP) :: length - !real(DP) :: s - !real(DP) :: dx - !real(DP) :: c - !real(DP) :: sa - !real(DP) :: wa - !real(DP) :: v - !real(DP) :: fact - !real(DP) :: c1 - !real(DP) :: c2 - !real(DP), allocatable, dimension(:) :: clb, caq - !character (len=14) :: cbedleak - !character (len=14) :: cbedcond - !character (len=10), dimension(0:3) :: ctype - !character (len=15) :: nodestr - !!data - !data ctype(0) /'VERTICAL '/ - !data ctype(1) /'HORIZONTAL'/ - !data ctype(2) /'EMBEDDEDH '/ - !data ctype(3) /'EMBEDDEDV '/ - ! -- format ! ------------------------------------------------------------------------------ - ! ! -- initialize xnewpak and set lake concentration (or temperature) ! -- todo: this should be a time series? do n = 1, this%ncv this%xnewpak(n) = this%strt(n) - !write(text,'(g15.7)') this%strt(n) - !endtim = DZERO - !jj = 1 ! For STAGE - !call read_single_value_or_time_series(text, & - ! this%stage(n)%value, & - ! this%stage(n)%name, & - ! endtim, & - ! this%name, 'BND', this%TsManager, & - ! this%iprpak, n, jj, 'STAGE', & - ! this%featname(n), this%inunit) - + ! ! -- todo: read aux - + ! ! -- todo: read boundname - end do ! ! -- initialize status (iboundpak) of lakes to active @@ -1866,18 +1775,17 @@ subroutine apt_read_initial_attr(this) ! -- copy boundname into boundname_cst call this%copy_boundname() ! - ! -- return + ! -- Return return end subroutine apt_read_initial_attr + !> @brief Add terms specific to advanced package transport to the explicit + !! solve + !! + !! Explicit solve for concentration (or temperature) in advaced package + !! features, which is an alternative to the iterative implicit solve. + !< subroutine apt_solve(this) -! ****************************************************************************** -! apt_solve -- explicit solve for concentration (or temperature) in features, -! which is an alternative to the iterative implicit solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use ConstantsModule, only: LINELENGTH ! -- dummy class(TspAptType) :: this @@ -1934,8 +1842,8 @@ subroutine apt_solve(this) this%dbuff(n) = this%dbuff(n) + c1 end do ! - ! -- go through each lak-lak connection and accumulate - ! total mass (or energy) in dbuff mass + ! -- go through each "within apt-apt" connection (e.g., lak-lak) and + ! accumulate total mass (or energy) in dbuff mass if (this%idxbudfjf /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist call this%apt_fjf_term(j, n1, n2, rrate) @@ -1963,13 +1871,12 @@ subroutine apt_solve(this) return end subroutine apt_solve + !> @brief Add terms specific to advanced package transport features to the + !! explicit solve routine + !! + !! This routine must be overridden by the specific apt package + !< subroutine pak_solve(this) -! ****************************************************************************** -! pak_solve -- must be overridden -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspAptType) :: this ! -- local @@ -1983,14 +1890,9 @@ subroutine pak_solve(this) return end subroutine pak_solve + !> @brief Accumulate constant concentration (or temperature) terms for budget + !< subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) -! ****************************************************************************** -! apt_accumulate_ccterm -- Accumulate constant concentration (or temperature) -! terms for budget. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspAptType) :: this integer(I4B), intent(in) :: ilak @@ -2018,18 +1920,14 @@ subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) ccratin = ccratin + q end if end if - ! -- return + ! -- Return return end subroutine apt_accumulate_ccterm + !> @brief 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: -! ------------------------------------------------------------------------------ class(TspAptType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! @@ -2050,18 +1948,14 @@ subroutine define_listlabel(this) write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' end if ! - ! -- return + ! -- Return return end subroutine define_listlabel + !> @brief Set pointers to model arrays and variables so that a package has + !! access to these items. + !< subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) -! ****************************************************************************** -! set_pointers -- Set pointers to model arrays and variables so that a package -! has access to these things. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ class(TspAptType) :: this integer(I4B), pointer :: neq integer(I4B), dimension(:), pointer, contiguous :: ibound @@ -2086,16 +1980,13 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) this%xnewpak => this%xnew(istart:iend) end if ! - ! -- return + ! -- Return + return end subroutine apt_set_pointers + !> @brief Return the feature new volume and old volume + !< subroutine get_volumes(this, icv, vnew, vold, delt) -! ****************************************************************************** -! get_volumes -- return the feature new volume and old volume -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2119,14 +2010,11 @@ subroutine get_volumes(this, icv, vnew, vold, delt) return end subroutine get_volumes + !> @brief Function to return the number of budget terms just for this package + !! + !! This function must be overridden. + !< function pak_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! pak_get_nbudterms -- function to return the number of budget terms just for -! this package. Must be overridden. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2141,6 +2029,8 @@ function pak_get_nbudterms(this) result(nbudterms) nbudterms = 0 end function pak_get_nbudterms + !> @brief Function for string manipulation + !< function padl(str, width) result(res) ! -- local character(len=*), intent(in) :: str @@ -2155,13 +2045,9 @@ function padl(str, width) result(res) return end function + !> @brief Set up the budget object that stores advanced package flow terms + !< subroutine apt_setup_budobj(this) -! ****************************************************************************** -! apt_setup_budobj -- Set up the budget object that stores all the lake flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -2199,14 +2085,6 @@ subroutine apt_setup_budobj(this) ! ! -- add terms for the specific package nbudterm = nbudterm + this%pak_get_nbudterms() - ! - ! -- add one for shared wetted area facilitating conduction in SFE, LKE, - ! and MWE (but not UZE) in GWE model - !if (this%tsplab%tsptype == 'GWE') then - ! if (adjustl(trim(this%text)) /= 'UZE') then - ! if (nlen > 0) nbudterm = nbudterm + 1 - ! end if - !end if ! ! -- add for mover terms and auxiliary if (this%idxbudtmvr /= 0) nbudterm = nbudterm + 1 @@ -2353,18 +2231,15 @@ subroutine apt_setup_budobj(this) call this%budobj%flowtable_df(this%iout) end if ! - ! -- return + ! -- Return return end subroutine apt_setup_budobj + !> @brief Set up a budget object that stores an advanced package flows + !! + !! Individual packages set up their budget terms. Must be overridden. + !< subroutine pak_setup_budobj(this, idx) -! ****************************************************************************** -! pak_setup_budobj -- Individual packages set up their budget terms. Must -! be overridden -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2376,17 +2251,13 @@ subroutine pak_setup_budobj(this, idx) call store_error('Program error: pak_setup_budobj not implemented.', & terminate=.TRUE.) ! - ! -- return + ! -- Return return end subroutine pak_setup_budobj + !> @brief Copy flow terms into this%budobj + !< subroutine apt_fill_budobj(this, x, flowja) -! ****************************************************************************** -! apt_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: delt ! -- dummy @@ -2417,7 +2288,7 @@ subroutine apt_fill_budobj(this, x, flowja) do n1 = 1, this%ncv this%ccterm(n1) = DZERO end do - + ! ! -- FLOW JA FACE nlen = 0 if (this%idxbudfjf /= 0) then @@ -2434,7 +2305,7 @@ subroutine apt_fill_budobj(this, x, flowja) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- GWF (LEAKAGE) idx = idx + 1 call this%budobj%budterm(idx)%reset(this%maxbound) @@ -2449,13 +2320,11 @@ subroutine apt_fill_budobj(this, x, flowja) call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - -!! ! -- individual package terms -!! call this%pak_fill_budobj(idx, x, ccratin, ccratout) + ! ! -- skip individual package terms for now and process them last ! -- in case they depend on the other terms (as for uze) idx = this%idxlastpak - + ! ! -- STORAGE idx = idx + 1 call this%budobj%budterm(idx)%reset(this%ncv) @@ -2468,7 +2337,7 @@ subroutine apt_fill_budobj(this, x, flowja) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do deallocate (auxvartmp) - + ! ! -- TO MOVER if (this%idxbudtmvr /= 0) then idx = idx + 1 @@ -2480,21 +2349,19 @@ subroutine apt_fill_budobj(this, x, flowja) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- FROM MOVER if (this%idxbudfmvr /= 0) then idx = idx + 1 nlist = this%ncv call this%budobj%budterm(idx)%reset(nlist) -!! do n1 = 1, nlist -!! q = this%qmfrommvr(n1) ! kluge note: presumably in terms of energy already for heat transport??? do j = 1, nlist call this%apt_fmvr_term(j, n1, n2, q) ! kluge note: don't really need to do this in apt_fmvr_term now, since no override by uze call this%budobj%budterm(idx)%update_term(n1, n1, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- CONSTANT FLOW idx = idx + 1 call this%budobj%budterm(idx)%reset(this%ncv) @@ -2502,7 +2369,7 @@ subroutine apt_fill_budobj(this, x, flowja) q = this%ccterm(n1) call this%budobj%budterm(idx)%update_term(n1, n1, q) end do - + ! ! -- AUXILIARY VARIABLES naux = this%naux if (naux > 0) then @@ -2526,17 +2393,13 @@ subroutine apt_fill_budobj(this, x, flowja) ! --Terms are filled, now accumulate them for this time step call this%budobj%accumulate_terms() ! - ! -- return + ! -- Return return end subroutine apt_fill_budobj + !> @brief Copy flow terms into this%budobj, must be overridden + !< subroutine pak_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! pak_fill_budobj -- copy flow terms into this%budobj, must be overridden -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2553,10 +2416,12 @@ subroutine pak_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call store_error('Program error: pak_fill_budobj not implemented.', & terminate=.TRUE.) ! - ! -- return + ! -- Return return end subroutine pak_fill_budobj + !> @brief Account for mass or energy storage in advanced package features + !< subroutine apt_stor_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) use TdisModule, only: delt @@ -2579,15 +2444,15 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & if (present(rrate)) then rrate = (-c1 * v1 / delt + c0 * v0 / delt) * this%eqnsclfac end if -!! if (present(rhsval)) rhsval = -c0 * v0 / delt -!! if (present(hcofval)) hcofval = -v1 / delt if (present(rhsval)) rhsval = -c0 * v0 * this%eqnsclfac / delt if (present(hcofval)) hcofval = -v1 * this%eqnsclfac / delt ! - ! -- return + ! -- Return return end subroutine apt_stor_term + !> @brief Account for mass or energy transferred to the MVR package + !< subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- modules @@ -2611,13 +2476,15 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & ctmp = this%xnewpak(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac if (present(rhsval)) rhsval = DZERO -!! if (present(hcofval)) hcofval = qbnd if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine apt_tmvr_term + !> @brief Account for mass or energy transferred to this package from the + !! MVR package + !< subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- modules @@ -2634,16 +2501,17 @@ subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & ! -- Calculate MVR-related terms n1 = ientry n2 = n1 -!! if (present(rrate)) rrate = this%qmfrommvr(n1) * this%eqnsclfac if (present(rrate)) rrate = this%qmfrommvr(n1) ! presumably in terms of energy already for heat transport??? -!! if (present(rhsval)) rhsval = this%qmfrommvr(n1) * this%eqnsclfac if (present(rhsval)) rhsval = this%qmfrommvr(n1) if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine apt_fmvr_term + !> @brief Go through each "within apt-apt" connection (e.g., lkt-lkt, or + !! sft-sft) and accumulate total mass (or energy) in dbuff mass + !< subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- modules @@ -2669,22 +2537,17 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & ctmp = this%xnewpak(n2) end if if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac -!! if (present(rhsval)) rhsval = -rrate if (present(rhsval)) rhsval = -rrate * this%eqnsclfac if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine apt_fjf_term + !> @brief Copy concentrations (or temperatures) into flow package aux + !! variable + !< subroutine apt_copy2flowp(this) -! ****************************************************************************** -! apt_copy2flowp -- copy concentrations (or temperatures) into flow package -! aux variable -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2704,19 +2567,17 @@ subroutine apt_copy2flowp(this) end do end if ! - ! -- return + ! -- Return return end subroutine apt_copy2flowp + !> @brief Determine whether an obs type is supported + !! + !! This function: + !! - returns true if APT package supports named observation. + !! - overrides BndType%bnd_obs_supported() + !< logical function apt_obs_supported(this) -! ****************************************************************************** -! apt_obs_supported -- obs are supported? -! -- Return true because APT package supports observations. -! -- Overrides BndType%bnd_obs_supported() -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2725,19 +2586,17 @@ logical function apt_obs_supported(this) ! -- Set to true apt_obs_supported = .true. ! - ! -- return + ! -- Return return end function apt_obs_supported + !> @brief Define observation type + !! + !! This routine: + !! - stores observation types supported by APT package. + !! - overrides BndType%bnd_df_obs + !< subroutine apt_df_obs(this) -! ****************************************************************************** -! apt_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2747,18 +2606,16 @@ subroutine apt_df_obs(this) ! -- call additional specific observations for lkt, sft, mwt, and uzt call this%pak_df_obs() ! + ! -- Return return end subroutine apt_df_obs + !> @brief Define apt observation type + !! + !! This routine: + !! - stores observations supported by the APT package + !! - must be overridden by child class subroutine pak_df_obs(this) -! ****************************************************************************** -! pak_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- must be overridden by child class -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -2773,9 +2630,8 @@ subroutine pak_df_obs(this) end subroutine pak_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. !< subroutine pak_rp_obs(this, obsrv, found) ! -- dummy @@ -2788,14 +2644,14 @@ subroutine pak_rp_obs(this, obsrv, found) call store_error('Program error: pak_rp_obs not implemented.', & terminate=.TRUE.) ! + ! -- Return return end subroutine pak_rp_obs !> @brief Prepare observation - !! - !! Find the indices for this observation assuming - !! they are indexed by feature number - !! + !! + !! Find the indices for this observation assuming they are indexed by + !! feature number !< subroutine rp_obs_byfeature(this, obsrv) class(TspAptType), intent(inout) :: this !< object @@ -2833,15 +2689,15 @@ subroutine rp_obs_byfeature(this, obsrv) end if call obsrv%AddObsIndex(nn1) end if + ! + ! -- Return return end subroutine rp_obs_byfeature !> @brief Prepare observation - !! - !! Find the indices for this observation assuming - !! they are first indexed by feature number and - !! secondly by a connection number - !! + !! + !! Find the indices for this observation assuming they are first indexed + !! by feature number and secondly by a connection number !< subroutine rp_obs_budterm(this, obsrv, budterm) class(TspAptType), intent(inout) :: this !< object @@ -2908,15 +2764,15 @@ subroutine rp_obs_budterm(this, obsrv, budterm) call store_error(errmsg) end if end if + ! + ! -- Return return end subroutine rp_obs_budterm !> @brief Prepare observation - !! - !! Find the indices for this observation assuming - !! they are first indexed by a feature number and - !! secondly by a second feature number - !! + !! + !! Find the indices for this observation assuming they are first indexed + !! by a feature number and secondly by a second feature number !< subroutine rp_obs_flowjaface(this, obsrv, budterm) class(TspAptType), intent(inout) :: this !< object @@ -2985,16 +2841,16 @@ subroutine rp_obs_flowjaface(this, obsrv, budterm) call store_error(errmsg) end if end if + ! + ! -- Return return end subroutine rp_obs_flowjaface + !> @brief Read and prepare apt-related observations + !! + !! Mehtod to process specific observations for an apt package + !< subroutine apt_rp_obs(this) -! ****************************************************************************** -! apt_rp_obs -- -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kper ! -- dummy @@ -3066,17 +2922,17 @@ subroutine apt_rp_obs(this) end if end if ! + ! -- Return return end subroutine apt_rp_obs + !> @brief Calculate observation values + !! + !! Routine calculates observations common to SFT/LKT/MWT/UZT + !! (or SFE/LKE/MWE/UZE) for as many TspAptType observations that are common + !! among the advanced transport packages + !< subroutine apt_bd_obs(this) -! ****************************************************************************** -! apt_bd_obs -- Calculate observations common to SFT/LKT/MWT/UZT -! ObsType%SaveOneSimval for each TspAptType observation. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspAptType) :: this @@ -3163,17 +3019,13 @@ subroutine apt_bd_obs(this) end if end if ! + ! -- Return return end subroutine apt_bd_obs + !> @brief Check if observation exists in an advanced package + !< subroutine pak_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! pak_bd_obs -- -! -- check for observations in concrete packages. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspAptType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -3186,15 +3038,15 @@ subroutine pak_bd_obs(this, obstypeid, jj, v, found) ! -- set found = .false. because obstypeid is not known found = .false. ! + ! -- Return return end subroutine pak_bd_obs - !> @brief Process observation IDs for a package - !! - !! Method to process observation ID strings for an APT package. - !! This processor is only for observation types that support ID1 - !! and not ID2. - !! + !> @brief Process observation IDs for an advanced package + !! + !! Method to process observation ID strings for an APT package. + !! This processor is only for observation types that support ID1 + !! and not ID2. !< subroutine apt_process_obsID(obsrv, dis, inunitobs, iout) ! -- dummy variables @@ -3232,16 +3084,15 @@ subroutine apt_process_obsID(obsrv, dis, inunitobs, iout) ! because there is only one reach per GWT connection. obsrv%NodeNumber2 = 1 ! - ! -- return + ! -- Return return end subroutine apt_process_obsID !> @brief Process observation IDs for a package - !! - !! Method to process observation ID strings for an APT package. - !! This processor is for the case where if ID1 is an integer - !! then ID2 must be provided. - !! + !! + !! Method to process observation ID strings for an APT package. This + !! processor is for the case where if ID1 is an integer then ID2 must be + !! provided. !< subroutine apt_process_obsID12(obsrv, dis, inunitobs, iout) ! -- dummy variables @@ -3286,19 +3137,17 @@ subroutine apt_process_obsID12(obsrv, dis, inunitobs, iout) ! -- store reach number (NodeNumber) obsrv%NodeNumber = nn1 ! - ! -- return + ! -- Return return end subroutine apt_process_obsID12 + !> @brief Setup a table object an advanced package + !! + !! Set up the table object that is used to write the apt concentration + !! (or temperature) data. The terms listed here must correspond in the + !! apt_ot method. + !< subroutine apt_setup_tableobj(this) -! ****************************************************************************** -! apt_setup_tableobj -- Set up the table object that is used to write the apt -! concentration (or temperature) data. The terms listed -! here must correspond in the apt_ot method. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH, LENBUDTXT ! -- dummy @@ -3343,7 +3192,7 @@ subroutine apt_setup_tableobj(this) call this%dvtab%initialize_column(text_temp, 12, alignment=TABCENTER) end if ! - ! -- return + ! -- Return return end subroutine apt_setup_tableobj From ed5e3669edd01733b26cdf360894604cfe025aab Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 13:17:43 -0700 Subject: [PATCH 157/212] tsp1cnc1.f90 doxygen compliance. Touch-up in gwe1dsp1.f90 --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 2 +- src/Model/TransportModel/tsp1cnc1.f90 | 170 ++++++++++------------- 2 files changed, 71 insertions(+), 101 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 75030a73456..60dd039bc85 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -482,7 +482,7 @@ subroutine allocate_arrays(this, nodes) return end subroutine allocate_arrays - !> @ brief Deallocate + !> @ brief Deallocate memory !! !! Method to deallocate memory for the package. !< diff --git a/src/Model/TransportModel/tsp1cnc1.f90 b/src/Model/TransportModel/tsp1cnc1.f90 index 5a476604904..2c30b9f6b14 100644 --- a/src/Model/TransportModel/tsp1cnc1.f90 +++ b/src/Model/TransportModel/tsp1cnc1.f90 @@ -46,18 +46,14 @@ module TspCncModule procedure, public :: bnd_rp_ts => cnc_rp_ts end type TspCncType -contains + contains + !> @brief Create a new constant concentration or temperature package + !! + !! Routine points packobj to the newly created package + !< subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & tsplab, eqnsclfac, gwecommon) -! ****************************************************************************** -! cnc_create -- Create a New Constant Concentration/Temperature Package -! Subroutine: (1) create new-style package -! (2) point packobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -106,17 +102,14 @@ subroutine cnc_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & cncobj%gwecommon => gwecommon end if ! - ! -- return + ! -- Return return end subroutine cnc_create + !> @brief Allocate arrays specific to the constant concentration/tempeature + !! package. + !< subroutine cnc_allocate_arrays(this, nodelist, auxvar) -! ****************************************************************************** -! allocate_scalars -- allocate arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -139,17 +132,13 @@ subroutine cnc_allocate_arrays(this, nodelist, auxvar) this%ratecncout(i) = DZERO end do ! - ! -- return + ! -- Return return end subroutine cnc_allocate_arrays + !> @brief Constant concentration/temperature read and prepare (rp) routine + !< subroutine cnc_rp(this) -! ****************************************************************************** -! cnc_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use SimModule, only: store_error use InputOutputModule, only: lowcase implicit none @@ -190,10 +179,15 @@ subroutine cnc_rp(this) call this%parser%StoreErrorUnit() end if ! - ! -- return + ! -- Return return end subroutine cnc_rp + + !> @brief Constant concentration/temperature package advance routine + !! + !! Add package connections to matrix + !< subroutine cnc_ad(this) ! ****************************************************************************** ! cnc_ad -- Advance @@ -226,17 +220,13 @@ subroutine cnc_ad(this) ! "current" value. call this%obs%obs_ad() ! - ! -- return + ! -- Return return end subroutine cnc_ad + !> @brief Check constant concentration/temperature boundary condition data + !< subroutine cnc_ck(this) -! ****************************************************************************** -! cnc_ck -- Check cnc boundary condition data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error, count_errors, store_error_unit @@ -268,17 +258,16 @@ subroutine cnc_ck(this) call this%parser%StoreErrorUnit() end if ! - ! -- return + ! -- Return return end subroutine cnc_ck + !> @brief Override bnd_fc and do nothing + !! + !! For constant concentration/temperature boundary type, the call to bnd_fc + !! needs to be overwritten to prevent logic found therein from being applied + !< subroutine cnc_fc(this, rhs, ia, idxglo, matrix_sln) -! ************************************************************************** -! cnc_fc -- Override bnd_fc and do nothing -! ************************************************************************** -! -! SPECIFICATIONS: -! -------------------------------------------------------------------------- ! -- dummy class(TspCncType) :: this real(DP), dimension(:), intent(inout) :: rhs @@ -288,17 +277,16 @@ subroutine cnc_fc(this, rhs, ia, idxglo, matrix_sln) ! -- local ! -------------------------------------------------------------------------- ! - ! -- return + ! -- Return return end subroutine cnc_fc + !> @brief Calculate flow associated with constant concentration/tempearture + !! boundary + !! + !! This method overrides bnd_cq() + !< subroutine cnc_cq(this, x, flowja, iadv) -! ****************************************************************************** -! cnc_cq -- Calculate constant concenration flow. This method overrides bnd_cq(). -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspCncType), intent(inout) :: this @@ -359,7 +347,7 @@ subroutine cnc_cq(this, x, flowja, iadv) ! end if ! - ! -- return + ! -- Return return end subroutine cnc_cq @@ -380,27 +368,20 @@ subroutine cnc_bd(this, model_budget) integer(I4B) :: isuppress_output ! ------------------------------------------------------------------------------ isuppress_output = 0 -!! ! -!! do n = 1, size(this%ratecncin) -!! this%ratecncin(n) = this%ratecncin(n) * this%eqnsclfac -!! end do -!! do n = 1, size(this%ratecncout) -!! this%ratecncout(n) = this%ratecncout(n) * this%eqnsclfac -!! end do -!! ! call rate_accumulator(this%ratecncin(1:this%nbound), ratin, dum) call rate_accumulator(this%ratecncout(1:this%nbound), ratout, dum) call model_budget%addentry(ratin, ratout, delt, this%text, & isuppress_output, this%packName) + ! + ! -- Return + return end subroutine cnc_bd + !> @brief Deallocate memory + !! + !! Method to deallocate memory for the package. + !< subroutine cnc_da(this) -! ****************************************************************************** -! cnc_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -417,18 +398,17 @@ subroutine cnc_da(this) ! -- pointers nullify (this%gwecommon) ! - ! -- return + ! -- Return return end subroutine cnc_da + !> @brief Define labels used in list file + !! + !! 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(TspCncType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! @@ -450,40 +430,34 @@ 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 Procedure related to observation processing + !! + !! This routine: + !! - returns true because the CNC package supports observations, + !! - overrides packagetype%_obs_supported() logical function cnc_obs_supported(this) -! ****************************************************************************** -! cnc_obs_supported -! -- Return true because CNC package supports observations. -! -- Overrides packagetype%_obs_supported() -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspCncType) :: this ! ------------------------------------------------------------------------------ ! cnc_obs_supported = .true. ! - ! -- return + ! -- Return return end function cnc_obs_supported + !> @brief Procedure related to observation processing + !! + !! This routine: + !! - defines observations + !! - stores observation types supported by the CNC package, + !! - overrides BndType%bnd_df_obs + !< subroutine cnc_df_obs(this) -! ****************************************************************************** -! cnc_df_obs (implements bnd_df_obs) -! -- Store observation type supported by CNC package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspCncType) :: this ! -- local @@ -493,21 +467,17 @@ subroutine cnc_df_obs(this) call this%obs%StoreObsType('cnc', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor ! - ! -- return + ! -- Return return end subroutine cnc_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 CNC package, variable CONCENTRATION or TEMPERATURE can be controlled + !! by time series. + !< subroutine cnc_rp_ts(this) -! ****************************************************************************** -! -- Assign tsLink%Text appropriately for all time series in use by package. -! In CNC package variable CONCENTRATION or TEMPERATURE can be controlled -! by time series. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspCncType), intent(inout) :: this ! -- local @@ -526,7 +496,7 @@ subroutine cnc_rp_ts(this) end if end do ! - ! -- return + ! -- Return return end subroutine cnc_rp_ts From 3d386bf78a5324142c0e213d464768fac9e36fbb Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 13:18:21 -0700 Subject: [PATCH 158/212] tsp1fmi1.f90 doxygen compliance. --- src/Model/TransportModel/tsp1fmi1.f90 | 261 ++++++++++---------------- 1 file changed, 98 insertions(+), 163 deletions(-) diff --git a/src/Model/TransportModel/tsp1fmi1.f90 b/src/Model/TransportModel/tsp1fmi1.f90 index 889e9777dc8..9727da9b44d 100644 --- a/src/Model/TransportModel/tsp1fmi1.f90 +++ b/src/Model/TransportModel/tsp1fmi1.f90 @@ -100,13 +100,9 @@ module TspFmiModule contains + !> @breif Create a new FMI object + !< subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) -! ****************************************************************************** -! fmi_cr -- Create a new FMI object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(TspFmiType), pointer :: fmiobj character(len=*), intent(in) :: name_model @@ -146,13 +142,9 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) return end subroutine fmi_cr + !> @brief Define FMI package + !< subroutine fmi_df(this, dis, inssm, idryinactive) -! ****************************************************************************** -! fmi_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: store_error ! -- dummy @@ -222,13 +214,9 @@ subroutine fmi_df(this, dis, inssm, idryinactive) return end subroutine fmi_df + !> @brief Allocate and Read routine for FMI object + !< subroutine fmi_ar(this, ibound) -! ****************************************************************************** -! fmi_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: store_error ! -- dummy @@ -248,13 +236,9 @@ subroutine fmi_ar(this, ibound) return end subroutine fmi_ar + !> @brief Read and prepare for FMI object + !< subroutine fmi_rp(this, inmvr) -! ****************************************************************************** -! fmi_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kper, kstp ! -- dummy @@ -285,13 +269,8 @@ subroutine fmi_rp(this, inmvr) return end subroutine fmi_rp + !> @brief Advance routine for FMI object subroutine fmi_ad(this, cnew) -! ****************************************************************************** -! fmi_ad -- advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: DHDRY ! -- dummy @@ -337,13 +316,10 @@ subroutine fmi_ad(this, cnew) return end subroutine fmi_ad + !> @brief Calculate coefficients and fill matrix and rhs terms associated + !! with FMI object + !< subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) -! ****************************************************************************** -! fmi_fc -- Calculate coefficients and fill matrix and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules !use BndModule, only: BndType, GetBndFromList ! -- dummy @@ -377,13 +353,12 @@ subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs) return end subroutine fmi_fc + !> @brief Calculate flow correction + !! + !! Where there is a flow imbalance for a given cell, a correction may be + !! applied if selected + !< subroutine fmi_cq(this, cnew, flowja) -! ****************************************************************************** -! fmi_cq -- Calculate flow correction -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspFmiType) :: this @@ -414,13 +389,9 @@ subroutine fmi_cq(this, cnew, flowja) return end subroutine fmi_cq + !> @brief Calculate budget terms associated with FMI object + !< subroutine fmi_bd(this, isuppress_output, model_budget) -! ****************************************************************************** -! mst_bd -- Calculate budget terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: delt use BudgetModule, only: BudgetType, rate_accumulator @@ -443,13 +414,9 @@ subroutine fmi_bd(this, isuppress_output, model_budget) return end subroutine fmi_bd + !> @brief Save budget terms associated with FMI object + !< subroutine fmi_ot_flow(this, icbcfl, icbcun) -! ****************************************************************************** -! fmi_ot_flow -- Save budget terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspFmiType) :: this integer(I4B), intent(in) :: icbcfl @@ -489,13 +456,11 @@ subroutine fmi_ot_flow(this, icbcfl, icbcun) return end subroutine fmi_ot_flow + !> @brief Deallocate memory + !! + !! Deallocate memory associated with FMI object + !< subroutine fmi_da(this) -! ****************************************************************************** -! fmi_da -- Deallocate variables -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -548,13 +513,11 @@ subroutine fmi_da(this) return end subroutine fmi_da + !> @ brief Allocate scalars + !! + !! Allocate scalar variables for an FMI object + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy @@ -597,13 +560,11 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @ brief Allocate arrays for FMI object + !! + !! Method to allocate arrays for the FMI package. + !< subroutine allocate_arrays(this, nodes) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use MemoryManagerModule, only: mem_allocate !modules use ConstantsModule, only: DZERO @@ -761,14 +722,12 @@ subroutine set_active_status(this, cnew) return end subroutine set_active_status + !> @brief Calculate the previous saturation level + !! + !! Calculate the groundwater cell head saturation for the end of + !! the last time step + !< function gwfsatold(this, n, delt) result(satold) -! ****************************************************************************** -! gwfsatold -- calculate the groundwater cell head saturation for the end of -! the last time step -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspFmiType) :: this @@ -847,18 +806,14 @@ subroutine read_options(this) write (this%iout, '(1x,a)') 'END OF FMI OPTIONS' end if ! - ! -- return + ! -- Return return end subroutine read_options + !> @brief Read PACKAGEDATA block + !! + !! Read packagedata block from input file subroutine read_packagedata(this) -! ****************************************************************************** -! read_packagedata -- Read PACKAGEDATA block -! Subroutine: (1) read packagedata block from input file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use OpenSpecModule, only: ACCESS, FORM use ConstantsModule, only: LINELENGTH, DEM6, LENPACKAGENAME @@ -984,7 +939,7 @@ subroutine read_packagedata(this) write (this%iout, '(1x,a)') 'END OF FMI PACKAGEDATA' end if ! - ! -- return + ! -- Return return end subroutine read_packagedata @@ -1019,13 +974,9 @@ subroutine set_aptbudobj_pointer(this, name, budobjptr) return end subroutine set_aptbudobj_pointer + !> @brief Initial the budget file reader + !< subroutine initialize_bfr(this) -! ****************************************************************************** -! initialize_bfr -- initalize the budget file reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules class(TspFmiType) :: this ! -- dummy @@ -1037,16 +988,17 @@ subroutine initialize_bfr(this) ! ! -- todo: need to run through the budget terms ! and do some checking + ! + ! -- Return + return end subroutine initialize_bfr + !> @brief Advance the budget file reader + !! + !! Advance the budget file reader by reading the next chunk of information + !! for the current time step and stress period + !< subroutine advance_bfr(this) -! ****************************************************************************** -! advance_bfr -- advance the budget file reader by reading the next chunk -! of information for the current time step and stress period -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper ! -- dummy @@ -1186,15 +1138,14 @@ subroutine advance_bfr(this) ! -- set the flag to indicate that flows were not updated this%iflowsupdated = 0 end if + ! + ! -- Return + return end subroutine advance_bfr + !> @brief Final the budget file reader + !< subroutine finalize_bfr(this) -! ****************************************************************************** -! finalize_bfr -- finalize the budget file reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules class(TspFmiType) :: this ! -- dummy @@ -1205,13 +1156,9 @@ subroutine finalize_bfr(this) ! end subroutine finalize_bfr + !> @brief Initialize the head file reader + !< subroutine initialize_hfr(this) -! ****************************************************************************** -! initialize_hfr -- initalize the head file reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules class(TspFmiType) :: this ! -- dummy @@ -1222,15 +1169,14 @@ subroutine initialize_hfr(this) ! ! -- todo: need to run through the head terms ! and do some checking + ! + ! -- Return + return end subroutine initialize_hfr + !> @brief Advance the head file reader + !< subroutine advance_hfr(this) -! ****************************************************************************** -! advance_hfr -- advance the head file reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper class(TspFmiType) :: this @@ -1319,15 +1265,14 @@ subroutine advance_hfr(this) else write (this%iout, fmthdskstpkper) kstp, kper, this%hfr%kstp, this%hfr%kper end if + ! + ! -- Return + return end subroutine advance_hfr + !> @brief Finalize the head file reader + !< subroutine finalize_hfr(this) -! ****************************************************************************** -! finalize_hfr -- finalize the head file reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules class(TspFmiType) :: this ! -- dummy @@ -1336,16 +1281,17 @@ subroutine finalize_hfr(this) ! -- Finalize the head file reader close (this%iuhds) ! + ! -- Return + return end subroutine finalize_hfr + !> @brief Initialize the groundwater flow terms based on the budget file + !! reader + !! + !! Initalize terms and figure out how many different terms and packages + !! are contained within the file + !< subroutine initialize_gwfterms_from_bfr(this) -! ****************************************************************************** -! initialize_gwfterms_from_bfr -- initalize terms and figure out how many -! different terms and packages are contained within the file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, store_error_unit, count_errors @@ -1440,18 +1386,15 @@ subroutine initialize_gwfterms_from_bfr(this) call this%parser%StoreErrorUnit() end if ! - ! -- return + ! -- Return return end subroutine initialize_gwfterms_from_bfr + !> @brief Initialize groundwater flow terms from the groundwater budget + !! + !! Flows are coming from a gwf-gwt exchange object + !< subroutine initialize_gwfterms_from_gwfbndlist(this) -! ****************************************************************************** -! initialize_gwfterms_from_gwfbndlist -- flows are coming from a gwf-gwt -! exchange -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use BndModule, only: BndType, GetBndFromList ! -- dummy @@ -1515,18 +1458,17 @@ subroutine initialize_gwfterms_from_gwfbndlist(this) iterm = iterm + 1 end if end do + ! + ! -- Return return end subroutine initialize_gwfterms_from_gwfbndlist + !> @brief Initialize an array for storing PackageBudget objects. + !! + !! This routine allocates gwfpackages to the proper size and initializes some + !! member variables. + !< subroutine allocate_gwfpackages(this, ngwfterms) -! ****************************************************************************** -! allocate_gwfpackages -- gwfpackages is an array of PackageBudget objects. -! This routine allocates gwfpackages to the proper size and initializes some -! member variables. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENMEMPATH use MemoryManagerModule, only: mem_allocate @@ -1560,17 +1502,14 @@ subroutine allocate_gwfpackages(this, ngwfterms) call this%gwfpackages(n)%initialize(memPath) end do ! - ! -- return + ! -- Return return end subroutine allocate_gwfpackages + !> @brief Deallocate memory + !! + !! Deallocate memory that stores the gwfpackages array subroutine deallocate_gwfpackages(this) -! ****************************************************************************** -! deallocate_gwfpackages -- memory in the gwfpackages array -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspFmiType) :: this @@ -1583,17 +1522,13 @@ subroutine deallocate_gwfpackages(this) call this%gwfpackages(n)%da() end do ! - ! -- return + ! -- Return return end subroutine deallocate_gwfpackages + !> @brief Find the package index for package called name + !< subroutine get_package_index(this, name, idx) -! ****************************************************************************** -! get_package_index -- find the package index for package called name -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use BndModule, only: BndType, GetBndFromList class(TspFmiType) :: this character(len=*), intent(in) :: name @@ -1615,7 +1550,7 @@ subroutine get_package_index(this, name, idx) terminate=.TRUE.) end if ! - ! -- return + ! -- Return return end subroutine get_package_index From 16bedfeb7d5165746d3a97dc66d6c69425400c42 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 13:22:06 -0700 Subject: [PATCH 159/212] tsp1ic1.f90 doxygen compliance --- src/Model/TransportModel/tsp1ic1.f90 | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Model/TransportModel/tsp1ic1.f90 b/src/Model/TransportModel/tsp1ic1.f90 index 7bc10e84162..572bd8a72ea 100644 --- a/src/Model/TransportModel/tsp1ic1.f90 +++ b/src/Model/TransportModel/tsp1ic1.f90 @@ -19,13 +19,9 @@ module TspIcModule contains + !> @brief Create a new initial conditions object + !< subroutine ic_cr(ic, name_model, inunit, iout, dis, tsplab) -! ****************************************************************************** -! ic_cr -- Create a new initial conditions object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(TspIcType), pointer :: ic type(TspLabelsType), pointer, intent(in) :: tsplab @@ -60,13 +56,11 @@ subroutine ic_cr(ic, name_model, inunit, iout, dis, tsplab) return end subroutine ic_cr + !> @brief Read initial conditions + !! + !! Read initial concentrations or temperatures depending on model type + !< subroutine read_data(this) -! ****************************************************************************** -! read_data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error From e48ed8c4a5b72bfa5ee56ee6c39ccde3bd88a1a1 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 13:55:05 -0700 Subject: [PATCH 160/212] tsp1mvt1.f90 doxygen compliance --- src/Model/TransportModel/tsp1mvt1.f90 | 197 +++++++++----------------- 1 file changed, 65 insertions(+), 132 deletions(-) diff --git a/src/Model/TransportModel/tsp1mvt1.f90 b/src/Model/TransportModel/tsp1mvt1.f90 index c2a6a9d9268..e27a9cd0a8e 100644 --- a/src/Model/TransportModel/tsp1mvt1.f90 +++ b/src/Model/TransportModel/tsp1mvt1.f90 @@ -61,16 +61,12 @@ module TspMvtModule procedure, private :: mvt_print_outputtab end type TspMvtType -contains + contains + !> @brief Create a new mover transport object + !< subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge note: does this need tsplab? gwfmodelname1, gwfmodelname2, fmi2) -! ****************************************************************************** -! mvt_cr -- Create a new initial conditions object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(TspMvtType), pointer :: mvt character(len=*), intent(in) :: name_model @@ -122,13 +118,9 @@ subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge not return end subroutine mvt_cr + !> @brief Define mover transport object + !< subroutine mvt_df(this, dis) -! ****************************************************************************** -! mvt_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspMvtType) :: this @@ -172,13 +164,9 @@ subroutine set_pointer_mvrbudobj(this, mvrbudobj) this%mvrbudobj => mvrbudobj end subroutine set_pointer_mvrbudobj + !> @brief Allocate and read mover-for-transport information + !< subroutine mvt_ar(this) -! ****************************************************************************** -! mvt_ar -- Allocate and read water mover information -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspMvtType) :: this @@ -192,13 +180,9 @@ subroutine mvt_ar(this) return end subroutine mvt_ar + !> @brief Read and prepare mover transport object + !< subroutine mvt_rp(this) -! ****************************************************************************** -! mvt_rp -- Read and prepare -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kper, kstp ! -- dummy @@ -229,19 +213,15 @@ subroutine mvt_rp(this) return end subroutine mvt_rp + !> @brief Calculate coefficients and fill amat and rhs + !! + !! The mvt package adds the mass flow rate to the provider qmfrommvr array. + !! The advanced packages know enough to subract any mass that is leaving, so + !! the mvt just adds mass coming in from elsewhere. Because the movers + !! change by stress period, their solute effects must be added to the right- + !! hand side of the transport matrix equations. + !< subroutine mvt_fc(this, cnew1, cnew2) -! ****************************************************************************** -! mvt_fc -- Calculate coefficients and fill amat and rhs -! -! The mvt package adds the mass flow rate to the provider qmfrommvr -! array. The advanced packages know enough to subract any mass that is -! leaving, so the mvt just adds mass coming in from elsewhere. Because the -! movers change change by stress period, their solute effects must be -! added to the right-hand side of the gwt matrix equations. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspMvtType) :: this @@ -330,13 +310,12 @@ end subroutine mvt_fc !> @ brief Set the fmi_pr and fmi_rc pointers !! - !! The fmi_pr and fmi_rc arguments are pointers to the provider - !! and receiver FMI Packages. If this MVT Package is owned by - !! a single GWT model, then these pointers are both set to the - !! FMI Package of this GWT model's FMI Package. If this MVT - !! Package is owned by a GWTGWT Exchange, then the fmi_pr and - !! fmi_rc pointers may be assigned to FMI Packages in different models. - !! + !! The fmi_pr and fmi_rc arguments are pointers to the provider and receiver + !! FMI Packages. If this MVT Package is owned by a single GWT model, then + !! these pointers are both set to the FMI Package of this GWT model's FMI + !! package. If this MVT package is owned by a GWTGWT exchange, then the + !! fmi_pr and fmi_rc pointers may be assigned to FMI Packages in different + !! models. !< subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) ! -- dummy @@ -394,17 +373,14 @@ subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) print *, 'Could not find FMI Package...' stop "error in set_fmi_pr_rc" end if - + ! + ! -- Return return end subroutine set_fmi_pr_rc + !> @brief Extra convergence check for mover + !< subroutine mvt_cc(this, kiter, iend, icnvgmod, cpak, dpak) -! ****************************************************************************** -! mvt_cc -- extra convergence check for mover -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspMvtType) :: this integer(I4B), intent(in) :: kiter @@ -428,17 +404,13 @@ subroutine mvt_cc(this, kiter, iend, icnvgmod, cpak, dpak) end if end if ! - ! -- return + ! -- Return return end subroutine mvt_cc + !> @brief Write mover terms to listing file + !< subroutine mvt_bd(this, cnew1, cnew2) -! ****************************************************************************** -! mvt_bd -- Write mover terms to listing file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspMvtType) :: this @@ -450,17 +422,13 @@ subroutine mvt_bd(this, cnew1, cnew2) ! -- fill the budget object call this%mvt_fill_budobj(cnew1, cnew2) ! - ! -- return + ! -- Return return end subroutine mvt_bd + !> @brief Write mover budget terms + !< subroutine mvt_ot_saveflow(this, icbcfl, ibudfl) -! ****************************************************************************** -! mvt_bd -- Write mover terms -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper, delt, pertim, totim ! -- dummy @@ -486,13 +454,9 @@ subroutine mvt_ot_saveflow(this, icbcfl, ibudfl) return end subroutine mvt_ot_saveflow + !> @brief Print mover flow table + !< subroutine mvt_ot_printflow(this, icbcfl, ibudfl) -! ****************************************************************************** -! mvr_ot_printflow -- Print mover flow table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspMvtType) :: this @@ -510,13 +474,9 @@ subroutine mvt_ot_printflow(this, icbcfl, ibudfl) return end subroutine mvt_ot_printflow + !> @brief Write mover budget to listing file + !< subroutine mvt_ot_bdsummary(this, ibudfl) -! ****************************************************************************** -! mvt_ot_bdsummary -- Write mover budget to listing file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper, delt, totim use ArrayHandlersModule, only: ifind, expandarray @@ -587,13 +547,12 @@ subroutine mvt_ot_bdsummary(this, ibudfl) return end subroutine mvt_ot_bdsummary + + !> @ brief Deallocate memory + !! + !! Method to deallocate memory for the package. + !< subroutine mvt_da(this) -! ****************************************************************************** -! mvt_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -639,13 +598,11 @@ subroutine mvt_da(this) return end subroutine mvt_da + !> @ brief Allocate scalar variables for package + !! + !! Method to allocate scalar variables for the MVT package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr ! -- dummy @@ -670,13 +627,9 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Read mover-for-transport options block + !< subroutine read_options(this) -! ****************************************************************************** -! read_options -- Read Options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use OpenSpecModule, only: access, form use InputOutputModule, only: getunit, openfile @@ -752,17 +705,13 @@ subroutine read_options(this) write (this%iout, '(1x,a)') 'END OF MVT OPTIONS' end if ! - ! -- return + ! -- Return return end subroutine read_options + !> @brief Set up the budget object that stores all the mvr flows + !< subroutine mvt_setup_budobj(this) -! ****************************************************************************** -! mvt_setup_budobj -- Set up the budget object that stores all the mvr flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -803,19 +752,14 @@ subroutine mvt_setup_budobj(this) maxlist, .false., .false., & naux) end do - ! - ! -- return + ! -- Return return end subroutine mvt_setup_budobj + !> @brief Copy mover-for-transport flow terms into this%budobj + !< subroutine mvt_fill_budobj(this, cnew1, cnew2) -! ****************************************************************************** -! mvt_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(TspMvtType) :: this @@ -880,18 +824,16 @@ subroutine mvt_fill_budobj(this, cnew1, cnew2) ! --Terms are filled, now accumulate them for this time step call this%budobj%accumulate_terms() ! - ! -- return + ! -- Return return end subroutine mvt_fill_budobj + !> @brief Determine max number of packages in use + !! + !! Scan through the gwf water mover budget object and determine the maximum + !! number of packages and unique package names + !< subroutine mvt_scan_mvrbudobj(this) -! ****************************************************************************** -! mvt_scan_mvrbudobj -- scan through the gwf water mover budget object and -! determine the maximum number of packages and unique package names -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ class(TspMvtType) :: this integer(I4B) :: nbudterm integer(I4B) :: maxpackages @@ -936,13 +878,9 @@ subroutine mvt_scan_mvrbudobj(this) return end subroutine mvt_scan_mvrbudobj + !> @brief Set up the mover-for-transport output table + !< subroutine mvt_setup_outputtab(this) -! ****************************************************************************** -! mvt_setup_outputtab -- set up output table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspMvtType), intent(inout) :: this ! -- local @@ -985,17 +923,12 @@ subroutine mvt_setup_outputtab(this) end if ! - ! -- return + ! -- Return return end subroutine mvt_setup_outputtab + !> @brief Set up mover-for-transport output table subroutine mvt_print_outputtab(this) -! ****************************************************************************** -! mvt_print_outputtab -- set up output table -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- module use TdisModule, only: kstp, kper ! -- dummy @@ -1046,7 +979,7 @@ subroutine mvt_print_outputtab(this) end do end do ! - ! -- return + ! -- Return return end subroutine mvt_print_outputtab From 44f5d7e792fb819b06d9ee47353fcacced320d37 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 14:57:02 -0700 Subject: [PATCH 161/212] tsp1obs1.f90 doxygen compliance --- src/Model/TransportModel/tsp1obs1.f90 | 95 +++++++++++---------------- 1 file changed, 40 insertions(+), 55 deletions(-) diff --git a/src/Model/TransportModel/tsp1obs1.f90 b/src/Model/TransportModel/tsp1obs1.f90 index c0d7bcc3e58..4dd8dfa4958 100644 --- a/src/Model/TransportModel/tsp1obs1.f90 +++ b/src/Model/TransportModel/tsp1obs1.f90 @@ -29,18 +29,16 @@ module TspObsModule procedure, private :: set_pointers end type TspObsType -contains + contains + !> @brief Create a new TspObsType object + !! + !! This routine: + !! - creates an observation object + !! - allocates pointers + !! - initializes values + !< subroutine tsp_obs_cr(obs, inobs) -! ****************************************************************************** -! tsp_obs_cr -- Create a new TspObsType object -! Subroutine: (1) creates object -! (2) allocates pointers -! (3) initializes values -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(TspObsType), pointer, intent(out) :: obs integer(I4B), pointer, intent(in) :: inobs @@ -52,16 +50,15 @@ subroutine tsp_obs_cr(obs, inobs) obs%inputFilename = '' obs%inUnitObs => inobs ! + ! -- Return return end subroutine tsp_obs_cr + !> @brief Allocate and read method for package + !! + !! Method to allocate and read static data for the package. + !< subroutine tsp_obs_ar(this, ic, x, flowja) -! ****************************************************************************** -! tsp_obs_ar -- allocate and read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspObsType), intent(inout) :: this type(TspIcType), pointer, intent(in) :: ic @@ -75,16 +72,13 @@ subroutine tsp_obs_ar(this, ic, x, flowja) ! set pointers call this%set_pointers(ic, x, flowja) ! + ! -- Return return end subroutine tsp_obs_ar + !> @brief Define observation object + !< subroutine tsp_obs_df(this, iout, pkgname, filtyp, dis) -! ****************************************************************************** -! tsp_obs_df -- define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspObsType), intent(inout) :: this integer(I4B), intent(in) :: iout @@ -109,16 +103,13 @@ subroutine tsp_obs_df(this, iout, pkgname, filtyp, dis) call this%StoreObsType('flow-ja-face', .true., indx) this%obsData(indx)%ProcessIdPtr => tsp_process_intercell_obs_id ! + ! -- Return return end subroutine tsp_obs_df + !> @brief Save observations + !< subroutine tsp_obs_bd(this) -! ****************************************************************************** -! tsp_obs_bd -- save obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspObsType), intent(inout) :: this ! -- local @@ -148,30 +139,25 @@ subroutine tsp_obs_bd(this) end do end if ! + ! -- Return return end subroutine tsp_obs_bd + !> @brief If transport model observations need checks, add them here + !< subroutine tsp_obs_rp(this) -! ****************************************************************************** -! tsp_obs_rp -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + ! -- dummy class(TspObsType), intent(inout) :: this ! ------------------------------------------------------------------------------ ! - ! Do GWT observations need any checking? If so, add checks here + ! -- Return return end subroutine tsp_obs_rp + !> Deallocate memory + !! + !! Deallocate memory associated with transport model subroutine tsp_obs_da(this) -! ****************************************************************************** -! tsp_obs_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(TspObsType), intent(inout) :: this ! ------------------------------------------------------------------------------ @@ -181,9 +167,12 @@ subroutine tsp_obs_da(this) nullify (this%flowja) call this%ObsType%obs_da() ! + ! -- Return return end subroutine tsp_obs_da + !> @brief Set pointers needed by the transport OBS package + !< subroutine set_pointers(this, ic, x, flowja) ! ****************************************************************************** ! set_pointers @@ -205,15 +194,11 @@ subroutine set_pointers(this, ic, x, flowja) return end subroutine set_pointers - ! -- Procedures related to GWF observations (NOT type-bound) - + !> @brief Procedure related to Tsp observations (NOT type-bound) + !! + !! Process a specific observation ID + !< subroutine gwt_process_concentration_obs_id(obsrv, dis, inunitobs, iout) -! ****************************************************************************** -! gwt_process_concentration_obs_id -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(ObserveType), intent(inout) :: obsrv class(DisBaseType), intent(in) :: dis @@ -242,16 +227,15 @@ subroutine gwt_process_concentration_obs_id(obsrv, dis, inunitobs, iout) call store_error_unit(inunitobs) end if ! + ! -- Return return end subroutine gwt_process_concentration_obs_id + !> @brief Procedure related to Tsp observations (NOT type-bound) + !! + !! Process an intercell observation requested by the user + !< subroutine tsp_process_intercell_obs_id(obsrv, dis, inunitobs, iout) -! ****************************************************************************** -! tsp_process_intercell_obs_id -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy type(ObserveType), intent(inout) :: obsrv class(DisBaseType), intent(in) :: dis @@ -304,6 +288,7 @@ subroutine tsp_process_intercell_obs_id(obsrv, dis, inunitobs, iout) call store_error_unit(inunitobs) end if ! + ! -- Return return end subroutine tsp_process_intercell_obs_id From 7e34050c714986b294a9738786e40ed267038010 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 15:45:07 -0700 Subject: [PATCH 162/212] gwt1uzt1.f90 doxygen compliance. Other minor touch-up --- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 2 +- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 4 +- src/Model/GroundWaterTransport/gwt1uzt1.f90 | 220 ++++++++------------ src/Model/TransportModel/tsp1ssm1.f90 | 35 +--- 4 files changed, 97 insertions(+), 164 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index d5b8f1b7d29..642f39e2426 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -529,7 +529,7 @@ subroutine mst_ot_flow(this, icbcfl, icbcun) return end subroutine mst_ot_flow - !> @ brief Deallocate + !> @brief Deallocate memory !! !! Method to deallocate memory for the package. !< diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index dacaad05d07..7322221ca18 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -1074,7 +1074,7 @@ end subroutine uze_infl_term !! Accounts for energy that is added to the model from specifying an !! infiltration rate and temperature, but is subsequently removed from !! the model as that portion of the infiltration that is rejected (and - !! transferred to another advanced package via the MVR/MVT packages. + !! NOT transferred to another advanced package via the MVR/MVT packages). !< subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) @@ -1295,6 +1295,7 @@ subroutine uze_df_obs(this) call this%obs%StoreObsType('thermal-equil', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine uze_df_obs @@ -1368,6 +1369,7 @@ subroutine uze_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine uze_bd_obs diff --git a/src/Model/GroundWaterTransport/gwt1uzt1.f90 b/src/Model/GroundWaterTransport/gwt1uzt1.f90 index 03e27800853..623c0be3356 100644 --- a/src/Model/GroundWaterTransport/gwt1uzt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1uzt1.f90 @@ -77,14 +77,10 @@ module GwtUztModule contains + !> @brief Create a new UZT package + !< subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi) -! ****************************************************************************** -! uzt_create -- Create a New UZT Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -124,17 +120,13 @@ subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages uztobj%fmi => fmi ! - ! -- return + ! -- Return return end subroutine uzt_create + !> @brief Find corresponding uzt package + !< subroutine find_uzt_package(this) -! ****************************************************************************** -! find corresponding uzt package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -249,14 +241,12 @@ subroutine find_uzt_package(this) return end subroutine find_uzt_package + !> @brief Add matrix terms related to UZT + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for this package + !< subroutine uzt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! uzt_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for this package -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtUztType) :: this @@ -321,14 +311,11 @@ subroutine uzt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine uzt_fc_expanded + !> @brief Explicit solve + !! + !! Add terms specific to the unsaturated zone to the explicit unsaturated- + !! zone solve subroutine uzt_solve(this) -! ****************************************************************************** -! uzt_solve -- add terms specific to the unsaturated zone to the explicit -! unsaturated-zone solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtUztType) :: this ! -- local @@ -373,14 +360,11 @@ subroutine uzt_solve(this) return end subroutine uzt_solve + !> @brief Function that returns the number of budget terms for this package + !! + !! This overrides function in parent. + !< function uzt_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! uzt_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtUztType) :: this @@ -400,14 +384,9 @@ function uzt_get_nbudterms(this) result(nbudterms) return end function uzt_get_nbudterms + !> @brief Set up the budget object that stores all the unsaturated-zone flows + !< subroutine uzt_setup_budobj(this, idx) -! ****************************************************************************** -! uzt_setup_budobj -- Set up the budget object that stores all the unsaturated- -! zone flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -418,7 +397,7 @@ subroutine uzt_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- Infiltration flux text = ' INFILTRATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudinfl)%maxlist @@ -430,9 +409,8 @@ subroutine uzt_setup_budobj(this, idx) this%packName, & maxlist, .false., .false., & naux) - ! - ! -- + ! -- Rejected infiltration flux (and subsequently removed from the model) if (this%idxbudrinf /= 0) then text = ' REJ-INF' idx = idx + 1 @@ -446,9 +424,8 @@ subroutine uzt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- + ! -- Evapotranspiration flux originating from the unsaturated zone if (this%idxbuduzet /= 0) then text = ' UZET' idx = idx + 1 @@ -462,9 +439,8 @@ subroutine uzt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- + ! -- Rejected infiltration flux that is transferred to the MVR/MVT packages if (this%idxbudritm /= 0) then text = ' INF-REJ-TO-MVR' idx = idx + 1 @@ -478,19 +454,13 @@ subroutine uzt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- return + ! -- Return return end subroutine uzt_setup_budobj + !> @brief Copy flow terms into this%budobj subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! uzt_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtUztType) :: this @@ -505,7 +475,7 @@ subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- INFILTRATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudinfl)%nlist @@ -515,7 +485,7 @@ subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- REJ-INF if (this%idxbudrinf /= 0) then idx = idx + 1 @@ -527,7 +497,7 @@ subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- UZET if (this%idxbuduzet /= 0) then idx = idx + 1 @@ -539,7 +509,7 @@ subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- REJ-INF-TO-MVR if (this%idxbudritm /= 0) then idx = idx + 1 @@ -551,19 +521,17 @@ subroutine uzt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - ! - ! -- return + ! + ! -- Return return end subroutine uzt_fill_budobj + !> @brief Allocate scalar variables for package + !! + !! Method to allocate scalar variables for the package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -590,13 +558,11 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays for package + !! + !! Method to allocate arrays for the package. + !< subroutine uzt_allocate_arrays(this) -! ****************************************************************************** -! uzt_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -623,13 +589,11 @@ subroutine uzt_allocate_arrays(this) return end subroutine uzt_allocate_arrays + !> @brief Deallocate memory + !! + !! Method to deallocate memory for the package. + !< subroutine uzt_da(this) -! ****************************************************************************** -! uzt_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -654,14 +618,13 @@ subroutine uzt_da(this) return end subroutine uzt_da + !> @brief Infiltration term + !! + !! Accounts for mass added to the subsurface via infiltration. For example, + !! mass entering the model domain via rainfall or irrigation. + !< subroutine uzt_infl_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uzt_infl_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtUztType) :: this integer(I4B), intent(in) :: ientry @@ -692,18 +655,19 @@ subroutine uzt_infl_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = r if (present(hcofval)) hcofval = h ! - ! -- return + ! -- Return return end subroutine uzt_infl_term + !> @brief Rejected infiltration term + !! + !! Accounts for mass that is added to the model from specifying an + !! infiltration rate and concentration, but is subsequently removed from + !! the model as that portion of the infiltration that is rejected (and + !! NOT transferred to another advanced package via the MVR/MVT packages). + !< subroutine uzt_rinf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uzt_rinf_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtUztType) :: this integer(I4B), intent(in) :: ientry @@ -724,18 +688,17 @@ subroutine uzt_rinf_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine uzt_rinf_term + !> @brief Evapotranspiration from the unsaturated-zone term + !! + !! Accounts for mass removed as a result of evapotranspiration from the + !! unsaturated zone. + !< subroutine uzt_uzet_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uzt_uzet_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtUztType) :: this integer(I4B), intent(in) :: ientry @@ -765,18 +728,19 @@ subroutine uzt_uzet_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! - ! -- return + ! -- Return return end subroutine uzt_uzet_term + !> @brief Rejected infiltration to MVR/MVT term + !! + !! Accounts for energy that is added to the model from specifying an + !! infiltration rate and temperature, but does not infiltrate into the + !! subsurface. This subroutine is called when the rejected infiltration + !! is transferred to another advanced package via the MVR/MVT packages. + !< subroutine uzt_ritm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! uzt_ritm_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtUztType) :: this integer(I4B), intent(in) :: ientry @@ -797,19 +761,17 @@ subroutine uzt_ritm_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine uzt_ritm_term + !> @brief Define UZT Observation + !! + !! This subroutine: + !! - Stores observation types supported by the parent APT package. + !! - Overrides BndType%bnd_df_obs + !< subroutine uzt_df_obs(this) -! ****************************************************************************** -! uzt_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtUztType) :: this @@ -871,13 +833,14 @@ subroutine uzt_df_obs(this) call this%obs%StoreObsType('rej-inf-to-mvr', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine uzt_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. + !! !< subroutine uzt_rp_obs(this, obsrv, found) ! -- dummy @@ -903,13 +866,9 @@ subroutine uzt_rp_obs(this, obsrv, found) return end subroutine uzt_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine uzt_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! uzt_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtUztType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -942,16 +901,13 @@ subroutine uzt_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine uzt_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine uzt_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! uzt_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GwtUztType), intent(inout) :: this @@ -1001,7 +957,7 @@ subroutine uzt_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine uzt_set_stressperiod diff --git a/src/Model/TransportModel/tsp1ssm1.f90 b/src/Model/TransportModel/tsp1ssm1.f90 index 4e1021c1a64..0b354566d78 100644 --- a/src/Model/TransportModel/tsp1ssm1.f90 +++ b/src/Model/TransportModel/tsp1ssm1.f90 @@ -34,7 +34,6 @@ module TspSsmModule !! This derived type corresponds to the SSM Package, which adds !! the effects of groundwater sources and sinks to the solute transport !! equation. - !! !< type, extends(NumericalPackageType) :: TspSsmType @@ -83,7 +82,6 @@ module TspSsmModule !! !! Create a new SSM package by defining names, allocating scalars !! and initializing the parser. - !! !< subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, eqnsclfac, & gwecommon) @@ -133,7 +131,6 @@ end subroutine ssm_cr !! This routine is called from gwt_df(), but does not do anything because !! df is typically used to set up dimensions. For the ssm package, the !! total number of ssm entries is defined by the flow model. - !! !< subroutine ssm_df(this) ! -- modules @@ -151,7 +148,6 @@ end subroutine ssm_df !! !! This routine is called from gwt_ar(). It allocates arrays, reads !! options and data, and sets up the output table. - !! !< subroutine ssm_ar(this, dis, ibound, cnew) ! -- modules @@ -209,7 +205,6 @@ end subroutine ssm_ar !! each stress period. If any SPC input files are used to provide source !! and sink concentrations, then period blocks for the current stress period !! are read. - !! !< subroutine ssm_rp(this) ! -- modules @@ -240,7 +235,6 @@ end subroutine ssm_rp !! in this%nbound. Also, if any SPC input files are used to provide source !! and sink concentrations and time series are referenced in those files, !! then ssm concenrations must be interpolated for the time step. - !! !< subroutine ssm_ad(this) ! -- modules @@ -288,7 +282,6 @@ end subroutine ssm_ad !! and right-hand-side value for any package and package entry. It returns !! several different optional variables that are used throughout this !! package to update matrix terms, budget calculations, and output tables. - !! !< subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & cssm, qssm) @@ -363,10 +356,8 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! ! -- Add terms based on qbnd sign if (qbnd <= DZERO) then -!! hcoftmp = qbnd * omega hcoftmp = qbnd * omega * this%eqnsclfac else -!! rhstmp = -qbnd * ctmp * (DONE - omega) rhstmp = -qbnd * ctmp * (DONE - omega) * this%eqnsclfac end if ! @@ -376,12 +367,11 @@ subroutine ssm_term(this, ipackage, ientry, rrate, rhsval, hcofval, & ! -- set requested values if (present(hcofval)) hcofval = hcoftmp if (present(rhsval)) rhsval = rhstmp -!! if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) * this%eqnsclfac if (present(rrate)) rrate = (hcoftmp * ctmp - rhstmp) if (present(cssm)) cssm = ctmp if (present(qssm)) qssm = qbnd ! - ! -- return + ! -- Return return end subroutine ssm_term @@ -393,7 +383,6 @@ end subroutine ssm_term !! the SSM bound concentration (or temperature) based on these different !! approaches. The mixed flag indicates whether or not the boundary as a !! mixed type. - !! !< subroutine get_ssm_conc(this, ipackage, ientry, nbound_flow, conc, & lauxmixed) @@ -429,7 +418,6 @@ end subroutine get_ssm_conc !! !! This routine adds the effects of the SSM to the matrix equations by !! updating the a matrix and right-hand side vector. - !! !< subroutine ssm_fc(this, matrix_sln, idxglo, rhs) ! -- modules @@ -476,7 +464,6 @@ end subroutine ssm_fc !! Calulate the resulting mass flow between the boundary and the connected !! GWT model cell. Update the diagonal position of the flowja array so that !! it ultimately contains the solute balance residual. - !! !< subroutine ssm_cq(this, flowja) ! -- modules @@ -516,7 +503,6 @@ end subroutine ssm_cq !! !! Calculate the global SSM budget terms using separate in and out entries !! for each flow package. - !! !< subroutine ssm_bd(this, isuppress_output, model_budget) ! -- modules @@ -574,7 +560,6 @@ end subroutine ssm_bd !! Based on user-specified controls, print SSM mass flow rates to the GWT !! listing file and/or write the SSM mass flow rates to the GWT binary !! budget file. - !! !< subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) ! -- modules @@ -697,14 +682,13 @@ subroutine ssm_ot_flow(this, icbcfl, ibudfl, icbcun) end if end if ! - ! -- return + ! -- Return return end subroutine ssm_ot_flow !> @ brief Deallocate !! !! Deallocate the memory associated with this derived type - !! !< subroutine ssm_da(this) ! -- modules @@ -757,7 +741,6 @@ end subroutine ssm_da !> @ brief Allocate scalars !! !! Allocate scalar variables for this derived type - !! !< subroutine allocate_scalars(this) ! -- modules @@ -782,7 +765,6 @@ end subroutine allocate_scalars !> @ brief Allocate arrays !! !! Allocate array variables for this derived type - !! !< subroutine allocate_arrays(this) ! -- modules @@ -814,7 +796,6 @@ end subroutine allocate_arrays !> @ brief Read package options !! !! Read and set the SSM Package options - !! !< subroutine read_options(this) ! -- modules @@ -866,7 +847,6 @@ end subroutine read_options !> @ brief Read package data !! !! Read and set the SSM Package data - !! !< subroutine read_data(this) ! -- dummy @@ -884,7 +864,6 @@ end subroutine read_data !! !! Read SOURCES block and look for auxiliary columns in !! corresponding flow data. - !! !< subroutine read_sources_aux(this) ! -- dummy @@ -987,7 +966,6 @@ end subroutine read_sources_aux !! !! Read optional FILEINPUT block and initialize an !! SPC input file reader for each entry. - !! !< subroutine read_sources_fileinput(this) ! -- dummy @@ -1108,7 +1086,6 @@ end subroutine read_sources_fileinput !! through the auxiliary names in package ip and sets iauxpak !! to the column number corresponding to the correct auxiliary !! column. - !! !< subroutine set_iauxpak(this, ip, packname) ! -- dummy @@ -1142,7 +1119,7 @@ subroutine set_iauxpak(this, ip, packname) write (this%iout, '(4x, a, i0, a, a)') 'USING AUX COLUMN ', & iaux, ' IN PACKAGE ', trim(packname) ! - ! -- return + ! -- Return return end subroutine set_iauxpak @@ -1151,7 +1128,6 @@ end subroutine set_iauxpak !! The next call to parser will return the input file name for !! package ip in the SSM SOURCES block. The routine then !! initializes the SPC input file. - !! !< subroutine set_ssmivec(this, ip, packname) ! -- module @@ -1179,14 +1155,13 @@ subroutine set_ssmivec(this, ip, packname) trim(filename), ' TO SET ',trim(this%tsplab%depvartype),'S FOR PACKAGE ', & trim(packname) ! - ! -- return + ! -- Return return end subroutine set_ssmivec !> @ brief Setup the output table !! !! Setup the output table by creating the column headers. - !! !< subroutine pak_setup_outputtab(this) ! -- dummy @@ -1228,7 +1203,7 @@ subroutine pak_setup_outputtab(this) !end if end if ! - ! -- return + ! -- Return return end subroutine pak_setup_outputtab From 483bb6a2fb1d03450a4ad797f45b0230187e5ea5 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 16:00:27 -0700 Subject: [PATCH 163/212] gwt1src1.f90 doxygen compliance. Minor touch-up in gwe1src.f90 --- src/Model/GroundWaterEnergy/gwe1src1.f90 | 28 +++-- src/Model/GroundWaterTransport/gwt1src1.f90 | 130 +++++++++----------- 2 files changed, 75 insertions(+), 83 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index c9284d59a45..3d749bcb79d 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -41,9 +41,7 @@ module GweSrcModule !> @brief Create an energy source loading package !! - !! This subroutine: - !! - creates new-style package - !! - points bndobj to the new package + !! This subroutine points bndobj to the newly created package !< subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & tsplab, gwecommon) @@ -221,8 +219,9 @@ end subroutine src_fc !! PRINT_INPUT option is used. !< subroutine define_listlabel(this) -! ------------------------------------------------------------------------------ + ! -- dummy class(GweSrcType), intent(inout) :: this + ! -- local ! ------------------------------------------------------------------------------ ! ! -- create the header list label @@ -253,12 +252,15 @@ end subroutine define_listlabel !! This function: !! - returns true because SRC package supports observations. !! - overrides BndType%bnd_obs_supported() + !< logical function src_obs_supported(this) ! ------------------------------------------------------------------------------ implicit none class(GweSrcType) :: this ! ------------------------------------------------------------------------------ src_obs_supported = .true. + ! + ! -- Return return end function src_obs_supported @@ -269,13 +271,12 @@ end function src_obs_supported !! - overrides BndType%bnd_df_obs !< subroutine src_df_obs(this) - ! ------------------------------------------------------------------------------ implicit none ! -- dummy class(GweSrcType) :: this ! -- local integer(I4B) :: indx - ! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ call this%obs%StoreObsType('src', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => DefaultObsIdProcessor ! @@ -284,21 +285,23 @@ 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(GweSrcType), intent(inout) :: this ! -- local integer(I4B) :: i, nlinks type(TimeSeriesLinkType), pointer :: tslink => null() +! ------------------------------------------------------------------------------ ! nlinks = this%TsManager%boundtslinks%Count() do i = 1, nlinks @@ -310,6 +313,7 @@ subroutine src_rp_ts(this) end if end do ! + ! -- Return return end subroutine src_rp_ts diff --git a/src/Model/GroundWaterTransport/gwt1src1.f90 b/src/Model/GroundWaterTransport/gwt1src1.f90 index 47c0a089051..59af4ea233d 100644 --- a/src/Model/GroundWaterTransport/gwt1src1.f90 +++ b/src/Model/GroundWaterTransport/gwt1src1.f90 @@ -34,16 +34,12 @@ module GwtSrcModule contains + !> @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, & tsplab) -! ****************************************************************************** -! src_create -- Create a New Src Package -! Subroutine: (1) create new-style package -! (2) point bndobj to the new package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -82,17 +78,13 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! package has access to the assigned labels packobj%tsplab => tsplab ! - ! -- return + ! -- Return return end subroutine src_create + !> @brief Deallocate memory + !< subroutine src_da(this) -! ****************************************************************************** -! src_da -- deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -104,17 +96,15 @@ subroutine src_da(this) ! ! -- 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 @@ -127,19 +117,17 @@ 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, reset_mover) -! ****************************************************************************** -! src_cf -- Formulate the HCOF and RHS terms -! Subroutine: (1) skip if no sources -! (2) calculate hcof and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSrcType) :: this logical, intent(in), optional :: reset_mover @@ -171,16 +159,15 @@ subroutine src_cf(this, reset_mover) 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 @@ -210,19 +197,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 @@ -242,42 +229,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 ! @@ -286,22 +272,23 @@ 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 integer(I4B) :: i, nlinks type(TimeSeriesLinkType), pointer :: tslink => null() +! ------------------------------------------------------------------------------ ! nlinks = this%TsManager%boundtslinks%Count() do i = 1, nlinks @@ -313,6 +300,7 @@ subroutine src_rp_ts(this) end if end do ! + ! -- Return return end subroutine src_rp_ts From 3f283e6d4be7690431b768ae68c37599a5bbde29 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 16:27:39 -0700 Subject: [PATCH 164/212] gwt1sft1.f90 doxygen compliance. Minor touch-up in gwe1sfe1.f90 --- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 23 ++- src/Model/GroundWaterTransport/gwt1sft1.f90 | 203 ++++++++------------ 2 files changed, 86 insertions(+), 140 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index e4142047b7a..f6369646a0e 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -285,7 +285,6 @@ end subroutine find_sfe_package !! !! This will be called from TspAptType%apt_fc_expanded() !! in order to add matrix terms specifically for SFE - !! !< subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- modules @@ -397,7 +396,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine sfe_fc_expanded - !> @ brief Add terms specific to sfr to the explicit sfr solve + !> @ brief Add terms specific to sfr to the explicit sfe solve !< subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/useful if there's streambed conduction??? ! -- dummy @@ -685,7 +684,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if end do ! - ! -- return + ! -- Return return end subroutine sfe_fill_budobj @@ -752,12 +751,11 @@ subroutine sfe_allocate_arrays(this) this%tempiflw(n) = DZERO end do ! - ! ! -- Return return end subroutine sfe_allocate_arrays - !> @brief Deallocate + !> @brief Deallocate memory !< subroutine sfe_da(this) ! -- modules @@ -812,7 +810,7 @@ subroutine sfe_rain_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sfe_rain_term @@ -842,7 +840,7 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sfe_evap_term @@ -900,7 +898,7 @@ subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sfe_iflw_term @@ -930,7 +928,7 @@ subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine sfe_outf_term @@ -938,7 +936,6 @@ end subroutine sfe_outf_term !! !! Store the observation type supported by the APT package and overide !! BndType%bnd_df_obs - !! !< subroutine sfe_df_obs(this) ! -- modules @@ -1008,13 +1005,13 @@ subroutine sfe_df_obs(this) call this%obs%StoreObsType('ext-outflow', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine sfe_df_obs !> @brief Process package specific obs !! !! Method to process specific observations for this package. - !! !< subroutine sfe_rp_obs(this, obsrv, found) ! -- dummy @@ -1041,6 +1038,7 @@ subroutine sfe_rp_obs(this, obsrv, found) found = .false. end select ! + ! -- Return return end subroutine sfe_rp_obs @@ -1083,6 +1081,7 @@ subroutine sfe_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine sfe_bd_obs @@ -1163,7 +1162,7 @@ subroutine sfe_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine sfe_set_stressperiod diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index f956d08ba1e..0631ce08ce4 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -1,4 +1,4 @@ -! -- Stream Transport Module +! -- Stream Mass Transport Module ! -- todo: what to do about reactions in stream? Decay? ! -- todo: save the sft concentration into the sfr aux variable? ! -- todo: calculate the sfr DENSE aux variable using concentration? @@ -90,14 +90,10 @@ module GwtSftModule contains + !> @brief Create a new sft package + !< subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac) -! ****************************************************************************** -! sft_create -- Create a New SFT Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -146,17 +142,13 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! concentration vs temperature sftobj%tsplab => tsplab ! - ! -- return + ! -- Return return end subroutine sft_create - subroutine find_sft_package(this) -! ****************************************************************************** -! find corresponding sft package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> @brief Find corresponding sft package + !< + subroutine find_sft_package(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -274,14 +266,12 @@ subroutine find_sft_package(this) return end subroutine find_sft_package + !> @brief Add matrix terms related to SFT + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for SFT + !< subroutine sft_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! sft_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for SFT -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtSftType) :: this @@ -357,6 +347,8 @@ subroutine sft_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine sft_fc_expanded + !> @brief Add terms specific to sft to the explicit sft solve + !< subroutine sft_solve(this) ! ****************************************************************************** ! sft_solve -- add terms specific to sfr to the explicit sfr solve @@ -416,14 +408,11 @@ subroutine sft_solve(this) return end subroutine sft_solve + !> @brief Function to return the number of budget terms just for this package. + !! + !! This overrides a function in the parent class. + !< function sft_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! sft_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtSftType) :: this @@ -432,20 +421,16 @@ function sft_get_nbudterms(this) result(nbudterms) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- Number of budget terms is 6 + ! -- Number of budget terms is 5 nbudterms = 5 ! ! -- Return return end function sft_get_nbudterms + !> @brief Set up the budget object that stores all the sft flows + !< subroutine sft_setup_budobj(this, idx) -! ****************************************************************************** -! sft_setup_budobj -- Set up the budget object that stores all the sfr flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -521,17 +506,13 @@ subroutine sft_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- return + ! -- Return return end subroutine sft_setup_budobj + !> @brief Copy flow terms into this%budobj + !< subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! sft_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtSftType) :: this @@ -546,7 +527,7 @@ subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- RAIN idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist @@ -556,7 +537,7 @@ subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EVAPORATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist @@ -566,7 +547,7 @@ subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- RUNOFF idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist @@ -576,7 +557,7 @@ subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-INFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist @@ -586,7 +567,7 @@ subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-OUTFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist @@ -596,19 +577,15 @@ subroutine sft_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! - ! -- return + ! -- Return return end subroutine sft_fill_budobj + !> @brief Allocate scalars specific to the streamflow energy transport (SFE) + !! package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -637,13 +614,10 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays specific to the streamflow energy transport (SFE) + !! package. + !< subroutine sft_allocate_arrays(this) -! ****************************************************************************** -! sft_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -669,18 +643,13 @@ subroutine sft_allocate_arrays(this) this%conciflw(n) = DZERO end do ! - ! ! -- Return return end subroutine sft_allocate_arrays + !> @brief Deallocate memory + !< subroutine sft_da(this) -! ****************************************************************************** -! sft_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -708,14 +677,10 @@ subroutine sft_da(this) return end subroutine sft_da + !> @brief Rain term + !< subroutine sft_rain_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! sft_rain_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType) :: this integer(I4B), intent(in) :: ientry @@ -736,18 +701,14 @@ subroutine sft_rain_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sft_rain_term + !> @brief Evaporative term + !< subroutine sft_evap_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! sft_evap_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType) :: this integer(I4B), intent(in) :: ientry @@ -777,18 +738,14 @@ subroutine sft_evap_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! - ! -- return + ! -- Return return end subroutine sft_evap_term + !> @brief Runoff term + !< subroutine sft_roff_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! sft_roff_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType) :: this integer(I4B), intent(in) :: ientry @@ -809,18 +766,18 @@ subroutine sft_roff_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sft_roff_term + !> @brief Inflow Term + !! + !! Accounts for mass added via streamflow entering into a stream channel; + !! for example, energy entering the model domain via a specified flow in a + !! stream channel. + !< subroutine sft_iflw_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! sft_iflw_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType) :: this integer(I4B), intent(in) :: ientry @@ -841,18 +798,17 @@ subroutine sft_iflw_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sft_iflw_term + !> @brief Outflow term + !! + !! Accounts for the mass leaving a stream channel; for example, mass exiting the + !! model domain via a flow in a stream channel flowing out of the active domain. + !< subroutine sft_outf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! sft_outf_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType) :: this integer(I4B), intent(in) :: ientry @@ -873,19 +829,16 @@ subroutine sft_outf_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine sft_outf_term + !> @brief Observations + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !< subroutine sft_df_obs(this) -! ****************************************************************************** -! sft_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtSftType) :: this @@ -953,13 +906,13 @@ subroutine sft_df_obs(this) call this%obs%StoreObsType('ext-outflow', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine sft_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. !< subroutine sft_rp_obs(this, obsrv, found) ! -- dummy @@ -986,16 +939,13 @@ subroutine sft_rp_obs(this, obsrv, found) found = .false. end select ! + ! -- Return return end subroutine sft_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine sft_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! sft_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -1032,16 +982,13 @@ subroutine sft_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine sft_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine sft_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! sft_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GwtSftType), intent(inout) :: this @@ -1116,7 +1063,7 @@ subroutine sft_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine sft_set_stressperiod From 4926396f1024c9cd20c69bda0ba61893498f3466 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 5 Jun 2023 18:11:38 -0700 Subject: [PATCH 165/212] gwt1mwt1.f90 & gwe1mwe1.f90 doxygen compliance. --- src/Model/GroundWaterEnergy/gwe1mwe1.f90 | 121 +++++------- src/Model/GroundWaterTransport/gwt1mwt1.f90 | 195 +++++++------------- 2 files changed, 115 insertions(+), 201 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 index 12c8fc900f7..6dc62541edf 100644 --- a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 @@ -90,14 +90,10 @@ module GweMweModule contains + !> Create new MWE package + !< subroutine mwe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac, gwecommon) -! ****************************************************************************** -! mwe_create -- Create a New MWE Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -152,11 +148,11 @@ subroutine mwe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! vaporization for evaporative cooling. mweobj%gwecommon => gwecommon ! - ! -- return + ! -- Return return end subroutine mwe_create - !> @brief find corresponding mwe package + !> @brief Find corresponding mwe package !< subroutine find_mwe_package(this) ! -- modules @@ -277,9 +273,9 @@ subroutine find_mwe_package(this) end subroutine find_mwe_package !> @brief Add matrix terms related to MWE - !! - !! This routine is called from TspAptType%apt_fc_expanded() in - !! order to add matrix terms specifically for MWE + !! + !! This routine is called from TspAptType%apt_fc_expanded() in + !! order to add matrix terms specifically for MWE !< subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- modules @@ -380,14 +376,10 @@ subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine mwe_fc_expanded + !> @ brief Add terms specific to multi-aquifer wells to the explicit multi- + !! aquifer well energy transport solve + !< subroutine mwe_solve(this) -! ****************************************************************************** -! mwe_solve -- add terms specific to multi-aquifer wells to the explicit multi- -! aquifer well solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweMweType) :: this ! -- local @@ -432,14 +424,11 @@ subroutine mwe_solve(this) return end subroutine mwe_solve + !> @brief Function to return the number of budget terms just for this package + !! + !! This overrides a function in the parent class. + !< function mwe_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! mwe_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweMweType) :: this @@ -459,14 +448,9 @@ function mwe_get_nbudterms(this) result(nbudterms) return end function mwe_get_nbudterms + !> @brief Set up the budget object that stores all the mwe flows + !< subroutine mwe_setup_budobj(this, idx) -! ****************************************************************************** -! mwe_setup_budobj -- Set up the budget object that stores all the multi- -! aquifer well flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -557,7 +541,7 @@ subroutine mwe_setup_budobj(this, idx) call this%budobj%budterm(idx)%update_term(n1, n2, q) end do ! - ! -- return + ! -- Return return end subroutine mwe_setup_budobj @@ -658,17 +642,14 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if end do ! - ! -- return + ! -- Return return end subroutine mwe_fill_budobj + !> @brief Allocate scalars specific to the multi-aquifer well energy + !! transport (MWE) package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -697,13 +678,10 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays specific to the streamflow mass transport (SFT) + !! package. + !< subroutine mwe_allocate_arrays(this) -! ****************************************************************************** -! mwe_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -723,7 +701,6 @@ subroutine mwe_allocate_arrays(this) this%temprate(n) = DZERO end do ! - ! ! -- Return return end subroutine mwe_allocate_arrays @@ -790,12 +767,12 @@ subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = r * this%eqnsclfac if (present(hcofval)) hcofval = h * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine mwe_rate_term !> @brief Thermal transport matrix term(s) associcated with a flowing- - !! well rater term (mwe_fwrt_term) + !! well rate term associated with pumping (or injection) !< subroutine mwe_fwrt_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) @@ -819,7 +796,7 @@ subroutine mwe_fwrt_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine mwe_fwrt_term @@ -848,7 +825,7 @@ subroutine mwe_rtmv_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine mwe_rtmv_term @@ -877,19 +854,16 @@ subroutine mwe_frtm_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine mwe_frtm_term + !> @brief Observations + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !< subroutine mwe_df_obs(this) -! ****************************************************************************** -! mwe_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GweMweType) :: this @@ -950,13 +924,14 @@ subroutine mwe_df_obs(this) call this%obs%StoreObsType('fw-rate-to-mvr', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine mwe_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. + !! !< subroutine mwe_rp_obs(this, obsrv, found) ! -- dummy @@ -979,16 +954,13 @@ subroutine mwe_rp_obs(this, obsrv, found) found = .false. end select ! + ! -- Return return end subroutine mwe_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine mwe_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! mwe_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GweMweType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -1021,16 +993,13 @@ subroutine mwe_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine mwe_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine mwe_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! mwe_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GweMweType), intent(inout) :: this @@ -1068,7 +1037,7 @@ subroutine mwe_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine mwe_set_stressperiod diff --git a/src/Model/GroundWaterTransport/gwt1mwt1.f90 b/src/Model/GroundWaterTransport/gwt1mwt1.f90 index 264a2861b79..8af5bfc90b2 100644 --- a/src/Model/GroundWaterTransport/gwt1mwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mwt1.f90 @@ -86,14 +86,10 @@ module GwtMwtModule contains + !> Create new MWT package + !< subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac) -! ****************************************************************************** -! mwt_create -- Create a New MWT Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -142,17 +138,13 @@ subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Store pointer to governing equation scale factor mwtobj%eqnsclfac => eqnsclfac ! - ! -- return + ! -- Return return end subroutine mwt_create + !> @brief find corresponding mwt package + !< subroutine find_mwt_package(this) -! ****************************************************************************** -! find corresponding mwt package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -267,14 +259,12 @@ subroutine find_mwt_package(this) return end subroutine find_mwt_package + !> @brief Add matrix terms related to MWT + !! + !! This routine is called from TspAptType%apt_fc_expanded() in + !! order to add matrix terms specifically for MWT + !< subroutine mwt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! mwt_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for this package -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtMwtType) :: this @@ -339,14 +329,10 @@ subroutine mwt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine mwt_fc_expanded + !> @ brief Add terms specific to multi-aquifer wells to the explicit multi- + !! aquifer well solute transport solve + !< subroutine mwt_solve(this) -! ****************************************************************************** -! mwt_solve -- add terms specific to multi-aquifer wells to the explicit multi- -! aquifer well solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtMwtType) :: this ! -- local @@ -391,14 +377,11 @@ subroutine mwt_solve(this) return end subroutine mwt_solve + !> @brief Function to return the number of budget terms just for this package + !! + !! This overrides a function in the parent class. + !< function mwt_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! mwt_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtMwtType) :: this @@ -417,14 +400,9 @@ function mwt_get_nbudterms(this) result(nbudterms) return end function mwt_get_nbudterms + !> @brief Set up the budget object that stores all the mwt flows + !< subroutine mwt_setup_budobj(this, idx) -! ****************************************************************************** -! mwt_setup_budobj -- Set up the budget object that stores all the multi- -! aquifer well flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -495,19 +473,14 @@ subroutine mwt_setup_budobj(this, idx) maxlist, .false., .false., & naux) end if - ! - ! -- return + ! -- Return return end subroutine mwt_setup_budobj + !> @brief Copy flow terms into this%budobj + !< subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! mwt_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtMwtType) :: this @@ -522,7 +495,7 @@ subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- RATE idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrate)%nlist @@ -532,7 +505,7 @@ subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- FW-RATE if (this%idxbudfwrt /= 0) then idx = idx + 1 @@ -544,7 +517,7 @@ subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- RATE-TO-MVR if (this%idxbudrtmv /= 0) then idx = idx + 1 @@ -556,7 +529,7 @@ subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - + ! ! -- FW-RATE-TO-MVR if (this%idxbudfrtm /= 0) then idx = idx + 1 @@ -568,19 +541,15 @@ subroutine mwt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do end if - ! - ! -- return + ! -- Return return end subroutine mwt_fill_budobj + !> @brief Allocate scalars specific to the streamflow mass transport (SFT) + !! package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -607,13 +576,10 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays specific to the streamflow mass transport (SFT) + !! package. + !< subroutine mwt_allocate_arrays(this) -! ****************************************************************************** -! mwt_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -638,13 +604,9 @@ subroutine mwt_allocate_arrays(this) return end subroutine mwt_allocate_arrays + !> @brief Deallocate memory + !< subroutine mwt_da(this) -! ****************************************************************************** -! mwt_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -668,14 +630,10 @@ subroutine mwt_da(this) return end subroutine mwt_da + !> @brief Rate term associated with pumping (or injection) + !< subroutine mwt_rate_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwt_rate_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtMwtType) :: this integer(I4B), intent(in) :: ientry @@ -706,18 +664,15 @@ subroutine mwt_rate_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = r if (present(hcofval)) hcofval = h ! - ! -- return + ! -- Return return end subroutine mwt_rate_term + !> @brief Transport matrix term(s) associcated with a flowing- + !! well rate term associated with pumping (or injection) + !< subroutine mwt_fwrt_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwt_fwrt_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtMwtType) :: this integer(I4B), intent(in) :: ientry @@ -738,18 +693,17 @@ subroutine mwt_fwrt_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine mwt_fwrt_term + !> @brief Rate-to-mvr term associated with pumping (or injection) + !! + !! Pumped water that is made available to the MVR package for transfer to + !! another advanced package + !< subroutine mwt_rtmv_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwt_rtmv_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtMwtType) :: this integer(I4B), intent(in) :: ientry @@ -770,18 +724,17 @@ subroutine mwt_rtmv_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine mwt_rtmv_term + !> @brief Flowing well rate-to-mvr term (or injection) + !! + !! Pumped water that is made available to the MVR package for transfer to + !! another advanced package + !< subroutine mwt_frtm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! mwt_frtm_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtMwtType) :: this integer(I4B), intent(in) :: ientry @@ -802,19 +755,16 @@ subroutine mwt_frtm_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine mwt_frtm_term + !> @brief Observations + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !< subroutine mwt_df_obs(this) -! ****************************************************************************** -! mwt_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtMwtType) :: this @@ -875,13 +825,13 @@ subroutine mwt_df_obs(this) call this%obs%StoreObsType('fw-rate-to-mvr', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine mwt_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. !< subroutine mwt_rp_obs(this, obsrv, found) ! -- dummy @@ -904,16 +854,13 @@ subroutine mwt_rp_obs(this, obsrv, found) found = .false. end select ! + ! -- Return return end subroutine mwt_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine mwt_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! mwt_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtMwtType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -946,16 +893,14 @@ subroutine mwt_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine mwt_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine mwt_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! mwt_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + ! -- modules use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GwtMwtType), intent(inout) :: this @@ -993,7 +938,7 @@ subroutine mwt_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine mwt_set_stressperiod From 8dbbc1e1d0a65a39779be56aa1169e595214e207 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 05:26:23 -0700 Subject: [PATCH 166/212] gwt1lkt1.f90 doxygen compliance. Touch-up in gwe1lke1.f90 --- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 19 +- src/Model/GroundWaterTransport/gwt1lkt1.f90 | 230 ++++++++------------ 2 files changed, 96 insertions(+), 153 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index 3a7c5b550d2..db6258e6dea 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -287,7 +287,6 @@ end subroutine find_lke_package !! !! This will be called from TspAptType%apt_fc_expanded() !! in order to add matrix terms specifically for LKE - !! !< subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- modules @@ -410,7 +409,7 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine lke_fc_expanded - !> @ brief Add terms specific to lakes to the explicit lake solve + !> @brief Add terms specific to lakes to the explicit lake solve !< subroutine lke_solve(this) ! -- dummy @@ -516,7 +515,7 @@ subroutine lke_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- Addition of heat associated with rainfall + ! -- Addition of heat associated with rainfall directly on the lake surface text = ' RAINFALL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist @@ -542,7 +541,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- Addition of heat associated with runoff added to the lake + ! -- Addition of heat associated with runoff that flows to the lake text = ' RUNOFF' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist @@ -804,7 +803,7 @@ subroutine lke_allocate_arrays(this) return end subroutine lke_allocate_arrays - !> @brief Deallocate + !> @brief Deallocate memory !< subroutine lke_da(this) ! -- modules @@ -954,8 +953,8 @@ end subroutine lke_iflw_term !> @brief Specified withdrawal term !! - !! Accounts for energy associated with energy removed when water is withdrawn - !! from a lake or group of lakes. + !! Accounts for energy associated with a withdrawal of water from a lake + !! or group of lakes. !< subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) @@ -986,7 +985,7 @@ end subroutine lke_wdrl_term !> @brief Outflow term !! !! Accounts for the energy leaving a lake, for example, energy exiting a - !! lake via a flow in a stream channel. + !! lake via a flow into a draining stream channel. !< subroutine lke_outf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) @@ -1092,13 +1091,13 @@ subroutine lke_df_obs(this) call this%obs%StoreObsType('ext-outflow', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine lke_df_obs !> @brief Process package specific obs !! !! Method to process specific observations for this package. - !! !< subroutine lke_rp_obs(this, obsrv, found) ! -- dummy @@ -1128,6 +1127,7 @@ subroutine lke_rp_obs(this, obsrv, found) found = .false. end select ! + ! -- Return return end subroutine lke_rp_obs @@ -1174,6 +1174,7 @@ subroutine lke_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine lke_bd_obs diff --git a/src/Model/GroundWaterTransport/gwt1lkt1.f90 b/src/Model/GroundWaterTransport/gwt1lkt1.f90 index 593bfc498d6..75c22659832 100644 --- a/src/Model/GroundWaterTransport/gwt1lkt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1lkt1.f90 @@ -93,14 +93,10 @@ module GwtLktModule contains + !> @brief Create a new lkt package + !< subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac) -! ****************************************************************************** -! mwt_create -- Create a New MWT Package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -149,17 +145,13 @@ subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Store pointer to governing equation scale factor lktobj%eqnsclfac => eqnsclfac ! - ! -- return + ! -- Return return end subroutine lkt_create + !> @brief Find corresponding lkt package + !< subroutine find_lkt_package(this) -! ****************************************************************************** -! find corresponding lkt package -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -280,14 +272,12 @@ subroutine find_lkt_package(this) return end subroutine find_lkt_package + !> @brief Add matrix terms related to LKT + !! + !! This will be called from TspAptType%apt_fc_expanded() + !! in order to add matrix terms specifically for LKT + !< subroutine lkt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) -! ****************************************************************************** -! lkt_fc_expanded -- this will be called from TspAptType%apt_fc_expanded() -! in order to add matrix terms specifically for LKT -! **************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtLktType) :: this @@ -374,13 +364,9 @@ subroutine lkt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) return end subroutine lkt_fc_expanded + !> @brief Add terms specific to lakes to the explicit lake solve + !< subroutine lkt_solve(this) -! ****************************************************************************** -! lkt_solve -- add terms specific to lakes to the explicit lake solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this ! -- local @@ -441,14 +427,11 @@ subroutine lkt_solve(this) return end subroutine lkt_solve + !> @brief Function to return the number of budget terms just for this package. + !! + !! This overrides a function in the parent class. + !< function lkt_get_nbudterms(this) result(nbudterms) -! ****************************************************************************** -! lkt_get_nbudterms -- function to return the number of budget terms just for -! this package. This overrides function in parent. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtLktType) :: this @@ -464,13 +447,9 @@ function lkt_get_nbudterms(this) result(nbudterms) return end function lkt_get_nbudterms + !> @brief Set up the budget object that stores all the lake flows + !< subroutine lkt_setup_budobj(this, idx) -! ****************************************************************************** -! lkt_setup_budobj -- Set up the budget object that stores all the lake flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBUDTXT ! -- dummy @@ -481,7 +460,7 @@ subroutine lkt_setup_budobj(this, idx) character(len=LENBUDTXT) :: text ! ------------------------------------------------------------------------------ ! - ! -- + ! -- Addition of mass associated with rainfall directly on lake surface text = ' RAINFALL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist @@ -494,7 +473,8 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Loss of dissolved mass associated with evaporation when a non-zero + ! evaporative concentration is specified text = ' EVAPORATION' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist @@ -507,7 +487,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Addition of mass associated with runoff that flows to the lake text = ' RUNOFF' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist @@ -520,7 +500,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Addition of mass associated with user-specified inflow to the lake text = ' EXT-INFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist @@ -533,7 +513,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Removal of mass associated with user-specified withdrawal from lake text = ' WITHDRAWAL' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudwdrl)%maxlist @@ -546,7 +526,8 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- + ! -- Removal of heat associated with outflow from lake that leaves + ! model domain text = ' EXT-OUTFLOW' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist @@ -559,17 +540,13 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- return + ! -- Return return end subroutine lkt_setup_budobj + !> @brief Copy flow terms into this%budobj + !< subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) -! ****************************************************************************** -! lkt_fill_budobj -- copy flow terms into this%budobj -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtLktType) :: this @@ -584,7 +561,7 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q ! -- formats ! ----------------------------------------------------------------------------- - + ! ! -- RAIN idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist @@ -594,7 +571,7 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EVAPORATION idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist @@ -604,7 +581,7 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- RUNOFF idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist @@ -614,7 +591,7 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-INFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist @@ -624,7 +601,7 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- WITHDRAWAL idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudwdrl)%nlist @@ -634,7 +611,7 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - + ! ! -- EXT-OUTFLOW idx = idx + 1 nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist @@ -644,19 +621,15 @@ subroutine lkt_fill_budobj(this, idx, x, flowja, ccratin, ccratout) call this%budobj%budterm(idx)%update_term(n1, n2, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do - ! - ! -- return + ! -- Return return end subroutine lkt_fill_budobj + !> @brief Allocate scalars specific to the lake mass transport (LKT) + !! package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -687,13 +660,10 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @brief Allocate arrays specific to the lake mass transport (LKT) + !! package. + !< subroutine lkt_allocate_arrays(this) -! ****************************************************************************** -! lkt_allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -724,13 +694,9 @@ subroutine lkt_allocate_arrays(this) return end subroutine lkt_allocate_arrays + !> @brief Deallocate memory + !< subroutine lkt_da(this) -! ****************************************************************************** -! lkt_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate ! -- dummy @@ -759,14 +725,10 @@ subroutine lkt_da(this) return end subroutine lkt_da + !> @brief Rain term + !< subroutine lkt_rain_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lkt_rain_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this integer(I4B), intent(in) :: ientry @@ -787,18 +749,14 @@ subroutine lkt_rain_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lkt_rain_term + !> @brief Evaporative term + !< subroutine lkt_evap_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lkt_evap_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this integer(I4B), intent(in) :: ientry @@ -828,18 +786,14 @@ subroutine lkt_evap_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp if (present(hcofval)) hcofval = omega * qbnd ! - ! -- return + ! -- Return return end subroutine lkt_evap_term + !> @brief Runoff term + !< subroutine lkt_roff_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lkt_roff_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this integer(I4B), intent(in) :: ientry @@ -860,18 +814,17 @@ subroutine lkt_roff_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lkt_roff_term + !> @brief Inflow Term + !! + !! Accounts for mass flowing into a lake from a connected stream, for + !! example. + !< subroutine lkt_iflw_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lkt_iflw_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this integer(I4B), intent(in) :: ientry @@ -892,18 +845,17 @@ subroutine lkt_iflw_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine lkt_iflw_term + !> @brief Specified withdrawal term + !! + !! Accounts for mass associated with a withdrawal of water from a lake + !! or group of lakes. + !< subroutine lkt_wdrl_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lkt_wdrl_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this integer(I4B), intent(in) :: ientry @@ -924,18 +876,17 @@ subroutine lkt_wdrl_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine lkt_wdrl_term + !> @brief Outflow term + !! + !! Accounts for the mass leaving a lake, for example, mass exiting a + !! lake via a flow into a draining stream channel. + !< subroutine lkt_outf_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) -! ****************************************************************************** -! lkt_outf_term -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType) :: this integer(I4B), intent(in) :: ientry @@ -956,19 +907,16 @@ subroutine lkt_outf_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd ! - ! -- return + ! -- Return return end subroutine lkt_outf_term + !> @brief Defined observation types + !! + !! Store the observation type supported by the APT package and overide + !! BndType%bnd_df_obs + !< subroutine lkt_df_obs(this) -! ****************************************************************************** -! lkt_df_obs -- obs are supported? -! -- Store observation type supported by APT package. -! -- Overrides BndType%bnd_df_obs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtLktType) :: this @@ -1041,13 +989,13 @@ subroutine lkt_df_obs(this) call this%obs%StoreObsType('ext-outflow', .true., indx) this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID ! + ! -- Return return end subroutine lkt_df_obs !> @brief Process package specific obs - !! - !! Method to process specific observations for this package. - !! + !! + !! Method to process specific observations for this package. !< subroutine lkt_rp_obs(this, obsrv, found) ! -- dummy @@ -1077,16 +1025,13 @@ subroutine lkt_rp_obs(this, obsrv, found) found = .false. end select ! + ! -- Return return end subroutine lkt_rp_obs + !> @brief Calculate observation value and pass it back to APT + !< subroutine lkt_bd_obs(this, obstypeid, jj, v, found) -! ****************************************************************************** -! lkt_bd_obs -- calculate observation value and pass it back to APT -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtLktType), intent(inout) :: this character(len=*), intent(in) :: obstypeid @@ -1127,16 +1072,13 @@ subroutine lkt_bd_obs(this, obstypeid, jj, v, found) found = .false. end select ! + ! -- Return return end subroutine lkt_bd_obs + !> @brief Sets the stress period attributes for keyword use. + !< subroutine lkt_set_stressperiod(this, itemno, keyword, found) -! ****************************************************************************** -! lkt_set_stressperiod -- Set a stress period attribute for using keywords. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use TimeSeriesManagerModule, only: read_value_or_time_series_adv ! -- dummy class(GwtLktType), intent(inout) :: this @@ -1211,7 +1153,7 @@ subroutine lkt_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine lkt_set_stressperiod From 43c489ca33389db634dd79d01ca3eae6a0b483ce Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 05:53:57 -0700 Subject: [PATCH 167/212] gwt1dsp1.f90 doxygen compliance. Touch-up in gwe1dsp1.f90 --- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 8 +- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 140 +++++++------------- 2 files changed, 55 insertions(+), 93 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 60dd039bc85..9c3491ed24e 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -389,7 +389,7 @@ end subroutine dsp_cq !! !! Method to allocate scalar variables for the package. !< - subroutine allocate_scalars(this) + subroutine allocate_scalars(this) ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -439,7 +439,7 @@ subroutine allocate_scalars(this) ! ! -- Return return - end subroutine allocate_scalars + end subroutine allocate_scalars !> @ brief Allocate arrays for package !! @@ -558,6 +558,8 @@ subroutine log_options(this, found) write (this%iout, '(4x,a,i0)') 'XT3D formulation [0=INACTIVE, 1=ACTIVE, & &3=ACTIVE RHS] set to: ', this%ixt3d write (this%iout, '(1x,a,/)') 'End Setting DSP Options' + ! -- Return + return end subroutine log_options !> @brief Update simulation mempath options @@ -715,7 +717,7 @@ subroutine source_griddata(this) ! ! -- Return return - end subroutine source_griddata + end subroutine source_griddata !> @brief Calculate dispersion coefficients !< diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index c080347a14e..c9e2c57ca66 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -72,13 +72,9 @@ module GwtDspModule contains + !> @brief Create a new DSP object + !< subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) -! ****************************************************************************** -! dsp_cr -- Create a new DSP object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use KindModule, only: LGP use MemoryManagerExtModule, only: mem_set_value @@ -128,13 +124,11 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) return end subroutine dsp_cr + !> @brief Define MST object + !! + !! Define the MST package + !< subroutine dsp_df(this, dis, dspOptions) -! ****************************************************************************** -! dsp_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -179,13 +173,11 @@ subroutine dsp_df(this, dis, dspOptions) return end subroutine dsp_df + !> @brief Add connections to DSP + !! + !! Add connections for extended neighbors to the sparse matrix + !< subroutine dsp_ac(this, moffset, sparse) -! ****************************************************************************** -! dsp_ac -- Add connections for extended neighbors to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix use MemoryManagerModule, only: mem_allocate @@ -203,13 +195,11 @@ subroutine dsp_ac(this, moffset, sparse) return end subroutine dsp_ac + !> @brief Map DSP connections + !! + !! Map connections and construct iax, jax, and idxglox + !< subroutine dsp_mc(this, moffset, matrix_sln) -! ****************************************************************************** -! dsp_mc -- Map connections and construct iax, jax, and idxglox -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -226,13 +216,11 @@ subroutine dsp_mc(this, moffset, matrix_sln) return end subroutine dsp_mc + !> @brief Allocate and read method for package + !! + !! Method to allocate and read static data for the package. + !< subroutine dsp_ar(this, ibound, porosity) -! ****************************************************************************** -! dsp_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -253,13 +241,9 @@ subroutine dsp_ar(this, ibound, porosity) return end subroutine dsp_ar + !> @brief Advance method for the package + !< subroutine dsp_ad(this) -! ****************************************************************************** -! dsp_ad -- Advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper ! -- dummy @@ -295,13 +279,11 @@ subroutine dsp_ad(this) return end subroutine dsp_ad + !> @brief Fill coefficient method for package + !! + !! Method to calculate and fill coefficients for the package. + !< subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) -! ****************************************************************************** -! dsp_fc -- Calculate coefficients and fill amat and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -348,13 +330,11 @@ subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) return end subroutine dsp_fc + !> @ brief Calculate flows for package + !! + !! Method to calculate dispersion contribution to flowja + !< subroutine dsp_cq(this, cnew, flowja) -! ****************************************************************************** -! dsp_cq -- Calculate dispersion contribution to flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -385,13 +365,11 @@ subroutine dsp_cq(this, cnew, flowja) return end subroutine dsp_cq + !> @ brief Allocate scalar variables for package + !! + !! Method to allocate scalar variables for the package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -441,13 +419,11 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @ brief Allocate arrays for package + !! + !! Method to allocate arrays for the package. + !< subroutine allocate_arrays(this, nodes) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -483,13 +459,11 @@ subroutine allocate_arrays(this, nodes) return end subroutine allocate_arrays + !> @ brief Deallocate memory + !! + !! Method to deallocate memory for the package. + !< subroutine dsp_da(this) -! ****************************************************************************** -! dsp_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate use MemoryManagerExtModule, only: memorylist_remove @@ -558,15 +532,13 @@ subroutine log_options(this, found) write (this%iout, '(4x,a,i0)') 'XT3D formulation [0=INACTIVE, 1=ACTIVE, & &3=ACTIVE RHS] set to: ', this%ixt3d write (this%iout, '(1x,a,/)') 'End Setting DSP Options' + ! -- Return + return end subroutine log_options + !> @brief Update simulation mempath options + !< subroutine source_options(this) -! ****************************************************************************** -! source_options -- update simulation mempath options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules !use KindModule, only: LGP use MemoryManagerExtModule, only: mem_set_value @@ -633,13 +605,9 @@ subroutine log_griddata(this, found) end subroutine log_griddata + !> @brief Update DSP simulation data from input mempath + !< subroutine source_griddata(this) -! ****************************************************************************** -! source_griddata -- update dsp simulation data from input mempath -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error use MemoryManagerModule, only: mem_reallocate, mem_reassignptr @@ -722,13 +690,9 @@ subroutine source_griddata(this) return end subroutine source_griddata + !> @brief Calculate dispersion coefficients + !< subroutine calcdispellipse(this) -! ****************************************************************************** -! calcdispellipse -- Calculate dispersion coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -839,13 +803,9 @@ subroutine calcdispellipse(this) return end subroutine calcdispellipse + !> @brief Calculate dispersion coefficients + !< subroutine calcdispcoef(this) -! ****************************************************************************** -! calcdispcoef -- Calculate dispersion coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use GwfNpfModule, only: hyeff_calc ! -- dummy From b096d07794d27607dd009f0f57f2fe1a17a51c7a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 06:21:56 -0700 Subject: [PATCH 168/212] gwt1.f90 doxygen compliance. Touch-up in gwe1.f90 --- src/Model/GroundWaterEnergy/gwe1.f90 | 60 +- src/Model/GroundWaterTransport/gwt1.f90 | 708 ++++-------------------- 2 files changed, 128 insertions(+), 640 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index e78a8112d61..73d93bd70e3 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -132,7 +132,6 @@ end subroutine gwe_cr !! This subroutine defines a gwe model type. Steps include: !! - call df routines for each package !! - set variables and pointers - !! !< subroutine gwe_df(this) ! -- modules @@ -183,7 +182,7 @@ subroutine gwe_df(this) ! -- Store information needed for observations call this%obs%obs_df(this%iout, this%name, 'GWE', this%dis) ! - ! -- return + ! -- Return return end subroutine gwe_df @@ -211,11 +210,11 @@ subroutine gwe_ac(this, sparse) call packobj%bnd_ac(this%moffset, sparse) end do ! - ! -- return + ! -- Return return end subroutine gwe_ac - !> @brief Map the positions of this model's connections in the numerical + !> @brief Map the positions of the GWE model connections in the numerical !! solution coefficient matrix. !< subroutine gwe_mc(this, matrix_sln) @@ -239,11 +238,11 @@ subroutine gwe_mc(this, matrix_sln) call packobj%bnd_mc(this%moffset, matrix_sln) end do ! - ! -- return + ! -- Return return end subroutine gwe_mc - !> @brief GroundWater Energy Transport Model Allocate and Read + !> @brief GWE Model Allocate and Read !! !! This subroutine: !! - allocates and reads packages that are part of this model, @@ -288,13 +287,14 @@ subroutine gwe_ar(this) call packobj%bnd_ar() end do ! - ! -- return + ! -- Return return end subroutine gwe_ar - !> @brief GroundWater Energy Transport Model Read and Prepare + !> @brief GWE Model Read and Prepare !! !! This subroutine calls the attached packages' read and prepare routines + !< subroutine gwe_rp(this) ! -- modules use TdisModule, only: readnewdata @@ -325,7 +325,7 @@ subroutine gwe_rp(this) return end subroutine gwe_rp - !> @brief GroundWater Energy Transport Model Time Step Advance + !> @brief GWE Model Time Step Advance !! !! This subroutine calls the attached packages' advance subroutines !< @@ -378,11 +378,11 @@ subroutine gwe_ad(this) ! -- Push simulated values to preceding time/subtime step call this%obs%obs_ad() ! - ! -- return + ! -- Return return end subroutine gwe_ad - !> @brief GroundWater Energy Transport Model calculate coefficients + !> @brief GWE Model calculate coefficients !! !! This subroutine calls the attached packages' calculate coefficients !! subroutines @@ -403,11 +403,11 @@ subroutine gwe_cf(this, kiter) call packobj%bnd_cf() end do ! - ! -- return + ! -- Return return end subroutine gwe_cf - !> @brief GroundWater Energy Transport Model fill coefficients + !> @brief GWE Model fill coefficients !! !! This subroutine calls the attached packages' fill coefficients !! subroutines @@ -452,11 +452,11 @@ subroutine gwe_fc(this, kiter, matrix_sln, inwtflag) call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, matrix_sln) end do ! - ! -- return + ! -- Return return end subroutine gwe_fc - !> @brief GroundWater Energy Transport Model Final Convergence Check + !> @brief GWE Model Final Convergence Check !! !! If MVR/MVT is active, this subroutine calls the MVR convergence check !! subroutines. @@ -478,11 +478,11 @@ subroutine gwe_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! -- If mover is on, then at least 2 outers required if (this%inmvt > 0) call this%mvt%mvt_cc(kiter, iend, icnvgmod, cpak, dpak) ! - ! -- return + ! -- Return return end subroutine gwe_cc - !> @brief Groundwater energy transport model calculate flow + !> @brief GWE Model calculate flow !! !! This subroutine calls the attached packages' intercell flows (flow ja) !< @@ -532,11 +532,12 @@ subroutine gwe_cq(this, icnvg, isuppress_output) return end subroutine gwe_cq - !> @brief GroundWater Energy Transport Model Budget + !> @brief GWE Model Budget !! !! This subroutine: !! - calculates intercell flows (flowja) !! - calculates package contributions to the model budget + !< subroutine gwe_bd(this, icnvg, isuppress_output) use ConstantsModule, only: DZERO ! -- dummy @@ -569,9 +570,9 @@ subroutine gwe_bd(this, icnvg, isuppress_output) return end subroutine gwe_bd - !> @brief GroundWater Energy Transport Model Output + !> @brief GWE Model Output !! - !! This subroutine calls the parent class's output routine. + !! This subroutine calls the parent class output routine. !< subroutine gwe_ot(this) ! -- modules @@ -665,7 +666,6 @@ end subroutine gwe_da !! This subroutine adds a budget entry to the flow budget. It was added as !! a method for the gwe model object so that the exchange object could add its !! contributions. - !! !< subroutine gwe_bdentry(this, budterm, budtxt, rowlabel) ! -- modules @@ -680,7 +680,7 @@ subroutine gwe_bdentry(this, budterm, budtxt, rowlabel) ! call this%budget%addentry(budterm, delt, budtxt, rowlabel=rowlabel) ! - ! -- return + ! -- Return return end subroutine gwe_bdentry @@ -713,7 +713,7 @@ function gwe_get_iasym(this) result(iasym) if (packobj%iasym /= 0) iasym = 1 end do ! - ! -- return + ! -- Return return end function gwe_get_iasym @@ -738,7 +738,7 @@ subroutine allocate_gwe_scalars(this, modelname) this%inmst = 0 this%indsp = 0 ! - ! -- return + ! -- Return return end subroutine allocate_gwe_scalars @@ -819,7 +819,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & end do call AddBndToList(this%bndlist, packobj) ! - ! -- return + ! -- Return return end subroutine package_create @@ -835,7 +835,9 @@ function CastAsGweModel(model) result(gwemodel) type is (GweModelType) gwemodel => model end select - + ! + ! -- Return + return end function CastAsGweModel !> @brief Source package info and begin to process @@ -891,7 +893,7 @@ subroutine create_bndpkgs(this, bndpkgs, pkgtypes, pkgnames, & deallocate (bndpkgs) end if ! - ! -- return + ! -- Return return end subroutine create_bndpkgs @@ -972,7 +974,9 @@ subroutine create_gwe_specific_packages(this, indis) call this%ftype_check(indis, this%inmst) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) - + ! + ! -- Return + return end subroutine create_gwe_specific_packages end module GweModule diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index e7f2a6dfe86..7759da8a3e3 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -60,38 +60,17 @@ module GwtModule procedure :: allocate_gwt_scalars procedure, private :: package_create - !procedure, private :: ftype_check procedure :: get_iasym => gwt_get_iasym - !procedure, private :: gwt_ot_flow - !procedure, private :: gwt_ot_flowja - !procedure, private :: gwt_ot_dv - !procedure, private :: gwt_ot_bdsummary - !procedure, private :: gwt_ot_obs procedure, private :: create_gwt_specific_packages procedure, private :: create_bndpkgs - !procedure, private :: create_lstfile - !procedure, private :: log_namfile_options + end type GwtModelType - ! -- Module variables constant for simulation - !integer(I4B), parameter :: NIUNIT = 100 - !character(len=LENFTYPE), dimension(NIUNIT) :: cunit - !data cunit/'DIS6 ', 'DISV6', 'DISU6', 'IC6 ', 'MST6 ', & ! 5 - ! &'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 - ! &'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 - ! &'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - ! &'API6 ', ' ', ' ', ' ', ' ', & ! 25 - ! &75*' '/ - contains + !> @brief Create a new groundwater energy transport model object + !< subroutine gwt_cr(filename, id, modelname) -! ****************************************************************************** -! gwt_cr -- Create a new groundwater transport model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ListsModule, only: basemodellist use BaseModelModule, only: AddBaseModelToList @@ -102,20 +81,6 @@ subroutine gwt_cr(filename, id, modelname) use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr - !use TspLabelsModule, only: tsplabels_cr - !use SimModule, only: store_error, count_errors - !use NameFileModule, only: NameFileType - !use CompilerVersion - !use GwfDisModule, only: dis_cr - !use GwfDisvModule, only: disv_cr - !use GwfDisuModule, only: disu_cr - !use TspIcModule, only: ic_cr - !use TspFmiModule, only: fmi_cr - !use TspAdvModule, only: adv_cr - !use TspSsmModule, only: ssm_cr - !use TspMvtModule, only: mvt_cr - !use TspOcModule, only: oc_cr - !use TspObsModule, only: tsp_obs_cr use GwtMstModule, only: mst_cr use GwtDspModule, only: dsp_cr ! -- dummy @@ -148,61 +113,23 @@ subroutine gwt_cr(filename, id, modelname) model => this call AddBaseModelToList(basemodellist, model) ! - ! -- Assign values - !this%filename = filename - !this%name = modelname - !this%macronym = 'GWT' - !this%id = id - ! ! -- Call parent class routine call this%tsp_cr(filename, id, modelname, 'GWT', indis) ! - ! -- set input model namfile memory path - !input_mempath = create_mem_path(modelname, 'NAM', idm_context) - ! - ! -- copy option params from input context - !call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) - !call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & - ! found%print_input) - !call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & - ! found%print_flows) - !call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) - ! - ! -- create the list file - !call this%create_lstfile(lst_fname, filename, found%list) - ! - ! -- activate save_flows if found - !if (found%save_flows) then - ! this%ipakcb = -1 - !end if - ! - ! -- Instantiate generalized labels - !call tsplabels_cr(this%tsplab, this%name) - ! - ! -- log set options - !if (this%iout > 0) then - ! call this%log_namfile_options(found) - !end if - ! - ! -- Create utility objects - !call budget_cr(this%budget, this%name, this%tsplab) - ! ! -- create model packages call this%create_gwt_specific_packages(indis) ! - ! -- return + ! -- Return return end subroutine gwt_cr + !> @brief Define packages of the GWT model + !! + !! This subroutine defines a gwt model type. Steps include: + !! - call df routines for each package + !! - set variables and pointers + !< subroutine gwt_df(this) -! ****************************************************************************** -! gwt_df -- Define packages of the model -! Subroutine: (1) call df routines for each package -! (2) set variables and pointers -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ModelPackageInputsModule, only: NIUNIT_GWT use TspLabelsModule, only: setTspLabels @@ -247,17 +174,13 @@ subroutine gwt_df(this) ! -- Store information needed for observations call this%obs%obs_df(this%iout, this%name, 'GWT', this%dis) ! - ! -- return + ! -- Return return end subroutine gwt_df + !> @brief Add the internal connections of this model to the sparse matrix + !< subroutine gwt_ac(this, sparse) -! ****************************************************************************** -! gwt_ac -- Add the internal connections of this model to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix ! -- dummy @@ -279,18 +202,14 @@ subroutine gwt_ac(this, sparse) call packobj%bnd_ac(this%moffset, sparse) end do ! - ! -- return + ! -- Return return end subroutine gwt_ac + !> @brief Map the positions of the GWT model connections in the numerical + !! solution coefficient matrix. + !< subroutine gwt_mc(this, matrix_sln) -! ****************************************************************************** -! gwt_mc -- Map the positions of this models connections in the -! numerical solution coefficient matrix. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this class(MatrixBaseType), pointer :: matrix_sln !< global system matrix @@ -311,19 +230,17 @@ subroutine gwt_mc(this, matrix_sln) call packobj%bnd_mc(this%moffset, matrix_sln) end do ! - ! -- return + ! -- Return return end subroutine gwt_mc + !> @brief GWT Model Allocate and Read + !! + !! This subroutine: + !! - allocates and reads packages that are part of this model, + !! - allocates memory for arrays used by this model object + !< subroutine gwt_ar(this) -! ****************************************************************************** -! gwt_ar -- GroundWater Transport Model Allocate and Read -! Subroutine: (1) allocates and reads packages part of this model, -! (2) allocates memory for arrays part of this model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: DHNOFLO ! -- dummy @@ -368,18 +285,15 @@ subroutine gwt_ar(this) call packobj%bnd_ar() end do ! - ! -- return + ! -- Return return end subroutine gwt_ar + !> @brief GWT Model Read and Prepare + !! + !! This subroutine calls the attached packages' read and prepare routines + !< subroutine gwt_rp(this) -! ****************************************************************************** -! gwt_rp -- GroundWater Transport Model Read and Prepare -! Subroutine: (1) calls package read and prepare routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: readnewdata ! -- dummy @@ -409,6 +323,10 @@ subroutine gwt_rp(this) return end subroutine gwt_rp + !> @brief GWT Model Time Step Advance + !! + !! This subroutine calls the attached packages' advance subroutines + !< subroutine gwt_ad(this) ! ****************************************************************************** ! gwt_ad -- GroundWater Transport Model Time Step Advance @@ -466,17 +384,16 @@ subroutine gwt_ad(this) ! -- Push simulated values to preceding time/subtime step call this%obs%obs_ad() ! - ! -- return + ! -- Return return end subroutine gwt_ad + !> @brief GWT Model calculate coefficients + !! + !! This subroutine calls the attached packages' calculate coefficients + !! subroutines + !< subroutine gwt_cf(this, kiter) -! ****************************************************************************** -! gwt_cf -- GroundWater Transport Model calculate coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtModelType) :: this @@ -492,17 +409,16 @@ subroutine gwt_cf(this, kiter) call packobj%bnd_cf() end do ! - ! -- return + ! -- Return return end subroutine gwt_cf + !> @brief GWT Model fill coefficients + !! + !! This subroutine calls the attached packages' fill coefficients + !! subroutines + !< subroutine gwt_fc(this, kiter, matrix_sln, inwtflag) -! ****************************************************************************** -! gwt_fc -- GroundWater Transport Model fill coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtModelType) :: this @@ -542,18 +458,16 @@ subroutine gwt_fc(this, kiter, matrix_sln, inwtflag) call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, matrix_sln) end do ! - ! -- return + ! -- Return return end subroutine gwt_fc + !> @brief GWT Model Final Convergence Check + !! + !! If MVR/MVT is active, this subroutine calls the MVR convergence check + !! subroutines. + !< subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) -! ****************************************************************************** -! gwt_cc -- GroundWater Transport Model Final Convergence Check -! Subroutine: (1) calls package cc routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this integer(I4B), intent(in) :: innertot @@ -564,32 +478,21 @@ subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) integer(I4B), intent(inout) :: ipak real(DP), intent(inout) :: dpak ! -- local - !class(BndType), pointer :: packobj - !integer(I4B) :: ip ! -- formats ! ------------------------------------------------------------------------------ ! ! -- If mover is on, then at least 2 outers required if (this%inmvt > 0) call this%mvt%mvt_cc(kiter, iend, icnvgmod, cpak, dpak) ! - ! -- Call package cc routines - !do ip = 1, this%bndlist%Count() - ! packobj => GetBndFromList(this%bndlist, ip) - ! call packobj%bnd_cc(iend, icnvg, hclose, rclose) - !enddo - ! - ! -- return + ! -- Return return end subroutine gwt_cc + !> @brief GWT Model calculate flow + !! + !! This subroutine calls the attached packages' intercell flows (flow ja) + !< subroutine gwt_cq(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwt_cq --Groundwater transport model calculate flow -! Subroutine: (1) Calculate intercell flows (flowja) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: csr_diagsum ! -- dummy @@ -635,15 +538,13 @@ subroutine gwt_cq(this, icnvg, isuppress_output) return end subroutine gwt_cq + !> @brief GWT Model Budget + !! + !! This subroutine: + !! - calculates intercell flows (flowja) + !! - calculates package contributions to the model budget + !< subroutine gwt_bd(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwt_bd --GroundWater Transport Model Budget -! Subroutine: (1) Calculate intercell flows (flowja) -! (2) Calculate package contributions to model budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use ConstantsModule, only: DZERO ! -- dummy class(GwtModelType) :: this @@ -675,239 +576,30 @@ subroutine gwt_bd(this, icnvg, isuppress_output) return end subroutine gwt_bd + !> @brief GWT Model Output + !! + !! This subroutine calls the parent class output routine. + !< subroutine gwt_ot(this) -! ****************************************************************************** -! gwt_ot -- GroundWater Transport Model Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(GwtModelType) :: this ! -- local -! integer(I4B) :: idvsave -! integer(I4B) :: idvprint -! integer(I4B) :: icbcfl -! integer(I4B) :: icbcun -! integer(I4B) :: ibudfl -! integer(I4B) :: ipflag -! ! -- formats -! character(len=*), parameter :: fmtnocnvg = & -! "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & -! &I0,' OF STRESS PERIOD ',I0,'****')" ! ------------------------------------------------------------------------------ ! ! -- Call parent class _ot routines. call this%tsp_ot(this%inmst) -! ! -! ! -- Set write and print flags -! idvsave = 0 -! idvprint = 0 -! icbcfl = 0 -! ibudfl = 0 -! if (this%oc%oc_save(trim(this%tsplab%depvartype))) idvsave = 1 -! if (this%oc%oc_print(trim(this%tsplab%depvartype))) idvprint = 1 -! if (this%oc%oc_save('BUDGET')) icbcfl = 1 -! if (this%oc%oc_print('BUDGET')) ibudfl = 1 -! icbcun = this%oc%oc_save_unit('BUDGET') -! ! -! ! -- Override ibudfl and idvprint flags for nonconvergence -! ! and end of period -! ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) -! idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & -! this%icnvg, endofperiod) -! ! -! ! Calculate and save observations -! call this%gwt_ot_obs() -! ! -! ! Save and print flows -! call this%gwt_ot_flow(icbcfl, ibudfl, icbcun) -! ! -! ! Save and print dependent variables -! call this%gwt_ot_dv(idvsave, idvprint, ipflag) -! ! -! ! Print budget summaries -! call this%gwt_ot_bdsummary(ibudfl, ipflag) -! ! -! ! -- Timing Output; if any dependendent variables or budgets -! ! are printed, then ipflag is set to 1. -! if (ipflag == 1) call tdis_ot(this%iout) -! ! -! ! -- Write non-convergence message -! if (this%icnvg == 0) then -! write (this%iout, fmtnocnvg) kstp, kper -! end if ! ! -- Return return end subroutine gwt_ot -! -! subroutine gwt_ot_obs(this) -! class(GwtModelType) :: this -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -- Calculate and save observations -! call this%obs%obs_bd() -! call this%obs%obs_ot() -! -! ! -- Calculate and save package obserations -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_bd_obs() -! call packobj%bnd_ot_obs() -! end do -! -! end subroutine gwt_ot_obs -! -! subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) -! class(GwtModelType) :: this -! integer(I4B), intent(in) :: icbcfl -! integer(I4B), intent(in) :: ibudfl -! integer(I4B), intent(in) :: icbcun -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -- Save GWT flows -! call this%gwt_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) -! if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) -! if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) -! if (this%inssm > 0) then -! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) -! end if -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) -! end do -! -! ! -- Save advanced package flows -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) -! end do -! if (this%inmvt > 0) then -! call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) -! end if -! -! ! -- Print GWF flows -! ! no need to print flowja -! ! no need to print mst -! ! no need to print fmi -! if (this%inssm > 0) then -! call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) -! end if -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) -! end do -! -! ! -- Print advanced package flows -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) -! end do -! if (this%inmvt > 0) then -! call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) -! end if -! -! end subroutine gwt_ot_flow -! -! subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) -!! ****************************************************************************** -!! gwt_ot_flowja -- Write intercell flows -!! ****************************************************************************** -!! -!! SPECIFICATIONS: -!! ------------------------------------------------------------------------------ -! ! -- dummy -! class(GwtModelType) :: this -! integer(I4B), intent(in) :: nja -! real(DP), dimension(nja), intent(in) :: flowja -! integer(I4B), intent(in) :: icbcfl -! integer(I4B), intent(in) :: icbcun -! ! -- local -! integer(I4B) :: ibinun -! ! -- formats -!! ------------------------------------------------------------------------------ -! ! -! ! -- Set unit number for binary output -! if (this%ipakcb < 0) then -! ibinun = icbcun -! elseif (this%ipakcb == 0) then -! ibinun = 0 -! else -! ibinun = this%ipakcb -! end if -! if (icbcfl == 0) ibinun = 0 -! ! -! ! -- Write the face flows if requested -! if (ibinun /= 0) then -! call this%dis%record_connection_array(flowja, ibinun, this%iout) -! end if -! ! -! ! -- Return -! return -! end subroutine gwt_ot_flowja -! -! subroutine gwt_ot_dv(this, idvsave, idvprint, ipflag) -! class(GwtModelType) :: this -! integer(I4B), intent(in) :: idvsave -! integer(I4B), intent(in) :: idvprint -! integer(I4B), intent(inout) :: ipflag -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -- Print advanced package dependent variables -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_dv(idvsave, idvprint) -! end do -! -! ! -- save head and print head -! call this%oc%oc_ot(ipflag) -! -! end subroutine gwt_ot_dv -! -! subroutine gwt_ot_bdsummary(this, ibudfl, ipflag) -! use TdisModule, only: kstp, kper, totim -! class(GwtModelType) :: this -! integer(I4B), intent(in) :: ibudfl -! integer(I4B), intent(inout) :: ipflag -! class(BndType), pointer :: packobj -! integer(I4B) :: ip -! -! ! -! ! -- Package budget summary -! do ip = 1, this%bndlist%Count() -! packobj => GetBndFromList(this%bndlist, ip) -! call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) -! end do -! -! ! -- mover budget summary -! if (this%inmvt > 0) then -! call this%mvt%mvt_ot_bdsummary(ibudfl) -! end if -! -! ! -- model budget summary -! if (ibudfl /= 0) then -! ipflag = 1 -! call this%budget%budget_ot(kstp, kper, this%iout) -! end if -! -! ! -- Write to budget csv -! call this%budget%writecsv(totim) -! -! end subroutine gwt_ot_bdsummary + !> @brief Deallocate + !! + !! Deallocate memmory at conclusion of model run + !< subroutine gwt_da(this) -! ****************************************************************************** -! gwt_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate use MemoryManagerExtModule, only: memorylist_remove @@ -968,7 +660,7 @@ subroutine gwt_da(this) ! -- NumericalModelType call this%NumericalModelType%model_da() ! - ! -- return + ! -- Return return end subroutine gwt_da @@ -977,8 +669,6 @@ end subroutine gwt_da !! This subroutine adds a budget entry to the flow budget. It was added as !! a method for the gwt model object so that the exchange object could add its !! contributions. - !! - !! (1) adds the entry to the budget object !< subroutine gwt_bdentry(this, budterm, budtxt, rowlabel) ! -- modules @@ -993,7 +683,7 @@ subroutine gwt_bdentry(this, budterm, budtxt, rowlabel) ! call this%budget%addentry(budterm, delt, budtxt, rowlabel=rowlabel) ! - ! -- return + ! -- Return return end subroutine gwt_bdentry @@ -1026,60 +716,42 @@ function gwt_get_iasym(this) result(iasym) if (packobj%iasym /= 0) iasym = 1 end do ! - ! -- return + ! -- Return return end function gwt_get_iasym + !> Allocate memory for non-allocatable members + !! + !! A subroutine for allocating the scalars specific to the GWT model type. + !! Additional scalars used by the parent class are allocated by the parent + !! class. + !< subroutine allocate_gwt_scalars(this, modelname) -! ****************************************************************************** -! allocate_scalars -- Allocate memory for non-allocatable members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy class(GwtModelType) :: this character(len=*), intent(in) :: modelname ! ------------------------------------------------------------------------------ - ! - ! -- allocate members from parent class - !call this%NumericalModelType%allocate_scalars(modelname) ! ! -- allocate additional members specific to GWT model type - !call mem_allocate(this%inic, 'INIC', this%memoryPath) - !call mem_allocate(this%infmi, 'INFMI', this%memoryPath) - !call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) call mem_allocate(this%inmst, 'INMST', this%memoryPath) - !call mem_allocate(this%inadv, 'INADV', this%memoryPath) call mem_allocate(this%indsp, 'INDSP', this%memoryPath) - !call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - !call mem_allocate(this%inoc, 'INOC ', this%memoryPath) - !call mem_allocate(this%inobs, 'INOBS', this%memoryPath) ! - !this%inic = 0 - !this%infmi = 0 - !this%inmvt = 0 this%inmst = 0 - !this%inadv = 0 this%indsp = 0 - !this%inssm = 0 - !this%inoc = 0 - !this%inobs = 0 ! - ! -- return + ! -- Return return end subroutine allocate_gwt_scalars + !> @brief Create boundary condition packages for this model + !! + !! This subroutine calls the package create routines for packages activated + !! by the user. + !< subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) -! ****************************************************************************** -! package_create -- Create boundary condition packages for this model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error @@ -1150,78 +822,12 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & end do call AddBndToList(this%bndlist, packobj) ! - ! -- return + ! -- Return return - end subroutine package_create - -! subroutine ftype_check(this, namefile_obj, indis) -!! ****************************************************************************** -!! ftype_check -- Check to make sure required input files have been specified -!! ****************************************************************************** -!! -!! SPECIFICATIONS: -!! ------------------------------------------------------------------------------ -! ! -- modules -! use ConstantsModule, only: LINELENGTH -! use SimModule, only: store_error, count_errors -! use NameFileModule, only: NameFileType -! ! -- dummy -! class(GwtModelType) :: this -! type(NameFileType), intent(in) :: namefile_obj -! integer(I4B), intent(in) :: indis -! ! -- local -! character(len=LINELENGTH) :: errmsg -! integer(I4B) :: i, iu -! character(len=LENFTYPE), dimension(10) :: nodupftype = & -! &(/'DIS6 ', 'DISU6', 'DISV6', 'IC6 ', 'MST6 ', 'ADV6 ', 'DSP6 ', & -! &'SSM6 ', 'OC6 ', 'OBS6 '/) -!! ------------------------------------------------------------------------------ -! ! -! ! -- Check for IC6, DIS(u), and MST. Stop if not present. -! if (this%inic == 0) then -! write (errmsg, '(1x,a)') & -! 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! if (indis == 0) then -! write (errmsg, '(1x,a)') & -! 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! if (this%inmst == 0) then -! write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & -! &PACKAGE NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! if (count_errors() > 0) then -! write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' -! call store_error(errmsg) -! end if -! ! -! ! -- Check to make sure that some GWT packages are not specified more -! ! than once -! do i = 1, size(nodupftype) -! call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0) -! if (iu > 0) then -! write (errmsg, '(1x, a, a, a)') & -! 'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)), & -! ' NOT ALLOWED FOR GWT MODEL.' -! call store_error(errmsg) -! end if -! end do -! ! -! ! -- Stop if errors -! if (count_errors() > 0) then -! write (errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ', & -! trim(namefile_obj%filename) -! call store_error(errmsg, terminate=.TRUE.) -! end if -! ! -! ! -- return -! return -! end subroutine ftype_check + end subroutine package_create !> @brief Cast to GwtModelType + !< function CastAsGwtModel(model) result(gwtmodel) class(*), pointer :: model !< The object to be cast class(GwtModelType), pointer :: gwtmodel !< The GWT model @@ -1232,7 +838,9 @@ function CastAsGwtModel(model) result(gwtmodel) type is (GwtModelType) gwtmodel => model end select - + ! + ! -- Return + return end function CastAsGwtModel !> @brief Source package info and begin to process @@ -1288,7 +896,7 @@ subroutine create_bndpkgs(this, bndpkgs, pkgtypes, pkgnames, & deallocate (bndpkgs) end if ! - ! -- return + ! -- Return return end subroutine create_bndpkgs @@ -1302,18 +910,8 @@ subroutine create_gwt_specific_packages(this, indis) use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context - !use GwfDisModule, only: dis_cr - !use GwfDisvModule, only: disv_cr - !use GwfDisuModule, only: disu_cr - !use TspIcModule, only: ic_cr - !use TspFmiModule, only: fmi_cr use GwtMstModule, only: mst_cr - !use TspAdvModule, only: adv_cr use GwtDspModule, only: dsp_cr - !use TspSsmModule, only: ssm_cr - !use TspMvtModule, only: mvt_cr - !use TspOcModule, only: oc_cr - !use TspObsModule, only: tsp_obs_cr ! -- dummy class(GwtModelType) :: this integer(I4B), intent(in) :: indis @@ -1333,7 +931,6 @@ subroutine create_gwt_specific_packages(this, indis) integer(I4B), pointer :: inunit integer(I4B), dimension(:), allocatable :: bndpkgs integer(I4B) :: n - !integer(I4B) :: indis = 0 ! DIS enabled flag character(len=LENMEMPATH) :: mempathdsp = '' ! ! -- set input memory paths, input/model and input/model/namfile @@ -1355,34 +952,11 @@ subroutine create_gwt_specific_packages(this, indis) ! ! -- create dis package as it is a prerequisite for other packages select case (pkgtype) - !case ('DIS6') - ! indis = 1 - ! call dis_cr(this%dis, this%name, mempath, indis, this%iout) - !case ('DISV6') - ! indis = 1 - ! call disv_cr(this%dis, this%name, mempath, indis, this%iout) - !case ('DISU6') - ! indis = 1 - ! call disu_cr(this%dis, this%name, mempath, indis, this%iout) - !case ('IC6') - ! this%inic = inunit - !case ('FMI6') - ! this%infmi = inunit - !case ('MVT6') - ! this%inmvt = inunit case ('MST6') this%inmst = inunit - !case ('ADV6') - ! this%inadv = inunit case ('DSP6') this%indsp = 1 mempathdsp = mempath - !case ('SSM6') - ! this%inssm = inunit - !case ('OC6') - ! this%inoc = inunit - !case ('OBS6') - ! this%inobs = inunit case ('CNC6', 'SRC6', 'LKT6', 'SFT6', & 'MWT6', 'UZT6', 'IST6', 'API6') call expandarray(bndpkgs) @@ -1393,106 +967,16 @@ subroutine create_gwt_specific_packages(this, indis) end do ! ! -- Create packages that are tied directly to model - !call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - !call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) - !call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, this%eqnsclfac) call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, this%fmi) - !call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, this%tsplab, this%eqnsclfac) - !call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) - !call oc_cr(this%oc, this%name, this%inoc, this%iout) - !call tsp_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified call this%ftype_check(indis, this%inmst) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) - - end subroutine create_gwt_specific_packages - - !subroutine create_lstfile(this, lst_fname, model_fname, defined) - ! ! -- modules - ! use KindModule, only: LGP - ! use InputOutputModule, only: openfile, getunit - ! ! -- dummy - ! class(GwtModelType) :: this - ! character(len=*), intent(inout) :: lst_fname - ! character(len=*), intent(in) :: model_fname - ! logical(LGP), intent(in) :: defined - ! ! -- local - ! integer(I4B) :: i, istart, istop - ! ! - ! ! -- set list file name if not provided - ! if (.not. defined) then - ! ! - ! ! -- initialize - ! lst_fname = ' ' - ! istart = 0 - ! istop = len_trim(model_fname) - ! ! - ! ! -- identify '.' character position from back of string - ! do i = istop, 1, -1 - ! if (model_fname(i:i) == '.') then - ! istart = i - ! exit - ! end if - ! end do - ! ! - ! ! -- if not found start from string end - ! if (istart == 0) istart = istop + 1 - ! ! - ! ! -- set list file name - ! lst_fname = model_fname(1:istart) - ! istop = istart + 3 - ! lst_fname(istart:istop) = '.lst' - ! end if - ! ! - ! ! -- create the list file - ! this%iout = getunit() - ! call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') - ! ! - ! ! -- write list file header - ! call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') - ! ! - ! ! -- return - ! return - !end subroutine create_lstfile - - !!> @brief Write model namfile options to list file - !!< - !subroutine log_namfile_options(this, found) - ! use GwfNamInputModule, only: GwfNamParamFoundType - ! class(GwtModelType) :: this - ! type(GwfNamParamFoundType), intent(in) :: found - ! - ! write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' - ! - ! if (found%newton) then - ! write (this%iout, '(4x,a)') & - ! 'NEWTON-RAPHSON method enabled for the model.' - ! if (found%under_relaxation) then - ! write (this%iout, '(4x,a,a)') & - ! 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & - ! 'elevation of the model will be applied to the model.' - ! end if - ! end if - ! - ! if (found%print_input) then - ! write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - ! 'FOR ALL MODEL STRESS PACKAGES' - ! end if - ! - ! if (found%print_flows) then - ! write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - ! 'FOR ALL MODEL PACKAGES' - ! end if - ! - ! if (found%save_flows) then - ! write (this%iout, '(4x,a)') & - ! 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - ! end if - ! - ! write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' - !end subroutine log_namfile_options + ! + ! -- Return + return + end subroutine create_gwt_specific_packages end module GwtModule From a8339880178986103feeabf507e52e163ab06048 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 09:39:24 -0700 Subject: [PATCH 169/212] fprettify on gwe src code --- src/Model/GroundWaterEnergy/gwe1.f90 | 20 ++-- src/Model/GroundWaterEnergy/gwe1dsp1.f90 | 12 +-- src/Model/GroundWaterEnergy/gwe1lke1.f90 | 38 +++---- src/Model/GroundWaterEnergy/gwe1mst1.f90 | 25 ++--- src/Model/GroundWaterEnergy/gwe1mwe1.f90 | 34 +++---- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 40 ++++---- src/Model/GroundWaterEnergy/gwe1src1.f90 | 14 +-- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 104 ++++++++++---------- src/Model/GroundWaterTransport/gwt1sft1.f90 | 6 -- 9 files changed, 142 insertions(+), 151 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 73d93bd70e3..8b0a5ee8731 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -23,7 +23,7 @@ module GweModule public :: GweModelType public :: CastAsGweModel public :: niunit - + type, extends(TransportModelType) :: GweModelType type(GweInputDataType), pointer :: gwecommon => null() !< container for data shared with multiple packages @@ -90,7 +90,7 @@ subroutine gwe_cr(filename, id, modelname) integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local - integer(I4B) :: indis + integer(I4B) :: indis integer(I4B) :: ipakid, i, j, iu, ipaknum character(len=LINELENGTH) :: errmsg character(len=LENPACKAGENAME) :: pakname @@ -99,7 +99,7 @@ subroutine gwe_cr(filename, id, modelname) character(len=LENMEMPATH) :: input_mempath character(len=LINELENGTH) :: lst_fname type(GwfNamParamFoundType) :: found - + cunit(10) = 'TMP6 ' ! ------------------------------------------------------------------------------ ! @@ -129,7 +129,7 @@ end subroutine gwe_cr !> @brief Define packages of the GWE model !! - !! This subroutine defines a gwe model type. Steps include: + !! This subroutine defines a gwe model type. Steps include: !! - call df routines for each package !! - set variables and pointers !< @@ -214,7 +214,7 @@ subroutine gwe_ac(this, sparse) return end subroutine gwe_ac - !> @brief Map the positions of the GWE model connections in the numerical + !> @brief Map the positions of the GWE model connections in the numerical !! solution coefficient matrix. !< subroutine gwe_mc(this, matrix_sln) @@ -384,7 +384,7 @@ end subroutine gwe_ad !> @brief GWE Model calculate coefficients !! - !! This subroutine calls the attached packages' calculate coefficients + !! This subroutine calls the attached packages' calculate coefficients !! subroutines !< subroutine gwe_cf(this, kiter) @@ -409,7 +409,7 @@ end subroutine gwe_cf !> @brief GWE Model fill coefficients !! - !! This subroutine calls the attached packages' fill coefficients + !! This subroutine calls the attached packages' fill coefficients !! subroutines !< subroutine gwe_fc(this, kiter, matrix_sln, inwtflag) @@ -718,7 +718,7 @@ function gwe_get_iasym(this) result(iasym) end function gwe_get_iasym !> Allocate memory for non-allocatable members - !! + !! !! A subroutine for allocating the scalars specific to the GWE model type. !! Additional scalars used by the parent class are allocated by the parent !! class. @@ -839,7 +839,7 @@ function CastAsGweModel(model) result(gwemodel) ! -- Return return end function CastAsGweModel - + !> @brief Source package info and begin to process !< subroutine create_bndpkgs(this, bndpkgs, pkgtypes, pkgnames, & @@ -888,7 +888,7 @@ subroutine create_bndpkgs(this, bndpkgs, pkgtypes, pkgnames, & ipakid = ipakid + 1 ipaknum = ipaknum + 1 end do - ! + ! ! -- cleanup deallocate (bndpkgs) end if diff --git a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 index 9c3491ed24e..83d741dbb11 100644 --- a/src/Model/GroundWaterEnergy/gwe1dsp1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1dsp1.f90 @@ -9,7 +9,7 @@ module GweDspModule use GweDspOptionsModule, only: GweDspOptionsType use GweInputDataModule, only: GweInputDataType use MatrixBaseModule - + implicit none private public :: GweDspType @@ -137,7 +137,7 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi, & end subroutine dsp_cr !> @brief Define MST object - !! + !! !! Define the MST package !< subroutine dsp_df(this, dis, dspOptions) @@ -190,12 +190,6 @@ end subroutine dsp_df !! Add connections for extended neighbors to the sparse matrix !< subroutine dsp_ac(this, moffset, sparse) -! ****************************************************************************** -! dsp_ac -- -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix use MemoryManagerModule, only: mem_allocate @@ -786,7 +780,7 @@ subroutine calcdispellipse(this) ! ktbulk is divided by the explicitly calculated product rhow*cpw, ! and not by the equivalent scale factor eqnsclfac, even though it ! should make no practical difference in the result. - dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) ! kluge note eqnsclfac, define product + dstar = ktbulk / (this%gwecommon%gwecpw * this%gwecommon%gwerhow) ! kluge note eqnsclfac, define product ! ! -- Calculate the longitudal and transverse dispersivities al = DZERO diff --git a/src/Model/GroundWaterEnergy/gwe1lke1.f90 b/src/Model/GroundWaterEnergy/gwe1lke1.f90 index db6258e6dea..fc5dd862710 100644 --- a/src/Model/GroundWaterEnergy/gwe1lke1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1lke1.f90 @@ -55,7 +55,7 @@ module GweLkeModule character(len=16) :: text = ' LKE' type, extends(TspAptType) :: GweLkeType - + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr @@ -143,7 +143,7 @@ subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages lkeobj%fmi => fmi ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature lkeobj%tsplab => tsplab ! @@ -161,7 +161,7 @@ end subroutine lke_create !> @brief Find corresponding lke package !< - subroutine find_lke_package(this) + subroutine find_lke_package(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -305,9 +305,9 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval - real(DP) :: ctherm !< thermal conductance + real(DP) :: ctherm !< thermal conductance real(DP) :: wa !< wetted area - real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive streambed material ! ------------------------------------------------------------------------------ ! @@ -386,7 +386,7 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ! -- set acoef and rhs to negative so they are relative to sfe and not gwe auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux - wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j) ktf = this%ktf(n) s = this%rfeatthk(n) ctherm = ktf * wa / s @@ -394,7 +394,7 @@ subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to sfe row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below call matrix_sln%add_value_pos(iposoffd, ctherm) ! ! -- add to gwe row for sfe connection @@ -486,12 +486,12 @@ function lke_get_nbudterms(this) result(nbudterms) ! ------------------------------------------------------------------------------ ! ! -- Number of budget terms is 7 - ! 1) rainfall - ! 2) evap - ! 3) runoff - ! 4) ext-inflow + ! 1) rainfall + ! 2) evap + ! 3) runoff + ! 4) ext-inflow ! 5) withdrawl - ! 6) ext-outflow + ! 6) ext-outflow ! 7) lakebed-cond ! nbudterms = 7 @@ -580,7 +580,7 @@ subroutine lke_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- Removal of heat associated with outflow from lake that leaves + ! -- Removal of heat associated with outflow from lake that leaves ! model domain text = ' EXT-OUTFLOW' idx = idx + 1 @@ -638,7 +638,7 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q real(DP) :: ctherm !< thermal conductance real(DP) :: wa !< wetted area - real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- @@ -711,12 +711,12 @@ subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout) n1 = this%flowbudptr%budterm(this%idxbudlbcd)%id1(j) if (this%iboundpak(n1) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudlbcd)%id2(j) - auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' - wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j) ktf = this%ktf(n1) s = this%rfeatthk(n1) - ctherm = ktf * wa / s - q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct + ctherm = ktf * wa / s + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct !q = -q ! flip sign so relative to advanced package feature end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) @@ -922,7 +922,7 @@ end subroutine lke_roff_term !> @brief Inflow Term !! - !! Accounts for energy flowing into a lake from a connected stream, for + !! Accounts for energy flowing into a lake from a connected stream, for !! example. !< subroutine lke_iflw_term(this, ientry, n1, n2, rrate, & diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index 642f39e2426..e2573719a7e 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -83,7 +83,7 @@ module GweMstModule !> @ brief Create a new MST object !! - !! Create a new MST package + !! Create a new MST package !< subroutine mst_cr(mstobj, name_model, inunit, iout, fmi, eqnsclfac, gwecommon) ! -- dummy @@ -292,7 +292,7 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & ! -- first order decay rate is a function of temperature, so add ! kluge note: do we need/want first-order decay for temperature??? ! to left hand side hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) & - * this%eqnsclfac + * this%eqnsclfac call matrix_sln%add_value_pos(idxglo(idiag), hhcof) elseif (this%idcy == 2) then ! @@ -300,7 +300,7 @@ subroutine mst_fc_dcy(this, nodes, cold, cnew, nja, matrix_sln, & ! from the user-specified rate to prevent negative temperatures ! kluge note: think through negative temps decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & kiter, cold(n), cnew(n), delt) - ! -- This term does get divided by eqnsclfac for fc purposes because it + ! -- This term does get divided by eqnsclfac for fc purposes because it ! should start out being a rate of energy this%decaylast(n) = decay_rate rrhs = decay_rate * vcell * swtpdt * this%porosity(n) @@ -374,8 +374,10 @@ subroutine mst_cq_sto(this, nodes, cnew, cold, flowja) vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n)) vwatnew = vcell * this%fmi%gwfsat(n) * this%porosity(n) vwatold = vwatnew - if (this%fmi%igwfstrgss /= 0) vwatold = vwatold + this%fmi%gwfstrgss(n) * delt - if (this%fmi%igwfstrgsy /= 0) vwatold = vwatold + this%fmi%gwfstrgsy(n) * delt + if (this%fmi%igwfstrgss /= 0) vwatold = vwatold + this%fmi%gwfstrgss(n) & + * delt + if (this%fmi%igwfstrgsy /= 0) vwatold = vwatold + this%fmi%gwfstrgsy(n) & + * delt vsolid = vcell * (DONE - this%porosity(n)) ! ! -- calculate rate @@ -396,7 +398,7 @@ end subroutine mst_cq_sto !! !! Method to calculate decay terms for the package. !< - subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) ! kluge note: this handles only decay in water; need to add zero-order (but not first-order?) decay in solid + subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) ! kluge note: this handles only decay in water; need to add zero-order (but not first-order?) decay in solid ! -- modules use TdisModule, only: delt ! -- dummy @@ -431,12 +433,13 @@ subroutine mst_cq_dcy(this, nodes, cnew, cold, flowja) ! kluge note: this han rate = DZERO hhcof = DZERO rrhs = DZERO - if (this%idcy == 1) then ! kluge note: do we need/want first-order decay for temperature??? - hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) * this%eqnsclfac + if (this%idcy == 1) then ! kluge note: do we need/want first-order decay for temperature??? + hhcof = -this%decay(n) * vcell * swtpdt * this%porosity(n) & + * this%eqnsclfac elseif (this%idcy == 2) then decay_rate = get_zero_order_decay(this%decay(n), this%decaylast(n), & 0, cold(n), cnew(n), delt) - rrhs = decay_rate * vcell * swtpdt * this%porosity(n) ! kluge note: this term does NOT get multiplied by eqnsclfac for cq purposes because it should already be a rate of energy + rrhs = decay_rate * vcell * swtpdt * this%porosity(n) ! kluge note: this term does NOT get multiplied by eqnsclfac for cq purposes because it should already be a rate of energy end if rate = hhcof * cnew(n) - rrhs this%ratedcy(n) = rate @@ -866,7 +869,7 @@ end subroutine read_packagedata !! Function to calculate the zero-order decay rate from the user specified !! decay rate. If the decay rate is positive, then the decay rate must !! be constrained so that more energy is not removed than is available. - !! Without this constraint, negative temperatures could result from + !! Without this constraint, negative temperatures could result from !! zero-order decay (no freezing). !< function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & @@ -892,7 +895,7 @@ function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & ! temperature, so reduce the rate if it would result in ! removing more energy than is in the cell. ! kluge note: think through if (kiter == 1) then - decay_rate = min(decay_rate_usr, cold / delt) ! kluge note: actually want to use rhow*cpw*cold and rhow*cpw*cnew for rates here and below + decay_rate = min(decay_rate_usr, cold / delt) ! kluge note: actually want to use rhow*cpw*cold and rhow*cpw*cnew for rates here and below else decay_rate = decay_rate_last if (cnew < DZERO) then diff --git a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 index 6dc62541edf..eddb400a15f 100644 --- a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 @@ -56,7 +56,7 @@ module GweMweModule character(len=16) :: text = ' MWE' type, extends(TspAptType) :: GweMweType - + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst integer(I4B), pointer :: idxbudrate => null() ! index of well rate terms in flowbudptr @@ -90,7 +90,7 @@ module GweMweModule contains - !> Create new MWE package + !> Create new MWE package !< subroutine mwe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac, gwecommon) @@ -136,7 +136,7 @@ subroutine mwe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages mweobj%fmi => fmi ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature mweobj%tsplab => tsplab ! @@ -294,9 +294,9 @@ subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval - real(DP) :: ctherm ! kluge? + real(DP) :: ctherm ! kluge? real(DP) :: wa !< wetted area - real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive wellbore material ! ------------------------------------------------------------------------------ ! @@ -353,7 +353,7 @@ subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ! -- set acoef and rhs to negative so they are relative to mwe and not gwe auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux - wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j) ktf = this%ktf(n) s = this%rfeatthk(n) ctherm = ktf * wa / s @@ -361,7 +361,7 @@ subroutine mwe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add to mwe row iposd = this%idxdglo(j) iposoffd = this%idxoffdglo(j) - call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below + call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below call matrix_sln%add_value_pos(iposoffd, ctherm) ! ! -- add to gwe row for mwe connection @@ -438,7 +438,7 @@ function mwe_get_nbudterms(this) result(nbudterms) ! ------------------------------------------------------------------------------ ! ! -- Number of potential budget terms is 5 - nbudterms = 1 ! RATE + nbudterms = 1 ! RATE if (this%idxbudfwrt /= 0) nbudterms = nbudterms + 1 if (this%idxbudrtmv /= 0) nbudterms = nbudterms + 1 if (this%idxbudfrtm /= 0) nbudterms = nbudterms + 1 @@ -565,7 +565,7 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q real(DP) :: ctherm real(DP) :: wa !< wetted area - real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- @@ -624,17 +624,17 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) n1 = this%flowbudptr%budterm(this%idxbudmwcd)%id1(j) if (this%iboundpak(n1) /= 0) then igwfnode = this%flowbudptr%budterm(this%idxbudmwcd)%id2(j) - auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' - wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF' + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j) ktf = this%ktf(n1) s = this%rfeatthk(n1) - ctherm = ktf * wa / s - q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct + ctherm = ktf * wa / s + q = ctherm * (x(igwfnode) - this%xnewpak(n1)) ! kluge note: check that sign is correct !q = -q ! flip sign so relative to advanced package feature end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) - if (this%iboundpak(n1) /= 0) then + if (this%iboundpak(n1) /= 0) then ! -- contribution to gwe cell budget this%simvals(j) = this%simvals(j) - q idiag = this%dis%con%ia(igwfnode) @@ -646,7 +646,7 @@ subroutine mwe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) return end subroutine mwe_fill_budobj - !> @brief Allocate scalars specific to the multi-aquifer well energy + !> @brief Allocate scalars specific to the multi-aquifer well energy !! transport (MWE) package. !< subroutine allocate_scalars(this) @@ -732,7 +732,7 @@ subroutine mwe_da(this) return end subroutine mwe_da - !> @brief Thermal transport matrix term(s) associcated with a user-specified + !> @brief Thermal transport matrix term(s) associcated with a user-specified !! flow rate (mwe_rate_term) !< subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & @@ -771,7 +771,7 @@ subroutine mwe_rate_term(this, ientry, n1, n2, rrate, & return end subroutine mwe_rate_term - !> @brief Thermal transport matrix term(s) associcated with a flowing- + !> @brief Thermal transport matrix term(s) associcated with a flowing- !! well rate term associated with pumping (or injection) !< subroutine mwe_fwrt_term(this, ientry, n1, n2, rrate, & diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index f6369646a0e..31fb883d50a 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -3,7 +3,7 @@ ! -- todo: save the sfe temperature into the sfr aux variable? (perhaps needed for GWT-GWE exchanges) ! -- todo: calculate the sfr VISC aux variable using temperature? ! -! SFR flows (sfrbudptr) index var SFE term Transport Type +! SFR flows (sfrbudptr) index var SFE term Transport Type !--------------------------------------------------------------------------------- ! -- terms from SFR that will be handled by parent APT Package @@ -58,7 +58,7 @@ module GweSfeModule type, extends(TspAptType) :: GweSfeType type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst - + integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr @@ -94,7 +94,7 @@ module GweSfeModule end type GweSfeType - contains +contains !> @brief Create a new sfe package !< @@ -142,7 +142,7 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages sfeobj%fmi => fmi ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature sfeobj%tsplab => tsplab ! @@ -305,7 +305,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) real(DP) :: hcofval real(DP) :: ctherm real(DP) :: wa !< wetted area - real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive streambed material ! ------------------------------------------------------------------------------ ! @@ -323,7 +323,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add evaporation contribution if (this%idxbudevap /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist - call this%sfe_evap_term(j, n1, n2, rrate, rhsval, hcofval) ! kluge note: included hcofval in the call; it'll be set to zero + call this%sfe_evap_term(j, n1, n2, rrate, rhsval, hcofval) ! kluge note: included hcofval in the call; it'll be set to zero iloc = this%idxlocnode(n1) iposd = this%idxpakdiag(n1) call matrix_sln%add_value_pos(iposd, hcofval) @@ -373,7 +373,7 @@ subroutine sfe_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ! -- set acoef and rhs to negative so they are relative to sfe and not gwe auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux - wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j) ktf = this%ktf(n) s = this%rfeatthk(n) ctherm = ktf * wa / s @@ -398,7 +398,7 @@ end subroutine sfe_fc_expanded !> @ brief Add terms specific to sfr to the explicit sfe solve !< - subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/useful if there's streambed conduction??? + subroutine sfe_solve(this) ! kluge note: will explicit solve still be possible/useful if there's streambed conduction??? ! -- dummy class(GweSfeType) :: this ! -- local @@ -559,7 +559,7 @@ subroutine sfe_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- conduction through the wetted streambed + ! -- conduction through the wetted streambed text = ' STREAMBED-COND' idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudsbcd)%maxlist @@ -603,7 +603,7 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP) :: q real(DP) :: ctherm real(DP) :: wa !< wetted area - real(DP) :: ktf !< thermal conductivity of streambed material + real(DP) :: ktf !< thermal conductivity of streambed material real(DP) :: s !< thickness of conductive streambed materia ! -- formats ! ----------------------------------------------------------------------------- @@ -668,15 +668,15 @@ subroutine sfe_fill_budobj(this, idx, x, flowja, ccratin, ccratout) igwfnode = this%flowbudptr%budterm(this%idxbudsbcd)%id2(j) ! for now, there is only 1 aux variable under 'GWF' auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux - wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos,j) + wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j) ktf = this%ktf(n1) s = this%rfeatthk(n1) - ctherm = ktf * wa / s + ctherm = ktf * wa / s q = ctherm * (x(igwfnode) - this%xnewpak(n1)) end if call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) - if (this%iboundpak(n1) /= 0) then + if (this%iboundpak(n1) /= 0) then ! -- contribution to gwe cell budget this%simvals(n1) = this%simvals(n1) - q idiag = this%dis%con%ia(igwfnode) @@ -806,8 +806,8 @@ subroutine sfe_rain_term(this, ientry, n1, n2, rrate, & n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry) ctmp = this%temprain(n1) - if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac ! kluge note: think about budget / sensible heat issue - if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now + if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac ! kluge note: think about budget / sensible heat issue + if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! ! -- Return @@ -835,7 +835,7 @@ subroutine sfe_evap_term(this, ientry, n1, n2, rrate, & ! -- note that qbnd is negative for evap qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry) heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap - if (present(rrate)) rrate = qbnd * heatlat + if (present(rrate)) rrate = qbnd * heatlat !!if (present(rhsval)) rhsval = -rrate / this%eqnsclfac ! kluge note: divided by eqnsclfac for fc purposes because rrate is in terms of energy if (present(rhsval)) rhsval = -rrate if (present(hcofval)) hcofval = DZERO @@ -864,7 +864,7 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry) ctmp = this%temproff(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac - if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now + if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! ! -- return @@ -874,7 +874,7 @@ end subroutine sfe_roff_term !> @brief Inflow Term !! !! Accounts for energy added via streamflow entering into a stream channel; - !! for example, energy entering the model domain via a specified flow in a + !! for example, energy entering the model domain via a specified flow in a !! stream channel. !< subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) @@ -895,7 +895,7 @@ subroutine sfe_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval) qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry) ctmp = this%tempiflw(n1) if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac - if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now + if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! ! -- Return @@ -904,7 +904,7 @@ end subroutine sfe_iflw_term !> @brief Outflow term !! - !! Accounts for the energy leaving a stream channel, for example, energy exiting the + !! Accounts for the energy leaving a stream channel, for example, energy exiting the !! model domain via a flow in a stream channel flowing out of the active domain. !< subroutine sfe_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval) diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index 3d749bcb79d..191e0b3d805 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -20,11 +20,11 @@ module GweSrcModule character(len=16) :: text = ' SRC' ! type, extends(BndType) :: GweSrcType - + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst - + contains - + procedure :: allocate_scalars => src_allocate_scalars procedure :: bnd_cf => src_cf procedure :: bnd_fc => src_fc @@ -40,7 +40,7 @@ module GweSrcModule contains !> @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, & @@ -80,7 +80,7 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ncolbnd = 1 packobj%iscloc = 1 ! - ! -- Store pointer to labels associated with the current model so that the + ! -- Store pointer to labels associated with the current model so that the ! package has access to the assigned labels packobj%tsplab => tsplab ! @@ -214,7 +214,7 @@ subroutine src_fc(this, rhs, ia, idxglo, matrix_sln) end subroutine src_fc !> @brief Define list labels - !! + !! !! Define the list heading that is written to iout when !! PRINT_INPUT option is used. !< @@ -292,7 +292,7 @@ end subroutine src_df_obs !> @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 + !! In the SRC package only the SENERRATE variable can be controlled by time !! series. !< subroutine src_rp_ts(this) diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 7322221ca18..184443acfd5 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -38,9 +38,9 @@ module GweUzeModule use TspLabelsModule, only: TspLabelsType use GweInputDataModule, only: GweInputDataType use MatrixBaseModule - + implicit none - + public uze_create character(len=*), parameter :: ftype = 'UZE' @@ -48,7 +48,7 @@ module GweUzeModule character(len=16) :: text = ' UZE' type, extends(TspAptType) :: GweUzeType - + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst integer(I4B), pointer :: idxbudinfl => null() ! index of uzf infiltration terms in flowbudptr @@ -132,7 +132,7 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages uzeobj%fmi => fmi ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature uzeobj%tsplab => tsplab ! @@ -268,11 +268,11 @@ subroutine find_uze_package(this) ! -- Return return end subroutine find_uze_package - - !> @brief Add package connection to matrix. + + !> @brief Add package connection to matrix. !! - !! Overrides apt_ac to fold the UZE heat balance terms into the row - !! corresponding to the host cell and enforce thermal equilibrium between + !! Overrides apt_ac to fold the UZE heat balance terms into the row + !! corresponding to the host cell and enforce thermal equilibrium between !! UZE and the GWE cell. !< subroutine uze_ac(this, moffset, sparse) @@ -285,7 +285,7 @@ subroutine uze_ac(this, moffset, sparse) ! -- local integer(I4B) :: i, ii integer(I4B) :: n !< index of a uze object within the complete list of uze objects - integer(I4B) :: jj !< + integer(I4B) :: jj !< integer(I4B) :: nglo !< index of uze object in global matrix integer(I4B) :: jglo !< host cell's position in global matrix for a uze object integer(I4B) :: idxn !< used for cross-check @@ -316,10 +316,10 @@ subroutine uze_ac(this, moffset, sparse) call sparse%addconnection(jglo, nglo, 1) end do ! - ! -- For uze, add feature-to-feature connections (i.e., - ! vertically stacked UZ objects) to row corresponding - ! to the host cell. Terms added to the row associated with host - ! cell are added to columns associated with other uze features. + ! -- For uze, add feature-to-feature connections (i.e., + ! vertically stacked UZ objects) to row corresponding + ! to the host cell. Terms added to the row associated with host + ! cell are added to columns associated with other uze features. ! This approach deviates from the approach taken in apt_ac. if (this%idxbudfjf /= 0) then do i = 1, this%flowbudptr%budterm(this%idxbudfjf)%maxlist @@ -327,7 +327,7 @@ subroutine uze_ac(this, moffset, sparse) jj = this%flowbudptr%budterm(this%idxbudfjf)%id2(i) !< position of connected uze feature nglo = moffset + this%dis%nodes + this%ioffset + n !< global position of currently considered uze feature jglo = moffset + this%dis%nodes + this%ioffset + jj !< global position of connected uze feature - ! -- if connected uze feature is upstream, find cell that hosts currently + ! -- if connected uze feature is upstream, find cell that hosts currently ! considered uze feature and add connection to that cell's row do ii = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist !< uze object id among uze objects idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(ii) !< uze object position within uze object list @@ -344,7 +344,7 @@ subroutine uze_ac(this, moffset, sparse) ! -- return return end subroutine uze_ac - + !> @brief Map package connection to matrix !< subroutine uze_mc(this, moffset, matrix_sln) @@ -381,12 +381,12 @@ subroutine uze_mc(this, moffset, matrix_sln) do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) !< feature number j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) !< cell number - iglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index - jglo = j + moffset !< cell row index + iglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index + jglo = j + moffset !< cell row index ! -- Note that this is where idxlocnode is set for uze; it is set ! to the host cell local row index rather than the feature local ! row index - this%idxlocnode(n) = j ! kluge note: do we want to introduce a new array instead of co-opting idxlocnode??? + this%idxlocnode(n) = j ! kluge note: do we want to introduce a new array instead of co-opting idxlocnode??? ! -- for connection ipos in list of feature-cell connections, ! global positions of feature-row diagonal and off-diagonal ! corresponding to the cell @@ -398,8 +398,8 @@ subroutine uze_mc(this, moffset, matrix_sln) do ipos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist n = this%flowbudptr%budterm(this%idxbudgwf)%id1(ipos) !< feature number j = this%flowbudptr%budterm(this%idxbudgwf)%id2(ipos) !< cell number - iglo = j + moffset !< cell row index - jglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index + iglo = j + moffset !< cell row index + jglo = moffset + this%dis%nodes + this%ioffset + n !< feature row index ! -- for connection ipos in list of feature-cell connections, ! global positions of cell-row diagonal and off-diagonal ! corresponding to the feature @@ -414,13 +414,13 @@ subroutine uze_mc(this, moffset, matrix_sln) j = this%flowbudptr%budterm(this%idxbudfjf)%id2(ipos) !< number of connected uze feature iglo = moffset + this%dis%nodes + this%ioffset + n !< global position of currently considered uze feature jglo = moffset + this%dis%nodes + this%ioffset + j !< global position of connected uze feature - ! -- if connected uze feature is upstream, find cell that hosts currently + ! -- if connected uze feature is upstream, find cell that hosts currently ! considered uze feature and map connection to that cell's row do idxpos = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist idxn = this%flowbudptr%budterm(this%idxbudgwf)%id1(idxpos) !< feature number idxj = this%flowbudptr%budterm(this%idxbudgwf)%id2(idxpos) !< cell number) - idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature row index - idxiglo = moffset + idxj !< cell row index + idxjglo = moffset + this%dis%nodes + this%ioffset + idxn !< feature row index + idxiglo = moffset + idxj !< cell row index if (idxjglo == iglo) exit end do ! -- for connection ipos in list of feature-feature connections, @@ -466,13 +466,13 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! ------------------------------------------------------------------------------ ! ! -- add infiltration contribution - ! uze does not put feature balance coefficients in the row + ! uze does not put feature balance coefficients in the row ! associated with the feature. Instead, these coefficients are ! moved into the row associated with cell hosting the uze feature if (this%idxbudinfl /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudinfl)%nlist call this%uze_infl_term(j, n1, n2, rrate, rhsval, hcofval) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -483,7 +483,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudrinf /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudrinf)%nlist call this%uze_rinf_term(j, n1, n2, rrate, rhsval, hcofval) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -494,7 +494,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbuduzet /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbuduzet)%nlist call this%uze_uzet_term(j, n1, n2, rrate, rhsval, hcofval) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -505,20 +505,20 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudritm /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudritm)%nlist call this%uze_ritm_term(j, n1, n2, rrate, rhsval, hcofval) - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval end do end if ! - ! -- For UZE, content of apt_fc_expanded placed here as the approach is to + ! -- For UZE, content of apt_fc_expanded placed here as the approach is to ! completely override apt_fc_expanded() with what follows ! ! -- mass (or energy) storage in features do n = 1, this%ncv cold = this%xoldpak(n) - iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(n) call this%apt_stor_term(n, n1, n2, rrate, rhsval, hcofval) call matrix_sln%add_value_pos(ipossymoffd, hcofval) @@ -529,11 +529,11 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudtmvr /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudtmvr)%nlist call this%apt_tmvr_term(j, n1, n2, rrate, rhsval, hcofval) - !NOTE: originally was iposd, but changed to idxsymdglo on the first + !NOTE: originally was iposd, but changed to idxsymdglo on the first ! modification. It was later realized we needed idxsymoffdglo. ! (If this works, consider changing 'ipossymd' to 'ipossymoffd' ! - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -543,8 +543,8 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add from mover contribution if (this%idxbudfmvr /= 0) then do n = 1, this%ncv - rhsval = this%qmfrommvr(n) ! kluge note: presumably already in terms of energy - iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index + rhsval = this%qmfrommvr(n) ! kluge note: presumably already in terms of energy + iloc = this%idxlocnode(n) ! for uze idxlocnode stores the host cell local row index rhs(iloc) = rhs(iloc) - rhsval end do end if @@ -576,8 +576,8 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) else omega = DZERO end if - iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row - iposoffd = this%idxfjfoffdglo(j) !< position of feature-id2 column in feature id1's host-cell row + iposd = this%idxfjfdglo(j) !< position of feature-id1 column in feature id1's host-cell row + iposoffd = this%idxfjfoffdglo(j) !< position of feature-id2 column in feature id1's host-cell row call matrix_sln%add_value_pos(iposd, omega * qbnd * this%eqnsclfac) call matrix_sln%add_value_pos(iposoffd, & (DONE - omega) * qbnd * this%eqnsclfac) @@ -591,7 +591,7 @@ end subroutine uze_fc_expanded !> @brief Explicit solve !! !! There should be no explicit solve for uze. However, if there were, then - !! this subroutine would add terms specific to the unsaturated zone to the + !! this subroutine would add terms specific to the unsaturated zone to the !! explicit unsaturated-zone solve subroutine uze_solve(this) ! -- dummy @@ -642,7 +642,7 @@ end subroutine uze_solve !! !! Function to return the number of budget terms just for this package. !! This overrides function in parent. - !< + !< function uze_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy @@ -780,7 +780,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- formats ! ----------------------------------------------------------------------------- ! - allocate(budresid(this%ncv)) + allocate (budresid(this%ncv)) do n1 = 1, this%ncv budresid(n1) = DZERO end do @@ -917,11 +917,11 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) do j = 1, nlist n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(j) igwfnode = this%flowbudptr%budterm(this%idxbudgwf)%id2(j) - q = - budresid(n1) + q = -budresid(n1) call this%uze_theq_term(j, n1, igwfnode, q) call this%budobj%budterm(idx)%update_term(n1, igwfnode, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) - if (this%iboundpak(n1) /= 0) then + if (this%iboundpak(n1) /= 0) then ! -- contribution to gwe cell budget this%simvals(n1) = this%simvals(n1) - q idiag = this%dis%con%ia(igwfnode) @@ -929,7 +929,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) end if end do ! - deallocate(budresid) + deallocate (budresid) ! ! -- return return @@ -1047,7 +1047,7 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & real(DP) :: ctmp real(DP) :: h, r ! ------------------------------------------------------------------------------ - ! + ! n1 = this%flowbudptr%budterm(this%idxbudinfl)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudinfl)%id2(ientry) ! -- note that qbnd is negative for negative infiltration @@ -1071,7 +1071,7 @@ end subroutine uze_infl_term !> @brief Rejected infiltration term !! - !! Accounts for energy that is added to the model from specifying an + !! Accounts for energy that is added to the model from specifying an !! infiltration rate and temperature, but is subsequently removed from !! the model as that portion of the infiltration that is rejected (and !! NOT transferred to another advanced package via the MVR/MVT packages). @@ -1090,7 +1090,7 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & real(DP) :: qbnd real(DP) :: ctmp ! ------------------------------------------------------------------------------ - ! + ! n1 = this%flowbudptr%budterm(this%idxbudrinf)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudrinf)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudrinf)%flow(ientry) @@ -1105,7 +1105,7 @@ end subroutine uze_rinf_term !> @brief Evapotranspiration from the unsaturated-zone term !! - !! Accounts for thermal cooling in the unsaturated zone as a result of + !! Accounts for thermal cooling in the unsaturated zone as a result of !! evapotranspiration from the unsaturated zone. Amount of water converted !! to vapor phase (UZET) determined by GWF model !< @@ -1121,9 +1121,9 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, rhsval, hcofval) ! -- local real(DP) :: qbnd real(DP) :: ctmp - real(DP) :: omega + real(DP) :: omega ! ------------------------------------------------------------------------------ - ! + ! n1 = this%flowbudptr%budterm(this%idxbuduzet)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbuduzet)%id2(ientry) ! -- note that qbnd is negative for uzet @@ -1136,7 +1136,7 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, rhsval, hcofval) end if if (present(rrate)) & rrate = (omega * qbnd * this%xnewpak(n1) + & - (DONE - omega) * qbnd * ctmp) * this%eqnsclfac + (DONE - omega) * qbnd * ctmp) * this%eqnsclfac if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * this%eqnsclfac if (present(hcofval)) hcofval = omega * qbnd * this%eqnsclfac ! @@ -1146,7 +1146,7 @@ end subroutine uze_uzet_term !> @brief Rejected infiltration to MVR/MVT term !! - !! Accounts for energy that is added to the model from specifying an + !! Accounts for energy that is added to the model from specifying an !! infiltration rate and temperature, but does not infiltrate into the !! subsurface. This subroutine is called when the rejected infiltration !! is transferred to another advanced package via the MVR/MVT packages. @@ -1165,7 +1165,7 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & real(DP) :: qbnd real(DP) :: ctmp ! ------------------------------------------------------------------------------ - ! + ! n1 = this%flowbudptr%budterm(this%idxbudritm)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudritm)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudritm)%flow(ientry) @@ -1181,7 +1181,7 @@ end subroutine uze_ritm_term !> @brief Heat transferred through thermal equilibrium with the solid phase !! - !! Accounts for the transfer of energy from the liquid phase to the solid + !! Accounts for the transfer of energy from the liquid phase to the solid !! phase as a result of the instantaneous thermal equilibrium assumption. !< subroutine uze_theq_term(this, ientry, n1, n2, rrate) diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 0631ce08ce4..805149ce1a5 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -350,12 +350,6 @@ end subroutine sft_fc_expanded !> @brief Add terms specific to sft to the explicit sft solve !< subroutine sft_solve(this) -! ****************************************************************************** -! sft_solve -- add terms specific to sfr to the explicit sfr solve -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtSftType) :: this ! -- local From 534b90a8d25ce7035dd9b611602e912af801d027 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 10:00:52 -0700 Subject: [PATCH 170/212] fprettify on gwt --- src/Model/GroundWaterTransport/gwt1.f90 | 25 ++++++++------------- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 4 ++-- src/Model/GroundWaterTransport/gwt1lkt1.f90 | 6 ++--- src/Model/GroundWaterTransport/gwt1mwt1.f90 | 10 ++++----- src/Model/GroundWaterTransport/gwt1sft1.f90 | 8 +++---- src/Model/GroundWaterTransport/gwt1src1.f90 | 10 ++++----- src/Model/GroundWaterTransport/gwt1uzt1.f90 | 16 ++++++------- 7 files changed, 36 insertions(+), 43 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 7759da8a3e3..f4322e833e0 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -63,7 +63,7 @@ module GwtModule procedure :: get_iasym => gwt_get_iasym procedure, private :: create_gwt_specific_packages procedure, private :: create_bndpkgs - + end type GwtModelType contains @@ -125,7 +125,7 @@ end subroutine gwt_cr !> @brief Define packages of the GWT model !! - !! This subroutine defines a gwt model type. Steps include: + !! This subroutine defines a gwt model type. Steps include: !! - call df routines for each package !! - set variables and pointers !< @@ -141,7 +141,7 @@ subroutine gwt_df(this) ! ------------------------------------------------------------------------------ ! ! -- Set labels to be used with transport model - call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') + call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') ! ! -- Define packages and utility objects call this%dis%dis_df() @@ -206,7 +206,7 @@ subroutine gwt_ac(this, sparse) return end subroutine gwt_ac - !> @brief Map the positions of the GWT model connections in the numerical + !> @brief Map the positions of the GWT model connections in the numerical !! solution coefficient matrix. !< subroutine gwt_mc(this, matrix_sln) @@ -325,16 +325,9 @@ end subroutine gwt_rp !> @brief GWT Model Time Step Advance !! - !! This subroutine calls the attached packages' advance subroutines + !! This subroutine calls the attached packages advance subroutines !< subroutine gwt_ad(this) -! ****************************************************************************** -! gwt_ad -- GroundWater Transport Model Time Step Advance -! Subroutine: (1) calls package advance subroutines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimVariablesModule, only: isimcheck, iFailedStepRetry ! -- dummy @@ -390,7 +383,7 @@ end subroutine gwt_ad !> @brief GWT Model calculate coefficients !! - !! This subroutine calls the attached packages' calculate coefficients + !! This subroutine calls the attached packages' calculate coefficients !! subroutines !< subroutine gwt_cf(this, kiter) @@ -415,7 +408,7 @@ end subroutine gwt_cf !> @brief GWT Model fill coefficients !! - !! This subroutine calls the attached packages' fill coefficients + !! This subroutine calls the attached packages' fill coefficients !! subroutines !< subroutine gwt_fc(this, kiter, matrix_sln, inwtflag) @@ -721,7 +714,7 @@ function gwt_get_iasym(this) result(iasym) end function gwt_get_iasym !> Allocate memory for non-allocatable members - !! + !! !! A subroutine for allocating the scalars specific to the GWT model type. !! Additional scalars used by the parent class are allocated by the parent !! class. @@ -824,7 +817,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! ! -- Return return - end subroutine package_create + end subroutine package_create !> @brief Cast to GwtModelType !< diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index c9e2c57ca66..e2152b797bf 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -125,7 +125,7 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) end subroutine dsp_cr !> @brief Define MST object - !! + !! !! Define the MST package !< subroutine dsp_df(this, dis, dspOptions) @@ -198,7 +198,7 @@ end subroutine dsp_ac !> @brief Map DSP connections !! !! Map connections and construct iax, jax, and idxglox - !< + !< subroutine dsp_mc(this, moffset, matrix_sln) ! -- modules use MemoryManagerModule, only: mem_allocate diff --git a/src/Model/GroundWaterTransport/gwt1lkt1.f90 b/src/Model/GroundWaterTransport/gwt1lkt1.f90 index 75c22659832..69851917945 100644 --- a/src/Model/GroundWaterTransport/gwt1lkt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1lkt1.f90 @@ -138,7 +138,7 @@ subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages lktobj%fmi => fmi ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature lktobj%tsplab => tsplab ! @@ -526,7 +526,7 @@ subroutine lkt_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- Removal of heat associated with outflow from lake that leaves + ! -- Removal of heat associated with outflow from lake that leaves ! model domain text = ' EXT-OUTFLOW' idx = idx + 1 @@ -820,7 +820,7 @@ end subroutine lkt_roff_term !> @brief Inflow Term !! - !! Accounts for mass flowing into a lake from a connected stream, for + !! Accounts for mass flowing into a lake from a connected stream, for !! example. !< subroutine lkt_iflw_term(this, ientry, n1, n2, rrate, & diff --git a/src/Model/GroundWaterTransport/gwt1mwt1.f90 b/src/Model/GroundWaterTransport/gwt1mwt1.f90 index 8af5bfc90b2..1bd83ce3dbc 100644 --- a/src/Model/GroundWaterTransport/gwt1mwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1mwt1.f90 @@ -86,7 +86,7 @@ module GwtMwtModule contains - !> Create new MWT package + !> Create new MWT package !< subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi, tsplab, eqnsclfac) @@ -131,7 +131,7 @@ subroutine mwt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages mwtobj%fmi => fmi ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature mwtobj%tsplab => tsplab ! @@ -668,7 +668,7 @@ subroutine mwt_rate_term(this, ientry, n1, n2, rrate, & return end subroutine mwt_rate_term - !> @brief Transport matrix term(s) associcated with a flowing- + !> @brief Transport matrix term(s) associcated with a flowing- !! well rate term associated with pumping (or injection) !< subroutine mwt_fwrt_term(this, ientry, n1, n2, rrate, & @@ -699,7 +699,7 @@ end subroutine mwt_fwrt_term !> @brief Rate-to-mvr term associated with pumping (or injection) !! - !! Pumped water that is made available to the MVR package for transfer to + !! Pumped water that is made available to the MVR package for transfer to !! another advanced package !< subroutine mwt_rtmv_term(this, ientry, n1, n2, rrate, & @@ -730,7 +730,7 @@ end subroutine mwt_rtmv_term !> @brief Flowing well rate-to-mvr term (or injection) !! - !! Pumped water that is made available to the MVR package for transfer to + !! Pumped water that is made available to the MVR package for transfer to !! another advanced package !< subroutine mwt_frtm_term(this, ientry, n1, n2, rrate, & diff --git a/src/Model/GroundWaterTransport/gwt1sft1.f90 b/src/Model/GroundWaterTransport/gwt1sft1.f90 index 805149ce1a5..0fbc0addaa2 100644 --- a/src/Model/GroundWaterTransport/gwt1sft1.f90 +++ b/src/Model/GroundWaterTransport/gwt1sft1.f90 @@ -138,7 +138,7 @@ subroutine sft_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! -- Store pointer to governing equation scale factor sftobj%eqnsclfac => eqnsclfac ! - ! -- Store pointer to the labels module for dynamic setting of + ! -- Store pointer to the labels module for dynamic setting of ! concentration vs temperature sftobj%tsplab => tsplab ! @@ -148,7 +148,7 @@ end subroutine sft_create !> @brief Find corresponding sft package !< - subroutine find_sft_package(this) + subroutine find_sft_package(this) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -767,7 +767,7 @@ end subroutine sft_roff_term !> @brief Inflow Term !! !! Accounts for mass added via streamflow entering into a stream channel; - !! for example, energy entering the model domain via a specified flow in a + !! for example, energy entering the model domain via a specified flow in a !! stream channel. !< subroutine sft_iflw_term(this, ientry, n1, n2, rrate, & @@ -798,7 +798,7 @@ end subroutine sft_iflw_term !> @brief Outflow term !! - !! Accounts for the mass leaving a stream channel; for example, mass exiting the + !! Accounts for the mass leaving a stream channel; for example, mass exiting the !! model domain via a flow in a stream channel flowing out of the active domain. !< subroutine sft_outf_term(this, ientry, n1, n2, rrate, & diff --git a/src/Model/GroundWaterTransport/gwt1src1.f90 b/src/Model/GroundWaterTransport/gwt1src1.f90 index 59af4ea233d..b7a100f087a 100644 --- a/src/Model/GroundWaterTransport/gwt1src1.f90 +++ b/src/Model/GroundWaterTransport/gwt1src1.f90 @@ -35,7 +35,7 @@ module GwtSrcModule contains !> @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, & @@ -74,7 +74,7 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & packobj%ncolbnd = 1 packobj%iscloc = 1 ! - ! -- Store pointer to labels associated with the current model so that the + ! -- Store pointer to labels associated with the current model so that the ! package has access to the assigned labels packobj%tsplab => tsplab ! @@ -202,7 +202,7 @@ subroutine src_fc(this, rhs, ia, idxglo, matrix_sln) end subroutine src_fc !> @brief Define list labels - !! + !! !! Define the list heading that is written to iout when PRINT_INPUT !! option is used. !< @@ -246,7 +246,7 @@ logical function src_obs_supported(this) class(GwtSrcType) :: this ! ------------------------------------------------------------------------------ src_obs_supported = .true. - ! + ! ! -- Return return end function src_obs_supported @@ -279,7 +279,7 @@ end subroutine src_df_obs !> @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 + !! In the SRC package only the SENERRATE variable can be controlled by time !! series. !< subroutine src_rp_ts(this) diff --git a/src/Model/GroundWaterTransport/gwt1uzt1.f90 b/src/Model/GroundWaterTransport/gwt1uzt1.f90 index 623c0be3356..8e78c329243 100644 --- a/src/Model/GroundWaterTransport/gwt1uzt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1uzt1.f90 @@ -77,7 +77,7 @@ module GwtUztModule contains - !> @brief Create a new UZT package + !> @brief Create a new UZT package !< subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & fmi) @@ -361,9 +361,9 @@ subroutine uzt_solve(this) end subroutine uzt_solve !> @brief Function that returns the number of budget terms for this package - !! + !! !! This overrides function in parent. - !< + !< function uzt_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy @@ -661,7 +661,7 @@ end subroutine uzt_infl_term !> @brief Rejected infiltration term !! - !! Accounts for mass that is added to the model from specifying an + !! Accounts for mass that is added to the model from specifying an !! infiltration rate and concentration, but is subsequently removed from !! the model as that portion of the infiltration that is rejected (and !! NOT transferred to another advanced package via the MVR/MVT packages). @@ -694,8 +694,8 @@ end subroutine uzt_rinf_term !> @brief Evapotranspiration from the unsaturated-zone term !! - !! Accounts for mass removed as a result of evapotranspiration from the - !! unsaturated zone. + !! Accounts for mass removed as a result of evapotranspiration from the + !! unsaturated zone. !< subroutine uzt_uzet_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) @@ -734,11 +734,11 @@ end subroutine uzt_uzet_term !> @brief Rejected infiltration to MVR/MVT term !! - !! Accounts for energy that is added to the model from specifying an + !! Accounts for energy that is added to the model from specifying an !! infiltration rate and temperature, but does not infiltrate into the !! subsurface. This subroutine is called when the rejected infiltration !! is transferred to another advanced package via the MVR/MVT packages. - !< + !< subroutine uzt_ritm_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- dummy From afdee063bc99456ad0aaff2693717150deb2e53b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 10:06:58 -0700 Subject: [PATCH 171/212] fprettify on generalized transport src code --- src/Model/TransportModel/tsp1.f90 | 53 ++++++------ src/Model/TransportModel/tsp1adv1.f90 | 14 +-- src/Model/TransportModel/tsp1apt1.f90 | 119 +++++++++++++------------- src/Model/TransportModel/tsp1cnc1.f90 | 31 ++++--- src/Model/TransportModel/tsp1fmi1.f90 | 22 ++--- src/Model/TransportModel/tsp1ic1.f90 | 4 +- src/Model/TransportModel/tsp1mvt1.f90 | 17 ++-- src/Model/TransportModel/tsp1obs1.f90 | 6 +- src/Model/TransportModel/tsp1oc1.f90 | 2 +- src/Model/TransportModel/tsp1ssm1.f90 | 16 ++-- 10 files changed, 141 insertions(+), 143 deletions(-) diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 746e782ddb3..4e2fdb780f3 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -59,7 +59,7 @@ module TransportModelModule real(DP), pointer :: eqnsclfac => null() !< constant factor by which all terms in the model's governing equation are scaled (divided) for formulation and solution contains - + ! -- public procedure :: allocate_tsp_scalars procedure, public :: ftype_check @@ -97,7 +97,7 @@ module TransportModelModule 'API6 ', ' ', 'SFE6 ', 'UZE6 ', ' ', & ! 25 75*' '/ - contains +contains !> @brief Create a new generalized transport model object !! @@ -169,7 +169,7 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) this%ipakcb = -1 end if ! - ! -- Instantiate generalized labels + ! -- Instantiate generalized labels call tsplabels_cr(this%tsplab, this%name) ! ! -- log set options @@ -190,11 +190,11 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) ! -- Return return end subroutine tsp_cr - + !> @brief Generalized transport model define model !! !! This subroutine extended by either GWT or GWE. This routine calls the - !! define (df) routines for each attached package and sets variables and + !! define (df) routines for each attached package and sets variables and !! pointers. !< subroutine tsp_df(this) @@ -204,10 +204,10 @@ subroutine tsp_df(this) ! -- return return end subroutine tsp_df - + !> @brief Generalized transport model add connections !! - !! This subroutine extended by either GWT or GWE. This routine adds the + !! This subroutine extended by either GWT or GWE. This routine adds the !! internal connections of this model to the sparse matrix !< subroutine tsp_ac(this, sparse) @@ -222,9 +222,9 @@ subroutine tsp_ac(this, sparse) ! -- return return end subroutine tsp_ac - + !> @brief Generalized transport model map coefficients - !! + !! !! This subroutine extended by either GWT or GWE. This routine maps the !! positions of this models connections in the numerical solution coefficient !! matrix. @@ -268,7 +268,7 @@ subroutine tsp_rp(this) ! -- Return return end subroutine tsp_rp - + !> @brief Generalized transport model time step advance !! !! This subroutine extended by either GWT or GWE. This routine calls @@ -345,7 +345,7 @@ subroutine tsp_cq(this, icnvg, isuppress_output) ! -- Return return end subroutine tsp_cq - + !> @brief Generalized transport model budget !! !! This subroutine extended by either GWT or GWE. This routine calculates @@ -399,7 +399,8 @@ subroutine tsp_ot(this, inmst) ! -- Override ibudfl and idvprint flags for nonconvergence ! and end of period ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), this%icnvg, endofperiod) + idvprint = this%oc%set_print_flag(trim(this%tsplab%depvartype), & + this%icnvg, endofperiod) ! ! Calculate and save observations call this%tsp_ot_obs() @@ -447,7 +448,7 @@ subroutine tsp_ot_obs(this) end do end subroutine tsp_ot_obs - + !> @brief Generalized transport model output routine !! !! Save and print flows @@ -463,8 +464,8 @@ subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun, inmst) ! ------------------------------------------------------------------------------ ! -- Save TSP flows call this%tsp_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if (inmst > 0) call this%tsp_ot_flowja(this%nja, this%flowja, & - icbcfl, icbcun) + if (inmst > 0) call this%tsp_ot_flowja(this%nja, this%flowja, & + icbcfl, icbcun) if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) if (this%inssm > 0) then call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) @@ -540,7 +541,7 @@ subroutine tsp_ot_flowja(this, nja, flowja, icbcfl, icbcun) ! -- Return return end subroutine tsp_ot_flowja - + !> @brief Generalized tranpsort model output routine !! !! Loop through attached packages saving and printing dependent variables @@ -602,7 +603,7 @@ subroutine tsp_ot_bdsummary(this, ibudfl, ipflag) ! -- Return return end subroutine tsp_ot_bdsummary - + !> @brief Allocate scalar variables for transport model !! !! Method to allocate memory for non-allocatable members. @@ -640,7 +641,7 @@ subroutine allocate_tsp_scalars(this, modelname) ! -- return return end subroutine allocate_tsp_scalars - + !> @brief Deallocate memory !! !! Deallocate memmory at conclusion of model run @@ -666,7 +667,7 @@ subroutine tsp_da(this) ! -- return return end subroutine tsp_da - + !> @brief Generalized tranpsort model routine !! !! Check to make sure required input files have been specified @@ -709,7 +710,7 @@ subroutine ftype_check(this, indis, inmst) ! -- return return end subroutine ftype_check - + !> @brief Create listing output file !< subroutine create_lstfile(this, lst_fname, model_fname, defined) @@ -796,7 +797,7 @@ subroutine log_namfile_options(this, found) write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' end subroutine log_namfile_options - + !> @brief Source package info and begin to process !< subroutine create_packages(this, indis, gwecommon) @@ -884,16 +885,16 @@ subroutine create_packages(this, indis, gwecommon) this%inoc = inunit case ('OBS6') this%inobs = inunit - !case default + !case default ! TODO end select end do ! ! -- Create packages that are tied directly to model call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis, this%tsplab) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & + call fmi_cr(this%fmi, this%name, this%infmi, this%iout, this%tsplab, & this%eqnsclfac) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & + call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi, & this%eqnsclfac) call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi, & this%tsplab, this%eqnsclfac, gwecommon) @@ -904,6 +905,6 @@ subroutine create_packages(this, indis, gwecommon) ! ! -- return return - end subroutine create_packages - + end subroutine create_packages + end module TransportModelModule diff --git a/src/Model/TransportModel/tsp1adv1.f90 b/src/Model/TransportModel/tsp1adv1.f90 index 5e3b1e5ca8c..f0b23796322 100644 --- a/src/Model/TransportModel/tsp1adv1.f90 +++ b/src/Model/TransportModel/tsp1adv1.f90 @@ -43,7 +43,7 @@ module TspAdvModule !> @ brief Create a new ADV object !! - !! Create a new ADV package + !! Create a new ADV package !< subroutine adv_cr(advobj, name_model, inunit, iout, fmi, eqnsclfac) ! -- dummy @@ -75,7 +75,7 @@ subroutine adv_cr(advobj, name_model, inunit, iout, fmi, eqnsclfac) end subroutine adv_cr !> @brief Define ADV object - !! + !! !! Define the ADV package !< subroutine adv_df(this, adv_options) @@ -186,7 +186,7 @@ subroutine adv_fc(this, nodes, matrix_sln, idxglo, cnew, rhs) end subroutine adv_fc !> @brief Calculate TVD - !! + !! !! Use explicit scheme to calculate the advective component of transport. !! TVD is an acronym for Total-Variation Diminishing !< @@ -218,7 +218,7 @@ subroutine advtvd(this, n, cnew, rhs) end subroutine advtvd !> @brief Calculate TVD - !! + !! !! Use explicit scheme to calculate the advective component of transport. !! TVD is an acronym for Total-Variation Diminishing !< @@ -315,7 +315,7 @@ subroutine adv_cq(this, cnew, flowja) qnm = this%fmi%gwfflowja(ipos) * this%eqnsclfac omega = this%adv_weight(this%iadvwt, ipos, n, m, qnm) flowja(ipos) = flowja(ipos) + qnm * omega * cnew(n) + & - qnm * (DONE - omega) * cnew(m) + qnm * (DONE - omega) * cnew(m) end do end do ! @@ -370,8 +370,8 @@ subroutine adv_da(this) ! ! -- nullify pointers this%ibound => null() - nullify(this%cpw) - nullify(this%rhow) + nullify (this%cpw) + nullify (this%rhow) ! ! -- Scalars call mem_deallocate(this%iadvwt) diff --git a/src/Model/TransportModel/tsp1apt1.f90 b/src/Model/TransportModel/tsp1apt1.f90 index 76fb1e4b58f..a5e191cdbf2 100644 --- a/src/Model/TransportModel/tsp1apt1.f90 +++ b/src/Model/TransportModel/tsp1apt1.f90 @@ -99,7 +99,7 @@ module TspAptModule real(DP), dimension(:, :), pointer, contiguous :: lauxvar => null() !< auxiliary variable type(TspFmiType), pointer :: fmi => null() !< pointer to fmi object real(DP), dimension(:), pointer, contiguous :: qsto => null() !< mass (or energy) flux due to storage change - real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass (or energy) flux required to maintain constant concentration (or temperature) + real(DP), dimension(:), pointer, contiguous :: ccterm => null() !< mass (or energy) flux required to maintain constant concentration (or temperature) integer(I4B), pointer :: idxbudfjf => null() !< index of flow ja face in flowbudptr integer(I4B), pointer :: idxbudgwf => null() !< index of gwf terms in flowbudptr integer(I4B), pointer :: idxbudsto => null() !< index of storage terms in flowbudptr @@ -132,10 +132,10 @@ module TspAptModule procedure :: bnd_ad => apt_ad procedure :: bnd_cf => apt_cf procedure :: bnd_fc => apt_fc - procedure, public :: apt_fc_expanded ! Made public for uze + procedure, public :: apt_fc_expanded ! Made public for uze procedure :: pak_fc_expanded procedure, private :: apt_fc_nonexpanded - procedure, public :: apt_cfupdate ! Made public for uze + procedure, public :: apt_cfupdate ! Made public for uze procedure :: apt_check_valid procedure :: apt_set_stressperiod procedure :: pak_set_stressperiod @@ -175,8 +175,8 @@ module TspAptModule procedure :: pak_fill_budobj procedure, public :: apt_stor_term procedure, public :: apt_tmvr_term - procedure, public :: apt_fmvr_term ! Made public for uze - procedure, public :: apt_fjf_term ! Made public for uze + procedure, public :: apt_fmvr_term ! Made public for uze + procedure, public :: apt_fjf_term ! Made public for uze procedure, private :: apt_copy2flowp procedure, private :: apt_setup_tableobj @@ -339,7 +339,7 @@ subroutine apt_ar(this) this%fmi%datp(this%igwfaptpak)%qmfrommvr => this%qmfrommvr ! ! -- If there is an associated flow package and the user wishes to put - ! simulated concentrations (or temperatures) into a aux variable + ! simulated concentrations (or temperatures) into a aux variable ! column, then find the column number. if (associated(this%flowpackagebnd)) then if (this%cauxfpconc /= '') then @@ -371,7 +371,7 @@ end subroutine apt_ar !> @brief Advanced package transport read and prepare (rp) routine !! - !! This subroutine calls the attached packages' read and prepare routines. + !! This subroutine calls the attached packages' read and prepare routines. !< subroutine apt_rp(this) use TdisModule, only: kper, nper @@ -493,7 +493,7 @@ end subroutine apt_rp !> @brief Advanced package transport set stress period routine. !! - !! Set a stress period attribute for an advanced transport package feature + !! Set a stress period attribute for an advanced transport package feature !! (itemno) using keywords. !< subroutine apt_set_stressperiod(this, itemno) @@ -594,7 +594,7 @@ end subroutine apt_set_stressperiod !> @brief Advanced package transport set stress period routine. !! - !! Set a stress period attribute for an individual package. This routine + !! Set a stress period attribute for an individual package. This routine !! must be overridden. !< subroutine pak_set_stressperiod(this, itemno, keyword, found) @@ -639,7 +639,7 @@ function apt_check_valid(this, itemno) result(ierr) end if end function apt_check_valid - !> @brief Advanced package transport routine + !> @brief Advanced package transport routine !! !! Add package connections to matrix !< @@ -702,7 +702,7 @@ end subroutine apt_ad !> @ brief Formulate the package hcof and rhs terms. !! - !! For the APT Package, the sole purpose here is to reset the qmfrommvr + !! For the APT Package, the sole purpose here is to reset the qmfrommvr !! term. !< subroutine apt_cf(this, reset_mover) @@ -753,10 +753,10 @@ subroutine apt_fc(this, rhs, ia, idxglo, matrix_sln) end subroutine apt_fc !> @brief Advanced package transport fill coefficient (fc) method - !! + !! !! Routine to formulate the nonexpanded matrix case in which feature !! concentrations (or temperatures) are solved explicitly - !< + !< subroutine apt_fc_nonexpanded(this, rhs, ia, idxglo, matrix_sln) ! -- modules ! -- dummy @@ -842,7 +842,7 @@ subroutine apt_fc_expanded(this, rhs, ia, idxglo, matrix_sln) ! -- add from mover contribution if (this%idxbudfmvr /= 0) then do n = 1, this%ncv - rhsval = this%qmfrommvr(n) ! kluge note: presumably already in terms of energy for heat transport??? + rhsval = this%qmfrommvr(n) ! kluge note: presumably already in terms of energy for heat transport??? iloc = this%idxlocnode(n) rhs(iloc) = rhs(iloc) - rhsval end do @@ -924,9 +924,9 @@ end subroutine pak_fc_expanded !> @brief Advanced package transport routine !! - !! Calculate advanced package transport hcof and rhs so transport budget is + !! Calculate advanced package transport hcof and rhs so transport budget is !! calculated. - !< + !< subroutine apt_cfupdate(this) ! -- modules ! -- dummy @@ -973,7 +973,7 @@ subroutine apt_cq(this, x, flowja, iadv) real(DP) :: rrate ! ------------------------------------------------------------------------------ ! - ! -- Solve the feature concentrations (or temperatures) again or update + ! -- Solve the feature concentrations (or temperatures) again or update ! the feature hcof and rhs terms if (this%imatrows == 0) then call this%apt_solve() @@ -1004,7 +1004,7 @@ subroutine apt_cq(this, x, flowja, iadv) end subroutine apt_cq !> @brief Save advanced package flows routine - !< + !< subroutine apt_ot_package_flows(this, icbcfl, ibudfl) use TdisModule, only: kstp, kper, delt, pertim, totim class(TspAptType) :: this @@ -1032,7 +1032,6 @@ subroutine apt_ot_package_flows(this, icbcfl, ibudfl) return end subroutine apt_ot_package_flows - subroutine apt_ot_dv(this, idvsave, idvprint) ! -- modules use ConstantsModule, only: LENBUDTXT @@ -1065,7 +1064,7 @@ subroutine apt_ot_dv(this, idvsave, idvprint) end if this%dbuff(n) = c end do - write(text, '(a)') padl(this%tsplab%depvartype, 16) + write (text, '(a)') padl(this%tsplab%depvartype, 16) call ulasav(this%dbuff, text, kstp, kper, pertim, totim, & this%ncv, 1, 1, ibinun) end if @@ -1365,7 +1364,7 @@ subroutine apt_da(this) end subroutine apt_da !> @brief Find corresponding advanced package transport package - !< + !< subroutine find_apt_package(this) ! -- modules use MemoryManagerModule, only: mem_allocate @@ -1650,7 +1649,7 @@ subroutine apt_read_cvs(this) ! -- if GWE model, read additional thermal conductivity terms if (this%tsplab%tsptype == 'GWE') then ! skip for UZE - if (trim(adjustl(this%text)) /= 'UZE') then + if (trim(adjustl(this%text)) /= 'UZE') then this%ktf(n) = this%parser%GetDouble() this%rfeatthk(n) = this%parser%GetDouble() if (this%rfeatthk(n) <= DZERO) then @@ -1658,8 +1657,8 @@ subroutine apt_read_cvs(this) '****ERROR. Specified thickness used for thermal & &conduction MUST BE > 0 else divide by zero error occurs' call store_error(errmsg) - cycle - end if + cycle + end if end if end if ! @@ -1782,9 +1781,9 @@ end subroutine apt_read_initial_attr !> @brief Add terms specific to advanced package transport to the explicit !! solve !! - !! Explicit solve for concentration (or temperature) in advaced package + !! Explicit solve for concentration (or temperature) in advaced package !! features, which is an alternative to the iterative implicit solve. - !< + !< subroutine apt_solve(this) use ConstantsModule, only: LINELENGTH ! -- dummy @@ -1818,7 +1817,7 @@ subroutine apt_solve(this) ! -- add from mover contribution if (this%idxbudfmvr /= 0) then do n1 = 1, size(this%qmfrommvr) - rrate = this%qmfrommvr(n1) ! kluge note: presumably in terms of energy already for heat transport??? + rrate = this%qmfrommvr(n1) ! kluge note: presumably in terms of energy already for heat transport??? this%dbuff(n1) = this%dbuff(n1) + rrate end do end if @@ -1842,7 +1841,7 @@ subroutine apt_solve(this) this%dbuff(n) = this%dbuff(n) + c1 end do ! - ! -- go through each "within apt-apt" connection (e.g., lak-lak) and + ! -- go through each "within apt-apt" connection (e.g., lak-lak) and ! accumulate total mass (or energy) in dbuff mass if (this%idxbudfjf /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudfjf)%nlist @@ -1871,7 +1870,7 @@ subroutine apt_solve(this) return end subroutine apt_solve - !> @brief Add terms specific to advanced package transport features to the + !> @brief Add terms specific to advanced package transport features to the !! explicit solve routine !! !! This routine must be overridden by the specific apt package @@ -1891,7 +1890,7 @@ subroutine pak_solve(this) end subroutine pak_solve !> @brief Accumulate constant concentration (or temperature) terms for budget - !< + !< subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) ! -- dummy class(TspAptType) :: this @@ -1924,7 +1923,7 @@ subroutine apt_accumulate_ccterm(this, ilak, rrate, ccratin, ccratout) return end subroutine apt_accumulate_ccterm - !> @brief Define the list heading that is written to iout when PRINT_INPUT + !> @brief Define the list heading that is written to iout when PRINT_INPUT !! option is used. !< subroutine define_listlabel(this) @@ -1952,7 +1951,7 @@ subroutine define_listlabel(this) return end subroutine define_listlabel - !> @brief Set pointers to model arrays and variables so that a package has + !> @brief Set pointers to model arrays and variables so that a package has !! access to these items. !< subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) @@ -1985,7 +1984,7 @@ subroutine apt_set_pointers(this, neq, ibound, xnew, xold, flowja) end subroutine apt_set_pointers !> @brief Return the feature new volume and old volume - !< + !< subroutine get_volumes(this, icv, vnew, vold, delt) ! -- modules ! -- dummy @@ -2028,7 +2027,7 @@ function pak_get_nbudterms(this) result(nbudterms) terminate=.TRUE.) nbudterms = 0 end function pak_get_nbudterms - + !> @brief Function for string manipulation !< function padl(str, width) result(res) @@ -2037,7 +2036,7 @@ function padl(str, width) result(res) integer, intent(in) :: width ! -- return character(len=max(len_trim(str), width)) :: res -! ------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------ res = str res = adjustr(res) ! @@ -2074,7 +2073,7 @@ subroutine apt_setup_budobj(this) nlen = this%flowbudptr%budterm(this%idxbudfjf)%maxlist end if ! - ! -- Determine the number of budget terms associated with apt. + ! -- Determine the number of budget terms associated with apt. ! These are fixed for the simulation and cannot change ! ! -- add one if flow-ja-face present @@ -2094,7 +2093,7 @@ subroutine apt_setup_budobj(this) ! -- set up budobj call budgetobject_cr(this%budobj, this%packName) ! - bddim_opt=this%tsplab%depvarunitabbrev + bddim_opt = this%tsplab%depvarunitabbrev call this%budobj%budgetobject_df(this%ncv, nbudterm, 0, 0, & bddim_opt=bddim_opt, ibudcsv=this%ibudcsv) idx = 0 @@ -2154,8 +2153,8 @@ subroutine apt_setup_budobj(this) idx = idx + 1 maxlist = this%flowbudptr%budterm(this%idxbudsto)%maxlist naux = 1 - write(textt, '(a)') padl(this%tsplab%depvarunit, 16) - auxtxt(1) = textt ! ' MASS' or ' ENERGY' + write (textt, '(a)') padl(this%tsplab%depvarunit, 16) + auxtxt(1) = textt ! ' MASS' or ' ENERGY' call this%budobj%budterm(idx)%initialize(text, & this%name_model, & this%packName, & @@ -2256,7 +2255,7 @@ subroutine pak_setup_budobj(this, idx) end subroutine pak_setup_budobj !> @brief Copy flow terms into this%budobj - !< + !< subroutine apt_fill_budobj(this, x, flowja) ! -- modules use TdisModule, only: delt @@ -2331,7 +2330,7 @@ subroutine apt_fill_budobj(this, x, flowja) allocate (auxvartmp(1)) do n1 = 1, this%ncv call this%get_volumes(n1, v1, v0, delt) - auxvartmp(1) = v1 * this%xnewpak(n1) ! kluge note: does this need a factor of eqnsclfac??? + auxvartmp(1) = v1 * this%xnewpak(n1) ! kluge note: does this need a factor of eqnsclfac??? q = this%qsto(n1) call this%budobj%budterm(idx)%update_term(n1, n1, q, auxvartmp) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) @@ -2356,7 +2355,7 @@ subroutine apt_fill_budobj(this, x, flowja) nlist = this%ncv call this%budobj%budterm(idx)%reset(nlist) do j = 1, nlist - call this%apt_fmvr_term(j, n1, n2, q) ! kluge note: don't really need to do this in apt_fmvr_term now, since no override by uze + call this%apt_fmvr_term(j, n1, n2, q) ! kluge note: don't really need to do this in apt_fmvr_term now, since no override by uze call this%budobj%budterm(idx)%update_term(n1, n1, q) call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout) end do @@ -2398,7 +2397,7 @@ subroutine apt_fill_budobj(this, x, flowja) end subroutine apt_fill_budobj !> @brief Copy flow terms into this%budobj, must be overridden - !< + !< subroutine pak_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! -- modules ! -- dummy @@ -2435,7 +2434,7 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & real(DP) :: v0, v1 real(DP) :: c0, c1 ! ----------------------------------------------------------------- - ! + ! n1 = ientry n2 = ientry call this%get_volumes(n1, v1, v0, delt) @@ -2452,7 +2451,7 @@ subroutine apt_stor_term(this, ientry, n1, n2, rrate, & end subroutine apt_stor_term !> @brief Account for mass or energy transferred to the MVR package - !< + !< subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- modules @@ -2469,7 +2468,7 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & real(DP) :: ctmp ! ------------------------------------------------------------------------------ ! - ! -- Calculate MVR-related terms + ! -- Calculate MVR-related terms n1 = this%flowbudptr%budterm(this%idxbudtmvr)%id1(ientry) n2 = this%flowbudptr%budterm(this%idxbudtmvr)%id2(ientry) qbnd = this%flowbudptr%budterm(this%idxbudtmvr)%flow(ientry) @@ -2482,9 +2481,9 @@ subroutine apt_tmvr_term(this, ientry, n1, n2, rrate, & return end subroutine apt_tmvr_term - !> @brief Account for mass or energy transferred to this package from the + !> @brief Account for mass or energy transferred to this package from the !! MVR package - !< + !< subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & rhsval, hcofval) ! -- modules @@ -2498,10 +2497,10 @@ subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & real(DP), intent(inout), optional :: hcofval ! ------------------------------------------------------------------------------ ! - ! -- Calculate MVR-related terms + ! -- Calculate MVR-related terms n1 = ientry n2 = n1 - if (present(rrate)) rrate = this%qmfrommvr(n1) ! presumably in terms of energy already for heat transport??? + if (present(rrate)) rrate = this%qmfrommvr(n1) ! presumably in terms of energy already for heat transport??? if (present(rhsval)) rhsval = this%qmfrommvr(n1) if (present(hcofval)) hcofval = DZERO ! @@ -2509,7 +2508,7 @@ subroutine apt_fmvr_term(this, ientry, n1, n2, rrate, & return end subroutine apt_fmvr_term - !> @brief Go through each "within apt-apt" connection (e.g., lkt-lkt, or + !> @brief Go through each "within apt-apt" connection (e.g., lkt-lkt, or !! sft-sft) and accumulate total mass (or energy) in dbuff mass !< subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & @@ -2544,7 +2543,7 @@ subroutine apt_fjf_term(this, ientry, n1, n2, rrate, & return end subroutine apt_fjf_term - !> @brief Copy concentrations (or temperatures) into flow package aux + !> @brief Copy concentrations (or temperatures) into flow package aux !! variable !< subroutine apt_copy2flowp(this) @@ -2595,7 +2594,7 @@ end function apt_obs_supported !! This routine: !! - stores observation types supported by APT package. !! - overrides BndType%bnd_df_obs - !< + !< subroutine apt_df_obs(this) ! -- modules ! -- dummy @@ -2650,7 +2649,7 @@ end subroutine pak_rp_obs !> @brief Prepare observation !! - !! Find the indices for this observation assuming they are indexed by + !! Find the indices for this observation assuming they are indexed by !! feature number !< subroutine rp_obs_byfeature(this, obsrv) @@ -2771,7 +2770,7 @@ end subroutine rp_obs_budterm !> @brief Prepare observation !! - !! Find the indices for this observation assuming they are first indexed + !! Find the indices for this observation assuming they are first indexed !! by a feature number and secondly by a second feature number !< subroutine rp_obs_flowjaface(this, obsrv, budterm) @@ -2871,7 +2870,7 @@ subroutine apt_rp_obs(this) ! -- catch non-cumulative observation assigned to observation defined ! by a boundname that is assigned to more than one element if (obsrv%indxbnds_count > 1) then - write (errmsg, '(a, a, a, a)') & + write (errmsg, '(a, a, a, a)') & trim(adjustl(this%tsplab%depvartype))// & ' for observation', trim(adjustl(obsrv%Name)), & ' must be assigned to a feature with a unique boundname.' @@ -2928,7 +2927,7 @@ end subroutine apt_rp_obs !> @brief Calculate observation values !! - !! Routine calculates observations common to SFT/LKT/MWT/UZT + !! Routine calculates observations common to SFT/LKT/MWT/UZT !! (or SFE/LKE/MWE/UZE) for as many TspAptType observations that are common !! among the advanced transport packages !< @@ -3024,7 +3023,7 @@ subroutine apt_bd_obs(this) end subroutine apt_bd_obs !> @brief Check if observation exists in an advanced package - !< + !< subroutine pak_bd_obs(this, obstypeid, jj, v, found) ! -- dummy class(TspAptType), intent(inout) :: this @@ -3143,8 +3142,8 @@ end subroutine apt_process_obsID12 !> @brief Setup a table object an advanced package !! - !! Set up the table object that is used to write the apt concentration - !! (or temperature) data. The terms listed here must correspond in the + !! Set up the table object that is used to write the apt concentration + !! (or temperature) data. The terms listed here must correspond in the !! apt_ot method. !< subroutine apt_setup_tableobj(this) diff --git a/src/Model/TransportModel/tsp1cnc1.f90 b/src/Model/TransportModel/tsp1cnc1.f90 index 2c30b9f6b14..c7b540c5885 100644 --- a/src/Model/TransportModel/tsp1cnc1.f90 +++ b/src/Model/TransportModel/tsp1cnc1.f90 @@ -21,15 +21,15 @@ module TspCncModule character(len=LENPACKAGENAME) :: text = ' CNC' ! type, extends(BndType) :: TspCncType - + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst - + real(DP), dimension(:), pointer, contiguous :: ratecncin => null() !simulated flows into constant conc (excluding other concs) real(DP), dimension(:), pointer, contiguous :: ratecncout => null() !simulated flows out of constant conc (excluding to other concs) real(DP), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy - + contains - + procedure :: bnd_rp => cnc_rp procedure :: bnd_ad => cnc_ad procedure :: bnd_ck => cnc_ck @@ -46,7 +46,7 @@ module TspCncModule procedure, public :: bnd_rp_ts => cnc_rp_ts end type TspCncType - contains +contains !> @brief Create a new constant concentration or temperature package !! @@ -164,10 +164,10 @@ subroutine cnc_rp(this) ibd = this%ibound(node) if (ibd < 0) then call this%dis%noder_to_string(node, nodestr) - dvtype = trim(this%tsplab%depvartype) + dvtype = trim(this%tsplab%depvartype) call lowcase(dvtype) - call store_error('Error. Cell is already a constant ' & - // dvtype // ': ' //trim(adjustl(nodestr))) + call store_error('Error. Cell is already a constant ' & + //dvtype//': '//trim(adjustl(nodestr))) ierr = ierr + 1 else this%ibound(node) = -this%ibcnum @@ -183,8 +183,7 @@ subroutine cnc_rp(this) return end subroutine cnc_rp - - !> @brief Constant concentration/temperature package advance routine + !> @brief Constant concentration/temperature package advance routine !! !! Add package connections to matrix !< @@ -318,7 +317,7 @@ subroutine cnc_cq(this, x, flowja, iadv) ! -- Calculate the flow rate into the cell. do ipos = this%dis%con%ia(node) + 1, & this%dis%con%ia(node + 1) - 1 - q = flowja(ipos) ! klughe note: flowja should already be in terms of energy for heat transport + q = flowja(ipos) ! klughe note: flowja should already be in terms of energy for heat transport rate = rate - q ! -- only accumulate chin and chout for active ! connected cells @@ -425,7 +424,7 @@ subroutine define_listlabel(this) write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE' end if write (this%listlabel, '(a, a16)') trim(this%listlabel), & - trim(this%tsplab%depvartype) + trim(this%tsplab%depvartype) if (this%inamedbound == 1) then write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' end if @@ -435,7 +434,7 @@ subroutine define_listlabel(this) end subroutine define_listlabel !> @brief Procedure related to observation processing - !! + !! !! This routine: !! - returns true because the CNC package supports observations, !! - overrides packagetype%_obs_supported() @@ -456,7 +455,7 @@ end function cnc_obs_supported !! - defines observations !! - stores observation types supported by the CNC package, !! - overrides BndType%bnd_df_obs - !< + !< subroutine cnc_df_obs(this) ! -- dummy class(TspCncType) :: this @@ -472,9 +471,9 @@ subroutine cnc_df_obs(this) end subroutine cnc_df_obs !> @brief Procedure related to time series - !! + !! !! Assign tsLink%Text appropriately for all time series in use by package. - !! In CNC package, variable CONCENTRATION or TEMPERATURE can be controlled + !! In CNC package, variable CONCENTRATION or TEMPERATURE can be controlled !! by time series. !< subroutine cnc_rp_ts(this) diff --git a/src/Model/TransportModel/tsp1fmi1.f90 b/src/Model/TransportModel/tsp1fmi1.f90 index 9727da9b44d..0beaadb83ac 100644 --- a/src/Model/TransportModel/tsp1fmi1.f90 +++ b/src/Model/TransportModel/tsp1fmi1.f90 @@ -142,7 +142,7 @@ subroutine fmi_cr(fmiobj, name_model, inunit, iout, tsplab, eqnsclfac) return end subroutine fmi_cr - !> @brief Define FMI package + !> @brief Define FMI package !< subroutine fmi_df(this, dis, inssm, idryinactive) ! -- modules @@ -190,7 +190,7 @@ subroutine fmi_df(this, dis, inssm, idryinactive) call this%initialize_gwfterms_from_bfr() end if ! - ! -- If GWF-GWT (or GWF-GWE) exchange is active, then setup gwfterms from + ! -- If GWF-GWT (or GWF-GWE) exchange is active, then setup gwfterms from ! bndlist if (.not. this%flows_from_file) then call this%initialize_gwfterms_from_gwfbndlist() @@ -205,8 +205,8 @@ subroutine fmi_df(this, dis, inssm, idryinactive) end if end if ! - ! -- Set flag that stops dry flows from being deactivated in a GWE - ! transport model since conduction will still be simulated. + ! -- Set flag that stops dry flows from being deactivated in a GWE + ! transport model since conduction will still be simulated. ! 0: GWE (skip deactivation step); 1: GWT (default: use existing code) this%idryinactive = idryinactive ! @@ -355,7 +355,7 @@ end subroutine fmi_fc !> @brief Calculate flow correction !! - !! Where there is a flow imbalance for a given cell, a correction may be + !! Where there is a flow imbalance for a given cell, a correction may be !! applied if selected !< subroutine fmi_cq(this, cnew, flowja) @@ -695,7 +695,7 @@ subroutine set_active_status(this, cnew) flownm = this%gwfflowja(ipos) if (flownm > 0) then if (this%ibound(m) /= 0) then - crewet = crewet + cnew(m) * flownm ! kluge note: apparently no need to multiply flows by eqnsclfac + crewet = crewet + cnew(m) * flownm ! kluge note: apparently no need to multiply flows by eqnsclfac tflow = tflow + this%gwfflowja(ipos) ! since it will divide out below anyway end if end if @@ -995,7 +995,7 @@ end subroutine initialize_bfr !> @brief Advance the budget file reader !! - !! Advance the budget file reader by reading the next chunk of information + !! Advance the budget file reader by reading the next chunk of information !! for the current time step and stress period !< subroutine advance_bfr(this) @@ -1285,10 +1285,10 @@ subroutine finalize_hfr(this) return end subroutine finalize_hfr - !> @brief Initialize the groundwater flow terms based on the budget file + !> @brief Initialize the groundwater flow terms based on the budget file !! reader !! - !! Initalize terms and figure out how many different terms and packages + !! Initalize terms and figure out how many different terms and packages !! are contained within the file !< subroutine initialize_gwfterms_from_bfr(this) @@ -1393,7 +1393,7 @@ end subroutine initialize_gwfterms_from_bfr !> @brief Initialize groundwater flow terms from the groundwater budget !! !! Flows are coming from a gwf-gwt exchange object - !< + !< subroutine initialize_gwfterms_from_gwfbndlist(this) ! -- modules use BndModule, only: BndType, GetBndFromList @@ -1527,7 +1527,7 @@ subroutine deallocate_gwfpackages(this) end subroutine deallocate_gwfpackages !> @brief Find the package index for package called name - !< + !< subroutine get_package_index(this, name, idx) use BndModule, only: BndType, GetBndFromList class(TspFmiType) :: this diff --git a/src/Model/TransportModel/tsp1ic1.f90 b/src/Model/TransportModel/tsp1ic1.f90 index 572bd8a72ea..6e58b914b0a 100644 --- a/src/Model/TransportModel/tsp1ic1.f90 +++ b/src/Model/TransportModel/tsp1ic1.f90 @@ -20,7 +20,7 @@ module TspIcModule contains !> @brief Create a new initial conditions object - !< + !< subroutine ic_cr(ic, name_model, inunit, iout, dis, tsplab) ! -- dummy type(TspIcType), pointer :: ic @@ -76,7 +76,7 @@ subroutine read_data(this) ! ------------------------------------------------------------------------------ ! ! -- Setup the label - write(aname(1), '(a,1x,a)') 'INITIAL', trim(adjustl(this%tsplab%depvartype)) + write (aname(1), '(a,1x,a)') 'INITIAL', trim(adjustl(this%tsplab%depvartype)) ! ! -- get griddata block call this%parser%GetBlock('GRIDDATA', isfound, ierr) diff --git a/src/Model/TransportModel/tsp1mvt1.f90 b/src/Model/TransportModel/tsp1mvt1.f90 index e27a9cd0a8e..896be50a2b1 100644 --- a/src/Model/TransportModel/tsp1mvt1.f90 +++ b/src/Model/TransportModel/tsp1mvt1.f90 @@ -61,11 +61,11 @@ module TspMvtModule procedure, private :: mvt_print_outputtab end type TspMvtType - contains +contains !> @brief Create a new mover transport object !< - subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge note: does this need tsplab? + subroutine mvt_cr(mvt, name_model, inunit, iout, fmi1, eqnsclfac, & ! kluge note: does this need tsplab? gwfmodelname1, gwfmodelname2, fmi2) ! -- dummy type(TspMvtType), pointer :: mvt @@ -217,7 +217,7 @@ end subroutine mvt_rp !! !! The mvt package adds the mass flow rate to the provider qmfrommvr array. !! The advanced packages know enough to subract any mass that is leaving, so - !! the mvt just adds mass coming in from elsewhere. Because the movers + !! the mvt just adds mass coming in from elsewhere. Because the movers !! change by stress period, their solute effects must be added to the right- !! hand side of the transport matrix equations. !< @@ -312,8 +312,8 @@ end subroutine mvt_fc !! !! The fmi_pr and fmi_rc arguments are pointers to the provider and receiver !! FMI Packages. If this MVT Package is owned by a single GWT model, then - !! these pointers are both set to the FMI Package of this GWT model's FMI - !! package. If this MVT package is owned by a GWTGWT exchange, then the + !! these pointers are both set to the FMI Package of this GWT model's FMI + !! package. If this MVT package is owned by a GWTGWT exchange, then the !! fmi_pr and fmi_rc pointers may be assigned to FMI Packages in different !! models. !< @@ -373,13 +373,13 @@ subroutine set_fmi_pr_rc(this, ibudterm, fmi_pr, fmi_rc) print *, 'Could not find FMI Package...' stop "error in set_fmi_pr_rc" end if - ! + ! ! -- Return return end subroutine set_fmi_pr_rc !> @brief Extra convergence check for mover - !< + !< subroutine mvt_cc(this, kiter, iend, icnvgmod, cpak, dpak) ! -- dummy class(TspMvtType) :: this @@ -547,7 +547,6 @@ subroutine mvt_ot_bdsummary(this, ibudfl) return end subroutine mvt_ot_bdsummary - !> @ brief Deallocate memory !! !! Method to deallocate memory for the package. @@ -927,7 +926,7 @@ subroutine mvt_setup_outputtab(this) return end subroutine mvt_setup_outputtab - !> @brief Set up mover-for-transport output table + !> @brief Set up mover-for-transport output table subroutine mvt_print_outputtab(this) ! -- module use TdisModule, only: kstp, kper diff --git a/src/Model/TransportModel/tsp1obs1.f90 b/src/Model/TransportModel/tsp1obs1.f90 index 4dd8dfa4958..8297a862125 100644 --- a/src/Model/TransportModel/tsp1obs1.f90 +++ b/src/Model/TransportModel/tsp1obs1.f90 @@ -29,7 +29,7 @@ module TspObsModule procedure, private :: set_pointers end type TspObsType - contains +contains !> @brief Create a new TspObsType object !! @@ -108,7 +108,7 @@ subroutine tsp_obs_df(this, iout, pkgname, filtyp, dis) end subroutine tsp_obs_df !> @brief Save observations - !< + !< subroutine tsp_obs_bd(this) ! -- dummy class(TspObsType), intent(inout) :: this @@ -156,7 +156,7 @@ end subroutine tsp_obs_rp !> Deallocate memory !! - !! Deallocate memory associated with transport model + !! Deallocate memory associated with transport model subroutine tsp_obs_da(this) ! -- dummy class(TspObsType), intent(inout) :: this diff --git a/src/Model/TransportModel/tsp1oc1.f90 b/src/Model/TransportModel/tsp1oc1.f90 index e548b2ae77d..49d1ff0b772 100644 --- a/src/Model/TransportModel/tsp1oc1.f90 +++ b/src/Model/TransportModel/tsp1oc1.f90 @@ -54,7 +54,7 @@ end subroutine oc_cr !> @ brief Allocate and read TspOcType !! - !! Setup dependent variable (e.g., concentration or temperature) + !! Setup dependent variable (e.g., concentration or temperature) !! and budget as output control variables. !! !< diff --git a/src/Model/TransportModel/tsp1ssm1.f90 b/src/Model/TransportModel/tsp1ssm1.f90 index 0b354566d78..900293352c2 100644 --- a/src/Model/TransportModel/tsp1ssm1.f90 +++ b/src/Model/TransportModel/tsp1ssm1.f90 @@ -36,9 +36,9 @@ module TspSsmModule !! equation. !< type, extends(NumericalPackageType) :: TspSsmType - + type(GweInputDataType), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst - + integer(I4B), pointer :: nbound !< total number of flow boundaries in this time step integer(I4B), dimension(:), pointer, contiguous :: isrctype => null() !< source type 0 is unspecified, 1 is aux, 2 is auxmixed, 3 is ssmi, 4 is ssmimixed integer(I4B), dimension(:), pointer, contiguous :: iauxpak => null() !< aux col for concentration @@ -83,7 +83,7 @@ module TspSsmModule !! Create a new SSM package by defining names, allocating scalars !! and initializing the parser. !< - subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, eqnsclfac, & + subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, eqnsclfac, & gwecommon) ! -- dummy type(TspSsmType), pointer :: ssmobj !< TspSsmType object @@ -113,7 +113,7 @@ subroutine ssm_cr(ssmobj, name_model, inunit, iout, fmi, tsplab, eqnsclfac, & ! -- Initialize block parser call ssmobj%parser%Initialize(ssmobj%inunit, ssmobj%iout) ! - ! -- Store pointer to labels associated with the current model so that the + ! -- Store pointer to labels associated with the current model so that the ! package has access to the corresponding dependent variable type ssmobj%tsplab => tsplab ! @@ -379,8 +379,8 @@ end subroutine ssm_term !! !! SSM concentrations and temperatures can be provided in auxiliary variables !! or through separate SPC files. If not provided, the default - !! concentration (or temperature) is zero. This single routine provides - !! the SSM bound concentration (or temperature) based on these different + !! concentration (or temperature) is zero. This single routine provides + !! the SSM bound concentration (or temperature) based on these different !! approaches. The mixed flag indicates whether or not the boundary as a !! mixed type. !< @@ -1152,8 +1152,8 @@ subroutine set_ssmivec(this, ip, packname) trim(packname)) write (this%iout, '(4x, a, a, a, a, a)') 'USING SPC INPUT FILE ', & - trim(filename), ' TO SET ',trim(this%tsplab%depvartype),'S FOR PACKAGE ', & - trim(packname) + trim(filename), ' TO SET ', trim(this%tsplab%depvartype), & + 'S FOR PACKAGE ', trim(packname) ! ! -- Return return From 2962a6b5ed26823602ff9c0cb188558ffe0d449b Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 6 Jun 2023 10:25:12 -0700 Subject: [PATCH 172/212] First push of mf6io-related .tex files. --- doc/mf6io/mf6ivar/tex/gwe-adv-desc.tex | 9 ++ doc/mf6io/mf6ivar/tex/gwe-adv-options.dat | 3 + doc/mf6io/mf6ivar/tex/gwe-dis-desc.tex | 41 +++++++ doc/mf6io/mf6ivar/tex/gwe-dis-dimensions.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-dis-griddata.dat | 12 +++ doc/mf6io/mf6ivar/tex/gwe-dis-options.dat | 7 ++ doc/mf6io/mf6ivar/tex/gwe-disu-cell2d.dat | 5 + .../mf6ivar/tex/gwe-disu-connectiondata.dat | 14 +++ doc/mf6io/mf6ivar/tex/gwe-disu-desc.tex | 81 ++++++++++++++ doc/mf6io/mf6ivar/tex/gwe-disu-dimensions.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-disu-griddata.dat | 10 ++ doc/mf6io/mf6ivar/tex/gwe-disu-options.dat | 8 ++ doc/mf6io/mf6ivar/tex/gwe-disu-vertices.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-disv-cell2d.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-disv-desc.tex | 61 +++++++++++ doc/mf6io/mf6ivar/tex/gwe-disv-dimensions.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-disv-griddata.dat | 8 ++ doc/mf6io/mf6ivar/tex/gwe-disv-options.dat | 7 ++ doc/mf6io/mf6ivar/tex/gwe-disv-vertices.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-dsp-desc.tex | 29 +++++ doc/mf6io/mf6ivar/tex/gwe-dsp-griddata.dat | 16 +++ doc/mf6io/mf6ivar/tex/gwe-dsp-options.dat | 4 + doc/mf6io/mf6ivar/tex/gwe-fmi-desc.tex | 21 ++++ doc/mf6io/mf6ivar/tex/gwe-fmi-options.dat | 4 + doc/mf6io/mf6ivar/tex/gwe-fmi-packagedata.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-ic-desc.tex | 9 ++ doc/mf6io/mf6ivar/tex/gwe-ic-griddata.dat | 4 + doc/mf6io/mf6ivar/tex/gwe-lke-desc.tex | 101 ++++++++++++++++++ doc/mf6io/mf6ivar/tex/gwe-lke-options.dat | 15 +++ doc/mf6io/mf6ivar/tex/gwe-lke-packagedata.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-lke-period.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-mst-desc.tex | 37 +++++++ doc/mf6io/mf6ivar/tex/gwe-mst-griddata.dat | 10 ++ doc/mf6io/mf6ivar/tex/gwe-mst-options.dat | 6 ++ doc/mf6io/mf6ivar/tex/gwe-mst-packagedata.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-mwe-desc.tex | 92 ++++++++++++++++ doc/mf6io/mf6ivar/tex/gwe-mwe-options.dat | 15 +++ doc/mf6io/mf6ivar/tex/gwe-mwe-packagedata.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-mwe-period.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-nam-desc.tex | 25 +++++ doc/mf6io/mf6ivar/tex/gwe-nam-options.dat | 6 ++ doc/mf6io/mf6ivar/tex/gwe-nam-packages.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-oc-desc.tex | 63 +++++++++++ doc/mf6io/mf6ivar/tex/gwe-oc-options.dat | 6 ++ doc/mf6io/mf6ivar/tex/gwe-oc-period.dat | 4 + doc/mf6io/mf6ivar/tex/gwe-sfe-desc.tex | 101 ++++++++++++++++++ doc/mf6io/mf6ivar/tex/gwe-sfe-options.dat | 15 +++ doc/mf6io/mf6ivar/tex/gwe-sfe-packagedata.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-sfe-period.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-src-desc.tex | 49 +++++++++ doc/mf6io/mf6ivar/tex/gwe-src-dimensions.dat | 3 + doc/mf6io/mf6ivar/tex/gwe-src-options.dat | 10 ++ doc/mf6io/mf6ivar/tex/gwe-src-period.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-ssm-desc.tex | 35 ++++++ doc/mf6io/mf6ivar/tex/gwe-ssm-fileinput.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-ssm-options.dat | 4 + doc/mf6io/mf6ivar/tex/gwe-ssm-sources.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-tmp-desc.tex | 49 +++++++++ doc/mf6io/mf6ivar/tex/gwe-tmp-dimensions.dat | 3 + doc/mf6io/mf6ivar/tex/gwe-tmp-options.dat | 10 ++ doc/mf6io/mf6ivar/tex/gwe-tmp-period.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-uze-desc.tex | 91 ++++++++++++++++ doc/mf6io/mf6ivar/tex/gwe-uze-options.dat | 15 +++ doc/mf6io/mf6ivar/tex/gwe-uze-packagedata.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-uze-period.dat | 5 + 65 files changed, 1223 insertions(+) create mode 100644 doc/mf6io/mf6ivar/tex/gwe-adv-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-adv-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dis-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dis-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dis-griddata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dis-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-cell2d.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-connectiondata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-griddata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disu-vertices.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disv-cell2d.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disv-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disv-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disv-griddata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disv-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-disv-vertices.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dsp-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dsp-griddata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-dsp-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-fmi-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-fmi-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-fmi-packagedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-ic-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-ic-griddata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-lke-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-lke-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-lke-packagedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-lke-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mst-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mst-griddata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mst-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mst-packagedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mwe-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mwe-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mwe-packagedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mwe-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-nam-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-nam-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-nam-packages.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-oc-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-oc-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-oc-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-sfe-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-sfe-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-sfe-packagedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-sfe-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-src-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-src-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-src-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-src-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-ssm-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-ssm-fileinput.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-ssm-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-ssm-sources.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-tmp-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-tmp-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-tmp-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-tmp-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-uze-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-uze-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-uze-packagedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-uze-period.dat diff --git a/doc/mf6io/mf6ivar/tex/gwe-adv-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-adv-desc.tex new file mode 100644 index 00000000000..fc18c7d2f3b --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-adv-desc.tex @@ -0,0 +1,9 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{scheme}---scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-adv-options.dat b/doc/mf6io/mf6ivar/tex/gwe-adv-options.dat new file mode 100644 index 00000000000..9ecafe688f1 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-adv-options.dat @@ -0,0 +1,3 @@ +BEGIN OPTIONS + [SCHEME ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-dis-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-dis-desc.tex new file mode 100644 index 00000000000..afef5a5fa76 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dis-desc.tex @@ -0,0 +1,41 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{length\_units}---is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. + +\item \texttt{NOGRB}---keyword to deactivate writing of the binary grid file. + +\item \texttt{xorigin}---x-position of the lower-left corner of the model grid. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{yorigin}---y-position of the lower-left corner of the model grid. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{angrot}---counter-clockwise rotation angle (in degrees) of the lower-left corner of the model grid. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\end{description} +\item \textbf{Block: DIMENSIONS} + +\begin{description} +\item \texttt{nlay}---is the number of layers in the model grid. + +\item \texttt{nrow}---is the number of rows in the model grid. + +\item \texttt{ncol}---is the number of columns in the model grid. + +\end{description} +\item \textbf{Block: GRIDDATA} + +\begin{description} +\item \texttt{delr}---is the column spacing in the row direction. + +\item \texttt{delc}---is the row spacing in the column direction. + +\item \texttt{top}---is the top elevation for each cell in the top model layer. + +\item \texttt{botm}---is the bottom elevation for each cell. + +\item \texttt{idomain}---is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-dis-dimensions.dat b/doc/mf6io/mf6ivar/tex/gwe-dis-dimensions.dat new file mode 100644 index 00000000000..227d0e1f799 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dis-dimensions.dat @@ -0,0 +1,5 @@ +BEGIN DIMENSIONS + NLAY + NROW + NCOL +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-dis-griddata.dat b/doc/mf6io/mf6ivar/tex/gwe-dis-griddata.dat new file mode 100644 index 00000000000..daae94c0ee3 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dis-griddata.dat @@ -0,0 +1,12 @@ +BEGIN GRIDDATA + DELR + -- READARRAY + DELC + -- READARRAY + TOP + -- READARRAY + BOTM [LAYERED] + -- READARRAY + [IDOMAIN [LAYERED] + -- READARRAY] +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-dis-options.dat b/doc/mf6io/mf6ivar/tex/gwe-dis-options.dat new file mode 100644 index 00000000000..67e3ed895ae --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dis-options.dat @@ -0,0 +1,7 @@ +BEGIN OPTIONS + [LENGTH_UNITS ] + [NOGRB] + [XORIGIN ] + [YORIGIN ] + [ANGROT ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-cell2d.dat b/doc/mf6io/mf6ivar/tex/gwe-disu-cell2d.dat new file mode 100644 index 00000000000..27900d67235 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-cell2d.dat @@ -0,0 +1,5 @@ +BEGIN CELL2D + + + ... +END CELL2D diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-connectiondata.dat b/doc/mf6io/mf6ivar/tex/gwe-disu-connectiondata.dat new file mode 100644 index 00000000000..9623a8be839 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-connectiondata.dat @@ -0,0 +1,14 @@ +BEGIN CONNECTIONDATA + IAC + -- READARRAY + JA + -- READARRAY + IHC + -- READARRAY + CL12 + -- READARRAY + HWVA + -- READARRAY + [ANGLDEGX + -- READARRAY] +END CONNECTIONDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-disu-desc.tex new file mode 100644 index 00000000000..14d67b19f02 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-desc.tex @@ -0,0 +1,81 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{length\_units}---is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. + +\item \texttt{NOGRB}---keyword to deactivate writing of the binary grid file. + +\item \texttt{xorigin}---x-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{yorigin}---y-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{angrot}---counter-clockwise rotation angle (in degrees) of the model grid coordinate system relative to a real-world coordinate system. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{vertical\_offset\_tolerance}---checks are performed to ensure that the top of a cell is not higher than the bottom of an overlying cell. This option can be used to specify the tolerance that is used for checking. If top of a cell is above the bottom of an overlying cell by a value less than this tolerance, then the program will not terminate with an error. The default value is zero. This option should generally not be used. + +\end{description} +\item \textbf{Block: DIMENSIONS} + +\begin{description} +\item \texttt{nodes}---is the number of cells in the model grid. + +\item \texttt{nja}---is the sum of the number of connections and NODES. When calculating the total number of connections, the connection between cell n and cell m is considered to be different from the connection between cell m and cell n. Thus, NJA is equal to the total number of connections, including n to m and m to n, and the total number of cells. + +\item \texttt{nvert}---is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. NVERT and the accompanying VERTICES and CELL2D blocks should be specified for most simulations. If the XT3D or SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package, then this information is required. + +\end{description} +\item \textbf{Block: GRIDDATA} + +\begin{description} +\item \texttt{top}---is the top elevation for each cell in the model grid. + +\item \texttt{bot}---is the bottom elevation for each cell. + +\item \texttt{area}---is the cell surface area (in plan view). + +\item \texttt{idomain}---is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1 or greater, the cell exists in the simulation. IDOMAIN values of -1 cannot be specified for the DISU Package. + +\end{description} +\item \textbf{Block: CONNECTIONDATA} + +\begin{description} +\item \texttt{iac}---is the number of connections (plus 1) for each cell. The sum of all the entries in IAC must be equal to NJA. + +\item \texttt{ja}---is a list of cell number (n) followed by its connecting cell numbers (m) for each of the m cells connected to cell n. The number of values to provide for cell n is IAC(n). This list is sequentially provided for the first to the last cell. The first value in the list must be cell n itself, and the remaining cells must be listed in an increasing order (sorted from lowest number to highest). Note that the cell and its connections are only supplied for the GWE cells and their connections to the other GWE cells. Also note that the JA list input may be divided such that every node and its connectivity list can be on a separate line for ease in readability of the file. To further ease readability of the file, the node number of the cell whose connectivity is subsequently listed, may be expressed as a negative number, the sign of which is subsequently converted to positive by the code. + +\item \texttt{ihc}---is an index array indicating the direction between node n and all of its m connections. If IHC = 0 then cell n and cell m are connected in the vertical direction. Cell n overlies cell m if the cell number for n is less than m; cell m overlies cell n if the cell number for m is less than n. If IHC = 1 then cell n and cell m are connected in the horizontal direction. If IHC = 2 then cell n and cell m are connected in the horizontal direction, and the connection is vertically staggered. A vertically staggered connection is one in which a cell is horizontally connected to more than one cell in a horizontal connection. + +\item \texttt{cl12}---is the array containing connection lengths between the center of cell n and the shared face with each adjacent m cell. + +\item \texttt{hwva}---is a symmetric array of size NJA. For horizontal connections, entries in HWVA are the horizontal width perpendicular to flow. For vertical connections, entries in HWVA are the vertical area for flow. Thus, values in the HWVA array contain dimensions of both length and area. Entries in the HWVA array have a one-to-one correspondence with the connections specified in the JA array. Likewise, there is a one-to-one correspondence between entries in the HWVA array and entries in the IHC array, which specifies the connection type (horizontal or vertical). Entries in the HWVA array must be symmetric; the program will terminate with an error if the value for HWVA for an n to m connection does not equal the value for HWVA for the corresponding n to m connection. + +\item \texttt{angldegx}---is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells. The angle varies between zero and 360.0 degrees, where zero degrees points in the positive x-axis direction, and 90 degrees points in the positive y-axis direction. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package, if the XT3D option is used in the NPF Package, or if the SAVE\_SPECIFIC\_DISCHARGE option is specifed in the NPF Package. ANGLDEGX does not need to be specified if these conditions are not met. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. + +\end{description} +\item \textbf{Block: VERTICES} + +\begin{description} +\item \texttt{iv}---is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. + +\item \texttt{xv}---is the x-coordinate for the vertex. + +\item \texttt{yv}---is the y-coordinate for the vertex. + +\end{description} +\item \textbf{Block: CELL2D} + +\begin{description} +\item \texttt{icell2d}---is the cell2d number. Records in the CELL2D block must be listed in consecutive order from 1 to NODES. + +\item \texttt{xc}---is the x-coordinate for the cell center. + +\item \texttt{yc}---is the y-coordinate for the cell center. + +\item \texttt{ncvert}---is the number of vertices required to define the cell. There may be a different number of vertices for each cell. + +\item \texttt{icvert}---is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-dimensions.dat b/doc/mf6io/mf6ivar/tex/gwe-disu-dimensions.dat new file mode 100644 index 00000000000..56d54756a40 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-dimensions.dat @@ -0,0 +1,5 @@ +BEGIN DIMENSIONS + NODES + NJA + [NVERT ] +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-griddata.dat b/doc/mf6io/mf6ivar/tex/gwe-disu-griddata.dat new file mode 100644 index 00000000000..2978f43b84e --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-griddata.dat @@ -0,0 +1,10 @@ +BEGIN GRIDDATA + TOP + -- READARRAY + BOT + -- READARRAY + AREA + -- READARRAY + [IDOMAIN + -- READARRAY] +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-options.dat b/doc/mf6io/mf6ivar/tex/gwe-disu-options.dat new file mode 100644 index 00000000000..281b79a4a27 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-options.dat @@ -0,0 +1,8 @@ +BEGIN OPTIONS + [LENGTH_UNITS ] + [NOGRB] + [XORIGIN ] + [YORIGIN ] + [ANGROT ] + [VERTICAL_OFFSET_TOLERANCE ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-disu-vertices.dat b/doc/mf6io/mf6ivar/tex/gwe-disu-vertices.dat new file mode 100644 index 00000000000..6831f23b5ff --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disu-vertices.dat @@ -0,0 +1,5 @@ +BEGIN VERTICES + + + ... +END VERTICES diff --git a/doc/mf6io/mf6ivar/tex/gwe-disv-cell2d.dat b/doc/mf6io/mf6ivar/tex/gwe-disv-cell2d.dat new file mode 100644 index 00000000000..27900d67235 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disv-cell2d.dat @@ -0,0 +1,5 @@ +BEGIN CELL2D + + + ... +END CELL2D diff --git a/doc/mf6io/mf6ivar/tex/gwe-disv-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-disv-desc.tex new file mode 100644 index 00000000000..dac7917328f --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disv-desc.tex @@ -0,0 +1,61 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{length\_units}---is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. + +\item \texttt{NOGRB}---keyword to deactivate writing of the binary grid file. + +\item \texttt{xorigin}---x-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{yorigin}---y-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\item \texttt{angrot}---counter-clockwise rotation angle (in degrees) of the model grid coordinate system relative to a real-world coordinate system. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. + +\end{description} +\item \textbf{Block: DIMENSIONS} + +\begin{description} +\item \texttt{nlay}---is the number of layers in the model grid. + +\item \texttt{ncpl}---is the number of cells per layer. This is a constant value for the grid and it applies to all layers. + +\item \texttt{nvert}---is the total number of (x, y) vertex pairs used to characterize the horizontal configuration of the model grid. + +\end{description} +\item \textbf{Block: GRIDDATA} + +\begin{description} +\item \texttt{top}---is the top elevation for each cell in the top model layer. + +\item \texttt{botm}---is the bottom elevation for each cell. + +\item \texttt{idomain}---is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. + +\end{description} +\item \textbf{Block: VERTICES} + +\begin{description} +\item \texttt{iv}---is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. + +\item \texttt{xv}---is the x-coordinate for the vertex. + +\item \texttt{yv}---is the y-coordinate for the vertex. + +\end{description} +\item \textbf{Block: CELL2D} + +\begin{description} +\item \texttt{icell2d}---is the CELL2D number. Records in the CELL2D block must be listed in consecutive order from the first to the last. + +\item \texttt{xc}---is the x-coordinate for the cell center. + +\item \texttt{yc}---is the y-coordinate for the cell center. + +\item \texttt{ncvert}---is the number of vertices required to define the cell. There may be a different number of vertices for each cell. + +\item \texttt{icvert}---is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. Cells that are connected must share vertices. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-disv-dimensions.dat b/doc/mf6io/mf6ivar/tex/gwe-disv-dimensions.dat new file mode 100644 index 00000000000..b05791a77b3 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disv-dimensions.dat @@ -0,0 +1,5 @@ +BEGIN DIMENSIONS + NLAY + NCPL + NVERT +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-disv-griddata.dat b/doc/mf6io/mf6ivar/tex/gwe-disv-griddata.dat new file mode 100644 index 00000000000..a9db9563a42 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disv-griddata.dat @@ -0,0 +1,8 @@ +BEGIN GRIDDATA + TOP + -- READARRAY + BOTM [LAYERED] + -- READARRAY + [IDOMAIN [LAYERED] + -- READARRAY] +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-disv-options.dat b/doc/mf6io/mf6ivar/tex/gwe-disv-options.dat new file mode 100644 index 00000000000..67e3ed895ae --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disv-options.dat @@ -0,0 +1,7 @@ +BEGIN OPTIONS + [LENGTH_UNITS ] + [NOGRB] + [XORIGIN ] + [YORIGIN ] + [ANGROT ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-disv-vertices.dat b/doc/mf6io/mf6ivar/tex/gwe-disv-vertices.dat new file mode 100644 index 00000000000..6831f23b5ff --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-disv-vertices.dat @@ -0,0 +1,5 @@ +BEGIN VERTICES + + + ... +END VERTICES diff --git a/doc/mf6io/mf6ivar/tex/gwe-dsp-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-dsp-desc.tex new file mode 100644 index 00000000000..74be7a55443 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dsp-desc.tex @@ -0,0 +1,29 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{XT3D\_OFF}---deactivate the xt3d method and use the faster and less accurate approximation. This option may provide a fast and accurate solution under some circumstances, such as when flow aligns with the model grid, there is no mechanical dispersion, or when the longitudinal and transverse dispersivities are equal. This option may also be used to assess the computational demand of the XT3D approach by noting the run time differences with and without this option on. + +\item \texttt{XT3D\_RHS}---add xt3d terms to right-hand side, when possible. This option uses less memory, but may require more iterations. + +\end{description} +\item \textbf{Block: GRIDDATA} + +\begin{description} +\item \texttt{alh}---longitudinal dispersivity in horizontal direction. If flow is strictly horizontal, then this is the longitudinal dispersivity that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. + +\item \texttt{alv}---longitudinal dispersivity in vertical direction. If flow is strictly vertical, then this is the longitudinal dispsersivity value that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ALH. + +\item \texttt{ath1}---transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the second ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the y direction. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. + +\item \texttt{ath2}---transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the third ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the z direction. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH1. + +\item \texttt{atv}---transverse dispersivity when flow is in vertical direction. If flow is strictly vertical and directed in the z direction, then this value controls spreading in the x and y directions. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH2. + +\item \texttt{ktw}---thermal conductivity of water + +\item \texttt{kts}---thermal conductivity of the aquifer material + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-dsp-griddata.dat b/doc/mf6io/mf6ivar/tex/gwe-dsp-griddata.dat new file mode 100644 index 00000000000..ea8514e771b --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dsp-griddata.dat @@ -0,0 +1,16 @@ +BEGIN GRIDDATA + [ALH [LAYERED] + -- READARRAY] + [ALV [LAYERED] + -- READARRAY] + [ATH1 [LAYERED] + -- READARRAY] + [ATH2 [LAYERED] + -- READARRAY] + [ATV [LAYERED] + -- READARRAY] + [KTW [LAYERED] + -- READARRAY] + [KTS [LAYERED] + -- READARRAY] +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-dsp-options.dat b/doc/mf6io/mf6ivar/tex/gwe-dsp-options.dat new file mode 100644 index 00000000000..8fd75f9d224 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-dsp-options.dat @@ -0,0 +1,4 @@ +BEGIN OPTIONS + [XT3D_OFF] + [XT3D_RHS] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-fmi-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-fmi-desc.tex new file mode 100644 index 00000000000..343dc0ff116 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-fmi-desc.tex @@ -0,0 +1,21 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{SAVE\_FLOWS}---keyword to indicate that FMI flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{FLOW\_IMBALANCE\_CORRECTION}---correct for an imbalance in flows by assuming that any residual flow error comes in or leaves at the concentration of the cell. When this option is activated, the GWT Model budget written to the listing file will contain two additional entries: FLOW-ERROR and FLOW-CORRECTION. These two entries will be equal but opposite in sign. The FLOW-CORRECTION term is a mass flow that is added to offset the error caused by an imprecise flow balance. If these terms are not relatively small, the flow model should be rerun with stricter convergence tolerances. + +\end{description} +\item \textbf{Block: PACKAGEDATA} + +\begin{description} +\item \texttt{flowtype}---is the word GWFBUDGET, GWFHEAD, GWFMOVER or the name of an advanced GWF stress package. If GWFBUDGET is specified, then the corresponding file must be a budget file from a previous GWF Model run. If an advanced GWF stress package name appears then the corresponding file must be the budget file saved by a LAK, SFR, MAW or UZF Package. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{fname}---is the name of the file containing flows. The path to the file should be included if the file is not located in the folder where the program was run. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-fmi-options.dat b/doc/mf6io/mf6ivar/tex/gwe-fmi-options.dat new file mode 100644 index 00000000000..d5ceb2575c8 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-fmi-options.dat @@ -0,0 +1,4 @@ +BEGIN OPTIONS + [SAVE_FLOWS] + [FLOW_IMBALANCE_CORRECTION] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-fmi-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwe-fmi-packagedata.dat new file mode 100644 index 00000000000..85d840ad9ef --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-fmi-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + FILEIN + FILEIN + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-ic-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-ic-desc.tex new file mode 100644 index 00000000000..7cf8d73b07a --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-ic-desc.tex @@ -0,0 +1,9 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: GRIDDATA} + +\begin{description} +\item \texttt{strt}---is the initial (starting) temperature---that is, the temperature at the beginning of the GWE Model simulation. STRT must be specified for all GWE Model simulations. One value is read for every model cell. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-ic-griddata.dat b/doc/mf6io/mf6ivar/tex/gwe-ic-griddata.dat new file mode 100644 index 00000000000..260626850a7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-ic-griddata.dat @@ -0,0 +1,4 @@ +BEGIN GRIDDATA + STRT [LAYERED] + -- READARRAY +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-lke-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-lke-desc.tex new file mode 100644 index 00000000000..b306a400e3c --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-lke-desc.tex @@ -0,0 +1,101 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated temperatures from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of lake cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of lake information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_TEMPERATURE}---keyword to indicate that the list of lake temperature will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_TEMPERATURE is specified, then temperature are printed for the last time step of each stress period. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of lake flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that lake flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TEMPERATURE}---keyword to specify that record corresponds to temperature. + +\item \texttt{tempfile}---name of the binary output file to write temperature information. + +\item \texttt{BUDGET}---keyword to specify that record corresponds to the budget. + +\item \texttt{FILEOUT}---keyword to specify that an output filename is expected next. + +\item \texttt{budgetfile}---name of the binary output file to write budget information. + +\item \texttt{BUDGETCSV}---keyword to specify that record corresponds to the budget CSV. + +\item \texttt{budgetcsvfile}---name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the LKE package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the LKE package. + +\end{description} +\item \textbf{Block: PACKAGEDATA} + +\begin{description} +\item \texttt{lakeno}---integer value that defines the lake number associated with the specified PACKAGEDATA data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. Lake information must be specified for every lake or the program will terminate with an error. The program will also terminate with an error if information for a lake is specified more than once. + +\item \texttt{strt}---real value that defines the starting temperature for the lake. + +\item \texttt{ktf}---is the thermal conductivity of the of the interface between the aquifer cell and the lake. + +\item \texttt{rbthcnd}---real value that defines the thickness of the lakebed material through which conduction occurs. Must be greater than 0. + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each lake. The values of auxiliary variables must be present for each lake. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the lake cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{lakeno}---integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. + +\item \texttt{laksetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated temperature of the lake. + +\begin{lstlisting}[style=blockdefinition] +STATUS +TEMPERATURE <@temperature@> +RAINFALL <@rainfall@> +EVAPORATION <@evaporation@> +RUNOFF <@runoff@> +EXT-INFLOW <@ext-inflow@> +AUXILIARY <@auxval@> +\end{lstlisting} + +\item \texttt{status}---keyword option to define lake status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the lake. If a lake is inactive, then there will be no solute mass fluxes into or out of the lake and the inactive value will be written for the lake temperature. If a lake is constant, then the temperature for the lake will be fixed at the user specified value. + +\item \textcolor{blue}{\texttt{temperature}---real or character value that defines the temperature for the lake. The specified TEMPERATURE is only applied if the lake is a constant temperature lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{rainfall}---real or character value that defines the rainfall temperature for the lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{evaporation}---real or character value that defines the temperature of evaporated water $(^{\circ}C)$ for the reach. If this temperature value is larger than the simulated temperature in the reach, then the evaporated water will be removed at the same temperature as the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{runoff}---real or character value that defines the temperature of runoff for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{ext-inflow}---real or character value that defines the temperature of external inflow for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. + +\item \texttt{auxname}---name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +\item \textcolor{blue}{\texttt{auxval}---value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-lke-options.dat b/doc/mf6io/mf6ivar/tex/gwe-lke-options.dat new file mode 100644 index 00000000000..ef83c7fa718 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-lke-options.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS + [FLOW_PACKAGE_NAME ] + [AUXILIARY ] + [FLOW_PACKAGE_AUXILIARY_NAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_TEMPERATURE] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TEMPERATURE FILEOUT ] + [BUDGET FILEOUT ] + [BUDGETCSV FILEOUT ] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-lke-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwe-lke-packagedata.dat new file mode 100644 index 00000000000..74aaecb370e --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-lke-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + [<@aux(naux)@>] [] + [<@aux(naux)@>] [] + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-lke-period.dat b/doc/mf6io/mf6ivar/tex/gwe-lke-period.dat new file mode 100644 index 00000000000..dfe899b47ef --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-lke-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + + + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-mst-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-mst-desc.tex new file mode 100644 index 00000000000..b88ecafd21e --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mst-desc.tex @@ -0,0 +1,37 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{SAVE\_FLOWS}---keyword to indicate that MST flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{FIRST\_ORDER\_DECAY}---is a text keyword to indicate that first-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. + +\item \texttt{ZERO\_ORDER\_DECAY}---is a text keyword to indicate that zero-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. + +\item \texttt{LATENT\_HEAT\_VAPORIZATION}---is a text keyword to indicate that cooling associated with evaporation will occur. Use of this keyword requires that LATHEATVAP are specified in the GRIDDATA block. While the MST package does not simulate evaporation, multiple other packages in a GWE simulation may. For example, evaporation may occur from the surface of streams or lakes. Owing to the energy consumed by the change in phase, the latent heat of vaporization is required. + +\end{description} +\item \textbf{Block: GRIDDATA} + +\begin{description} +\item \texttt{porosity}---is the aquifer porosity. + +\item \texttt{decay}---is the rate coefficient for first or zero-order decay for the aqueous phase of the mobile domain. A negative value indicates solute production. The dimensions of decay for first-order decay is one over time. The dimensions of decay for zero-order decay is mass per length cubed per time. decay will have no effect on simulation results unless either first- or zero-order decay is specified in the options block. + +\item \texttt{cps}---is the mass-based heat capacity of dry solids (aquifer material). Thus, enter value in units of J/kg/C + +\item \texttt{rhos}---is a user-specified value of the density of aquifer material not considering the voids. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3. Bulk density is calculated from this value. + +\end{description} +\item \textbf{Block: PACKAGEDATA} + +\begin{description} +\item \texttt{cpw}---is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. + +\item \texttt{rhow}---is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 + +\item \texttt{latheatvap}---is the user-specified value for the latent heat of vaporization. Currently, it may be specified spatially to facilitate temperature-dependent alterations in its value, though this functionality needs to be re-thought (perhaps its needs something like the VSC package approach). Typical units are kJ/kg (which is the same as J/g). + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-mst-griddata.dat b/doc/mf6io/mf6ivar/tex/gwe-mst-griddata.dat new file mode 100644 index 00000000000..b67c69b58c4 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mst-griddata.dat @@ -0,0 +1,10 @@ +BEGIN GRIDDATA + POROSITY [LAYERED] + -- READARRAY + [DECAY [LAYERED] + -- READARRAY] + CPS [LAYERED] + -- READARRAY + RHOS [LAYERED] + -- READARRAY +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-mst-options.dat b/doc/mf6io/mf6ivar/tex/gwe-mst-options.dat new file mode 100644 index 00000000000..e066ec5e11c --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mst-options.dat @@ -0,0 +1,6 @@ +BEGIN OPTIONS + [SAVE_FLOWS] + [FIRST_ORDER_DECAY] + [ZERO_ORDER_DECAY] + [LATENT_HEAT_VAPORIZATION] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-mst-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwe-mst-packagedata.dat new file mode 100644 index 00000000000..d94a5a61d14 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mst-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + + + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-mwe-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-mwe-desc.tex new file mode 100644 index 00000000000..26df2a2bdbc --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mwe-desc.tex @@ -0,0 +1,92 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated temperatures from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of well cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of well information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_TEMPERATURE}---keyword to indicate that the list of well temperature will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_TEMPERATURE is specified, then temperature are printed for the last time step of each stress period. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of well flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that well flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TEMPERATURE}---keyword to specify that record corresponds to temperature. + +\item \texttt{tempfile}---name of the binary output file to write temperature information. + +\item \texttt{BUDGET}---keyword to specify that record corresponds to the budget. + +\item \texttt{FILEOUT}---keyword to specify that an output filename is expected next. + +\item \texttt{budgetfile}---name of the binary output file to write budget information. + +\item \texttt{BUDGETCSV}---keyword to specify that record corresponds to the budget CSV. + +\item \texttt{budgetcsvfile}---name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the MWE package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the MWE package. + +\end{description} +\item \textbf{Block: PACKAGEDATA} + +\begin{description} +\item \texttt{mawno}---integer value that defines the well number associated with the specified PACKAGEDATA data on the line. MAWNO must be greater than zero and less than or equal to NMAWWELLS. Well information must be specified for every well or the program will terminate with an error. The program will also terminate with an error if information for a well is specified more than once. + +\item \texttt{strt}---real value that defines the starting temperature for the well. + +\item \texttt{ktf}---is the thermal conductivity of the of the interface between the aquifer cell and the feature. + +\item \texttt{fthk}---real value that defines the thickness of the material through which conduction occurs. Must be greater than 0. + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each well. The values of auxiliary variables must be present for each well. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the well cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{mawno}---integer value that defines the well number associated with the specified PERIOD data on the line. MAWNO must be greater than zero and less than or equal to NMAWWELLS. + +\item \texttt{mwesetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the MWESETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature of associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Multi-Aquifer Well Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the well at the calculated temperature of the well. + +\begin{lstlisting}[style=blockdefinition] +STATUS +TEMPERATURE <@temperature@> +RATE <@rate@> +AUXILIARY <@auxval@> +\end{lstlisting} + +\item \texttt{status}---keyword option to define well status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the well. If a well is inactive, then there will be no solute mass fluxes into or out of the well and the inactive value will be written for the well temperature. If a well is constant, then the temperature for the well will be fixed at the user specified value. + +\item \textcolor{blue}{\texttt{temperature}---real or character value that defines the temperature for the well. The specified TEMPERATURE is only applied if the well is a constant temperature well. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{rate}---real or character value that defines the injection solute temperature $^{\circ}C$ for the well. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. + +\item \texttt{auxname}---name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +\item \textcolor{blue}{\texttt{auxval}---value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-mwe-options.dat b/doc/mf6io/mf6ivar/tex/gwe-mwe-options.dat new file mode 100644 index 00000000000..ef83c7fa718 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mwe-options.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS + [FLOW_PACKAGE_NAME ] + [AUXILIARY ] + [FLOW_PACKAGE_AUXILIARY_NAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_TEMPERATURE] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TEMPERATURE FILEOUT ] + [BUDGET FILEOUT ] + [BUDGETCSV FILEOUT ] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-mwe-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwe-mwe-packagedata.dat new file mode 100644 index 00000000000..0d46cfac181 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mwe-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + [<@aux(naux)@>] [] + [<@aux(naux)@>] [] + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-mwe-period.dat b/doc/mf6io/mf6ivar/tex/gwe-mwe-period.dat new file mode 100644 index 00000000000..4c9a183703a --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mwe-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + + + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-nam-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-nam-desc.tex new file mode 100644 index 00000000000..b464804151c --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-nam-desc.tex @@ -0,0 +1,25 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{list}---is name of the listing file to create for this GWE model. If not specified, then the name of the list file will be the basename of the GWE model name file and the '.lst' extension. For example, if the GWE name file is called ``my.model.nam'' then the list file will be called ``my.model.lst''. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of all model stress package information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of all model package flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that all model package flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\end{description} +\item \textbf{Block: PACKAGES} + +\begin{description} +\item \texttt{ftype}---is the file type, which must be one of the following character values shown in table~\ref{table:ftype}. Ftype may be entered in any combination of uppercase and lowercase. + +\item \texttt{fname}---is the name of the file containing the package input. The path to the file should be included if the file is not located in the folder where the program was run. + +\item \texttt{pname}---is the user-defined name for the package. PNAME is restricted to 16 characters. No spaces are allowed in PNAME. PNAME character values are read and stored by the program for stress packages only. These names may be useful for labeling purposes when multiple stress packages of the same type are located within a single GWE Model. If PNAME is specified for a stress package, then PNAME will be used in the flow budget table in the listing file; it will also be used for the text entry in the cell-by-cell budget file. PNAME is case insensitive and is stored in all upper case letters. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-nam-options.dat b/doc/mf6io/mf6ivar/tex/gwe-nam-options.dat new file mode 100644 index 00000000000..a65ebd5e24d --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-nam-options.dat @@ -0,0 +1,6 @@ +BEGIN OPTIONS + [LIST ] + [PRINT_INPUT] + [PRINT_FLOWS] + [SAVE_FLOWS] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-nam-packages.dat b/doc/mf6io/mf6ivar/tex/gwe-nam-packages.dat new file mode 100644 index 00000000000..ee5dc814ee7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-nam-packages.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGES + [] + [] + ... +END PACKAGES diff --git a/doc/mf6io/mf6ivar/tex/gwe-oc-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-oc-desc.tex new file mode 100644 index 00000000000..5cf6ff3a1d4 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-oc-desc.tex @@ -0,0 +1,63 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{BUDGET}---keyword to specify that record corresponds to the budget. + +\item \texttt{FILEOUT}---keyword to specify that an output filename is expected next. + +\item \texttt{budgetfile}---name of the output file to write budget information. + +\item \texttt{BUDGETCSV}---keyword to specify that record corresponds to the budget CSV. + +\item \texttt{budgetcsvfile}---name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +\item \texttt{TEMPERATURE}---keyword to specify that record corresponds to temperature. + +\item \texttt{temperaturefile}---name of the output file to write conc information. + +\item \texttt{PRINT\_FORMAT}---keyword to specify format for printing to the listing file. + +\item \texttt{columns}---number of columns for writing data. + +\item \texttt{width}---width for writing each number. + +\item \texttt{digits}---number of digits to use for writing a number. + +\item \texttt{format}---write format can be EXPONENTIAL, FIXED, GENERAL, or SCIENTIFIC. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{SAVE}---keyword to indicate that information will be saved this stress period. + +\item \texttt{PRINT}---keyword to indicate that information will be printed this stress period. + +\item \texttt{rtype}---type of information to save or print. Can be BUDGET or TEMPERATURE. + +\item \texttt{ocsetting}---specifies the steps for which the data will be saved. + +\begin{lstlisting}[style=blockdefinition] +ALL +FIRST +LAST +FREQUENCY +STEPS +\end{lstlisting} + +\item \texttt{ALL}---keyword to indicate save for all time steps in period. + +\item \texttt{FIRST}---keyword to indicate save for first step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +\item \texttt{LAST}---keyword to indicate save for last step in period. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +\item \texttt{frequency}---save at the specified time step frequency. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +\item \texttt{steps}---save for each step specified in STEPS. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-oc-options.dat b/doc/mf6io/mf6ivar/tex/gwe-oc-options.dat new file mode 100644 index 00000000000..aedf37e5832 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-oc-options.dat @@ -0,0 +1,6 @@ +BEGIN OPTIONS + [BUDGET FILEOUT ] + [BUDGETCSV FILEOUT ] + [TEMPERATURE FILEOUT ] + [TEMPERATURE PRINT_FORMAT COLUMNS WIDTH DIGITS ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-oc-period.dat b/doc/mf6io/mf6ivar/tex/gwe-oc-period.dat new file mode 100644 index 00000000000..abcceee3794 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-oc-period.dat @@ -0,0 +1,4 @@ +BEGIN PERIOD + [SAVE ] + [PRINT ] +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-sfe-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-sfe-desc.tex new file mode 100644 index 00000000000..468c8fb2285 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-sfe-desc.tex @@ -0,0 +1,101 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable provided in the corresponding flow package (i.e., FLOW\_PACKAE\_NAME). If specified, then the simulated temperatures from this advanced energy transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced energy transport package are read from a file, then this option will have no effect. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of reach cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of reach information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_TEMPERATURE}---keyword to indicate that the list of reach temperatures will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_TEMPERATURE is specified, then temperatures are printed for the last time step of each stress period. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of reach flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that reach flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TEMPERATURE}---keyword to specify that record corresponds to temperature. + +\item \texttt{tempfile}---name of the binary output file to write temperature information. + +\item \texttt{BUDGET}---keyword to specify that record corresponds to the budget. + +\item \texttt{FILEOUT}---keyword to specify that an output filename is expected next. + +\item \texttt{budgetfile}---name of the binary output file to write budget information. + +\item \texttt{BUDGETCSV}---keyword to specify that record corresponds to the budget CSV. + +\item \texttt{budgetcsvfile}---name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the SFT package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the SFT package. + +\end{description} +\item \textbf{Block: PACKAGEDATA} + +\begin{description} +\item \texttt{rno}---integer value that defines the reach number associated with the specified PACKAGEDATA data on the line. RNO must be greater than zero and less than or equal to NREACHES. Reach information must be specified for every reach or the program will terminate with an error. The program will also terminate with an error if information for a reach is specified more than once. + +\item \texttt{strt}---real value that defines the starting temperature for the reach. + +\item \texttt{ktf}---is the thermal conductivity of the of the interface between the aquifer cell and the stream reach. + +\item \texttt{rbthcnd}---real value that defines the thickness of the streambed material through which conduction occurs. Must be greater than 0. + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each reach. The values of auxiliary variables must be present for each reach. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the reach cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{rno}---integer value that defines the reach number associated with the specified PERIOD data on the line. RNO must be greater than zero and less than or equal to NREACHES. + +\item \texttt{reachsetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the REACHSETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature of associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Streamflow Package supports a ``DIVERSION'' flow term. Diversion water will be routed using the calculated temperature of the reach. + +\begin{lstlisting}[style=blockdefinition] +STATUS +TEMPERATURE <@temperature@> +RAINFALL <@rainfall@> +EVAPORATION <@evaporation@> +RUNOFF <@runoff@> +INFLOW <@inflow@> +AUXILIARY <@auxval@> +\end{lstlisting} + +\item \texttt{status}---keyword option to define reach status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the reach. If a reach is inactive, then there will be no energy fluxes into or out of the reach and the inactive value will be written for the reach temperature. If a reach is constant, then the temperature for the reach will be fixed at the user specified value. + +\item \textcolor{blue}{\texttt{temperature}---real or character value that defines the temperature for the reach. The specified TEMPERATURE is only applied if the reach is a constant temperature reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{rainfall}---real or character value that defines the rainfall temperature $(^{\circ}C)$ for the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{evaporation}---real or character value that defines the temperature of evaporated water $(^{\circ}C)$ for the reach. If this temperature value is larger than the simulated temperature in the reach, then the evaporated water will be removed at the same temperature as the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{runoff}---real or character value that defines the temperature of runoff $(^{\circ}C)$ for the reach. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{inflow}---real or character value that defines the temperature of inflow $(^{\circ}C)$ for the reach. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. + +\item \texttt{auxname}---name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +\item \textcolor{blue}{\texttt{auxval}---value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-sfe-options.dat b/doc/mf6io/mf6ivar/tex/gwe-sfe-options.dat new file mode 100644 index 00000000000..ef83c7fa718 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-sfe-options.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS + [FLOW_PACKAGE_NAME ] + [AUXILIARY ] + [FLOW_PACKAGE_AUXILIARY_NAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_TEMPERATURE] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TEMPERATURE FILEOUT ] + [BUDGET FILEOUT ] + [BUDGETCSV FILEOUT ] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-sfe-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwe-sfe-packagedata.dat new file mode 100644 index 00000000000..d75a5bae2d0 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-sfe-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + [<@aux(naux)@>] [] + [<@aux(naux)@>] [] + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-sfe-period.dat b/doc/mf6io/mf6ivar/tex/gwe-sfe-period.dat new file mode 100644 index 00000000000..1b56b2824e2 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-sfe-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + + + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-src-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-src-desc.tex new file mode 100644 index 00000000000..89176dd5982 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-src-desc.tex @@ -0,0 +1,49 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of energy loading rate. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of energy source cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of energy source information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of energy source flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that energy source flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the Mass Source package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the Mass Source package. + +\end{description} +\item \textbf{Block: DIMENSIONS} + +\begin{description} +\item \texttt{maxbound}---integer value specifying the maximum number of sources cells that will be specified for use during any stress period. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{cellid}---is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. + +\item \textcolor{blue}{\texttt{senerrate}---is the energy source loading rate. A positive value indicates addition of energy and a negative value indicates removal of energy. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each energy source. The values of auxiliary variables must be present for each energy source. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the energy source cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-src-dimensions.dat b/doc/mf6io/mf6ivar/tex/gwe-src-dimensions.dat new file mode 100644 index 00000000000..7b4c7bf6ec7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-src-dimensions.dat @@ -0,0 +1,3 @@ +BEGIN DIMENSIONS + MAXBOUND +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-src-options.dat b/doc/mf6io/mf6ivar/tex/gwe-src-options.dat new file mode 100644 index 00000000000..0985bd51e40 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-src-options.dat @@ -0,0 +1,10 @@ +BEGIN OPTIONS + [AUXILIARY ] + [AUXMULTNAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-src-period.dat b/doc/mf6io/mf6ivar/tex/gwe-src-period.dat new file mode 100644 index 00000000000..1d90784538b --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-src-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + <@senerrate@> [<@aux(naux)@>] [] + <@senerrate@> [<@aux(naux)@>] [] + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-ssm-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-ssm-desc.tex new file mode 100644 index 00000000000..c0585a88d59 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-ssm-desc.tex @@ -0,0 +1,35 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of SSM flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that SSM flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\end{description} +\item \textbf{Block: SOURCES} + +\begin{description} +\item \texttt{pname}---name of the flow package for which an auxiliary variable contains a source temperature. If this flow package is represented using an advanced transport package (SFT, LKT, MWT, or UZT), then the advanced transport package will override SSM terms specified here. + +\item \texttt{srctype}---keyword indicating how temperature will be assigned for sources and sinks. Keyword must be specified as either AUX or AUXMIXED. For both options the user must provide an auxiliary variable in the corresponding flow package. The auxiliary variable must have the same name as the AUXNAME value that follows. If the AUX keyword is specified, then the auxiliary variable specified by the user will be assigned as the concenration value for groundwater sources (flows with a positive sign). For negative flow rates (sinks), groundwater will be withdrawn from the cell at the simulated temperature of the cell. The AUXMIXED option provides an alternative method for how to determine the temperature of sinks. If the cell temperature is larger than the user-specified auxiliary temperature, then the temperature of groundwater withdrawn from the cell will be assigned as the user-specified temperature. Alternatively, if the user-specified auxiliary temperature is larger than the cell temperature, then groundwater will be withdrawn at the cell temperature. Thus, the AUXMIXED option is designed to work with the Evapotranspiration (EVT) and Recharge (RCH) Packages where water may be withdrawn at a temperature that is less than the cell temperature. + +\item \texttt{auxname}---name of the auxiliary variable in the package PNAME. This auxiliary variable must exist and be specified by the user in that package. The values in this auxiliary variable will be used to set the temperature associated with the flows for that boundary package. + +\end{description} +\item \textbf{Block: FILEINPUT} + +\begin{description} +\item \texttt{pname}---name of the flow package for which an SPC6 input file contains a source temperature. If this flow package is represented using an advanced transport package (SFT, LKT, MWT, or UZT), then the advanced transport package will override SSM terms specified here. + +\item \texttt{SPC6}---keyword to specify that record corresponds to a source sink mixing input file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{spc6\_filename}---character string that defines the path and filename for the file containing source and sink input data for the flow package. The SPC6\_FILENAME file is a flexible input file that allows temperatures to be specified by stress period and with time series. Instructions for creating the SPC6\_FILENAME input file are provided in the next section on file input for boundary temperatures. + +\item \texttt{MIXED}---keyword to specify that these stress package boundaries will have the mixed condition. The MIXED condition is described in the SOURCES block for AUXMIXED. The MIXED condition allows for water to be withdrawn at a temperature that is less than the cell temperature. It is intended primarily for representing evapotranspiration. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-ssm-fileinput.dat b/doc/mf6io/mf6ivar/tex/gwe-ssm-fileinput.dat new file mode 100644 index 00000000000..37a7a969d7a --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-ssm-fileinput.dat @@ -0,0 +1,5 @@ +BEGIN FILEINPUT + SPC6 FILEIN [MIXED] + SPC6 FILEIN [MIXED] + ... +END FILEINPUT diff --git a/doc/mf6io/mf6ivar/tex/gwe-ssm-options.dat b/doc/mf6io/mf6ivar/tex/gwe-ssm-options.dat new file mode 100644 index 00000000000..de7ccf03076 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-ssm-options.dat @@ -0,0 +1,4 @@ +BEGIN OPTIONS + [PRINT_FLOWS] + [SAVE_FLOWS] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-ssm-sources.dat b/doc/mf6io/mf6ivar/tex/gwe-ssm-sources.dat new file mode 100644 index 00000000000..82557990b00 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-ssm-sources.dat @@ -0,0 +1,5 @@ +BEGIN SOURCES + + + ... +END SOURCES diff --git a/doc/mf6io/mf6ivar/tex/gwe-tmp-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-tmp-desc.tex new file mode 100644 index 00000000000..adda7d48fd1 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-tmp-desc.tex @@ -0,0 +1,49 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of temperature value. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of constant temperature cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of constant temperature information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of constant temperature flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that constant temperature flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the Constant Temperature package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the Constant Temperature package. + +\end{description} +\item \textbf{Block: DIMENSIONS} + +\begin{description} +\item \texttt{maxbound}---integer value specifying the maximum number of constant temperatures cells that will be specified for use during any stress period. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{cellid}---is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. + +\item \textcolor{blue}{\texttt{temp}---is the constant temperature value. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each constant temperature. The values of auxiliary variables must be present for each constant temperature. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the constant temperature cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-tmp-dimensions.dat b/doc/mf6io/mf6ivar/tex/gwe-tmp-dimensions.dat new file mode 100644 index 00000000000..7b4c7bf6ec7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-tmp-dimensions.dat @@ -0,0 +1,3 @@ +BEGIN DIMENSIONS + MAXBOUND +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-tmp-options.dat b/doc/mf6io/mf6ivar/tex/gwe-tmp-options.dat new file mode 100644 index 00000000000..0985bd51e40 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-tmp-options.dat @@ -0,0 +1,10 @@ +BEGIN OPTIONS + [AUXILIARY ] + [AUXMULTNAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-tmp-period.dat b/doc/mf6io/mf6ivar/tex/gwe-tmp-period.dat new file mode 100644 index 00000000000..71db20fc4ec --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-tmp-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + <@temp@> [<@aux(naux)@>] [] + <@temp@> [<@aux(naux)@>] [] + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-uze-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-uze-desc.tex new file mode 100644 index 00000000000..d209370d535 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-uze-desc.tex @@ -0,0 +1,91 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). + +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of unsaturated zone flow cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of unsaturated zone flow information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_TEMPERATURE}---keyword to indicate that the list of UZF cell temperatures will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_TEMPERATURE is specified, then temperatures are printed for the last time step of each stress period. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of unsaturated zone flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that unsaturated zone flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TEMPERATURE}---keyword to specify that record corresponds to temperature. + +\item \texttt{tempfile}---name of the binary output file to write temperature information. + +\item \texttt{BUDGET}---keyword to specify that record corresponds to the budget. + +\item \texttt{FILEOUT}---keyword to specify that an output filename is expected next. + +\item \texttt{budgetfile}---name of the binary output file to write budget information. + +\item \texttt{BUDGETCSV}---keyword to specify that record corresponds to the budget CSV. + +\item \texttt{budgetcsvfile}---name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the UZE package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the UZE package. + +\end{description} +\item \textbf{Block: PACKAGEDATA} + +\begin{description} +\item \texttt{uzfno}---integer value that defines the UZF cell number associated with the specified PACKAGEDATA data on the line. UZFNO must be greater than zero and less than or equal to NUZFCELLS. Unsaturated zone flow information must be specified for every UZF cell or the program will terminate with an error. The program also will terminate with an error if information for a UZF cell is specified more than once. + +\item \texttt{strt}---real value that defines the starting temperature for the unsaturated zone flow cell. + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each unsaturated zone flow. The values of auxiliary variables must be present for each unsaturated zone flow. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the unsaturated zone flow cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{uzfno}---integer value that defines the UZF cell number associated with the specified PERIOD data on the line. UZFNO must be greater than zero and less than or equal to NUZFCELLS. + +\item \texttt{uzesetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the UZESETTING string include: STATUS, TEMPERATURE, INFILTRATION, UZET, and AUXILIARY. These settings are used to assign the temperature associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. + +\begin{lstlisting}[style=blockdefinition] +STATUS +TEMPERATURE <@temperature@> +INFILTRATION <@infiltration@> +UZET <@uzet@> +AUXILIARY <@auxval@> +\end{lstlisting} + +\item \texttt{status}---keyword option to define UZF cell status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the UZF cell. If a UZF cell is inactive, then there will be no energy fluxes into or out of the UZF cell and the inactive value will be written for the UZF cell temperature. If a UZF cell is constant, then the temperature for the UZF cell will be fixed at the user specified value. + +\item \textcolor{blue}{\texttt{temperature}---real or character value that defines the temperature for the unsaturated zone flow cell. The specified TEMPERATURE is only applied if the unsaturated zone flow cell is a constant temperature cell. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{infiltration}---real or character value that defines the temperature of the infiltration $(^\circ C)$ for the UZF cell. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{uzet}---real or character value that states what fraction of the simulated unsaturated zone evapotranspiration is associated with evaporation. The evaporative losses from the unsaturated zone moisture content will have an evaporative cooling effect on the GWE cell from which the evaporation originated. If this value is larger than 1, then it will be reset to 1. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{AUXILIARY}---keyword for specifying auxiliary variable. + +\item \texttt{auxname}---name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. + +\item \textcolor{blue}{\texttt{auxval}---value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-uze-options.dat b/doc/mf6io/mf6ivar/tex/gwe-uze-options.dat new file mode 100644 index 00000000000..ef83c7fa718 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-uze-options.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS + [FLOW_PACKAGE_NAME ] + [AUXILIARY ] + [FLOW_PACKAGE_AUXILIARY_NAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_TEMPERATURE] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TEMPERATURE FILEOUT ] + [BUDGET FILEOUT ] + [BUDGETCSV FILEOUT ] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-uze-packagedata.dat b/doc/mf6io/mf6ivar/tex/gwe-uze-packagedata.dat new file mode 100644 index 00000000000..b6b04c298fe --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-uze-packagedata.dat @@ -0,0 +1,5 @@ +BEGIN PACKAGEDATA + [<@aux(naux)@>] [] + [<@aux(naux)@>] [] + ... +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/tex/gwe-uze-period.dat b/doc/mf6io/mf6ivar/tex/gwe-uze-period.dat new file mode 100644 index 00000000000..b06edb21028 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-uze-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + + + ... +END PERIOD From d8abaef3cf26c82c40172fc1bb309d666a80b079 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 7 Jun 2023 20:20:32 -0700 Subject: [PATCH 173/212] mf6io stuff (and lots of it) --- doc/Common/gwe-cncobs.tex | 1 + doc/Common/gwe-gweobs.tex | 1 + doc/Common/gwe-lkeobs.tex | 18 + doc/Common/gwe-mweobs.tex | 13 + doc/Common/gwe-obs.tex | 2 + doc/Common/gwe-sfeobs.tex | 16 + doc/Common/gwe-srcobs.tex | 1 + doc/Common/gwe-uzeobs.tex | 14 + doc/MODFLOW6References.bib | 22 + doc/mf6io/body.tex | 5 + doc/mf6io/gwe/adv.tex | 16 + doc/mf6io/gwe/cnc.tex | 47 + doc/mf6io/gwe/dsp.tex | 17 + doc/mf6io/gwe/fmi.tex | 54 + doc/mf6io/gwe/gwe-gwe.tex | 45 + doc/mf6io/gwe/gwe-obs.tex | 39 + doc/mf6io/gwe/gwe.tex | 155 ++ doc/mf6io/gwe/ic.tex | 17 + doc/mf6io/gwe/lke.tex | 55 + doc/mf6io/gwe/mst.tex | 17 + doc/mf6io/gwe/mve.tex | 18 + doc/mf6io/gwe/mwe.tex | 55 + doc/mf6io/gwe/namefile.tex | 53 + doc/mf6io/gwe/oc.tex | 25 + doc/mf6io/gwe/sfe.tex | 55 + doc/mf6io/gwe/src.tex | 47 + doc/mf6io/gwe/ssm.tex | 114 + doc/mf6io/gwe/uze.tex | 55 + doc/mf6io/mf6io.bbl | 289 +++ doc/mf6io/mf6ivar/dfn/gwe-cnc.dfn | 206 ++ doc/mf6io/mf6ivar/dfn/gwe-mve.dfn | 106 + .../examples/exg-gwegwe-example-obs.dat | 12 + .../mf6ivar/examples/exg-gwegwe-example.dat | 58 + .../mf6ivar/examples/gwe-adv-example.dat | 3 + .../mf6ivar/examples/gwe-cnc-example-obs.dat | 16 + .../mf6ivar/examples/gwe-cnc-example.dat | 15 + .../mf6ivar/examples/gwe-dsp-example.dat | 19 + .../mf6ivar/examples/gwe-fmi-example.dat | 14 + doc/mf6io/mf6ivar/examples/gwe-ic-example.dat | 10 + .../mf6ivar/examples/gwe-lke-example-obs.dat | 25 + .../mf6ivar/examples/gwe-lke-example.dat | 24 + .../mf6ivar/examples/gwe-mst-example.dat | 15 + .../mf6ivar/examples/gwe-mve-example.dat | 6 + .../mf6ivar/examples/gwe-mwe-example-obs.dat | 43 + .../mf6ivar/examples/gwe-mwe-example.dat | 24 + doc/mf6io/mf6ivar/examples/gwe-oc-example.dat | 10 + .../mf6ivar/examples/gwe-sfe-example-obs.dat | 24 + .../mf6ivar/examples/gwe-sfe-example.dat | 24 + .../mf6ivar/examples/gwe-src-example-obs.dat | 11 + .../mf6ivar/examples/gwe-src-example.dat | 13 + .../mf6ivar/examples/gwe-ssm-example.dat | 16 + .../mf6ivar/examples/gwe-uze-example-obs.dat | 12 + .../mf6ivar/examples/gwe-uze-example.dat | 24 + .../mf6ivar/examples/utl-obs-gwe-example.dat | 18 + doc/mf6io/mf6ivar/md/mf6ivar.md | 213 +- doc/mf6io/mf6ivar/md/mf6memvar.md | 1739 ++++++++------ doc/mf6io/mf6ivar/mf6ivar.py | 2 + doc/mf6io/mf6ivar/tex/appendixA.tex | 25 + doc/mf6io/mf6ivar/tex/exg-gwegwe-desc.tex | 63 + .../mf6ivar/tex/exg-gwegwe-dimensions.dat | 3 + .../mf6ivar/tex/exg-gwegwe-exchangedata.dat | 5 + doc/mf6io/mf6ivar/tex/exg-gwegwe-options.dat | 14 + doc/mf6io/mf6ivar/tex/exg-gwfgwe-desc.tex | 3 + doc/mf6io/mf6ivar/tex/gwe-cnc-desc.tex | 49 + doc/mf6io/mf6ivar/tex/gwe-cnc-dimensions.dat | 3 + doc/mf6io/mf6ivar/tex/gwe-cnc-options.dat | 10 + doc/mf6io/mf6ivar/tex/gwe-cnc-period.dat | 5 + doc/mf6io/mf6ivar/tex/gwe-mve-desc.tex | 23 + doc/mf6io/mf6ivar/tex/gwe-mve-options.dat | 7 + doc/mf6io/mf6ivar/tex/gwf-chd-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-drn-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-evta-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-ghb-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-rcha-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-riv-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-sfr-period.dat | 1 - doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwf-wel-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwt-cnc-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwt-disv-griddata.dat | 4 +- doc/mf6io/mf6ivar/tex/gwt-lkt-desc.tex | 4 +- doc/mf6io/mf6ivar/tex/gwt-mwt-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwt-sft-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwt-src-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/gwt-uzt-desc.tex | 2 +- doc/mf6io/mf6ivar/tex/sim-nam-desc.tex | 2 + doc/mf6io/mf6ivar/tex/sim-nam-options.dat | 1 + doc/usgs.bst | 2080 +++++++++++++++++ 93 files changed, 5541 insertions(+), 765 deletions(-) create mode 100644 doc/Common/gwe-cncobs.tex create mode 100644 doc/Common/gwe-gweobs.tex create mode 100644 doc/Common/gwe-lkeobs.tex create mode 100644 doc/Common/gwe-mweobs.tex create mode 100644 doc/Common/gwe-obs.tex create mode 100644 doc/Common/gwe-sfeobs.tex create mode 100644 doc/Common/gwe-srcobs.tex create mode 100644 doc/Common/gwe-uzeobs.tex create mode 100644 doc/mf6io/gwe/adv.tex create mode 100644 doc/mf6io/gwe/cnc.tex create mode 100644 doc/mf6io/gwe/dsp.tex create mode 100644 doc/mf6io/gwe/fmi.tex create mode 100644 doc/mf6io/gwe/gwe-gwe.tex create mode 100644 doc/mf6io/gwe/gwe-obs.tex create mode 100644 doc/mf6io/gwe/gwe.tex create mode 100644 doc/mf6io/gwe/ic.tex create mode 100644 doc/mf6io/gwe/lke.tex create mode 100644 doc/mf6io/gwe/mst.tex create mode 100644 doc/mf6io/gwe/mve.tex create mode 100644 doc/mf6io/gwe/mwe.tex create mode 100644 doc/mf6io/gwe/namefile.tex create mode 100644 doc/mf6io/gwe/oc.tex create mode 100644 doc/mf6io/gwe/sfe.tex create mode 100644 doc/mf6io/gwe/src.tex create mode 100644 doc/mf6io/gwe/ssm.tex create mode 100644 doc/mf6io/gwe/uze.tex create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-cnc.dfn create mode 100644 doc/mf6io/mf6ivar/dfn/gwe-mve.dfn create mode 100644 doc/mf6io/mf6ivar/examples/exg-gwegwe-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/exg-gwegwe-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-adv-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-cnc-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-cnc-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-dsp-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-fmi-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-ic-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-lke-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-lke-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-mst-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-mve-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-mwe-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-mwe-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-oc-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-sfe-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-sfe-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-src-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-src-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-ssm-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-uze-example-obs.dat create mode 100644 doc/mf6io/mf6ivar/examples/gwe-uze-example.dat create mode 100644 doc/mf6io/mf6ivar/examples/utl-obs-gwe-example.dat create mode 100644 doc/mf6io/mf6ivar/tex/exg-gwegwe-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/exg-gwegwe-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/exg-gwegwe-exchangedata.dat create mode 100644 doc/mf6io/mf6ivar/tex/exg-gwegwe-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/exg-gwfgwe-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-cnc-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-cnc-dimensions.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-cnc-options.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-cnc-period.dat create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mve-desc.tex create mode 100644 doc/mf6io/mf6ivar/tex/gwe-mve-options.dat create mode 100644 doc/usgs.bst diff --git a/doc/Common/gwe-cncobs.tex b/doc/Common/gwe-cncobs.tex new file mode 100644 index 00000000000..50b3b0bdc43 --- /dev/null +++ b/doc/Common/gwe-cncobs.tex @@ -0,0 +1 @@ +CNC & cnc & cellid or boundname & -- & Energy flow between the groundwater system and a constant-temperature boundary or a group of cells with constant-temperature boundaries. diff --git a/doc/Common/gwe-gweobs.tex b/doc/Common/gwe-gweobs.tex new file mode 100644 index 00000000000..35c76e185d6 --- /dev/null +++ b/doc/Common/gwe-gweobs.tex @@ -0,0 +1 @@ +GWE-GWE & flow-ja-face & exchange number or boundname & -- & Mass flow between model 1 and model 2 for a specified exchange (which is the consecutive exchange number listed in the EXCHANGEDATA block), or the sum of these exchange flows by boundname if boundname is specified. \ No newline at end of file diff --git a/doc/Common/gwe-lkeobs.tex b/doc/Common/gwe-lkeobs.tex new file mode 100644 index 00000000000..f66ba397ae3 --- /dev/null +++ b/doc/Common/gwe-lkeobs.tex @@ -0,0 +1,18 @@ +% general APT observations +LKE & temperature & lakeno or boundname & -- & Lake temperature. If boundname is specified, boundname must be unique for each lake. \\ +LKE & flow-ja-face & lakeno or boundname & lakeno or -- & Energy flow between two lakes connected by an outlet. If more than one outlet is used to connect the same two lakes, then the energy flow for only the first outlet can be observed. If a boundname is specified for ID1, then the result is the total energy flow for all outlets for a lake. If a boundname is specified for ID1 then ID2 is not used.\\ +LKE & storage & lakeno or boundname & -- & Simulated energy storage flow rate for a lake or group of lakes. \\ +LKE & constant & lakeno or boundname & -- & Simulated energy constant-flow rate for a lake or group of lakes. \\ +LKE & from-mvr & lakeno or boundname & -- & Simulated energy inflow into a lake or group of lakes from the MVE package. Energy inflow is calculated as the product of provider temperature and the mover flow rate. \\ +LKE & to-mvr & outletno or boundname & -- & Energy outflow from a lake outlet, a lake, or a group of lakes that is available for the MVR package. If boundname is not specified for ID, then the outflow available for the MVR package from a specific lake outlet is observed. In this case, ID is the outlet number, which must be between 1 and NOUTLETS. \\ +LKE & lke & lakeno or boundname & \texttt{iconn} or -- & Energy flow rate for a lake or group of lakes and its aquifer connection(s). If boundname is not specified for ID, then the simulated lake-aquifer flow rate at a specific lake connection is observed. In this case, ID2 must be specified and is the connection number \texttt{iconn} for lake \texttt{lakeno}. \\ + +%observations specific to the lake package +% rainfall evaporation runoff ext-inflow withdrawal outflow +LKE & rainfall & lakeno or boundname & -- & Rainfall rate applied to a lake or group of lakes multiplied by the rainfall temperature. \\ +LKE & evaporation & lakeno or boundname & -- & Simulated evaporation rate from a lake or group of lakes multiplied by the latent heat of evaporation for determining the energy lost from a lake. \\ +LKE & runoff & lakeno or boundname & -- & Runoff rate applied to a lake or group of lakes multiplied by the runoff temperature. \\ +LKE & ext-inflow & lakeno or boundname & -- & Energy inflow into a lake or group of lakes calculated as the external inflow rate multiplied by the inflow temperature. \\ +LKE & withdrawal & lakeno or boundname & -- & Specified withdrawal rate from a lake or group of lakes multiplied by the simulated lake temperature. \\ +LKE & ext-outflow & lakeno or boundname & -- & External outflow from a lake or a group of lakes, through their outlets, to an external boundary. If the water mover is active, the reported ext-outflow value plus the rate to mover is equal to the total outlet outflow. + diff --git a/doc/Common/gwe-mweobs.tex b/doc/Common/gwe-mweobs.tex new file mode 100644 index 00000000000..a2c51bf6a3b --- /dev/null +++ b/doc/Common/gwe-mweobs.tex @@ -0,0 +1,13 @@ +% general APT observations +MWE & temperature & mawno or boundname & -- & Well temperature. If boundname is specified, boundname must be unique for each well. \\ +%flowjaface not included +MWE & storage & mawno or boundname & -- & Simulated energy storage flow rate for a well or group of wells. \\ +MWE & constant & mawno or boundname & -- & Simulated energy constant-flow rate for a well or group of wells. \\ +MWE & from-mvr & mawno or boundname & -- & Simulated energy inflow into a well or group of wells from the MVE package. Energy inflow is calculated as the product of provider temperature and the mover flow rate. \\ +MWE & mwe & mawno or boundname & \texttt{iconn} or -- & Energy flow rate for a well or group of wells and its aquifer connection(s). If boundname is not specified for ID, then the simulated well-aquifer flow rate at a specific well connection is observed. In this case, ID2 must be specified and is the connection number \texttt{iconn} for well \texttt{mawno}. \\ + +% observations specific to the mwe package +MWE & rate & mawno or boundname & -- & Simulated energy flow rate for a well or group of wells. \\ +MWE & fw-rate & mawno or boundname & -- & Simulated energy flow rate for a flowing well or group of flowing wells. \\ +MWE & rate-to-mvr & well or boundname & -- & Simulated energy flow rate that is sent to the MVE Package for a well or group of wells.\\ +MWE & fw-rate-to-mvr & well or boundname & -- & Simulated energy flow rate that is sent to the MVE Package from a flowing well or group of flowing wells. \\ diff --git a/doc/Common/gwe-obs.tex b/doc/Common/gwe-obs.tex new file mode 100644 index 00000000000..05293d51f3c --- /dev/null +++ b/doc/Common/gwe-obs.tex @@ -0,0 +1,2 @@ +GWE & temperature & cellid & -- & Temperature at a specified cell. \\ +GWE & flow-ja-face & cellid & cellid & Energy flow in dimensions of energy per time between two adjacent cells. The energy flow rate includes the contributions from both convection (advection) and conduction (including mechanical dispersion) if those packages are active \ No newline at end of file diff --git a/doc/Common/gwe-sfeobs.tex b/doc/Common/gwe-sfeobs.tex new file mode 100644 index 00000000000..ccbc4158607 --- /dev/null +++ b/doc/Common/gwe-sfeobs.tex @@ -0,0 +1,16 @@ +% general APT observations +SFE & temperature & rno or boundname & -- & Reach temperature. If boundname is specified, boundname must be unique for each reach. \\ +SFE & flow-ja-face & rno or boundname & rno or -- & Energy flow between two reaches. If a boundname is specified for ID1, then the result is the total energy flow for all reaches. If a boundname is specified for ID1 then ID2 is not used.\\ +SFE & storage & rno or boundname & -- & Simulated energy storage flow rate for a reach or group of reaches. \\ +SFE & constant & rno or boundname & -- & Simulated energy constant-flow rate for a reach or group of reaches. \\ +SFE & from-mvr & rno or boundname & -- & Simulated energy inflow into a reach or group of reaches from the MVE package. Energy inflow is calculated as the product of provider temperature and the mover flow rate. \\ +SFE & to-mvr & rno or boundname & -- & Energy outflow from a reach, or a group of reaches that is available for the MVR package. If boundname is not specified for ID, then the outflow available for the MVR package from a specific reach is observed. \\ +SFE & sfe & rno or boundname & -- & Energy flow rate for a reach or group of reaches and its aquifer connection(s). \\ + +%observations specific to the stream energy transport package +% rainfall evaporation runoff ext-inflow withdrawal outflow +SFE & rainfall & rno or boundname & -- & Rainfall rate applied to a reach or group of reaches multiplied by the rainfall temperature. \\ +SFE & evaporation & rno or boundname & -- & Simulated evaporation rate from a reach or group of reaches multiplied by the latent heat of vaporization for determining the amount of energy lost from a reach. \\ +SFE & runoff & rno or boundname & -- & Runoff rate applied to a reach or group of reaches multiplied by the runoff temperature. \\ +SFE & ext-inflow & rno or boundname & -- & Energy inflow into a reach or group of reaches calculated as the external inflow rate multiplied by the inflow temperature. \\ +SFE & ext-outflow & rno or boundname & -- & External outflow from a reach or group of reaches to an external boundary. If boundname is not specified for ID, then the external outflow from a specific reach is observed. In this case, ID is the reach rno. diff --git a/doc/Common/gwe-srcobs.tex b/doc/Common/gwe-srcobs.tex new file mode 100644 index 00000000000..821ce336c5a --- /dev/null +++ b/doc/Common/gwe-srcobs.tex @@ -0,0 +1 @@ +SRC & src & cellid or boundname & -- & Energy source loading rate between the groundwater system and a energy source loading boundary or a group of boundaries. \ No newline at end of file diff --git a/doc/Common/gwe-uzeobs.tex b/doc/Common/gwe-uzeobs.tex new file mode 100644 index 00000000000..241c86ef653 --- /dev/null +++ b/doc/Common/gwe-uzeobs.tex @@ -0,0 +1,14 @@ +% general APT observations +UZE & temperature & uzeno or boundname & -- & uze cell temperature. If boundname is specified, boundname must be unique for each uze cell. \\ +UZE & flow-ja-face & uzeno or boundname & uzeno or -- & Energy flow between two uze cells. If a boundname is specified for ID1, then the result is the total energy flow for all uze cells. If a boundname is specified for ID1 then ID2 is not used.\\ +UZE & storage & uzeno or boundname & -- & Simulated energy storage flow rate for a uze cell or group of uze cells. \\ +UZE & constant & uzeno or boundname & -- & Simulated energy constant-flow rate for a uze cell or a group of uze cells. \\ +UZE & from-mvr & uzeno or boundname & -- & Simulated energy inflow into a uze cell or group of uze cells from the MVE package. Energy inflow is calculated as the product of provider temperature and the mover flow rate. \\ +UZE & uze & uzeno or boundname & -- & Energy flow rate for a uze cell or group of uze cells and its aquifer connection(s). \\ + +%observations specific to the uze package +% infiltration rej-inf uzet rej-inf-to-mvr +UZE & infiltration & uzeno or boundname & -- & Infiltration rate applied to a uze cell or group of uze cells multiplied by the infiltration temperature. \\ +UZE & rej-inf & uzeno or boundname & -- & Rejected infiltration rate applied to a uze cell or group of uze cells multiplied by the infiltration temperature. \\ +UZE & uzet & uzeno or boundname & -- & Unsaturated zone evapotranspiration rate applied to a uze cell or group of uze cells multiplied by the uze cell temperature. \\ +UZE & rej-inf-to-mvr & uzeno or boundname & -- & Rejected infiltration rate applied to a uze cell or group of uze cells multiplied by the infiltration temperature that is sent to the mover package. \\ diff --git a/doc/MODFLOW6References.bib b/doc/MODFLOW6References.bib index ebd845d7ab0..cfa684c3610 100644 --- a/doc/MODFLOW6References.bib +++ b/doc/MODFLOW6References.bib @@ -8,6 +8,28 @@ +@article{mazheng2010, + author = {Ma, Rui and Zheng, Chunmiao}, + title = {Effects of Density and Viscosity in Modeling Heat as a Groundwater Tracer}, + journal = {Groundwater}, + year = {2010}, + volume = {48}, + number = {3}, + pages = {380--389}, + doi = {10.1111/j.1745-6584.2009.00660.x}, + } + +@article{hechtmendez, + author = {Hecht-Mendez, J. and Molina-Giraldo, N. and Blum, P. and Bayer, P.}, + title = {Evaluating MT3DMS for Heat Transport Simulation of Closed Geothermal Systems}, + journal = {Groundwater}, + year = {2010}, + volume = {48}, + number = {5}, + pages = {741--756}, + doi = {10.1111/j.1745-6584.2010.00678.x}, + } + @article{morway2021, author = {Morway, Eric D. and Langevin, Christian D. and Hughes, Joseph D.}, title = {Use of the {MODFLOW 6} Water Mover Package to Represent Natural and Managed Hydrologic Connections}, diff --git a/doc/mf6io/body.tex b/doc/mf6io/body.tex index 4bcf8ca3f73..d12795434d2 100644 --- a/doc/mf6io/body.tex +++ b/doc/mf6io/body.tex @@ -37,6 +37,11 @@ \SECTION{Groundwater Transport (GWT) Model Input} \input{gwt/gwt.tex} +%GWE Model Input Instructions +\newpage +\SECTION{Groundwater Energy Transport (GWE) Model Input} +\input{gwe/gwe.tex} + %Sparse Matrix Solution (IMS) \newpage \SECTION{Iterative Model Solution} diff --git a/doc/mf6io/gwe/adv.tex b/doc/mf6io/gwe/adv.tex new file mode 100644 index 00000000000..3c10f398dec --- /dev/null +++ b/doc/mf6io/gwe/adv.tex @@ -0,0 +1,16 @@ +Advection (ADV) Package information is read from the file that is specified by ``ADV6'' as the file type. Only one ADV Package can be specified for a GWE model. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-adv-options.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-adv-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-adv-example.dat} + diff --git a/doc/mf6io/gwe/cnc.tex b/doc/mf6io/gwe/cnc.tex new file mode 100644 index 00000000000..d82548f7236 --- /dev/null +++ b/doc/mf6io/gwe/cnc.tex @@ -0,0 +1,47 @@ +Constant Temperature (CNC) Package information is read from the file that is specified by ``CNC6'' as the file type. Any number of CNC Packages can be specified for a single GWE model, but the same cell cannot be designated as a constant temperature by more than one CNC entry. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\vspace{5mm} + +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-cnc-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-cnc-dimensions.dat} +\vspace{5mm} +\noindent \textit{FOR ANY STRESS PERIOD} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-cnc-period.dat} +\packageperioddescription + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-cnc-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-cnc-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +CNC Package observations are limited to the simulated constant temperature energy flow rate (\texttt{cnc}). The data required for the CNC Package observation type is defined in table~\ref{table:gwe-cncobstype}. Negative and positive values for an observation represent a loss from and gain to the GWE model, respectively. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available CNC Package observation types} \tabularnewline + +\hline +\hline +\textbf{Model} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + +\hline +\endfoot + +\input{../Common/gwe-cncobs.tex} +\label{table:gwe-cncobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-cnc-example-obs.dat} diff --git a/doc/mf6io/gwe/dsp.tex b/doc/mf6io/gwe/dsp.tex new file mode 100644 index 00000000000..a12f1f3cd0c --- /dev/null +++ b/doc/mf6io/gwe/dsp.tex @@ -0,0 +1,17 @@ +Dispersion (DSP) Package information is read from the file that is specified by ``DSP6'' as the file type. Only one DSP Package can be specified for a GWE model. The DSP Package is based on the mathematical formulation presented for the XT3D option of the NPF Package available to represent full three-dimensional anisotropy in groundwater flow. XT3D can be computationally expensive and can be turned off to use a simplified and approximate form of the dispersion equations. For most problems, however, XT3D will be required to accurately represent dispersion. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-dsp-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-dsp-griddata.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-dsp-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-dsp-example.dat} + diff --git a/doc/mf6io/gwe/fmi.tex b/doc/mf6io/gwe/fmi.tex new file mode 100644 index 00000000000..5eab129cbed --- /dev/null +++ b/doc/mf6io/gwe/fmi.tex @@ -0,0 +1,54 @@ +Flow Model Interface (FMI) Package information is read from the file that is specified by ``FMI6'' as the file type. The FMI Package is optional, but if provided, only one FMI Package can be specified for a GWE model. + +For most simulations, the GWE Model needs groundwater flows for every cell in the model grid, for all boundary conditions, and for other terms, such as the flow of water in or out of storage. The FMI Package is the interface between the GWE Model and simulated groundwater flows provided by a corresponding GWF Model that is running concurrently within the simulation or from binary budget files that were created from a previous GWF model run. The following are several different FMI simulation cases: + +\begin{itemize} + +\item Flows are provided by a corresponding GWF Model running in the same simulation---in this case, all groundwater flows are calculated by the corresponding GWF Model and provided through FMI to the energy transport model. This is a common use case in which the user wants to run the flow and energy transport models as part of a single simulation. The GWF and GWE models must be part of a GWF-GWE Exchange that is listed in mfsim.nam. If a GWF-GWE Exchange is specified by the user, then the user does not need to specify an FMI Package input file for the simulation, unless an FMI option is needed. If a GWF-GWE Exchange is specified and the FMI Package is specified, then the PACKAGEDATA block below is not read or used. + +\item There is no groundwater flow and the user is interested only in the effects of diffusion, sorption, and decay or production---in this case, FMI should not be provided in the GWE name file and the GWE model should not be listed in any GWF-GWE Exchanges in mfsim.nam. In this case, all groundwater flows are assumed to be zero and cells are assumed to be fully saturated. The SSM Package should not be activated in this case, because there can be no sources or sinks of water. Likewise, none of the advanced transport packages (LKE, SFE, MWE, and UZE) should be specified in the GWE name file. This type of model simulation without an FMI Package is included as an option to represent diffusion, sorption, and decay or growth in the absence of any groundwater flow. + +\item Flows are provided from a previous GWF model simulation---in this case the FMI Package should be listed in the GWE name file and the head and budget files should be listed in the FMI PACKAGEDATA block. In this case, FMI reads the simulated head and flows from these files and makes them available to the energy transport model. There are some additional considerations when the heads and flows are provided from binary files. + +\begin{itemize} +\item The binary budget file must contain the simulated flows for all of the packages that were included in the GWF model run. Saving of flows can be activated for all packages by specifying ``SAVE\_FLOWS'' as an option in the GWF name file. The GWF Output Control Package must also have ``SAVE BUGET ALL'' specified. The easiest way to ensure that all flows and heads are saved is to use the following simple form of a GWF Output Control file: + +\begin{verbatim} +BEGIN OPTIONS + HEAD FILEOUT mymodel.hds + BUDGET FILEOUT mymodel.bud +END OPTIONS + +BEGIN PERIOD 1 + SAVE HEAD ALL + SAVE BUDGET ALL +END PERIOD +\end{verbatim} + +\item The binary budget file must have the same number of budget terms listed for each time step. This will always be the case when the binary budget file is created by \mf. +\item The advanced flow packages (LAK, SFR, MAW, and UZF) all have options for saving a detailed budget file the describes all of the flows for each lake, reach, well, or UZF cell. These budget files can also be used as input to FMI if a corresponding advanced transport package is needed, such as LKE, SFE, MWE, and UZE. If the Water Mover Package is also specified for the GWF Model, then the the budget file for the Water Mover Package will also need to be specified as input to this FMI Package. +\item The binary heads file must have heads saved for all layers in the model. This will always be the case when the binary head file is created by \mf. This was not always the case as previous MODFLOW versions allowed different save options for each layer. +\item If the binary budget and head files have more than one time step for a single stress period, then the budget and head information must be contained within the binary file for every time step in the simulation stress period. +\item The binary budget and head files must correspond in terms of information stored for each time step and stress period. +\item If the binary budget and head files have information provided for only the first time step of a given stress period, this information will be used for all time steps in that stress period in the GWE simulation. If the final stress period (which may be the only stress period) in the binary budget and head files has information provided for only one time step, this information will be used for any subsequent time steps and stress periods in the GWE simulation. This makes it possible to provide flows, for example, from a steady-state GWF stress period and have those flows used for all GWE time steps in that stress period, for all remaining time steps in the GWE simulation, or for all time steps throughout the entire GWE simulation. With this option, it is possible to have smaller time steps in the GWE simulation than the time steps used in the GWF simulation. Note that this cannot be done when the GWF and GWE models are run in the same simulation, because in that case, both models are solved for each time step in the stress period, as listed in the TDIS Package. This option for reading flows from a previous GWF simulation may offer an efficient alternative to running both models in the same simulation, but it comes at the cost of having potentially very large budget files. +\end{itemize} + +\end{itemize} + +\noindent Determination of which FMI use case to invoke requires careful consideration of the different advantages and disadvantages of each case. For example, running GWE and GWF in the same simulation can often be faster because GWF flows are passed through memory to the GWE model instead of being written to files. The disadvantage of this approach is that the same time step lengths must be used for both GWF and GWE. Ultimately, it should be relatively straightforward to test different ways in which GWF and GWE interact and select the use case most appropriate for the particular problem. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-fmi-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-fmi-packagedata.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-fmi-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-fmi-example.dat} + diff --git a/doc/mf6io/gwe/gwe-gwe.tex b/doc/mf6io/gwe/gwe-gwe.tex new file mode 100644 index 00000000000..7428d6d4af7 --- /dev/null +++ b/doc/mf6io/gwe/gwe-gwe.tex @@ -0,0 +1,45 @@ +Input to the Groundwater Energy Transport (GWE-GWE) Exchange is read from the file that has type ``GWE6-GWE6'' in the Simulation Name File. + +The list of exchanges entered into the EXCHANGEDATA block must be identical to the list of exchanges entered for the GWF-GWF input file. One way to ensure that this information is identical is to put this list into an external file and refer to this same list using the OPEN/CLOSE functionality in both this EXCHANGEDATA input block and the EXCHANGEDATA input block in the GWF-GWF input file. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/exg-gwegwe-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/exg-gwegwe-dimensions.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/exg-gwegwe-exchangedata.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/exg-gwegwe-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/exg-gwegwe-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +GWE-GWE Exchange observations include the simulated flow for any exchange (\texttt{flow-ja-face}). The data required for each GWE-GWE Exchange observation type is defined in table~\ref{table:gwe-gweobstype}. For \texttt{flow-ja-face} observation types, negative and positive values represent a loss from and gain to the first model specified for this exchange. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available GWE-GWE Exchange observation types} \tabularnewline + +\hline +\hline +\textbf{Exchange} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + +\hline +\endfoot + +\input{../Common/gwe-gweobs.tex} +\label{table:gwe-gweobstype} +\end{longtable} + + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/exg-gwegwe-example-obs.dat} + diff --git a/doc/mf6io/gwe/gwe-obs.tex b/doc/mf6io/gwe/gwe-obs.tex new file mode 100644 index 00000000000..a46ca5de597 --- /dev/null +++ b/doc/mf6io/gwe/gwe-obs.tex @@ -0,0 +1,39 @@ + +GWE Model observations include the simulated groundwater temperature (\texttt{temperature}), and the energy flow, with units of energy per time, between two connected cells (\texttt{flow-ja-face}). The data required for each GWE Model observation type is defined in table~\ref{table:gweobstype}. For \texttt{flow-ja-face} observation types, negative and positive values represent a loss from and gain to the \texttt{cellid} specified for ID, respectively. + +\subsubsection{Structure of Blocks} +\vspace{5mm} + +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-obs-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-obs-continuous.dat} + +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/utl-obs-desc.tex} +\end{description} + + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available GWE model observation types} \tabularnewline + +\hline +\hline +\textbf{Model} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + +\hline +\endfoot + +\input{../Common/gwe-obs.tex} +\label{table:gweobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} + +An example GWE Model observation file is shown below. + +\lstinputlisting[style=inputfile]{./mf6ivar/examples/utl-obs-gwe-example.dat} + diff --git a/doc/mf6io/gwe/gwe.tex b/doc/mf6io/gwe/gwe.tex new file mode 100644 index 00000000000..7cd4487ee9a --- /dev/null +++ b/doc/mf6io/gwe/gwe.tex @@ -0,0 +1,155 @@ +Like GWT \citep{modflow6gwt}, the GWE Model simulates three-dimensional transport in flowing groundwater. The primary difference between GWT and GWE is that heat (i.e., temperature), instead of concentration, is the simulated ``species.'' As such, the GWE Model solves the heat transport equation using numerical methods and a generalized control-volume finite-difference approach, which can be used with regular MODFLOW grids (DIS Package) or with unstructured grids (DISV and DISU Packages). The GWE Model is designed to work with most of the new capabilities released with the GWF Model, including the Newton flow formulation, XT3D \citep{modflow6xt3d}, unstructured grids, advanced packages, the movement of water between packages. The GWF and GWE (and, if active, GWT) models operate simultaneously during a \mf simulation to represent coupled groundwater flow and heat transport. The GWE Model can also run separately from a GWF Model by reading the heads and flows saved by a previously run GWF Model. The GWE model is also capable of working with the flows from another groundwater flow model as long as the cell-by-cell and boundary flows and groundwater heads are written to ``linker'' files in the correct format. + +The purpose of the GWE Model is to calculate changes in groundwater temperature in both space and time. Groundwater temperature within an aquifer can change in response to different energy transport processes. These processes include (1) convective (advective) transport of heat with flowing groundwater, (2) the combined hydrodynamic dispersion processes of velocity-dependent mechanical dispersion and conduction (analogous to chemical diffusion), (3) thermal equilibrium with the aquifer matrix, (4) mixing with fluids from groundwater sources and sinks, and (5) direct addition of thermal energy. + +For GWE, the energy present in the aquifer is assumed to instantaneously equilibrate between the aqueous and solid phase domains. For example, a pulse of heat convecting through an aquifer will be retarded through thermal equilibration with the aquifer material. Conversely, the introduction of cold groundwater into a previously warm region of the aquifer will warmup, at least in part, as energy within the aquifer matrix transfers to the aqueous phase. Unlike GWT, the GWE Model type does not support an immobile domain. The energy that is transferred between the aqeous and solid phases of the groundwater system are tracked in the GWE Model budget. + +This section describes the data files for a \mf Groundwater Energy Transport (GWE) Model. A GWE Model is added to the simulation by including a GWE entry in the MODELS block of the simulation name file. There are three types of spatial discretization approaches that can be used with the GWE Model: DIS, DISV, and DISU. The input instructions for these three packages are not described here in this section on GWE Model input; input instructions for these three packages are described in the section on GWF Model input. + +The GWE Model is designed to permit input to be gathered, as it is needed, from many different files. Likewise, results from the model calculations can be written to a number of output files. The GWE Model Listing File is a key file to which the GWE model output is written. As \mf runs, information about the GWE Model is written to the GWE Model Listing File, including much of the input data (as a record of the simulation) and calculated results. Details about the files used by each package are provided in this section. + +The GWE Model reads a file called the Name File, which specifies most of the files that will be used in a groundwater energy transport simulation. Several files are always required whereas other files are optional depending on the question(s) being addressed by the model. The Output Control Package receives instructions from the user to control the amount and frequency of output. Details about the Name File and the Output Control Package are described in this section. + +For the GWE Model, ``flows'' (unless stated otherwise) represent the ``flow'' of energy, often expressed in units of energy (e.g., joules) per time, rather than groundwater flow. + +\subsection{Information for Existing Heat Transport Modelers} +An important goal of the \mf GWE Model is to alleviate the need for ``parameter equivalents'' when simulating heat transport in groundwater systems. In the past, codes like HST3D \citep{kipp1987} or VS2DH \citep{healy1996} simulated energy transport directly by supporting the use of native heat transport units. For example, users could directly specify thermal conductivity of the fluid and solid phases, as well as the heat capacity of both phases. Alternatively, codes like MT3DMS \citep{zheng1999mt3dms}, MT3D-USGS \citep{mt3dusgs}, and MODFLOW-USG \citep{modflowusg} could be used to simulate the movement of heat in groundwater, but required users to leverage existing variables as surrogates for heat transport. For example, the molecular diffusion parameter may be used as a surrogate for simulating thermal conduction in an aquifer \citep{mazheng2010, hechtmendez}. + +The following list summarizes important aspects of GWE for simulating heat transport with \mf: + +\begin{enumerate} + +\item The GWE Model uses parameters that are native to heat transport, including thermal conductivity of water, heat capacity of water, thermal conductivity of the aquifer material, heat capacity of of the aquifer material, and latent heat of vaporization. Therefore, users do not need to pre-calculate ``parameter equivalents'' when generating GWE model input; users can instead enter native parameter values that are readily available. + +\item Thermal energy transport budgets written to the \mf list file are reported in units of energy (e.g., joules). Previously, using a program like MT3D-USGS \citep{mt3dusgs} to simulate heat transport, units in the list file budget did not correspond to thermal energy, but were reported in units of $\frac{m^{3 \;\circ}C}{d}$. To convert to thermal energy units, values in the list file had to be post-processed by multiplying each line item by the density of water ($\rho_w$) and the heat capacity of water ($C_p$) \citep{langevin2008seawat}. + +\item Thermal equilibrium between the aqueous and solid phases is assumed. Thus, simulated temperatures are representive of both phases. As a result, thermal conduction between adjacent cells may still occur even in the absense of convection. + +\item In GWE, dry cells (devoid of groundwater) remain active for simulating thermal conduction. For example, energy (heat) transfer will be simulated between a partially saturated cell (i.e., ``water-table'' cell) and an overlying dry cell. In this way, a more full accounting of various heat transport processes is represented in the subsurface. Moreover, this approach readily supports heat transport in the unsaturated-zone when the UZE (unsaturated-zone energy transport) Package is active. + +\item Heat transport is supported for all five of the advanced GWF packages using the following packages in GWE: (1) streamflow energy transport, SFE Package; (2) lake energy transport, LKE Package; (3) multi-aquifer well energy transport, MWE Package; (4) unsaturated zone energy transport, UZE Package; and the (5) Water Mover Package, MVE. Similar to GWT, GWE will simulate heat transfer between an advanced package and the groundwater system via groundwater surface-water exchange; however, GWE also simulates a conductive transfer of heat between an advanced package feature and the aquifer. To take advantage of this functionality, users must specify the thermal conductivity of the material separating a stream from the aquifer, for example, the thermal conductivity of the streambed (or lakebed), as well as the thickness of the streambed (or lakebed). As with the advanced GWT packages, GWE simulates thermal convection between package features, such as between two stream reaches for example. Also, dispersive heat transport among among advanced package features is not represented, similar to GWT. + +\item Where the GWF model simulates evaporation from an open body of water, for example from the surface of a stream or lake, the latent heat of vaporization may be used to simulate evaporative cooling. As water is converted from liquid to gas, the energy required by the phase change is drawn from the remaining body of water and the resulting cool down is calculated. + +\end{enumerate} + +Many of the same considerations listed for the GWT model should be kept in mind when developing a GWE model. For convenience, many of those considerations are adapted for GWE and repeated here. + +\begin{enumerate} + +\item A GWE Model can access flows calculated by a GWF Model that is running in the same simulation as the GWE Model. Alternatively, a GWE Model can read binary head and budget files created from a previous GWF Model simulation (provided these files contain all of the required information for all time steps); there is no specialized flow and transport link file \citep{zheng2001modflow} as there is for MT3D. Details on these two different use cases are provided in the chapter on the FMI Package. + +\item The GWE Model is based on a generalized control-volume finite-difference method, which means that heat transport can be simulated using regular MODFLOW grids consisting of layers, rows, and columns, or heat transport can be simulated using unstructured grids. + +\item GWE and GWT use the same advection package source code. As a result, advection can be simulated using central-in-space weighting, upstream weighting, or an implicit second-order TVD scheme. Currently, neither the GWE or GWT models can use a Method of Characteristics (particle-based approaches) or an explicit TVD scheme to simulate convective (or advective) transport. Consequently, the GWE Model may require a higher level of spatial discretization than other transport models that use higher order terms for advection dominated systems. This can be an important limitation in problems involving sharp heat fronts. + +\item The Viscosity Package may reference a GWE model directly for adjusting the viscosity-affected groundwater flow. + +\item GWE and GWT use the same Source and Sink Mixing (SSM) Package for representing the effects of GWF stress package inflows and outflows on simulated temperatures and concentrations. In a GWE simulation, there are two ways in which users can assign concentrations to the individual features in these stress package. The first way is to activate a temperature auxiliary variable in the corresponding GWF stress package. In the SSM input file, the user provides the name of the auxiliary variable to be used for temperature. The second way is to create a special SPC file, which contains user-assigned time-varying temperatures for stress package features. + +\item The GWE model includes an MST Package, but does not include an IST Package. Heat transport-related parameters such as thermal conductivities and heat capacities are specified in the MST Package. + +\item A GWE-GWE Exchange (introduced in version 6.5.0) can be used to tightly couple multiple heat transport models, as might be done in a nested grid configuration. + +\item There is no option to automatically run the GWE Model to steady state using a single time step. This is an option available in MT3DMS \citep{zheng2010supplemental}. Steady state conditions must be determined by running the transport model under transient conditions until temperatures stabilize. + +\item As is the case with GWT, the GWE Model has not yet been programmed to work with the Skeletal Storage, Compaction, and Subsidence (CSUB) Package for the GWF Model. + +\item There are many other differences between the \mf GWE Model and other solute transport models that work with MODFLOW, especially with regards to program design and input and output. Descriptions for the GWE input and output are described here. + +\end{enumerate} + +\subsection{Units of Length and Time} +The GWF Model formulates the groundwater flow equation without using prescribed length and time units. Any consistent units of length and time can be used when specifying the input data for a simulation. This capability gives a certain amount of freedom to the user, but care must be exercised to avoid mixing units. The program cannot detect the use of inconsistent units. + +\subsection{Thermal Energy Budget} +A summary of all inflow (sources) and outflow (sinks) of thermal energy is referred to as an energy budget. \mf calculates an energy budget for the overall model as a check on the acceptability of the solution, and to provide a summary of the sources and sinks of energy to the flow system. The energy budget is printed to the GWE Model Listing File for specified time steps. + +\subsection{Time Stepping} + +For the present implementation of the GWE Model, all terms in the heat transport equation are solved implicitly. With the implicit approach applied to the transport equation, it is possible to take relatively large time steps and efficiently obtain a stable solution. If the time steps are too large, however, accuracy of the model results will suffer, so there is usually some compromise required between the desired level of accuracy and length of the time step. An assessment of accuracy can be performed by simply running simulations with shorter time steps and comparing results. + +In \mf time step lengths are controlled by the user and specified in the Temporal Discretization (TDIS) input file. When the flow model and heat transport model are included in the same simulation, then the length of the time step specified in TDIS is used for both models. If the GWE Model runs in a separate simulation from the GWE Model, then the time steps used for the heat transport model can be different, and likely shorter, than the time steps used for the flow solution. Instructions for specifying time steps are described in the TDIS section of this user guide; additional information on GWF and GWE configurations are in the Flow Model Interface section. + + + +\newpage +\subsection{GWT Model Name File} +\input{gwe/namefile.tex} + +%\newpage +%\subsection{Structured Discretization (DIS) Input File} +%\input{gwf/dis} + +%\newpage +%\subsection{Discretization with Vertices (DISV) Input File} +%\input{gwf/disv} + +%\newpage +%\subsection{Unstructured Discretization (DISU) Input File} +%\input{gwf/disu} + +\newpage +\subsection{Initial Conditions (IC) Package} +\input{gwe/ic} + +\newpage +\subsection{Output Control (OC) Option} +\input{gwe/oc} + +\newpage +\subsection{Observation (OBS) Utility for a GWE Model} +\input{gwe/gwe-obs} + +\newpage +\subsection{Advection (ADV) Package} +\input{gwe/adv} + +\newpage +\subsection{Dispersion (DSP) Package} +\input{gwe/dsp} + +\newpage +\subsection{Source and Sink Mixing (SSM) Package} +\input{gwe/ssm} + +\newpage +\subsection{Mobile Storage and Transfer (MST) Package} +\input{gwe/mst} + +\newpage +\subsection{Constant Temperature (CNC) Package} +\input{gwe/cnc} + +\newpage +\subsection{Energy Source Loading (SRC) Package} +\input{gwe/src} + +\newpage +\subsection{Streamflow Energy Transport (SFE) Package} +\input{gwe/sfe} + +\newpage +\subsection{Lake Energy Transport (LKE) Package} +\input{gwe/lke} + +\newpage +\subsection{Multi-Aquifer Well Energy Transport (MWE) Package} +\input{gwe/mwe} + +\newpage +\subsection{Unsaturated Zone Energy Transport (UZE) Package} +\input{gwe/uze} + +\newpage +\subsection{Flow Model Interface (FMI) Package} +\input{gwe/fmi} + +\newpage +\subsection{Mover Energy Transport (MVE) Package} +\input{gwe/mve} + +\newpage +\subsection{Groundwater Energy Transport (GWE) Exchange} +\input{gwe/gwe-gwe} + diff --git a/doc/mf6io/gwe/ic.tex b/doc/mf6io/gwe/ic.tex new file mode 100644 index 00000000000..aa9c1accaad --- /dev/null +++ b/doc/mf6io/gwe/ic.tex @@ -0,0 +1,17 @@ +Initial Conditions (IC) Package information is read from the file that is specified by ``IC6'' as the file type. Only one IC Package can be specified for a GWE model. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +%\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-ic-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-ic-griddata.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-ic-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-ic-example.dat} + diff --git a/doc/mf6io/gwe/lke.tex b/doc/mf6io/gwe/lke.tex new file mode 100644 index 00000000000..4b9e28581c5 --- /dev/null +++ b/doc/mf6io/gwe/lke.tex @@ -0,0 +1,55 @@ +Lake Energy Transport (LKE) Package information is read from the file that is specified by ``LKE6'' as the file type. There can be as many LKE Packages as necessary for a GWE model. Each LKE Package is designed to work with flows from a single corresponding GWF LAK Package. By default \mf uses the LKE package name to determine which LAK Package corresponds to the LKE Package. Therefore, the package name of the LKE Package (as specified in the GWE name file) must match with the name of the corresponding LAK Package (as specified in the GWF name file). Alternatively, the name of the flow package can be specified using the FLOW\_PACKAGE\_NAME keyword in the options block. The GWE LKE Package cannot be used without a corresponding GWF LAK Package. + +The LKE Package does not have a dimensions block; instead, dimensions for the LKE Package are set using the dimensions from the corresponding LAK Package. For example, the LAK Package requires specification of the number of lakes (NLAKES). LKE sets the number of lakes equal to NLAKES. Therefore, the PACKAGEDATA block below must have NLAKES entries in it. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-lke-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-lke-packagedata.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-lke-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-lke-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-lke-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +Lake Energy Transport Package observations include lake temperature and all of the terms that contribute to the continuity equation for each lake. Additional LKE Package observations include energy flow rates for individual outlets, lakes, or groups of lakes (\texttt{outlet}). The data required for each LKE Package observation type is defined in table~\ref{table:gwe-lkeobstype}. Negative and positive values for \texttt{lke} observations represent a loss from and gain to the GWE model, respectively. For all other flow terms, negative and positive values represent a loss from and gain from the LKE package, respectively. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available LKE Package observation types} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endfirsthead + +\captionsetup{textformat=simple} +\caption*{\textbf{Table \arabic{table}.}{\quad}Available LKE Package observation types.---Continued} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + + +\hline +\endfoot + +\input{../Common/gwe-lkeobs.tex} +\label{table:gwe-lkeobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-lke-example-obs.dat} + + diff --git a/doc/mf6io/gwe/mst.tex b/doc/mf6io/gwe/mst.tex new file mode 100644 index 00000000000..283e3febead --- /dev/null +++ b/doc/mf6io/gwe/mst.tex @@ -0,0 +1,17 @@ +Mobile Storage and Transfer (MST) Package information is read from the file that is specified by ``MST6'' as the file type. Only one MST Package can be specified for a GWE model. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-mst-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-mst-griddata.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-mst-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-mst-example.dat} + diff --git a/doc/mf6io/gwe/mve.tex b/doc/mf6io/gwe/mve.tex new file mode 100644 index 00000000000..8b4330d98df --- /dev/null +++ b/doc/mf6io/gwe/mve.tex @@ -0,0 +1,18 @@ +Mover Energy Transport (MVT) Package information is read from the file that is specified by ``MVE6'' as the file type. Only one MVE Package can be specified for a GWE model. + +The MVE Package is used to route thermal energy according to flows from the GWF Water Mover (MVR) Package. This MVE Package must be activated by the user if the MVR Package was active for the GWF Model. Flows from the GWF MVR Package must be available to the GWE model either through activation of a GWF-GWE Exchange or through specification of ``GWFMOVER'' in the PACKAGEDATA block of the GWE FMI Package. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-mve-options.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-mve-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-mve-example.dat} + diff --git a/doc/mf6io/gwe/mwe.tex b/doc/mf6io/gwe/mwe.tex new file mode 100644 index 00000000000..70fc673987d --- /dev/null +++ b/doc/mf6io/gwe/mwe.tex @@ -0,0 +1,55 @@ +Multi-Aquifer Well Energy Transport (MWE) Package information is read from the file that is specified by ``MWE6'' as the file type. There can be as many MWE Packages as necessary for a GWE model. Each MWE Package is designed to work with flows from a corresponding GWF MAW Package. By default \mf uses the MWE package name to determine which MAW Package corresponds to the MWE Package. Therefore, the package name of the MWE Package (as specified in the GWE name file) must match with the name of the corresponding MAW Package (as specified in the GWF name file). Alternatively, the name of the flow package can be specified using the FLOW\_PACKAGE\_NAME keyword in the options block. The GWE MWE Package cannot be used without a corresponding GWF MAW Package. + +The MWE Package does not have a dimensions block; instead, dimensions for the MWE Package are set using the dimensions from the corresponding MAW Package. For example, the MAW Package requires specification of the number of wells (NMAWWELLS). MWE sets the number of wells equal to NMAWWELLS. Therefore, the PACKAGEDATA block below must have NMAWWELLS entries in it. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-mwe-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-mwe-packagedata.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-mwe-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-mwe-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-mwe-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +Multi-Aquifer Well Energy Transport Package observations include well temperature and all of the terms that contribute to the continuity equation for each well. Additional MWE Package observations include energy flow rates for individual wells, or groups of wells; the well volume (\texttt{volume}); and the conductance for a well-aquifer connection conductance (\texttt{conductance}). The data required for each MWE Package observation type is defined in table~\ref{table:gwe-mweobstype}. Negative and positive values for \texttt{mwe} observations represent a loss from and gain to the GWE model, respectively. For all other flow terms, negative and positive values represent a loss from and gain from the MWE package, respectively. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available MWE Package observation types} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endfirsthead + +\captionsetup{textformat=simple} +\caption*{\textbf{Table \arabic{table}.}{\quad}Available MWE Package observation types.---Continued} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + + +\hline +\endfoot + +\input{../Common/gwe-mweobs.tex} +\label{table:gwe-mweobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-mwe-example-obs.dat} + + diff --git a/doc/mf6io/gwe/namefile.tex b/doc/mf6io/gwe/namefile.tex new file mode 100644 index 00000000000..030cb8972cd --- /dev/null +++ b/doc/mf6io/gwe/namefile.tex @@ -0,0 +1,53 @@ +The GWE Model Name File specifies the options and packages that are active for a GWE model. The Name File contains two blocks: OPTIONS and PACKAGES. The length of each line must be 299 characters or less. The lines in each block can be in any order. Files listed in the PACKAGES block must exist when the program starts. + +Comment lines are indicated when the first character in a line is one of the valid comment characters. Commented lines can be located anywhere in the file. Any text characters can follow the comment character. Comment lines have no effect on the simulation; their purpose is to allow users to provide documentation about a particular simulation. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-nam-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-nam-packages.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-nam-desc.tex} +\end{description} + +\begin{table}[H] +\caption{Ftype values described in this report. The \texttt{Pname} column indicates whether or not a package name can be provided in the name file. The capability to provide a package name also indicates that the GWE Model can have more than one package of that Ftype} +\small +\begin{center} +\begin{tabular*}{\columnwidth}{l l l} +\hline +\hline +Ftype & Input File Description & \texttt{Pname}\\ +\hline +DIS6 & Rectilinear Discretization Input File \\ +DISV6 & Discretization by Vertices Input File \\ +DISU6 & Unstructured Discretization Input File \\ +FMI6 & Flow Model Interface Package & \\ +IC6 & Initial Conditions Package \\ +OC6 & Output Control Option \\ +ADV6 & Advection Package \\ +DSP6 & Dispersion Package \\ +SSM6 & Source and Sink Mixing Package \\ +MST6 & Mobile Storage and Transfer Package \\ +CNC6 & Constant Temperature Package & * \\ +SRC6 & Energy Source Loading Package & * \\ +LKE6 & Lake Energy Transport Package & * \\ +SFE6 & Streamflow Energy Transport Package & * \\ +MWE6 & Multi-Aquifer Well Energy Transport Package & * \\ +UZE6 & Unsaturated Zone Energy Transport Package & * \\ +MVE6 & Mover Energy Transport Package \\ +OBS6 & Observations Option \\ +\hline +\end{tabular*} +\label{table:ftype} +\end{center} +\normalsize +\end{table} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwt-nam-example.dat} + diff --git a/doc/mf6io/gwe/oc.tex b/doc/mf6io/gwe/oc.tex new file mode 100644 index 00000000000..d534a14eb08 --- /dev/null +++ b/doc/mf6io/gwe/oc.tex @@ -0,0 +1,25 @@ +Input to the Output Control Option of the Groundwater Energy Transport Model is read from the file that is specified as type ``OC6'' in the Name File. If no ``OC6'' file is specified, default output control is used. The Output Control Option determines how and when temperatures are printed to the listing file and/or written to a separate binary output file. Under the default, temperature and the overall energy transport budget are written to the Listing File at the end of every stress period. The default printout format for temperatures is 10G11.4. The temperatures and overall energy transport budget are also written to the list file if the simulation terminates prematurely due to failed convergence. + +Output Control data must be specified using words. The numeric codes supported in earlier MODFLOW versions can no longer be used. + +For the PRINT and SAVE options of temperature, there is no option to specify individual layers. Whenever the temperature array is printed or saved, all layers are printed or saved. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\vspace{5mm} + +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-oc-options.dat} +\vspace{5mm} +\noindent \textit{FOR ANY STRESS PERIOD} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-oc-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-oc-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-oc-example.dat} diff --git a/doc/mf6io/gwe/sfe.tex b/doc/mf6io/gwe/sfe.tex new file mode 100644 index 00000000000..4f1e5fca4db --- /dev/null +++ b/doc/mf6io/gwe/sfe.tex @@ -0,0 +1,55 @@ +Streamflow Energy Transport (SFE) Package information is read from the file that is specified by ``SFE6'' as the file type. There can be as many SFE Packages as necessary for a GWE model. Each SFE Package is designed to work with flows from a corresponding GWF SFR Package. By default \mf uses the SFE package name to determine which SFR Package corresponds to the SFE Package. Therefore, the package name of the SFE Package (as specified in the GWE name file) must match with the name of the corresponding SFR Package (as specified in the GWF name file). Alternatively, the name of the flow package can be specified using the FLOW\_PACKAGE\_NAME keyword in the options block. The GWE SFE Package cannot be used without a corresponding GWF SFR Package. + +The SFE Package does not have a dimensions block; instead, dimensions for the SFE Package are set using the dimensions from the corresponding SFR Package. For example, the SFR Package requires specification of the number of reaches (NREACHES). SFE sets the number of reaches equal to NREACHES. Therefore, the PACKAGEDATA block below must have NREACHES entries in it. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-sfe-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-sfe-packagedata.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-sfe-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-sfe-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-sfe-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +Streamflow Energy Transport Package observations include reach temperature and all of the terms that contribute to the continuity equation for each reach. Additional SFE Package observations include energy flow rates for individual reaches, or groups of reaches. The data required for each SFE Package observation type is defined in table~\ref{table:gwe-sfeobstype}. Negative and positive values for \texttt{sfe} observations represent a loss from and gain to the GWE model, respectively. For all other flow terms, negative and positive values represent a loss from and gain from the SFE package, respectively. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available SFE Package observation types} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endfirsthead + +\captionsetup{textformat=simple} +\caption*{\textbf{Table \arabic{table}.}{\quad}Available SFE Package observation types.---Continued} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + + +\hline +\endfoot + +\input{../Common/gwe-sfeobs.tex} +\label{table:gwe-sfeobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-sfe-example-obs.dat} + + diff --git a/doc/mf6io/gwe/src.tex b/doc/mf6io/gwe/src.tex new file mode 100644 index 00000000000..54c425d5890 --- /dev/null +++ b/doc/mf6io/gwe/src.tex @@ -0,0 +1,47 @@ +Input to the Energy Source Loading (SRC) Package is read from the file that has type ``SRC6'' in the Name File. Any number of SRC Packages can be specified for a single groundwater energy transport model. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\vspace{5mm} + +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-src-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-src-dimensions.dat} +\vspace{5mm} +\noindent \textit{FOR ANY STRESS PERIOD} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-src-period.dat} +\packageperioddescription + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-src-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-src-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +Energy Source Loading Package observations include the simulated source loading rates (\texttt{src}). The data required for each SRC Package observation type is defined in table~\ref{table:gwe-srcobstype}. The \texttt{src} observation is equal to the simulated energy source loading rate. Negative and positive values for an observation represent a loss from and gain to the GWE model, respectively. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available SRC Package observation types} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + +\hline +\endfoot + +\input{../Common/gwe-srcobs.tex} +\label{table:gwe-srcobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-src-example-obs.dat} diff --git a/doc/mf6io/gwe/ssm.tex b/doc/mf6io/gwe/ssm.tex new file mode 100644 index 00000000000..2489f0122b4 --- /dev/null +++ b/doc/mf6io/gwe/ssm.tex @@ -0,0 +1,114 @@ +Source and Sink Mixing (SSM) Package information is read from the file that is specified by ``SSM6'' as the file type. Only one SSM Package can be specified for a GWE model. The SSM Package is required if the flow model has any stress packages. + +The SSM Package is used to add or remove thermal energy from GWE model cells based on inflows and outflows from GWF stress packages. If a GWF stress package provides flow into a model cell, that flow can be assigned a user-specified temperature. If a GWF stress package removes water from a model cell, the temperature of that water is the temperature of the cell from which the water is removed. For flow boundary conditions that include evapotranspiration, the latent heat of vaporization may be used to represent evaporative cooling. There are several different ways for the user to specify the temperatures. + +\begin{itemize} +\item The default condition is that sources have a temperature of zero and sinks withdraw water at the calculated temperature of the cell. This default condition is assigned to any GWF stress package that is not included in a SOURCES block or FILEINPUT block. +\item A second option is to assign auxiliary variables in the GWF model and include a temperature for each stress boundary. In this case, the user provides the name of the package and the name of the auxiliary variable containing temperature values for each boundary. As described below for srctype, there are multiple options for defining this behavior. +\item A third option is to prepare an SPC6 file for any desired GWF stress package. This SPC6 file allows users to change temperatures by stress period, or to use the time-series option to interpolate temperatures by time step. This third option was introduced in MODFLOW version 6.3.0. Information for this approach is entered in an optional FILEINPUT block below. The SPC6 input file supports list-based temperature input for most corresponding GWF stress packages, but also supports a READASARRAYS array-based input format if a corresponding GWF recharge or evapotranspiration package uses the READASARRAYS option. +\end{itemize} + +\noindent The auxiliary method and the SPC6 file input method can both be used for a GWE model, but only one approach can be assigned per GWF stress package. If a flow package specified in the SOURCES or FILEINPUT blocks is also represented using an advanced transport package (SFE, LKE, MWE, or UZE), then the advanced transport package will override SSM calculations for that package. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-ssm-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-ssm-sources.dat} +\vspace{5mm} +\noindent \textit{FILEINPUT BLOCK IS OPTIONAL} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-ssm-fileinput.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-ssm-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-ssm-example.dat} + +% when obs are ready, they should go here + +\newpage +\subsection{Stress Package Concentrations (SPC) -- List-Based Input} +As mentioned in the previous section on the SSM Package, temperatures can be specified for GWF stress packages using auxiliary variables, or they can be specified using input files dedicated to this purpose. The Stress Package Concentrations (SPC) input file can be used to provide concentrations (temperatures) that are assigned for GWF sources and sinks. An SPC input file can be list based or array based. List-based input files can be used for list-based GWF stress packages, such as wells, drains, and rivers. Array-based input files can be used for array-based GWF stress packages, such as recharge and evapotranspiration (provided the READASARRAYS options is used; these packages can also be provided in a list-based format). Array-based SPC input files are discussed in the next section. This section describes the list-based input format for the SPC input file. + +An SPC6 file can be prepared to provide user-specified temperatures for a GWF stress package, such a Well or General-Head Boundary Package, for example. One SPC6 file applies to one GWF stress package. Names for the SPC6 input files are provided in the FILEINPUT block of the SSM Package. SPC6 entries cannot be specified in the GWE name file. Use of the SPC6 input file is an alternative to specifying stress package temperatures as auxiliary variables in the flow model stress package. + +The boundary number in the PERIOD block corresponds to the boundary number in the GWF stress period package. Assignment of the boundary number is straightforward for the advanced packages (SFR, LAK, MAW, and UZF) because the features in these advanced packages are defined once at the beginning of the simulation and they do not change. For the other stress packages, however, the order of boundaries may change between stress periods. Consider the following Well Package input file, for example: + +\begin{verbatim} +# This is an example of a GWF Well Package +# in which the order of the wells changes from +# stress period 1 to 2. This must be explicitly +# handled by the user if using the SPC6 input +# for a GWE model. +BEGIN options + BOUNDNAMES +END options + +BEGIN dimensions + MAXBOUND 3 +END dimensions + +BEGIN period 1 + 1 77 65 -2200 SHALLOW_WELL + 2 77 65 -24.0 INTERMEDIATE_WELL + 3 77 65 -6.20 DEEP_WELL +END period + +BEGIN period 2 + 1 77 65 -1100 SHALLOW_WELL + 3 77 65 -3.10 DEEP_WELL + 2 77 65 -12.0 INTERMEDIATE_WELL +END period +\end{verbatim} + +\noindent In this Well input file, the order of the wells changed between periods 1 and 2. This reordering must be explicitly taken into account by the user when creating an SSMI6 file, because the boundary number in the SSMI file corresponds to the boundary number in the Well input file. In stress period 1, boundary number 2 is the INTERMEDIATE\_WELL, whereas in stress period 2, boundary number 2 is the DEEP\_WELL. When using this SSMI capability to specify boundary temperatures, it is recommended that users write the corresponding GWF stress packages using the same number, cell locations, and order of boundary conditions for each stress period. In addition, users can activate the PRINT\_FLOWS option in the SSM input file. When the SSM Package prints the individual solute flows to the transport list file, it includes a column containing the boundary temperature. Users can check the boundary temperatures in this output to verify that they are assigned as intended. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\vspace{5mm} + +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-spc-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-spc-dimensions.dat} +\vspace{5mm} +\noindent \textit{FOR ANY STRESS PERIOD} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-spc-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/utl-spc-desc.tex} +\end{description} + +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/utl-spc-example.dat} + +% SPC array based +\newpage +\subsection{Stress Package Concentrations (SPC) -- Array-Based Input} + +This section describes array-based input for the SPC input file. If the READASARRAYS options is specified for either the GWF Recharge (RCH) or Evapotranspiration (EVT) Packages, then concentrations (temperatures) for these packages can be specified using array-based temperature input. This SPC array-based input is distinguished from the list-based input in the previous section through specification of the READASARRAYS option. When the READASARRAYS option is specified, then there is no DIMENSIONS block in the SPC input file. Instead, the shape of the array for temperatures is the number of rows by number of columns (NROW, NCOL), for a regular MODFLOW grid (DIS), and the number of cells in a layer (NCPL) for a discretization by vertices (DISV) grid. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\vspace{5mm} + +\noindent \textit{FOR EACH SIMULATION} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-spca-options.dat} +\vspace{5mm} +\noindent \textit{FOR ANY STRESS PERIOD} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/utl-spca-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/utl-spca-desc.tex} +\end{description} + +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/utl-spca-example.dat} + diff --git a/doc/mf6io/gwe/uze.tex b/doc/mf6io/gwe/uze.tex new file mode 100644 index 00000000000..1e65d5bbd11 --- /dev/null +++ b/doc/mf6io/gwe/uze.tex @@ -0,0 +1,55 @@ +Unsaturated Zone Energy Transport (UZE) Package information is read from the file that is specified by ``UZE6'' as the file type. There can be as many UZE Packages as necessary for a GWE model. Each UZE Package is designed to work with flows from a corresponding GWF UZF Package. By default \mf uses the UZE package name to determine which UZF Package corresponds to the UZE Package. Therefore, the package name of the UZE Package (as specified in the GWE name file) must match with the name of the corresponding UZF Package (as specified in the GWF name file). Alternatively, the name of the flow package can be specified using the FLOW\_PACKAGE\_NAME keyword in the options block. The GWE UZE Package cannot be used without a corresponding GWF UZF Package. + +The UZE Package does not have a dimensions block; instead, dimensions for the UZE Package are set using the dimensions from the corresponding UZF Package. For example, the UZF Package requires specification of the number of cells (NUZFCELLS). UZE sets the number of UZE cells equal to NUZFCELLS. Therefore, the PACKAGEDATA block below must have NUZFCELLS entries in it. + +\vspace{5mm} +\subsubsection{Structure of Blocks} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-uze-options.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-uze-packagedata.dat} +\lstinputlisting[style=blockdefinition]{./mf6ivar/tex/gwe-uze-period.dat} + +\vspace{5mm} +\subsubsection{Explanation of Variables} +\begin{description} +\input{./mf6ivar/tex/gwe-uze-desc.tex} +\end{description} + +\vspace{5mm} +\subsubsection{Example Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-uze-example.dat} + +\vspace{5mm} +\subsubsection{Available observation types} +Unsaturated Zone Energy Transport Package observations include UZF cell temperature and all of the terms that contribute to the continuity equation for each UZF cell. Additional UZE Package observations include energy flow rates for individual UZF cells, or groups of UZF cells. The data required for each UZE Package observation type is defined in table~\ref{table:gwe-uzeobstype}. Negative and positive values for \texttt{uzt} observations represent a loss from and gain to the GWE model, respectively. For all other flow terms, negative and positive values represent a loss from and gain from the UZE package, respectively. + +\begin{longtable}{p{2cm} p{2.75cm} p{2cm} p{1.25cm} p{7cm}} +\caption{Available UZE Package observation types} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endfirsthead + +\captionsetup{textformat=simple} +\caption*{\textbf{Table \arabic{table}.}{\quad}Available UZE Package observation types.---Continued} \tabularnewline + +\hline +\hline +\textbf{Stress Package} & \textbf{Observation type} & \textbf{ID} & \textbf{ID2} & \textbf{Description} \\ +\hline +\endhead + + +\hline +\endfoot + +\input{../Common/gwe-uzeobs.tex} +\label{table:gwe-uzeobstype} +\end{longtable} + +\vspace{5mm} +\subsubsection{Example Observation Input File} +\lstinputlisting[style=inputfile]{./mf6ivar/examples/gwe-uze-example-obs.dat} + + diff --git a/doc/mf6io/mf6io.bbl b/doc/mf6io/mf6io.bbl index e69de29bb2d..9a3a5427419 100644 --- a/doc/mf6io/mf6io.bbl +++ b/doc/mf6io/mf6io.bbl @@ -0,0 +1,289 @@ +\begin{thebibliography}{41} +\providecommand{\natexlab}[1]{#1} +\expandafter\ifx\csname urlstyle\endcsname\relax + \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else + \providecommand{\doi}{doi:\discretionary{}{}{}\begingroup + \urlstyle{rm}\Url}\fi + +\bibitem[{Anderman and Hill(2000)}]{anderman2000modflow} +Anderman, E.R., and Hill, M.C., 2000, MODFLOW-2000, the U.S. Geological Survey + modular ground-water model-documentation of the Hydrogeologic-Unit Flow (HUF) + Package: {U.S. Geological Survey Open-File Report 2000--342, 89 p.} + +\bibitem[{Anderman and Hill(2003)}]{anderman2003modflow} +Anderman, E.R., and Hill, M.C., 2003, MODFLOW-2000, the U.S. Geological Survey + modular ground-water model---Three additions to the Hydrogeologic-Unit Flow + (HUF) Package: Alternative storage for the uppermost active cells, flows in + hydrogeologic units, and the hydraulic-conductivity depth-dependence (KDEP) + capability: {U.S. Geological Survey Open-File Report 2003--347, 36 p.} + +\bibitem[{Bakker and others(2013)Bakker, Schaars, Hughes, Langevin, and + Dausman}]{bakker2013documentation} +Bakker, Mark, Schaars, Frans, Hughes, J.D., Langevin, C.D., and Dausman, A.M., + 2013, Documentation of the seawater intrusion (SWI2) package for MODFLOW: + {U.S. Geological Survey Techniques and Methods, book 6, chap. A46, 47 p.}, + accessed June 27, 2017, at \url{https://pubs.er.usgs.gov/publication/tm6A46}. + +\bibitem[{Banta(2000)}]{modflowdrtpack} +Banta, E.R., 2000, MODFLOW-2000, the U.S. Geological Survey Modular + Ground-Water Model; documentation of packages for simulating + evapotranspiration with a segmented function (ETS1) and drains with return + flow (DRT1): {U.S. Geological Survey Open File Report 2000--466, 127 p}. + +\bibitem[{Banta(2011)}]{banta2011modflow} +Banta, E.R., 2011, MODFLOW-CDSS, a version of MODFLOW-2005 with modifications + for Colorado Decision Support Systems: {U.S. Geological Survey Open-File + Report 2011--1213, 19 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/ofr20111213}. + +\bibitem[{Bedekar and others(2016)Bedekar, Morway, Langevin, and + Tonkin}]{mt3dusgs} +Bedekar, Vivek, Morway, E.D., Langevin, C.D., and Tonkin, M.J., 2016, MT3D-USGS + version 1: A U.S. Geological Survey release of MT3DMS updated with new and + expanded transport capabilities for use with MODFLOW: {U.S. Geological Survey + Techniques and Methods, book 6, chap. A53, 69 p.}, + \url{https://doi.org/10.3133/tm6a53}, \url{http://dx.doi.org/10.3133/tm6A53}. + +\bibitem[{Fenske and others(1996)Fenske, Leake, and + Prudic}]{fenske1996documentation} +Fenske, J.P., Leake, S.A., and Prudic, D.E., 1996, Documentation of a computer + program (RES1) to simulate leakage from reservoirs using the modular + finite-difference ground-water flow model (MODFLOW): {U.S. Geological Survey + Open-File Report 96--364, 51 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/ofr96364}. + +\bibitem[{Halford and Hanson(2002)}]{halford2002} +Halford, K.J., and Hanson, R.T., 2002, User guide for the drawdown-limited, + multi-node well (MNW) package for the U.S. Geological Survey's modular + three-dimensional finite-difference ground-water flow model, versions + MODFLOW-96 and MODFLOW-2000: {U.S. Geological Survey Open-File Report + 02--293, 33 p.} + +\bibitem[{Hanson and Leake(1999)}]{hanson1999documentation} +Hanson, R.T., and Leake, S.A., 1999, Documentation for HYDMOD---A program for + extracting and processing time-series data from the U.S. Geological Survey's + modular three-dimensional finite-difference ground-water flow model: {U.S. + Geological Survey Open-File Report 98--564, 57 p.}, accessed June 27, 2017, + at \url{https://pubs.er.usgs.gov/publication/ofr98564}. + +\bibitem[{Harbaugh(2005)}]{modflow2005} +Harbaugh, A.W., 2005, MODFLOW-2005, the U.S. Geological Survey modular + ground-water model---the Ground-Water Flow Process: {U.S. Geological Survey + Techniques and Methods, book 6, chap. A16, variously paged}, accessed June + 27, 2017, at \url{https://pubs.usgs.gov/tm/2005/tm6A16/}. + +\bibitem[{Healy and Ronan(1996)}]{healy1996} +Healy, R.W., and Ronan, A.D., 1996, Documentation of Computer Program VS2DH for + Simulation of Energy Transport in Variably Saturated Porous Media: + Modification of the U.S. Geological Survey's Computer Program VS2DT: {U.S. + Geological Survey Water-Resources Investigation Report 96-4230, 36 p.}, + accessed September 27, 2022, at \url{https://doi.org/10.3133/wri964230}, at + \url{https://pubs.usgs.gov/wri/1996/4230/report.pdf}. + +\bibitem[{Hecht-Mendez and others(2010)Hecht-Mendez, Molina-Giraldo, Blum, and + Bayer}]{hechtmendez} +Hecht-Mendez, J., Molina-Giraldo, N., Blum, P., and Bayer, P., 2010, Evaluating + mt3dms for heat transport simulation of closed geothermal systems: + Groundwater, v.~48, no.~5, p.~741--756, + \url{https://doi.org/10.1111/j.1745-6584.2010.00678.x}. + +\bibitem[{Hill(1990)}]{hill1990preconditioned} +Hill, M.C., 1990, Preconditioned Conjugate-Gradient 2 (PCG2), a computer + program for solving ground-water flow equations: {U.S. Geological Survey + Water-Resources Investigations Report 90--4048, 25 p.}, accessed June 27, + 2017, at \url{https://pubs.usgs.gov/wri/wrir_90-4048}. + +\bibitem[{Hill and others(2000)Hill, Banta, Harbaugh, and + Anderman}]{hill2000modflow} +Hill, M.C., Banta, E.R., Harbaugh, A.W., and Anderman, E.R., 2000, + MODFLOW-2000, the U.S. Geological Survey modular ground-water model---User + guide to the observation, sensitivity, and parameter-estimation processes and + three post-processing programs: {U.S. Geological Survey Open-File Report + 00--184, 210 p.} + +\bibitem[{Hoffmann and others(2003)Hoffmann, Leake, Galloway, and + Wilson}]{hoffmann2003modflow} +Hoffmann, J{\"o}rn, Leake, S.A., Galloway, D.L., and Wilson, A.M., 2003, + MODFLOW-2000 Ground-Water Model---User Guide to the Subsidence and + Aquifer-System Compaction (SUB) Package: {U.S. Geological Survey Open-File + Report 03--233, 44 p.}, accessed June 27, 2017, at + \url{https://pubs.usgs.gov/of/2003/ofr03-233/}. + +\bibitem[{Hsieh and Freckleton(1993)}]{hsieh1993hfb} +Hsieh, P.A., and Freckleton, J.R., 1993, Documentation of a computer program to + simulate horizontal-flow barriers using the U.S. Geological Survey's modular + three-dimensional finite-difference ground-water flow model: {U.S. Geological + Survey Open-File Report 92--477, 32 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/ofr92477}. + +\bibitem[{Hughes and others(2012)Hughes, Langevin, Chartier, and + White}]{hughes2012documentation} +Hughes, J.D., Langevin, C.D., Chartier, K.L., and White, J.T., 2012, + Documentation of the Surface-Water Routing (SWR1) Process for modeling + surface-water flow with the U.S. Geological Survey modular groundwater model + (MODFLOW-2005): {U.S. Geological Survey Techniques and Methods, book 6, chap. + A40 (Version 1.0), 113 p.}, accessed June 27, 2017, at + \url{https://pubs.usgs.gov/tm/6a40/}. + +\bibitem[{Hughes and others(2017)Hughes, Langevin, and + Banta}]{modflow6framework} +Hughes, J.D., Langevin, C.D., and Banta, E.R., 2017, Documentation for the + MODFLOW 6 framework: {U.S. Geological Survey Techniques and Methods, book 6, + chap. A57, 36 p.}, \url{https://doi.org/10.3133/tm6A57}. + +\bibitem[{Hughes and others(2022{\natexlab{a}})Hughes, Russcher, Langevin, + Morway, and McDonald}]{modflow6api} +Hughes, J.D., Russcher, M.J., Langevin, C.D., Morway, E.D., and McDonald, R.R., + 2022{\natexlab{a}}, The {MODFLOW Application Programming Interface} for + simulation control and software interoperability: Environmental Modelling \& + Software, v. 148, 105257, + \url{https://doi.org/10.1016/j.envsoft.2021.105257}. + +\bibitem[{Hughes and others(2022{\natexlab{b}})Hughes, Leake, Galloway, and + White}]{modflow6csub} +Hughes, J.D., Leake, S.A., Galloway, D.L., and White, J.T., 2022{\natexlab{b}}, + Documentation for the Skeletal Storage, Compaction, and Subsidence (CSUB) + Package of MODFLOW 6: {U.S. Geological Survey Techniques and Methods, book 6, + chap. A62, 57 p.}, \url{https://doi.org/10.3133/tm6A62}. + +\bibitem[{Kipp(1987)}]{kipp1987} +Kipp, K.L., 1987, HST3D: A Computer Code for Simulation of Heat and Solute + Transport in Three-Dimensional Ground-Water Flow Systems: {U.S. Geological + Survey Water-Resources Investigation Report 86-4095, 517 p.}, accessed + September 27, 2022, at \url{https://pubs.usgs.gov/wri/1986/4095/report.pdf}. + +\bibitem[{Konikow and others(2009)Konikow, Hornberger, Halford, and + Hanson}]{konikow2009} +Konikow, L.F., Hornberger, G.Z., Halford, K.J., and Hanson, R.T., 2009, Revised + multi-node well (MNW2) package for MODFLOW ground-water flow model: {U.S. + Geological Survey Techniques and Methods, book 6, chap. A30, 67 p.}, accessed + June 27, 2017, at \url{https://pubs.usgs.gov/tm/tm6a30/}. + +\bibitem[{Langevin and others(2008)Langevin, Thorne~Jr, Dausman, Sukop, and + Guo}]{langevin2008seawat} +Langevin, C.D., Thorne~Jr, D.T., Dausman, A.M., Sukop, M.C., and Guo, Weixing, + 2008, {SEAWAT} Version 4---A computer program for simulation of multi-species + solute and heat transport: {U.S. Geological Survey Techniques and Methods, + book 6, chap. A22, 39 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/tm6A22}. + +\bibitem[{Langevin and others(2017)Langevin, Hughes, Provost, Banta, Niswonger, + and Panday}]{modflow6gwf} +Langevin, C.D., Hughes, J.D., Provost, A.M., Banta, E.R., Niswonger, R.G., and + Panday, Sorab, 2017, Documentation for the MODFLOW 6 Groundwater Flow (GWF) + Model: {U.S. Geological Survey Techniques and Methods, book 6, chap. A55, 197 + p.}, \url{https://doi.org/10.3133/tm6A55}. + +\bibitem[{Langevin and others(2020)Langevin, Panday, and + Provost}]{langevin2020hydraulic} +Langevin, C.D., Panday, Sorab, and Provost, A.M., 2020, Hydraulic-head + formulation for density-dependent flow and transport: Groundwater, v.~58, + no.~3, p.~349--362. + +\bibitem[{Langevin and others(2022)Langevin, Provost, Panday, and + Hughes}]{modflow6gwt} +Langevin, C.D., Provost, A.M., Panday, Sorab, and Hughes, J.D., 2022, + Documentation for the MODFLOW 6 Groundwater Transport (GWT) Model: {U.S. + Geological Survey Techniques and Methods, book 6, chap. A61, 56 p.}, + \url{https://doi.org/10.3133/tm6A61}. + +\bibitem[{Leake and Galloway(2007)}]{leake2007modflow} +Leake, S.A., and Galloway, D.L., 2007, MODFLOW Ground-water model---User guide + to the Subsidence and Aquifer-System Compaction Package (SUB-WT) for + Water-Table Aquifers: {U.S. Geological Survey Techniques and Methods, book 6, + chap. A23, 42 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/tm6A23}. + +\bibitem[{Leake and Lilly(1997)}]{leake1997documentation} +Leake, S.A., and Lilly, M.R., 1997, Documentation of computer program (FHB1) + for assignment of transient specified-flow and specified-head boundaries in + applications of the modular finite-diference ground-water flow model + (MODFLOW): {U.S. Geological Survey Open-File Report 97--571, 50 p.}, accessed + June 27, 2017, at \url{https://pubs.er.usgs.gov/publication/ofr97571}. + +\bibitem[{Ma and Zheng(2010)}]{mazheng2010} +Ma, Rui, and Zheng, Chunmiao, 2010, Effects of density and viscosity in + modeling heat as a groundwater tracer: Groundwater, v.~48, no.~3, + p.~380--389, \url{https://doi.org/10.1111/j.1745-6584.2009.00660.x}. + +\bibitem[{Maddock and others(2012)Maddock, Baird, Hanson, Schmid, and + Ajami}]{modflowripetpack} +Maddock, Thomas, III, Baird, K.J., Hanson, R.T., Schmid, Wolfgang, and Ajami, + Hoori, 2012, RIP-ET---A Riparian Evapotranspiration Package for MODFLOW-2005: + {U.S. Geological Survey Techniques and Methods, book 6, chap. A39, 76 p.}, + accessed June 27, 2017, at \url{https://pubs.usgs.gov/tm/tm6a39/}. + +\bibitem[{Merritt and Konikow(2000)}]{modflowlak3pack} +Merritt, M.L., and Konikow, L.F., 2000, Documentation of a computer program to + simulate lake-aquifer interaction using the MODFLOW ground-water flow model + and the MOC3D solute-transport model: {U.S. Geological Survey Water-Resources + Investigations Report 00--4167, 146 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/wri004167}. + +\bibitem[{Niswonger and Prudic(2005)}]{modflowsfr2pack} +Niswonger, R.G., and Prudic, D.E., 2005, Documentation of the + Streamflow-Routing (SFR2) Package to include unsaturated flow beneath + streams---A modification to SFR1: {U.S. Geological Survey Techniques and + Methods, book 6, chap. A13, 50 p.}, accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/tm6A13}. + +\bibitem[{Niswonger and others(2006)Niswonger, Prudic, and Regan}]{UZF} +Niswonger, R.G., Prudic, D.E., and Regan, R.S., 2006, Documentation of the + Unsaturated-Zone Flow (UZF1) Package for modeling unsaturated flow between + the land surface and the water table with {MODFLOW}-2005: {U.S. Geological + Survey Techniques and Methods, book 6, chap. A19, 62 p.}, accessed June 27, + 2017, at \url{https://pubs.usgs.gov/tm/2006/tm6a19/}. + +\bibitem[{Panday and others(2013)Panday, Langevin, Niswonger, Ibaraki, and + Hughes}]{modflowusg} +Panday, Sorab, Langevin, C.D., Niswonger, R.G., Ibaraki, Motomu, and Hughes, + J.D., 2013, MODFLOW-USG version 1---An unstructured grid version of MODFLOW + for simulating groundwater flow and tightly coupled processes using a control + volume finite-difference formulation: {U.S. Geological Survey Techniques and + Methods, book 6, chap. A45, 66 p.}, accessed June 27, 2017, at + \url{https://pubs.usgs.gov/tm/06/a45/}. + +\bibitem[{Provost and others(2017)Provost, Langevin, and Hughes}]{modflow6xt3d} +Provost, A.M., Langevin, C.D., and Hughes, J.D., 2017, Documentation for the + ``XT3D'' Option in the Node Property Flow (NPF) Package of MODFLOW 6: {U.S. + Geological Survey Techniques and Methods, book 6, chap. A56, 46 p.}, + \url{https://doi.org/10.3133/tm6A56}. + +\bibitem[{Prudic(1989)}]{prudic1989str} +Prudic, D.E., 1989, Documentation of a computer program to simulate + stream-aquifer relations using a modular, finite-difference, ground-water + flow model: {U.S. Geological Survey Open-File Report 88--729, 113 p.}, + accessed June 27, 2017, at + \url{https://pubs.er.usgs.gov/publication/ofr88729}. + +\bibitem[{Prudic and others(2004)Prudic, Konikow, and Banta}]{modflowsfr1pack} +Prudic, D.E., Konikow, L.F., and Banta, E.R., 2004, A New Streamflow-Routing + (SFR1) Package to simulate stream-aquifer interaction with MODFLOW-2000: + {U.S. Geological Survey Open File Report 2004--1042, 104 p.}, accessed June + 27, 2017, at \url{https://pubs.er.usgs.gov/publication/ofr20041042}. + +\bibitem[{Voss(1984)}]{Voss1984sutra} +Voss, C.I., 1984, SUTRA---A finite-element simulation model for + saturated-unsaturated fluid-density-dependent ground-water flow with energy + transport or chemically-reactive single-species solute transport: {U.S. + Geological Survey Water-Resources Investigations Report 84--4369, 409 p.} + +\bibitem[{Zheng(2010)}]{zheng2010supplemental} +Zheng, Chunmiao, 2010, MT3DMS v5.3, Supplemental User's Guide: {Technical + Report Prepared for the U.S. Army Corps of Engineers, 51 p.} + +\bibitem[{Zheng and Wang(1999)}]{zheng1999mt3dms} +Zheng, Chunmiao, and Wang, P.P., 1999, MT3DMS---A modular three-dimensional + multi-species transport model for simulation of advection, dispersion and + chemical reactions of contaminants in groundwater systems; Documentation and + user's guide: {Contract report SERDP--99--1: Vicksburg, Miss., U.S. Army + Engineer Research and Development Center, 169 p.} + +\bibitem[{Zheng and others(2001)Zheng, Hill, and Hsieh}]{zheng2001modflow} +Zheng, Chunmiao, Hill, M.C., and Hsieh, P.A., 2001, MODFLOW-2000, the U.S. + Geological Survey Modular Ground-Water Model---User guide to the LMT6 + package, the linkage with MT3DMS for multi-species mass transport modeling: + {U.S. Geological Survey Open-File Report 01--82, 43 p.}, accessed June 27, + 2017, at \url{https://pubs.er.usgs.gov/publication/ofr0182}. + +\end{thebibliography} diff --git a/doc/mf6io/mf6ivar/dfn/gwe-cnc.dfn b/doc/mf6io/mf6ivar/dfn/gwe-cnc.dfn new file mode 100644 index 00000000000..956feeeb712 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-cnc.dfn @@ -0,0 +1,206 @@ +# --------------------- gwe cnc options --------------------- + +block options +name auxiliary +type string +shape (naux) +reader urword +optional true +longname keyword to specify aux variables +description REPLACE auxnames {'{#1}': 'Groundwater Energy Transport'} + +block options +name auxmultname +type string +shape +reader urword +optional true +longname name of auxiliary variable for multiplier +description REPLACE auxmultname {'{#1}': 'temperature value'} + +block options +name boundnames +type keyword +shape +reader urword +optional true +longname +description REPLACE boundnames {'{#1}': 'constant temperature'} + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'constant temperature'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'constant temperature'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save constant temperature flows to budget file +description REPLACE save_flows {'{#1}': 'constant temperature'} + +block options +name ts_filerecord +type record ts6 filein ts6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name ts6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname time series keyword +description keyword to specify that record corresponds to a time-series file. + +block options +name filein +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an input filename is expected next. + +block options +name ts6_filename +type string +preserve_case true +in_record true +reader urword +optional false +tagged false +longname file name of time series information +description REPLACE timeseriesfile {} + +block options +name obs_filerecord +type record obs6 filein obs6_filename +shape +reader urword +tagged true +optional true +longname +description + +block options +name obs6 +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname obs keyword +description keyword to specify that record corresponds to an observations file. + +block options +name obs6_filename +type string +preserve_case true +in_record true +tagged false +reader urword +optional false +longname obs6 input filename +description REPLACE obs6_filename {'{#1}': 'Constant Temperature'} + + +# --------------------- gwe cnc dimensions --------------------- + +block dimensions +name maxbound +type integer +reader urword +optional false +longname maximum number of constant temperatures +description REPLACE maxbound {'{#1}': 'constant temperatures'} + + +# --------------------- gwe cnc period --------------------- + +block period +name iper +type integer +block_variable True +in_record true +tagged false +shape +valid +reader urword +optional false +longname stress period number +description REPLACE iper {} + +block period +name stress_period_data +type recarray cellid temp aux boundname +shape (maxbound) +reader urword +longname +description + +block period +name cellid +type integer +shape (ncelldim) +tagged false +in_record true +reader urword +longname cell identifier +description REPLACE cellid {} + +block period +name temp +type double precision +shape +tagged false +in_record true +reader urword +time_series true +longname constant temperature value +description is the constant temperature value. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. + +block period +name aux +type double precision +in_record true +tagged false +shape (naux) +reader urword +optional true +time_series true +longname auxiliary variables +description REPLACE aux {'{#1}': 'constant temperature'} + +block period +name boundname +type string +shape +tagged false +in_record true +reader urword +optional true +longname constant temperature name +description REPLACE boundname {'{#1}': 'constant temperature'} diff --git a/doc/mf6io/mf6ivar/dfn/gwe-mve.dfn b/doc/mf6io/mf6ivar/dfn/gwe-mve.dfn new file mode 100644 index 00000000000..e67e76ba471 --- /dev/null +++ b/doc/mf6io/mf6ivar/dfn/gwe-mve.dfn @@ -0,0 +1,106 @@ +# --------------------- gwe mve options --------------------- +# flopy subpackage mve_filerecord mve perioddata perioddata +# flopy parent_name_type parent_model_or_package MFModel/MFPackage + +block options +name print_input +type keyword +reader urword +optional true +longname print input to listing file +description REPLACE print_input {'{#1}': 'mover'} + +block options +name print_flows +type keyword +reader urword +optional true +longname print calculated flows to listing file +description REPLACE print_flows {'{#1}': 'lake'} + +block options +name save_flows +type keyword +reader urword +optional true +longname save lake flows to budget file +description REPLACE save_flows {'{#1}': 'lake'} + +block options +name budget_filerecord +type record budget fileout budgetfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budget +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget. + +block options +name fileout +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname file keyword +description keyword to specify that an output filename is expected next. + +block options +name budgetfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the binary output file to write budget information. + +block options +name budgetcsv_filerecord +type record budgetcsv fileout budgetcsvfile +shape +reader urword +tagged true +optional true +longname +description + +block options +name budgetcsv +type keyword +shape +in_record true +reader urword +tagged true +optional false +longname budget keyword +description keyword to specify that record corresponds to the budget CSV. + +block options +name budgetcsvfile +type string +preserve_case true +shape +in_record true +reader urword +tagged false +optional false +longname file keyword +description name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + + diff --git a/doc/mf6io/mf6ivar/examples/exg-gwegwe-example-obs.dat b/doc/mf6io/mf6ivar/examples/exg-gwegwe-example-obs.dat new file mode 100644 index 00000000000..5312a75f67b --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/exg-gwegwe-example-obs.dat @@ -0,0 +1,12 @@ +BEGIN OPTIONS + DIGITS 10 + PRINT_INPUT +END OPTIONS + +# Block defining continuous observations +BEGIN CONTINUOUS FILEOUT simulation.obs.csv +# obsname obstype id or boundname + exg1 flow-ja-face 1 + left-face flow-ja-face bnameleft + right-face flow-ja-face bnameright +END CONTINUOUS diff --git a/doc/mf6io/mf6ivar/examples/exg-gwegwe-example.dat b/doc/mf6io/mf6ivar/examples/exg-gwegwe-example.dat new file mode 100644 index 00000000000..263c9fd5750 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/exg-gwegwe-example.dat @@ -0,0 +1,58 @@ +BEGIN OPTIONS + PRINT_INPUT + PRINT_FLOWS + SAVE_FLOWS + AUXILIARY testaux +END OPTIONS + +BEGIN DIMENSIONS + NEXG 36 +END DIMENSIONS + + # nodem1 nodem2 ihc cl1 cl2 fahl testaux +BEGIN EXCHANGEDATA +# +# left side + 16 1 1 50. 16.67 33.33 100.99 + 16 10 1 50. 16.67 33.33 100.99 + 16 19 1 50. 16.67 33.33 100.99 + 23 28 1 50. 16.67 33.33 100.99 + 23 37 1 50. 16.67 33.33 100.99 + 23 46 1 50. 16.67 33.33 100.99 + 30 55 1 50. 16.67 33.33 100.99 + 30 64 1 50. 16.67 33.33 100.99 + 30 73 1 50. 16.67 33.33 100.99 +# +# right side + 20 9 1 50. 16.67 33.33 100.99 + 20 18 1 50. 16.67 33.33 100.99 + 20 27 1 50. 16.67 33.33 100.99 + 27 36 1 50. 16.67 33.33 100.99 + 27 45 1 50. 16.67 33.33 100.99 + 27 54 1 50. 16.67 33.33 100.99 + 34 63 1 50. 16.67 33.33 100.99 + 34 72 1 50. 16.67 33.33 100.99 + 34 81 1 50. 16.67 33.33 100.99 +# +# back + 10 1 1 50. 17.67 33.33 100.99 + 10 2 1 50. 17.67 33.33 100.99 + 10 3 1 50. 17.67 33.33 100.99 + 11 4 1 50. 17.67 33.33 100.99 + 11 5 1 50. 17.67 33.33 100.99 + 11 6 1 50. 17.67 33.33 100.99 + 12 7 1 50. 17.67 33.33 100.99 + 12 8 1 50. 17.67 33.33 100.99 + 12 9 1 50. 17.67 33.33 100.99 +# +# front + 38 73 1 50. 17.67 33.33 100.99 + 38 74 1 50. 17.67 33.33 100.99 + 38 75 1 50. 17.67 33.33 100.99 + 39 76 1 50. 17.67 33.33 100.99 + 39 77 1 50. 17.67 33.33 100.99 + 39 78 1 50. 17.67 33.33 100.99 + 40 79 1 50. 17.67 33.33 100.99 + 40 80 1 50. 17.67 33.33 100.99 + 40 81 1 50. 17.67 33.33 100.99 +END EXCHANGEDATA diff --git a/doc/mf6io/mf6ivar/examples/gwe-adv-example.dat b/doc/mf6io/mf6ivar/examples/gwe-adv-example.dat new file mode 100644 index 00000000000..62b508e03a7 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-adv-example.dat @@ -0,0 +1,3 @@ +BEGIN OPTIONS + SCHEME UPSTREAM +END OPTIONS diff --git a/doc/mf6io/mf6ivar/examples/gwe-cnc-example-obs.dat b/doc/mf6io/mf6ivar/examples/gwe-cnc-example-obs.dat new file mode 100644 index 00000000000..898e6856c4f --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-cnc-example-obs.dat @@ -0,0 +1,16 @@ +BEGIN OPTIONS + DIGITS 8 + PRINT_INPUT +END OPTIONS + +BEGIN CONTINUOUS FILEOUT my_model.cnc01.csv +# obsname obstype ID + ctemp_3_1 CNC 3 1 1 + ctemp_3_2 CNC 3 2 1 + ctemp_3_3 CNC 3 3 1 +END CONTINUOUS + +BEGIN CONTINUOUS FILEOUT my_model.chd02.csv +# obsname obstype ID + ctemp_3_flow CNC CTEMP_3_1 +END CONTINUOUS \ No newline at end of file diff --git a/doc/mf6io/mf6ivar/examples/gwe-cnc-example.dat b/doc/mf6io/mf6ivar/examples/gwe-cnc-example.dat new file mode 100644 index 00000000000..d1df1d6fcaf --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-cnc-example.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS + PRINT_FLOWS + PRINT_INPUT + SAVE_FLOWS +END OPTIONS + +BEGIN DIMENSIONS + MAXBOUND 1 +END DIMENSIONS + +BEGIN PERIOD 1 + 3 1 1 15.0 + 3 2 1 15.5 + 3 3 1 16.0 +END PERIOD diff --git a/doc/mf6io/mf6ivar/examples/gwe-dsp-example.dat b/doc/mf6io/mf6ivar/examples/gwe-dsp-example.dat new file mode 100644 index 00000000000..50231007102 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-dsp-example.dat @@ -0,0 +1,19 @@ +BEGIN OPTIONS +END OPTIONS + +BEGIN GRIDDATA + ALH + CONSTANT 1. + ALV + CONSTANT 1. + ATH1 + CONSTANT 0.1 + ATH2 + CONSTANT 0.1 + ATV + CONSTANT 0.1 + KTW + CONSTANT 0.5918 + KTS + CONSTANT 0.27 +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/examples/gwe-fmi-example.dat b/doc/mf6io/mf6ivar/examples/gwe-fmi-example.dat new file mode 100644 index 00000000000..67dee32f24e --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-fmi-example.dat @@ -0,0 +1,14 @@ +BEGIN OPTIONS + FLOW_IMBALANCE_CORRECTION +END OPTIONS + +BEGIN PACKAGEDATA + GWFBUDGET FILEIN ../flow/mygwfmodel.bud + GWFHEAD FILEIN ../flow/mygwfmodel.hds + GWFMOVER FILEIN ../flow/mygwfmodel.hds + LAK-1 FILEIN ../flow/mygwfmodel.lak.bud + SFR-1 FILEIN ../flow/mygwfmodel.sfr.bud + MAW-1 FILEIN ../flow/mygwfmodel.maw.bud + UZF-1 FILEIN ../flow/mygwfmodel.uzf.bud + LAK-2 FILEIN ../flow/mygwfmodel-2.lak.bud +END PACKAGEDATA \ No newline at end of file diff --git a/doc/mf6io/mf6ivar/examples/gwe-ic-example.dat b/doc/mf6io/mf6ivar/examples/gwe-ic-example.dat new file mode 100644 index 00000000000..101cdf843cb --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-ic-example.dat @@ -0,0 +1,10 @@ +#The OPTIONS block is optional +BEGIN OPTIONS +END OPTIONS + +#The GRIDDATA block is required +BEGIN GRIDDATA + STRT LAYERED + CONSTANT 10.0 Initial Temperature (C) layer 1 + CONSTANT 10.0 Initial Temperature (C) layer 2 +END GRIDDATA diff --git a/doc/mf6io/mf6ivar/examples/gwe-lke-example-obs.dat b/doc/mf6io/mf6ivar/examples/gwe-lke-example-obs.dat new file mode 100644 index 00000000000..c37a5c8f190 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-lke-example-obs.dat @@ -0,0 +1,25 @@ +BEGIN options + DIGITS 7 + PRINT_INPUT +END options + +BEGIN continuous FILEOUT gwe_lke02.lke.obs.csv + lke-1-temp TEMPERATURE 1 + lke-1-extinflow EXT-INFLOW 1 + lke-1-rain RAINFALL 1 + lke-1-roff RUNOFF 1 + lke-1-wdrl WITHDRAWAL 1 + lke-1-stor STORAGE 1 + lke-1-const CONSTANT 1 + lke-1-gwe1 LKE 1 1 + lke-1-gwe2 LKE 1 2 + lke-2-gwe1 LKE 2 1 + lke-1-mylake1 LKE MYLAKE1 + lke-1-fjf FLOW-JA-FACE 1 2 + lke-2-fjf FLOW-JA-FACE 2 1 + lke-3-fjf FLOW-JA-FACE 2 3 + lke-4-fjf FLOW-JA-FACE 3 2 + lke-5-fjf FLOW-JA-FACE MYLAKE1 + lke-6-fjf FLOW-JA-FACE MYLAKE2 + lke-7-fjf FLOW-JA-FACE MYLAKE3 +END continuous diff --git a/doc/mf6io/mf6ivar/examples/gwe-lke-example.dat b/doc/mf6io/mf6ivar/examples/gwe-lke-example.dat new file mode 100644 index 00000000000..1ffe73824fa --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-lke-example.dat @@ -0,0 +1,24 @@ +BEGIN OPTIONS + AUXILIARY aux1 aux2 + BOUNDNAMES + PRINT_INPUT + PRINT_TEMPERATURE + PRINT_FLOWS + SAVE_FLOWS + TEMPERATURE FILEOUT gwe_lke_02.lke.bin + BUDGET FILEOUT gwe_lke_02.lke.bud + OBS6 FILEIN gwe_lke_02.lke.obs +END OPTIONS + +BEGIN PACKAGEDATA +# L STRT aux1 aux2 bname + 1 5.0 99.0 999.0 MYLAKE1 + 2 6.0 99.0 999.0 MYLAKE2 + 3 7.0 99.0 999.0 MYLAKE3 +END PACKAGEDATA + +BEGIN PERIOD 1 + 1 STATUS ACTIVE + 2 STATUS ACTIVE + 3 STATUS ACTIVE +END PERIOD 1 diff --git a/doc/mf6io/mf6ivar/examples/gwe-mst-example.dat b/doc/mf6io/mf6ivar/examples/gwe-mst-example.dat new file mode 100644 index 00000000000..cce31b5124c --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-mst-example.dat @@ -0,0 +1,15 @@ +BEGIN OPTIONS +END OPTIONS + +BEGIN GRIDDATA + POROSITY + CONSTANT 0.1 + CPS + CONSTANT 880.0 + RHOS + CONSTANT 2650.0 +END GRIDDATA + +BEGIN PACKAGEDATA + 4180.0 1000.0 2.454E+06 +END PACKAGEDATA diff --git a/doc/mf6io/mf6ivar/examples/gwe-mve-example.dat b/doc/mf6io/mf6ivar/examples/gwe-mve-example.dat new file mode 100644 index 00000000000..1b2835d13cf --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-mve-example.dat @@ -0,0 +1,6 @@ +BEGIN OPTIONS + PRINT_INPUT + PRINT_FLOWS + SAVE_FLOWS + BUDGET FILEOUT mygwemodel.mve.bud +END OPTIONS diff --git a/doc/mf6io/mf6ivar/examples/gwe-mwe-example-obs.dat b/doc/mf6io/mf6ivar/examples/gwe-mwe-example-obs.dat new file mode 100644 index 00000000000..a3a8ced3ad9 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-mwe-example-obs.dat @@ -0,0 +1,43 @@ +BEGIN options + DIGITS 12 + PRINT_INPUT +END options + +BEGIN continuous FILEOUT gwe_mwe_02.mwe.obs.csv + mwe1mwe MWE 1 1 + mwe2mwe MWE 2 1 + mwe3mwe MWE 3 1 + mwe4mwe MWE 4 1 + mwe1temp TEMPERATURE 1 + mwe2temp TEMPERATURE 2 + mwe3temp TEMPERATURE 3 + mwe4temp TEMPERATURE 4 + mwe1stor STORAGE 1 + mwe2stor STORAGE 2 + mwe3stor STORAGE 3 + mwe4stor STORAGE 4 + mwe1cnst CONSTANT 1 + mwe2cnst CONSTANT 2 + mwe3cnst CONSTANT 3 + mwe4cnst CONSTANT 4 + mwe1fmvr FROM-MVR 1 + mwe2fmvr FROM-MVR 2 + mwe3fmvr FROM-MVR 3 + mwe4fmvr FROM-MVR 4 + mwe1rate RATE 1 + mwe2rate RATE 2 + mwe3rate RATE 3 + mwe4rate RATE 4 + mwe1rtmv RATE-TO-MVR 1 + mwe2rtmv RATE-TO-MVR 2 + mwe3rtmv RATE-TO-MVR 3 + mwe4rtmv RATE-TO-MVR 4 + mwe1fwrt FW-RATE 1 + mwe2fwrt FW-RATE 2 + mwe3fwrt FW-RATE 3 + mwe4fwrt FW-RATE 4 + mwe1frtm FW-RATE-TO-MVR 1 + mwe2frtm FW-RATE-TO-MVR 2 + mwe3frtm FW-RATE-TO-MVR 3 + mwe4frtm FW-RATE-TO-MVR 4 +END continuous FILEOUT gwe_mwe_02.mwe.obs.csv \ No newline at end of file diff --git a/doc/mf6io/mf6ivar/examples/gwe-mwe-example.dat b/doc/mf6io/mf6ivar/examples/gwe-mwe-example.dat new file mode 100644 index 00000000000..4616f3fa7bc --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-mwe-example.dat @@ -0,0 +1,24 @@ +BEGIN OPTIONS + AUXILIARY aux1 aux2 + BOUNDNAMES + PRINT_INPUT + PRINT_TEMPERATURE + PRINT_FLOWS + SAVE_FLOWS + TEMPERATURE FILEOUT gwe_mwe_02.mwe.bin + BUDGET FILEOUT gwe_mwe_02.mwe.bud + OBS6 FILEIN gwe_mwe_02.mwe.obs +END OPTIONS + +BEGIN PACKAGEDATA +# L STRT aux1 aux2 bname + 1 10.00 99.00 999.00 MYWELL1 + 2 10.00 99.00 999.00 MYWELL2 + 3 10.00 99.00 999.00 MYWELL3 +END PACKAGEDATA + +BEGIN PERIOD 1 + 1 STATUS ACTIVE + 2 STATUS ACTIVE + 3 STATUS ACTIVE +END PERIOD 1 diff --git a/doc/mf6io/mf6ivar/examples/gwe-oc-example.dat b/doc/mf6io/mf6ivar/examples/gwe-oc-example.dat new file mode 100644 index 00000000000..ecd0453ce69 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-oc-example.dat @@ -0,0 +1,10 @@ +BEGIN OPTIONS + TEMPERATURE FILEOUT gw_temperatures.ucn + TEMPERATURE PRINT_FORMAT COLUMNS 15 WIDTH 7 DIGITS 2 FIXED +END OPTIONS + +BEGIN PERIOD 1 + PRINT BUDGET ALL + SAVE TEMPERATURE ALL + PRINT TEMPERATURE ALL +END PERIOD diff --git a/doc/mf6io/mf6ivar/examples/gwe-sfe-example-obs.dat b/doc/mf6io/mf6ivar/examples/gwe-sfe-example-obs.dat new file mode 100644 index 00000000000..d3652a5bf66 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-sfe-example-obs.dat @@ -0,0 +1,24 @@ +BEGIN options + DIGITS 7 + PRINT_INPUT +END options + +BEGIN continuous FILEOUT gwe_sfe02.sfe.obs.csv + sfe-1-temp TEMPERATURE 1 + sfe-1-extinflow EXT-INFLOW 1 + sfe-1-rain RAINFALL 1 + sfe-1-roff RUNOFF 1 + sfe-1-stor STORAGE 1 + sfe-1-const CONSTANT 1 + sfe-1-gwe1 SFE 1 1 + sfe-1-gwe2 SFE 1 2 + sfe-2-gwe1 SFE 2 1 + sfe-1-mylake1 SFE MYREACHES + sfe-1-fjf FLOW-JA-FACE 1 2 + sfe-2-fjf FLOW-JA-FACE 2 1 + sfe-3-fjf FLOW-JA-FACE 2 3 + sfe-4-fjf FLOW-JA-FACE 3 2 + sfe-5-fjf FLOW-JA-FACE MYREACH1 + sfe-6-fjf FLOW-JA-FACE MYREACH2 + sfe-7-fjf FLOW-JA-FACE MYREACH3 +END continuous diff --git a/doc/mf6io/mf6ivar/examples/gwe-sfe-example.dat b/doc/mf6io/mf6ivar/examples/gwe-sfe-example.dat new file mode 100644 index 00000000000..c5bfd627e62 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-sfe-example.dat @@ -0,0 +1,24 @@ +BEGIN OPTIONS + AUXILIARY aux1 aux2 + BOUNDNAMES + PRINT_INPUT + PRINT_TEMPERATURE + PRINT_FLOWS + SAVE_FLOWS + TEMPERATURE FILEOUT gwe_sfe_02.sfe.bin + BUDGET FILEOUT gwe_sfe_02.sfe.bud + OBS6 FILEIN gwe_sfe_02.sfe.obs +END OPTIONS + +BEGIN PACKAGEDATA +# L STRT aux1 aux2 bname + 1 5.00000000 99.00000000 999.00000000 REACH1 + 2 5.00000000 99.00000000 999.00000000 REACH2 + 3 5.00000000 99.00000000 999.00000000 REACH3 +END PACKAGEDATA + +BEGIN PERIOD 1 + 1 STATUS ACTIVE + 2 STATUS ACTIVE + 3 STATUS ACTIVE +END PERIOD 1 diff --git a/doc/mf6io/mf6ivar/examples/gwe-src-example-obs.dat b/doc/mf6io/mf6ivar/examples/gwe-src-example-obs.dat new file mode 100644 index 00000000000..5653a77b9f7 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-src-example-obs.dat @@ -0,0 +1,11 @@ +BEGIN OPTIONS + DIGITS 7 + PRINT_INPUT +END OPTIONS + +BEGIN CONTINUOUS FILEOUT my_model.src.obs.csv +# obsname obstype ID + esrc_7_102_17 SRC 7 102 17 + esrc_7_102_17 SRC CW_1 + esources SRC esources +END CONTINUOUS diff --git a/doc/mf6io/mf6ivar/examples/gwe-src-example.dat b/doc/mf6io/mf6ivar/examples/gwe-src-example.dat new file mode 100644 index 00000000000..72f42e5d4e8 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-src-example.dat @@ -0,0 +1,13 @@ +BEGIN OPTIONS + PRINT_FLOWS + PRINT_INPUT + SAVE_FLOWS +END OPTIONS + +BEGIN DIMENSIONS + MAXBOUND 1 +END DIMENSIONS + +BEGIN PERIOD 1 + 1 1 1 1500000.0 +END PERIOD diff --git a/doc/mf6io/mf6ivar/examples/gwe-ssm-example.dat b/doc/mf6io/mf6ivar/examples/gwe-ssm-example.dat new file mode 100644 index 00000000000..f64b3109f4a --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-ssm-example.dat @@ -0,0 +1,16 @@ +BEGIN OPTIONS + PRINT_FLOWS + SAVE_FLOWS +END OPTIONS + +BEGIN SOURCES +# pname srctype auxname + WEL-1 AUX TEMPERATURE + LAK-1 AUX TEMPERATURE + RCH-1 AUX TEMPERATURE +END SOURCES + +BEGIN FILEINPUT + GHB-1 SPC6 FILEINPUT mymodel.ghb1.spc + DRN-1 SPC6 FILEINPUT mymodel.drn1.spc +END FILEINPUT \ No newline at end of file diff --git a/doc/mf6io/mf6ivar/examples/gwe-uze-example-obs.dat b/doc/mf6io/mf6ivar/examples/gwe-uze-example-obs.dat new file mode 100644 index 00000000000..5d0ab4cc3bf --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-uze-example-obs.dat @@ -0,0 +1,12 @@ +BEGIN options + DIGITS 7 + PRINT_INPUT +END options + +BEGIN continuous FILEOUT gwe_02.uze.obs.csv + mwe-1-temp TEMPERATURE 1 + mwe-1-stor STORAGE 1 + mwe-1-gwe1 UZE 1 + mwe-1-gwe2 UZE 2 + mwe-2-gwe1 UZE 3 +END continuous diff --git a/doc/mf6io/mf6ivar/examples/gwe-uze-example.dat b/doc/mf6io/mf6ivar/examples/gwe-uze-example.dat new file mode 100644 index 00000000000..e6e29baac43 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/gwe-uze-example.dat @@ -0,0 +1,24 @@ +BEGIN OPTIONS + AUXILIARY aux1 aux2 + BOUNDNAMES + PRINT_INPUT + PRINT_TEMPERATURE + PRINT_FLOWS + SAVE_FLOWS + TEMPERATURE FILEOUT gwe_02.uze.bin + BUDGET FILEOUT gwe_02.uze.bud + OBS6 FILEIN gwe_02.uze.obs +END OPTIONS + +BEGIN PACKAGEDATA +# L STRT aux1 aux2 bname + 1 0.0 99.0 999.0 MYUZFCELL1 + 2 0.0 99.0 999.0 MYUZFCELL2 + 3 0.0 99.0 999.0 MYUZFCELL3 +END PACKAGEDATA + +BEGIN PERIOD 1 + 1 STATUS ACTIVE + 2 STATUS ACTIVE + 3 STATUS ACTIVE +END PERIOD 1 diff --git a/doc/mf6io/mf6ivar/examples/utl-obs-gwe-example.dat b/doc/mf6io/mf6ivar/examples/utl-obs-gwe-example.dat new file mode 100644 index 00000000000..10fb74a0762 --- /dev/null +++ b/doc/mf6io/mf6ivar/examples/utl-obs-gwe-example.dat @@ -0,0 +1,18 @@ +BEGIN OPTIONS + DIGITS 10 + PRINT_INPUT +END OPTIONS + +BEGIN CONTINUOUS FILEOUT my_model.gwt.conc.csv +# obsname obstype ID + L1 TEMPERATURE 1 51 51 # temps at lay 1 row 51 col 51 + L2 TEMPERATURE 2 51 51 # temps at lay 2 row 51 col 51 +END CONTINUOUS + +BEGIN CONTINUOUS FILEOUT my_model.gwe.eflow.csv +# obsname obstype ID ID1 + L1rfflow FLOW-JA-FACE 1 51 51 1 51 52 + L2rfflow FLOW-JA-FACE 2 51 51 2 51 52 + L1-L2flow FLOW-JA-FACE 1 51 51 2 51 51 +END CONTINUOUS + diff --git a/doc/mf6io/mf6ivar/md/mf6ivar.md b/doc/mf6io/mf6ivar/md/mf6ivar.md index 0bb99977d02..9bd764f506a 100644 --- a/doc/mf6io/mf6ivar/md/mf6ivar.md +++ b/doc/mf6io/mf6ivar/md/mf6ivar.md @@ -6,6 +6,7 @@ | SIM | NAM | OPTIONS | NOCHECK | KEYWORD | keyword flag to indicate that the model input check routines should not be called prior to each time step. Checks are performed by default. | | SIM | NAM | OPTIONS | MEMORY_PRINT_OPTION | STRING | is a flag that controls printing of detailed memory manager usage to the end of the simulation list file. NONE means do not print detailed information. SUMMARY means print only the total memory for each simulation component. ALL means print information for each variable stored in the memory manager. NONE is default if MEMORY\_PRINT\_OPTION is not specified. | | SIM | NAM | OPTIONS | MAXERRORS | INTEGER | maximum number of errors that will be stored and printed. | +| SIM | NAM | OPTIONS | PRINT_INPUT | KEYWORD | keyword to activate printing of simulation input summaries to the simulation list file (mfsim.lst). With this keyword, input summaries will be written for those packages that support newer input data model routines. Not all packages are supported yet by the newer input data model routines. | | SIM | NAM | TIMING | TDIS6 | STRING | is the name of the Temporal Discretization (TDIS) Input File. | | SIM | NAM | MODELS | MTYPE | STRING | is the type of model to add to simulation. | | SIM | NAM | MODELS | MFNAME | STRING | is the file name of the model name file. | @@ -349,7 +350,7 @@ | GWF | HFB | PERIOD | CELLID1 | INTEGER (NCELLDIM) | identifier for the first cell. For a structured grid that uses the DIS input file, CELLID1 is the layer, row, and column numbers of the cell. For a grid that uses the DISV input file, CELLID1 is the layer number and CELL2D number for the two cells. If the model uses the unstructured discretization (DISU) input file, then CELLID1 is the node numbers for the cell. The barrier is located between cells designated as CELLID1 and CELLID2. For models that use the DIS and DISV grid types, the layer number for CELLID1 and CELLID2 must be the same. For all grid types, cells must be horizontally adjacent or the program will terminate with an error. | | GWF | HFB | PERIOD | CELLID2 | INTEGER (NCELLDIM) | identifier for the second cell. See CELLID1 for description of how to specify. | | GWF | HFB | PERIOD | HYDCHR | DOUBLE PRECISION | is the hydraulic characteristic of the horizontal-flow barrier. The hydraulic characteristic is the barrier hydraulic conductivity divided by the width of the horizontal-flow barrier. If the hydraulic characteristic is negative, then the absolute value of HYDCHR acts as a multiplier to the conductance between the two model cells specified as containing the barrier. For example, if the value for HYDCHR was specified as -1.5, the conductance calculated for the two cells would be multiplied by 1.5. | -| GWF | CHD | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | CHD | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | CHD | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of CHD head value. | | GWF | CHD | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of constant-head cells. | | GWF | CHD | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of constant-head information will be written to the listing file immediately after it is read. | @@ -366,7 +367,7 @@ | GWF | CHD | PERIOD | HEAD | DOUBLE PRECISION | is the head at the boundary. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | CHD | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each constant head. The values of auxiliary variables must be present for each constant head. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | CHD | PERIOD | BOUNDNAME | STRING | name of the constant head boundary cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | -| GWF | WEL | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | WEL | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | WEL | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of well flow rate. | | GWF | WEL | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of well cells. | | GWF | WEL | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of well information will be written to the listing file immediately after it is read. | @@ -388,7 +389,7 @@ | GWF | WEL | PERIOD | Q | DOUBLE PRECISION | is the volumetric well rate. A positive value indicates recharge (injection) and a negative value indicates discharge (extraction). If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | WEL | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each well. The values of auxiliary variables must be present for each well. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | WEL | PERIOD | BOUNDNAME | STRING | name of the well cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | -| GWF | DRN | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | DRN | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | DRN | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of drain conductance. | | GWF | DRN | OPTIONS | AUXDEPTHNAME | STRING | name of a variable listed in AUXILIARY that defines the depth at which drainage discharge will be scaled. If a positive value is specified for the AUXDEPTHNAME AUXILIARY variable, then ELEV is the elevation at which the drain starts to discharge and ELEV + DDRN (assuming DDRN is the AUXDEPTHNAME variable) is the elevation when the drain conductance (COND) scaling factor is 1. If a negative drainage depth value is specified for DDRN, then ELEV + DDRN is the elevation at which the drain starts to discharge and ELEV is the elevation when the conductance (COND) scaling factor is 1. A linear- or cubic-scaling is used to scale the drain conductance (COND) when the Standard or Newton-Raphson Formulation is used, respectively. | | GWF | DRN | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of drain cells. | @@ -408,7 +409,7 @@ | GWF | DRN | PERIOD | COND | DOUBLE PRECISION | is the hydraulic conductance of the interface between the aquifer and the drain. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | DRN | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each drain. The values of auxiliary variables must be present for each drain. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | DRN | PERIOD | BOUNDNAME | STRING | name of the drain cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | -| GWF | RIV | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | RIV | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | RIV | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of riverbed conductance. | | GWF | RIV | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of river cells. | | GWF | RIV | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of river information will be written to the listing file immediately after it is read. | @@ -428,7 +429,7 @@ | GWF | RIV | PERIOD | RBOT | DOUBLE PRECISION | is the elevation of the bottom of the riverbed. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | RIV | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each river. The values of auxiliary variables must be present for each river. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | RIV | PERIOD | BOUNDNAME | STRING | name of the river cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | -| GWF | GHB | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | GHB | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | GHB | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of general-head boundary conductance. | | GWF | GHB | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of general-head boundary cells. | | GWF | GHB | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of general-head boundary information will be written to the listing file immediately after it is read. | @@ -448,7 +449,7 @@ | GWF | GHB | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each general-head boundary. The values of auxiliary variables must be present for each general-head boundary. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWF | GHB | PERIOD | BOUNDNAME | STRING | name of the general-head boundary cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWF | RCH | OPTIONS | FIXED_CELL | KEYWORD | indicates that recharge will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. | -| GWF | RCH | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | RCH | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | RCH | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of recharge. | | GWF | RCH | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of recharge cells. | | GWF | RCH | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of recharge information will be written to the listing file immediately after it is read. | @@ -467,7 +468,7 @@ | GWF | RCH | PERIOD | BOUNDNAME | STRING | name of the recharge cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWF | RCHA | OPTIONS | READASARRAYS | KEYWORD | indicates that array-based input will be used for the Recharge Package. This keyword must be specified to use array-based input. | | GWF | RCHA | OPTIONS | FIXED_CELL | KEYWORD | indicates that recharge will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. | -| GWF | RCHA | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | RCHA | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | RCHA | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of recharge. | | GWF | RCHA | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of recharge information will be written to the listing file immediately after it is read. | | GWF | RCHA | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of recharge flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | @@ -482,7 +483,7 @@ | GWF | RCHA | PERIOD | RECHARGE | DOUBLE PRECISION (NCOL*NROW; NCPL) | is the recharge flux rate ($LT^{-1}$). This rate is multiplied inside the program by the surface area of the cell to calculate the volumetric recharge rate. The recharge array may be defined by a time-array series (see the "Using Time-Array Series in a Package" section). | | GWF | RCHA | PERIOD | AUX | DOUBLE PRECISION (NCOL*NROW; NCPL) | is an array of values for auxiliary variable aux(iaux), where iaux is a value from 1 to naux, and aux(iaux) must be listed as part of the auxiliary variables. A separate array can be specified for each auxiliary variable. If an array is not specified for an auxiliary variable, then a value of zero is assigned. If the value specified here for the auxiliary variable is the same as auxmultname, then the recharge array will be multiplied by this array. | | GWF | EVT | OPTIONS | FIXED_CELL | KEYWORD | indicates that evapotranspiration will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. | -| GWF | EVT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | EVT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | EVT | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of evapotranspiration rate. | | GWF | EVT | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of evapotranspiration cells. | | GWF | EVT | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of evapotranspiration information will be written to the listing file immediately after it is read. | @@ -508,7 +509,7 @@ | GWF | EVT | PERIOD | BOUNDNAME | STRING | name of the evapotranspiration cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWF | EVTA | OPTIONS | READASARRAYS | KEYWORD | indicates that array-based input will be used for the Evapotranspiration Package. This keyword must be specified to use array-based input. | | GWF | EVTA | OPTIONS | FIXED_CELL | KEYWORD | indicates that evapotranspiration will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. | -| GWF | EVTA | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | EVTA | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | EVTA | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of evapotranspiration rate. | | GWF | EVTA | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of evapotranspiration information will be written to the listing file immediately after it is read. | | GWF | EVTA | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of evapotranspiration flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | @@ -524,7 +525,7 @@ | GWF | EVTA | PERIOD | RATE | DOUBLE PRECISION (NCOL*NROW; NCPL) | is the maximum ET flux rate ($LT^{-1}$). | | GWF | EVTA | PERIOD | DEPTH | DOUBLE PRECISION (NCOL*NROW; NCPL) | is the ET extinction depth ($L$). | | GWF | EVTA | PERIOD | AUX(IAUX) | DOUBLE PRECISION (NCOL*NROW; NCPL) | is an array of values for auxiliary variable AUX(IAUX), where iaux is a value from 1 to NAUX, and AUX(IAUX) must be listed as part of the auxiliary variables. A separate array can be specified for each auxiliary variable. If an array is not specified for an auxiliary variable, then a value of zero is assigned. If the value specified here for the auxiliary variable is the same as auxmultname, then the evapotranspiration rate will be multiplied by this array. | -| GWF | MAW | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | MAW | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | MAW | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of multi-aquifer well cells. | | GWF | MAW | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of multi-aquifer well information will be written to the listing file immediately after it is read. | | GWF | MAW | OPTIONS | PRINT_HEAD | KEYWORD | keyword to indicate that the list of multi-aquifer well heads will be printed to the listing file for every stress period in which ``HEAD PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_HEAD is specified, then heads are printed for the last time step of each stress period. | @@ -586,7 +587,7 @@ | GWF | MAW | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | | GWF | MAW | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWF | MAW | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | SFR | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | SFR | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | SFR | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of stream reach cells. | | GWF | SFR | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of stream reach information will be written to the listing file immediately after it is read. | | GWF | SFR | OPTIONS | PRINT_STAGE | KEYWORD | keyword to indicate that the list of stream reach stages will be printed to the listing file for every stress period in which ``HEAD PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_STAGE is specified, then stages are printed for the last time step of each stress period. | @@ -659,7 +660,7 @@ | GWF | SFR | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | | GWF | SFR | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWF | SFR | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | LAK | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | LAK | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | LAK | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of lake cells. | | GWF | LAK | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of lake information will be written to the listing file immediately after it is read. | | GWF | LAK | OPTIONS | PRINT_STAGE | KEYWORD | keyword to indicate that the list of lake stages will be printed to the listing file for every stress period in which ``HEAD PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_STAGE is specified, then stages are printed for the last time step of each stress period. | @@ -732,7 +733,7 @@ | GWF | LAK | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | | GWF | LAK | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWF | LAK | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | -| GWF | UZF | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWF | UZF | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWF | UZF | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of GWF cell area used by UZF cell. | | GWF | UZF | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of UZF cells. | | GWF | UZF | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of UZF information will be written to the listing file immediately after it is read. | @@ -868,7 +869,7 @@ | GWT | DSP | GRIDDATA | ATH1 | DOUBLE PRECISION (NODES) | transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the second ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the y direction. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. | | GWT | DSP | GRIDDATA | ATH2 | DOUBLE PRECISION (NODES) | transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the third ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the z direction. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH1. | | GWT | DSP | GRIDDATA | ATV | DOUBLE PRECISION (NODES) | transverse dispersivity when flow is in vertical direction. If flow is strictly vertical and directed in the z direction, then this value controls spreading in the x and y directions. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ATH2. | -| GWT | CNC | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWT | CNC | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWT | CNC | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of concentration value. | | GWT | CNC | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of constant concentration cells. | | GWT | CNC | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of constant concentration information will be written to the listing file immediately after it is read. | @@ -907,8 +908,8 @@ | GWT | DISV | DIMENSIONS | NCPL | INTEGER | is the number of cells per layer. This is a constant value for the grid and it applies to all layers. | | GWT | DISV | DIMENSIONS | NVERT | INTEGER | is the total number of (x, y) vertex pairs used to characterize the horizontal configuration of the model grid. | | GWT | DISV | GRIDDATA | TOP | DOUBLE PRECISION (NCPL) | is the top elevation for each cell in the top model layer. | -| GWT | DISV | GRIDDATA | BOTM | DOUBLE PRECISION (NLAY, NCPL) | is the bottom elevation for each cell. | -| GWT | DISV | GRIDDATA | IDOMAIN | INTEGER (NLAY, NCPL) | is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. | +| GWT | DISV | GRIDDATA | BOTM | DOUBLE PRECISION (NCPL, NLAY) | is the bottom elevation for each cell. | +| GWT | DISV | GRIDDATA | IDOMAIN | INTEGER (NCPL, NLAY) | is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in the simulation. Furthermore, the first existing cell above will be connected to the first existing cell below. This type of cell is referred to as a ``vertical pass through'' cell. | | GWT | DISV | VERTICES | IV | INTEGER | is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. | | GWT | DISV | VERTICES | XV | DOUBLE PRECISION | is the x-coordinate for the vertex. | | GWT | DISV | VERTICES | YV | DOUBLE PRECISION | is the y-coordinate for the vertex. | @@ -984,7 +985,7 @@ | GWT | SSM | FILEINPUT | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | GWT | SSM | FILEINPUT | SPC6_FILENAME | STRING | character string that defines the path and filename for the file containing source and sink input data for the flow package. The SPC6\_FILENAME file is a flexible input file that allows concentrations to be specified by stress period and with time series. Instructions for creating the SPC6\_FILENAME input file are provided in the next section on file input for boundary concentrations. | | GWT | SSM | FILEINPUT | MIXED | KEYWORD | keyword to specify that these stress package boundaries will have the mixed condition. The MIXED condition is described in the SOURCES block for AUXMIXED. The MIXED condition allows for water to be withdrawn at a concentration that is less than the cell concentration. It is intended primarily for representing evapotranspiration. | -| GWT | SRC | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWT | SRC | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWT | SRC | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of mass loading rate. | | GWT | SRC | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of mass source cells. | | GWT | SRC | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of mass source information will be written to the listing file immediately after it is read. | @@ -1035,7 +1036,7 @@ | GWT | IST | GRIDDATA | BULK_DENSITY | DOUBLE PRECISION (NODES) | is the bulk density of the aquifer in mass per length cubed. bulk\_density will have no effect on simulation results unless the SORPTION keyword is specified in the options block. Bulk density is defined as the immobile domain solid mass per aquifer volume. The definition for this input variable changed after version 6.4.1 was released. The bulk density specified in this package is defined differently from the bulk density defined in the Mobile Storage and Transfer (MST) Package. Additional information on bulk density is included in the MODFLOW 6 Supplemental Technical Information document. | | GWT | IST | GRIDDATA | DISTCOEF | DOUBLE PRECISION (NODES) | is the distribution coefficient for the equilibrium-controlled linear sorption isotherm in dimensions of length cubed per mass. distcoef will have no effect on simulation results unless the SORPTION keyword is specified in the options block. | | GWT | SFT | OPTIONS | FLOW_PACKAGE_NAME | STRING | keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). | -| GWT | SFT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWT | SFT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWT | SFT | OPTIONS | FLOW_PACKAGE_AUXILIARY_NAME | STRING | keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. | | GWT | SFT | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of reach cells. | | GWT | SFT | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of reach information will be written to the listing file immediately after it is read. | @@ -1071,7 +1072,7 @@ | GWT | SFT | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWT | SFT | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWT | LKT | OPTIONS | FLOW_PACKAGE_NAME | STRING | keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). | -| GWT | LKT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWT | LKT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWT | LKT | OPTIONS | FLOW_PACKAGE_AUXILIARY_NAME | STRING | keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. | | GWT | LKT | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of lake cells. | | GWT | LKT | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of lake information will be written to the listing file immediately after it is read. | @@ -1096,7 +1097,7 @@ | GWT | LKT | PACKAGEDATA | BOUNDNAME | STRING | name of the lake cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWT | LKT | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | | GWT | LKT | PERIOD | LAKENO | INTEGER | integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. | -| GWT | LKT | PERIOD | LAKSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, CONCENTRATION, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the concentration of associated with the corresponding flow terms. Concentrations cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated concentration of the lake. | +| GWT | LKT | PERIOD | LAKSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, CONCENTRATION, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the concentration associated with the corresponding flow terms. Concentrations cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated concentration of the lake. | | GWT | LKT | PERIOD | STATUS | STRING | keyword option to define lake status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that concentration will be calculated for the lake. If a lake is inactive, then there will be no solute mass fluxes into or out of the lake and the inactive value will be written for the lake concentration. If a lake is constant, then the concentration for the lake will be fixed at the user specified value. | | GWT | LKT | PERIOD | CONCENTRATION | STRING | real or character value that defines the concentration for the lake. The specified CONCENTRATION is only applied if the lake is a constant concentration lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWT | LKT | PERIOD | RAINFALL | STRING | real or character value that defines the rainfall solute concentration $(ML^{-3})$ for the lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | @@ -1107,7 +1108,7 @@ | GWT | LKT | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWT | LKT | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWT | MWT | OPTIONS | FLOW_PACKAGE_NAME | STRING | keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). | -| GWT | MWT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWT | MWT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWT | MWT | OPTIONS | FLOW_PACKAGE_AUXILIARY_NAME | STRING | keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. | | GWT | MWT | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of well cells. | | GWT | MWT | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of well information will be written to the listing file immediately after it is read. | @@ -1140,7 +1141,7 @@ | GWT | MWT | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | | GWT | MWT | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWT | UZT | OPTIONS | FLOW_PACKAGE_NAME | STRING | keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). | -| GWT | UZT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWT | UZT | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | | GWT | UZT | OPTIONS | FLOW_PACKAGE_AUXILIARY_NAME | STRING | keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. | | GWT | UZT | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of unsaturated zone flow cells. | | GWT | UZT | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of unsaturated zone flow information will be written to the listing file immediately after it is read. | @@ -1203,6 +1204,23 @@ | GWE | NAM | PACKAGES | FNAME | STRING | is the name of the file containing the package input. The path to the file should be included if the file is not located in the folder where the program was run. | | GWE | NAM | PACKAGES | PNAME | STRING | is the user-defined name for the package. PNAME is restricted to 16 characters. No spaces are allowed in PNAME. PNAME character values are read and stored by the program for stress packages only. These names may be useful for labeling purposes when multiple stress packages of the same type are located within a single GWE Model. If PNAME is specified for a stress package, then PNAME will be used in the flow budget table in the listing file; it will also be used for the text entry in the cell-by-cell budget file. PNAME is case insensitive and is stored in all upper case letters. | | GWE | ADV | OPTIONS | SCHEME | STRING | scheme used to solve the advection term. Can be upstream, central, or TVD. If not specified, upstream weighting is the default weighting scheme. | +| GWE | CNC | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWE | CNC | OPTIONS | AUXMULTNAME | STRING | name of auxiliary variable to be used as multiplier of temperature value. | +| GWE | CNC | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of constant temperature cells. | +| GWE | CNC | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of constant temperature information will be written to the listing file immediately after it is read. | +| GWE | CNC | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of constant temperature flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | +| GWE | CNC | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that constant temperature flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | CNC | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | +| GWE | CNC | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | +| GWE | CNC | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | +| GWE | CNC | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | +| GWE | CNC | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the Constant Temperature package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the Constant Temperature package. | +| GWE | CNC | DIMENSIONS | MAXBOUND | INTEGER | integer value specifying the maximum number of constant temperatures cells that will be specified for use during any stress period. | +| GWE | CNC | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | +| GWE | CNC | PERIOD | CELLID | INTEGER (NCELLDIM) | is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. | +| GWE | CNC | PERIOD | TEMP | DOUBLE PRECISION | is the constant temperature value. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | CNC | PERIOD | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each constant temperature. The values of auxiliary variables must be present for each constant temperature. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | CNC | PERIOD | BOUNDNAME | STRING | name of the constant temperature cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | | GWE | DIS | OPTIONS | LENGTH_UNITS | STRING | is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. | | GWE | DIS | OPTIONS | NOGRB | KEYWORD | keyword to deactivate writing of the binary grid file. | | GWE | DIS | OPTIONS | XORIGIN | DOUBLE PRECISION | x-position of the lower-left corner of the model grid. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | @@ -1235,9 +1253,35 @@ | GWE | DISV | CELL2D | YC | DOUBLE PRECISION | is the y-coordinate for the cell center. | | GWE | DISV | CELL2D | NCVERT | INTEGER | is the number of vertices required to define the cell. There may be a different number of vertices for each cell. | | GWE | DISV | CELL2D | ICVERT | INTEGER (NCVERT) | is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. Cells that are connected must share vertices. | +| GWE | DISU | OPTIONS | LENGTH_UNITS | STRING | is the length units used for this model. Values can be ``FEET'', ``METERS'', or ``CENTIMETERS''. If not specified, the default is ``UNKNOWN''. | +| GWE | DISU | OPTIONS | NOGRB | KEYWORD | keyword to deactivate writing of the binary grid file. | +| GWE | DISU | OPTIONS | XORIGIN | DOUBLE PRECISION | x-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. A default value of zero is assigned if not specified. The value for XORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DISU | OPTIONS | YORIGIN | DOUBLE PRECISION | y-position of the origin used for model grid vertices. This value should be provided in a real-world coordinate system. If not specified, then a default value equal to zero is used. The value for YORIGIN does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DISU | OPTIONS | ANGROT | DOUBLE PRECISION | counter-clockwise rotation angle (in degrees) of the model grid coordinate system relative to a real-world coordinate system. If not specified, then a default value of 0.0 is assigned. The value for ANGROT does not affect the model simulation, but it is written to the binary grid file so that postprocessors can locate the grid in space. | +| GWE | DISU | OPTIONS | VERTICAL_OFFSET_TOLERANCE | DOUBLE PRECISION | checks are performed to ensure that the top of a cell is not higher than the bottom of an overlying cell. This option can be used to specify the tolerance that is used for checking. If top of a cell is above the bottom of an overlying cell by a value less than this tolerance, then the program will not terminate with an error. The default value is zero. This option should generally not be used. | +| GWE | DISU | DIMENSIONS | NODES | INTEGER | is the number of cells in the model grid. | +| GWE | DISU | DIMENSIONS | NJA | INTEGER | is the sum of the number of connections and NODES. When calculating the total number of connections, the connection between cell n and cell m is considered to be different from the connection between cell m and cell n. Thus, NJA is equal to the total number of connections, including n to m and m to n, and the total number of cells. | +| GWE | DISU | DIMENSIONS | NVERT | INTEGER | is the total number of (x, y) vertex pairs used to define the plan-view shape of each cell in the model grid. If NVERT is not specified or is specified as zero, then the VERTICES and CELL2D blocks below are not read. NVERT and the accompanying VERTICES and CELL2D blocks should be specified for most simulations. If the XT3D or SAVE\_SPECIFIC\_DISCHARGE options are specified in the NPF Package, then this information is required. | +| GWE | DISU | GRIDDATA | TOP | DOUBLE PRECISION (NODES) | is the top elevation for each cell in the model grid. | +| GWE | DISU | GRIDDATA | BOT | DOUBLE PRECISION (NODES) | is the bottom elevation for each cell. | +| GWE | DISU | GRIDDATA | AREA | DOUBLE PRECISION (NODES) | is the cell surface area (in plan view). | +| GWE | DISU | GRIDDATA | IDOMAIN | INTEGER (NODES) | is an optional array that characterizes the existence status of a cell. If the IDOMAIN array is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0, the cell does not exist in the simulation. Input and output values will be read and written for the cell, but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell is 1 or greater, the cell exists in the simulation. IDOMAIN values of -1 cannot be specified for the DISU Package. | +| GWE | DISU | CONNECTIONDATA | IAC | INTEGER (NODES) | is the number of connections (plus 1) for each cell. The sum of all the entries in IAC must be equal to NJA. | +| GWE | DISU | CONNECTIONDATA | JA | INTEGER (NJA) | is a list of cell number (n) followed by its connecting cell numbers (m) for each of the m cells connected to cell n. The number of values to provide for cell n is IAC(n). This list is sequentially provided for the first to the last cell. The first value in the list must be cell n itself, and the remaining cells must be listed in an increasing order (sorted from lowest number to highest). Note that the cell and its connections are only supplied for the GWE cells and their connections to the other GWE cells. Also note that the JA list input may be divided such that every node and its connectivity list can be on a separate line for ease in readability of the file. To further ease readability of the file, the node number of the cell whose connectivity is subsequently listed, may be expressed as a negative number, the sign of which is subsequently converted to positive by the code. | +| GWE | DISU | CONNECTIONDATA | IHC | INTEGER (NJA) | is an index array indicating the direction between node n and all of its m connections. If IHC = 0 then cell n and cell m are connected in the vertical direction. Cell n overlies cell m if the cell number for n is less than m; cell m overlies cell n if the cell number for m is less than n. If IHC = 1 then cell n and cell m are connected in the horizontal direction. If IHC = 2 then cell n and cell m are connected in the horizontal direction, and the connection is vertically staggered. A vertically staggered connection is one in which a cell is horizontally connected to more than one cell in a horizontal connection. | +| GWE | DISU | CONNECTIONDATA | CL12 | DOUBLE PRECISION (NJA) | is the array containing connection lengths between the center of cell n and the shared face with each adjacent m cell. | +| GWE | DISU | CONNECTIONDATA | HWVA | DOUBLE PRECISION (NJA) | is a symmetric array of size NJA. For horizontal connections, entries in HWVA are the horizontal width perpendicular to flow. For vertical connections, entries in HWVA are the vertical area for flow. Thus, values in the HWVA array contain dimensions of both length and area. Entries in the HWVA array have a one-to-one correspondence with the connections specified in the JA array. Likewise, there is a one-to-one correspondence between entries in the HWVA array and entries in the IHC array, which specifies the connection type (horizontal or vertical). Entries in the HWVA array must be symmetric; the program will terminate with an error if the value for HWVA for an n to m connection does not equal the value for HWVA for the corresponding n to m connection. | +| GWE | DISU | CONNECTIONDATA | ANGLDEGX | DOUBLE PRECISION (NJA) | is the angle (in degrees) between the horizontal x-axis and the outward normal to the face between a cell and its connecting cells. The angle varies between zero and 360.0 degrees, where zero degrees points in the positive x-axis direction, and 90 degrees points in the positive y-axis direction. ANGLDEGX is only needed if horizontal anisotropy is specified in the NPF Package, if the XT3D option is used in the NPF Package, or if the SAVE\_SPECIFIC\_DISCHARGE option is specifed in the NPF Package. ANGLDEGX does not need to be specified if these conditions are not met. ANGLDEGX is of size NJA; values specified for vertical connections and for the diagonal position are not used. Note that ANGLDEGX is read in degrees, which is different from MODFLOW-USG, which reads a similar variable (ANGLEX) in radians. | +| GWE | DISU | VERTICES | IV | INTEGER | is the vertex number. Records in the VERTICES block must be listed in consecutive order from 1 to NVERT. | +| GWE | DISU | VERTICES | XV | DOUBLE PRECISION | is the x-coordinate for the vertex. | +| GWE | DISU | VERTICES | YV | DOUBLE PRECISION | is the y-coordinate for the vertex. | +| GWE | DISU | CELL2D | ICELL2D | INTEGER | is the cell2d number. Records in the CELL2D block must be listed in consecutive order from 1 to NODES. | +| GWE | DISU | CELL2D | XC | DOUBLE PRECISION | is the x-coordinate for the cell center. | +| GWE | DISU | CELL2D | YC | DOUBLE PRECISION | is the y-coordinate for the cell center. | +| GWE | DISU | CELL2D | NCVERT | INTEGER | is the number of vertices required to define the cell. There may be a different number of vertices for each cell. | +| GWE | DISU | CELL2D | ICVERT | INTEGER (NCVERT) | is an array of integer values containing vertex numbers (in the VERTICES block) used to define the cell. Vertices must be listed in clockwise order. | | GWE | DSP | OPTIONS | XT3D_OFF | KEYWORD | deactivate the xt3d method and use the faster and less accurate approximation. This option may provide a fast and accurate solution under some circumstances, such as when flow aligns with the model grid, there is no mechanical dispersion, or when the longitudinal and transverse dispersivities are equal. This option may also be used to assess the computational demand of the XT3D approach by noting the run time differences with and without this option on. | | GWE | DSP | OPTIONS | XT3D_RHS | KEYWORD | add xt3d terms to right-hand side, when possible. This option uses less memory, but may require more iterations. | -| GWE | DSP | GRIDDATA | DIFFC | DOUBLE PRECISION (NODES) | effective molecular diffusion coefficient. | | GWE | DSP | GRIDDATA | ALH | DOUBLE PRECISION (NODES) | longitudinal dispersivity in horizontal direction. If flow is strictly horizontal, then this is the longitudinal dispersivity that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. | | GWE | DSP | GRIDDATA | ALV | DOUBLE PRECISION (NODES) | longitudinal dispersivity in vertical direction. If flow is strictly vertical, then this is the longitudinal dispsersivity value that will be used. If flow is not strictly horizontal or strictly vertical, then the longitudinal dispersivity is a function of both ALH and ALV. If this value is not specified and mechanical dispersion is represented, then this array is set equal to ALH. | | GWE | DSP | GRIDDATA | ATH1 | DOUBLE PRECISION (NODES) | transverse dispersivity in horizontal direction. This is the transverse dispersivity value for the second ellipsoid axis. If flow is strictly horizontal and directed in the x direction (along a row for a regular grid), then this value controls spreading in the y direction. If mechanical dispersion is represented (by specifying any dispersivity values) then this array is required. | @@ -1251,6 +1295,44 @@ | GWE | FMI | PACKAGEDATA | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | | GWE | FMI | PACKAGEDATA | FNAME | STRING | is the name of the file containing flows. The path to the file should be included if the file is not located in the folder where the program was run. | | GWE | IC | GRIDDATA | STRT | DOUBLE PRECISION (NODES) | is the initial (starting) temperature---that is, the temperature at the beginning of the GWE Model simulation. STRT must be specified for all GWE Model simulations. One value is read for every model cell. | +| GWE | LKE | OPTIONS | FLOW_PACKAGE_NAME | STRING | keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). | +| GWE | LKE | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWE | LKE | OPTIONS | FLOW_PACKAGE_AUXILIARY_NAME | STRING | keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated temperatures from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. | +| GWE | LKE | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of lake cells. | +| GWE | LKE | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of lake information will be written to the listing file immediately after it is read. | +| GWE | LKE | OPTIONS | PRINT_TEMPERATURE | KEYWORD | keyword to indicate that the list of lake temperature will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_TEMPERATURE is specified, then temperature are printed for the last time step of each stress period. | +| GWE | LKE | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of lake flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | +| GWE | LKE | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that lake flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | LKE | OPTIONS | TEMPERATURE | KEYWORD | keyword to specify that record corresponds to temperature. | +| GWE | LKE | OPTIONS | TEMPFILE | STRING | name of the binary output file to write temperature information. | +| GWE | LKE | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | +| GWE | LKE | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWE | LKE | OPTIONS | BUDGETFILE | STRING | name of the binary output file to write budget information. | +| GWE | LKE | OPTIONS | BUDGETCSV | KEYWORD | keyword to specify that record corresponds to the budget CSV. | +| GWE | LKE | OPTIONS | BUDGETCSVFILE | STRING | name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. | +| GWE | LKE | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | +| GWE | LKE | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | +| GWE | LKE | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | +| GWE | LKE | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | +| GWE | LKE | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the LKE package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the LKE package. | +| GWE | LKE | PACKAGEDATA | LAKENO | INTEGER | integer value that defines the lake number associated with the specified PACKAGEDATA data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. Lake information must be specified for every lake or the program will terminate with an error. The program will also terminate with an error if information for a lake is specified more than once. | +| GWE | LKE | PACKAGEDATA | STRT | DOUBLE PRECISION | real value that defines the starting temperature for the lake. | +| GWE | LKE | PACKAGEDATA | KTF | DOUBLE PRECISION | is the thermal conductivity of the of the interface between the aquifer cell and the lake. | +| GWE | LKE | PACKAGEDATA | RBTHCND | DOUBLE PRECISION | real value that defines the thickness of the lakebed material through which conduction occurs. Must be greater than 0. | +| GWE | LKE | PACKAGEDATA | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each lake. The values of auxiliary variables must be present for each lake. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | LKE | PACKAGEDATA | BOUNDNAME | STRING | name of the lake cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | +| GWE | LKE | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | +| GWE | LKE | PERIOD | LAKENO | INTEGER | integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. | +| GWE | LKE | PERIOD | LAKSETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated temperature of the lake. | +| GWE | LKE | PERIOD | STATUS | STRING | keyword option to define lake status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the lake. If a lake is inactive, then there will be no solute mass fluxes into or out of the lake and the inactive value will be written for the lake temperature. If a lake is constant, then the temperature for the lake will be fixed at the user specified value. | +| GWE | LKE | PERIOD | TEMPERATURE | STRING | real or character value that defines the temperature for the lake. The specified TEMPERATURE is only applied if the lake is a constant temperature lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | LKE | PERIOD | RAINFALL | STRING | real or character value that defines the rainfall temperature for the lake. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | LKE | PERIOD | EVAPORATION | STRING | real or character value that defines the temperature of evaporated water $(^{\circ}C)$ for the reach. If this temperature value is larger than the simulated temperature in the reach, then the evaporated water will be removed at the same temperature as the reach. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | LKE | PERIOD | RUNOFF | STRING | real or character value that defines the temperature of runoff for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | LKE | PERIOD | EXT-INFLOW | STRING | real or character value that defines the temperature of external inflow for the lake. Value must be greater than or equal to zero. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | LKE | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | +| GWE | LKE | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | +| GWE | LKE | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWE | MST | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that MST flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | | GWE | MST | OPTIONS | FIRST_ORDER_DECAY | KEYWORD | is a text keyword to indicate that first-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. | | GWE | MST | OPTIONS | ZERO_ORDER_DECAY | KEYWORD | is a text keyword to indicate that zero-order decay will occur. Use of this keyword requires that DECAY and DECAY\_SORBED (if sorption is active) are specified in the GRIDDATA block. | @@ -1262,6 +1344,49 @@ | GWE | MST | PACKAGEDATA | CPW | DOUBLE PRECISION | is the mass-based heat capacity of water. Thus, enter value in units of J/kg/C. | | GWE | MST | PACKAGEDATA | RHOW | DOUBLE PRECISION | is a user-specified value of the density of water. Value will remain fixed for the entire simulation. For now, enter the value in SI units: kg/m3 | | GWE | MST | PACKAGEDATA | LATHEATVAP | DOUBLE PRECISION | is the user-specified value for the latent heat of vaporization. Currently, it may be specified spatially to facilitate temperature-dependent alterations in its value, though this functionality needs to be re-thought (perhaps its needs something like the VSC package approach). Typical units are kJ/kg (which is the same as J/g). | +| GWE | MVE | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of mover information will be written to the listing file immediately after it is read. | +| GWE | MVE | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of lake flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | +| GWE | MVE | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that lake flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | MVE | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | +| GWE | MVE | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWE | MVE | OPTIONS | BUDGETFILE | STRING | name of the binary output file to write budget information. | +| GWE | MVE | OPTIONS | BUDGETCSV | KEYWORD | keyword to specify that record corresponds to the budget CSV. | +| GWE | MVE | OPTIONS | BUDGETCSVFILE | STRING | name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. | +| GWE | MWE | OPTIONS | FLOW_PACKAGE_NAME | STRING | keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWE name file). | +| GWE | MWE | OPTIONS | AUXILIARY | STRING (NAUX) | defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. | +| GWE | MWE | OPTIONS | FLOW_PACKAGE_AUXILIARY_NAME | STRING | keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated temperatures from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. | +| GWE | MWE | OPTIONS | BOUNDNAMES | KEYWORD | keyword to indicate that boundary names may be provided with the list of well cells. | +| GWE | MWE | OPTIONS | PRINT_INPUT | KEYWORD | keyword to indicate that the list of well information will be written to the listing file immediately after it is read. | +| GWE | MWE | OPTIONS | PRINT_TEMPERATURE | KEYWORD | keyword to indicate that the list of well temperature will be printed to the listing file for every stress period in which ``TEMPERATURE PRINT'' is specified in Output Control. If there is no Output Control option and PRINT\_TEMPERATURE is specified, then temperature are printed for the last time step of each stress period. | +| GWE | MWE | OPTIONS | PRINT_FLOWS | KEYWORD | keyword to indicate that the list of well flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. | +| GWE | MWE | OPTIONS | SAVE_FLOWS | KEYWORD | keyword to indicate that well flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. | +| GWE | MWE | OPTIONS | TEMPERATURE | KEYWORD | keyword to specify that record corresponds to temperature. | +| GWE | MWE | OPTIONS | TEMPFILE | STRING | name of the binary output file to write temperature information. | +| GWE | MWE | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | +| GWE | MWE | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | +| GWE | MWE | OPTIONS | BUDGETFILE | STRING | name of the binary output file to write budget information. | +| GWE | MWE | OPTIONS | BUDGETCSV | KEYWORD | keyword to specify that record corresponds to the budget CSV. | +| GWE | MWE | OPTIONS | BUDGETCSVFILE | STRING | name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. | +| GWE | MWE | OPTIONS | TS6 | KEYWORD | keyword to specify that record corresponds to a time-series file. | +| GWE | MWE | OPTIONS | FILEIN | KEYWORD | keyword to specify that an input filename is expected next. | +| GWE | MWE | OPTIONS | TS6_FILENAME | STRING | defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. | +| GWE | MWE | OPTIONS | OBS6 | KEYWORD | keyword to specify that record corresponds to an observations file. | +| GWE | MWE | OPTIONS | OBS6_FILENAME | STRING | name of input file to define observations for the MWE package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the MWE package. | +| GWE | MWE | PACKAGEDATA | MAWNO | INTEGER | integer value that defines the well number associated with the specified PACKAGEDATA data on the line. MAWNO must be greater than zero and less than or equal to NMAWWELLS. Well information must be specified for every well or the program will terminate with an error. The program will also terminate with an error if information for a well is specified more than once. | +| GWE | MWE | PACKAGEDATA | STRT | DOUBLE PRECISION | real value that defines the starting temperature for the well. | +| GWE | MWE | PACKAGEDATA | KTF | DOUBLE PRECISION | is the thermal conductivity of the of the interface between the aquifer cell and the feature. | +| GWE | MWE | PACKAGEDATA | FTHK | DOUBLE PRECISION | real value that defines the thickness of the material through which conduction occurs. Must be greater than 0. | +| GWE | MWE | PACKAGEDATA | AUX | DOUBLE PRECISION (NAUX) | represents the values of the auxiliary variables for each well. The values of auxiliary variables must be present for each well. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | MWE | PACKAGEDATA | BOUNDNAME | STRING | name of the well cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. | +| GWE | MWE | PERIOD | IPER | INTEGER | integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. | +| GWE | MWE | PERIOD | MAWNO | INTEGER | integer value that defines the well number associated with the specified PERIOD data on the line. MAWNO must be greater than zero and less than or equal to NMAWWELLS. | +| GWE | MWE | PERIOD | MWESETTING | KEYSTRING | line of information that is parsed into a keyword and values. Keyword values that can be used to start the MWESETTING string include: STATUS, TEMPERATURE, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the temperature of associated with the corresponding flow terms. Temperatures cannot be specified for all flow terms. For example, the Multi-Aquifer Well Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the well at the calculated temperature of the well. | +| GWE | MWE | PERIOD | STATUS | STRING | keyword option to define well status. STATUS can be ACTIVE, INACTIVE, or CONSTANT. By default, STATUS is ACTIVE, which means that temperature will be calculated for the well. If a well is inactive, then there will be no solute mass fluxes into or out of the well and the inactive value will be written for the well temperature. If a well is constant, then the temperature for the well will be fixed at the user specified value. | +| GWE | MWE | PERIOD | TEMPERATURE | STRING | real or character value that defines the temperature for the well. The specified TEMPERATURE is only applied if the well is a constant temperature well. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | MWE | PERIOD | RATE | STRING | real or character value that defines the injection solute temperature $^{\circ}C$ for the well. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | +| GWE | MWE | PERIOD | AUXILIARY | KEYWORD | keyword for specifying auxiliary variable. | +| GWE | MWE | PERIOD | AUXNAME | STRING | name for the auxiliary variable to be assigned AUXVAL. AUXNAME must match one of the auxiliary variable names defined in the OPTIONS block. If AUXNAME does not match one of the auxiliary variable names defined in the OPTIONS block the data are ignored. | +| GWE | MWE | PERIOD | AUXVAL | DOUBLE PRECISION | value for the auxiliary variable. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value. | | GWE | OC | OPTIONS | BUDGET | KEYWORD | keyword to specify that record corresponds to the budget. | | GWE | OC | OPTIONS | FILEOUT | KEYWORD | keyword to specify that an output filename is expected next. | | GWE | OC | OPTIONS | BUDGETFILE | STRING | name of the output file to write budget information. | @@ -1285,7 +1410,7 @@ | GWE | OC | PERIOD | FREQUENCY | INTEGER | save at the specified time step frequency. This keyword may be used in conjunction with other keywords to print or save results for multiple time steps. | | GWE | OC | PERIOD | STEPS | INTEGER ($ 0, or it is the area perpendicular to flow of the vertical connection between cell 1 and cell 2 if IHC = 0. + +\item \texttt{aux}---represents the values of the auxiliary variables for each GWEGWE Exchange. The values of auxiliary variables must be present for each exchange. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. + +\item \texttt{boundname}---name of the GWE Exchange cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/exg-gwegwe-dimensions.dat b/doc/mf6io/mf6ivar/tex/exg-gwegwe-dimensions.dat new file mode 100644 index 00000000000..405fdc5cdf7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/exg-gwegwe-dimensions.dat @@ -0,0 +1,3 @@ +BEGIN DIMENSIONS + NEXG +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/exg-gwegwe-exchangedata.dat b/doc/mf6io/mf6ivar/tex/exg-gwegwe-exchangedata.dat new file mode 100644 index 00000000000..c11fc9ce016 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/exg-gwegwe-exchangedata.dat @@ -0,0 +1,5 @@ +BEGIN EXCHANGEDATA + [] [] + [] [] + ... +END EXCHANGEDATA diff --git a/doc/mf6io/mf6ivar/tex/exg-gwegwe-options.dat b/doc/mf6io/mf6ivar/tex/exg-gwegwe-options.dat new file mode 100644 index 00000000000..0d6e40d9fd7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/exg-gwegwe-options.dat @@ -0,0 +1,14 @@ +BEGIN OPTIONS + GWFMODELNAME1 + GWFMODELNAME2 + [AUXILIARY ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_FLOWS] + [SAVE_FLOWS] + [ADV_SCHEME ] + [DSP_XT3D_OFF] + [DSP_XT3D_RHS] + [MVT6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/exg-gwfgwe-desc.tex b/doc/mf6io/mf6ivar/tex/exg-gwfgwe-desc.tex new file mode 100644 index 00000000000..bf95ac4119f --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/exg-gwfgwe-desc.tex @@ -0,0 +1,3 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + + diff --git a/doc/mf6io/mf6ivar/tex/gwe-cnc-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-cnc-desc.tex new file mode 100644 index 00000000000..adda7d48fd1 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-cnc-desc.tex @@ -0,0 +1,49 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. + +\item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of temperature value. + +\item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of constant temperature cells. + +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of constant temperature information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of constant temperature flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that constant temperature flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{TS6}---keyword to specify that record corresponds to a time-series file. + +\item \texttt{FILEIN}---keyword to specify that an input filename is expected next. + +\item \texttt{ts6\_filename}---defines a time-series file defining time series that can be used to assign time-varying values. See the ``Time-Variable Input'' section for instructions on using the time-series capability. + +\item \texttt{OBS6}---keyword to specify that record corresponds to an observations file. + +\item \texttt{obs6\_filename}---name of input file to define observations for the Constant Temperature package. See the ``Observation utility'' section for instructions for preparing observation input files. Tables \ref{table:gwf-obstypetable} and \ref{table:gwt-obstypetable} lists observation type(s) supported by the Constant Temperature package. + +\end{description} +\item \textbf{Block: DIMENSIONS} + +\begin{description} +\item \texttt{maxbound}---integer value specifying the maximum number of constant temperatures cells that will be specified for use during any stress period. + +\end{description} +\item \textbf{Block: PERIOD} + +\begin{description} +\item \texttt{iper}---integer value specifying the starting stress period number for which the data specified in the PERIOD block apply. IPER must be less than or equal to NPER in the TDIS Package and greater than zero. The IPER value assigned to a stress period block must be greater than the IPER value assigned for the previous PERIOD block. The information specified in the PERIOD block will continue to apply for all subsequent stress periods, unless the program encounters another PERIOD block. + +\item \texttt{cellid}---is the cell identifier, and depends on the type of grid that is used for the simulation. For a structured grid that uses the DIS input file, CELLID is the layer, row, and column. For a grid that uses the DISV input file, CELLID is the layer and CELL2D number. If the model uses the unstructured discretization (DISU) input file, CELLID is the node number for the cell. + +\item \textcolor{blue}{\texttt{temp}---is the constant temperature value. If the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \textcolor{blue}{\texttt{aux}---represents the values of the auxiliary variables for each constant temperature. The values of auxiliary variables must be present for each constant temperature. The values must be specified in the order of the auxiliary variables specified in the OPTIONS block. If the package supports time series and the Options block includes a TIMESERIESFILE entry (see the ``Time-Variable Input'' section), values can be obtained from a time series by entering the time-series name in place of a numeric value.} + +\item \texttt{boundname}---name of the constant temperature cell. BOUNDNAME is an ASCII character variable that can contain as many as 40 characters. If BOUNDNAME contains spaces in it, then the entire name must be enclosed within single quotes. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-cnc-dimensions.dat b/doc/mf6io/mf6ivar/tex/gwe-cnc-dimensions.dat new file mode 100644 index 00000000000..7b4c7bf6ec7 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-cnc-dimensions.dat @@ -0,0 +1,3 @@ +BEGIN DIMENSIONS + MAXBOUND +END DIMENSIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-cnc-options.dat b/doc/mf6io/mf6ivar/tex/gwe-cnc-options.dat new file mode 100644 index 00000000000..0985bd51e40 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-cnc-options.dat @@ -0,0 +1,10 @@ +BEGIN OPTIONS + [AUXILIARY ] + [AUXMULTNAME ] + [BOUNDNAMES] + [PRINT_INPUT] + [PRINT_FLOWS] + [SAVE_FLOWS] + [TS6 FILEIN ] + [OBS6 FILEIN ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwe-cnc-period.dat b/doc/mf6io/mf6ivar/tex/gwe-cnc-period.dat new file mode 100644 index 00000000000..71db20fc4ec --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-cnc-period.dat @@ -0,0 +1,5 @@ +BEGIN PERIOD + <@temp@> [<@aux(naux)@>] [] + <@temp@> [<@aux(naux)@>] [] + ... +END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwe-mve-desc.tex b/doc/mf6io/mf6ivar/tex/gwe-mve-desc.tex new file mode 100644 index 00000000000..faae2d20ff4 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mve-desc.tex @@ -0,0 +1,23 @@ +% DO NOT MODIFY THIS FILE DIRECTLY. IT IS CREATED BY mf6ivar.py + +\item \textbf{Block: OPTIONS} + +\begin{description} +\item \texttt{PRINT\_INPUT}---keyword to indicate that the list of mover information will be written to the listing file immediately after it is read. + +\item \texttt{PRINT\_FLOWS}---keyword to indicate that the list of lake flow rates will be printed to the listing file for every stress period time step in which ``BUDGET PRINT'' is specified in Output Control. If there is no Output Control option and ``PRINT\_FLOWS'' is specified, then flow rates are printed for the last time step of each stress period. + +\item \texttt{SAVE\_FLOWS}---keyword to indicate that lake flow terms will be written to the file specified with ``BUDGET FILEOUT'' in Output Control. + +\item \texttt{BUDGET}---keyword to specify that record corresponds to the budget. + +\item \texttt{FILEOUT}---keyword to specify that an output filename is expected next. + +\item \texttt{budgetfile}---name of the binary output file to write budget information. + +\item \texttt{BUDGETCSV}---keyword to specify that record corresponds to the budget CSV. + +\item \texttt{budgetcsvfile}---name of the comma-separated value (CSV) output file to write budget summary information. A budget summary record will be written to this file for each time step of the simulation. + +\end{description} + diff --git a/doc/mf6io/mf6ivar/tex/gwe-mve-options.dat b/doc/mf6io/mf6ivar/tex/gwe-mve-options.dat new file mode 100644 index 00000000000..7b9ca2ed7b1 --- /dev/null +++ b/doc/mf6io/mf6ivar/tex/gwe-mve-options.dat @@ -0,0 +1,7 @@ +BEGIN OPTIONS + [PRINT_INPUT] + [PRINT_FLOWS] + [SAVE_FLOWS] + [BUDGET FILEOUT ] + [BUDGETCSV FILEOUT ] +END OPTIONS diff --git a/doc/mf6io/mf6ivar/tex/gwf-chd-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-chd-desc.tex index eb5be079cd5..81d23b4605d 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-chd-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-chd-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of CHD head value. diff --git a/doc/mf6io/mf6ivar/tex/gwf-drn-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-drn-desc.tex index d8234a8be3a..b2690eb7533 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-drn-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-drn-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of drain conductance. diff --git a/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex index 036cc53ff2b..cfa1073192c 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-evt-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{FIXED\_CELL}---indicates that evapotranspiration will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of evapotranspiration rate. diff --git a/doc/mf6io/mf6ivar/tex/gwf-evta-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-evta-desc.tex index 3dbded6c6c1..a59cb1c60ca 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-evta-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-evta-desc.tex @@ -7,7 +7,7 @@ \item \texttt{FIXED\_CELL}---indicates that evapotranspiration will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of evapotranspiration rate. diff --git a/doc/mf6io/mf6ivar/tex/gwf-ghb-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-ghb-desc.tex index 0abcadc0b74..49ef5c397bd 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-ghb-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-ghb-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of general-head boundary conductance. diff --git a/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex index ad5ac4b7d71..cc28e23caed 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-lak-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of lake cells. diff --git a/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex index abb1023e655..48ddd8ee4f1 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-maw-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of multi-aquifer well cells. diff --git a/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex index 12a359075e8..60c0acbaeb2 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-rch-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{FIXED\_CELL}---indicates that recharge will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of recharge. diff --git a/doc/mf6io/mf6ivar/tex/gwf-rcha-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-rcha-desc.tex index c8ed6e6cda9..11fae1cce33 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-rcha-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-rcha-desc.tex @@ -7,7 +7,7 @@ \item \texttt{FIXED\_CELL}---indicates that recharge will not be reassigned to a cell underlying the cell specified in the list if the specified cell is inactive. -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of recharge. diff --git a/doc/mf6io/mf6ivar/tex/gwf-riv-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-riv-desc.tex index 910dc777224..2763254e5cd 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-riv-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-riv-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of riverbed conductance. diff --git a/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex index b0664a7f91f..8be23a066ce 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-sfr-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{BOUNDNAMES}---keyword to indicate that boundary names may be provided with the list of stream reach cells. diff --git a/doc/mf6io/mf6ivar/tex/gwf-sfr-period.dat b/doc/mf6io/mf6ivar/tex/gwf-sfr-period.dat index 06390501c16..40fc6597787 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-sfr-period.dat +++ b/doc/mf6io/mf6ivar/tex/gwf-sfr-period.dat @@ -2,5 +2,4 @@ BEGIN PERIOD ... - CROSS_SECTION TAB6 FILEIN END PERIOD diff --git a/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex index 6bbd3b03034..51ba01473c7 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-uzf-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of GWF cell area used by UZF cell. diff --git a/doc/mf6io/mf6ivar/tex/gwf-wel-desc.tex b/doc/mf6io/mf6ivar/tex/gwf-wel-desc.tex index 5834632c55f..e04235f62bb 100644 --- a/doc/mf6io/mf6ivar/tex/gwf-wel-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwf-wel-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of well flow rate. diff --git a/doc/mf6io/mf6ivar/tex/gwt-cnc-desc.tex b/doc/mf6io/mf6ivar/tex/gwt-cnc-desc.tex index 08306a1d5db..97ebb7b104c 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-cnc-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwt-cnc-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of concentration value. diff --git a/doc/mf6io/mf6ivar/tex/gwt-disv-griddata.dat b/doc/mf6io/mf6ivar/tex/gwt-disv-griddata.dat index a9db9563a42..e263cb1d7bb 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-disv-griddata.dat +++ b/doc/mf6io/mf6ivar/tex/gwt-disv-griddata.dat @@ -2,7 +2,7 @@ BEGIN GRIDDATA TOP -- READARRAY BOTM [LAYERED] - -- READARRAY + -- READARRAY [IDOMAIN [LAYERED] - -- READARRAY] + -- READARRAY] END GRIDDATA diff --git a/doc/mf6io/mf6ivar/tex/gwt-lkt-desc.tex b/doc/mf6io/mf6ivar/tex/gwt-lkt-desc.tex index 29e18ed0fef..9391b8ed74f 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-lkt-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwt-lkt-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. @@ -63,7 +63,7 @@ \item \texttt{lakeno}---integer value that defines the lake number associated with the specified PERIOD data on the line. LAKENO must be greater than zero and less than or equal to NLAKES. -\item \texttt{laksetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, CONCENTRATION, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the concentration of associated with the corresponding flow terms. Concentrations cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated concentration of the lake. +\item \texttt{laksetting}---line of information that is parsed into a keyword and values. Keyword values that can be used to start the LAKSETTING string include: STATUS, CONCENTRATION, RAINFALL, EVAPORATION, RUNOFF, and AUXILIARY. These settings are used to assign the concentration associated with the corresponding flow terms. Concentrations cannot be specified for all flow terms. For example, the Lake Package supports a ``WITHDRAWAL'' flow term. If this withdrawal term is active, then water will be withdrawn from the lake at the calculated concentration of the lake. \begin{lstlisting}[style=blockdefinition] STATUS diff --git a/doc/mf6io/mf6ivar/tex/gwt-mwt-desc.tex b/doc/mf6io/mf6ivar/tex/gwt-mwt-desc.tex index b3bbbc87356..681224671af 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-mwt-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwt-mwt-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. diff --git a/doc/mf6io/mf6ivar/tex/gwt-sft-desc.tex b/doc/mf6io/mf6ivar/tex/gwt-sft-desc.tex index bed98a05116..c6eb62c32f7 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-sft-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwt-sft-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. diff --git a/doc/mf6io/mf6ivar/tex/gwt-src-desc.tex b/doc/mf6io/mf6ivar/tex/gwt-src-desc.tex index d4ff9e3c55c..734708a897e 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-src-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwt-src-desc.tex @@ -3,7 +3,7 @@ \item \textbf{Block: OPTIONS} \begin{description} -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{auxmultname}---name of auxiliary variable to be used as multiplier of mass loading rate. diff --git a/doc/mf6io/mf6ivar/tex/gwt-uzt-desc.tex b/doc/mf6io/mf6ivar/tex/gwt-uzt-desc.tex index aab78138481..5ce6809693e 100644 --- a/doc/mf6io/mf6ivar/tex/gwt-uzt-desc.tex +++ b/doc/mf6io/mf6ivar/tex/gwt-uzt-desc.tex @@ -5,7 +5,7 @@ \begin{description} \item \texttt{flow\_package\_name}---keyword to specify the name of the corresponding flow package. If not specified, then the corresponding flow package must have the same name as this advanced transport package (the name associated with this package in the GWT name file). -\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. +\item \texttt{auxiliary}---defines an array of one or more auxiliary variable names. Auxiliary variable names are limited to 16 characters. There is no limit on the number of auxiliary variables that can be provided on this line; however, lists of information provided in subsequent blocks must have a column of data for each auxiliary variable name defined here. The number of auxiliary variables detected on this line determines the value for naux. Comments cannot be provided anywhere on this line as they will be interpreted as auxiliary variable names. Auxiliary variables may not be used by the package, but they will be available for use by other parts of the program. The program will terminate with an error if auxiliary variables are specified on more than one line in the options block. \item \texttt{flow\_package\_auxiliary\_name}---keyword to specify the name of an auxiliary variable in the corresponding flow package. If specified, then the simulated concentrations from this advanced transport package will be copied into the auxiliary variable specified with this name. Note that the flow package must have an auxiliary variable with this name or the program will terminate with an error. If the flows for this advanced transport package are read from a file, then this option will have no effect. diff --git a/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex b/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex index 3efe21201c4..727842d12da 100644 --- a/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex +++ b/doc/mf6io/mf6ivar/tex/sim-nam-desc.tex @@ -11,6 +11,8 @@ \item \texttt{maxerrors}---maximum number of errors that will be stored and printed. +\item \texttt{PRINT\_INPUT}---keyword to activate printing of simulation input summaries to the simulation list file (mfsim.lst). With this keyword, input summaries will be written for those packages that support newer input data model routines. Not all packages are supported yet by the newer input data model routines. + \end{description} \item \textbf{Block: TIMING} diff --git a/doc/mf6io/mf6ivar/tex/sim-nam-options.dat b/doc/mf6io/mf6ivar/tex/sim-nam-options.dat index 5f007b32f0d..c09288ec1ea 100644 --- a/doc/mf6io/mf6ivar/tex/sim-nam-options.dat +++ b/doc/mf6io/mf6ivar/tex/sim-nam-options.dat @@ -3,4 +3,5 @@ BEGIN OPTIONS [NOCHECK] [MEMORY_PRINT_OPTION ] [MAXERRORS ] + [PRINT_INPUT] END OPTIONS diff --git a/doc/usgs.bst b/doc/usgs.bst new file mode 100644 index 00000000000..326cc9cf966 --- /dev/null +++ b/doc/usgs.bst @@ -0,0 +1,2080 @@ +%% +%% This is file `usgs.bst', +%%% ADAPTED BY MIKE FIENEN FROM agufull08.bst +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% merlin.mbs (with options: `head,ay,nat,seq-labc,nm-rev1,jnrlst,lab,lab-it,keyxyr,blkyear,dt-beg,yr-par,xmth,note-yr,thtit-a,trnum-it,vol-it,volp-com,pgsep-c,num-xser,ser-vol,ser-ed,pg-bk,pg-pre,pre-edn,agu-doi,doi,edpar,bkedcap,edby,blk-com,pp,ed,abr,ednx,xedn,jabr,and-com,em-it,nfss,{}') +%% physjour.mbs (with options: `ay,nat,seq-labc,nm-rev1,jnrlst,lab,lab-it,keyxyr,blkyear,dt-beg,yr-par,xmth,note-yr,thtit-a,trnum-it,vol-it,volp-com,pgsep-c,num-xser,ser-vol,ser-ed,pg-bk,pg-pre,pre-edn,agu-doi,doi,edpar,bkedcap,edby,blk-com,pp,ed,abr,ednx,xedn,jabr,and-com,em-it,nfss,{}') +%% geojour.mbs (with options: `ay,nat,seq-labc,nm-rev1,jnrlst,lab,lab-it,keyxyr,blkyear,dt-beg,yr-par,xmth,note-yr,thtit-a,trnum-it,vol-it,volp-com,pgsep-c,num-xser,ser-vol,ser-ed,pg-bk,pg-pre,pre-edn,agu-doi,doi,edpar,bkedcap,edby,blk-com,pp,ed,abr,ednx,xedn,jabr,and-com,em-it,nfss,{}') +%% photjour.mbs (with options: `ay,nat,seq-labc,nm-rev1,jnrlst,lab,lab-it,keyxyr,blkyear,dt-beg,yr-par,xmth,note-yr,thtit-a,trnum-it,vol-it,volp-com,pgsep-c,num-xser,ser-vol,ser-ed,pg-bk,pg-pre,pre-edn,agu-doi,doi,edpar,bkedcap,edby,blk-com,pp,ed,abr,ednx,xedn,jabr,and-com,em-it,nfss,{}') +%% merlin.mbs (with options: `tail,ay,nat,seq-labc,nm-rev1,jnrlst,lab,lab-it,keyxyr,blkyear,dt-beg,yr-par,xmth,note-yr,thtit-a,trnum-it,vol-it,volp-com,pgsep-c,num-xser,ser-vol,ser-ed,pg-bk,pg-pre,pre-edn,agu-doi,doi,edpar,bkedcap,edby,blk-com,pp,ed,abr,ednx,xedn,jabr,and-com,em-it,nfss,{}') +%% ---------------------------------------- +%% *** For journals of the American Geophysical Union *** +%% *** NOTE: this version does not limit the number of authors in ref list. +%% *** Use agu08.bst to limit authors to maximum 9. +%% *** +%% ---------------------------------------- +%% *** Version 3.1 from 2008/08/27 +%% *** Multiple authors of same first author and year now in order of citation +%% *** and other minor fixes +%% *** Renamed to agu08.bst and agufull08.bst +%% *** +%% *** Version 3.0 from 2004/02/06 +%% *** Changed date format for AGU journals +%% *** The date now appears in parentheses after authors +%% *** +%% *** Version 2.2 from 2003/06/26 +%% *** (with bug fix from 2003/08/19) +%% *** Includes new fields eid and doi +%% *** The eid is what the AGU calls "citation number" +%% *** and doi is the DOI number; both of these are +%% *** used as substitution for page number +%% *** The issue number is now also included as +%% *** 84(3) for vol. 84, nr. 3 +%% *** +%% *** Version 2.1d from 1999/05/20 +%% *** Book editors done right as P. James (Ed.), +%% *** Missing italics with some authors fixed +%% *** +%% *** Version 2.1c from 1999/02/11 +%% *** This version does not crash older BibTeX installations with +%% *** more than 3000 wiz-functions +%% *** +%% *** Version 2.1b from 1997/11/18 +%% *** (page numbers over 9999 are broken with commas, as 12,345) +%% *** +%% *** Version 2.1a from 1997/05/26 +%% *** (contains improvements from copy editor comments, +%% *** notes added with first word lowercase (bug in 2.1 fixed) +%% *** and journal `number' never output +%% *** abbreviation for grl corrected) +%% *** +%% +%% Copyright 1994-2008 Patrick W Daly + % =============================================================== + % IMPORTANT NOTICE: + % This bibliographic style (bst) file has been generated from one or + % more master bibliographic style (mbs) files, listed above. + % + % This generated file can be redistributed and/or modified under the terms + % of the LaTeX Project Public License Distributed from CTAN + % archives in directory macros/latex/base/lppl.txt; either + % version 1 of the License, or any later version. + % =============================================================== + % Name and version information of the main mbs file: + % \ProvidesFile{merlin.mbs}[2008/08/27 4.30 (PWD, AO, DPC)] + % For use with BibTeX version 0.99a or later + %------------------------------------------------------------------- + % This bibliography style file is intended for texts in ENGLISH + % This is an author-year citation style bibliography. As such, it is + % non-standard LaTeX, and requires a special package file to function properly. + % Such a package is natbib.sty by Patrick W. Daly + % The form of the \bibitem entries is + % \bibitem[Jones et al.(1990)]{key}... + % \bibitem[Jones et al.(1990)Jones, Baker, and Smith]{key}... + % The essential feature is that the label (the part in brackets) consists + % of the author names, as they should appear in the citation, with the year + % in parentheses following. There must be no space before the opening + % parenthesis! + % With natbib v5.3, a full list of authors may also follow the year. + % In natbib.sty, it is possible to define the type of enclosures that is + % really wanted (brackets or parentheses), but in either case, there must + % be parentheses in the label. + % The \cite command functions as follows: + % \citet{key} ==>> Jones et al. (1990) + % \citet*{key} ==>> Jones, Baker, and Smith (1990) + % \citep{key} ==>> (Jones et al., 1990) + % \citep*{key} ==>> (Jones, Baker, and Smith, 1990) + % \citep[chap. 2]{key} ==>> (Jones et al., 1990, chap. 2) + % \citep[e.g.][]{key} ==>> (e.g. Jones et al., 1990) + % \citep[e.g.][p. 32]{key} ==>> (e.g. Jones et al., 1990, p. 32) + % \citeauthor{key} ==>> Jones et al. + % \citeauthor*{key} ==>> Jones, Baker, and Smith + % \citeyear{key} ==>> 1990 + %--------------------------------------------------------------------- + +ENTRY + { address + author + booktitle + chapter + doi + urldate + url + urllink + edition + editor + eid + howpublished + institution + journal + key + month + note + number + organization + pages + publisher + school + series + title + type + volume + year + } + {} + { label extra.label sort.label short.list } +INTEGERS { output.state before.all mid.sentence after.sentence after.block } +FUNCTION {init.state.consts} +{ #0 'before.all := + #1 'mid.sentence := + #2 'after.sentence := + #3 'after.block := +} +STRINGS { s t} +FUNCTION {output.nonnull} +{ 's := + output.state mid.sentence = + { ", " * write$ } + { output.state after.block = + { add.period$ write$ + newline$ + "\newblock " write$ + } + { output.state before.all = + 'write$ + { add.period$ " " * write$ } + if$ + } + if$ + mid.sentence 'output.state := + } + if$ + s +} +FUNCTION {outputc.nonnull} +{ 's := + output.state mid.sentence = + { ": " * write$ } + { output.state after.block = + { add.period$ write$ + newline$ + "\newblock " write$ + } + { output.state before.all = + 'write$ + { add.period$ " " * write$ } + if$ + } + if$ + mid.sentence 'output.state := + } + if$ + s +} +FUNCTION {output} +{ duplicate$ empty$ + 'pop$ + 'output.nonnull + if$ +} +FUNCTION {outputc} +{ duplicate$ empty$ + 'pop$ + 'outputc.nonnull + if$ +} +FUNCTION {output.check} +{ 't := + duplicate$ empty$ + { pop$ "empty " t * " in " * cite$ * warning$ } + 'output.nonnull + if$ +} +FUNCTION {outputc.check} +{ 't := + duplicate$ empty$ + { pop$ "empty " t * " in " * cite$ * warning$ } + 'outputc.nonnull + if$ +} +FUNCTION {fin.entry} +{ add.period$ + write$ + newline$ +} + +FUNCTION {new.block} +{ output.state before.all = + 'skip$ + { after.block 'output.state := } + if$ +} +FUNCTION {new.sentence} +{ output.state after.block = + 'skip$ + { output.state before.all = + 'skip$ + { after.sentence 'output.state := } + if$ + } + if$ +} +FUNCTION {add.blank} +{ " " * before.all 'output.state := +} + +FUNCTION {date.block} +{ + skip$ +} + +FUNCTION {not} +{ { #0 } + { #1 } + if$ +} +FUNCTION {and} +{ 'skip$ + { pop$ #0 } + if$ +} +FUNCTION {or} +{ { pop$ #1 } + 'skip$ + if$ +} +FUNCTION {new.block.checkb} +{ empty$ + swap$ empty$ + and + 'skip$ + 'new.block + if$ +} +FUNCTION {field.or.null} +{ duplicate$ empty$ + { pop$ "" } + 'skip$ + if$ +} +FUNCTION {emphasize} +{ duplicate$ empty$ + { pop$ "" } + { "\textit{" swap$ * "}" * } + if$ +} +FUNCTION {cite.name.font} +%{ emphasize } +{ } +FUNCTION {tie.or.space.prefix} +{ duplicate$ text.length$ #3 < + { "~" } + { " " } + if$ + swap$ +} + +FUNCTION {capitalize} +{ "u" change.case$ "t" change.case$ } + +FUNCTION {space.word} +{ " " swap$ * " " * } + % Here are the language-specific definitions for explicit words. + % Each function has a name bbl.xxx where xxx is the English word. + % The language selected here is ENGLISH +FUNCTION {bbl.and} +{ "and" } + +FUNCTION {bbl.etal} +{ "and others" } + +FUNCTION {bbl.andothers} +{ "and others" } + +FUNCTION {bbl.editors} +{ "eds." } + +FUNCTION {bbl.editor} +{ "ed." } + +FUNCTION {bbl.edby} +{ "edited by" } + +FUNCTION {bbl.edition} +{ "ed." } + +FUNCTION {bbl.volume} +{ "v." } + +FUNCTION {bbl.of} +{ "of" } + +FUNCTION {bbl.number} +{ "no." } + +FUNCTION {bbl.nr} +{ "no." } + +FUNCTION {bbl.in} +{ "\emph{in}" } + +FUNCTION {bbl.pages} +{ "p." } + +FUNCTION {bbl.page} +{ "p." } + +FUNCTION {bbl.chapter} +{ "Chap." } + +FUNCTION {bbl.techrep} +%{ "Tech. Rep." } REMOVE THE TECH REPORT WORDS FOR USGS +{""} +FUNCTION {bbl.mthesis} +{ "M.S. thesis" } + +FUNCTION {bbl.phdthesis} +{ "Ph.D. thesis" } + +MACRO {jan} {"Jan."} + +MACRO {feb} {"Feb."} + +MACRO {mar} {"Mar."} + +MACRO {apr} {"Apr."} + +MACRO {may} {"May"} + +MACRO {jun} {"Jun."} + +MACRO {jul} {"Jul."} + +MACRO {aug} {"Aug."} + +MACRO {sep} {"Sep."} + +MACRO {oct} {"Oct."} + +MACRO {nov} {"Nov."} + +MACRO {dec} {"Dec."} + + %------------------------------------------------------------------- + % Begin module: + % \ProvidesFile{physjour.mbs}[2002/01/14 2.2 (PWD)] +MACRO {aa}{"Astron. \& Astrophys."} +MACRO {aasup}{"Astron. \& Astrophys. Suppl. Ser."} +MACRO {aj} {"Astron. J."} +MACRO {aph} {"Acta Phys."} +MACRO {advp} {"Adv. Phys."} +MACRO {ajp} {"Amer. J. Phys."} +MACRO {ajm} {"Amer. J. Math."} +MACRO {amsci} {"Amer. Sci."} +MACRO {anofd} {"Ann. Fluid Dyn."} +MACRO {am} {"Ann. Math."} +MACRO {ap} {"Ann. Phys. (NY)"} +MACRO {adp} {"Ann. Phys. (Leipzig)"} +MACRO {ao} {"Appl. Opt."} +MACRO {apl} {"Appl. Phys. Lett."} +MACRO {app} {"Astroparticle Phys."} +MACRO {apj} {"Astrophys. J."} +MACRO {apjsup} {"Astrophys. J. Suppl."} +MACRO {apss} {"Astrophys. Space Sci."} +MACRO {araa} {"Ann. Rev. Astron. Astrophys."} +MACRO {baas} {"Bull. Amer. Astron. Soc."} +MACRO {baps} {"Bull. Amer. Phys. Soc."} +MACRO {cmp} {"Comm. Math. Phys."} +MACRO {cpam} {"Commun. Pure Appl. Math."} +MACRO {cppcf} {"Comm. Plasma Phys. \& Controlled Fusion"} +MACRO {cpc} {"Comp. Phys. Comm."} +MACRO {cqg} {"Class. Quant. Grav."} +MACRO {cra} {"C. R. Acad. Sci. A"} +MACRO {fed} {"Fusion Eng. \& Design"} +MACRO {ft} {"Fusion Tech."} +MACRO {grg} {"Gen. Relativ. Gravit."} +MACRO {ieeens} {"IEEE Trans. Nucl. Sci."} +MACRO {ieeeps} {"IEEE Trans. Plasma Sci."} +MACRO {ijimw} {"Interntl. J. Infrared \& Millimeter Waves"} +MACRO {ip} {"Infrared Phys."} +MACRO {irp} {"Infrared Phys."} +MACRO {jap} {"J. Appl. Phys."} +MACRO {jasa} {"J. Acoust. Soc. America"} +MACRO {jcp} {"J. Comp. Phys."} +MACRO {jetp} {"Sov. Phys.--JETP"} +MACRO {jfe} {"J. Fusion Energy"} +MACRO {jfm} {"J. Fluid Mech."} +MACRO {jmp} {"J. Math. Phys."} +MACRO {jne} {"J. Nucl. Energy"} +MACRO {jnec} {"J. Nucl. Energy, C: Plasma Phys., Accelerators, Thermonucl. Res."} +MACRO {jnm} {"J. Nucl. Mat."} +MACRO {jpc} {"J. Phys. Chem."} +MACRO {jpp} {"J. Plasma Phys."} +MACRO {jpsj} {"J. Phys. Soc. Japan"} +MACRO {jsi} {"J. Sci. Instrum."} +MACRO {jvst} {"J. Vac. Sci. \& Tech."} +MACRO {nat} {"Nature"} +MACRO {nature} {"Nature"} +MACRO {nedf} {"Nucl. Eng. \& Design/Fusion"} +MACRO {nf} {"Nucl. Fusion"} +MACRO {nim} {"Nucl. Inst. \& Meth."} +MACRO {nimpr} {"Nucl. Inst. \& Meth. in Phys. Res."} +MACRO {np} {"Nucl. Phys."} +MACRO {npb} {"Nucl. Phys. B"} +MACRO {nt/f} {"Nucl. Tech./Fusion"} +MACRO {npbpc} {"Nucl. Phys. B (Proc. Suppl.)"} +MACRO {inc} {"Nuovo Cimento"} +MACRO {nc} {"Nuovo Cimento"} +MACRO {pf} {"Phys. Fluids"} +MACRO {pfa} {"Phys. Fluids A: Fluid Dyn."} +MACRO {pfb} {"Phys. Fluids B: Plasma Phys."} +MACRO {pl} {"Phys. Lett."} +MACRO {pla} {"Phys. Lett. A"} +MACRO {plb} {"Phys. Lett. B"} +MACRO {prep} {"Phys. Rep."} +MACRO {pnas} {"Proc. Nat. Acad. Sci. USA"} +MACRO {pp} {"Phys. Plasmas"} +MACRO {ppcf} {"Plasma Phys. \& Controlled Fusion"} +MACRO {phitrsl} {"Philos. Trans. Roy. Soc. London"} +MACRO {prl} {"Phys. Rev. Lett."} +MACRO {pr} {"Phys. Rev."} +MACRO {physrev} {"Phys. Rev."} +MACRO {pra} {"Phys. Rev. A"} +MACRO {prb} {"Phys. Rev. B"} +MACRO {prc} {"Phys. Rev. C"} +MACRO {prd} {"Phys. Rev. D"} +MACRO {pre} {"Phys. Rev. E"} +MACRO {ps} {"Phys. Scripta"} +MACRO {procrsl} {"Proc. Roy. Soc. London"} +MACRO {rmp} {"Rev. Mod. Phys."} +MACRO {rsi} {"Rev. Sci. Inst."} +MACRO {science} {"Science"} +MACRO {sciam} {"Sci. Am."} +MACRO {sam} {"Stud. Appl. Math."} +MACRO {sjpp} {"Sov. J. Plasma Phys."} +MACRO {spd} {"Sov. Phys.--Doklady"} +MACRO {sptp} {"Sov. Phys.--Tech. Phys."} +MACRO {spu} {"Sov. Phys.--Uspeki"} +MACRO {st} {"Sky and Telesc."} + % End module: physjour.mbs + %------------------------------------------------------------------- + % Begin module: + % \ProvidesFile{geojour.mbs}[2002/07/10 2.0h (PWD)] +MACRO {aisr} {"Adv. Space Res."} +MACRO {ag} {"Ann. Geophys."} +MACRO {anigeo} {"Ann. Geofis."} +MACRO {angl} {"Ann. Glaciol."} +MACRO {andmet} {"Ann. d. Meteor."} +MACRO {andgeo} {"Ann. d. Geophys."} +MACRO {andphy} {"Ann. Phys.-Paris"} +MACRO {afmgb} {"Arch. Meteor. Geophys. Bioklimatol."} +MACRO {atph} {"Atm\'osphera"} +MACRO {aao} {"Atmos. Ocean"} +MACRO {ass}{"Astrophys. Space Sci."} +MACRO {atenv} {"Atmos. Environ."} +MACRO {aujag} {"Aust. J. Agr. Res."} +MACRO {aumet} {"Aust. Meteorol. Mag."} +MACRO {blmet} {"Bound.-Lay. Meteorol."} +MACRO {bams} {"Bull. Amer. Meteorol. Soc."} +MACRO {cch} {"Clim. Change"} +MACRO {cdyn} {"Clim. Dynam."} +MACRO {cbul} {"Climatol. Bull."} +MACRO {cap} {"Contrib. Atmos. Phys."} +MACRO {dsr} {"Deep-Sea Res."} +MACRO {dhz} {"Dtsch. Hydrogr. Z."} +MACRO {dao} {"Dynam. Atmos. Oceans"} +MACRO {eco} {"Ecology"} +MACRO {empl}{"Earth, Moon and Planets"} +MACRO {envres} {"Environ. Res."} +MACRO {envst} {"Environ. Sci. Technol."} +MACRO {ecms} {"Estuarine Coastal Mar. Sci."} +MACRO {expa}{"Exper. Astron."} +MACRO {geoint} {"Geofis. Int."} +MACRO {geopub} {"Geofys. Publ."} +MACRO {geogeo} {"Geol. Geofiz."} +MACRO {gafd} {"Geophys. Astrophys. Fluid Dyn."} +MACRO {gfd} {"Geophys. Fluid Dyn."} +MACRO {geomag} {"Geophys. Mag."} +MACRO {georl} {"Geophys. Res. Lett."} +MACRO {grl} {"Geophys. Res. Lett."} +MACRO {ga} {"Geophysica"} +MACRO {gs} {"Geophysics"} +MACRO {ieeetap} {"IEEE Trans. Antenn. Propag."} +MACRO {ijawp} {"Int. J. Air Water Pollut."} +MACRO {ijc} {"Int. J. Climatol."} +MACRO {ijrs} {"Int. J. Remote Sens."} +MACRO {jam} {"J. Appl. Meteorol."} +MACRO {jaot} {"J. Atmos. Ocean. Technol."} +MACRO {jatp} {"J. Atmos. Terr. Phys."} +MACRO {jastp} {"J. Atmos. Solar-Terr. Phys."} +MACRO {jce} {"J. Climate"} +MACRO {jcam} {"J. Climate Appl. Meteor."} +MACRO {jcm} {"J. Climate Meteor."} +MACRO {jcy} {"J. Climatol."} +MACRO {jgr} {"J. Geophys. Res."} +MACRO {jga} {"J. Glaciol."} +MACRO {jh} {"J. Hydrol."} +MACRO {jmr} {"J. Mar. Res."} +MACRO {jmrj} {"J. Meteor. Res. Japan"} +MACRO {jm} {"J. Meteor."} +MACRO {jpo} {"J. Phys. Oceanogr."} +MACRO {jra} {"J. Rech. Atmos."} +MACRO {jaes} {"J. Aeronaut. Sci."} +MACRO {japca} {"J. Air Pollut. Control Assoc."} +MACRO {jas} {"J. Atmos. Sci."} +MACRO {jmts} {"J. Mar. Technol. Soc."} +MACRO {jmsj} {"J. Meteorol. Soc. Japan"} +MACRO {josj} {"J. Oceanogr. Soc. Japan"} +MACRO {jwm} {"J. Wea. Mod."} +MACRO {lao} {"Limnol. Oceanogr."} +MACRO {mwl} {"Mar. Wea. Log"} +MACRO {mau} {"Mausam"} +MACRO {meteor} {"``Meteor'' Forschungsergeb."} +MACRO {map} {"Meteorol. Atmos. Phys."} +MACRO {metmag} {"Meteor. Mag."} +MACRO {metmon} {"Meteor. Monogr."} +MACRO {metrun} {"Meteor. Rundsch."} +MACRO {metzeit} {"Meteor. Z."} +MACRO {metgid} {"Meteor. Gidrol."} +MACRO {mwr} {"Mon. Weather Rev."} +MACRO {nwd} {"Natl. Weather Dig."} +MACRO {nzjmfr} {"New Zeal. J. Mar. Freshwater Res."} +MACRO {npg} {"Nonlin. Proc. Geophys."} +MACRO {om} {"Oceanogr. Meteorol."} +MACRO {ocac} {"Oceanol. Acta"} +MACRO {oceanus} {"Oceanus"} +MACRO {paleoc} {"Paleoceanography"} +MACRO {pce} {"Phys. Chem. Earth"} +MACRO {pmg} {"Pap. Meteor. Geophys."} +MACRO {ppom} {"Pap. Phys. Oceanogr. Meteor."} +MACRO {physzeit} {"Phys. Z."} +MACRO {pps} {"Planet. Space Sci."} +MACRO {pss} {"Planet. Space Sci."} +MACRO {pag} {"Pure Appl. Geophys."} +MACRO {qjrms} {"Quart. J. Roy. Meteorol. Soc."} +MACRO {quatres} {"Quat. Res."} +MACRO {rsci} {"Radio Sci."} +MACRO {rse} {"Remote Sens. Environ."} +MACRO {rgeo} {"Rev. Geophys."} +MACRO {rgsp} {"Rev. Geophys. Space Phys."} +MACRO {rdgeo} {"Rev. Geofis."} +MACRO {revmeta} {"Rev. Meteorol."} +MACRO {sgp}{"Surveys in Geophys."} +MACRO {sp} {"Solar Phys."} +MACRO {ssr} {"Space Sci. Rev."} +MACRO {tellus} {"Tellus"} +MACRO {tac} {"Theor. Appl. Climatol."} +MACRO {tagu} {"Trans. Am. Geophys. Union (EOS)"} +MACRO {wrr} {"Water Resour. Res."} +MACRO {weather} {"Weather"} +MACRO {wafc} {"Weather Forecast."} +MACRO {ww} {"Weatherwise"} +MACRO {wmob} {"WMO Bull."} +MACRO {zeitmet} {"Z. Meteorol."} + % End module: geojour.mbs + %------------------------------------------------------------------- + % Begin module: + % \ProvidesFile{photjour.mbs}[1999/02/24 2.0b (PWD)] + +MACRO {appopt} {"Appl. Opt."} +MACRO {bell} {"Bell Syst. Tech. J."} +MACRO {ell} {"Electron. Lett."} +MACRO {jasp} {"J. Appl. Spectr."} +MACRO {jqe} {"IEEE J. Quantum Electron."} +MACRO {jlwt} {"J. Lightwave Technol."} +MACRO {jmo} {"J. Mod. Opt."} +MACRO {josa} {"J. Opt. Soc. America"} +MACRO {josaa} {"J. Opt. Soc. Amer.~A"} +MACRO {josab} {"J. Opt. Soc. Amer.~B"} +MACRO {jdp} {"J. Phys. (Paris)"} +MACRO {oc} {"Opt. Commun."} +MACRO {ol} {"Opt. Lett."} +MACRO {phtl} {"IEEE Photon. Technol. Lett."} +MACRO {pspie} {"Proc. Soc. Photo-Opt. Instrum. Eng."} +MACRO {sse} {"Solid-State Electron."} +MACRO {sjot} {"Sov. J. Opt. Technol."} +MACRO {sjqe} {"Sov. J. Quantum Electron."} +MACRO {sleb} {"Sov. Phys.--Leb. Inst. Rep."} +MACRO {stph} {"Sov. Phys.--Techn. Phys."} +MACRO {stphl} {"Sov. Techn. Phys. Lett."} +MACRO {vr} {"Vision Res."} +MACRO {zph} {"Z. f. Physik"} +MACRO {zphb} {"Z. f. Physik~B"} +MACRO {zphd} {"Z. f. Physik~D"} + +MACRO {CLEO} {"CLEO"} +MACRO {ASSL} {"Adv. Sol.-State Lasers"} +MACRO {OSA} {"OSA"} + % End module: photjour.mbs +%% Copyright 1994-2008 Patrick W Daly +MACRO {acmcs} {"ACM Comput. Surv."} + +MACRO {acta} {"Acta Inf."} + +MACRO {cacm} {"Commun. ACM"} + +MACRO {ibmjrd} {"IBM J. Res. Dev."} + +MACRO {ibmsj} {"IBM Syst.~J."} + +MACRO {ieeese} {"IEEE Trans. Software Eng."} + +MACRO {ieeetc} {"IEEE Trans. Comput."} + +MACRO {ieeetcad} + {"IEEE Trans. Comput. Aid. Des."} + +MACRO {ipl} {"Inf. Process. Lett."} + +MACRO {jacm} {"J.~ACM"} + +MACRO {jcss} {"J.~Comput. Syst. Sci."} + +MACRO {scp} {"Sci. Comput. Program."} + +MACRO {sicomp} {"SIAM J. Comput."} + +MACRO {tocs} {"ACM Trans. Comput. Syst."} + +MACRO {tods} {"ACM Trans. Database Syst."} + +MACRO {tog} {"ACM Trans. Graphic."} + +MACRO {toms} {"ACM Trans. Math. Software"} + +MACRO {toois} {"ACM Trans. Office Inf. Syst."} + +MACRO {toplas} {"ACM Trans. Progr. Lang. Syst."} + +MACRO {tcs} {"Theor. Comput. Sci."} + +FUNCTION {bibinfo.check} +{ swap$ + duplicate$ missing$ + { + pop$ pop$ + "" + } + { duplicate$ empty$ + { + swap$ pop$ + } + { swap$ + pop$ + } + if$ + } + if$ +} +FUNCTION {bibinfo.warn} +{ swap$ + duplicate$ missing$ + { + swap$ "missing " swap$ * " in " * cite$ * warning$ pop$ + "" + } + { duplicate$ empty$ + { + swap$ "empty " swap$ * " in " * cite$ * warning$ + } + { swap$ + pop$ + } + if$ + } + if$ +} + + +STRINGS {ss tt fm} +FUNCTION {format.onlyfirst} +{ + 'ss := %% Make a copy of the name in s + %% Extract the First (and possible Medium) names + %% and store it in variable fm + ss #1 "{ff}" format.name$ 'fm := + + %% Note that now fm could contain: + %% * An empty string ("") if the author has no first name (only Last name was provided) + %% * A single word (like "First") if the author has no medium name + %% * A sequence of words (like "First Medium") + %% For the last case we want to abbreviate "Medium", without dot + + %% Test if we are in the first case + fm empty$ { + % If empty (no first name), use the standard formatting + ss #1 "{vv~}{ll}{, f{.}.}{, jj}" format.name$ + }{ % Otherwise, attempt the trick + %% Now the trick. Interpret "First Medium" + %% as if "Medium" were a last name, and abbreviate it + fm #1 "{f.}{l}" format.name$ 'tt := %% And store the result in tt + %% Consider the particular case in which no Medium name is present + %% In this case, "First" will be interpreted as a last name, and + %% thus abbreviated. This can be detected because the resulting + %% string has length 1 + tt text.length$ #1 > { %% If there was a medium name + fm #1 "{f.}{l.}" format.name$ 'tt := + tt %% Store the abbreviated version + }{ %% Else store the original version of the name + fm + } if$ + + %% After the above, the top of the stack will contain + %% either "First" unabbreviated (if the author has not middle name) + %% or "First M", as required + 'tt := %% Copy that value to tt + + %% Now complete the standard formatting of the author, omitting + %% the first name part, which is stored in tt + ss #1 "{vv~}{ll}{, jj}" format.name$ + %% And concatenate to it the value of tt + ", " * + tt * + }if$ %% If the trick has to be done +} + +INTEGERS { nameptr namesleft numnames } +STRINGS { bibinfo} + +FUNCTION {format.names} +{ 'bibinfo := + duplicate$ empty$ 'skip$ { + 's := + "" 't := + #1 'nameptr := + s num.names$ 'numnames := + numnames 'namesleft := + { namesleft #0 > } + { s nameptr + "{vv~}{ll}{, ff}{, jj}" + format.name$ + bibinfo bibinfo.check + format.onlyfirst 't := + nameptr #1 > + { + namesleft #1 > + { ", " * t * } + { + s nameptr "{ll}" format.name$ duplicate$ "others" = + { 't := } + { pop$ } + if$ + numnames #1 > + { "," * } + 'skip$ + if$ + t "others" = + { + " " * bbl.etal * + } + { + bbl.and + space.word * t * + } + if$ + } + if$ + } + 't + if$ + nameptr #1 + 'nameptr := + namesleft #1 - 'namesleft := + } + while$ + } if$ +} + + +FUNCTION {format.names.ed} +{ + 'bibinfo := + duplicate$ empty$ 'skip$ { + 's := + "" 't := + #1 'nameptr := + s num.names$ 'numnames := + numnames 'namesleft := + { namesleft #0 > } + { s nameptr + "{f.~}{vv~}{ll}{, jj}" + format.name$ + bibinfo bibinfo.check + 't := + nameptr #1 > + { + namesleft #1 > + { ", " * t * } + { + s nameptr "{ll}" format.name$ duplicate$ "others" = + { 't := } + { pop$ } + if$ + numnames #2 > + { "," * } + 'skip$ + if$ + t "others" = + { + + " " * bbl.etal * + } + { + bbl.and + space.word * t * + } + if$ + } + if$ + } + 't + if$ + nameptr #1 + 'nameptr := + namesleft #1 - 'namesleft := + } + while$ + } if$ +} +FUNCTION {format.key} +{ empty$ + { key field.or.null } + { "" } + if$ +} + +FUNCTION {format.authors} +{ author "author" format.names +} +FUNCTION {get.bbl.editor} +{ editor num.names$ #1 > 'bbl.editors 'bbl.editor if$ } + +FUNCTION {format.editors} +{ editor "editor" format.names duplicate$ empty$ 'skip$ + { + " " * + get.bbl.editor + capitalize + "(" swap$ * ")" * + * + } + if$ +} +FUNCTION {format.book.pages} +{ pages "pages" bibinfo.check + duplicate$ empty$ 'skip$ + { "~" * bbl.pages * } + if$ +} +FUNCTION {format.doi} +{ doi empty$ + { "" } + { + urldate empty$ + { + "\url{https://doi.org/" doi * "}" * + } + { + "at \url{https://doi.org/" doi * "}" * + } + if$ + } + if$ +} +FUNCTION {format.urldate} +{ urldate empty$ + { "" } + { + url empty$ + { + doi empty$ + { "" } + { + "accessed " urldate * + } + if$ + } + { + "accessed " urldate * + } + if$ + } + if$ +} +FUNCTION {format.url} +{ url empty$ + { "" } + { + urldate empty$ + { + "\url{" url * "}" * + } + { + "at \url{" url * "}" * + } + if$ + } + if$ +} +FUNCTION {format.urllink} +{ urllink empty$ + { "" } + { + " (Available online at \url{" urllink * "})" * + } + if$ +} +FUNCTION {format.note} +{ + note empty$ + { "" } + { note #1 #1 substring$ + duplicate$ "{" = + 'skip$ + { output.state mid.sentence = + { "l" } + { "u" } + if$ + change.case$ + } + if$ + note #2 global.max$ substring$ * "note" bibinfo.check + } + if$ +} + +FUNCTION {format.title} +{ title + duplicate$ empty$ 'skip$ + { "t" change.case$ } + if$ + "title" bibinfo.check +} +FUNCTION {format.full.names} +{'s := + "" 't := + #1 'nameptr := + s num.names$ 'numnames := + numnames 'namesleft := + { namesleft #0 > } + { s nameptr + "{vv~}{ll}" format.name$ + 't := + nameptr #1 > + { + namesleft #1 > + { ", " * t * } + { + s nameptr "{ll}" format.name$ duplicate$ "others" = + { 't := } + { pop$ } + if$ + t "others" = + { + " " * bbl.etal * + cite.name.font + } + { + numnames #2 > + { "," * } + 'skip$ + if$ + bbl.and + space.word * t * + } + if$ + } + if$ + } + 't + if$ + nameptr #1 + 'nameptr := + namesleft #1 - 'namesleft := + } + while$ + t "others" = + 'skip$ + { cite.name.font } + if$ +} + +FUNCTION {author.editor.key.full} +{ author empty$ + { editor empty$ + { key empty$ + { cite$ #1 #3 substring$ } + 'key + if$ + } + { editor format.full.names } + if$ + } + { author format.full.names } + if$ +} + +FUNCTION {author.key.full} +{ author empty$ + { key empty$ + { cite$ #1 #3 substring$ } + 'key + if$ + } + { author format.full.names } + if$ +} + +FUNCTION {editor.key.full} +{ editor empty$ + { key empty$ + { cite$ #1 #3 substring$ } + 'key + if$ + } + { editor format.full.names } + if$ +} + +FUNCTION {make.full.names} +{ type$ "book" = + type$ "inbook" = + or + 'author.editor.key.full + { type$ "proceedings" = + 'editor.key.full + 'author.key.full + if$ + } + if$ +} + +FUNCTION {output.bibitem} +{ newline$ + "\bibitem[{" write$ + label write$ + ")" make.full.names duplicate$ short.list = + { pop$ } + { * } + if$ + "}]{" * write$ + cite$ write$ + "}" write$ + newline$ + "" + before.all 'output.state := +} + +FUNCTION {if.digit} +{ duplicate$ "0" = + swap$ duplicate$ "1" = + swap$ duplicate$ "2" = + swap$ duplicate$ "3" = + swap$ duplicate$ "4" = + swap$ duplicate$ "5" = + swap$ duplicate$ "6" = + swap$ duplicate$ "7" = + swap$ duplicate$ "8" = + swap$ "9" = or or or or or or or or or +} +FUNCTION {n.separate} +{ 't := + "" + #0 'numnames := + { t empty$ not } + { t #-1 #1 substring$ if.digit + { numnames #1 + 'numnames := } + { #0 'numnames := } + if$ + t #-1 #1 substring$ swap$ * + t #-2 global.max$ substring$ 't := + numnames #5 = + { duplicate$ #1 #2 substring$ swap$ + #3 global.max$ substring$ + "," swap$ * * + } + 'skip$ + if$ + } + while$ +} +FUNCTION {n.dashify} +{ + n.separate + 't := + "" + { t empty$ not } + { t #1 #1 substring$ "-" = + { t #1 #2 substring$ "--" = not + { "--" * + t #2 global.max$ substring$ 't := + } + { { t #1 #1 substring$ "-" = } + { "-" * + t #2 global.max$ substring$ 't := + } + while$ + } + if$ + } + { t #1 #1 substring$ * + t #2 global.max$ substring$ 't := + } + if$ + } + while$ +} + +FUNCTION {word.in} +{ bbl.in + " " * } + +FUNCTION {format.date} +{ year "year" bibinfo.check duplicate$ empty$ + { + } + 'skip$ + if$ + extra.label * + before.all 'output.state := + ", " swap$ * "" * +} +FUNCTION {format.btitle} +{ title "title" bibinfo.check + duplicate$ empty$ 'skip$ + { + %emphasize + } + if$ +} +FUNCTION {either.or.check} +{ empty$ + 'pop$ + { "can't use both " swap$ * " fields in " * cite$ * warning$ } + if$ +} +FUNCTION {format.bvolume} +{ volume empty$ + { "" } + { bbl.volume volume tie.or.space.prefix + "volume" bibinfo.check * * + series "series" bibinfo.check + duplicate$ empty$ 'pop$ + + % { emphasize ", " * swap$ * } % REMOVE ITALICS FOR USGS + { ", " * swap$ * } + if$ + "volume and number" number either.or.check + } + if$ +} +FUNCTION {format.number.series} +{ volume empty$ + { number empty$ + { series field.or.null } + { series empty$ + { number "number" bibinfo.check } + { output.state mid.sentence = + { bbl.number } + { bbl.number capitalize } + if$ + number tie.or.space.prefix "number" bibinfo.check * * + bbl.in space.word * + series "series" bibinfo.check * + } + if$ + } + if$ + } + { "" } + if$ +} + +FUNCTION {format.edition} +{ edition duplicate$ empty$ 'skip$ + { + output.state mid.sentence = + { "l" } + { "t" } + if$ change.case$ + "edition" bibinfo.check + " " * bbl.edition * + } + if$ +} +INTEGERS { multiresult } +FUNCTION {multi.page.check} +{ 't := + #0 'multiresult := + { multiresult not + t empty$ not + and + } + { t #1 #1 substring$ + duplicate$ "-" = + swap$ duplicate$ "," = + swap$ "+" = + or or + { #1 'multiresult := } + { t #2 global.max$ substring$ 't := } + if$ + } + while$ + multiresult +} +FUNCTION {format.pages} +{ pages duplicate$ empty$ 'skip$ + { duplicate$ multi.page.check + { + bbl.pages swap$ + n.dashify + } + { + bbl.page swap$ + } + if$ + tie.or.space.prefix + "pages" bibinfo.check + * * + } + if$ +} +FUNCTION {format.journal.pages} +{ pages duplicate$ empty$ 'pop$ + { swap$ duplicate$ empty$ + { pop$ pop$ format.pages } + { + ", p.~" * + swap$ + n.dashify + "pages" bibinfo.check + * + } + if$ + } + if$ +} +FUNCTION {format.journal.eid} +{ eid "eid" bibinfo.check + duplicate$ empty$ 'pop$ + { swap$ duplicate$ empty$ 'skip$ + { + ", " * + } + if$ + swap$ * + } + if$ +} +FUNCTION {format.vol.num.pages} +{ volume field.or.null + duplicate$ empty$ 'skip$ + { + bbl.volume swap$ tie.or.space.prefix + "volume" bibinfo.check + * * + } + if$ + number "number" bibinfo.check duplicate$ empty$ 'skip$ + { + swap$ duplicate$ empty$ + { "there's a number but no volume in " cite$ * warning$ } + 'skip$ + if$ + swap$ + ", " bbl.nr * number tie.or.space.prefix pop$ * swap$ * + } + if$ * + eid empty$ + { format.journal.pages } + { format.journal.eid } + if$ +} + +FUNCTION {format.chapter.pages} +{ chapter empty$ + 'format.pages + { type empty$ + { bbl.chapter } + { type "l" change.case$ + "type" bibinfo.check + } + if$ + chapter tie.or.space.prefix + "chapter" bibinfo.check + * * + pages empty$ + 'skip$ + { ", " * format.pages * } + if$ + } + if$ +} + +FUNCTION {format.booktitle} +{ + booktitle "booktitle" bibinfo.check + %emphasize +} + +FUNCTION {format.editor} +{ + editor "editor" format.names + duplicate$ empty$ 'pop$ + { + %emphasize + } + if$ +} + +FUNCTION {format.in.ed.booktitle} +{ format.booktitle duplicate$ empty$ 'skip$ + { + format.bvolume duplicate$ empty$ 'pop$ + { ", " swap$ * * } + if$ + editor "editor" format.names.ed duplicate$ empty$ 'pop$ + { + bbl.edby + " " * swap$ * + swap$ + "," * + " " * swap$ + * } + if$ + word.in swap$ * + } + if$ +} + +FUNCTION {formatc.in.ed.booktitle} +{ format.editor duplicate$ empty$ 'skip$ + { + format.bvolume duplicate$ empty$ 'pop$ + { ", " swap$ * * } + if$ + format.booktitle duplicate$ empty$ 'pop$ + { + swap$ + "," * + " " * swap$ + * } + if$ + word.in swap$ * + } + if$ +} + +FUNCTION {format.thesis.type} +{ type duplicate$ empty$ + 'pop$ + { swap$ pop$ + "t" change.case$ "type" bibinfo.check + } + if$ +} +FUNCTION {format.tr.number} +{ number "number" bibinfo.check + type duplicate$ empty$ + { pop$ bbl.techrep } + 'skip$ + if$ + "type" bibinfo.check + swap$ duplicate$ empty$ + { pop$ "t" change.case$ } + { tie.or.space.prefix * * } + if$ +} +FUNCTION {format.article.crossref} +{ + word.in + " \cite{" * crossref * "}" * +} +FUNCTION {format.book.crossref} +{ volume duplicate$ empty$ + { "empty volume in " cite$ * "'s crossref of " * crossref * warning$ + pop$ word.in + } + { bbl.volume + swap$ tie.or.space.prefix "volume" bibinfo.check * * bbl.of space.word * + } + if$ + " \cite{" * crossref * "}" * +} +FUNCTION {format.incoll.inproc.crossref} +{ + word.in + " \cite{" * crossref * "}" * +} +FUNCTION {format.org.or.pub} +{ 't := + "" + address empty$ t empty$ and + 'skip$ + { + t empty$ + { address "address" bibinfo.check * + } + { t * + address empty$ + 'skip$ + { ", " * address "address" bibinfo.check * } + if$ + } + if$ + } + if$ +} +FUNCTION {formatc.org.or.pub} +{ 't := + "" + address empty$ t empty$ and + 'skip$ + { + t empty$ + { address "address" bibinfo.check * + } + { t * + address empty$ + 'skip$ + { ": " * address "address" bibinfo.check * } + if$ + } + if$ + } + if$ +} +FUNCTION {format.publisher.address} +{ format.org.or.pub publisher "publisher" bibinfo.warn +} +FUNCTION {formatc.publisher.address} +{ formatc.org.or.pub publisher "publisher" bibinfo.warn +} + +FUNCTION {format.organization.address} +{ organization "organization" bibinfo.check format.org.or.pub +} + +FUNCTION {article} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title "title" output.check + crossref missing$ + { + journal + "journal" bibinfo.check + %emphasize + "journal" outputc.check + format.vol.num.pages output + format.urldate output + format.doi output + format.url output + format.urllink output + } + { format.article.crossref output.nonnull + format.pages output + } + if$ + format.note output + fin.entry +} +FUNCTION {book} +{ output.bibitem + author empty$ + { format.editors "author and editor" output.check + editor format.key output + } + { format.authors output.nonnull + crossref missing$ + { "author and editor" editor either.or.check } + 'skip$ + if$ + } + if$ + format.date "year" output.check + date.block + format.btitle "title" output.check + publisher empty$ + { format.number.series outputc.nonnull } + { formatc.publisher.address output + format.book.pages output + } + if$ + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} +FUNCTION {booklet} +{ output.bibitem + format.authors output + author format.key output + format.date "year" output.check + date.block + format.title "title" output.check + howpublished "howpublished" bibinfo.check output + address "address" bibinfo.check output + format.book.pages output + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} + +FUNCTION {inbook} +{ output.bibitem + author empty$ + { format.editors "author and editor" output.check + editor format.key output + } + { format.authors output.nonnull + crossref missing$ + { "author and editor" editor either.or.check } + 'skip$ + if$ + } + if$ + format.date "year" output.check + date.block + format.btitle "title" output.check + publisher empty$ + { format.number.series outputc.nonnull } + { formatc.publisher.address output + format.book.pages output + } +% crossref missing$ +% { +% format.bvolume output +% format.chapter.pages "chapter and pages" output.check +% format.number.series output +% format.edition output +% formatc.publisher.address output +% } +% { +% format.chapter.pages "chapter and pages" output.check +% format.book.crossref output.nonnull +% } + if$ + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} + +FUNCTION {incollection} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title "title" output.check + publisher empty$ + { formatc.in.ed.booktitle "booktitle" output.check + format.number.series outputc.nonnull } + { formatc.in.ed.booktitle "booktitle" output.check + formatc.publisher.address output + format.book.pages output + } +% crossref missing$ +% { format.in.ed.booktitle "booktitle" output.check +% format.number.series output +% format.edition output +% format.chapter.pages output +% formatc.publisher.address output +% } +% { format.incoll.inproc.crossref output.nonnull +% format.chapter.pages output +% } + if$ + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} +FUNCTION {inproceedings} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title "title" output.check + crossref missing$ + { format.in.ed.booktitle "booktitle" output.check + format.number.series output + publisher empty$ + { format.organization.address output } + { organization "organization" bibinfo.check output + format.publisher.address output + } + if$ + format.pages output + } + { format.incoll.inproc.crossref output.nonnull + format.pages output + } + if$ + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} +FUNCTION {conference} { inproceedings } +FUNCTION {manual} +{ output.bibitem + format.authors output + author format.key output + format.date "year" output.check + date.block + format.btitle "title" output.check + organization "organization" bibinfo.check output + address "address" bibinfo.check output + format.edition output + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} + +FUNCTION {mastersthesis} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title + "title" output.check + bbl.mthesis format.thesis.type output.nonnull + school "school" bibinfo.warn output + address "address" bibinfo.check output + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + format.book.pages output + fin.entry +} + +FUNCTION {misc} +{ output.bibitem + format.authors output + author format.key output + format.date "year" output.check + date.block + format.title output + howpublished "howpublished" bibinfo.check output + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} +FUNCTION {phdthesis} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title + "title" output.check + bbl.phdthesis format.thesis.type output.nonnull + school "school" bibinfo.warn output + address "address" bibinfo.check output + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + format.book.pages output + fin.entry +} + +FUNCTION {proceedings} +{ output.bibitem + format.editors output + editor format.key output + format.date "year" output.check + date.block + format.btitle "title" output.check + format.bvolume output + format.number.series output + publisher empty$ + { format.organization.address output } + { organization "organization" bibinfo.check output + format.publisher.address output + } + if$ + format.urldate output + format.doi output + format.url output + format.urllink output + format.note output + fin.entry +} + +FUNCTION {techreport} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title + "title" output.check + % format.tr.number emphasize output.nonnull + institution "institution" bibinfo.warn output + address "address" bibinfo.check output + format.book.pages output + fin.entry +} + +FUNCTION {online} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title + "title" output.check + % format.tr.number emphasize output.nonnull + + fin.entry +} + +FUNCTION {unpublished} +{ output.bibitem + format.authors "author" output.check + author format.key output + format.date "year" output.check + date.block + format.title "title" output.check + format.urldate output + format.doi output + format.url output + format.urllink output + format.note "note" output.check + fin.entry +} + +FUNCTION {default.type} { misc } +READ +FUNCTION {sortify} +{ purify$ + "l" change.case$ +} +INTEGERS { len } +FUNCTION {chop.word} +{ 's := + 'len := + s #1 len substring$ = + { s len #1 + global.max$ substring$ } + 's + if$ +} +FUNCTION {format.lab.names} +{ 's := + "" 't := + s #1 "{vv~}{ll}" format.name$ + s num.names$ duplicate$ + #2 > + { pop$ + " " * bbl.etal * + cite.name.font + "others" 't := + } + { #2 < + 'skip$ + { s #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" = + { + " " * bbl.etal * + cite.name.font + "others" 't := + } + { bbl.and space.word * s #2 "{vv~}{ll}" format.name$ + * } + if$ + } + if$ + } + if$ + t "others" = + 'skip$ + { cite.name.font } + if$ +} + +FUNCTION {author.key.label} +{ author empty$ + { key empty$ + { cite$ #1 #3 substring$ } + 'key + if$ + } + { author format.lab.names } + if$ +} + +FUNCTION {author.editor.key.label} +{ author empty$ + { editor empty$ + { key empty$ + { cite$ #1 #3 substring$ } + 'key + if$ + } + { editor format.lab.names } + if$ + } + { author format.lab.names } + if$ +} + +FUNCTION {editor.key.label} +{ editor empty$ + { key empty$ + { cite$ #1 #3 substring$ } + 'key + if$ + } + { editor format.lab.names } + if$ +} + +FUNCTION {calc.short.authors} +{ type$ "book" = + type$ "inbook" = + or + 'author.editor.key.label + { type$ "proceedings" = + 'editor.key.label + 'author.key.label + if$ + } + if$ + 'short.list := +} + +FUNCTION {calc.label} +{ calc.short.authors + short.list + "(" + * + year duplicate$ empty$ + short.list key field.or.null = or + { pop$ "" } + 'skip$ + if$ + * + 'label := +} + +FUNCTION {sort.format.names} +{ 's := + #1 'nameptr := + "" + s num.names$ 'numnames := + numnames 'namesleft := + { namesleft #0 > } + { s nameptr + "{vv{ } }{ll{ }}{ f{ }}{ jj{ }}" + format.name$ 't := + nameptr #1 > + { + " " * + namesleft #1 = t "others" = and + { "zzzzz" 't := } + 'skip$ + if$ + numnames #2 > nameptr #2 = and + { "zz" * year field.or.null * " " * + #1 'namesleft := + } + { t sortify * } + if$ + } + { t sortify * } + if$ + nameptr #1 + 'nameptr := + namesleft #1 - 'namesleft := + } + while$ +} + +FUNCTION {sort.format.title} +{ 't := + "A " #2 + "An " #3 + "The " #4 t chop.word + chop.word + chop.word + sortify + #1 global.max$ substring$ +} +FUNCTION {author.sort} +{ author empty$ + { key empty$ + { "to sort, need author or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { author sort.format.names } + if$ +} +FUNCTION {author.editor.sort} +{ author empty$ + { editor empty$ + { key empty$ + { "to sort, need author, editor, or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { editor sort.format.names } + if$ + } + { author sort.format.names } + if$ +} +FUNCTION {editor.sort} +{ editor empty$ + { key empty$ + { "to sort, need editor or key in " cite$ * warning$ + "" + } + { key sortify } + if$ + } + { editor sort.format.names } + if$ +} +FUNCTION {presort} +{ calc.label + label sortify + " " + * + type$ "book" = + type$ "inbook" = + or + 'author.editor.sort + { type$ "proceedings" = + 'editor.sort + 'author.sort + if$ + } + if$ + #1 entry.max$ substring$ + 'sort.label := + sort.label + * + #1 entry.max$ substring$ + 'sort.key$ := +} + +ITERATE {presort} +SORT +STRINGS { last.label next.extra } +INTEGERS { last.extra.num last.extra.num.extended last.extra.num.blank number.label } +FUNCTION {initialize.extra.label.stuff} +{ #0 int.to.chr$ 'last.label := + "" 'next.extra := + #0 'last.extra.num := + "a" chr.to.int$ #1 - 'last.extra.num.blank := + last.extra.num.blank 'last.extra.num.extended := + #0 'number.label := +} +FUNCTION {forward.pass} +{ last.label label = + { last.extra.num #1 + 'last.extra.num := + last.extra.num "z" chr.to.int$ > + { "a" chr.to.int$ 'last.extra.num := + last.extra.num.extended #1 + 'last.extra.num.extended := + } + 'skip$ + if$ + last.extra.num.extended last.extra.num.blank > + { last.extra.num.extended int.to.chr$ + last.extra.num int.to.chr$ + * 'extra.label := } + { last.extra.num int.to.chr$ 'extra.label := } + if$ + } + { "a" chr.to.int$ 'last.extra.num := + "" 'extra.label := + label 'last.label := + } + if$ + number.label #1 + 'number.label := +} +FUNCTION {reverse.pass} +{ next.extra "b" = + { "a" 'extra.label := } + 'skip$ + if$ + extra.label 'next.extra := + extra.label + duplicate$ empty$ + 'skip$ + { "{\natexlab{" swap$ * "}}" * } + if$ + 'extra.label := + label extra.label * 'label := +} +EXECUTE {initialize.extra.label.stuff} +ITERATE {forward.pass} +REVERSE {reverse.pass} +FUNCTION {bib.sort.order} +{ sort.label + " " + * + year field.or.null sortify + * + #1 entry.max$ substring$ + 'sort.key$ := +} +ITERATE {bib.sort.order} +SORT +FUNCTION {begin.bib} +{ preamble$ empty$ + 'skip$ + { preamble$ write$ newline$ } + if$ + "\begin{thebibliography}{" number.label int.to.str$ * "}" * + write$ newline$ + "\providecommand{\natexlab}[1]{#1}" + write$ newline$ + "\expandafter\ifx\csname urlstyle\endcsname\relax" + write$ newline$ + " \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else" + write$ newline$ + " \providecommand{\doi}{doi:\discretionary{}{}{}\begingroup \urlstyle{rm}\Url}\fi" + write$ newline$ +} +EXECUTE {begin.bib} +EXECUTE {init.state.consts} +ITERATE {call.type$} +FUNCTION {end.bib} +{ newline$ + "\end{thebibliography}" write$ newline$ +} +EXECUTE {end.bib} +%% End of customized bst file +%% +%% End of file `agufull08.bst'. From 63df2deabe224313fb8c8c5ca3b25c4b1d4b7f50 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 10:32:38 -0700 Subject: [PATCH 174/212] fprettify --- src/Exchange/GweGweExchange.f90 | 4 +- src/Exchange/GwfGweExchange.f90 | 3 +- src/Model/Connection/GweInterfaceModel.f90 | 4 +- src/Model/Connection/GwtInterfaceModel.f90 | 4 +- src/Model/GroundWaterFlow/gwf3drn8.f90 | 6 +-- src/Model/ModelUtilities/GweInputData.f90 | 43 +++++++++++----------- src/Model/ModelUtilities/TspLabels.f90 | 2 +- src/Utilities/Budget.f90 | 2 +- src/Utilities/Idm/ModelPackageInputs.f90 | 2 +- 9 files changed, 34 insertions(+), 36 deletions(-) diff --git a/src/Exchange/GweGweExchange.f90 b/src/Exchange/GweGweExchange.f90 index 82c1ce4ae19..a74f4e9eb59 100644 --- a/src/Exchange/GweGweExchange.f90 +++ b/src/Exchange/GweGweExchange.f90 @@ -529,7 +529,7 @@ subroutine gwe_gwe_bdsav(this) call this%gwemodel1%dis%record_srcdst_list_header(budtxt(1), & this%gwemodel1%name, & this%name, & - this%gwemodel2%name, & + this%gwemodel2%name, & this%name, & this%naux, this%auxname, & ibinun1, this%nexg, & @@ -606,7 +606,7 @@ subroutine gwe_gwe_bdsav(this) ! ! -- If cell-by-cell flows will be saved as a list, write header. if (ibinun2 /= 0) then - call this%gwemodel2%dis%record_srcdst_list_header(budtxt(1), & + call this%gwemodel2%dis%record_srcdst_list_header(budtxt(1), & this%gwemodel2%name, & this%name, & this%gwemodel1%name, & diff --git a/src/Exchange/GwfGweExchange.f90 b/src/Exchange/GwfGweExchange.f90 index 9b370bffb77..6c7f5f9f5dc 100644 --- a/src/Exchange/GwfGweExchange.f90 +++ b/src/Exchange/GwfGweExchange.f90 @@ -190,7 +190,7 @@ subroutine exg_df(this) call mem_checkin(gwemodel%fmi%gwfflowja, & 'GWFFLOWJA', gwemodel%fmi%memoryPath, & 'FLOWJA', gwfmodel%memoryPath) - + ! ! -- Set the npf flag so that specific discharge is available for ! transport calculations if dispersion is active @@ -395,7 +395,6 @@ subroutine gwfconn2gweconn(this, gwfModel, gweModel) 'SIMVALS', gwfEx%memoryPath) end if - !cdl link up mvt to mvr if (gwfEx%inmvr > 0) then if (gweConn%exchangeIsOwned) then diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 032ac0f786c..88448761dd5 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -81,9 +81,9 @@ subroutine gweifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, '', -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & this%eqnsclfac) - call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, '', -dsp_unit, this%iout, this%fmi, & this%eqnsclfac, this%gwecommon) diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index 517bb52f6da..7d8a96c034e 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -81,9 +81,9 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, '', -1, this%iout) - call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & + call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & this%eqnsclfac) - call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & + call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & this%eqnsclfac) call dsp_cr(this%dsp, this%name, '', -dsp_unit, this%iout, this%fmi) call tsp_obs_cr(this%obs, inobs) diff --git a/src/Model/GroundWaterFlow/gwf3drn8.f90 b/src/Model/GroundWaterFlow/gwf3drn8.f90 index af572bf8bf3..c95dc431d5f 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -107,12 +107,12 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) ! -- return return end subroutine drn_create - + !> @ brief Advance the drain boundary package !! !! Advance data in the drain boundary package. Overides the bnd_ad() - !! routine in the bndType parent class. The method advances time - !! series and observation data as well as updates the user-specified + !! routine in the bndType parent class. The method advances time + !! series and observation data as well as updates the user-specified !! conductance based on changes in viscosity when water enters from !! the boundary !< diff --git a/src/Model/ModelUtilities/GweInputData.f90 b/src/Model/ModelUtilities/GweInputData.f90 index f4ccdf288fa..4507ecc3051 100644 --- a/src/Model/ModelUtilities/GweInputData.f90 +++ b/src/Model/ModelUtilities/GweInputData.f90 @@ -1,35 +1,35 @@ module GweInputDataModule - + use KindModule, only: I4B, DP use ConstantsModule, only: DZERO, LENMEMPATH - + implicit none private public :: GweInputDataType public :: gweshared_dat_cr public :: gweshared_dat_df public :: set_gwe_dat_ptrs - - !> Data for sharing among multiple packages. Originally read in from + + !> Data for sharing among multiple packages. Originally read in from !< the MST package - + type GweInputDataType ! dim integer(I4B) :: nnodes !< number of cells - + ! strings character(len=LENMEMPATH) :: memoryPath = '' !< the location in the memory manager where the variables are stored - + ! mst data to be share across multiple packages real(DP), pointer :: gwerhow => null() !< Density of water (for GWE purposes, a constant scalar) real(DP), pointer :: gwecpw => null() !< Heat capacity of water (non-spatially varying) real(DP), pointer :: gwelatheatvap => null() !< latent heat of vaporization real(DP), dimension(:), pointer, contiguous :: gwerhos => null() !< Density of the aquifer material real(DP), dimension(:), pointer, contiguous :: gwecps => null() !< Heat capacity of solids (spatially varying) - + contains - + ! -- public procedure, public :: gweshared_dat_df procedure, public :: set_gwe_dat_ptrs @@ -38,7 +38,7 @@ module GweInputDataModule procedure, private :: allocate_shared_vars procedure, private :: set_gwe_shared_scalars procedure, private :: set_gwe_shared_arrays - + end type GweInputDataType contains @@ -58,7 +58,7 @@ subroutine gweshared_dat_cr(this) ! -- return return end subroutine gweshared_dat_cr - + !> @brief Define the shared data !< subroutine gweshared_dat_df(this, nodes) @@ -101,7 +101,7 @@ subroutine allocate_shared_vars(this, nodes) this%gwecpw = DZERO this%gwerhow = DZERO this%gwelatheatvap = DZERO - do i=1, nodes + do i = 1, nodes this%gwecps(i) = DZERO this%gwerhos(i) = DZERO end do @@ -110,13 +110,12 @@ subroutine allocate_shared_vars(this, nodes) return end subroutine allocate_shared_vars - - !> @brief Allocate and read data from MST + !> @brief Allocate and read data from MST !! - !! MST data, including heat capacity of water (cpw), density of water - !! (rhow), latent heat of vaporization (latheatvap), heat capacity of - !! the aquifer material (cps), and density of the aquifer material - !! (rhow) is used among other packages and is therefore stored in a + !! MST data, including heat capacity of water (cpw), density of water + !! (rhow), latent heat of vaporization (latheatvap), heat capacity of + !! the aquifer material (cps), and density of the aquifer material + !! (rhow) is used among other packages and is therefore stored in a !! separate class subroutine set_gwe_dat_ptrs(this, gwerhow, gwecpw, gwerhos, gwecps, & gwelatheatvap) @@ -148,10 +147,10 @@ end subroutine set_gwe_dat_ptrs !! for use by other packages !! !! Set pointers to GWE-related scalars and arrays for use - !! by multiple packages. For example, a package capable of + !! by multiple packages. For example, a package capable of !! simulating evaporation will need access to latent heat of !! of vaporization. - !! + !! !< subroutine set_gwe_shared_scalars(this, gwerhow, gwecpw, gwelatheatvap) ! -- modules @@ -181,8 +180,8 @@ end subroutine set_gwe_shared_scalars !! for use by other packages !! !! Set pointers to GWE-related arrays for use - !! by multiple packages. - !! + !! by multiple packages. + !! !< subroutine set_gwe_shared_arrays(this, gwerhos, gwecps) ! -- modules diff --git a/src/Model/ModelUtilities/TspLabels.f90 b/src/Model/ModelUtilities/TspLabels.f90 index 3c3a401cb1e..0946a41bba2 100644 --- a/src/Model/ModelUtilities/TspLabels.f90 +++ b/src/Model/ModelUtilities/TspLabels.f90 @@ -47,7 +47,7 @@ module TspLabelsModule !! !< type TspLabelsType - + character(len=LENVARNAME), pointer :: modname => null() !< name of the model that module is associated with character(len=LENVARNAME), pointer :: tsptype => null() !< "solute" or "heat" character(len=LENVARNAME), pointer :: depvartype => null() !< "concentration" or "temperature" diff --git a/src/Utilities/Budget.f90 b/src/Utilities/Budget.f90 index a56d7b7d190..3ac3b323855 100644 --- a/src/Utilities/Budget.f90 +++ b/src/Utilities/Budget.f90 @@ -98,7 +98,7 @@ subroutine budget_cr(this, name_model, tsplab) call this%allocate_scalars(name_model) ! ! -- Store pointer to labels associated with the current model in order - ! assign the correct transport-related labels - only necessary for + ! assign the correct transport-related labels - only necessary for ! transport model type (i.e., GWT or GWE) if (present(tsplab)) this%tsplab => tsplab ! diff --git a/src/Utilities/Idm/ModelPackageInputs.f90 b/src/Utilities/Idm/ModelPackageInputs.f90 index 575e9066ad8..9a2f5d49c68 100644 --- a/src/Utilities/Idm/ModelPackageInputs.f90 +++ b/src/Utilities/Idm/ModelPackageInputs.f90 @@ -239,7 +239,7 @@ function multi_pkg_type(mtype_component, ptype_component, pkgtype) & end do ! case ('GWE') - do n = 1, GWE_NMULTIPKG + do n = 1, GWE_NMULTIPKG if (GWE_MULTIPKG(n) == pkgtype) then multi_pkg = .true. exit From a2063abfb971b0829962f1bad9b00e6f34573e46 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 12:53:33 -0700 Subject: [PATCH 175/212] Meson --- src/meson.build | 41 +++++++++++++++++++++++++++++++---------- 1 file changed, 31 insertions(+), 10 deletions(-) diff --git a/src/meson.build b/src/meson.build index d84924ee05e..6a28e559034 100644 --- a/src/meson.build +++ b/src/meson.build @@ -28,6 +28,8 @@ modflow_sources = files( 'Exchange' / 'BaseExchange.f90', 'Exchange' / 'DisConnExchange.f90', 'Exchange' / 'GhostNode.f90', + 'Exchange' / 'GweGweExchange.f90', + 'Exchange' / 'GwfGweExchange.f90', 'Exchange' / 'GwfGwfExchange.f90', 'Exchange' / 'GwfGwtExchange.f90', 'Exchange' / 'GwtGwtExchange.f90', @@ -37,8 +39,10 @@ modflow_sources = files( 'Model' / 'Connection' / 'CsrUtils.f90', 'Model' / 'Connection' / 'GridConnection.f90', 'Model' / 'Connection' / 'GridSorting.f90', + 'Model' / 'Connection' / 'GweGweConnection.f90', 'Model' / 'Connection' / 'GwfGwfConnection.f90', 'Model' / 'Connection' / 'GwtGwtConnection.f90', + 'Model' / 'Connection' / 'GweInterfaceModel.f90', 'Model' / 'Connection' / 'GwfInterfaceModel.f90', 'Model' / 'Connection' / 'GwtInterfaceModel.f90', 'Model' / 'Connection' / 'SpatialModelConnection.f90', @@ -46,6 +50,19 @@ modflow_sources = files( 'Model' / 'Geometry' / 'BaseGeometry.f90', 'Model' / 'Geometry' / 'CircularGeometry.f90', 'Model' / 'Geometry' / 'RectangularGeometry.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1dis1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1disu1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1disv1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1dsp1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1dspidm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1lke1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1mst1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1mwe1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1sfe1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1src1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1uze1.f90', 'Model' / 'GroundWaterFlow' / 'gwf3.f90', 'Model' / 'GroundWaterFlow' / 'gwf3api8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3buy8.f90', @@ -81,32 +98,25 @@ modflow_sources = files( 'Model' / 'GroundWaterFlow' / 'gwf3vsc8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3wel8.f90', 'Model' / 'GroundWaterTransport' / 'gwt1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1adv1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1apt1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1cnc1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dis1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disu1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disv1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dsp.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dspidm.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1fmi1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1ic1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ist1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1lkt1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1mst1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1mvt1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1mwt1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1obs1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1oc1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1sft1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1src1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1ssm1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1uzt1.f90', 'Model' / 'ModelUtilities' / 'BoundaryPackage.f90', 'Model' / 'ModelUtilities' / 'Connections.f90', 'Model' / 'ModelUtilities' / 'DiscretizationBase.f90', 'Model' / 'ModelUtilities' / 'DisvGeom.f90', + 'Model' / 'ModelUtilities' / 'GweDspOptions.f90', + 'Model' / 'ModelUtilities' / 'GweInputData.f90', 'Model' / 'ModelUtilities' / 'GwfBuyInputData.f90', 'Model' / 'ModelUtilities' / 'GwfMvrPeriodData.f90', 'Model' / 'ModelUtilities' / 'GwfNpfOptions.f90', @@ -119,14 +129,25 @@ modflow_sources = files( 'Model' / 'ModelUtilities' / 'PackageMover.f90', 'Model' / 'ModelUtilities' / 'SfrCrossSectionManager.f90', 'Model' / 'ModelUtilities' / 'SfrCrossSectionUtils.f90', + 'Model' / 'ModelUtilities' / 'TspAdvOptions.f90', + 'Model' / 'ModelUtilities' / 'TspLabels.f90', 'Model' / 'ModelUtilities' / 'UzfCellGroup.f90', 'Model' / 'ModelUtilities' / 'Xt3dAlgorithm.f90', 'Model' / 'ModelUtilities' / 'Xt3dInterface.f90', + 'Model' / 'TransportModel' / 'tsp1.f90', + 'Model' / 'TransportModel' / 'tsp1adv1.f90', + 'Model' / 'TransportModel' / 'tsp1apt1.f90', + 'Model' / 'TransportModel' / 'tsp1cnc1.f90', + 'Model' / 'TransportModel' / 'tsp1fmi1.f90', + 'Model' / 'TransportModel' / 'tsp1ic1.f90', + 'Model' / 'TransportModel' / 'tsp1mvt1.f90', + 'Model' / 'TransportModel' / 'tsp1obs1.f90', + 'Model' / 'TransportModel' / 'tsp1oc1.f90', + 'Model' / 'TransportModel' / 'tsp1ssm1.f90', 'Model' / 'BaseModel.f90', 'Model' / 'ExplicitModel.f90', 'Model' / 'NumericalModel.f90', 'Model' / 'NumericalPackage.f90', - 'Model' / 'TransportModel.f90', 'Solution' / 'LinearMethods' / 'ims8base.f90', 'Solution' / 'LinearMethods' / 'ims8linear.f90', 'Solution' / 'LinearMethods' / 'ims8reordering.f90', From e3ee30073741a5ca73736e6bf9e2ac28b164ef22 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 13:00:58 -0700 Subject: [PATCH 176/212] Meson typo --- src/meson.build | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/meson.build b/src/meson.build index 6a28e559034..3085637b86c 100644 --- a/src/meson.build +++ b/src/meson.build @@ -101,7 +101,7 @@ modflow_sources = files( 'Model' / 'GroundWaterTransport' / 'gwt1dis1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disu1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disv1idm.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1dsp.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dsp1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dspidm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ist1.f90', From 8873acf83613d1e31764f314aac10a8add35db19 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 13:04:38 -0700 Subject: [PATCH 177/212] forgot to run distribution/build_makefiles.py --- make/makedefaults | 4 +- make/makefile | 142 ++++++++++++++++++++++++++++------------------ 2 files changed, 88 insertions(+), 58 deletions(-) diff --git a/make/makedefaults b/make/makedefaults index 7bbd4dd3293..fd9328048d6 100644 --- a/make/makedefaults +++ b/make/makedefaults @@ -57,11 +57,11 @@ OPTLEVEL ?= -O2 # set the fortran flags ifeq ($(detected_OS), Windows) ifeq ($(FC), gfortran) - FFLAGS ?= -static -fbacktrace -ffpe-summary=overflow -ffpe-trap=overflow,zero,invalid $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp + FFLAGS ?= -static -fbacktrace $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp endif else ifeq ($(FC), gfortran) - FFLAGS ?= -fbacktrace -ffpe-summary=overflow -ffpe-trap=overflow,zero,invalid $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp + FFLAGS ?= -fbacktrace $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp endif ifeq ($(FC), $(filter $(FC), ifort mpiifort)) FFLAGS ?= -no-heap-arrays -fpe0 -traceback -fpp diff --git a/make/makefile b/make/makefile index 90d440be5b6..047b1678063 100644 --- a/make/makefile +++ b/make/makefile @@ -4,36 +4,38 @@ include ./makedefaults # Define the source file directories -SOURCEDIR1=../src -SOURCEDIR2=../src/Distributed -SOURCEDIR3=../src/Exchange -SOURCEDIR4=../src/Model -SOURCEDIR5=../src/Model/Connection -SOURCEDIR6=../src/Model/Geometry -SOURCEDIR7=../src/Model/GroundWaterFlow -SOURCEDIR8=../src/Model/GroundWaterTransport -SOURCEDIR9=../src/Model/ModelUtilities -SOURCEDIR10=../src/Solution -SOURCEDIR11=../src/Solution/LinearMethods -SOURCEDIR12=../src/Solution/PETSc -SOURCEDIR13=../src/Timing -SOURCEDIR14=../src/Utilities -SOURCEDIR15=../src/Utilities/ArrayRead -SOURCEDIR16=../src/Utilities/Idm -SOURCEDIR17=../src/Utilities/Idm/mf6blockfile -SOURCEDIR18=../src/Utilities/Idm/selector -SOURCEDIR19=../src/Utilities/Libraries -SOURCEDIR20=../src/Utilities/Libraries/blas -SOURCEDIR21=../src/Utilities/Libraries/daglib -SOURCEDIR22=../src/Utilities/Libraries/rcm -SOURCEDIR23=../src/Utilities/Libraries/sparsekit -SOURCEDIR24=../src/Utilities/Libraries/sparskit2 -SOURCEDIR25=../src/Utilities/Matrix -SOURCEDIR26=../src/Utilities/Memory -SOURCEDIR27=../src/Utilities/Observation -SOURCEDIR28=../src/Utilities/OutputControl -SOURCEDIR29=../src/Utilities/TimeSeries -SOURCEDIR30=../src/Utilities/Vector +SOURCEDIR1=..\src +SOURCEDIR2=..\src\Distributed +SOURCEDIR3=..\src\Exchange +SOURCEDIR4=..\src\Model +SOURCEDIR5=..\src\Model\Connection +SOURCEDIR6=..\src\Model\Geometry +SOURCEDIR7=..\src\Model\GroundWaterEnergy +SOURCEDIR8=..\src\Model\GroundWaterFlow +SOURCEDIR9=..\src\Model\GroundWaterTransport +SOURCEDIR10=..\src\Model\ModelUtilities +SOURCEDIR11=..\src\Model\TransportModel +SOURCEDIR12=..\src\Solution +SOURCEDIR13=..\src\Solution\LinearMethods +SOURCEDIR14=..\src\Solution\PETSc +SOURCEDIR15=..\src\Timing +SOURCEDIR16=..\src\Utilities +SOURCEDIR17=..\src\Utilities\ArrayRead +SOURCEDIR18=..\src\Utilities\Idm +SOURCEDIR19=..\src\Utilities\Idm\mf6blockfile +SOURCEDIR20=..\src\Utilities\Idm\selector +SOURCEDIR21=..\src\Utilities\Libraries +SOURCEDIR22=..\src\Utilities\Libraries\blas +SOURCEDIR23=..\src\Utilities\Libraries\daglib +SOURCEDIR24=..\src\Utilities\Libraries\rcm +SOURCEDIR25=..\src\Utilities\Libraries\sparsekit +SOURCEDIR26=..\src\Utilities\Libraries\sparskit2 +SOURCEDIR27=..\src\Utilities\Matrix +SOURCEDIR28=..\src\Utilities\Memory +SOURCEDIR29=..\src\Utilities\Observation +SOURCEDIR30=..\src\Utilities\OutputControl +SOURCEDIR31=..\src\Utilities\TimeSeries +SOURCEDIR32=..\src\Utilities\Vector VPATH = \ ${SOURCEDIR1} \ @@ -65,7 +67,9 @@ ${SOURCEDIR26} \ ${SOURCEDIR27} \ ${SOURCEDIR28} \ ${SOURCEDIR29} \ -${SOURCEDIR30} +${SOURCEDIR30} \ +${SOURCEDIR31} \ +${SOURCEDIR32} .SUFFIXES: .f90 .F90 .o @@ -116,6 +120,7 @@ $(OBJDIR)/Observe.o \ $(OBJDIR)/TimeArraySeriesLink.o \ $(OBJDIR)/ObsUtility.o \ $(OBJDIR)/ObsContainer.o \ +$(OBJDIR)/TspLabels.o \ $(OBJDIR)/BudgetFileReader.o \ $(OBJDIR)/TimeArraySeriesManager.o \ $(OBJDIR)/PackageMover.o \ @@ -133,6 +138,7 @@ $(OBJDIR)/LinearSolverBase.o \ $(OBJDIR)/ims8reordering.o \ $(OBJDIR)/VirtualBase.o \ $(OBJDIR)/STLVecInt.o \ +$(OBJDIR)/PrintSaveManager.o \ $(OBJDIR)/InputDefinition.o \ $(OBJDIR)/SfrCrossSectionManager.o \ $(OBJDIR)/dag_module.o \ @@ -144,6 +150,10 @@ $(OBJDIR)/ims8base.o \ $(OBJDIR)/VirtualDataLists.o \ $(OBJDIR)/VirtualDataContainer.o \ $(OBJDIR)/SimStages.o \ +$(OBJDIR)/PackageBudget.o \ +$(OBJDIR)/HeadFileReader.o \ +$(OBJDIR)/OutputControlData.o \ +$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/simnamidm.o \ $(OBJDIR)/gwt1idm.o \ $(OBJDIR)/gwt1dspidm.o \ @@ -155,9 +165,11 @@ $(OBJDIR)/gwf3idm.o \ $(OBJDIR)/gwf3disv8idm.o \ $(OBJDIR)/gwf3disu8idm.o \ $(OBJDIR)/gwf3dis8idm.o \ -$(OBJDIR)/PackageBudget.o \ -$(OBJDIR)/HeadFileReader.o \ -$(OBJDIR)/PrintSaveManager.o \ +$(OBJDIR)/gwe1idm.o \ +$(OBJDIR)/gwe1dspidm.o \ +$(OBJDIR)/gwe1disv1idm.o \ +$(OBJDIR)/gwe1disu1idm.o \ +$(OBJDIR)/gwe1dis1idm.o \ $(OBJDIR)/Xt3dAlgorithm.o \ $(OBJDIR)/gwf3tvbase8.o \ $(OBJDIR)/gwf3sfr8.o \ @@ -175,61 +187,63 @@ $(OBJDIR)/ims8linear.o \ $(OBJDIR)/BaseSolution.o \ $(OBJDIR)/IndexMap.o \ $(OBJDIR)/VirtualModel.o \ +$(OBJDIR)/tsp1fmi1.o \ +$(OBJDIR)/GwtSpc.o \ +$(OBJDIR)/GweInputData.o \ +$(OBJDIR)/OutputControl.o \ +$(OBJDIR)/tsp1ic1.o \ +$(OBJDIR)/TspAdvOptions.o \ +$(OBJDIR)/MemoryManagerExt.o \ $(OBJDIR)/IdmSimDfnSelector.o \ $(OBJDIR)/IdmGwtDfnSelector.o \ $(OBJDIR)/IdmGwfDfnSelector.o \ +$(OBJDIR)/IdmGweDfnSelector.o \ $(OBJDIR)/UzfCellGroup.o \ -$(OBJDIR)/gwt1fmi1.o \ -$(OBJDIR)/OutputControlData.o \ -$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3tvk8.o \ -$(OBJDIR)/MemoryManagerExt.o \ -$(OBJDIR)/gwf3vsc8.o \ +$(OBJDIR)/gwf3vsc8_memoryMng_strings.o \ $(OBJDIR)/GwfNpfOptions.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/InterfaceMap.o \ $(OBJDIR)/CellWithNbrs.o \ +$(OBJDIR)/tsp1ssm1.o \ +$(OBJDIR)/tsp1oc1.o \ +$(OBJDIR)/tsp1obs1.o \ +$(OBJDIR)/tsp1mvt1.o \ +$(OBJDIR)/tsp1adv1.o \ +$(OBJDIR)/gwt1mst1.o \ +$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/gwf3disu8.o \ +$(OBJDIR)/gwf3dis8.o \ +$(OBJDIR)/gwe1mst1.o \ $(OBJDIR)/IdmDfnSelector.o \ $(OBJDIR)/gwf3uzf8.o \ -$(OBJDIR)/gwt1apt1.o \ -$(OBJDIR)/GwtSpc.o \ -$(OBJDIR)/OutputControl.o \ -$(OBJDIR)/gwt1ic1.o \ -$(OBJDIR)/gwt1mst1.o \ +$(OBJDIR)/tsp1apt1.o \ $(OBJDIR)/GwtDspOptions.o \ $(OBJDIR)/gwf3npf8.o \ -$(OBJDIR)/GwtAdvOptions.o \ $(OBJDIR)/gwf3tvs8.o \ $(OBJDIR)/GwfStorageUtils.o \ $(OBJDIR)/Mover.o \ $(OBJDIR)/GwfMvrPeriodData.o \ $(OBJDIR)/ims8misc.o \ $(OBJDIR)/GwfBuyInputData.o \ +$(OBJDIR)/GweDspOptions.o \ $(OBJDIR)/VirtualSolution.o \ $(OBJDIR)/ArrayReaderBase.o \ $(OBJDIR)/VirtualExchange.o \ -$(OBJDIR)/gwf3disu8.o \ $(OBJDIR)/GridSorting.o \ $(OBJDIR)/DisConnExchange.o \ $(OBJDIR)/CsrUtils.o \ -$(OBJDIR)/TransportModel.o \ +$(OBJDIR)/tsp1cnc1.o \ +$(OBJDIR)/tsp1.o \ $(OBJDIR)/ModelPackageInputs.o \ $(OBJDIR)/gwt1uzt1.o \ -$(OBJDIR)/gwt1ssm1.o \ $(OBJDIR)/gwt1src1.o \ $(OBJDIR)/gwt1sft1.o \ -$(OBJDIR)/gwt1oc1.o \ -$(OBJDIR)/gwt1obs1.o \ $(OBJDIR)/gwt1mwt1.o \ -$(OBJDIR)/gwt1mvt1.o \ $(OBJDIR)/gwt1lkt1.o \ $(OBJDIR)/gwt1ist1.o \ -$(OBJDIR)/gwt1dsp.o \ -$(OBJDIR)/gwt1cnc1.o \ -$(OBJDIR)/gwt1adv1.o \ -$(OBJDIR)/gwf3disv8.o \ -$(OBJDIR)/gwf3dis8.o \ +$(OBJDIR)/gwt1dsp1.o \ $(OBJDIR)/gwf3api8.o \ $(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/gwf3rch8.o \ @@ -243,12 +257,19 @@ $(OBJDIR)/gwf3buy8.o \ $(OBJDIR)/GhostNode.o \ $(OBJDIR)/gwf3evt8.o \ $(OBJDIR)/gwf3chd8.o \ +$(OBJDIR)/gwe1uze1.o \ +$(OBJDIR)/gwe1src1.o \ +$(OBJDIR)/gwe1sfe1.o \ +$(OBJDIR)/gwe1mwe1.o \ +$(OBJDIR)/gwe1lke1.o \ +$(OBJDIR)/gwe1dsp1.o \ $(OBJDIR)/RouterBase.o \ $(OBJDIR)/Integer2dReader.o \ $(OBJDIR)/GridConnection.o \ $(OBJDIR)/DistributedVariable.o \ $(OBJDIR)/gwt1.o \ $(OBJDIR)/gwf3.o \ +$(OBJDIR)/gwe1.o \ $(OBJDIR)/SerialRouter.o \ $(OBJDIR)/StructVector.o \ $(OBJDIR)/IdmLogger.o \ @@ -261,6 +282,8 @@ $(OBJDIR)/GwtInterfaceModel.o \ $(OBJDIR)/GwtGwtExchange.o \ $(OBJDIR)/GwfInterfaceModel.o \ $(OBJDIR)/GwfGwfExchange.o \ +$(OBJDIR)/GweInterfaceModel.o \ +$(OBJDIR)/GweGweExchange.o \ $(OBJDIR)/RouterFactory.o \ $(OBJDIR)/MappedMemory.o \ $(OBJDIR)/StructArray.o \ @@ -270,6 +293,7 @@ $(OBJDIR)/DefinitionSelect.o \ $(OBJDIR)/ExplicitSolution.o \ $(OBJDIR)/GwtGwtConnection.o \ $(OBJDIR)/GwfGwfConnection.o \ +$(OBJDIR)/GweGweConnection.o \ $(OBJDIR)/VirtualDataManager.o \ $(OBJDIR)/Mapper.o \ $(OBJDIR)/LoadMf6File.o \ @@ -277,9 +301,12 @@ $(OBJDIR)/VirtualGwtModel.o \ $(OBJDIR)/VirtualGwtExchange.o \ $(OBJDIR)/VirtualGwfModel.o \ $(OBJDIR)/VirtualGwfExchange.o \ +$(OBJDIR)/VirtualGweModel.o \ +$(OBJDIR)/VirtualGweExchange.o \ $(OBJDIR)/SolutionGroup.o \ $(OBJDIR)/SolutionFactory.o \ $(OBJDIR)/GwfGwtExchange.o \ +$(OBJDIR)/GwfGweExchange.o \ $(OBJDIR)/RunControl.o \ $(OBJDIR)/IdmMf6File.o \ $(OBJDIR)/SimulationCreate.o \ @@ -297,6 +324,9 @@ $(OBJDIR)/sparsekit.o \ $(OBJDIR)/rcm.o \ $(OBJDIR)/blas1_d.o \ $(OBJDIR)/Iunit.o \ +$(OBJDIR)/LatHeatVapor.o \ +$(OBJDIR)/GwtAdvOptions.o \ +$(OBJDIR)/gwf3vsc8.o \ $(OBJDIR)/RectangularGeometry.o \ $(OBJDIR)/CircularGeometry.o From 013691e4a46d62af4079cf2a3d6d9274d00c9464 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 14:58:45 -0700 Subject: [PATCH 178/212] Updating some material that was lost in a merge conflict --- doc/mf6io/gwe/gwe.tex | 2 +- make/makedefaults | 4 +- src/Model/GroundWaterTransport/gwt1.f90 | 784 ++++---------------- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 146 ++-- 4 files changed, 221 insertions(+), 715 deletions(-) diff --git a/doc/mf6io/gwe/gwe.tex b/doc/mf6io/gwe/gwe.tex index 7cd4487ee9a..35a7b47f374 100644 --- a/doc/mf6io/gwe/gwe.tex +++ b/doc/mf6io/gwe/gwe.tex @@ -74,7 +74,7 @@ \subsection{Time Stepping} \newpage -\subsection{GWT Model Name File} +\subsection{GWE Model Name File} \input{gwe/namefile.tex} %\newpage diff --git a/make/makedefaults b/make/makedefaults index fd9328048d6..7bbd4dd3293 100644 --- a/make/makedefaults +++ b/make/makedefaults @@ -57,11 +57,11 @@ OPTLEVEL ?= -O2 # set the fortran flags ifeq ($(detected_OS), Windows) ifeq ($(FC), gfortran) - FFLAGS ?= -static -fbacktrace $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp + FFLAGS ?= -static -fbacktrace -ffpe-summary=overflow -ffpe-trap=overflow,zero,invalid $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp endif else ifeq ($(FC), gfortran) - FFLAGS ?= -fbacktrace $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp + FFLAGS ?= -fbacktrace -ffpe-summary=overflow -ffpe-trap=overflow,zero,invalid $(OS_macro) -fall-intrinsics -Wtabs -Wline-truncation -Wunused-label -Wunused-variable -pedantic -std=f2008 -Wcharacter-truncation -cpp endif ifeq ($(FC), $(filter $(FC), ifort mpiifort)) FFLAGS ?= -no-heap-arrays -fpe0 -traceback -fpp diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 281fd2b4931..1c3ae816011 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -8,22 +8,15 @@ module GwtModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENFTYPE, LENMEMPATH, DZERO, LENPAKLOC + use ConstantsModule, only: LENFTYPE, LENMEMPATH, DZERO, LENPAKLOC, DONE use VersionModule, only: write_listfile_header use NumericalModelModule, only: NumericalModelType - use TransportModelModule, only: TransportModelType use BaseModelModule, only: BaseModelType use BndModule, only: BndType, AddBndToList, GetBndFromList - use GwtIcModule, only: GwtIcType - use GwtFmiModule, only: GwtFmiType - use GwtAdvModule, only: GwtAdvType use GwtDspModule, only: GwtDspType - use GwtSsmModule, only: GwtSsmType - use GwtMvtModule, only: GwtMvtType use GwtMstModule, only: GwtMstType - use GwtOcModule, only: GwtOcType - use GwtObsModule, only: GwtObsType use BudgetModule, only: BudgetType + use TransportModelModule use MatrixBaseModule implicit none @@ -32,28 +25,21 @@ module GwtModule public :: gwt_cr public :: GwtModelType public :: CastAsGwtModel + public :: niunit type, extends(TransportModelType) :: GwtModelType - type(GwtIcType), pointer :: ic => null() ! initial conditions package - type(GwtFmiType), pointer :: fmi => null() ! flow model interface type(GwtMstType), pointer :: mst => null() ! mass storage and transfer package - type(GwtAdvType), pointer :: adv => null() ! advection package type(GwtDspType), pointer :: dsp => null() ! dispersion package - type(GwtSsmType), pointer :: ssm => null() ! source sink mixing package - type(GwtMvtType), pointer :: mvt => null() ! mover transport package - type(GwtOcType), pointer :: oc => null() ! output control package - type(GwtObsType), pointer :: obs => null() ! observation package - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: infmi => null() ! unit number FMI - integer(I4B), pointer :: inmvt => null() ! unit number MVT + ! integer(I4B), pointer :: inic => null() ! unit number IC + ! integer(I4B), pointer :: infmi => null() ! unit number FMI + ! integer(I4B), pointer :: inmvt => null() ! unit number MVT integer(I4B), pointer :: inmst => null() ! unit number MST - integer(I4B), pointer :: inadv => null() ! unit number ADV + ! integer(I4B), pointer :: inadv => null() ! unit number ADV integer(I4B), pointer :: indsp => null() ! DSP enabled flag - integer(I4B), pointer :: inssm => null() ! unit number SSM - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: inobs => null() ! unit number OBS + ! integer(I4B), pointer :: inssm => null() ! unit number SSM + ! integer(I4B), pointer :: inoc => null() ! unit number OC + ! integer(I4B), pointer :: inobs => null() ! unit number OBS contains @@ -72,49 +58,47 @@ module GwtModule procedure :: model_da => gwt_da procedure :: model_bdentry => gwt_bdentry - procedure :: allocate_scalars + procedure :: allocate_gwt_scalars procedure, private :: package_create - procedure, private :: ftype_check procedure :: get_iasym => gwt_get_iasym - procedure, private :: gwt_ot_flow - procedure, private :: gwt_ot_flowja - procedure, private :: gwt_ot_dv - procedure, private :: gwt_ot_bdsummary - procedure, private :: gwt_ot_obs - procedure, private :: create_packages + procedure, private :: create_gwt_specific_packages procedure, private :: create_bndpkgs - procedure, private :: create_lstfile - procedure, private :: log_namfile_options + end type GwtModelType contains + !> @brief Create a new groundwater energy transport model object + !< subroutine gwt_cr(filename, id, modelname) -! ****************************************************************************** -! gwt_cr -- Create a new groundwater transport model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ListsModule, only: basemodellist use BaseModelModule, only: AddBaseModelToList - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use MemoryHelperModule, only: create_mem_path use MemoryManagerExtModule, only: mem_set_value use SimVariablesModule, only: idm_context use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr + use TspLabelsModule, only: tsplabels_cr + use GwtMstModule, only: mst_cr + use GwtDspModule, only: dsp_cr ! -- dummy character(len=*), intent(in) :: filename integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local + integer(I4B) :: indis !, indis6, indisu6, indisv6 + integer(I4B) :: ipakid, i, j, iu, ipaknum + character(len=LINELENGTH) :: errmsg + character(len=LENPACKAGENAME) :: pakname + !type(NameFileType) :: namefile_obj type(GwtModelType), pointer :: this class(BaseModelType), pointer :: model character(len=LENMEMPATH) :: input_mempath character(len=LINELENGTH) :: lst_fname type(GwfNamParamFoundType) :: found + cunit(10) = 'CNC6' ! -- format ! ------------------------------------------------------------------------------ ! @@ -124,77 +108,51 @@ subroutine gwt_cr(filename, id, modelname) ! -- Set memory path before allocation in memory manager can be done this%memoryPath = create_mem_path(modelname) ! - call this%allocate_scalars(modelname) + call this%allocate_tsp_scalars(modelname) + call this%allocate_gwt_scalars(modelname) model => this call AddBaseModelToList(basemodellist, model) ! - ! -- Assign values - this%filename = filename - this%name = modelname - this%macronym = 'GWT' - this%id = id - ! - ! -- set input model namfile memory path - input_mempath = create_mem_path(modelname, 'NAM', idm_context) - ! - ! -- copy option params from input context - call mem_set_value(lst_fname, 'LIST', input_mempath, found%list) - call mem_set_value(this%iprpak, 'PRINT_INPUT', input_mempath, & - found%print_input) - call mem_set_value(this%iprflow, 'PRINT_FLOWS', input_mempath, & - found%print_flows) - call mem_set_value(this%ipakcb, 'SAVE_FLOWS', input_mempath, found%save_flows) - ! - ! -- create the list file - call this%create_lstfile(lst_fname, filename, found%list) - ! - ! -- activate save_flows if found - if (found%save_flows) then - this%ipakcb = -1 - end if - ! - ! -- log set options - if (this%iout > 0) then - call this%log_namfile_options(found) - end if - ! - ! -- Create utility objects - call budget_cr(this%budget, this%name) + ! -- Call parent class routine + call this%tsp_cr(filename, id, modelname, 'GWT', indis) ! ! -- create model packages - call this%create_packages() + call this%create_gwt_specific_packages(indis) ! - ! -- return + ! -- Return return end subroutine gwt_cr + !> @brief Define packages of the GWT model + !! + !! This subroutine defines a gwt model type. Steps include: + !! - call df routines for each package + !! - set variables and pointers + !< subroutine gwt_df(this) -! ****************************************************************************** -! gwt_df -- Define packages of the model -! Subroutine: (1) call df routines for each package -! (2) set variables and pointers -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ModelPackageInputsModule, only: NIUNIT_GWT + use TspLabelsModule, only: setTspLabels ! -- dummy class(GwtModelType) :: this ! -- local integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Set labels to be used with transport model + call this%tsplab%setTspLabels(this%macronym, 'CONCENTRATION', 'MASS', 'M') ! ! -- Define packages and utility objects call this%dis%dis_df() - call this%fmi%fmi_df(this%dis, this%inssm) + call this%fmi%fmi_df(this%dis, this%inssm, 1) if (this%inmvt > 0) call this%mvt%mvt_df(this%dis) if (this%inadv > 0) call this%adv%adv_df() if (this%indsp > 0) call this%dsp%dsp_df(this%dis) if (this%inssm > 0) call this%ssm%ssm_df() call this%oc%oc_df() - call this%budget%budget_df(NIUNIT_GWT, 'MASS', 'M') + call this%budget%budget_df(niunit, this%tsplab%depvarunit, & + this%tsplab%depvarunitabbrev) ! ! -- Assign or point model members to dis members this%neq = this%dis%nodes @@ -216,17 +174,13 @@ subroutine gwt_df(this) ! -- Store information needed for observations call this%obs%obs_df(this%iout, this%name, 'GWT', this%dis) ! - ! -- return + ! -- Return return end subroutine gwt_df + !> @brief Add the internal connections of this model to the sparse matrix + !< subroutine gwt_ac(this, sparse) -! ****************************************************************************** -! gwt_ac -- Add the internal connections of this model to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix ! -- dummy @@ -248,18 +202,14 @@ subroutine gwt_ac(this, sparse) call packobj%bnd_ac(this%moffset, sparse) end do ! - ! -- return + ! -- Return return end subroutine gwt_ac + !> @brief Map the positions of the GWT model connections in the numerical + !! solution coefficient matrix. + !< subroutine gwt_mc(this, matrix_sln) -! ****************************************************************************** -! gwt_mc -- Map the positions of this models connections in the -! numerical solution coefficient matrix. -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this class(MatrixBaseType), pointer :: matrix_sln !< global system matrix @@ -271,6 +221,7 @@ subroutine gwt_mc(this, matrix_sln) ! -- Find the position of each connection in the global ia, ja structure ! and store them in idxglo. call this%dis%dis_mc(this%moffset, this%idxglo, matrix_sln) + ! if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, matrix_sln) ! ! -- Map any package connections @@ -279,19 +230,17 @@ subroutine gwt_mc(this, matrix_sln) call packobj%bnd_mc(this%moffset, matrix_sln) end do ! - ! -- return + ! -- Return return end subroutine gwt_mc + !> @brief GWT Model Allocate and Read + !! + !! This subroutine: + !! - allocates and reads packages that are part of this model, + !! - allocates memory for arrays used by this model object + !< subroutine gwt_ar(this) -! ****************************************************************************** -! gwt_ar -- GroundWater Transport Model Allocate and Read -! Subroutine: (1) allocates and reads packages part of this model, -! (2) allocates memory for arrays part of this model object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: DHNOFLO ! -- dummy @@ -309,13 +258,22 @@ subroutine gwt_ar(this) if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound) if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%thetam) if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x) - if (this%inobs > 0) call this%obs%gwt_obs_ar(this%ic, this%x, this%flowja) + if (this%inobs > 0) call this%obs%tsp_obs_ar(this%ic, this%x, this%flowja) + ! + ! -- Set governing equation scale factor. Note that this scale factor + ! -- cannot be set arbitrarily. For solute transport, it must be set + ! -- to 1. Setting it to a different value will NOT automatically + ! -- scale all the terms of the governing equation correctly by that + ! -- value. This is because much of the coding in the associated + ! -- packages implicitly assumes the governing equation for solute + ! -- transport is scaled by 1. (effectively unscaled). + this%eqnsclfac = DONE ! ! -- Call dis_ar to write binary grid file !call this%dis%dis_ar(this%npf%icelltype) ! ! -- set up output control - call this%oc%oc_ar(this%x, this%dis, DHNOFLO) + call this%oc%oc_ar(this%x, this%dis, DHNOFLO, this%tsplab%depvartype) call this%budget%set_ibudcsv(this%oc%ibudcsv) ! ! -- Package input files now open, so allocate and read @@ -327,18 +285,15 @@ subroutine gwt_ar(this) call packobj%bnd_ar() end do ! - ! -- return + ! -- Return return end subroutine gwt_ar + !> @brief GWT Model Read and Prepare + !! + !! This subroutine calls the attached packages' read and prepare routines + !< subroutine gwt_rp(this) -! ****************************************************************************** -! gwt_rp -- GroundWater Transport Model Read and Prepare -! Subroutine: (1) calls package read and prepare routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: readnewdata ! -- dummy @@ -368,14 +323,11 @@ subroutine gwt_rp(this) return end subroutine gwt_rp + !> @brief GWT Model Time Step Advance + !! + !! This subroutine calls the attached packages advance subroutines + !< subroutine gwt_ad(this) -! ****************************************************************************** -! gwt_ad -- GroundWater Transport Model Time Step Advance -! Subroutine: (1) calls package advance subroutines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimVariablesModule, only: isimcheck, iFailedStepRetry ! -- dummy @@ -425,17 +377,16 @@ subroutine gwt_ad(this) ! -- Push simulated values to preceding time/subtime step call this%obs%obs_ad() ! - ! -- return + ! -- Return return end subroutine gwt_ad + !> @brief GWT Model calculate coefficients + !! + !! This subroutine calls the attached packages' calculate coefficients + !! subroutines + !< subroutine gwt_cf(this, kiter) -! ****************************************************************************** -! gwt_cf -- GroundWater Transport Model calculate coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtModelType) :: this @@ -451,17 +402,16 @@ subroutine gwt_cf(this, kiter) call packobj%bnd_cf() end do ! - ! -- return + ! -- Return return end subroutine gwt_cf + !> @brief GWT Model fill coefficients + !! + !! This subroutine calls the attached packages' fill coefficients + !! subroutines + !< subroutine gwt_fc(this, kiter, matrix_sln, inwtflag) -! ****************************************************************************** -! gwt_fc -- GroundWater Transport Model fill coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtModelType) :: this @@ -501,18 +451,16 @@ subroutine gwt_fc(this, kiter, matrix_sln, inwtflag) call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, matrix_sln) end do ! - ! -- return + ! -- Return return end subroutine gwt_fc + !> @brief GWT Model Final Convergence Check + !! + !! If MVR/MVT is active, this subroutine calls the MVR convergence check + !! subroutines. + !< subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) -! ****************************************************************************** -! gwt_cc -- GroundWater Transport Model Final Convergence Check -! Subroutine: (1) calls package cc routines -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- dummy class(GwtModelType) :: this integer(I4B), intent(in) :: innertot @@ -523,32 +471,21 @@ subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) integer(I4B), intent(inout) :: ipak real(DP), intent(inout) :: dpak ! -- local - !class(BndType), pointer :: packobj - !integer(I4B) :: ip ! -- formats ! ------------------------------------------------------------------------------ ! ! -- If mover is on, then at least 2 outers required if (this%inmvt > 0) call this%mvt%mvt_cc(kiter, iend, icnvgmod, cpak, dpak) ! - ! -- Call package cc routines - !do ip = 1, this%bndlist%Count() - ! packobj => GetBndFromList(this%bndlist, ip) - ! call packobj%bnd_cc(iend, icnvg, hclose, rclose) - !enddo - ! - ! -- return + ! -- Return return end subroutine gwt_cc + !> @brief GWT Model calculate flow + !! + !! This subroutine calls the attached packages' intercell flows (flow ja) + !< subroutine gwt_cq(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwt_cq --Groundwater transport model calculate flow -! Subroutine: (1) Calculate intercell flows (flowja) -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: csr_diagsum ! -- dummy @@ -594,15 +531,13 @@ subroutine gwt_cq(this, icnvg, isuppress_output) return end subroutine gwt_cq + !> @brief GWT Model Budget + !! + !! This subroutine: + !! - calculates intercell flows (flowja) + !! - calculates package contributions to the model budget + !< subroutine gwt_bd(this, icnvg, isuppress_output) -! ****************************************************************************** -! gwt_bd --GroundWater Transport Model Budget -! Subroutine: (1) Calculate intercell flows (flowja) -! (2) Calculate package contributions to model budget -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ use ConstantsModule, only: DZERO ! -- dummy class(GwtModelType) :: this @@ -629,241 +564,35 @@ subroutine gwt_bd(this, icnvg, isuppress_output) packobj => GetBndFromList(this%bndlist, ip) call packobj%bnd_bd(this%budget) end do - ! ! -- Return return end subroutine gwt_bd + !> @brief GWT Model Output + !! + !! This subroutine calls the parent class output routine. + !< subroutine gwt_ot(this) -! ****************************************************************************** -! gwt_ot -- GroundWater Transport Model Output -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(GwtModelType) :: this ! -- local - integer(I4B) :: idvsave - integer(I4B) :: idvprint - integer(I4B) :: icbcfl - integer(I4B) :: icbcun - integer(I4B) :: ibudfl - integer(I4B) :: ipflag - ! -- formats - character(len=*), parameter :: fmtnocnvg = & - "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', & - &I0,' OF STRESS PERIOD ',I0,'****')" ! ------------------------------------------------------------------------------ ! - ! -- Set write and print flags - idvsave = 0 - idvprint = 0 - icbcfl = 0 - ibudfl = 0 - if (this%oc%oc_save('CONCENTRATION')) idvsave = 1 - if (this%oc%oc_print('CONCENTRATION')) idvprint = 1 - if (this%oc%oc_save('BUDGET')) icbcfl = 1 - if (this%oc%oc_print('BUDGET')) ibudfl = 1 - icbcun = this%oc%oc_save_unit('BUDGET') - ! - ! -- Override ibudfl and idvprint flags for nonconvergence - ! and end of period - ibudfl = this%oc%set_print_flag('BUDGET', this%icnvg, endofperiod) - idvprint = this%oc%set_print_flag('CONCENTRATION', this%icnvg, endofperiod) - ! - ! Calculate and save observations - call this%gwt_ot_obs() - ! - ! Save and print flows - call this%gwt_ot_flow(icbcfl, ibudfl, icbcun) - ! - ! Save and print dependent variables - call this%gwt_ot_dv(idvsave, idvprint, ipflag) - ! - ! Print budget summaries - call this%gwt_ot_bdsummary(ibudfl, ipflag) - ! - ! -- Timing Output; if any dependendent variables or budgets - ! are printed, then ipflag is set to 1. - if (ipflag == 1) call tdis_ot(this%iout) - ! - ! -- Write non-convergence message - if (this%icnvg == 0) then - write (this%iout, fmtnocnvg) kstp, kper - end if + ! -- Call parent class _ot routines. + call this%tsp_ot(this%inmst) ! ! -- Return return end subroutine gwt_ot - subroutine gwt_ot_obs(this) - class(GwtModelType) :: this - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Calculate and save observations - call this%obs%obs_bd() - call this%obs%obs_ot() - - ! -- Calculate and save package obserations - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_bd_obs() - call packobj%bnd_ot_obs() - end do - - end subroutine gwt_ot_obs - - subroutine gwt_ot_flow(this, icbcfl, ibudfl, icbcun) - class(GwtModelType) :: this - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(in) :: icbcun - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Save GWT flows - call this%gwt_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) - if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) - if (this%inssm > 0) then - call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) - end if - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) - end do - - ! -- Save advanced package flows - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_package_flows(icbcfl=icbcfl, ibudfl=0) - end do - if (this%inmvt > 0) then - call this%mvt%mvt_ot_saveflow(icbcfl, ibudfl) - end if - - ! -- Print GWF flows - ! no need to print flowja - ! no need to print mst - ! no need to print fmi - if (this%inssm > 0) then - call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) - end if - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_model_flows(icbcfl=icbcfl, ibudfl=ibudfl, icbcun=0) - end do - - ! -- Print advanced package flows - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_package_flows(icbcfl=0, ibudfl=ibudfl) - end do - if (this%inmvt > 0) then - call this%mvt%mvt_ot_printflow(icbcfl, ibudfl) - end if - - end subroutine gwt_ot_flow - - subroutine gwt_ot_flowja(this, nja, flowja, icbcfl, icbcun) -! ****************************************************************************** -! gwt_ot_flowja -- Write intercell flows -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- dummy - class(GwtModelType) :: this - integer(I4B), intent(in) :: nja - real(DP), dimension(nja), intent(in) :: flowja - integer(I4B), intent(in) :: icbcfl - integer(I4B), intent(in) :: icbcun - ! -- local - integer(I4B) :: ibinun - ! -- formats -! ------------------------------------------------------------------------------ - ! - ! -- Set unit number for binary output - if (this%ipakcb < 0) then - ibinun = icbcun - elseif (this%ipakcb == 0) then - ibinun = 0 - else - ibinun = this%ipakcb - end if - if (icbcfl == 0) ibinun = 0 - ! - ! -- Write the face flows if requested - if (ibinun /= 0) then - call this%dis%record_connection_array(flowja, ibinun, this%iout) - end if - ! - ! -- Return - return - end subroutine gwt_ot_flowja - - subroutine gwt_ot_dv(this, idvsave, idvprint, ipflag) - class(GwtModelType) :: this - integer(I4B), intent(in) :: idvsave - integer(I4B), intent(in) :: idvprint - integer(I4B), intent(inout) :: ipflag - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! -- Print advanced package dependent variables - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_dv(idvsave, idvprint) - end do - - ! -- save head and print head - call this%oc%oc_ot(ipflag) - - end subroutine gwt_ot_dv - - subroutine gwt_ot_bdsummary(this, ibudfl, ipflag) - use TdisModule, only: kstp, kper, totim - class(GwtModelType) :: this - integer(I4B), intent(in) :: ibudfl - integer(I4B), intent(inout) :: ipflag - class(BndType), pointer :: packobj - integer(I4B) :: ip - - ! - ! -- Package budget summary - do ip = 1, this%bndlist%Count() - packobj => GetBndFromList(this%bndlist, ip) - call packobj%bnd_ot_bdsummary(kstp, kper, this%iout, ibudfl) - end do - - ! -- mover budget summary - if (this%inmvt > 0) then - call this%mvt%mvt_ot_bdsummary(ibudfl) - end if - - ! -- model budget summary - if (ibudfl /= 0) then - ipflag = 1 - call this%budget%budget_ot(kstp, kper, this%iout) - end if - - ! -- Write to budget csv - call this%budget%writecsv(totim) - - end subroutine gwt_ot_bdsummary - + !> @brief Deallocate + !! + !! Deallocate memmory at conclusion of model run + !< subroutine gwt_da(this) -! ****************************************************************************** -! gwt_da -- Deallocate -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate use MemoryManagerExtModule, only: memorylist_remove @@ -874,6 +603,10 @@ subroutine gwt_da(this) integer(I4B) :: ip class(BndType), pointer :: packobj ! ------------------------------------------------------------------------------ + ! + ! -- Scalars + call mem_deallocate(this%inmst) + call mem_deallocate(this%indsp) ! ! -- Deallocate idm memory call memorylist_remove(this%name, 'NAM', idm_context) @@ -891,6 +624,7 @@ subroutine gwt_da(this) call this%budget%budget_da() call this%oc%oc_da() call this%obs%obs_da() + call this%tsplab%tsplabels_da() ! ! -- Internal package objects deallocate (this%dis) @@ -904,6 +638,7 @@ subroutine gwt_da(this) deallocate (this%budget) deallocate (this%oc) deallocate (this%obs) + deallocate (this%tsplab) ! ! -- Boundary packages do ip = 1, this%bndlist%Count() @@ -913,20 +648,12 @@ subroutine gwt_da(this) end do ! ! -- Scalars - call mem_deallocate(this%inic) - call mem_deallocate(this%infmi) - call mem_deallocate(this%inadv) - call mem_deallocate(this%indsp) - call mem_deallocate(this%inssm) - call mem_deallocate(this%inmst) - call mem_deallocate(this%inmvt) - call mem_deallocate(this%inoc) - call mem_deallocate(this%inobs) + call this%TransportModelType%tsp_da() ! ! -- NumericalModelType call this%NumericalModelType%model_da() ! - ! -- return + ! -- Return return end subroutine gwt_da @@ -935,8 +662,6 @@ end subroutine gwt_da !! This subroutine adds a budget entry to the flow budget. It was added as !! a method for the gwt model object so that the exchange object could add its !! contributions. - !! - !! (1) adds the entry to the budget object !< subroutine gwt_bdentry(this, budterm, budtxt, rowlabel) ! -- modules @@ -951,7 +676,7 @@ subroutine gwt_bdentry(this, budterm, budtxt, rowlabel) ! call this%budget%addentry(budterm, delt, budtxt, rowlabel=rowlabel) ! - ! -- return + ! -- Return return end subroutine gwt_bdentry @@ -984,17 +709,17 @@ function gwt_get_iasym(this) result(iasym) if (packobj%iasym /= 0) iasym = 1 end do ! - ! -- return + ! -- Return return end function gwt_get_iasym - subroutine allocate_scalars(this, modelname) -! ****************************************************************************** -! allocate_scalars -- Allocate memory for non-allocatable members -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ + !> Allocate memory for non-allocatable members + !! + !! A subroutine for allocating the scalars specific to the GWT model type. + !! Additional scalars used by the parent class are allocated by the parent + !! class. + !< + subroutine allocate_gwt_scalars(this, modelname) ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -1002,46 +727,28 @@ subroutine allocate_scalars(this, modelname) character(len=*), intent(in) :: modelname ! ------------------------------------------------------------------------------ ! - ! -- allocate members from parent class - call this%NumericalModelType%allocate_scalars(modelname) - ! - ! -- allocate members that are part of model class - call mem_allocate(this%inic, 'INIC', this%memoryPath) - call mem_allocate(this%infmi, 'INFMI', this%memoryPath) - call mem_allocate(this%inmvt, 'INMVT', this%memoryPath) + ! -- allocate additional members specific to GWT model type call mem_allocate(this%inmst, 'INMST', this%memoryPath) - call mem_allocate(this%inadv, 'INADV', this%memoryPath) call mem_allocate(this%indsp, 'INDSP', this%memoryPath) - call mem_allocate(this%inssm, 'INSSM', this%memoryPath) - call mem_allocate(this%inoc, 'INOC ', this%memoryPath) - call mem_allocate(this%inobs, 'INOBS', this%memoryPath) ! - this%inic = 0 - this%infmi = 0 - this%inmvt = 0 this%inmst = 0 - this%inadv = 0 this%indsp = 0 - this%inssm = 0 - this%inoc = 0 - this%inobs = 0 ! - ! -- return + ! -- Return return - end subroutine allocate_scalars + end subroutine allocate_gwt_scalars + !> @brief Create boundary condition packages for this model + !! + !! This subroutine calls the package create routines for packages activated + !! by the user. + !< subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & iout) -! ****************************************************************************** -! package_create -- Create boundary condition packages for this model -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH use SimModule, only: store_error - use GwtCncModule, only: cnc_create + use TspCncModule, only: cnc_create use GwtSrcModule, only: src_create use GwtIstModule, only: ist_create use GwtLktModule, only: lkt_create @@ -1067,18 +774,20 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & ! -- This part creates the package object select case (filtyp) case ('CNC6') - call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab, this%eqnsclfac) case ('SRC6') - call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname, this%tsplab) case ('LKT6') call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('SFT6') call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('MWT6') call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('UZT6') call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi) @@ -1086,7 +795,8 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%mst) case ('API6') - call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname) + call api_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & + pakname) case default write (errmsg, *) 'Invalid package type: ', filtyp call store_error(errmsg, terminate=.TRUE.) @@ -1105,55 +815,12 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & end do call AddBndToList(this%bndlist, packobj) ! - ! -- return + ! -- Return return end subroutine package_create - subroutine ftype_check(this, indis) -! ****************************************************************************** -! ftype_check -- Check to make sure required input files have been specified -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules - use ConstantsModule, only: LINELENGTH - use SimModule, only: store_error, count_errors, store_error_filename - ! -- dummy - class(GwtModelType) :: this - integer(I4B), intent(in) :: indis - ! -- local - character(len=LINELENGTH) :: errmsg -! ------------------------------------------------------------------------------ - ! - ! -- Check for IC6, DIS(u), and MST. Stop if not present. - if (this%inic == 0) then - write (errmsg, '(1x,a)') & - 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - end if - if (indis == 0) then - write (errmsg, '(1x,a)') & - 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - end if - if (this%inmst == 0) then - write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & - &PACKAGE NOT SPECIFIED.' - call store_error(errmsg) - end if - ! - if (count_errors() > 0) then - write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' - call store_error(errmsg) - call store_error_filename(this%filename) - end if - ! - ! -- return - return - end subroutine ftype_check - !> @brief Cast to GwtModelType + !< function CastAsGwtModel(model) result(gwtmodel) class(*), pointer :: model !< The object to be cast class(GwtModelType), pointer :: gwtmodel !< The GWT model @@ -1164,7 +831,9 @@ function CastAsGwtModel(model) result(gwtmodel) type is (GwtModelType) gwtmodel => model end select - + ! + ! -- Return + return end function CastAsGwtModel !> @brief Source package info and begin to process @@ -1220,13 +889,13 @@ subroutine create_bndpkgs(this, bndpkgs, pkgtypes, pkgnames, & deallocate (bndpkgs) end if ! - ! -- return + ! -- Return return end subroutine create_bndpkgs !> @brief Source package info and begin to process !< - subroutine create_packages(this) + subroutine create_gwt_specific_packages(this, indis) ! -- modules use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use CharacterStringModule, only: CharacterStringType @@ -1234,20 +903,11 @@ subroutine create_packages(this) use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context - use GwfDisModule, only: dis_cr - use GwfDisvModule, only: disv_cr - use GwfDisuModule, only: disu_cr - use GwtIcModule, only: ic_cr - use GwtFmiModule, only: fmi_cr use GwtMstModule, only: mst_cr - use GwtAdvModule, only: adv_cr use GwtDspModule, only: dsp_cr - use GwtSsmModule, only: ssm_cr - use GwtMvtModule, only: mvt_cr - use GwtOcModule, only: oc_cr - use GwtObsModule, only: gwt_obs_cr ! -- dummy class(GwtModelType) :: this + integer(I4B), intent(in) :: indis ! -- local type(CharacterStringType), dimension(:), contiguous, & pointer :: pkgtypes => null() @@ -1264,7 +924,6 @@ subroutine create_packages(this) integer(I4B), pointer :: inunit integer(I4B), dimension(:), allocatable :: bndpkgs integer(I4B) :: n - integer(I4B) :: indis = 0 ! DIS enabled flag character(len=LENMEMPATH) :: mempathdsp = '' ! ! -- set input memory paths, input/model and input/model/namfile @@ -1286,34 +945,11 @@ subroutine create_packages(this) ! ! -- create dis package as it is a prerequisite for other packages select case (pkgtype) - case ('DIS6') - indis = 1 - call dis_cr(this%dis, this%name, mempath, indis, this%iout) - case ('DISV6') - indis = 1 - call disv_cr(this%dis, this%name, mempath, indis, this%iout) - case ('DISU6') - indis = 1 - call disu_cr(this%dis, this%name, mempath, indis, this%iout) - case ('IC6') - this%inic = inunit - case ('FMI6') - this%infmi = inunit - case ('MVT6') - this%inmvt = inunit case ('MST6') this%inmst = inunit - case ('ADV6') - this%inadv = inunit case ('DSP6') this%indsp = 1 mempathdsp = mempath - case ('SSM6') - this%inssm = inunit - case ('OC6') - this%inoc = inunit - case ('OBS6') - this%inobs = inunit case ('CNC6', 'SRC6', 'LKT6', 'SFT6', & 'MWT6', 'UZT6', 'IST6', 'API6') call expandarray(bndpkgs) @@ -1324,107 +960,17 @@ subroutine create_packages(this) end do ! ! -- Create packages that are tied directly to model - call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis) - call fmi_cr(this%fmi, this%name, this%infmi, this%iout) call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) - call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & + call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & this%fmi) - call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi) - call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi) - call oc_cr(this%oc, this%name, this%inoc, this%iout) - call gwt_obs_cr(this%obs, this%inobs) ! ! -- Check to make sure that required ftype's have been specified - call this%ftype_check(indis) + call this%ftype_check(indis, this%inmst) ! call this%create_bndpkgs(bndpkgs, pkgtypes, pkgnames, mempaths, inunits) - - end subroutine create_packages - - subroutine create_lstfile(this, lst_fname, model_fname, defined) - ! -- modules - use KindModule, only: LGP - use InputOutputModule, only: openfile, getunit - ! -- dummy - class(GwtModelType) :: this - character(len=*), intent(inout) :: lst_fname - character(len=*), intent(in) :: model_fname - logical(LGP), intent(in) :: defined - ! -- local - integer(I4B) :: i, istart, istop - ! - ! -- set list file name if not provided - if (.not. defined) then - ! - ! -- initialize - lst_fname = ' ' - istart = 0 - istop = len_trim(model_fname) - ! - ! -- identify '.' character position from back of string - do i = istop, 1, -1 - if (model_fname(i:i) == '.') then - istart = i - exit - end if - end do - ! - ! -- if not found start from string end - if (istart == 0) istart = istop + 1 - ! - ! -- set list file name - lst_fname = model_fname(1:istart) - istop = istart + 3 - lst_fname(istart:istop) = '.lst' - end if - ! - ! -- create the list file - this%iout = getunit() - call openfile(this%iout, 0, lst_fname, 'LIST', filstat_opt='REPLACE') ! - ! -- write list file header - call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') - ! - ! -- return + ! -- Return return - end subroutine create_lstfile - - !> @brief Write model namfile options to list file - !< - subroutine log_namfile_options(this, found) - use GwfNamInputModule, only: GwfNamParamFoundType - class(GwtModelType) :: this - type(GwfNamParamFoundType), intent(in) :: found - - write (this%iout, '(1x,a)') 'NAMEFILE OPTIONS:' - - if (found%newton) then - write (this%iout, '(4x,a)') & - 'NEWTON-RAPHSON method enabled for the model.' - if (found%under_relaxation) then - write (this%iout, '(4x,a,a)') & - 'NEWTON-RAPHSON UNDER-RELAXATION based on the bottom ', & - 'elevation of the model will be applied to the model.' - end if - end if - - if (found%print_input) then - write (this%iout, '(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '// & - 'FOR ALL MODEL STRESS PACKAGES' - end if - - if (found%print_flows) then - write (this%iout, '(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '// & - 'FOR ALL MODEL PACKAGES' - end if - - if (found%save_flows) then - write (this%iout, '(4x,a)') & - 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL' - end if - - write (this%iout, '(1x,a)') 'END NAMEFILE OPTIONS:' - end subroutine log_namfile_options + end subroutine create_gwt_specific_packages end module GwtModule diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index d9604cc5ad1..c02fa59081e 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -4,7 +4,7 @@ module GwtDspModule use ConstantsModule, only: DONE, DZERO, DHALF, DPI use NumericalPackageModule, only: NumericalPackageType use BaseDisModule, only: DisBaseType - use GwtFmiModule, only: GwtFmiType + use TspFmiModule, only: TspFmiType use Xt3dModule, only: Xt3dType, xt3d_cr use GwtDspOptionsModule, only: GwtDspOptionsType use MatrixBaseModule @@ -17,7 +17,7 @@ module GwtDspModule type, extends(NumericalPackageType) :: GwtDspType integer(I4B), dimension(:), pointer, contiguous :: ibound => null() ! pointer to GWT model ibound - type(GwtFmiType), pointer :: fmi => null() ! pointer to GWT fmi object + type(TspFmiType), pointer :: fmi => null() ! pointer to GWT fmi object real(DP), dimension(:), pointer, contiguous :: thetam => null() ! pointer to GWT storage porosity (voids per aquifer volume) real(DP), dimension(:), pointer, contiguous :: diffc => null() ! molecular diffusion coefficient for each cell real(DP), dimension(:), pointer, contiguous :: alh => null() ! longitudinal horizontal dispersivity @@ -72,13 +72,9 @@ module GwtDspModule contains + !> @brief Create a new DSP object + !< subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) -! ****************************************************************************** -! dsp_cr -- Create a new DSP object -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use KindModule, only: LGP use MemoryManagerExtModule, only: mem_set_value @@ -88,7 +84,7 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) character(len=*), intent(in) :: input_mempath integer(I4B), intent(in) :: inunit integer(I4B), intent(in) :: iout - type(GwtFmiType), intent(in), target :: fmi + type(TspFmiType), intent(in), target :: fmi ! -- locals logical(LGP) :: found_fname ! -- formats @@ -128,13 +124,11 @@ subroutine dsp_cr(dspobj, name_model, input_mempath, inunit, iout, fmi) return end subroutine dsp_cr + !> @brief Define MST object + !! + !! Define the MST package + !< subroutine dsp_df(this, dis, dspOptions) -! ****************************************************************************** -! dsp_df -- Define -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -179,13 +173,11 @@ subroutine dsp_df(this, dis, dspOptions) return end subroutine dsp_df + !> @brief Add connections to DSP + !! + !! Add connections for extended neighbors to the sparse matrix + !< subroutine dsp_ac(this, moffset, sparse) -! ****************************************************************************** -! dsp_ac -- Add connections for extended neighbors to the sparse matrix -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SparseModule, only: sparsematrix use MemoryManagerModule, only: mem_allocate @@ -203,13 +195,11 @@ subroutine dsp_ac(this, moffset, sparse) return end subroutine dsp_ac + !> @brief Map DSP connections + !! + !! Map connections and construct iax, jax, and idxglox + !< subroutine dsp_mc(this, moffset, matrix_sln) -! ****************************************************************************** -! dsp_mc -- Map connections and construct iax, jax, and idxglox -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate ! -- dummy @@ -226,13 +216,11 @@ subroutine dsp_mc(this, moffset, matrix_sln) return end subroutine dsp_mc + !> @brief Allocate and read method for package + !! + !! Method to allocate and read static data for the package. + !< subroutine dsp_ar(this, ibound, thetam) -! ****************************************************************************** -! dsp_ar -- Allocate and Read -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -253,13 +241,9 @@ subroutine dsp_ar(this, ibound, thetam) return end subroutine dsp_ar + !> @brief Advance method for the package + !< subroutine dsp_ad(this) -! ****************************************************************************** -! dsp_ad -- Advance -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use TdisModule, only: kstp, kper ! -- dummy @@ -295,13 +279,11 @@ subroutine dsp_ad(this) return end subroutine dsp_ad + !> @brief Fill coefficient method for package + !! + !! Method to calculate and fill coefficients for the package. + !< subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) -! ****************************************************************************** -! dsp_fc -- Calculate coefficients and fill amat and rhs -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -348,13 +330,11 @@ subroutine dsp_fc(this, kiter, nodes, nja, matrix_sln, idxglo, rhs, cnew) return end subroutine dsp_fc + !> @ brief Calculate flows for package + !! + !! Method to calculate dispersion contribution to flowja + !< subroutine dsp_cq(this, cnew, flowja) -! ****************************************************************************** -! dsp_cq -- Calculate dispersion contribution to flowja -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -385,13 +365,11 @@ subroutine dsp_cq(this, cnew, flowja) return end subroutine dsp_cq + !> @ brief Allocate scalar variables for package + !! + !! Method to allocate scalar variables for the package. + !< subroutine allocate_scalars(this) -! ****************************************************************************** -! allocate_scalars -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -441,13 +419,11 @@ subroutine allocate_scalars(this) return end subroutine allocate_scalars + !> @ brief Allocate arrays for package + !! + !! Method to allocate arrays for the package. + !< subroutine allocate_arrays(this, nodes) -! ****************************************************************************** -! allocate_arrays -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_allocate use ConstantsModule, only: DZERO @@ -483,13 +459,11 @@ subroutine allocate_arrays(this, nodes) return end subroutine allocate_arrays + !> @ brief Deallocate memory + !! + !! Method to deallocate memory for the package. + !< subroutine dsp_da(this) -! ****************************************************************************** -! dsp_da -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use MemoryManagerModule, only: mem_deallocate use MemoryManagerExtModule, only: memorylist_remove @@ -561,15 +535,13 @@ subroutine log_options(this, found) write (this%iout, '(4x,a,i0)') 'XT3D formulation [0=INACTIVE, 1=ACTIVE, & &3=ACTIVE RHS] set to: ', this%ixt3d write (this%iout, '(1x,a,/)') 'End Setting DSP Options' + ! -- Return + return end subroutine log_options + !> @brief Update simulation mempath options + !< subroutine source_options(this) -! ****************************************************************************** -! source_options -- update simulation mempath options -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules !use KindModule, only: LGP use MemoryManagerExtModule, only: mem_set_value @@ -636,13 +608,9 @@ subroutine log_griddata(this, found) end subroutine log_griddata + !> @brief Update DSP simulation data from input mempath + !< subroutine source_griddata(this) -! ****************************************************************************** -! source_griddata -- update dsp simulation data from input mempath -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use SimModule, only: count_errors, store_error use MemoryManagerModule, only: mem_reallocate, mem_reassignptr @@ -725,13 +693,9 @@ subroutine source_griddata(this) return end subroutine source_griddata + !> @brief Calculate dispersion coefficients + !< subroutine calcdispellipse(this) -! ****************************************************************************** -! calcdispellipse -- Calculate dispersion coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules ! -- dummy class(GwtDspType) :: this @@ -844,13 +808,9 @@ subroutine calcdispellipse(this) return end subroutine calcdispellipse + !> @brief Calculate dispersion coefficients + !< subroutine calcdispcoef(this) -! ****************************************************************************** -! calcdispcoef -- Calculate dispersion coefficients -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use GwfNpfModule, only: hyeff_calc ! -- dummy From f85d0ad3273165ba2880f5bdd31d6406c9d3ff12 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 15:23:24 -0700 Subject: [PATCH 179/212] trying to find errors caused by an inadvertent rename --- make/makefile | 2 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/{gwt1dsp1.f90 => gwt1dsp.f90} | 0 src/meson.build | 2 +- 4 files changed, 3 insertions(+), 3 deletions(-) rename src/Model/GroundWaterTransport/{gwt1dsp1.f90 => gwt1dsp.f90} (100%) diff --git a/make/makefile b/make/makefile index 047b1678063..5569fc44ba2 100644 --- a/make/makefile +++ b/make/makefile @@ -243,7 +243,7 @@ $(OBJDIR)/gwt1sft1.o \ $(OBJDIR)/gwt1mwt1.o \ $(OBJDIR)/gwt1lkt1.o \ $(OBJDIR)/gwt1ist1.o \ -$(OBJDIR)/gwt1dsp1.o \ +$(OBJDIR)/gwt1dsp.o \ $(OBJDIR)/gwf3api8.o \ $(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/gwf3rch8.o \ diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 1c3ae816011..eb1d9b560b8 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -961,7 +961,7 @@ subroutine create_gwt_specific_packages(this, indis) ! ! -- Create packages that are tied directly to model call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi) - call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & + call dsp_cr(this%dsp, this%name, mempathdsp, this%indsp, this%iout, & this%fmi) ! ! -- Check to make sure that required ftype's have been specified diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp.f90 similarity index 100% rename from src/Model/GroundWaterTransport/gwt1dsp1.f90 rename to src/Model/GroundWaterTransport/gwt1dsp.f90 diff --git a/src/meson.build b/src/meson.build index 3085637b86c..6a28e559034 100644 --- a/src/meson.build +++ b/src/meson.build @@ -101,7 +101,7 @@ modflow_sources = files( 'Model' / 'GroundWaterTransport' / 'gwt1dis1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disu1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disv1idm.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1dsp1.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dsp.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dspidm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ist1.f90', From abaaa3d6f0ebef495591e73d209fc4abb5586ca0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 15:38:26 -0700 Subject: [PATCH 180/212] more meson --- src/meson.build | 1 + 1 file changed, 1 insertion(+) diff --git a/src/meson.build b/src/meson.build index 6a28e559034..f0709f44c2b 100644 --- a/src/meson.build +++ b/src/meson.build @@ -179,6 +179,7 @@ modflow_sources = files( 'Utilities' / 'Idm' / 'mf6blockfile' / 'StructArray.f90', 'Utilities' / 'Idm' / 'mf6blockfile' / 'StructVector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmDfnSelector.f90', + 'Utilities' / 'Idm' / 'selector' / 'IdmGweDfnSelector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmGwfDfnSelector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmGwtDfnSelector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmSimDfnSelector.f90', From 7951e6026edd3bb8969ad5a602ae1520d0d5a696 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 8 Jun 2023 15:43:38 -0700 Subject: [PATCH 181/212] Removed unused variable from cnc --- src/Model/TransportModel/tsp1cnc1.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Model/TransportModel/tsp1cnc1.f90 b/src/Model/TransportModel/tsp1cnc1.f90 index c7b540c5885..538f5ff252d 100644 --- a/src/Model/TransportModel/tsp1cnc1.f90 +++ b/src/Model/TransportModel/tsp1cnc1.f90 @@ -360,7 +360,6 @@ subroutine cnc_bd(this, model_budget) class(TspCncType) :: this type(BudgetType), intent(inout) :: model_budget ! -- local - integer(I4B) :: n real(DP) :: ratin real(DP) :: ratout real(DP) :: dum From f8e19720ff190c4a2742cf73fed8d90bbbd5b3c3 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 9 Jun 2023 11:52:04 -0700 Subject: [PATCH 182/212] Remove more unused variables --- msvs/mf6core.vfproj | 2 +- src/Model/GroundWaterEnergy/gwe1.f90 | 14 ++------ src/Model/GroundWaterEnergy/gwe1mst1.f90 | 3 +- src/Model/GroundWaterEnergy/gwe1mwe1.f90 | 2 +- src/Model/GroundWaterEnergy/gwe1sfe1.f90 | 8 ++--- src/Model/GroundWaterEnergy/gwe1src1.f90 | 10 +++--- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 46 ++++++++++-------------- src/Model/GroundWaterTransport/gwt1.f90 | 19 +--------- src/Model/TransportModel/tsp1.f90 | 32 +++++++---------- src/Model/TransportModel/tsp1adv1.f90 | 6 ++-- src/Model/TransportModel/tsp1apt1.f90 | 16 ++++----- src/Model/TransportModel/tsp1fmi1.f90 | 4 +-- 12 files changed, 59 insertions(+), 103 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index f9e719a42fd..4b9272ea18c 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -177,7 +177,7 @@ - + diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 8b0a5ee8731..a996cc8e101 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -91,15 +91,9 @@ subroutine gwe_cr(filename, id, modelname) character(len=*), intent(in) :: modelname ! -- local integer(I4B) :: indis - integer(I4B) :: ipakid, i, j, iu, ipaknum - character(len=LINELENGTH) :: errmsg - character(len=LENPACKAGENAME) :: pakname type(GweModelType), pointer :: this class(BaseModelType), pointer :: model - character(len=LENMEMPATH) :: input_mempath - character(len=LINELENGTH) :: lst_fname - type(GwfNamParamFoundType) :: found - + ! cunit(10) = 'TMP6 ' ! ------------------------------------------------------------------------------ ! @@ -123,7 +117,7 @@ subroutine gwe_cr(filename, id, modelname) ! -- create model packages call this%create_gwe_specific_packages(indis) ! - ! -- return + ! -- Return return end subroutine gwe_cr @@ -575,8 +569,6 @@ end subroutine gwe_bd !! This subroutine calls the parent class output routine. !< subroutine gwe_ot(this) - ! -- modules - use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(GweModelType) :: this ! -- local @@ -657,7 +649,7 @@ subroutine gwe_da(this) ! -- NumericalModelType call this%NumericalModelType%model_da() ! - ! -- return + ! -- Return return end subroutine gwe_da diff --git a/src/Model/GroundWaterEnergy/gwe1mst1.f90 b/src/Model/GroundWaterEnergy/gwe1mst1.f90 index e2573719a7e..08fe194cda4 100644 --- a/src/Model/GroundWaterEnergy/gwe1mst1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mst1.f90 @@ -465,7 +465,6 @@ subroutine mst_bd(this, isuppress_output, model_budget) integer(I4B), intent(in) :: isuppress_output !< flag to supress output type(BudgetType), intent(inout) :: model_budget !< model budget object ! -- local - integer(I4B) :: n real(DP) :: rin real(DP) :: rout ! @@ -881,7 +880,7 @@ function get_zero_order_decay(decay_rate_usr, decay_rate_last, kiter, & real(DP), intent(in) :: cold !< temperature at end of last time step real(DP), intent(in) :: cnew !< temperature at end of this time step real(DP), intent(in) :: delt !< length of time step - ! -- return + ! -- Return real(DP) :: decay_rate !< returned value for decay rate ! ! -- Return user rate if production, otherwise constrain, if necessary diff --git a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 index eddb400a15f..78404ec77e4 100644 --- a/src/Model/GroundWaterEnergy/gwe1mwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1mwe1.f90 @@ -432,7 +432,7 @@ function mwe_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy class(GweMweType) :: this - ! -- return + ! -- Return integer(I4B) :: nbudterms ! -- local ! ------------------------------------------------------------------------------ diff --git a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 index 31fb883d50a..e973c30cc64 100644 --- a/src/Model/GroundWaterEnergy/gwe1sfe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1sfe1.f90 @@ -154,7 +154,7 @@ subroutine sfe_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! vaporization for evaporative cooling. sfeobj%gwecommon => gwecommon ! - ! -- return + ! -- Return return end subroutine sfe_create @@ -461,7 +461,7 @@ function sfe_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy class(GweSfeType) :: this - ! -- return + ! -- Return integer(I4B) :: nbudterms ! -- local ! ------------------------------------------------------------------------------ @@ -579,7 +579,7 @@ subroutine sfe_setup_budobj(this, idx) call this%budobj%budterm(idx)%update_term(n1, n2, q) end do ! - ! -- return + ! -- Return return end subroutine sfe_setup_budobj @@ -867,7 +867,7 @@ subroutine sfe_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval) if (present(rhsval)) rhsval = -rrate ! kluge note eqnsclfac: this was incorrect for divided-through formulation but is ok now if (present(hcofval)) hcofval = DZERO ! - ! -- return + ! -- Return return end subroutine sfe_roff_term diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index 191e0b3d805..cee57d6a166 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -89,7 +89,7 @@ subroutine src_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! vaporization for evaporative cooling. srcobj%gwecommon => gwecommon ! - ! -- return + ! -- Return return end subroutine src_create @@ -107,7 +107,7 @@ subroutine src_da(this) ! ! -- scalars ! - ! -- return + ! -- Return return end subroutine src_da @@ -128,7 +128,7 @@ subroutine src_allocate_scalars(this) ! ! -- Set values ! - ! -- return + ! -- Return return end subroutine src_allocate_scalars @@ -209,7 +209,7 @@ subroutine src_fc(this, rhs, ia, idxglo, matrix_sln) end if end do ! - ! -- return + ! -- Return return end subroutine src_fc @@ -241,7 +241,7 @@ subroutine define_listlabel(this) write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME' end if ! - ! -- return + ! -- Return return end subroutine define_listlabel diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 184443acfd5..4f41820787a 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -144,7 +144,7 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! vaporization uzeobj%gwecommon => gwecommon ! - ! -- return + ! -- Return return end subroutine uze_create @@ -341,7 +341,7 @@ subroutine uze_ac(this, moffset, sparse) end if end if ! - ! -- return + ! -- Return return end subroutine uze_ac @@ -433,7 +433,7 @@ subroutine uze_mc(this, moffset, matrix_sln) end if end if ! - ! -- return + ! -- Return return end subroutine uze_mc @@ -443,8 +443,6 @@ end subroutine uze_mc !! in order to add matrix terms specifically for this package !< subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) - ! -- modules - use TdisModule, only: kper, kstp ! -- dummy class(GweUzeType) :: this real(DP), dimension(:), intent(inout) :: rhs @@ -453,16 +451,15 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) class(MatrixBaseType), pointer :: matrix_sln ! -- local integer(I4B) :: j, n, n1, n2 - integer(I4B) :: iloc, ihostcell + integer(I4B) :: iloc integer(I4B) :: iposd, iposoffd - integer(I4B) :: ipossymd, ipossymoffd + integer(I4B) :: ipossymoffd real(DP) :: cold real(DP) :: qbnd real(DP) :: omega real(DP) :: rrate real(DP) :: rhsval real(DP) :: hcofval - real(DP) :: dummy ! ------------------------------------------------------------------------------ ! ! -- add infiltration contribution @@ -529,11 +526,7 @@ subroutine uze_fc_expanded(this, rhs, ia, idxglo, matrix_sln) if (this%idxbudtmvr /= 0) then do j = 1, this%flowbudptr%budterm(this%idxbudtmvr)%nlist call this%apt_tmvr_term(j, n1, n2, rrate, rhsval, hcofval) - !NOTE: originally was iposd, but changed to idxsymdglo on the first - ! modification. It was later realized we needed idxsymoffdglo. - ! (If this works, consider changing 'ipossymd' to 'ipossymoffd' - ! - iloc = this%idxlocnode(n1) ! for uze idxlocnode stores the host cell local row index + iloc = this%idxlocnode(n1) ! for uze, idxlocnode stores the host cell local row index ipossymoffd = this%idxsymoffdglo(j) call matrix_sln%add_value_pos(ipossymoffd, hcofval) rhs(iloc) = rhs(iloc) + rhsval @@ -647,7 +640,7 @@ function uze_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy class(GweUzeType) :: this - ! -- return + ! -- Return integer(I4B) :: nbudterms ! -- local ! ------------------------------------------------------------------------------ @@ -676,9 +669,8 @@ subroutine uze_setup_budobj(this, idx) class(GweUzeType) :: this integer(I4B), intent(inout) :: idx ! -- local - integer(I4B) :: maxlist, naux, n, n1, n2 + integer(I4B) :: maxlist, naux character(len=LENBUDTXT) :: text - real(DP) :: q ! ------------------------------------------------------------------------------ ! ! -- Infiltration @@ -753,7 +745,7 @@ subroutine uze_setup_budobj(this, idx) maxlist, .false., .false., & naux) ! - ! -- return + ! -- Return return end subroutine uze_setup_budobj @@ -771,8 +763,8 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) real(DP), intent(inout) :: ccratin real(DP), intent(inout) :: ccratout ! -- local - integer(I4B) :: j, n1, n2, i, indx - integer(I4B) :: nlist, nbudterm, nlen + integer(I4B) :: j, n1, n2, indx + integer(I4B) :: nlist, nlen integer(I4B) :: igwfnode integer(I4B) :: idiag real(DP) :: q @@ -931,7 +923,7 @@ subroutine uze_fill_budobj(this, idx, x, flowja, ccratin, ccratout) ! deallocate (budresid) ! - ! -- return + ! -- Return return end subroutine uze_fill_budobj @@ -1065,7 +1057,7 @@ subroutine uze_infl_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = r * this%eqnsclfac if (present(hcofval)) hcofval = h * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine uze_infl_term @@ -1099,7 +1091,7 @@ subroutine uze_rinf_term(this, ientry, n1, n2, rrate, & if (present(rhsval)) rhsval = DZERO if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine uze_rinf_term @@ -1140,7 +1132,7 @@ subroutine uze_uzet_term(this, ientry, n1, n2, rrate, rhsval, hcofval) if (present(rhsval)) rhsval = -(DONE - omega) * qbnd * ctmp * this%eqnsclfac if (present(hcofval)) hcofval = omega * qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine uze_uzet_term @@ -1175,7 +1167,7 @@ subroutine uze_ritm_term(this, ientry, n1, n2, rrate, & !! if (present(hcofval)) hcofval = qbnd if (present(hcofval)) hcofval = qbnd * this%eqnsclfac ! - ! -- return + ! -- Return return end subroutine uze_ritm_term @@ -1194,8 +1186,6 @@ subroutine uze_theq_term(this, ientry, n1, n2, rrate) integer(I4B), intent(inout) :: n2 real(DP), intent(inout) :: rrate ! -- local - real(DP) :: qbnd - real(DP) :: ctmp real(DP) :: r integer(I4B) :: i character(len=LENBUDTXT) :: flowtype @@ -1218,7 +1208,7 @@ subroutine uze_theq_term(this, ientry, n1, n2, rrate) end if rrate = r ! - ! -- return + ! -- Return return end subroutine uze_theq_term @@ -1425,7 +1415,7 @@ subroutine uze_set_stressperiod(this, itemno, keyword, found) ! 999 continue ! - ! -- return + ! -- Return return end subroutine uze_set_stressperiod diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index eb1d9b560b8..b267d636ee9 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -31,15 +31,8 @@ module GwtModule type(GwtMstType), pointer :: mst => null() ! mass storage and transfer package type(GwtDspType), pointer :: dsp => null() ! dispersion package - ! integer(I4B), pointer :: inic => null() ! unit number IC - ! integer(I4B), pointer :: infmi => null() ! unit number FMI - ! integer(I4B), pointer :: inmvt => null() ! unit number MVT integer(I4B), pointer :: inmst => null() ! unit number MST - ! integer(I4B), pointer :: inadv => null() ! unit number ADV integer(I4B), pointer :: indsp => null() ! DSP enabled flag - ! integer(I4B), pointer :: inssm => null() ! unit number SSM - ! integer(I4B), pointer :: inoc => null() ! unit number OC - ! integer(I4B), pointer :: inobs => null() ! unit number OBS contains @@ -77,7 +70,6 @@ subroutine gwt_cr(filename, id, modelname) use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use MemoryHelperModule, only: create_mem_path use MemoryManagerExtModule, only: mem_set_value - use SimVariablesModule, only: idm_context use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr @@ -88,16 +80,9 @@ subroutine gwt_cr(filename, id, modelname) integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local - integer(I4B) :: indis !, indis6, indisu6, indisv6 - integer(I4B) :: ipakid, i, j, iu, ipaknum - character(len=LINELENGTH) :: errmsg - character(len=LENPACKAGENAME) :: pakname - !type(NameFileType) :: namefile_obj + integer(I4B) :: indis type(GwtModelType), pointer :: this class(BaseModelType), pointer :: model - character(len=LENMEMPATH) :: input_mempath - character(len=LINELENGTH) :: lst_fname - type(GwfNamParamFoundType) :: found cunit(10) = 'CNC6' ! -- format ! ------------------------------------------------------------------------------ @@ -574,8 +559,6 @@ end subroutine gwt_bd !! This subroutine calls the parent class output routine. !< subroutine gwt_ot(this) - ! -- modules - use TdisModule, only: kstp, kper, tdis_ot, endofperiod ! -- dummy class(GwtModelType) :: this ! -- local diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 4e2fdb780f3..05df744dbfd 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -134,12 +134,7 @@ subroutine tsp_cr(this, filename, id, modelname, macronym, indis, gwecommon) character(len=*), intent(in) :: macronym type(GweInputDataType), intent(in), optional :: gwecommon !< shared data container for use by multiple GWE packages ! -- local - class(*), pointer :: mstobjPtr - character(len=LINELENGTH) :: errmsg character(len=LENMEMPATH) :: input_mempath - integer(I4B) :: nwords - integer(I4B) :: i - character(len=LINELENGTH), allocatable, dimension(:) :: words character(len=LINELENGTH) :: lst_fname type(GwfNamParamFoundType) :: found ! ------------------------------------------------------------------------------ @@ -201,7 +196,7 @@ subroutine tsp_df(this) ! -- dummy variables class(TransportModelType) :: this ! - ! -- return + ! -- Return return end subroutine tsp_df @@ -219,7 +214,7 @@ subroutine tsp_ac(this, sparse) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- return + ! -- Return return end subroutine tsp_ac @@ -236,7 +231,7 @@ subroutine tsp_mc(this, matrix_sln) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- return + ! -- Return return end subroutine tsp_mc @@ -251,7 +246,7 @@ subroutine tsp_ar(this) class(TransportModelType) :: this ! ------------------------------------------------------------------------------ ! - ! -- return + ! -- Return return end subroutine tsp_ar @@ -279,7 +274,7 @@ subroutine tsp_ad(this) class(TransportModelType) :: this ! ------------------------------------------------------------------------------ ! - ! -- return + ! -- Return return end subroutine tsp_ad @@ -302,7 +297,7 @@ subroutine tsp_fc(this, kiter, matrix_sln, inwtflag) integer(I4B), intent(in) :: inwtflag ! ------------------------------------------------------------------------------ ! - ! -- return + ! -- Return return end subroutine tsp_fc @@ -324,7 +319,7 @@ subroutine tsp_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak) ! -- local ! ------------------------------------------------------------------------------ ! - ! -- return + ! -- Return return end subroutine tsp_cc @@ -339,7 +334,6 @@ subroutine tsp_cq(this, icnvg, isuppress_output) integer(I4B), intent(in) :: icnvg integer(I4B), intent(in) :: isuppress_output ! -- local - integer(I4B) :: i ! ------------------------------------------------------------------------------ ! ! -- Return @@ -638,7 +632,7 @@ subroutine allocate_tsp_scalars(this, modelname) this%inobs = 0 this%eqnsclfac = DZERO ! - ! -- return + ! -- Return return end subroutine allocate_tsp_scalars @@ -664,7 +658,7 @@ subroutine tsp_da(this) call mem_deallocate(this%inobs) call mem_deallocate(this%eqnsclfac) ! - ! -- return + ! -- Return return end subroutine tsp_da @@ -707,7 +701,7 @@ subroutine ftype_check(this, indis, inmst) call store_error_filename(this%filename) end if ! - ! -- return + ! -- Return return end subroutine ftype_check @@ -757,7 +751,7 @@ subroutine create_lstfile(this, lst_fname, model_fname, defined) ! -- write list file header call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)') ! - ! -- return + ! -- Return return end subroutine create_lstfile @@ -836,9 +830,7 @@ subroutine create_packages(this, indis, gwecommon) character(len=LENPACKAGENAME) :: pkgname character(len=LENMEMPATH) :: mempath integer(I4B), pointer :: inunit - integer(I4B), dimension(:), allocatable :: bndpkgs integer(I4B) :: n - character(len=LENMEMPATH) :: mempathdsp = '' ! ! -- Initialize indis = 0 @@ -903,7 +895,7 @@ subroutine create_packages(this, indis, gwecommon) call oc_cr(this%oc, this%name, this%inoc, this%iout) call tsp_obs_cr(this%obs, this%inobs) ! - ! -- return + ! -- Return return end subroutine create_packages diff --git a/src/Model/TransportModel/tsp1adv1.f90 b/src/Model/TransportModel/tsp1adv1.f90 index f0b23796322..323c2f52f75 100644 --- a/src/Model/TransportModel/tsp1adv1.f90 +++ b/src/Model/TransportModel/tsp1adv1.f90 @@ -225,7 +225,7 @@ end subroutine advtvd function advqtvd(this, n, m, iposnm, cnew) result(qtvd) ! -- modules use ConstantsModule, only: DPREC - ! -- return + ! -- Return real(DP) :: qtvd ! -- dummy class(TspAdvType) :: this @@ -480,7 +480,7 @@ end subroutine read_options !! Calculate the advection weight !< function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) - ! -- return + ! -- Return real(DP) :: omega ! -- dummy class(TspAdvType) :: this @@ -515,7 +515,7 @@ function adv_weight(this, iadvwt, ipos, n, m, qnm) result(omega) end if end select ! - ! -- return + ! -- Return return end function adv_weight diff --git a/src/Model/TransportModel/tsp1apt1.f90 b/src/Model/TransportModel/tsp1apt1.f90 index a5e191cdbf2..b867c025b7f 100644 --- a/src/Model/TransportModel/tsp1apt1.f90 +++ b/src/Model/TransportModel/tsp1apt1.f90 @@ -231,7 +231,7 @@ subroutine apt_ac(this, moffset, sparse) end if end if ! - ! -- return + ! -- Return return end subroutine apt_ac @@ -588,7 +588,7 @@ subroutine apt_set_stressperiod(this, itemno) call this%parser%StoreErrorUnit() end if ! - ! -- return + ! -- Return return end subroutine apt_set_stressperiod @@ -613,7 +613,7 @@ subroutine pak_set_stressperiod(this, itemno, keyword, found) call store_error('Program error: pak_set_stressperiod not implemented.', & terminate=.TRUE.) ! - ! -- return + ! -- Return return end subroutine pak_set_stressperiod @@ -622,7 +622,7 @@ end subroutine pak_set_stressperiod !! Determine if a valid feature number has been specified. !< function apt_check_valid(this, itemno) result(ierr) - ! -- return + ! -- Return integer(I4B) :: ierr ! -- dummy class(TspAptType), intent(inout) :: this @@ -722,7 +722,7 @@ subroutine apt_cf(this, reset_mover) end do end if ! - ! -- return + ! -- Return return end subroutine apt_cf @@ -2017,7 +2017,7 @@ function pak_get_nbudterms(this) result(nbudterms) ! -- modules ! -- dummy class(TspAptType) :: this - ! -- return + ! -- Return integer(I4B) :: nbudterms ! -- local ! ------------------------------------------------------------------------------ @@ -2034,13 +2034,13 @@ function padl(str, width) result(res) ! -- local character(len=*), intent(in) :: str integer, intent(in) :: width - ! -- return + ! -- Return character(len=max(len_trim(str), width)) :: res ! ------------------------------------------------------------------------------ res = str res = adjustr(res) ! - ! -- return + ! -- Return return end function diff --git a/src/Model/TransportModel/tsp1fmi1.f90 b/src/Model/TransportModel/tsp1fmi1.f90 index 0beaadb83ac..1b748f1ab9d 100644 --- a/src/Model/TransportModel/tsp1fmi1.f90 +++ b/src/Model/TransportModel/tsp1fmi1.f90 @@ -718,7 +718,7 @@ subroutine set_active_status(this, cnew) end do ! - ! -- return + ! -- Return return end subroutine set_active_status @@ -970,7 +970,7 @@ subroutine set_aptbudobj_pointer(this, name, budobjptr) end if end do ! - ! -- return + ! -- Return return end subroutine set_aptbudobj_pointer From ca4458b7166e4faf8cf10bdad9482d96fad03a6a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 9 Jun 2023 13:56:18 -0700 Subject: [PATCH 183/212] touch-up gwe & gwt --- src/Model/GroundWaterEnergy/gwe1.f90 | 1 - src/Model/GroundWaterTransport/gwt1.f90 | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index a996cc8e101..9b8f231eb06 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -68,7 +68,6 @@ subroutine gwe_cr(filename, id, modelname) use ConstantsModule, only: LINELENGTH, LENPACKAGENAME use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path - use SimVariablesModule, only: idm_context use GwfNamInputModule, only: GwfNamParamFoundType use BudgetModule, only: budget_cr use TspLabelsModule, only: tsplabels_cr diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index b267d636ee9..f7aebba9b21 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -80,7 +80,7 @@ subroutine gwt_cr(filename, id, modelname) integer(I4B), intent(in) :: id character(len=*), intent(in) :: modelname ! -- local - integer(I4B) :: indis + integer(I4B) :: indis type(GwtModelType), pointer :: this class(BaseModelType), pointer :: model cunit(10) = 'CNC6' From 22267573ac67decb25bf0cdd8fe38ce660a4752a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 9 Jun 2023 14:59:01 -0700 Subject: [PATCH 184/212] more meson --- src/meson.build | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/meson.build b/src/meson.build index f0709f44c2b..5cd095d7bc1 100644 --- a/src/meson.build +++ b/src/meson.build @@ -21,9 +21,11 @@ modflow_sources = files( 'Distributed' / 'VirtualExchange.f90', 'Distributed' / 'VirtualGwfExchange.f90', 'Distributed' / 'VirtualGwtExchange.f90', + 'Distributed' / 'VirtualGweExchange.f90', 'Distributed' / 'VirtualModel.f90', 'Distributed' / 'VirtualGwfModel.f90', 'Distributed' / 'VirtualGwtModel.f90', + 'Distributed' / 'VirtualGweModel.f90', 'Distributed' / 'VirtualSolution.f90', 'Exchange' / 'BaseExchange.f90', 'Exchange' / 'DisConnExchange.f90', From 480aca39eca803a0a01d4106b3095ff7633fe8a8 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 12 Jun 2023 07:50:58 -0700 Subject: [PATCH 185/212] fix for autotest/test_gwe_dsp.py --- autotest/test_gwe_dsp.py | 2 +- autotest/test_gwe_stallman.py | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/autotest/test_gwe_dsp.py b/autotest/test_gwe_dsp.py index 3d86abd9f88..37482db2c25 100644 --- a/autotest/test_gwe_dsp.py +++ b/autotest/test_gwe_dsp.py @@ -481,7 +481,7 @@ def eval_transport(sim): ] msg = f"gwe temperatures do not match stored concentrations" - assert np.allclose(conc1[0, 0, 0, :], c_ans, atol=1e-5), msg + assert np.allclose(conc1[-1, 0, 0, :], c_ans, atol=1e-5), msg # - No need to change any code below diff --git a/autotest/test_gwe_stallman.py b/autotest/test_gwe_stallman.py index cfb7eb46c7e..f457804f245 100644 --- a/autotest/test_gwe_stallman.py +++ b/autotest/test_gwe_stallman.py @@ -246,7 +246,7 @@ def build_model(idx, dir): printrecord=[("HEAD", "LAST"), ("BUDGET", "LAST")], ) - # Instantiating MODFLOW 6 groundwater transport package + # Instantiating MODFLOW 6 groundwater heat transport package gwe = flopy.mf6.MFModel( sim, model_type="gwe6", From de9f982b22988d2b62fd1e0c941180c4b4aa7c0d Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 12 Jun 2023 08:22:58 -0700 Subject: [PATCH 186/212] Restore some build files I broke with the last merge conflict --- make/makefile | 128 +++++++++++++++++++++++++++----------------- msvs/mf6core.vfproj | 52 +++++++++++++----- src/meson.build | 48 ++++++++++++----- 3 files changed, 154 insertions(+), 74 deletions(-) diff --git a/make/makefile b/make/makefile index 3c34055f856..591983f0aa2 100644 --- a/make/makefile +++ b/make/makefile @@ -10,30 +10,32 @@ SOURCEDIR3=../src/Exchange SOURCEDIR4=../src/Model SOURCEDIR5=../src/Model/Connection SOURCEDIR6=../src/Model/Geometry -SOURCEDIR7=../src/Model/GroundWaterFlow -SOURCEDIR8=../src/Model/GroundWaterTransport -SOURCEDIR9=../src/Model/ModelUtilities -SOURCEDIR10=../src/Solution -SOURCEDIR11=../src/Solution/LinearMethods -SOURCEDIR12=../src/Solution/PETSc -SOURCEDIR13=../src/Timing -SOURCEDIR14=../src/Utilities -SOURCEDIR15=../src/Utilities/ArrayRead -SOURCEDIR16=../src/Utilities/Idm -SOURCEDIR17=../src/Utilities/Idm/mf6blockfile -SOURCEDIR18=../src/Utilities/Idm/selector -SOURCEDIR19=../src/Utilities/Libraries -SOURCEDIR20=../src/Utilities/Libraries/blas -SOURCEDIR21=../src/Utilities/Libraries/daglib -SOURCEDIR22=../src/Utilities/Libraries/rcm -SOURCEDIR23=../src/Utilities/Libraries/sparsekit -SOURCEDIR24=../src/Utilities/Libraries/sparskit2 -SOURCEDIR25=../src/Utilities/Matrix -SOURCEDIR26=../src/Utilities/Memory -SOURCEDIR27=../src/Utilities/Observation -SOURCEDIR28=../src/Utilities/OutputControl -SOURCEDIR29=../src/Utilities/TimeSeries -SOURCEDIR30=../src/Utilities/Vector +SOURCEDIR7=../src/Model/GroundWaterEnergy +SOURCEDIR8=../src/Model/GroundWaterFlow +SOURCEDIR9=../src/Model/GroundWaterTransport +SOURCEDIR10=../src/Model/ModelUtilities +SOURCEDIR11=../src/Model/TransportModel +SOURCEDIR12=../src/Solution +SOURCEDIR13=../src/Solution/LinearMethods +SOURCEDIR14=../src/Solution/PETSc +SOURCEDIR15=../src/Timing +SOURCEDIR16=../src/Utilities +SOURCEDIR17=../src/Utilities/ArrayRead +SOURCEDIR18=../src/Utilities/Idm +SOURCEDIR19=../src/Utilities/Idm/mf6blockfile +SOURCEDIR20=../src/Utilities/Idm/selector +SOURCEDIR21=../src/Utilities/Libraries +SOURCEDIR22=../src/Utilities/Libraries/blas +SOURCEDIR23=../src/Utilities/Libraries/daglib +SOURCEDIR24=../src/Utilities/Libraries/rcm +SOURCEDIR25=../src/Utilities/Libraries/sparsekit +SOURCEDIR26=../src/Utilities/Libraries/sparskit2 +SOURCEDIR27=../src/Utilities/Matrix +SOURCEDIR28=../src/Utilities/Memory +SOURCEDIR29=../src/Utilities/Observation +SOURCEDIR30=../src/Utilities/OutputControl +SOURCEDIR31=../src/Utilities/TimeSeries +SOURCEDIR32=../src/Utilities/Vector VPATH = \ ${SOURCEDIR1} \ @@ -65,7 +67,9 @@ ${SOURCEDIR26} \ ${SOURCEDIR27} \ ${SOURCEDIR28} \ ${SOURCEDIR29} \ -${SOURCEDIR30} +${SOURCEDIR30} \ +${SOURCEDIR31} \ +${SOURCEDIR32} .SUFFIXES: .f90 .F90 .o @@ -116,6 +120,7 @@ $(OBJDIR)/Observe.o \ $(OBJDIR)/TimeArraySeriesLink.o \ $(OBJDIR)/ObsUtility.o \ $(OBJDIR)/ObsContainer.o \ +$(OBJDIR)/TspLabels.o \ $(OBJDIR)/BudgetFileReader.o \ $(OBJDIR)/TimeArraySeriesManager.o \ $(OBJDIR)/PackageMover.o \ @@ -133,6 +138,7 @@ $(OBJDIR)/LinearSolverBase.o \ $(OBJDIR)/ims8reordering.o \ $(OBJDIR)/VirtualBase.o \ $(OBJDIR)/STLVecInt.o \ +$(OBJDIR)/PrintSaveManager.o \ $(OBJDIR)/InputDefinition.o \ $(OBJDIR)/SfrCrossSectionManager.o \ $(OBJDIR)/dag_module.o \ @@ -144,6 +150,10 @@ $(OBJDIR)/ims8base.o \ $(OBJDIR)/VirtualDataLists.o \ $(OBJDIR)/VirtualDataContainer.o \ $(OBJDIR)/SimStages.o \ +$(OBJDIR)/PackageBudget.o \ +$(OBJDIR)/HeadFileReader.o \ +$(OBJDIR)/OutputControlData.o \ +$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/simnamidm.o \ $(OBJDIR)/gwt1idm.o \ $(OBJDIR)/gwt1dsp1idm.o \ @@ -155,9 +165,11 @@ $(OBJDIR)/gwf3idm.o \ $(OBJDIR)/gwf3disv8idm.o \ $(OBJDIR)/gwf3disu8idm.o \ $(OBJDIR)/gwf3dis8idm.o \ -$(OBJDIR)/PackageBudget.o \ -$(OBJDIR)/HeadFileReader.o \ -$(OBJDIR)/PrintSaveManager.o \ +$(OBJDIR)/gwe1idm.o \ +$(OBJDIR)/gwe1dspidm.o \ +$(OBJDIR)/gwe1disv1idm.o \ +$(OBJDIR)/gwe1disu1idm.o \ +$(OBJDIR)/gwe1dis1idm.o \ $(OBJDIR)/Xt3dAlgorithm.o \ $(OBJDIR)/gwf3tvbase8.o \ $(OBJDIR)/gwf3sfr8.o \ @@ -175,61 +187,63 @@ $(OBJDIR)/ims8linear.o \ $(OBJDIR)/BaseSolution.o \ $(OBJDIR)/IndexMap.o \ $(OBJDIR)/VirtualModel.o \ +$(OBJDIR)/tsp1fmi1.o \ +$(OBJDIR)/GwtSpc.o \ +$(OBJDIR)/GweInputData.o \ +$(OBJDIR)/OutputControl.o \ +$(OBJDIR)/tsp1ic1.o \ +$(OBJDIR)/TspAdvOptions.o \ +$(OBJDIR)/MemoryManagerExt.o \ $(OBJDIR)/IdmSimDfnSelector.o \ $(OBJDIR)/IdmGwtDfnSelector.o \ $(OBJDIR)/IdmGwfDfnSelector.o \ +$(OBJDIR)/IdmGweDfnSelector.o \ $(OBJDIR)/UzfCellGroup.o \ -$(OBJDIR)/gwt1fmi1.o \ -$(OBJDIR)/OutputControlData.o \ -$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3tvk8.o \ -$(OBJDIR)/MemoryManagerExt.o \ -$(OBJDIR)/gwf3vsc8.o \ +$(OBJDIR)/gwf3vsc8_memoryMng_strings.o \ $(OBJDIR)/GwfNpfOptions.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/InterfaceMap.o \ $(OBJDIR)/CellWithNbrs.o \ +$(OBJDIR)/tsp1ssm1.o \ +$(OBJDIR)/tsp1oc1.o \ +$(OBJDIR)/tsp1obs1.o \ +$(OBJDIR)/tsp1mvt1.o \ +$(OBJDIR)/tsp1adv1.o \ +$(OBJDIR)/gwt1mst1.o \ +$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/gwf3disu8.o \ +$(OBJDIR)/gwf3dis8.o \ +$(OBJDIR)/gwe1mst1.o \ $(OBJDIR)/IdmDfnSelector.o \ $(OBJDIR)/gwf3uzf8.o \ -$(OBJDIR)/gwt1apt1.o \ -$(OBJDIR)/GwtSpc.o \ -$(OBJDIR)/OutputControl.o \ -$(OBJDIR)/gwt1ic1.o \ -$(OBJDIR)/gwt1mst1.o \ +$(OBJDIR)/tsp1apt1.o \ $(OBJDIR)/GwtDspOptions.o \ $(OBJDIR)/gwf3npf8.o \ -$(OBJDIR)/GwtAdvOptions.o \ $(OBJDIR)/gwf3tvs8.o \ $(OBJDIR)/GwfStorageUtils.o \ $(OBJDIR)/Mover.o \ $(OBJDIR)/GwfMvrPeriodData.o \ $(OBJDIR)/ims8misc.o \ $(OBJDIR)/GwfBuyInputData.o \ +$(OBJDIR)/GweDspOptions.o \ $(OBJDIR)/VirtualSolution.o \ $(OBJDIR)/ArrayReaderBase.o \ $(OBJDIR)/VirtualExchange.o \ -$(OBJDIR)/gwf3disu8.o \ $(OBJDIR)/GridSorting.o \ $(OBJDIR)/DisConnExchange.o \ $(OBJDIR)/CsrUtils.o \ -$(OBJDIR)/TransportModel.o \ +$(OBJDIR)/tsp1cnc1.o \ +$(OBJDIR)/tsp1.o \ $(OBJDIR)/ModelPackageInputs.o \ $(OBJDIR)/gwt1uzt1.o \ -$(OBJDIR)/gwt1ssm1.o \ $(OBJDIR)/gwt1src1.o \ $(OBJDIR)/gwt1sft1.o \ -$(OBJDIR)/gwt1oc1.o \ -$(OBJDIR)/gwt1obs1.o \ $(OBJDIR)/gwt1mwt1.o \ -$(OBJDIR)/gwt1mvt1.o \ $(OBJDIR)/gwt1lkt1.o \ $(OBJDIR)/gwt1ist1.o \ $(OBJDIR)/gwt1dsp1.o \ -$(OBJDIR)/gwt1cnc1.o \ -$(OBJDIR)/gwt1adv1.o \ -$(OBJDIR)/gwf3disv8.o \ -$(OBJDIR)/gwf3dis8.o \ $(OBJDIR)/gwf3api8.o \ $(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/gwf3rch8.o \ @@ -243,12 +257,19 @@ $(OBJDIR)/gwf3buy8.o \ $(OBJDIR)/GhostNode.o \ $(OBJDIR)/gwf3evt8.o \ $(OBJDIR)/gwf3chd8.o \ +$(OBJDIR)/gwe1uze1.o \ +$(OBJDIR)/gwe1src1.o \ +$(OBJDIR)/gwe1sfe1.o \ +$(OBJDIR)/gwe1mwe1.o \ +$(OBJDIR)/gwe1lke1.o \ +$(OBJDIR)/gwe1dsp1.o \ $(OBJDIR)/RouterBase.o \ $(OBJDIR)/Integer2dReader.o \ $(OBJDIR)/GridConnection.o \ $(OBJDIR)/DistributedVariable.o \ $(OBJDIR)/gwt1.o \ $(OBJDIR)/gwf3.o \ +$(OBJDIR)/gwe1.o \ $(OBJDIR)/SerialRouter.o \ $(OBJDIR)/StructVector.o \ $(OBJDIR)/IdmLogger.o \ @@ -261,6 +282,8 @@ $(OBJDIR)/GwtInterfaceModel.o \ $(OBJDIR)/GwtGwtExchange.o \ $(OBJDIR)/GwfInterfaceModel.o \ $(OBJDIR)/GwfGwfExchange.o \ +$(OBJDIR)/GweInterfaceModel.o \ +$(OBJDIR)/GweGweExchange.o \ $(OBJDIR)/RouterFactory.o \ $(OBJDIR)/MappedMemory.o \ $(OBJDIR)/StructArray.o \ @@ -270,6 +293,7 @@ $(OBJDIR)/DefinitionSelect.o \ $(OBJDIR)/ExplicitSolution.o \ $(OBJDIR)/GwtGwtConnection.o \ $(OBJDIR)/GwfGwfConnection.o \ +$(OBJDIR)/GweGweConnection.o \ $(OBJDIR)/VirtualDataManager.o \ $(OBJDIR)/Mapper.o \ $(OBJDIR)/LoadMf6File.o \ @@ -277,9 +301,12 @@ $(OBJDIR)/VirtualGwtModel.o \ $(OBJDIR)/VirtualGwtExchange.o \ $(OBJDIR)/VirtualGwfModel.o \ $(OBJDIR)/VirtualGwfExchange.o \ +$(OBJDIR)/VirtualGweModel.o \ +$(OBJDIR)/VirtualGweExchange.o \ $(OBJDIR)/SolutionGroup.o \ $(OBJDIR)/SolutionFactory.o \ $(OBJDIR)/GwfGwtExchange.o \ +$(OBJDIR)/GwfGweExchange.o \ $(OBJDIR)/RunControl.o \ $(OBJDIR)/IdmMf6File.o \ $(OBJDIR)/SimulationCreate.o \ @@ -297,6 +324,9 @@ $(OBJDIR)/sparsekit.o \ $(OBJDIR)/rcm.o \ $(OBJDIR)/blas1_d.o \ $(OBJDIR)/Iunit.o \ +$(OBJDIR)/LatHeatVapor.o \ +$(OBJDIR)/GwtAdvOptions.o \ +$(OBJDIR)/gwf3vsc8.o \ $(OBJDIR)/RectangularGeometry.o \ $(OBJDIR)/CircularGeometry.o diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index e2be9f2e7b6..4b9272ea18c 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -85,6 +85,8 @@ + + @@ -95,6 +97,8 @@ + + @@ -107,6 +111,8 @@ + + @@ -117,6 +123,20 @@ + + + + + + + + + + + + + + @@ -154,33 +174,26 @@ - - - - - - - + + - - - - + + @@ -193,14 +206,26 @@ + + + + + + + + + + + + + - - + @@ -266,6 +291,7 @@ + diff --git a/src/meson.build b/src/meson.build index 0f1156ff9e3..5cd095d7bc1 100644 --- a/src/meson.build +++ b/src/meson.build @@ -21,13 +21,17 @@ modflow_sources = files( 'Distributed' / 'VirtualExchange.f90', 'Distributed' / 'VirtualGwfExchange.f90', 'Distributed' / 'VirtualGwtExchange.f90', + 'Distributed' / 'VirtualGweExchange.f90', 'Distributed' / 'VirtualModel.f90', 'Distributed' / 'VirtualGwfModel.f90', 'Distributed' / 'VirtualGwtModel.f90', + 'Distributed' / 'VirtualGweModel.f90', 'Distributed' / 'VirtualSolution.f90', 'Exchange' / 'BaseExchange.f90', 'Exchange' / 'DisConnExchange.f90', 'Exchange' / 'GhostNode.f90', + 'Exchange' / 'GweGweExchange.f90', + 'Exchange' / 'GwfGweExchange.f90', 'Exchange' / 'GwfGwfExchange.f90', 'Exchange' / 'GwfGwtExchange.f90', 'Exchange' / 'GwtGwtExchange.f90', @@ -37,8 +41,10 @@ modflow_sources = files( 'Model' / 'Connection' / 'CsrUtils.f90', 'Model' / 'Connection' / 'GridConnection.f90', 'Model' / 'Connection' / 'GridSorting.f90', + 'Model' / 'Connection' / 'GweGweConnection.f90', 'Model' / 'Connection' / 'GwfGwfConnection.f90', 'Model' / 'Connection' / 'GwtGwtConnection.f90', + 'Model' / 'Connection' / 'GweInterfaceModel.f90', 'Model' / 'Connection' / 'GwfInterfaceModel.f90', 'Model' / 'Connection' / 'GwtInterfaceModel.f90', 'Model' / 'Connection' / 'SpatialModelConnection.f90', @@ -46,6 +52,19 @@ modflow_sources = files( 'Model' / 'Geometry' / 'BaseGeometry.f90', 'Model' / 'Geometry' / 'CircularGeometry.f90', 'Model' / 'Geometry' / 'RectangularGeometry.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1dis1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1disu1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1disv1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1dsp1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1dspidm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1idm.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1lke1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1mst1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1mwe1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1sfe1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1src1.f90', + 'Model' / 'GroundWaterEnergy' / 'gwe1uze1.f90', 'Model' / 'GroundWaterFlow' / 'gwf3.f90', 'Model' / 'GroundWaterFlow' / 'gwf3api8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3buy8.f90', @@ -81,32 +100,25 @@ modflow_sources = files( 'Model' / 'GroundWaterFlow' / 'gwf3vsc8.f90', 'Model' / 'GroundWaterFlow' / 'gwf3wel8.f90', 'Model' / 'GroundWaterTransport' / 'gwt1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1adv1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1apt1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1cnc1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1dis1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disu1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disv1idm.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1dsp1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1dsp1idm.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1fmi1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1ic1.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dsp.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dspidm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ist1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1lkt1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1mst1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1mvt1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1mwt1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1obs1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1oc1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1sft1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1src1.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1ssm1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1uzt1.f90', 'Model' / 'ModelUtilities' / 'BoundaryPackage.f90', 'Model' / 'ModelUtilities' / 'Connections.f90', 'Model' / 'ModelUtilities' / 'DiscretizationBase.f90', 'Model' / 'ModelUtilities' / 'DisvGeom.f90', + 'Model' / 'ModelUtilities' / 'GweDspOptions.f90', + 'Model' / 'ModelUtilities' / 'GweInputData.f90', 'Model' / 'ModelUtilities' / 'GwfBuyInputData.f90', 'Model' / 'ModelUtilities' / 'GwfMvrPeriodData.f90', 'Model' / 'ModelUtilities' / 'GwfNpfOptions.f90', @@ -119,14 +131,25 @@ modflow_sources = files( 'Model' / 'ModelUtilities' / 'PackageMover.f90', 'Model' / 'ModelUtilities' / 'SfrCrossSectionManager.f90', 'Model' / 'ModelUtilities' / 'SfrCrossSectionUtils.f90', + 'Model' / 'ModelUtilities' / 'TspAdvOptions.f90', + 'Model' / 'ModelUtilities' / 'TspLabels.f90', 'Model' / 'ModelUtilities' / 'UzfCellGroup.f90', 'Model' / 'ModelUtilities' / 'Xt3dAlgorithm.f90', 'Model' / 'ModelUtilities' / 'Xt3dInterface.f90', + 'Model' / 'TransportModel' / 'tsp1.f90', + 'Model' / 'TransportModel' / 'tsp1adv1.f90', + 'Model' / 'TransportModel' / 'tsp1apt1.f90', + 'Model' / 'TransportModel' / 'tsp1cnc1.f90', + 'Model' / 'TransportModel' / 'tsp1fmi1.f90', + 'Model' / 'TransportModel' / 'tsp1ic1.f90', + 'Model' / 'TransportModel' / 'tsp1mvt1.f90', + 'Model' / 'TransportModel' / 'tsp1obs1.f90', + 'Model' / 'TransportModel' / 'tsp1oc1.f90', + 'Model' / 'TransportModel' / 'tsp1ssm1.f90', 'Model' / 'BaseModel.f90', 'Model' / 'ExplicitModel.f90', 'Model' / 'NumericalModel.f90', 'Model' / 'NumericalPackage.f90', - 'Model' / 'TransportModel.f90', 'Solution' / 'LinearMethods' / 'ims8base.f90', 'Solution' / 'LinearMethods' / 'ims8linear.f90', 'Solution' / 'LinearMethods' / 'ims8reordering.f90', @@ -158,6 +181,7 @@ modflow_sources = files( 'Utilities' / 'Idm' / 'mf6blockfile' / 'StructArray.f90', 'Utilities' / 'Idm' / 'mf6blockfile' / 'StructVector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmDfnSelector.f90', + 'Utilities' / 'Idm' / 'selector' / 'IdmGweDfnSelector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmGwfDfnSelector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmGwtDfnSelector.f90', 'Utilities' / 'Idm' / 'selector' / 'IdmSimDfnSelector.f90', From 23163feb88f9185e210de6e0ea59eed11abcb9fb Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 12 Jun 2023 08:43:39 -0700 Subject: [PATCH 187/212] more fixes --- autotest/test_gwe_stallman.py | 73 +++++++++-------------------------- src/meson.build | 4 +- 2 files changed, 20 insertions(+), 57 deletions(-) diff --git a/autotest/test_gwe_stallman.py b/autotest/test_gwe_stallman.py index f457804f245..652ed8fa7b5 100644 --- a/autotest/test_gwe_stallman.py +++ b/autotest/test_gwe_stallman.py @@ -6,32 +6,14 @@ # Imports import os -import sys import numpy as np import pytest import matplotlib.pyplot as plt +import flopy -try: - import pymake -except: - msg = "Error. Pymake package is not available.\n" - msg += "Try installing using the following command:\n" - msg += " pip install https://github.com/modflowpy/pymake/zipball/master" - raise Exception(msg) - -try: - import flopy -except: - msg = "Error. FloPy package is not available.\n" - msg += "Try installing using the following command:\n" - msg += " pip install flopy" - raise Exception(msg) - -import targets - -from framework import testing_framework -from simulation import Simulation +from framework import TestFramework +from simulation import TestSimulation # Base simulation and model name and workspace @@ -75,6 +57,7 @@ cps = 800.0 rhow = 1000.0 rhos = bulk_dens +lhv = 2454000.0 # Latent heat of vaporization ($J/kg$) # Stress period input per_data = [] @@ -310,10 +293,9 @@ def build_model(idx, dir): flopy.mf6.ModflowGwemst( gwe, porosity=porosity, - cpw=cpw, cps=cps, - rhow=rhow, rhos=rhos, + packagedata=[cpw, rhow, lhv], filename="{}.mst".format(gwename), ) @@ -352,7 +334,7 @@ def build_model(idx, dir): return sim, None -def eval_model(sim): +def eval_results(sim): print("evaluating results...") # read transport results from GWE model @@ -408,36 +390,17 @@ def eval_model(sim): # - No need to change any code below @pytest.mark.parametrize( - "idx, dir", - list(enumerate(exdirs)), + "idx, name", + list(enumerate(ex)), ) -def test_mf6model(idx, dir): - # initialize testing framework - test = testing_framework() - - # build the model - test.build_mf6_models(build_model, idx, dir) - - # run the test model - test.run_mf6(Simulation(dir, exfunc=eval_model, idxsim=idx)) - - -def main(): - # initialize testing framework - test = testing_framework() - - # run the test model - for idx, dir in enumerate(exdirs): - - test.build_mf6_models(build_model, idx, dir) - sim = Simulation(dir, exfunc=eval_model, idxsim=idx) - test.run_mf6(sim) - - -if __name__ == "__main__": - # Heat Transport in 1-dimension - # print message - print(f"standalone run of {os.path.basename(__file__)}") +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_results, idxsim=idx + ), + ws, + ) - # run main routine - main() diff --git a/src/meson.build b/src/meson.build index 5cd095d7bc1..c3a6e91f258 100644 --- a/src/meson.build +++ b/src/meson.build @@ -103,8 +103,8 @@ modflow_sources = files( 'Model' / 'GroundWaterTransport' / 'gwt1dis1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disu1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1disv1idm.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1dsp.f90', - 'Model' / 'GroundWaterTransport' / 'gwt1dspidm.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dsp1.f90', + 'Model' / 'GroundWaterTransport' / 'gwt1dsp1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1idm.f90', 'Model' / 'GroundWaterTransport' / 'gwt1ist1.f90', 'Model' / 'GroundWaterTransport' / 'gwt1lkt1.f90', From 42f9de4bc71493a4421f0d51a870e4cb8e22d485 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Mon, 12 Jun 2023 14:03:57 -0700 Subject: [PATCH 188/212] providing a fix for at least one of the GWT-GWT autotests --- msvs/mf6core.vfproj | 4 ++-- src/Model/Connection/GwtInterfaceModel.f90 | 13 ++++++++++--- src/Model/GroundWaterEnergy/gwe1src1.f90 | 1 - 3 files changed, 12 insertions(+), 6 deletions(-) diff --git a/msvs/mf6core.vfproj b/msvs/mf6core.vfproj index 4b9272ea18c..eb7af6255d5 100644 --- a/msvs/mf6core.vfproj +++ b/msvs/mf6core.vfproj @@ -177,8 +177,8 @@ - - + + diff --git a/src/Model/Connection/GwtInterfaceModel.f90 b/src/Model/Connection/GwtInterfaceModel.f90 index abaa0e10689..228a8d9c29f 100644 --- a/src/Model/Connection/GwtInterfaceModel.f90 +++ b/src/Model/Connection/GwtInterfaceModel.f90 @@ -1,5 +1,6 @@ module GwtInterfaceModelModule use KindModule, only: I4B, DP + use ConstantsModule, only: DONE use MemoryManagerModule, only: mem_allocate, mem_deallocate, mem_reallocate use MemoryHelperModule, only: create_mem_path use NumericalModelModule, only: NumericalModelType @@ -25,6 +26,7 @@ module GwtInterfaceModelModule integer(i4B), pointer :: iAdvScheme => null() !< the advection scheme: 0 = up, 1 = central, 2 = tvd integer(i4B), pointer :: ixt3d => null() !< xt3d setting: 0 = off, 1 = lhs, 2 = rhs + real(DP), pointer :: ieqnsclfac => null() !< governing eqn scaling factor: 1: GWT, >1: GWE class(GridConnectionType), pointer :: gridConnection => null() !< The grid connection class will provide the interface grid class(GwtModelType), private, pointer :: owner => null() !< the real GWT model for which the exchange coefficients @@ -61,6 +63,7 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! defaults this%iAdvScheme = 0 this%ixt3d = 0 + this%ieqnsclfac = DONE this%iout = iout this%gridConnection => gridConn @@ -82,9 +85,9 @@ subroutine gwtifmod_cr(this, name, iout, gridConn) ! create dis and packages call disu_cr(this%dis, this%name, '', -1, this%iout) call fmi_cr(this%fmi, this%name, 0, this%iout, this%tsplab, & - this%eqnsclfac) + this%ieqnsclfac) call adv_cr(this%adv, this%name, adv_unit, this%iout, this%fmi, & - this%eqnsclfac) + this%ieqnsclfac) call dsp_cr(this%dsp, this%name, '', -dsp_unit, this%iout, this%fmi) call tsp_obs_cr(this%obs, inobs) @@ -94,10 +97,12 @@ subroutine allocate_scalars(this, modelname) class(GwtInterfaceModelType) :: this !< the GWT interface model character(len=*), intent(in) :: modelname !< the model name - call this%GwtModelType%allocate_scalars(modelname) + call this%GwtModelType%allocate_tsp_scalars(modelname) + call this%GwtModelType%allocate_gwt_scalars(modelname) call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) + call mem_allocate(this%ieqnsclfac, 'IEQNSCLFAC', this%memoryPath) end subroutine allocate_scalars @@ -196,6 +201,7 @@ subroutine gwtifmod_da(this) ! this call mem_deallocate(this%iAdvScheme) call mem_deallocate(this%ixt3d) + call mem_deallocate(this%ieqnsclfac) ! gwt packages call this%dis%dis_da() @@ -223,6 +229,7 @@ subroutine gwtifmod_da(this) call mem_deallocate(this%inmvt) call mem_deallocate(this%inoc) call mem_deallocate(this%inobs) + call mem_deallocate(this%eqnsclfac) ! base call this%NumericalModelType%model_da() diff --git a/src/Model/GroundWaterEnergy/gwe1src1.f90 b/src/Model/GroundWaterEnergy/gwe1src1.f90 index cee57d6a166..66da03309b2 100644 --- a/src/Model/GroundWaterEnergy/gwe1src1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1src1.f90 @@ -167,7 +167,6 @@ subroutine src_cf(this, reset_mover) cycle end if q = this%bound(1, i) -!! this%rhs(i) = -q / this%eqnsclfac ! kluge Ask Alden if this can be deleted this%rhs(i) = -q end do ! From 14676160a00f1aacecf293686f417fae83524d8c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 14 Jun 2023 11:21:42 -0700 Subject: [PATCH 189/212] Should not be part of the GWE PR --- autotest/data/stg-vol-surfarea-vsc04-lak.xlsx | Bin 30532 -> 0 bytes 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 autotest/data/stg-vol-surfarea-vsc04-lak.xlsx diff --git a/autotest/data/stg-vol-surfarea-vsc04-lak.xlsx b/autotest/data/stg-vol-surfarea-vsc04-lak.xlsx deleted file mode 100644 index a1c18ca1ce846609028aac37e5c01b4b329afe81..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 30532 zcmeEt^LON5n{8~{wmY`%j&0kvZFbC#-LaF7opfw=Z0lC{_kCyPu9^E6%&i|jwN|Zz z2YWyJIaQ|=WkA8ufFOXNfPjFAfeezox&wfLfZ!m2fKY*;K(s~d?OaUlT=Z2u9Za2d z89Z!lhzh|#sPch80OSAv>wj?s2301dLBAk%!*&lORi2eT5Rq(nT^*GPpMn;Tx^S>& zg-ocdwYamdk|=3Mfir40jQR*9@8fRNaI1F;3FG?EGgJmr^`073*;`$6`_k2l1r~RH zW$-BbiKDn4H$5#r?+QlOx@t_XRp>!VeuBXrsv5EFX-c5q+L;@9I)D?tRvVA}Fv z$}1J6c;cZV?~KZlqFuwEJp!o{RhU0Fj=FOzFlfZhe~@6%Y;`^hDTO_+TQLbS@`Tke zQ7A%a1D)ugCz}qj0+XVRbDW`6tQKS^i6DrN{6B5nQrobD8KP&PL`dH9jLY#P`oQs>&8z zmUTwCPTVA(`X)BLx1w1+sP8`X^4TLwB&;Y;%+nIXA=W-(h*l`K(_wYaP#Z^~3!9EY3qZ{%gNd z>kA4^JF&k#jj_Y8n(&%WI$3;h$$YiIsV0+?r`en-cox^bU7Nh@(Y0^Wpy$-b2AXLS zX-sj#*H+6)ZK60w*Pn-=1IJ`bWI~gv)Psk#2BRXn>t_ zRaI$8`bZR{CJOT2Y;xKxQQ0W7ZAGHCfn(aK2Ray}D%)+TIA7NI6^#A1-8lK*SVGX#dHI9LiWliUx<|ID-Sl#pCK! zo$Y)5Fgau>Zv0(s95hTQ_zQ@B0lB6u#yMzW$!w&Rh5Rnp-w?Z(W zx%QOq2}P6*fiZy$HzGn?!qWXq?$g7hTeya3WP4zq&<~0kapEKRVqdYi%9Gn45U+&6 z9EbW^Zt_7wxmfumpEHkh&%9up_u>u+k9yX^5tZH*R3s&h#{r zZ_j5$kryV`zR#*<>1i;?BxJ$r&o58E3#~MObuVB0W{_o?;Bu3~W_(59j5?U{dBmT7 zKwT2y{2{WxG72Rx1vw(M?r_3cAOIyiImKP@-Ci@l+`DKt^}5(jFJRG`X6}m4$Th5W z(iJ(o#_j;c)+2OP9u17)BH35)p>=u|=6C$KWU3H&xjZ3~;acPZOnb6>^#Wf+dZ6}l zqXa0=O#+{*@4k@M*WYajINqq{Cy1rVmb;aBl`S%F{_FMaVY?qcN;J|$M>2_4VD#ML znT3&6+)T~ENoIP$i02KZ2B>u2GQHKH0djddY93UuQ0Ezz*yZ=h%e+wTlpi>2m z{onoSOjeK?WJ3CR8MH+_u~Ayx9%0iCDYjf$Lr7FSUuu(;GV%0%Yg4h_)v!E$*Ksr9 z(T|sTZNq#i${lXO<2#Xz64LJ&MqG7T4?bSqjXQvMsn=voYKL^-@BzZ1@m~risO1&MKxa!E!z`!S|HIVbB*+Apk8lq1`U53 z-)wDmSKtK4Z+5!=ev%E@9|@gR49C&z#7H!clOo}=yCKgw z%QM8tTB(9IcCjX?vRhxDAfsn<>YxDA#IN(&L1GLrOF;F6J~UIsB3Sism=7;;{D@4a zALSrWFU}^74hZPi4G<6(03!dA17{0UQx|8(zi(gu=t6e#THG2DQrIQ!JwDQ7 zeXK%#HCg4Pl&I#Ay=pkq=V;!O_QPr(3P_8pITGeB%W?+`vNr3?mm&SB@uiaIs zU$I}HNn$*PRp{IAvHV}#@zAiaWjek!SL_-4Y(s3xZua1wr}(krPSJx1n-6&y+vpNa7<>D@1?TF2Isf+oGK|`c~VYz`F1z)e7n({?k5Lv;mgZFO1wirVL$dA-GjgtM1Y>u*sDI+3D?7?Y}G zKS+T=o;~rwV4P5tz{Hd=%7?MM9X{!=ArEApApg`Y0H8iUt8%R4$y*%5KBMY1u+(e_ z*_a{wDr0cFYtM{#G(K8Hve6q z`?<#VabRTY>T=?4GFaq;3-^Y9LS6mv);IPFk*!~0(QKJkse9&^^9Qb6#bo*$hwKY3 z;q6w&{FcV;mPWt5&(9Z_=&DK$lP#CW(1lI$d3c#8&!>m1mW|8L zXMH`t*N1_%hmAGD%{cuJ(9b)_*R7s6-`j)c(F2-^;g@)is>@Bc%T2#eHz?zK{Y?Rs z_u%)SciB(V9a6#^{>`;fKKDz#_Ws)HN7v?QCe1$INtk9x3dr?Dc7bJonY3zMrKC}crEhZ&-Hj8XT5&cuzplPPw#kLC^_JdeRsfp@ytkTv&Wf|bWAWm zall{heN&J0*(&`=E#x`yeW}2O4 zhC=x6@x<}46tX0{On>9*(Gqv-JAI8y>;KlR@x7d*r34<~J2jo!sX*tV*wAws=N4jU zEyLp9eXfTQKMtek|Lhg*nh@=Z)2`;>H=Q{6^Jj&mP4o}jbh}Q+2Kf!jEqb2WsJhJ&5`$o&wKiDB) zw4dvF5#dbH<0)1s;6TGm`t$sl!M4jayFhBSKJV2RTZ%`#5c9lD(t~HpmS>~1I|tLd z=9}ilH_gVq$SW_Zv-4IL5&yN%)zUiaG#H)_)c!tcqtFk_>zz1pz0$2^|ChUu7Jsde zE4j}Db+hdgmk%p<+;D2)rt!NS#9jHf2L|h$Mnv|Rot#EPyP@u$bM^FuSBLahw@3l? zhe;jQqtO!zJeWou+1nYozWU^7YLu?l475nwFZTnyt{gsLehtH4*T#PCe~3S~ohx$w z@wDY!IatG#fr}a%s&kJ;Wwo#q+dx}ZKXQ~CxwD>M|IOQ%i1r&HBnRBE&mD1{>>?QF- zG4It`N5~SLwyT=i*M!f}=MMHh@F)8n9a>An_mYdYl47?9HDHUV5Oafd)M#3gCsjKeTb^NZF_=UPT!_}%KPxd%8Ara)q-X(ep|6?hzwYx9Jr0tfAj9U`n&~|h3o2-{9 z1SG{;%4UlPC0N{_z3*;KSX5@8a|W5)A^gh-Wm|=rRRsusMf9jE-W!$rbvioIy{$OU zKQdSKVIAE2Qgji>c&j$HOxQ9R241>LcqJ``Fy+dEjLHR#R?lf#^XN>bd~kBd_oyqq z%+Ui4O~Gw|&HbhX{>IN7R(OYce6Qi9{L=eVXx9lwnz8y0sz4xD+m{(yoC8|2MJun= z5w4DH{$-Df??X@Mv^4YE)C=sO$deC?i9}o2{B*IpnIgYxSnf=3_15L|#_q9Fe8P)$ zQ!bHJvY=Iyo$R!u7VkLW@WLUU%I#z#me|_Vp3(eXn|e*b3CnRRHkDQj=Pd>oedtw0 zq{BU6o}faqfkNedL8e@*5cur&im!KvUu`@6(eL@D{N87FIc1sbR{O9C`laoo%)7DT zaVMtwWNaLVJm z$?4R_DbudbB!IZtAH7%v({PX^e3*Z_IrTRogZRcSqC%}wAfZ(^p6R&l`wf|B`Qrt( zA7eC!FL`m)@7uAQc4l4Wi6a-kjbKGBDikjnTh_X+?;S5*v{?3u*^@H8;8asuG|A1B z{o+o?&f<-3?dV-@e0?ycjG@^5v59yN#cb6v6tgdT06c&cHRrl>ui-KOEL!E#ErzMN z!(dBF_kxo{Y0xCsTlR}9vzKo@x!MI>6GJJ%uAP#05>Qb(GO?6+79NWgB+y5G0U{c<_k=b0W2 z$XM!Up|+=)Z~D#AtMerP5atwi=B^pCt^+@>gg_Rb*%sAgRoWy96*;h2_B5V!{>hu% zgxj6(Y9?l&zaKYJLXx>MN><@7*bFfcGUBKtIhA3BGMW)Gxv#gYTTn8^GxaEvEZ-eX zaQthF?|)(it)f1AxtEwg#=ywB?xbGQat~X^%;kx0#1+Nb;xoAJc1)2o93@nNl3QJxUU}E)j4B0&`_+H=<&uY51Xg-!w~9j7#+N3}0`XT`{2LSw?6Sy&l@94{ zt|I`8t#wJ}9c@TIbW87t6D{Am`r9rzgZJo>5O9zCn8He3m13d*DaCI>I6&H!fU?14 zQc@3>&3USEjg%cWJ$4WK`mcFOi@;`e^w1TI^MWMfP!-LPK96#fYJ^NT zXy$V=X7WlP$?I2oz(lS;AgD$Z#p#oTCrcoJk#)Sbt=`aMe4Vs-8eo}6ChH9?i+LoHvgk$UgG`btsw1=_W53yzF~nW8(C>KM#w>rE z<%Ive4U%emGVp>zOquIp}!3z$QSZUwehkq}0IF4)^OF1sCaGdL9W!6x4!t z$onjL!nhGf_S3FX%VkaxLUvp~!f?BjYcJ?woOWRqRo$@w^o84E<4gUcKpWEF*=cVL z>ei3kAl)W@lxY}_rU(jt0GJi%!3phYH(uUn-n}`$D=$5kPQ(0UtMjJlVz&IrSeOAx z^Kg-Z2J+yGzYJjRqH>*#a1z*^yyX}m`pbamYn{^nEMgE?SXos~o_)j;(LAO6(@*H1 z7VQ~bK6L{aRJTTH(4x@Cpmlj@H|&=QsBQpDqqHbb`9#KZ(`#7h$&VVSgTmbElWDq` zK~1YgCPLG?B*tOyy1EfA{v_Lm z|JGFerVEc1a^0nZb$+2X-zcY9w#}2==n0p1&apoTW8>Na?=-cab32=)LJf>5`2DwS zL1=fgIV;Q3>Oa9cX{eF+(O;%+{qa5XJ^I~|M4M@_9}^!#Zjgs=VD5g>_S+7qvCW*) zE|NK%+)6uu^5?01JSc8xUE?}n={^6B)PsF;^&J2PhHJ`R?_ne6(`P(beLfAekrPCWH7gJ@ zl{4kO|I`b16|RkkZwtc3rey`tTp=`i@YfR(&(=?XAfk*xo7M|CRRwB5Fks2c642>nx&W{CvFXdXLpJGOEc zbib2+T7P@ZqnWN1gBEg?1vCoe&vjrFVqZRc zMmes^f-Mz4oi?5R2l8G#`dVYm5``l>4D^;=2)+nX4Xz2llT8MjP}7;K1>*Pt{ooX) z^${?h=tXn{EV>+X%J{$9iQ{}%$=>xnz(i54Fz&nK!N(sAvqwO+2Ikj)dJ$iMua-IB zOK>5$7b}eH9lQptcPoHWGa<-jXyYj1y|yv*H%JA4gH*5&Z^M%qv*z$!d92XVb`wpkP_Yw2dAAWzb`uYRmq=aRDv%MnVW0+g;WYE1@Mv&X7?lMrW zZP9oqT5CzPb1@Lgh1yEO$##ac`~t~3=Ra#XJKLg2^JA`Y;PjV8Vr5E#CVpuX=`UX! z|8ZD$?=n>$3r0F0aYYul*!_2TQt|MAIxNv$8an=tYzA;Sj6{{I!t3K>3=kR4*!zdMJ@{G0?-}=ml!9Z z;gi#qWJaIYYiJzDABh5XO_4`Uo#ht>;{K7C5mNw&(cC{h=H2FOjmT1Q8TMy#4nBo?b1TP60mX6FkGxZtxjTuQZEkPnY1SN52S?aL&u6}29t|bB z4a*-;&1{#PxBlCnQiK8`#gC6@8Rx@H+J3`bWxf7B*hh>laXl%c6~=3N_fbN&Uwu2= zjiYwIANQ$-yA6|_a!WULI7mPaOE!!7$Ay*zecww5Wlgk21-=*ex(x^j&~sTnHHiuQ zf^f&aCE!8PbvXAp3_5gx|4v?A3%8WaXpsB#9q`Tr!0!+_sLqy znXyWaA-2tG`VbMyxGI8r{ZMD>6$S-_KU9F%s5KRi(m{dIUEvDO4Oz{IwzEmKTktKzW{2z&g}?F)q)6s( zzk1iO?b$r@z1-zN)|GQPGJM=b+Of{oR!CaF1QyUE(fO#J9tmQJAo3wHFL%OY3hRYT z{JVGwoyMh3db)p7w^bo) zcF3RRYre3<6;SD7>cxi!PvKMJB6Yu`C8_;m^^`IhoN;3j-!CB_R~|hyDxJA!&mcFf z->~d6P2twIVb>|9KQkLkUH&%BT6y@?-jqD(`By6G`F}N#DrOP7m~ewOYZ2W*d+vn` zAfw#LPc57%JhrY)d9d5%VJNuA(1 z%@E#kp|!au((+3kv1r~I*JdNZ%kjw_$yx$nIeGxqr%hICvg1igmA~Q6;3j8sl{TdL zc3}xmuvNfQBtUy;st<+rQGaQ9rOobCrd)Nv1+*3 z5m>Z5O0*kZF>wve(uy;k&)3s$5&D}8xEwACB`f*@eYIn|Y%v9R2Y(w4fiX<16;4^m zjWVU`CBs>+zQV@A!Zaz&fEBWwv_JV}G?+C#^XSI42d6j?40js+vD5g^+3{HJ^lls+ zBDclt+i6`HDx$NJP1TkA#)C($pSeV}Mg!mKR{l;%| zt^j3QrOk0aG_-*9av9{1Qn=@);--wvG=mnio!&&+PcdDoKT|EqQx3It$q9DNe10W< z!Q3GR`Q?X0sn^l=Qe?t2OG8HIto z=t%9MrVvn4ymYX~0es-<$~O;syU?9pEEa-k_5;rO$Y@}uX<)4BF2q$6f?q&8u%z9$ zl_fUSjKWF~MgTo1izJcEPM9zF>&N^!3pEDAS(xSSM{!)TAn~&kuX$pR$LvsRJ1$m{ z55@H$xXg1Hy;or+7#Wzbc6`Zu<^oroJC#}#&Qgh4nMkutkPT*}O(yG+6-IXVFqQF2 z5ITk=2b!c4^{?nKj9u!_NjT?X_!Hu<@^3-&|>FR1QwjNbD_YHvO7ztaL2Qt zq}V-$nU-o~Q9JN(j{XRN|5~%kh1|h2hkfv#}#zpLK%D?x7}Ae z$sLy1pB_nU>#)r6?|8836TP%9qP}M$>Fco$f?&WqfSldf&1|!5f|nf(m2Q_Xn$1LD z1F+C`tiZe+cbC3w%%bBhA1x5JQUYSBYS#*3HGTf z)^P;}$0v8k>Biy-1HA4W`ruc7zxgW(qHPebPh4)F{B$w*QzzM#r_>IMSzWQMKi4>S z-;qYE34}C{Cs9I_)|*?+=$RR(0%#t@mkjY|$wE=!G6(B4h(lh~1jtjs!6TjwH?U#9 zeiE+4JyBK}GVk){wIF5J{M*DD#;u>g$oX5gWICJ>T5orecq0-!*dP_Qyb@$vJMkG& z6g?;MXg87?iOd9EOpFQIVDJ|_0p1ifv7KxanVD3SsOQsYy^EVZEZGxx`yS76?3d&B zC4YYf))8?KkOAoil)A8_i;ZkG9GbhP%u-pn_)z(_n?!FdlDwlB1&%O$(R%S|Hu&qT zaMY3LyQXHeBV{38je+YSk!vSWew4*B(0QbgNAa!8yo{8lAz8WVcz2mcLTf6GW$mKI zGkTA23?^&0FW*{e7ldjq;o-lo^%D5d)X=z5v0*3WcdT+zrL)To;Q`z8l)=bJkJPE# z#X@0d8yDxVc2{%@Jjn(V_o24?`>knet!LfEMtd`M>7<^;z)~MJZUanP!DgQjBNz^C z%MeDRa4KN7aiqF%4>Ju!X@3;>TBURr!)@SepGAitT>JDPNUZh}4qm@;54yfr633QqQ=Ww9yGqRD~B}%(;^Rb$u?-|6x7dLs#yD*)_K%(Hd{Xeih#x)RM%hx zKdjp}_&+_`wmw2%B?qo-XvTF83!1`4nEi9%>a^i$DTxroBnUY#zeuc@86I(?DR9&M zaE{t5*C!?TeQew$Gj--8-+OU9AtZwJyX1ite0;Rmh#Ar|&SrDi4<}7xZE$oH z?^=auJWa2ErI`oqF`S6eIEfaDd}US({jf~rwp6NN$3nanl6Ttn*6bquJ0G)i_R#?K zk3(D4F*i;KTS(Q>I9Z~QnQKax@cy37PBv+E$6V?(7wn%k_@)`OnIbd%tdqcQRw)y5|Cy9aifA%nR*tbBsOPj^rf^jiT@t=)?(ki+` zlPd_Lo*|efK)Qv8-9U5f@*#34NwW^OG>%LZkdJy_5I8{v7Ob(&hN<*Gpw1 zR=^>!(%+VF8C?gx%7z3>bLbHVR`wb++625BH3`*Z4R|5y`zIwYN8#DHVH|SqkZNeS zVKCpBQhx0o^OPP)x&(En=XRLiFr*3WPTra{B%3jpN|au{Kv2D5Kdm5=dkk;#|ZQesWc``!G5G3}uwg_nM6o_`!J>5kea%Q3vE%JZ}y4$z#GtCe9 z{Tp~%ok|I6GU!`&`SqEnrE&Lxoy#10$mJ(HDw?~P{doSwz0Y^fHf@LS$!?aM#!Z5J zor8Lv1La~(+&}k*eLP&dm1k;)KTtCQzc|37EHH+l3&%u5>F+{i*?X4tk!9W!S(+w? zGm4&wrIhDL9`?w_vKd7vsaa^LxRGP$#&EeW?1*jVu5n|~kgMi~RH9^Gr?d1kzoZZo zFoi{p(ih|$da?hIjLNG4$^619yP3RFN2(-nwO+)P(io zgmpchs;p ztxAv7Q+H$DyrKKz!Z&S(s?Xj!FJT#bcuC)59P89DC>Q@Eg@){sYDypI*R7E<*9w{1 zYdV!3`abj+BnVs0f-T}@^%R~wKX(-wS)LT6mzz!+n}4^zo_nRzA!jUXqk|o9_!49l zmKawRr?agX0v!E#gdv8LJ6^Q?j!u3QJt-7go07Tes)gz|Qp36;J>;pM1HEqxrkQ=RCkTJJ%uXNo*LMRrsj3+HSR%xeITp18IY#!L0+l)LuG+I7T4{;pxf zQ$Z$@ZRtVLJe>M0X<%MUDme6mM%VPobD!C%r_0v}2>>kP zTc`=_m3ia1IGOpv5q_F=>;dMRIOBMZiL)`L_^0pPB4&t)?Kf{5Iv{4;JhkVDxoMO~ z_&B9P=88i8B9DM|RuR5opG<0@CWB<{o4Y4#k4YcB;0)h~KF;oSkhfg;2NaajV%?Ee zL{VmtX2kNc2(;))Ji{o>H;dx@?Oq{VG{l}+fK@{GA2IVs*4S&Y zA!3dcfw@&A5tPf1iEgi(5^U46l5sLaoZKB;XSNtvts~!<4dbLGH%k*b<%qcsiR>^U zTr?FdYM$qL4TMD?F~$+5@znCjWu~ZLes6I)zN}cXJ81K`|Oa zWerLa&-2JMV3Az*JOtVHvqlW%-`&>sr5TQglY)Y0H7L35`>@$^{}@w0u(Pt zx(i~iKrjob+$#)7jk%2-?hkdqPwQ`XaSWmR7*AL7apC(7{l?x7g5mqE%sl8ht3a6y zo^3s#idcVYPlAsFdY>o|rjmji0Ok4ztX_hW9BN@C4VPOuOGm#?Ks!SxznsU+b4j1_qLo>L z@(75+F7?Itkb!Qk);8E=x}WBtR$MO5l+o=|2)Q@>$$LqX%J}=tdnsQL?w~jNzNnSw zL%>X+QLlhc&@qo$GWh#z2K6Lves zw8*qlA^RwToZ@nBbUi`47L&@n8yR7?!swcEy2uUo(DCD?gwWt)M}E7^)Q$#&Gwt$? zg(OAF;nmZY(hmz2i5F0yyaU|<{lLQ+r_UAZ8WZP+Ro>R0>+6<8M*T?C> zKr`GaWqm<1g)|?7L}O2TWFIJLa^B0hRu{{76$r?7R?eBxZ6JHR9b{XKNCL|%^^CC7 z0fNZmQ;(W9F@71B00FTdQ01g^8iO`Ap8^$*%z3*S{2GJkY#t~0Xm?3sG<%@BIE24V zeDZsogD$?SEm~xyfl3#XYmk}M?dh3DsNf&Gl)FY;4U~%wpbb>ouCtgV(d|$-j@0|q zMO0c}o$&e9LAA4r&Ws`fV`^F0P`olZ9?>F$SX4fqvhUR0E}LRZt4OrjC5XiI z;12Q&i72Qo>1S*1LvW=%LevAx@nU}7=`Zw(K5e851u?**xG+l!_VCMqw%I3EX>z3R zhtem_ET2avwi)J;OZVzDiCE*54K&y`Xq-H(kNxfke>Ol?U*D$oI1s6T>E3v$O>L-{82f;!*zQIR3sr8cj*fb6|i9#l22F18dl)HT}i5g@WjM`)rjngjs zfJ&yB&+j}-*DnGML|c&{xDVPm!jKpQ2q>-Nl}@MARcUR=jXZxtM957iD!Lc;6|c8h zBCI0+LF28g48~dv<@L*mKv5Y+Jzt*(%E&!f<2yp5$f?Grb_l(2YVh~H)Zj^9ay|E( zL@_cwO2eq4R$UTJcwai*brR?zd{A?q{YI1P%qXjP}>dWT&CSsI--2^sSY(etef0-=Mo~c+-_OTWdv60Op5@o|yDx4ma~OnC*2MJM|sQNuH-j@4xOf61g50 zt{4+bjCOED`*!9S&8_2cD;}*DOc_${qZ1Ib_>wCEtQR6vG>`9yGO_E0wsjEHu#Jj@I=dGr__H@}09BF#^EaG%NvupJ_i6W^cDr912- zW8=4afLFgwUU)FBF7845QYEPCNa8|hUsYqD(zcf!GJctM1#BQ@-V~!!#H)1v#Xf1Y zWIjSqaxT(ZW-1#gN41>h!;1kl@;mc#( zAgIocODyCH_(o?(ngE2uo1YBu|7>=Qcxdlt2 zi~~^7Dj=@uGI4ZCAg**Mo2G-)WAIMk-ziz$$6}m`LELh3e5AnSp-|~AoUb6RpyB~i11pHIvU$;3`VuWD&1>wYMQJjEyR7Dfy z)$Q6H4xq)e+=6~!&y{T-=fE^NJZ`;SeM1xHhQ#;OGbrriZJz`d@{BRfD$d&=)%ht) z5K0o7>r#T>PhEyRDHk1k4V~}Nw+}Gzh1hXTCP1(psXGNu1YSgw7?Tj z5u}u*@30l~|ImQsBA>dgIUI9QoMqvBX?l9I^ka29(gIRQm}!e@-h3oCmT$^$gOx+X zk7FIOx~R8onYhRB;A5DJk}I?rV@=2JLXv)k8eok@yRsS76FFi;f{pT?*!t1nuKo=p zew($W!GZSwq^<%~)>JU=-4D9@l1>LHoi~cUC|uu{!Nk z6Q}C?DV1aqCt{ST9@spUHbc=0tESnketX6eih@U3l!gV(3ps(~j7ler1POrgOcL*38T6gJz|c4%ftZe=H7;VS>qgqSQi2N8}q; zNMAQSUyC|4%tiD3Hqo$yk_$;VWbC&$=KuG4@!v;r&c@UQyIrU~`3N}YVh`U4*zb-b z@gP>g_|l(eMDv@zgmVpa%G%IK&qPotV|f-|wf0GVJ`UG@-k;X?yzd=t`F$J@`@cW- z^t>)@^|){OKi>QMeH^KOoZIibUVbe7%=3R<^Z(cq@Oyt5ul;;GzudaimVP~r-1@xR zV`RP)FsbSWZmWG;+VZ~<__%si06b(;pJGskwRgv<9N8lYGmNv!^fSt0QX@~$rs)q- zCPlkGdNyRIK9-h3p0xa*$48g#ggqZ?mZ`yWlt#bUQWKPCORPU8!hKF*oP2`m?NnW9~h@Q>MQiH^0*{q7?p^&)6!C%*wD!N}b_N{Rp?Gy}5tn^S1BmSff;) z?)A&VQU95#4ae(12i__~W21oU12vg@nN%@o9*eo z*8S$<+7zKBmo2k4v)v9SGiB1&`&YUl9VcM$v9!F6&zBQBXlQ$^N+{>-dfqIXjK@&X z%vxVNbE-}JjAaJ~Uqk7e?%p)MX1u8f+3q(OQSRVGa|b-qN0#lE&=?STOYdH4?SZ4} z3gF*hXZ$d-2wp8g<=m}}_!!#q{V#AhI<20fEx{_pVNOr2;qy2G_UQ113XnB3!L#;j znt`fIdsfRWzVV|!Y}qGXgQn(FGdSFaM?2&A#G~svRgWfN+UVOJj`O;%7Y)FTbrBm1 zfeG({M}&f5C8k-jfz%wR(Wc%sk~V&%>lhh7#U|hTnOWC?wAM)I%;u+L<4PjnsL*YU z6YLB2sSElk1mEjBQ3q*j`#fA09ecy82`=52MMF%9oq1Zlqbul6w1RFDKBMX2#QAN~ zsD;FiLcgAEMJ{ct1*k)Ay{fZHzV57k_$KIWY$DE`Sb8bmFG~Z?Wy}|roUe>+bTtEE zk3IsZ(|y$ewFnn%z4RXIYXCdda|EXQhYtdze%=;@=lG18YKFjHUieXL2J83f}#T&$UAoTzR$xUlPJlsBxC5|8Fw@dMK6YXH@WV|y5RE07u}14yrB@6Qy` zuaT`&)werl;!Plf-SKv_L?J|kuFYVWy$$oqAhS@NcfaWea8!EDdK}n!37!XYZfO&$ zf;()H#x4k_-8F)7?#z5td(JcKI8m?BaLaGiG=oWzh3xSA6%dqrKt{P+=ZToBDPdUT zrywmiAjt8N1)W3DNo_c*SX2(;P-Qm>dU$zzA4_f2h*oeV4;_w?Y-jR?Z;(kePMx@) zN3a!&|3z&M`qeHdum@b&Z@-#C3jR z3{A&afG7GA!Zs#;S-%UZ4F*9^oDQA|cjh=Vl7F>)=iaOsYTi>GjBEUcUrHNs_UfU* zD*2Rk{)Ed~mdJp5yNzu~E`jo8)d5X)A47uA6>M>k1)esdDwu~I*tZHo(i-f9 zgwUV#<(ioM((P1Pg=_uJVLxu-n`K?lNFR|C#=Hg3w8k)`BRlw_JSs0hcTjiqSJiTXv@~|J;K`0| zV-PFZEF6TYAs_O&p<$u{G1NSA;Mq8Gy<8bgv9pC z&|ZVDP~mrBNKUt>qU8Cs&8!2Oc30Xc-{MJ~tooo^Etc}f5`~ezy*vJ*^uSO@(u91( z5me%}N!JA}W`su|VUf(w$N_s}XD>6VWAASeAbuPyiJ%Rr3eEz#YC+OKTw$Y9l(HC2 zNVLy38}X>L16>&&e(1E{%^3RQXcq)FN42fVo`YXPS|&8aNK5D&J+U~Zt%KqL-ZRzH z!;wJ-7^EXL?i+{+h!)6W_!$msYXG~)Tm_B?_~<}VEUN^v@*La9Sc?FVz`Ox?!d`T< zc(6kVq!1)LL$T>%2piMoFm})_S!*=}dg4yJ;U=NFuQ2Bjy69qG4tgRQQcT5kzR)BZ z} zPk8;E(}!IkgV*4LRVQ`c$m~!h#_Q!36c?5H zIP*h0tdz^D6%2uy9hC$Hz{`K+217SqFjHKO{(O z5vEI-8-hzNVZ4+tK7leTHV4%Lfyz(*w@k7Toq1r<{}GVn(LF&`DJH3~04=T#2-PWX z(L#A|zeYi2Ff-DwaW+UlE;2rwSX3ExJ*i zAS2wZ+Q9i$GO^#_Q2X0~l&Yb=ZTyOw@+wf3A4exv$P)QN+;js&aJsDr+?j#Vf&i;% zUGG$?Wj(-{)ME>(Ni&{%tLwQWvZ&QdhVF+oc0{K7AxT$(4pg-jh|A;c5YD?q+_ z-m7)G%HkDvs?gcaJniqlLd5z21N%!o0?qQ2^FRjEf8-HPhDtajAiEoT89-3T3~KvaP*(j4;< z+%y5#G>*m^s2qTOAKmALsyYSRg_Ap1T|>1~-S=lz71^oi+QpHoufbZJ^lcJM!OvnI zP)Txb@H7~xe9Fz6(k*e30xD{C8jvl{Q1D5^tY#`m0D-?C%jrxsB-xSk&^+TWb270h zap_96o2)9UGWeVFcz%<#Nf**;91nhhr7vV4Mx-&B7c>$W5+1HqXI^F!mYPDwfSy6H zp|WSgXdBD&m*CiCs@>v^Hz$X&n5z8gB`gQ;M@9h^twmL^H+Vz50;{zqeX%Mq$t%+K zFY2}euspFk7!^(mVDMT51HDA!7S zGSPD<`EI@xiJE^$QumJL=IxqCLr9*Y6oYCP$>=~C<}rWvV%Bolq^ds zoc#6z`!Z>sy%$_+XpcL;sUXYr*ER8W5XMmZR)Jgt=qXTH0c{OsEm+qTK?(YU)Dvse zZwMW*32!HnWgyU8a7Ak3O2E(H;}i!^BMz`mtW6on^pN0S59{t)t{uIjr$-c3Jbn}; zL-cB8cECvI58PoYrmOA~b{n!FM`ELa+!_X)`m9Lh>;%YzuMU!nCK2(B=bD}B4-u&G zTE&5P3A0S|X^3cnJj|QyB|=UnFfvAj=y9PD$k=A(OF08Oqnd&=J-}yScR49)tgCYW zcD_1IFg2^x8EQQtnL-#~K)7{`dq8-pKo_LCqFpqA#kEl#Q*K?W-H3RRE_!pcrPiUQ zx>v>!Vb#~)NUe2!S0=G%UilXp4ZSDf#!?K+iGG=XdoKgWAv`AdGa;u9ki=Nsmkew} z2vxuwA-@+fQ=M5xG3tEQgU}UQA7nhNw{C%587U+`e-yzP*(G~MYasL3ZG|RperM-) zDaKXn-t?(d8G3s%n^X(IfacjGW`eaEs!ka{VI+=QrIIaao0_W8C8YKU?P1`xR-8>c zO@;MH4f5qL;63#<#zEP@_!hbCs1yrep$IKY>FA`y4?d%-c#v zaH?+Lja0^xIIrgEZ%s(U@&oP1RbKViE@wMes3URr8y;>kaTp)J>TwB@<@r?d+mPS; ztbeY)EZIsImicw_LqU-iUQhTeU8K6*-%3M!|C7U`E$cDkd2@(n+byTjVAi>t(=_0L zte8M~XCJ-?#T^n&B77=T{g^N28+|dWgX{=4=XARba=!P*wEY4Um)Z-cs~LtuU2d$Y z91Z?^c{w#+W-Hl)B#rNHIkK@?g$&P5)mv`f;4meU7bA#-0;^j(YSg&rZIs8fY}o-p zPIl|Z)DH{68l$(KS!@JwHr{q7seX@SOa##~U{DsOm8u*A-Xz)n^u6CT*JeSQc-Cfz zoJio&G@48Z4kTSQfU+j~b|E%5vC$(tfs)@XhTl^8ERhgEgBIDmRm}IY`Q2|}CdH#~ z*OoH4bhM61UeI$hYL8vQh3%3zi7J?aA|b0M+Ez48Z*5K&rePyG97n!b=vs3)xzr^Z zzJ+aQxk@YyF`+v(pbi2zpMqkAZM3PDOftWtx)y6R*B3g^x#&EdalA>(iA+$UC+_ zH?~Lc9_)krs3R(bS_8Rn#;5cNnG)}P4@>*-nP_L5?^sGQK_{eQdHNYy-V)2XUxmTC zJTh6Wn(RdBX;|FPxgH~@TZJWh35=^;Zi9uEfS@X$J6R@B{yX)X^g5cZyG~KvxRK97 zb+r*N2U>KXzQWNEFOw&>e4C5v-=E_?@j0Dj6Q5}KdvtDkag*D7dBFxm&X#foxxR;$!XmuRBUNCP<3a-A3b@*X4i+kg>5sWG`>d4zR zIe~(s&d}ZFc6%=smmupoQ2h0KHR~)>618pip-d-!H))(wkpOp~8*B_o8pPa-XqXPO zR1>1*N?pZI4EfQg<2A`EX6@=!MoMIEM#(^1+eEo#4I<{j5#*2$!)3oRbA3~>ehqOs zvsxip!8fdUHH|`$G-4Oe_Ip_fxG)8p1 zgjL3Q$!IwIh82ePuE#@;P`DgQJa}9S1fI!H>!fvIu7rpUaD9%ZSLF|^(o?=MHHyx&o zJcC6>mdThH*{r9JLFQB7KmGOglXUJ}yo|mq&Lk+q-1^5QQhPHejf*X0S*0vuAO?Qg@n#uryn(E_+cnJOEq zloeZJEcLPM5>4Q1SBP84BAPad_QAJozQb@MmzpMGvEW<$4B1Hwq`|Lo!Om3=s`_sE zd7d|*={vRIq~{e(Adc4AyZm+{RBM0(A$qn=eb9iu8-j?<)Q=|38Gq~N+h*=881boP zi)j=1x|Q@6u<~^Kwd(;U^Skzgx@m}&kT#1P1LAuORJW>pghhfpPO*r5yS#1;`_@J; z{hPv*Y_{P7VvWY}l?oxp=O*(4R_6pcf!ATGcb0K77>aq@_^E2>d+7Lo%aiQMyILjw3xKNYXOM>n_g{ee1 z)QPY}p*mU~{W$yc`^o!IY|yeW_+>zHG(sm=S$nbLcE6t$K0ZE@%wbLOuv>?LDd26uvUAQZ$mHVn z=3BUl_}zQ9Sg?!W#SiDFj0=GDT>Lt`;labaL2fiP?wV2!eN703$Ocz=#3!VmNTPEL87cwf>l+vJYz5xzTD`FR6e|*)+@Y&r2s6 zMiw#OBX6fos`4AF;TDn*%?^?M(IfN8^|qRU$qv5ozoBo9LC|FnOL&a_Jt};T)@&a^ zmNgy_M5qvysO|UzsFtnqC5%O8`mjZHCP6=Ws2OVMWZ8(8oani^KIq)CMBdO|^v1U^ zI)sIZ>uoM`0hw87^fPzXH7rausOPhh1t4F(iTg%bY$yb@q-U|T`mFbpVb^!?d;~2d z!}>HbFR97_pOWz=Rl-;YBv&GN1EG#k+Uu}fPgp`Z0SSoaoCsuvi!olpJW^}FI+gcA;>PHc9gXqdZ~ybhAX@lvYC{upyLV!(l$wWw!*zqV37 z`Iy%Yc#gfl6@-lC@eP2EJKm?y`YJhL-24c)&}vXT_j{yq6(^TmG=1}36*#02MF|R% zH)bTXr2}(5R!vV?ZJ|-@y6a;6fbXEcy3NB?QhJo@1S=n7o7dt;g8GK`H2RMhjUu$| zQOzC`cZ903G6#HVK%jz|4Z*pSDZ#?_?k{QYboYs*9{g+HI_%e;o6#EuCFJKLV+RL8yrX8OoE5Y^44v=r za%w*RaadFX@o;c`X)^FVjS>J<=Dt=ok5JW|f#{8V?sM}yG_D{NZ_|gq`^mrdK$y1tt-yc7jw(IQQyHHnkT-&~UJfY&j zW;M3F?bHFbs7D~VHl1d*!RlS&8;eT+j=X<$94?u-BW?ND1hYah|rllm|hh!^I=dtAYupEaMjZ>#}}L@RJ;he z$uA4z;n~sH^iY0}TI-`G2`zvmQCZjKl20uWDn4%BR2MIQ5*Yot-BUp)qo8#4j!|x8 zkU^tQ_8mjHI{PSxrV8zV!iaCV{5fJ>U-=T|KLTl$D8`6?*W8qTJ}jZ-x*X zy9;x>NjtdaxF2%!5@&y>#`@n3TkW`LEsCHVHa%p&lfeGTi{xZsZez~!=krfWq(kkY zFhXvuR@{4GBuCfBw;NGZ%c~dsoEnQqZyi|EZ%yP`cY2D1vyOmx%tPBn+$LF3#YU3=45y2WWVZ&3*Wqf=r;Xuy|a*a5+Ab?No9E#=yAH? zzQokEz31^;p$_kr>7e|E(@R7gu$+v;@Li=Ck23bwz~4mK!;77q@(?*e&d1|tlhPVn zj2Ln_?TThWIaOBqMrVasaNw@WF){i4xp4*?Kgqhs_zf)vhPTBX)zc1cEep<=2DQW% zjJCLK<_mkhf{~}znB)0gyVW=uT!4c4Q7M-BBW>xm1Z0%tPSe9FF%A~mc^B9@BM3F&nPrN962;b0~c%TTv- zM*he^x%SdpSwa?A_k}sI+RC+l9^0&AHxhFhDL}M2mTm+Pja+!BqN<=p!M&vue#|Ze z<_n?nMs~fw8%b#tuA(lCmUp#lfocK{!|n?PwNafK9kQJIZK;soa~@@A4J&(Yg1%9R z7NN?un@Lx{Ld_#X<`g#>ONOAw^XcA2P^+NNM&zJl!r5L;q)$6v94GV^j(+y<6nIc2D)VX9nNJ(9ScNSJl5FK4z9H0=wDa$kbd{nTseh-$o9_ z2+8AVA6IQH7Y`>cY!naPnh|7QS11d)JVq-G2%ex42O3eSFjtA21pn$VC;L2qKD2C8 z+L>=XCFp5JX$(3KR`1}STRp!lm;r|>yb^40iCe*-L+LK=O&LGS zZ}SCR5s0=TAZ?&Lkmz@D#mWPB$LquJIAR1{W+RjZ9Oo5c`?|cTQOG4@TmxirJ)`FM zB?QHZlq=X4YvF4;p59Z`L2p{6#M1=dn-3G0H-&#~CdGB~FAFoD7pR%79tz>$=ezis zFyDx$>J;9C=TR%EhP0c+$66M|MTZk>v&9Di&8R%Ws*v3}bg9te74@vGg z$DaE34BmE?y+(%1f=4Y-_?}kyWY@LVLudeNe*xn!a0p1aOa8&w&w3K+g*qRP<5Oo- zxlkdoq%@i_<2EC@M?xxS9$g1WT)`b-prdrp9^&~@Y0Y;e{3_vZNExl&Eix9{>|=`@ zr$4DX8cf~3JQTd2Fc2y=AGZE_q0@79eI;u3waL?OfcoToH$$nZe2arT{`ePkccYlA z7gW<&I4o=a0-%AW-U@t};x^@NGUH-ACDVojwJ;6)eAFnCj=1?!TUw~Xm6{s|b*5=< zkTV1Jx6$GU#S6EnhzZ3H^+gRSKM|p0@7(D0BE*yA@^*CuPnL@(54?BPT(y&6Xy+#I zj1}G!0-W&xhA3iK1|L2f%zf1wbJ7}9-cQQXk#g8VV70-#@m$6aIO zA4+`C?rHcMG|8@1Z&FVP&HC#K)}&l8EQii&GqcVT(!ji0@)DWb#Qs<{Tr+wqelpMHAB5 zND*NmO?5zX;_q`~Z>O~UvV;f7P$czRQ!TN7F6dq%E_yRZ)X_{D5!DRIx5JH|tEI)l z02>+N8x{cEA7b-MEyIr4x^rDO8nBpY3LWQ-kEG-aQ+CNtHp}RE8&Wbjro=#sr!<$+ zo^`-1kX!(H-K@04O*%E;2xGbZA+MW$f6^&#FNl8=x$snDh@_CB&A8NTN`I79>KE`8sWb5K^OHHrb~p-ddygXESOvbX7Nmu0R?HbaoaPHODAqkec3&zRBN8}m zrbI@WpR!dx;6|th*6PApQJH(^Xy?Nw$nodb5UI(Rdeg|^F$bY$CN2gC8%^iO~zmu!JV7tJI888Lz`Nd4`R7l9oCkm>!o>+NRgc2(Mx)Tr zXk#T5-PGmzmm=NRzD>|O^l&^xPM?Pr?$5ejmJx{R?Cqdp?g~*qg!d&^5*6wVr#A{f zISBHCT*G$KL7ljJ>h!SL6$*`OhaQI>oJiopcDk-7kygz>(BLPtx^>@ZRpdTx93S?( z|D@y4Fdd5UO%4^PBf>|8xxVcBa&wRGqDxtw5a?8^{$-8$j)EvDy3crSl{lbYb85^>k(e%Qc$gfH-H8vpz921bcSDZ z)fnpr9icc}g6=t3Ql&iTXEJihr%rOGF>;D4{1ZwbMf_^i>Q~^#KB^A*`>Bj6R4;{{ zABr=$KWImxunYGzK#yn`e;GL#DO%UX|JKxUp6)^{0XpVi$sOzJH7ahbJgry_tNHTb zc4ugP;^QaPu69m6g@ChQs&+kFR+!2Y;yQFL!J)icQP5il~y7YD*!R zs`>#dgPAddXR#EX#%s|(H6QeUfLZpLlC2a*-OMyfLo-H7;c^(4mh|mg*x4afiu}U3 zvBLQJt!mr2W791O6fvg(WfkYOnzrjR2|tO&V_jt(kT?PTu#oCwtD0{R=mQ@Q-$GYLc+PcXNnKq@NAh4e;iVI!6Y0^U5~ zb$WNrl}Ez=j27CSlMVUA+J6^DI9gO-Wpi!_Tg9SSeZsiur5V5{sG|LR80keSV4KrA zEOS2cS(Z22NGMx|w@>ou+}A|(!1X%A+6x6L&t~w~#Wnmt&A_(ddyR3>$jd+#Dro+i z0eg@pIGF=g&7GWns|3rdV>V_JOIx6sjB(!w850?EWg|Evdt-Z3GGx{Y*2*R0x(_O(AK7=d#+-0ngvZR@JR3ga($`aXkv+*2a(4w4}Xq~saR*?Pz zog{S1?P8piZ`wS;ozcvUz>MK$+sZ!UC)u#VLsEl(!Lxh+1?dA$6N;l_>PrZAK1A-m zFxvV#<&_t=)w&S^xXOkX*kD_UB6DP>9@04jI}EQ7o|e@c z_Dyj4pAtrMG3+Tk()Mt^gJQgqYhqJF00UbS0Ruz(Yg$Z=KbneL7+c!@_8U%m z3$}XPNS-XCK3az!8&k`*!Er&8+%nRiEQQ;W@`7`H1o_SUWzCiWh-9-~%Dedb0!?A$y|)IRLYOq>Cq zN6rLZ9`|;>2?;F<3wwTQ^5Gj&=-l(<_3`w1IXmd?zFRxH1^PUn-fy^7fUX$suYoVN zFAvvG>yH~pZZAiVZUQZ>0)~vZVMpCzbjd#Vx2ztGX+BGXAC$H`J+B{Ed|0H;T(DAO zLfmF>Q(IpcETu{B*Uj8KI^#Z#C9ni~Qf*q3yA~Cv%KE;8u)(m8Yiq=EOM*C2S=C2q zlJ|3^J7tDm{{F8bx7wS`_TZfpG0 zsJOZW-^B0dN^^P)wVdA8sG1bh)`;om3UOkvx`f!|;pfV7dJMhX+}4QecC&wt?REok zBDyLF*97Z#Lv~66wH(mqf#!w^Y8*rE=f+yoqU|YHjyKKX=@pBK3^XA|l;p<=b!Egl z)1uu>v7+0QC09cDq|z5B#tffirWXsO8&1I5lM8jGl5C7!*Ox^v%}v%+nPi|lPQbd8 z3-zLsY>izvltnMg#nV#3Vx&V!#DbR(4WyFnj9oXDMK8}y)>2Vpq+?FR!j}(?ppxv3 zT{o3QugJyIR*7e%Q%uC7lMhXZX!KM-FYV#@fc1z2t+^4x7FieRpGsR7;onGG7wWAi z-Tn@1QL3HT7+;D0h7;k-^PVea?~+uzK9*iYZ_7gHUw!#8!hc-nUveSXX0P%glw_~U zKW5hZj3?bjghpADV6!t>J)%_GWlBNLl@5cRrGNw|Kgn6q^jr;YU<;J&h)_N<+rAy^ zqRj`WULCZIafZW4;Q}9ts3P;dyrbJ8bP#h{5v;yxVr8*DAV#vJMiEg#mkQX}^PIIU z#^i*@&W~+7QCWnMb3{MOE#ugyWir9+uTrk*E($>g0|+UYdl$VIKYUQe>#viLaoxVY z({kbal7RaVCZ!>|Rl&i#dl>X7D@MJn?eGm6UpIAbj5=E1;UhYq;PwKZy;z7$-Vw#D z19U6~0WNbyG9VF+iq*GTyMG22^cScG2b6b5CVQrj> z9%L+X_~D3}1TXc3hKCdfvY76_wT}eUxTPdT)_7-Y_Qz2anJGb>nr~FAMALqr3Ip&( z*X+BX)0p780l}3laHF67<8!ZuI51|U?hAK#@iywM8!2UUvGJ9zKlirs%nkK<`D63# z@Xz1Zj<520rOT>F4krk1b?{wUYJdimYdu%_cK2|FdTxT-O>t3f(;FY(pwX3&FN83p zsvItTE>4OpJKevF{Z>5u7stCU*~!EhCm5Tq62AH1cJf-AoZ;fzpIf}eltl6z8F>9eqx`TAU@6;AOJLMSVtRv>h z4^kt01d>El=i3u<7v<;b5ZHMCn>ZI_*$>yS*eh9XvX+2}KEF2!mzn~zP);$0ShWW< zkg^4*Odb))){=U|2aeB7%H@bHVw*i|!`UMFcLl~X^}F>wOPWRGsCfu5xXl-qmF;|z1hgjTah z`(wXH$f%(O;75X6TH70#il38ni(OOv|&9S;cMV`>UB3&J(6-BN%FDZ_KeMDW>Lhk@`hry@n(b9!xf^1 z-5fT%GAnk;-yrC^(XABnaqWXSOH%EDl4GT-%xda5iA1f$gQUfA+kBsiq>|KWge~$( z&*_zu(xUEIKVY;UT_frmMH_$g2>o=tnetw&;wG?7siAw65@Xu$T3lWLIi=u>xaUKC7H_%C6{;d^X`wC3?4Z2ZB~h*ZW%Uh*T}rPj z328-9X~hHHy}{)iNCt|VA2D+eZmUY3x+J3q6UT5TSAO~p{1V@ksgz)xP@oyGrp#(X zOLF{6a>~ARwKSo^Ye}eie2DF39V)iPHND4(K-4C|M}_ENhO z;cbzhe;7sx+fWCeu|zZmPPo{_J)G2uOEZKO;mn@wSFGnw%2R<@5(5;lZ2S5PtpJgB zlmqYQHq;4&)pf_L9!F(f|gWg>~qd(1pornSdq5WMQwmwN;Zw3 z#FguXn!x)rt&4aJ(%?STniBf$Q}ABQsTX9Am5K0SfWiqUv^})Xc-Z_nK~>ti+INb^ zw=jw%pqMO$kPOVZqduv~RXif=OXN2xkJ^OYVaL%W+P7<*0HAg&; zn{p~~`#kgmzE&N7kxxT--o|NWQX=ro(e+H8aB^hevy+;PT)*dU2&S=~_X*-s^^Ad6 z#c%G31KVzVS4FRjss8f4{l4rr6vJj{8y=3=DnwNhz9h;uU?*7^fo?!aUL^*PnZsv;0wiZJ*T&_Jd5s9x91qe;M=Az zfkTOrwNxR46W(LJd0|NwkH!_g*#iOF&WCt_3+{l+oH>zLuM;KT!PG_bQ_ZcmuOAe2(gwQcwo542>5#eYu|d`RGHXoxKhYb9)79tgUl^ z-!gjY)RCQggR{dXv5gShb)_D$+6A`Kvl?LCirz)JCWlNONth0)ZhNfLpw-Y0-bgI1 zTmsjnC?@i6Np6r=U2!sf7v)*+-b(d7$ZYtMT7(l6?vl*DO>MsGGTS#h#Ya#z)UvobVZ<+Gs3WK={{J zY6W~ZPPqUF?Af-sTq*@zi=8xTJlz^dQJYQT@i0PjC}(f$8ZFgp#aiD9o(yB~NZ>y0 zv2PYh$gc0^M~Qt@)f=#3)=4rEzOXpj_7wwIsaau`%YiOB`WdU0Jv7&W?T={EH_IA1 z<(4V={r7l6KK_Q9s7hW_WwA>|c$w@w;jEC8bgCusmKGl9i>aYoZWK=9ML(Sxgiqc< zKjuAc2~G*tma?_^!3yEwTM;EB9bVfuOPCYKYzwEt8-V|)AmuX`Y+``0TiPSg%W z9|oR4UXvm%Ve-x?Bl#6&%kW>88H2~Ve0Y~5C&8< z2yzP@kY$Bsp%t1lv%_&EG7}-5Io&qgQn0_ll-n@%71IOjE`GihJyQ8d9s@bZLt#X2 zmF+@FHBUegAfE`ypso->ZaV?!DFEUe=Lo((jVP57lHr&O6vdlY!Bv?doF5>tAG-Jb}9kKx#D8tD16rs}%~WCyqSaB5=3_ zvrZnOfqGYi#u0Zxyt+EBYj8?9#F=1NX_8avYL1X+NdeYykcVyA(H**@R>|GS4)gZ= zq4pJOdx`u@GbkBwVqaTfgN+xs;Wou&6ic@of+}!(mP5j!wDyv2@%2bhPV^) znre7yT0_B;z~?}Ls8&CNCB_RSUc={)d7BFXGkk9`Wv*~^bhENF0mzg-JN`cUKhOYZI{*Lx From ddc301af67f6181dc5b8f1606f5822de781a90b2 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 15 Jun 2023 11:51:31 -0700 Subject: [PATCH 190/212] These changes should not exist --- src/Model/GroundWaterFlow/gwf3drn8.f90 | 51 ++------------------------ src/Model/GroundWaterFlow/gwf3riv8.f90 | 19 ++-------- 2 files changed, 6 insertions(+), 64 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3drn8.f90 b/src/Model/GroundWaterFlow/gwf3drn8.f90 index c95dc431d5f..53f74bf3bea 100644 --- a/src/Model/GroundWaterFlow/gwf3drn8.f90 +++ b/src/Model/GroundWaterFlow/gwf3drn8.f90 @@ -1,14 +1,12 @@ module DrnModule - use KindModule, only: DP, I4B, LGP + use KindModule, only: DP, I4B use ConstantsModule, only: DZERO, DONE, DTWO, & - LENFTYPE, LENPACKAGENAME, LENAUXNAME, LINELENGTH, & - LENMEMPATH, LENVARNAME, LENMEMSEPARATOR - use MemoryHelperModule, only: create_mem_path, split_mem_address + LENFTYPE, LENPACKAGENAME, LENAUXNAME, LINELENGTH + use MemoryHelperModule, only: create_mem_path use SmoothingModule, only: sQSaturation, sQSaturationDerivative, & sQuadraticSaturation use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor - use TdisModule, only: delt, totimc use TimeSeriesLinkModule, only: TimeSeriesLinkType, & GetTimeSeriesLinkFromList use MatrixBaseModule @@ -21,7 +19,6 @@ module DrnModule ! character(len=LENFTYPE) :: ftype = 'DRN' character(len=LENPACKAGENAME) :: text = ' DRN' - character(len=LENMEMSEPARATOR), parameter :: memPathSeparator = '/' ! type, extends(BndType) :: DrnType @@ -31,7 +28,6 @@ module DrnModule contains procedure :: allocate_scalars => drn_allocate_scalars procedure :: bnd_options => drn_options - procedure :: bnd_ad => drn_ad procedure :: bnd_ck => drn_ck procedure :: bnd_cf => drn_cf procedure :: bnd_fc => drn_fc @@ -68,10 +64,6 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) character(len=*), intent(in) :: pakname ! -- local type(DrnType), pointer :: drnobj - character(len=LENMEMPATH) :: vscpath !< if vsc exist, this is path name - character(len=LENMEMPATH) :: locmempath !< the memory path for the model - character(len=LENVARNAME) :: locvarname !< the package name to check on - logical(LGP) :: vscexists !< flag will be true if vsc is active ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables @@ -97,47 +89,10 @@ subroutine drn_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%iscloc = 2 !sfac applies to conductance packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! - ! -- check if vsc package exists and set flag if so - vscpath = trim(namemodel)//memPathSeparator//'VSC' - call split_mem_address(vscpath, locmempath, locvarname, vscexists) - if (vscexists) then - packobj%ivsc = 1 - end if - ! ! -- return return end subroutine drn_create - !> @ brief Advance the drain boundary package - !! - !! Advance data in the drain boundary package. Overides the bnd_ad() - !! routine in the bndType parent class. The method advances time - !! series and observation data as well as updates the user-specified - !! conductance based on changes in viscosity when water enters from - !! the boundary - !< - subroutine drn_ad(this) - ! -- dummy variables - class(DrnType) :: this !< DrnType object - ! -- local variables - real(DP) :: begintime, endtime - ! - ! -- Initialize time variables - begintime = totimc - endtime = begintime + delt - ! - ! -- Advance the time series managers - call this%TsManager%ad() - call this%TasManager%ad() - ! - ! -- For each observation, push simulated value and corresponding - ! simulation time from "current" to "preceding" and reset - ! "current" value. - call this%obs%obs_ad() - ! - return - end subroutine drn_ad - subroutine drn_da(this) ! ****************************************************************************** ! drn_da -- deallocate diff --git a/src/Model/GroundWaterFlow/gwf3riv8.f90 b/src/Model/GroundWaterFlow/gwf3riv8.f90 index 36fda9c4fad..8feffb43f43 100644 --- a/src/Model/GroundWaterFlow/gwf3riv8.f90 +++ b/src/Model/GroundWaterFlow/gwf3riv8.f90 @@ -1,8 +1,7 @@ module rivmodule - use KindModule, only: DP, I4B, LGP - use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME, LENMEMPATH, & - LENVARNAME, LENMEMSEPARATOR - use MemoryHelperModule, only: create_mem_path, split_mem_address + use KindModule, only: DP, I4B + use ConstantsModule, only: DZERO, LENFTYPE, LENPACKAGENAME + use MemoryHelperModule, only: create_mem_path use BndModule, only: BndType use ObsModule, only: DefaultObsIdProcessor use TimeSeriesLinkModule, only: TimeSeriesLinkType, & @@ -17,7 +16,6 @@ module rivmodule ! character(len=LENFTYPE) :: ftype = 'RIV' character(len=LENPACKAGENAME) :: text = ' RIV' - character(len=LENMEMSEPARATOR), parameter :: memPathSeparator = '/' ! type, extends(BndType) :: RivType contains @@ -54,10 +52,6 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) character(len=*), intent(in) :: pakname ! -- local type(RivType), pointer :: rivobj - character(len=LENMEMPATH) :: vscpath !< if vsc exist, this is path name - character(len=LENMEMPATH) :: locmempath !< the memory path for the model - character(len=LENVARNAME) :: locvarname !< the package name to check on - logical(LGP) :: vscexists !< flag will be true if vsc is active ! ------------------------------------------------------------------------------ ! ! -- allocate the object and assign values to object variables @@ -82,13 +76,6 @@ subroutine riv_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname) packobj%iscloc = 2 !sfac applies to conductance packobj%ictMemPath = create_mem_path(namemodel, 'NPF') ! - ! -- check if vsc package exists and set flag if so - vscpath = trim(namemodel)//memPathSeparator//'VSC' - call split_mem_address(vscpath, locmempath, locvarname, vscexists) - if (vscexists) then - packobj%ivsc = 1 - end if - ! ! -- return return end subroutine riv_create From 3a81ef6910f6eb4b86d07f53887a2886e6c35dd0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 15 Jun 2023 12:19:11 -0700 Subject: [PATCH 191/212] Another unecessary change, restoring --- src/Solution/NumericalSolution.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Solution/NumericalSolution.f90 b/src/Solution/NumericalSolution.f90 index d492cccd452..83682cfdc4c 100644 --- a/src/Solution/NumericalSolution.f90 +++ b/src/Solution/NumericalSolution.f90 @@ -2547,7 +2547,7 @@ subroutine sln_ls(this, kiter, kstp, kper, in_iter, iptc, ptcf) ! to enable set itestmat to 1 and recompile !------------------------------------------------------- itestmat = 0 - if (itestmat == 1 .and. this%id == 2) then + if (itestmat == 1) then write (fname, fmtfname) this%id, kper, kstp, kiter print *, 'Saving amat to: ', trim(adjustl(fname)) From e2a5185aa5889174766f7189a94d9aba060bd33c Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 15 Jun 2023 14:43:28 -0700 Subject: [PATCH 192/212] Minor clean-up --- src/Model/TransportModel/tsp1.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 05df744dbfd..4ab43875032 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -17,8 +17,6 @@ module TransportModelModule use NumericalPackageModule, only: NumericalPackageType use TspLabelsModule, only: TspLabelsType use BndModule, only: BndType, GetBndFromList - use GwtMstModule, only: GwtMstType - use GweMstModule, only: GweMstType use TspIcModule, only: TspIcType use TspFmiModule, only: TspFmiType use TspAdvModule, only: TspAdvType From ca33cb84e32b4487a042ea06c993712c39e07b25 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 16 Jun 2023 15:09:06 -0700 Subject: [PATCH 193/212] Inconsequential --- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/TransportModel/tsp1.f90 | 34 +++++++++++++------------ 2 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index f7aebba9b21..ed09bfbcf9a 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -101,7 +101,7 @@ subroutine gwt_cr(filename, id, modelname) ! -- Call parent class routine call this%tsp_cr(filename, id, modelname, 'GWT', indis) ! - ! -- create model packages + ! -- Create model packages call this%create_gwt_specific_packages(indis) ! ! -- Return diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 4ab43875032..496255367fa 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -38,22 +38,22 @@ module TransportModelModule type, extends(NumericalModelType) :: TransportModelType ! Generalized transport package types common to either GWT or GWE - type(TspAdvType), pointer :: adv => null() ! advection package - type(TspFmiType), pointer :: fmi => null() ! flow model interface - type(TspIcType), pointer :: ic => null() ! initial conditions package - type(TspMvtType), pointer :: mvt => null() ! mover transport package - type(TspObsType), pointer :: obs => null() ! observation package - type(TspOcType), pointer :: oc => null() ! output control package - type(TspSsmType), pointer :: ssm => null() ! source sink mixing package - type(TspLabelsType), pointer :: tsplab => null() ! object defining the appropriate labels - type(BudgetType), pointer :: budget => null() ! budget object - integer(I4B), pointer :: inic => null() ! unit number IC - integer(I4B), pointer :: infmi => null() ! unit number FMI - integer(I4B), pointer :: inmvt => null() ! unit number MVT - integer(I4B), pointer :: inadv => null() ! unit number ADV - integer(I4B), pointer :: inssm => null() ! unit number SSM - integer(I4B), pointer :: inoc => null() ! unit number OC - integer(I4B), pointer :: inobs => null() ! unit number OBS + type(TspAdvType), pointer :: adv => null() !< advection package + type(TspFmiType), pointer :: fmi => null() !< flow model interface + type(TspIcType), pointer :: ic => null() !< initial conditions package + type(TspMvtType), pointer :: mvt => null() !< mover transport package + type(TspObsType), pointer :: obs => null() !< observation package + type(TspOcType), pointer :: oc => null() !< output control package + type(TspSsmType), pointer :: ssm => null() !< source sink mixing package + type(TspLabelsType), pointer :: tsplab => null() !< object defining the appropriate labels + type(BudgetType), pointer :: budget => null() !< budget object + integer(I4B), pointer :: inic => null() !< unit number IC + integer(I4B), pointer :: infmi => null() !< unit number FMI + integer(I4B), pointer :: inmvt => null() !< unit number MVT + integer(I4B), pointer :: inadv => null() !< unit number ADV + integer(I4B), pointer :: inssm => null() !< unit number SSM + integer(I4B), pointer :: inoc => null() !< unit number OC + integer(I4B), pointer :: inobs => null() !< unit number OBS real(DP), pointer :: eqnsclfac => null() !< constant factor by which all terms in the model's governing equation are scaled (divided) for formulation and solution contains @@ -446,11 +446,13 @@ end subroutine tsp_ot_obs !! Save and print flows !< subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun, inmst) + ! -- dummy class(TransportModelType) :: this integer(I4B), intent(in) :: icbcfl integer(I4B), intent(in) :: ibudfl integer(I4B), intent(in) :: icbcun integer(I4B), intent(in) :: inmst + ! -- local class(BndType), pointer :: packobj integer(I4B) :: ip ! ------------------------------------------------------------------------------ From b138fbee3925ee68e0f24869030a133bee8aace2 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 16 Jun 2023 16:33:16 -0700 Subject: [PATCH 194/212] Friday afternoon piece of hay in a needlestack --- src/Model/GroundWaterEnergy/gwe1.f90 | 10 ++++++++++ src/Model/GroundWaterTransport/gwt1.f90 | 10 ++++++++++ src/Model/TransportModel/tsp1.f90 | 2 -- 3 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index 9b8f231eb06..b742265166c 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -571,8 +571,18 @@ subroutine gwe_ot(this) ! -- dummy class(GweModelType) :: this ! -- local + integer(I4B) :: icbcfl + integer(I4B) :: icbcun ! -- formats ! ------------------------------------------------------------------------------ + ! + ! -- Initialize + icbcfl = 0 + ! + ! -- Because mst belongs to gwt, call mst_ot_flow directly (and not from parent) + if (this%oc%oc_save('BUDGET')) icbcfl = 1 + icbcun = this%oc%oc_save_unit('BUDGET') + if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) ! ! -- Call parent class _ot routines. call this%tsp_ot(this%inmst) diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index ed09bfbcf9a..4a020d377f3 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -562,7 +562,17 @@ subroutine gwt_ot(this) ! -- dummy class(GwtModelType) :: this ! -- local + integer(I4B) :: icbcfl + integer(I4B) :: icbcun ! ------------------------------------------------------------------------------ + ! + ! -- Initialize + icbcfl = 0 + ! + ! -- Because mst belongs to gwt, call mst_ot_flow directly (and not from parent) + if (this%oc%oc_save('BUDGET')) icbcfl = 1 + icbcun = this%oc%oc_save_unit('BUDGET') + if (this%inmst > 0) call this%mst%mst_ot_flow(icbcfl, icbcun) ! ! -- Call parent class _ot routines. call this%tsp_ot(this%inmst) diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 496255367fa..3e0e810ff35 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -458,8 +458,6 @@ subroutine tsp_ot_flow(this, icbcfl, ibudfl, icbcun, inmst) ! ------------------------------------------------------------------------------ ! -- Save TSP flows call this%tsp_ot_flowja(this%nja, this%flowja, icbcfl, icbcun) - if (inmst > 0) call this%tsp_ot_flowja(this%nja, this%flowja, & - icbcfl, icbcun) if (this%infmi > 0) call this%fmi%fmi_ot_flow(icbcfl, icbcun) if (this%inssm > 0) then call this%ssm%ssm_ot_flow(icbcfl=icbcfl, ibudfl=0, icbcun=icbcun) From 7b1062f727e791efbc702158800dc688da4382c5 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 16 Jun 2023 17:06:53 -0700 Subject: [PATCH 195/212] resolve a conflict from the last merge. --- make/makefile | 138 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 84 insertions(+), 54 deletions(-) diff --git a/make/makefile b/make/makefile index 552d7c70a1d..c3eca3e9899 100644 --- a/make/makefile +++ b/make/makefile @@ -4,36 +4,38 @@ include ./makedefaults # Define the source file directories -SOURCEDIR1=../src -SOURCEDIR2=../src/Exchange -SOURCEDIR3=../src/Distributed -SOURCEDIR4=../src/Solution -SOURCEDIR5=../src/Solution/LinearMethods -SOURCEDIR6=../src/Solution/PETSc -SOURCEDIR7=../src/Timing -SOURCEDIR8=../src/Utilities -SOURCEDIR9=../src/Utilities/Idm -SOURCEDIR10=../src/Utilities/Idm/selector -SOURCEDIR11=../src/Utilities/Idm/mf6blockfile -SOURCEDIR12=../src/Utilities/TimeSeries -SOURCEDIR13=../src/Utilities/Memory -SOURCEDIR14=../src/Utilities/OutputControl -SOURCEDIR15=../src/Utilities/ArrayRead -SOURCEDIR16=../src/Utilities/Libraries -SOURCEDIR17=../src/Utilities/Libraries/rcm -SOURCEDIR18=../src/Utilities/Libraries/blas -SOURCEDIR19=../src/Utilities/Libraries/sparskit2 -SOURCEDIR20=../src/Utilities/Libraries/daglib -SOURCEDIR21=../src/Utilities/Libraries/sparsekit -SOURCEDIR22=../src/Utilities/Vector -SOURCEDIR23=../src/Utilities/Matrix -SOURCEDIR24=../src/Utilities/Observation -SOURCEDIR25=../src/Model -SOURCEDIR26=../src/Model/Connection -SOURCEDIR27=../src/Model/GroundWaterTransport -SOURCEDIR28=../src/Model/ModelUtilities -SOURCEDIR29=../src/Model/GroundWaterFlow -SOURCEDIR30=../src/Model/Geometry +SOURCEDIR1=..\src +SOURCEDIR2=..\src\Distributed +SOURCEDIR3=..\src\Exchange +SOURCEDIR4=..\src\Model +SOURCEDIR5=..\src\Model\Connection +SOURCEDIR6=..\src\Model\Geometry +SOURCEDIR7=..\src\Model\GroundWaterEnergy +SOURCEDIR8=..\src\Model\GroundWaterFlow +SOURCEDIR9=..\src\Model\GroundWaterTransport +SOURCEDIR10=..\src\Model\ModelUtilities +SOURCEDIR11=..\src\Model\TransportModel +SOURCEDIR12=..\src\Solution +SOURCEDIR13=..\src\Solution\LinearMethods +SOURCEDIR14=..\src\Solution\PETSc +SOURCEDIR15=..\src\Timing +SOURCEDIR16=..\src\Utilities +SOURCEDIR17=..\src\Utilities\ArrayRead +SOURCEDIR18=..\src\Utilities\Idm +SOURCEDIR19=..\src\Utilities\Idm\mf6blockfile +SOURCEDIR20=..\src\Utilities\Idm\selector +SOURCEDIR21=..\src\Utilities\Libraries +SOURCEDIR22=..\src\Utilities\Libraries\blas +SOURCEDIR23=..\src\Utilities\Libraries\daglib +SOURCEDIR24=..\src\Utilities\Libraries\rcm +SOURCEDIR25=..\src\Utilities\Libraries\sparsekit +SOURCEDIR26=..\src\Utilities\Libraries\sparskit2 +SOURCEDIR27=..\src\Utilities\Matrix +SOURCEDIR28=..\src\Utilities\Memory +SOURCEDIR29=..\src\Utilities\Observation +SOURCEDIR30=..\src\Utilities\OutputControl +SOURCEDIR31=..\src\Utilities\TimeSeries +SOURCEDIR32=..\src\Utilities\Vector VPATH = \ ${SOURCEDIR1} \ @@ -65,7 +67,9 @@ ${SOURCEDIR26} \ ${SOURCEDIR27} \ ${SOURCEDIR28} \ ${SOURCEDIR29} \ -${SOURCEDIR30} +${SOURCEDIR30} \ +${SOURCEDIR31} \ +${SOURCEDIR32} .SUFFIXES: .f90 .F90 .o @@ -116,6 +120,7 @@ $(OBJDIR)/Observe.o \ $(OBJDIR)/TimeArraySeriesLink.o \ $(OBJDIR)/ObsUtility.o \ $(OBJDIR)/ObsContainer.o \ +$(OBJDIR)/TspLabels.o \ $(OBJDIR)/BudgetFileReader.o \ $(OBJDIR)/TimeArraySeriesManager.o \ $(OBJDIR)/PackageMover.o \ @@ -133,6 +138,7 @@ $(OBJDIR)/LinearSolverBase.o \ $(OBJDIR)/ims8reordering.o \ $(OBJDIR)/VirtualBase.o \ $(OBJDIR)/STLVecInt.o \ +$(OBJDIR)/PrintSaveManager.o \ $(OBJDIR)/InputDefinition.o \ $(OBJDIR)/SfrCrossSectionManager.o \ $(OBJDIR)/dag_module.o \ @@ -144,6 +150,10 @@ $(OBJDIR)/ims8base.o \ $(OBJDIR)/VirtualDataLists.o \ $(OBJDIR)/VirtualDataContainer.o \ $(OBJDIR)/SimStages.o \ +$(OBJDIR)/PackageBudget.o \ +$(OBJDIR)/HeadFileReader.o \ +$(OBJDIR)/OutputControlData.o \ +$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/simnamidm.o \ $(OBJDIR)/gwt1idm.o \ $(OBJDIR)/gwt1dsp1idm.o \ @@ -155,9 +165,11 @@ $(OBJDIR)/gwf3idm.o \ $(OBJDIR)/gwf3disv8idm.o \ $(OBJDIR)/gwf3disu8idm.o \ $(OBJDIR)/gwf3dis8idm.o \ -$(OBJDIR)/PackageBudget.o \ -$(OBJDIR)/HeadFileReader.o \ -$(OBJDIR)/PrintSaveManager.o \ +$(OBJDIR)/gwe1idm.o \ +$(OBJDIR)/gwe1dspidm.o \ +$(OBJDIR)/gwe1disv1idm.o \ +$(OBJDIR)/gwe1disu1idm.o \ +$(OBJDIR)/gwe1dis1idm.o \ $(OBJDIR)/Xt3dAlgorithm.o \ $(OBJDIR)/gwf3tvbase8.o \ $(OBJDIR)/gwf3sfr8.o \ @@ -175,61 +187,62 @@ $(OBJDIR)/ims8linear.o \ $(OBJDIR)/BaseSolution.o \ $(OBJDIR)/IndexMap.o \ $(OBJDIR)/VirtualModel.o \ +$(OBJDIR)/tsp1fmi1.o \ +$(OBJDIR)/GwtSpc.o \ +$(OBJDIR)/GweInputData.o \ +$(OBJDIR)/OutputControl.o \ +$(OBJDIR)/tsp1ic1.o \ +$(OBJDIR)/TspAdvOptions.o \ +$(OBJDIR)/MemoryManagerExt.o \ $(OBJDIR)/IdmSimDfnSelector.o \ $(OBJDIR)/IdmGwtDfnSelector.o \ $(OBJDIR)/IdmGwfDfnSelector.o \ +$(OBJDIR)/IdmGweDfnSelector.o \ $(OBJDIR)/UzfCellGroup.o \ -$(OBJDIR)/gwt1fmi1.o \ -$(OBJDIR)/OutputControlData.o \ -$(OBJDIR)/gwf3ic8.o \ $(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3tvk8.o \ -$(OBJDIR)/MemoryManagerExt.o \ -$(OBJDIR)/gwf3vsc8.o \ +$(OBJDIR)/gwf3vsc8_memoryMng_strings.o \ $(OBJDIR)/GwfNpfOptions.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/InterfaceMap.o \ $(OBJDIR)/CellWithNbrs.o \ +$(OBJDIR)/tsp1ssm1.o \ +$(OBJDIR)/tsp1oc1.o \ +$(OBJDIR)/tsp1obs1.o \ +$(OBJDIR)/tsp1mvt1.o \ +$(OBJDIR)/tsp1adv1.o \ +$(OBJDIR)/gwf3disv8.o \ +$(OBJDIR)/gwf3disu8.o \ +$(OBJDIR)/gwf3dis8.o \ $(OBJDIR)/IdmDfnSelector.o \ $(OBJDIR)/gwf3uzf8.o \ -$(OBJDIR)/gwt1apt1.o \ -$(OBJDIR)/GwtSpc.o \ -$(OBJDIR)/OutputControl.o \ -$(OBJDIR)/gwt1ic1.o \ +$(OBJDIR)/tsp1apt1.o \ $(OBJDIR)/gwt1mst1.o \ $(OBJDIR)/GwtDspOptions.o \ $(OBJDIR)/gwf3npf8.o \ -$(OBJDIR)/GwtAdvOptions.o \ $(OBJDIR)/gwf3tvs8.o \ $(OBJDIR)/GwfStorageUtils.o \ $(OBJDIR)/Mover.o \ $(OBJDIR)/GwfMvrPeriodData.o \ $(OBJDIR)/ims8misc.o \ $(OBJDIR)/GwfBuyInputData.o \ +$(OBJDIR)/GweDspOptions.o \ $(OBJDIR)/VirtualSolution.o \ $(OBJDIR)/ArrayReaderBase.o \ $(OBJDIR)/VirtualExchange.o \ -$(OBJDIR)/gwf3disu8.o \ $(OBJDIR)/GridSorting.o \ $(OBJDIR)/DisConnExchange.o \ $(OBJDIR)/CsrUtils.o \ -$(OBJDIR)/TransportModel.o \ +$(OBJDIR)/tsp1cnc1.o \ +$(OBJDIR)/tsp1.o \ $(OBJDIR)/ModelPackageInputs.o \ $(OBJDIR)/gwt1uzt1.o \ -$(OBJDIR)/gwt1ssm1.o \ $(OBJDIR)/gwt1src1.o \ $(OBJDIR)/gwt1sft1.o \ -$(OBJDIR)/gwt1oc1.o \ -$(OBJDIR)/gwt1obs1.o \ $(OBJDIR)/gwt1mwt1.o \ -$(OBJDIR)/gwt1mvt1.o \ $(OBJDIR)/gwt1lkt1.o \ $(OBJDIR)/gwt1ist1.o \ $(OBJDIR)/gwt1dsp1.o \ -$(OBJDIR)/gwt1cnc1.o \ -$(OBJDIR)/gwt1adv1.o \ -$(OBJDIR)/gwf3disv8.o \ -$(OBJDIR)/gwf3dis8.o \ $(OBJDIR)/gwf3api8.o \ $(OBJDIR)/gwf3wel8.o \ $(OBJDIR)/gwf3rch8.o \ @@ -243,12 +256,20 @@ $(OBJDIR)/gwf3buy8.o \ $(OBJDIR)/GhostNode.o \ $(OBJDIR)/gwf3evt8.o \ $(OBJDIR)/gwf3chd8.o \ +$(OBJDIR)/gwe1uze1.o \ +$(OBJDIR)/gwe1src1.o \ +$(OBJDIR)/gwe1sfe1.o \ +$(OBJDIR)/gwe1mwe1.o \ +$(OBJDIR)/gwe1mst1.o \ +$(OBJDIR)/gwe1lke1.o \ +$(OBJDIR)/gwe1dsp1.o \ $(OBJDIR)/RouterBase.o \ $(OBJDIR)/Integer2dReader.o \ $(OBJDIR)/GridConnection.o \ $(OBJDIR)/DistributedVariable.o \ $(OBJDIR)/gwt1.o \ $(OBJDIR)/gwf3.o \ +$(OBJDIR)/gwe1.o \ $(OBJDIR)/SerialRouter.o \ $(OBJDIR)/StructVector.o \ $(OBJDIR)/IdmLogger.o \ @@ -261,6 +282,8 @@ $(OBJDIR)/GwtInterfaceModel.o \ $(OBJDIR)/GwtGwtExchange.o \ $(OBJDIR)/GwfInterfaceModel.o \ $(OBJDIR)/GwfGwfExchange.o \ +$(OBJDIR)/GweInterfaceModel.o \ +$(OBJDIR)/GweGweExchange.o \ $(OBJDIR)/RouterFactory.o \ $(OBJDIR)/MappedMemory.o \ $(OBJDIR)/StructArray.o \ @@ -270,6 +293,7 @@ $(OBJDIR)/DefinitionSelect.o \ $(OBJDIR)/ExplicitSolution.o \ $(OBJDIR)/GwtGwtConnection.o \ $(OBJDIR)/GwfGwfConnection.o \ +$(OBJDIR)/GweGweConnection.o \ $(OBJDIR)/VirtualDataManager.o \ $(OBJDIR)/Mapper.o \ $(OBJDIR)/LoadMf6File.o \ @@ -277,9 +301,12 @@ $(OBJDIR)/VirtualGwtModel.o \ $(OBJDIR)/VirtualGwtExchange.o \ $(OBJDIR)/VirtualGwfModel.o \ $(OBJDIR)/VirtualGwfExchange.o \ +$(OBJDIR)/VirtualGweModel.o \ +$(OBJDIR)/VirtualGweExchange.o \ $(OBJDIR)/SolutionGroup.o \ $(OBJDIR)/SolutionFactory.o \ $(OBJDIR)/GwfGwtExchange.o \ +$(OBJDIR)/GwfGweExchange.o \ $(OBJDIR)/RunControl.o \ $(OBJDIR)/IdmMf6File.o \ $(OBJDIR)/SimulationCreate.o \ @@ -297,6 +324,9 @@ $(OBJDIR)/sparsekit.o \ $(OBJDIR)/rcm.o \ $(OBJDIR)/blas1_d.o \ $(OBJDIR)/Iunit.o \ +$(OBJDIR)/LatHeatVapor.o \ +$(OBJDIR)/GwtAdvOptions.o \ +$(OBJDIR)/gwf3vsc8.o \ $(OBJDIR)/RectangularGeometry.o \ $(OBJDIR)/CircularGeometry.o From 5bf187e6298c76cfa5df047dc2cf83ef50549495 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 20 Jun 2023 08:01:02 -0700 Subject: [PATCH 196/212] Amend UZT with the tsplabels class --- src/Model/GroundWaterEnergy/gwe1uze1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1uzt1.f90 | 12 +++++++++++- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1uze1.f90 b/src/Model/GroundWaterEnergy/gwe1uze1.f90 index 4f41820787a..1d30e6f32e0 100644 --- a/src/Model/GroundWaterEnergy/gwe1uze1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1uze1.f90 @@ -99,7 +99,7 @@ subroutine uze_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi - type(TspLabelsType), pointer :: tsplab + type(TspLabelsType), pointer :: tsplab !< class bearing appropriate labels depending on the transport model type real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor type(GweInputDataType), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages ! -- local diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 4a020d377f3..630ed74bc94 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -783,7 +783,7 @@ subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit, & pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('UZT6') call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & - pakname, this%fmi) + pakname, this%fmi, this%tsplab, this%eqnsclfac) case ('IST6') call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name, & pakname, this%fmi, this%mst) diff --git a/src/Model/GroundWaterTransport/gwt1uzt1.f90 b/src/Model/GroundWaterTransport/gwt1uzt1.f90 index 8e78c329243..efb547ec047 100644 --- a/src/Model/GroundWaterTransport/gwt1uzt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1uzt1.f90 @@ -35,6 +35,7 @@ module GwtUztModule use ObserveModule, only: ObserveType use TspAptModule, only: TspAptType, apt_process_obsID, & apt_process_obsID12 + use TspLabelsModule, only: TspLabelsType use MatrixBaseModule implicit none @@ -80,7 +81,7 @@ module GwtUztModule !> @brief Create a new UZT package !< subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & - fmi) + fmi, tsplab, eqnsclfac) ! -- dummy class(BndType), pointer :: packobj integer(I4B), intent(in) :: id @@ -90,6 +91,8 @@ subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & character(len=*), intent(in) :: namemodel character(len=*), intent(in) :: pakname type(TspFmiType), pointer :: fmi + type(TspLabelsType), pointer :: tsplab !< class bearing appropriate labels depending on the transport model type + real(DP), intent(in), pointer :: eqnsclfac !< governing equation scale factor ! -- local type(GwtUztType), pointer :: uztobj ! ------------------------------------------------------------------------------ @@ -120,6 +123,13 @@ subroutine uzt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, & ! the flow packages uztobj%fmi => fmi ! + ! -- Store pointer to the labels module for dynamic setting of + ! concentration vs temperature + uztobj%tsplab => tsplab + ! + ! -- Store pointer to governing equation scale factor + uztobj%eqnsclfac => eqnsclfac + ! ! -- Return return end subroutine uzt_create From b7a492373b4eedc8d8fe2b11704c9e9ade6c16f0 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 20 Jun 2023 08:44:36 -0700 Subject: [PATCH 197/212] fprettify --- src/Model/GroundWaterEnergy/gwe1.f90 | 2 +- src/Model/GroundWaterTransport/gwt1.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Model/GroundWaterEnergy/gwe1.f90 b/src/Model/GroundWaterEnergy/gwe1.f90 index b742265166c..d1b9d08ef00 100644 --- a/src/Model/GroundWaterEnergy/gwe1.f90 +++ b/src/Model/GroundWaterEnergy/gwe1.f90 @@ -578,7 +578,7 @@ subroutine gwe_ot(this) ! ! -- Initialize icbcfl = 0 - ! + ! ! -- Because mst belongs to gwt, call mst_ot_flow directly (and not from parent) if (this%oc%oc_save('BUDGET')) icbcfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') diff --git a/src/Model/GroundWaterTransport/gwt1.f90 b/src/Model/GroundWaterTransport/gwt1.f90 index 630ed74bc94..6c568230fb4 100644 --- a/src/Model/GroundWaterTransport/gwt1.f90 +++ b/src/Model/GroundWaterTransport/gwt1.f90 @@ -568,7 +568,7 @@ subroutine gwt_ot(this) ! ! -- Initialize icbcfl = 0 - ! + ! ! -- Because mst belongs to gwt, call mst_ot_flow directly (and not from parent) if (this%oc%oc_save('BUDGET')) icbcfl = 1 icbcun = this%oc%oc_save_unit('BUDGET') From 195977867f5f2e6869224e885e588e50738188c6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 20 Jun 2023 15:39:42 -0700 Subject: [PATCH 198/212] Line should not be in the makefile --- make/makefile | 1 - 1 file changed, 1 deletion(-) diff --git a/make/makefile b/make/makefile index c3eca3e9899..a5c8a208cb4 100644 --- a/make/makefile +++ b/make/makefile @@ -201,7 +201,6 @@ $(OBJDIR)/IdmGweDfnSelector.o \ $(OBJDIR)/UzfCellGroup.o \ $(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3tvk8.o \ -$(OBJDIR)/gwf3vsc8_memoryMng_strings.o \ $(OBJDIR)/GwfNpfOptions.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/InterfaceMap.o \ From 7978dfa4747c3654cddfc2dfd621d4a7de8cf2e6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 20 Jun 2023 16:34:14 -0700 Subject: [PATCH 199/212] Maybe some yet-to-be-checked-in changes to GweInterfaceModel are the issue with gfortran12 --- src/Model/Connection/GweInterfaceModel.f90 | 4 +++- src/Utilities/Budget.f90 | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Model/Connection/GweInterfaceModel.f90 b/src/Model/Connection/GweInterfaceModel.f90 index 88448761dd5..8021dfaf681 100644 --- a/src/Model/Connection/GweInterfaceModel.f90 +++ b/src/Model/Connection/GweInterfaceModel.f90 @@ -95,7 +95,8 @@ subroutine allocate_scalars(this, modelname) class(GweInterfaceModelType) :: this !< the GWE interface model character(len=*), intent(in) :: modelname !< the model name - call this%GweModelType%allocate_scalars(modelname) + call this%GweModelType%allocate_tsp_scalars(modelname) + call this%GweModelType%allocate_gwe_scalars(modelname) call mem_allocate(this%iAdvScheme, 'ADVSCHEME', this%memoryPath) call mem_allocate(this%ixt3d, 'IXT3D', this%memoryPath) @@ -228,6 +229,7 @@ subroutine gweifmod_da(this) call mem_deallocate(this%inmvt) call mem_deallocate(this%inoc) call mem_deallocate(this%inobs) + call mem_deallocate(this%eqnsclfac) ! base call this%NumericalModelType%model_da() diff --git a/src/Utilities/Budget.f90 b/src/Utilities/Budget.f90 index 3ac3b323855..a27e7f8ccdc 100644 --- a/src/Utilities/Budget.f90 +++ b/src/Utilities/Budget.f90 @@ -26,7 +26,9 @@ module BudgetModule use TspLabelsModule, only: TspLabelsType implicit none + private + public :: BudgetType public :: budget_cr public :: rate_accumulator From 416e8c83d1042d8dc19506ba5b48e6594f0c108f Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 21 Jun 2023 12:16:46 -0700 Subject: [PATCH 200/212] add another uze autotest (ran black) --- autotest/test_gwe_uze00.py | 624 +++++++++++++++++++++++++++++++++++++ 1 file changed, 624 insertions(+) create mode 100644 autotest/test_gwe_uze00.py diff --git a/autotest/test_gwe_uze00.py b/autotest/test_gwe_uze00.py new file mode 100644 index 00000000000..92cb2588c35 --- /dev/null +++ b/autotest/test_gwe_uze00.py @@ -0,0 +1,624 @@ +# +# - Outer columns not active for unsaturated zone, but are present to host +# constant head boundaries at the bottom of the model. +# +# +-------+ +# |///////| = Inactive cell +# +-------+ +# +# Model depiction: +# +# +-------+-------+-------+ +# |///////| |///////| Layer 1 +# +-------+-------+-------+ +# |///////| |///////| Layer 2 +# +-------+-------+-------+ +# |///////| |///////| Layer 3 +# +-------+-------+-------+ +# |///////| |///////| +# + -- -- + -- -- + -- -- + +# |///////| |///////| Layer x (Middle portion of model not shown) +# + -- -- + -- -- + -- -- + +# |///////| |///////| +# +-------+-------+-------+ +# | | | | Layer 99 +# +-------+-------+-------+ +# | | | | Layer 100 +# +-------+-------+-------+ + +import os + +import flopy +import numpy as np +import pytest +from framework import TestFramework +from simulation import TestSimulation + +import flopy.utils.binaryfile as bf +import math + +import matplotlib.pyplot as plt + + +# Analytical solution, from Barends (2010) Equation 5 +def temp_analyt(t, z, t0, tinfil, v, d): + if t == 0.0: + temp = t0 + else: + denom = 2.0 * math.sqrt(d * t) + ztermm = (z - v * t) / denom + ztermp = (z + v * t) / denom + vterm = v * z / d + if vterm < 100.0: + # might need to adjust this limit + temp = t0 + 0.5 * (tinfil - t0) * ( + math.erfc(ztermm) + math.exp(vterm) * math.erfc(ztermp) + ) + else: + zeta = 1.0 / (1.0 + 0.47047 * ztermp) + polyterm = zeta * ( + 0.3480242 + zeta * (-0.0958798 + zeta * 0.7478556) + ) + temp = t0 + 0.5 * (tinfil - t0) * ( + math.erfc(ztermm) + math.exp(vterm - ztermp**2) * polyterm + ) + return temp + + +# Model units +length_units = "meters" +time_units = "days" + +nlay, nrow, ncol = 101, 1, 3 +nper = 2 +perlen = [1.0e9, 100.0] +nstp = [1, 100] +tsmult = len(perlen) * [1.0] + +delr = 1.0 +delc = 1.0 +delz = 0.1 # 10 cm +strt = 0.05 +top = 10.0005 +botm = [ + 9.9995 +] # Top layer is very thin for application of the boundary condition +for i in np.arange(1, nlay): + bot = 10.0 - (i * delz) + botm.append(round(bot, 1)) + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-9, 1e-3, 0.97 +steady = {0: False, 1: False} +transient = {0: True, 1: True} + +idomain_u = [0, 1, 0] +idomain_l = [1, 1, 1] +idomain = [] +for i in np.arange(nlay): + if i < 99: + idomain.append(idomain_u) + else: + idomain.append(idomain_l) + +idomain = np.array(idomain) + +strt_temp = 10.0 +scheme = "UPSTREAM" +dispersivity = 0.0 +prsity = 0.2 + +# transient uzf info +# iuzno cellid landflg ivertcn surfdp vks thtr thts thti eps [bndnm] +uzf_pkdat = [[0, (0, 0, 1), 1, 1, 0.00001, 1, 0.0001, 0.20, 0.055, 4]] + +# Continue building the UZF list of objects +for iuzno in np.arange(1, 101, 1): + if iuzno < 99: + ivertconn = iuzno + 1 + else: + ivertconn = -1 + + uzf_pkdat.append( + [iuzno, (iuzno, 0, 1), 0, ivertconn, 0.01, 1, 0.0001, 0.20, 0.055, 4] + ) + +iuz_cell_dict = {} +cell_iuz_dict = {} +for i, itm in enumerate(uzf_pkdat): + iuz_cell_dict.update({itm[0]: (itm[1][0], itm[1][1], itm[1][2])}) + cell_iuz_dict.update({(itm[1][0], itm[1][1], itm[1][2]): itm[0]}) + +finf = 0.01 +extdp = 0.0 +pet = 0.0 +extwc = 0.0 +zero = 0.0 +uzf_spd = { + 0: [[0, finf, pet, extdp, extwc, zero, zero, zero]], + 1: [[0, finf, pet, extdp, extwc, zero, zero, zero]], +} + +ex = ["uze00"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", s)) + + +def build_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation( + sim_name=name, version="mf6", exe_name="mf6", sim_ws=ws + ) + + # create tdis package + tdis_rc = [] + for i in range(nper): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + flopy.mf6.ModflowTdis( + sim, time_units=time_units, nper=nper, perioddata=tdis_rc + ) + + gwfname = "gwf_" + name + gwename = "gwe_" + name + + newtonoptions = ["NEWTON", "UNDER_RELAXATION"] + # create gwf model + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + newtonoptions=newtonoptions, + save_flows=True, + ) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + complexity="MODERATE", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="DBD", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename=f"{gwfname}.ims", + ) + sim.register_ims_package(ims, [gwf.name]) + + flopy.mf6.ModflowGwfdis( + gwf, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=idomain, + filename=f"{gwfname}.dis", + ) + + # initial conditions + flopy.mf6.ModflowGwfic( + gwf, + strt=strt, + filename=f"{gwfname}.ic", + ) + + # node property flow + flopy.mf6.ModflowGwfnpf( + gwf, + save_flows=True, + icelltype=1, + k=100.0, + k33=10, + filename=f"{gwfname}.npf", + ) + + # aquifer storage + flopy.mf6.ModflowGwfsto( + gwf, + iconvert=1, + ss=1e-5, + sy=prsity, + steady_state=steady, + transient=transient, + filename=f"{gwfname}.sto", + ) + + # chd files + chdval = 0.05 + chdspd = {0: [[(100, 0, 0), chdval, 10.0], [(100, 0, 2), chdval, 10.0]]} + + flopy.mf6.ModflowGwfchd( + gwf, + auxiliary=["TEMPERATURE"], + print_flows=True, + stress_period_data=chdspd, + pname="CHD-1", + filename=f"{gwfname}.chd", + ) + + # Unsaturated-zone flow package + flopy.mf6.ModflowGwfuzf( + gwf, + print_flows=True, + save_flows=True, + wc_filerecord=gwfname + ".uzfwc.bin", + simulate_et=False, + simulate_gwseep=False, + linear_gwet=False, + boundnames=False, + ntrailwaves=15, + nwavesets=40, + nuzfcells=len(uzf_pkdat), + packagedata=uzf_pkdat, + perioddata=uzf_spd, + budget_filerecord=f"{gwfname}.uzf.bud", + pname="UZF-1", + filename=f"{gwfname}.uzf", + ) + + # output control + oc = flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{name}.cbc", + head_filerecord=f"{name}.hds", + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + filename=f"{gwfname}.oc", + ) + + # ---------------------------------------------------- + # Instantiating MODFLOW 6 GWE model + # ---------------------------------------------------- + gwe = flopy.mf6.ModflowGwe( + sim, modelname=gwename, model_nam_file=f"{gwename}.nam" + ) + gwe.name_file.save_flows = True + + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename), + ) + sim.register_ims_package(imsgwe, [gwe.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + nogrb=True, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=idomain, + pname="DIS", + filename=f"{gwename}.dis", + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe, + strt=strt_temp, + pname="IC", + filename=f"{gwename}.ic", + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGweadv( + gwe, scheme=scheme, pname="ADV", filename="{}.adv".format(gwename) + ) + + # Instantiating MODFLOW 6 transport dispersion package + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=False, + alh=dispersivity, + ath1=dispersivity, + ktw=0.5918 * 86400, + kts=0.2700 * 86400, + pname="DSP", + filename=f"{gwename}.dsp", + ) + + # Instantiating MODFLOW 6 transport mass storage package + rhow = 1000.0 + cpw = 4183.0 + lhv = 2500.0 + flopy.mf6.ModflowGwemst( + gwe, + save_flows=True, + porosity=prsity, + cps=760.0, + rhos=1500.0, + packagedata=[cpw, rhow, lhv], + pname="MST", + filename=f"{gwename}.mst", + ) + + # Instantiating MODFLOW 6 constant temperature boundary condition at + tmpspd = {0: [[(0, 0, 1), 10.0]], 1: [[(0, 0, 1), 20.0]]} + + flopy.mf6.ModflowGwetmp( + gwe, + save_flows=True, + print_flows=True, + stress_period_data=tmpspd, + pname="CTMP", + filename="{}.ctmp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + srctype = "AUX" + auxname = "TEMPERATURE" + pname = ["CHD-1"] + # Inpput to SSM is: + sources = [[itm, srctype, auxname] for itm in pname] + + flopy.mf6.ModflowGwessm( + gwe, + sources=sources, + pname="SSM", + filename=f"{gwename}.ssm", + ) + + # Instantiating MODFLOW 6 energy transport source-sink mixing package + uzepackagedata = [(iuz, 10.0) for iuz in range(nlay)] + uzeperioddata = { + 0: [[0, "INFILTRATION", 10.0]], + 1: [[0, "INFILTRATION", 20.0]], + } + + flopy.mf6.ModflowGweuze( + gwe, + flow_package_name="UZF-1", + boundnames=False, + save_flows=True, + print_input=True, + print_flows=True, + print_temperature=True, + temperature_filerecord=gwename + ".uze.bin", + budget_filerecord=gwename + ".uze.bud", + packagedata=uzepackagedata, + uzeperioddata=uzeperioddata, + pname="UZE-1", + filename=f"{gwename}.uze", + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe, + pname="OC", + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + filename=f"{gwename}.oc", + ) + + # Instantiate Gwf-Gwe Exchange package + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename="{}.gwfgwe".format(gwename), + ) + + return sim, None + + +def eval_flow(sim): + print("evaluating flow...") + + name = ex[sim.idxsim] + gwfname = "gwf_" + name + gwename = "gwe_" + name + ws = sim.simpath # exdirs[sim.idxsim] + + # check some output... + wc_fl = gwfname + ".uzfwc.bin" + wcobj = flopy.utils.HeadFile(os.path.join(ws, wc_fl), text="water-content") + wc = wcobj.get_alldata() + + fl2 = gwename + ".uze.bin" + + uzeobj = flopy.utils.HeadFile(os.path.join(ws, fl2), text="TEMPERATURE") + temps = uzeobj.get_alldata() + + t = np.linspace(0.0, 100.0, 101) + z = np.arange(0.05, 10.0, 0.1) + z = np.insert(z, 0, 0.0) + + t0 = 10.0 + tinfil = 20.0 + + q = finf # infiltration rate + rhos = 1500.0 + Cps = 760.0 + rhow = 1000.0 + Cpw = 4183.0 + rhowCpw = Cpw * rhow + rhosCps = Cps * rhos + + Kts = 23328.0 + Ktw = 0.0 + + steady_wc = wc[1, 0, 0, 1] + Sw = steady_wc / prsity + + rhoCp_bulk = Sw * prsity * rhowCpw + (1 - prsity) * rhosCps + Kt_bulk = Sw * prsity * Ktw + (1 - prsity) * Kts + v = rhowCpw / rhoCp_bulk * q + D = Kt_bulk / rhoCp_bulk + + # Put analytical solution in place + analytical_sln = np.zeros((len(t), len(z))) + for i, tm in enumerate(t): + for j, depth in enumerate(z): + temp = temp_analyt(tm, depth, t0, tinfil, v, D) + analytical_sln[i, j] = temp + + msg0 = ( + "Simulated solution no longer falling within" + " default tolerance where it previously did" + ) + # Compare day 1. For layer 20 and below, the defaults of allclose should work + assert np.allclose(analytical_sln[1, 19:], temps[1, 0, 0, 19:]), msg0 + # Compare day 10. For layer 39 and below, the defaults of allclose should work + assert np.allclose(analytical_sln[10, 38:], temps[10, 0, 0, 38:]), msg0 + # Compare day 50. For layer 84 and below, the defaults of allclose should work + assert np.allclose(analytical_sln[50, 83:], temps[50, 0, 0, 83:]), msg0 + # Compare day 100, fits are generally good, but do not pass allclose default settings + + # Ensure that the differences in the 1st day fall within established bounds + msg1 = ( + "Simulated fits to analytical solution are " + "falling outside established bounds on day 1" + ) + assert ( + np.max(analytical_sln[1, :18] - temps[1, 0, 0, :18]) + <= 1.5292109787949998 + ), msg1 + assert ( + np.min(analytical_sln[1, :18] - temps[1, 0, 0, :18]) + >= -0.3226087127748852 + ), msg1 + + # Ensure that the differences on day 10 fall within established bounds + msg2 = ( + "Simulated fits to analytical solution are " + "falling outside established bounds on day 10" + ) + assert ( + np.max(analytical_sln[10, :37] - temps[10, 0, 0, :37]) + <= 0.15993441015261923 + ), msg2 + assert ( + np.min(analytical_sln[10, :37] - temps[10, 0, 0, :37]) + >= -0.22298707252912387 + ), msg2 + + # Ensure that the differences on day 50 fall within established bounds + msg3 = ( + "Simulated fits to analytical solution are " + "falling outside established bounds on day 50" + ) + assert ( + np.max(analytical_sln[50, :82] - temps[50, 0, 0, :82]) + <= 0.09327747257422915 + ), msg3 + assert ( + np.min(analytical_sln[50, :82] - temps[50, 0, 0, :82]) + >= -0.21182907401427188 + ), msg3 + + # Ensure that the differences on day 50 fall within established bounds + msg3 = ( + "Simulated fits to analytical solution are " + "falling outside established bounds on day 50" + ) + assert ( + np.max(analytical_sln[50, :82] - temps[50, 0, 0, :82]) + <= 0.09327747257422915 + ), msg3 + assert ( + np.min(analytical_sln[50, :82] - temps[50, 0, 0, :82]) + >= -0.21182907401427188 + ), msg3 + + # Ensure that the differences on day 100 fall within established bounds + msg4 = ( + "Simulated fits to analytical solution are " + "falling outside established bounds on day 100" + ) + assert ( + np.max(analytical_sln[100] - temps[100]) <= 0.10680304267998154 + ), msg4 + assert ( + np.min(analytical_sln[100] - temps[100]) >= -0.20763221275394983 + ), msg4 + + # If a plot is needed for visual inspection, change 1st if statement to "True" + if False: + analytical_sln = np.zeros((len(t), len(z))) + for i, tm in enumerate(t): + for j, depth in enumerate(z): + temp = temp_analyt(tm, depth, t0, tinfil, v, D) + analytical_sln[i, j] = temp + + # first transient stress period + line1 = plt.plot( + analytical_sln[1], z, "-", color="red", label="Analytical" + ) + line2 = plt.plot( + temps[1, 0, 0], z, "-.", color="blue", label="MODFLOW 6" + ) + # 10th transient stress period + plt.plot(analytical_sln[10], z, "-", color="red") + plt.plot(temps[10, 0, 0], z, "-.", color="blue") + # 50th transient stress period + plt.plot(analytical_sln[50], z, "-", color="red") + plt.plot(temps[50, 0, 0], z, "-.", color="blue") + # last stress period + plt.plot(analytical_sln[100], z, "-", color="red") + plt.plot(temps[100, 0, 0], z, "-.", color="blue") + # add labels + plt.text(11.0, 0.85, "1 day", fontsize=10) + plt.text(12.0, 1.65, "10 days", fontsize=10) + plt.text(14.0, 2.90, "50 days", fontsize=10) + plt.text(16.0, 4.00, "100 days", fontsize=10) + + plt.gca().invert_yaxis() + plt.xlabel( + "$Temperature, C$" + ) # For latex replace with: '$Temperature, ^{\circ}C$' + plt.ylabel("$Depth, m$") + plt.minorticks_on() + plt.axhline(y=0.0) + plt.legend(loc="lower right", frameon=False) + plt.savefig(os.path.join(ws, "fit_view.png"), format="png") + + +# - No need to change any code below +@pytest.mark.parametrize( + "name", + ex, +) +def test_mf6model(name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, 0, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_flow, idxsim=0 + ), + ws, + ) From dcebbfcb9f8f30e8bb9d5d5ffd0dfcc47ae7e4d5 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 21 Jun 2023 15:21:57 -0700 Subject: [PATCH 201/212] yet another uze autotest (ran black). Also fixing sig figs in previous new autotest --- autotest/test_gwe_uze00.py | 21 +- autotest/test_gwe_uze00_flux.py | 757 ++++++++++++++++++++++++++++++++ 2 files changed, 768 insertions(+), 10 deletions(-) create mode 100644 autotest/test_gwe_uze00_flux.py diff --git a/autotest/test_gwe_uze00.py b/autotest/test_gwe_uze00.py index 92cb2588c35..587e2172a48 100644 --- a/autotest/test_gwe_uze00.py +++ b/autotest/test_gwe_uze00.py @@ -486,6 +486,7 @@ def eval_flow(sim): temp = temp_analyt(tm, depth, t0, tinfil, v, D) analytical_sln[i, j] = temp + # Run checks msg0 = ( "Simulated solution no longer falling within" " default tolerance where it previously did" @@ -505,11 +506,11 @@ def eval_flow(sim): ) assert ( np.max(analytical_sln[1, :18] - temps[1, 0, 0, :18]) - <= 1.5292109787949998 + <= 1.52921097880 ), msg1 assert ( np.min(analytical_sln[1, :18] - temps[1, 0, 0, :18]) - >= -0.3226087127748852 + >= -0.32260871278 ), msg1 # Ensure that the differences on day 10 fall within established bounds @@ -519,11 +520,11 @@ def eval_flow(sim): ) assert ( np.max(analytical_sln[10, :37] - temps[10, 0, 0, :37]) - <= 0.15993441015261923 + <= 0.15993441016 ), msg2 assert ( np.min(analytical_sln[10, :37] - temps[10, 0, 0, :37]) - >= -0.22298707252912387 + >= -0.22298707253 ), msg2 # Ensure that the differences on day 50 fall within established bounds @@ -533,11 +534,11 @@ def eval_flow(sim): ) assert ( np.max(analytical_sln[50, :82] - temps[50, 0, 0, :82]) - <= 0.09327747257422915 + <= 0.09327747258 ), msg3 assert ( np.min(analytical_sln[50, :82] - temps[50, 0, 0, :82]) - >= -0.21182907401427188 + >= -0.21182907402 ), msg3 # Ensure that the differences on day 50 fall within established bounds @@ -547,11 +548,11 @@ def eval_flow(sim): ) assert ( np.max(analytical_sln[50, :82] - temps[50, 0, 0, :82]) - <= 0.09327747257422915 + <= 0.09327747258 ), msg3 assert ( np.min(analytical_sln[50, :82] - temps[50, 0, 0, :82]) - >= -0.21182907401427188 + >= -0.21182907402 ), msg3 # Ensure that the differences on day 100 fall within established bounds @@ -560,10 +561,10 @@ def eval_flow(sim): "falling outside established bounds on day 100" ) assert ( - np.max(analytical_sln[100] - temps[100]) <= 0.10680304267998154 + np.max(analytical_sln[100] - temps[100]) <= 0.10680304268 ), msg4 assert ( - np.min(analytical_sln[100] - temps[100]) >= -0.20763221275394983 + np.min(analytical_sln[100] - temps[100]) >= -0.20763221276 ), msg4 # If a plot is needed for visual inspection, change 1st if statement to "True" diff --git a/autotest/test_gwe_uze00_flux.py b/autotest/test_gwe_uze00_flux.py new file mode 100644 index 00000000000..b1a50352f3a --- /dev/null +++ b/autotest/test_gwe_uze00_flux.py @@ -0,0 +1,757 @@ +# - Similar to test_gwe_uze00.py; however, this looks into whether the +# flux input is correct without pinning the temperature of the top-most +# cell to a specified value. +# +# - Outer columns not active for unsaturated zone, but are present to host +# constant head boundaries at the bottom of the model. +# +# +-------+ +# |///////| = Inactive cell +# +-------+ +# +# Model depiction: +# +# +-------+-------+-------+ +# |///////| |///////| Layer 1 +# +-------+-------+-------+ +# |///////| |///////| Layer 2 +# +-------+-------+-------+ +# |///////| |///////| Layer 3 +# +-------+-------+-------+ +# |///////| |///////| +# + -- -- + -- -- + -- -- + +# |///////| |///////| Layer x (Middle portion of model not shown) +# + -- -- + -- -- + -- -- + +# |///////| |///////| +# +-------+-------+-------+ +# | | | | Layer 99 +# +-------+-------+-------+ +# | | | | Layer 100 +# +-------+-------+-------+ + +import os + +import flopy +import numpy as np +import pytest +import math + +import flopy.utils.binaryfile as bf +from framework import TestFramework +from simulation import TestSimulation + + +# Analytical solution derived by Alden, similar in form to +# Barends (2010) Equation 5 - but remember that that solution +# pins the temperature of the top cell to a specified temperature +def flux_analyt(t, z, qt0, qtinfil, v, d): + if t == 0.0: + flux = qt0 + else: + denom = 2.0 * math.sqrt(d * t) + ztermm = (z - v * t) / denom + ztermp = (z + v * t) / denom + vterm = v * z / d + if vterm < 100.0: + # might need to adjust this limit + flux = qt0 + (qtinfil - qt0) * 0.5 * ( + math.erfc(ztermm) + math.exp(vterm) * math.erfc(ztermp) + ) + else: + zeta = 1.0 / (1.0 + 0.47047 * ztermp) + polyterm = zeta * ( + 0.3480242 + zeta * (-0.0958798 + zeta * 0.7478556) + ) + flux = qt0 + 0.5 * (qtinfil - qt0) * ( + math.erfc(ztermm) + math.exp(vterm - ztermp**2) * polyterm + ) + return flux + + +def temp_analyt(t, z, t0, tinfil, v, d): + if t == 0.0: + temp = t0 + else: + denom = 2.0 * math.sqrt(d * t) + ztermm = (z - v * t) / denom + ztermp = (z + v * t) / denom + vterm = v * z / d + if vterm < 100.0: + # might need to adjust this limit + temp = t0 + 0.5 * (tinfil - t0) * ( + math.erfc(ztermm) + math.exp(vterm) * math.erfc(ztermp) + ) + else: + zeta = 1.0 / (1.0 + 0.47047 * ztermp) + polyterm = zeta * ( + 0.3480242 + zeta * (-0.0958798 + zeta * 0.7478556) + ) + temp = t0 + 0.5 * (tinfil - t0) * ( + math.erfc(ztermm) + math.exp(vterm - ztermp**2) * polyterm + ) + return temp + + +# Model units +length_units = "meters" +time_units = "days" + +nlay, nrow, ncol = 101, 1, 3 +nper = 2 +perlen = [1.0e9, 100.0] +nstp = [1, 100] +tsmult = len(perlen) * [1.0] + +delr = 1.0 +delc = 1.0 +delz = 0.1 # 10 cm +strt = 0.05 +top = 10.0005 +botm = [ + 9.9995 +] # Top layer is very thin for application of the boundary condition +for i in np.arange(1, nlay): + bot = 10.0 - (i * delz) + botm.append(round(bot, 1)) + +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-9, 1e-3, 0.97 +steady = {0: False, 1: False} +transient = {0: True, 1: True} + +idomain_u = [0, 1, 0] +idomain_l = [1, 1, 1] +idomain = [] +for i in np.arange(nlay): + if i < 99: + idomain.append(idomain_u) + else: + idomain.append(idomain_l) + +idomain = np.array(idomain) + +strt_temp = 10.0 +scheme = "UPSTREAM" +dispersivity = 0.0 +prsity = 0.2 + +# transient uzf info +# iuzno cellid landflg ivertcn surfdp vks thtr thts thti eps [bndnm] +uzf_pkdat = [[0, (0, 0, 1), 1, 1, 0.00001, 1, 0.0001, 0.20, 0.055, 4]] + +# Continue building the UZF list of objects +for iuzno in np.arange(1, 101, 1): + if iuzno < nlay - 1: + ivertconn = iuzno + 1 + else: + ivertconn = -1 + + uzf_pkdat.append( + [iuzno, (iuzno, 0, 1), 0, ivertconn, 0.01, 1, 0.0001, 0.20, 0.055, 4] + ) + +iuz_cell_dict = {} +cell_iuz_dict = {} +for i, itm in enumerate(uzf_pkdat): + iuz_cell_dict.update({itm[0]: (itm[1][0], itm[1][1], itm[1][2])}) + cell_iuz_dict.update({(itm[1][0], itm[1][1], itm[1][2]): itm[0]}) + +finf = 0.01 +extdp = 0.0 +pet = 0.0 +extwc = 0.0 +zero = 0.0 +uzf_spd = { + 0: [[0, finf, pet, extdp, extwc, zero, zero, zero]], + 1: [[0, finf, pet, extdp, extwc, zero, zero, zero]], +} + +ex = ["uze00_flux"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", s)) + + +def build_model(idx, dir): + name = ex[idx] + + # build MODFLOW 6 files + ws = dir + sim = flopy.mf6.MFSimulation( + sim_name=name, version="mf6", exe_name="mf6", sim_ws=ws + ) + + # create tdis package + tdis_rc = [] + for i in range(nper): + tdis_rc.append((perlen[i], nstp[i], tsmult[i])) + + flopy.mf6.ModflowTdis( + sim, time_units=time_units, nper=nper, perioddata=tdis_rc + ) + + gwfname = "gwf_" + name + gwename = "gwe_" + name + + newtonoptions = ["NEWTON", "UNDER_RELAXATION"] + # create gwf model + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + newtonoptions=newtonoptions, + save_flows=True, + ) + + # create iterative model solution and register the gwf model with it + ims = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + complexity="MODERATE", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="DBD", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename=f"{gwfname}.ims", + ) + sim.register_ims_package(ims, [gwf.name]) + + flopy.mf6.ModflowGwfdis( + gwf, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=idomain, + filename=f"{gwfname}.dis", + ) + + # initial conditions + flopy.mf6.ModflowGwfic( + gwf, + strt=strt, + filename=f"{gwfname}.ic", + ) + + # node property flow + flopy.mf6.ModflowGwfnpf( + gwf, + save_flows=True, + icelltype=1, + k=100.0, + k33=10, + filename=f"{gwfname}.npf", + ) + + # aquifer storage + flopy.mf6.ModflowGwfsto( + gwf, + iconvert=1, + ss=1e-5, + sy=prsity, + steady_state=steady, + transient=transient, + filename=f"{gwfname}.sto", + ) + + # chd files + chdval = 0.05 + chdspd = {0: [[(100, 0, 0), chdval, 10.0], [(100, 0, 2), chdval, 10.0]]} + + flopy.mf6.ModflowGwfchd( + gwf, + auxiliary=["TEMPERATURE"], + print_flows=True, + stress_period_data=chdspd, + pname="CHD-1", + filename=f"{gwfname}.chd", + ) + + # Unsaturated-zone flow package + flopy.mf6.ModflowGwfuzf( + gwf, + print_flows=True, + save_flows=True, + wc_filerecord=gwfname + ".uzfwc.bin", + simulate_et=False, + simulate_gwseep=False, + linear_gwet=False, + boundnames=False, + ntrailwaves=15, + nwavesets=40, + nuzfcells=len(uzf_pkdat), + packagedata=uzf_pkdat, + perioddata=uzf_spd, + budget_filerecord=f"{gwfname}.uzf.bud", + pname="UZF-1", + filename=f"{gwfname}.uzf", + ) + + # output control + oc = flopy.mf6.ModflowGwfoc( + gwf, + budget_filerecord=f"{name}.cbc", + head_filerecord=f"{name}.hds", + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + filename=f"{gwfname}.oc", + ) + + # ---------------------------------------------------- + # Instantiating MODFLOW 6 GWE model + # ---------------------------------------------------- + gwe = flopy.mf6.ModflowGwe( + sim, modelname=gwename, model_nam_file=f"{gwename}.nam" + ) + gwe.name_file.save_flows = True + + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename), + ) + sim.register_ims_package(imsgwe, [gwe.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + nogrb=True, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=idomain, + pname="DIS", + filename=f"{gwename}.dis", + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe, + strt=strt_temp, + pname="IC", + filename=f"{gwename}.ic", + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGweadv( + gwe, scheme=scheme, pname="ADV", filename="{}.adv".format(gwename) + ) + + # Instantiating MODFLOW 6 transport dispersion package + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=False, + alh=dispersivity, + ath1=dispersivity, + ktw=0.5918 * 86400, + kts=0.2700 * 86400, + pname="DSP", + filename=f"{gwename}.dsp", + ) + + # Instantiating MODFLOW 6 transport mass storage package + rhow = 1000.0 + cpw = 4183.0 + lhv = 2500.0 + flopy.mf6.ModflowGwemst( + gwe, + save_flows=True, + porosity=prsity, + cps=760.0, + rhos=1500.0, + packagedata=[cpw, rhow, lhv], + pname="MST", + filename=f"{gwename}.mst", + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + srctype = "AUX" + auxname = "TEMPERATURE" + pname = ["CHD-1"] + # Inpput to SSM is: + sources = [[itm, srctype, auxname] for itm in pname] + + flopy.mf6.ModflowGwessm( + gwe, + sources=sources, + pname="SSM", + filename=f"{gwename}.ssm", + ) + + # Instantiating MODFLOW 6 energy transport source-sink mixing package + uzepackagedata = [(iuz, 10.0) for iuz in range(nlay)] + uzeperioddata = { + 0: [[0, "INFILTRATION", 10.0]], + 1: [[0, "INFILTRATION", 20.0]], + } + + flopy.mf6.ModflowGweuze( + gwe, + flow_package_name="UZF-1", + boundnames=False, + save_flows=True, + print_input=True, + print_flows=True, + print_temperature=True, + temperature_filerecord=gwename + ".uze.bin", + budget_filerecord=gwename + ".uze.bud", + packagedata=uzepackagedata, + uzeperioddata=uzeperioddata, + pname="UZE-1", + filename=f"{gwename}.uze", + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe, + pname="OC", + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + filename=f"{gwename}.oc", + ) + + # Instantiate Gwf-Gwe Exchange package + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + filename="{}.gwfgwe".format(gwename), + ) + + return sim, None + + +def eval_results(sim): + print("evaluating flow...") + + name = ex[sim.idxsim] + gwfname = "gwf_" + name + gwename = "gwe_" + name + ws = sim.simpath # exdirs[sim.idxsim] + + # check some output... + wc_fl = gwfname + ".uzfwc.bin" + wcobj = flopy.utils.HeadFile(os.path.join(ws, wc_fl), text="water-content") + wc = wcobj.get_alldata() + + # temperature output + fl2 = gwename + ".uze.bin" + uzeobj = flopy.utils.HeadFile(os.path.join(ws, fl2), text="TEMPERATURE") + temps = uzeobj.get_alldata() + + # Cell flows output + qfile = gwename + ".cbc" + gweflowsobj = flopy.utils.CellBudgetFile(os.path.join(ws, qfile)) + + # Binary grid file needed for post-processing + fgrb = gwfname + ".dis.grb" + grb_file = os.path.join(ws, fgrb) + + # UZE flows + fuzebud = gwename + ".uze.bud" + uzeflowsobj = flopy.utils.CellBudgetFile(os.path.join(ws, fuzebud)) + flowsadv = uzeflowsobj.get_data(text="FLOW-JA-FACE") + + t = np.linspace(0.0, 100.0, 101) + z = np.linspace(0.0, 9.9, 99) + + q = finf # infiltration rate + area = delr * delc + rhos = 1500.0 + Cps = 760.0 + rhow = 1000.0 + Cpw = 4183.0 + rhowCpw = Cpw * rhow + rhosCps = Cps * rhos + + Kts = 23328.0 + Ktw = 0.0 + + steady_wc = wc[1, 0, 0, 1] + Sw = steady_wc / prsity + + rhoCp_bulk = Sw * prsity * rhowCpw + (1 - prsity) * rhosCps + Kt_bulk = Sw * prsity * Ktw + (1 - prsity) * Kts + v = rhowCpw / rhoCp_bulk * q + D = Kt_bulk / rhoCp_bulk + + t0 = 10.0 + tinfil = 20.0 + qt0 = q * t0 + qtinfil = q * tinfil + + # for converting from J/day to W + unitadj = 1 / 86400 + + # Get analytical solution + conv10 = [] + cond10 = [] + conv50 = [] + cond50 = [] + conv100 = [] + cond100 = [] + analytical_sln = np.zeros((len(t), len(z))) + simulated_sln = np.zeros((len(t), len(z))) + for i, tm in enumerate(t): + if i == 0: + gweflowjaface = gweflowsobj.get_data( + text="FLOW-JA-FACE", kstpkper=(0, 0) + ) + else: + gweflowjaface = gweflowsobj.get_data( + text="FLOW-JA-FACE", kstpkper=(i - 1, 1) + ) + flowscond = flopy.mf6.utils.postprocessing.get_structured_faceflows( + gweflowjaface[0][0], grb_file=grb_file + ) + for j, depth in enumerate(z): + fluxa = flux_analyt(tm, depth, qt0, qtinfil, v, D) + analytical_sln[i, j] = fluxa * rhowCpw * unitadj + + (uze1, uze2, floadv) = flowsadv[i][2 * j + 1] + (fjunk1, flocond, fjunk2) = flowscond[1][j][0] + flo = floadv * rhowCpw * unitadj + flocond * rhowCpw * unitadj + if i == 10: + conv10.append(floadv * rhowCpw * unitadj) + cond10.append(flocond * rhowCpw * unitadj) + elif i == 50: + conv50.append(floadv * rhowCpw * unitadj) + cond50.append(flocond * rhowCpw * unitadj) + elif i == 100: + conv100.append(floadv * rhowCpw * unitadj) + cond100.append(flocond * rhowCpw * unitadj) + + flux = flo / area + simulated_sln[i, j] = flux + + # Run checks + msg0 = ( + "Simulated solution has deviated too far from the analytical solution" + ) + # Following values are calculated as "percent differences" when determining if fits are acceptable + # Day 10 + assert ( + np.max( + ((analytical_sln[10] * rhowCpw) - simulated_sln[10]) + / (analytical_sln[10] * rhowCpw) + * 100 + ) + <= 0.51091366512 + ), msg0 + assert ( + np.min( + ((analytical_sln[10] * rhowCpw) - simulated_sln[10]) + / (analytical_sln[10] * rhowCpw) + * 100 + ) + >= -2.62119104308 + ), msg0 + + # Day 50 + assert ( + np.max( + ((analytical_sln[50] * rhowCpw) - simulated_sln[50]) + / (analytical_sln[50] * rhowCpw) + * 100 + ) + <= 0.317103470187 + ), msg0 + assert ( + np.min( + ((analytical_sln[50] * rhowCpw) - simulated_sln[50]) + / (analytical_sln[50] * rhowCpw) + * 100 + ) + >= -2.52020856407 + ), msg0 + + # Day 100 + assert ( + np.max( + ((analytical_sln[100] * rhowCpw) - simulated_sln[100]) + / (analytical_sln[100] * rhowCpw) + * 100 + ) + <= 0.37655443170 + ), msg0 + assert ( + np.min( + ((analytical_sln[100] * rhowCpw) - simulated_sln[100]) + / (analytical_sln[100] * rhowCpw) + * 100 + ) + >= -2.56004275225 + ), msg0 + + # If plot is needed, change next statement to "if True:" + if False: + import matplotlib.pyplot as plt + from matplotlib import transforms + from matplotlib.collections import PathCollection + from matplotlib.patches import Patch + from matplotlib.lines import Line2D + + fig, (ax1, ax2, ax3) = plt.subplots(ncols=3, figsize=(10, 5)) + # 10 days + # ------- + polys1 = ax1.stackplot( + z, + conv10, + cond10, + labels=["Convection", "Conduction"], + colors=["lightseagreen", "lightgreen"], + ) + ax1.set_xlim((-0.05, 10.05)) + xlims = ax1.get_xlim() + for poly in polys1: + for path in poly.get_paths(): + path.vertices = path.vertices[:, ::-1] + ax1.set_xlim(0.095 * rhowCpw * unitadj, 0.205 * rhowCpw * unitadj) + ax1.set_ylim(xlims[::-1]) + ax1.plot(simulated_sln[10], z, "-", color="blue", linewidth=1) + ax1.plot(analytical_sln[10], z, "-.", color="red") + ax1.text(4.9, 0.4, "10 Days") + + legend_elements = [ + Line2D( + [0], + [0], + linestyle="-", + color="blue", + lw=1, + label="MODFLOW 6 Total Heat Flux", + ), + Line2D( + [0], [0], linestyle="-.", color="red", lw=1, label="Analytical" + ), + Patch( + facecolor="lightseagreen", + edgecolor="lightseagreen", + label="Convection", + ), + Patch( + facecolor="lightgreen", + edgecolor="lightgreen", + label="Conduction", + ), + ] + + ax1.legend(handles=legend_elements, loc="lower right", frameon=False) + ax1.set_xlabel("Energy Flux, $\dfrac{Watts}{m^2}$") + ax1.set_ylabel("Depth, m") + + # 50 days + # ------- + polys2 = ax2.stackplot( + z, + conv50, + cond50, + labels=["Convection", "Conduction"], + colors=["lightseagreen", "lightgreen"], + ) + ax2.set_xlim((-0.05, 10.05)) + xlims = ax2.get_xlim() + for poly in polys2: + for path in poly.get_paths(): + path.vertices = path.vertices[:, ::-1] + ax2.set_xlim(0.095 * rhowCpw * unitadj, 0.205 * rhowCpw * unitadj) + ax2.set_ylim(xlims[::-1]) + ax2.plot(simulated_sln[50], z, "-", color="blue", linewidth=1) + ax2.plot(analytical_sln[50], z, "-.", color="red") + ax2.set_xlabel("Energy Flux, $\dfrac{Watts}{m^2}$") + ax2.text(4.9, 0.4, "50 Days") + + # 100 days + # ------- + polys3 = ax3.stackplot( + z, + conv100, + cond100, + labels=["Convection", "Conduction"], + colors=["lightseagreen", "lightgreen"], + ) + ax3.set_xlim((-0.05, 10.05)) + xlims = ax3.get_xlim() + for poly in polys3: + for path in poly.get_paths(): + path.vertices = path.vertices[:, ::-1] + ax3.set_xlim(0.095 * rhowCpw * unitadj, 0.205 * rhowCpw * unitadj) + ax3.set_ylim(xlims[::-1]) + ax3.plot(simulated_sln[100], z, "-", color="blue", linewidth=1) + ax3.plot(analytical_sln[100], z, "-.", color="red") + ax3.set_xlabel("Energy Flux, $\dfrac{Watts}{m^2}$") + ax3.text(4.9, 0.4, "100 Days") + + plt.tight_layout() + plt.savefig(os.path.join(ws, "dual_view.png"), format="png") + + line1 = plt.plot( + analytical_sln[10], z, "-", color="red", label="Analytical" + ) + line2 = plt.plot( + simulated_sln[10], z, "-.", color="blue", label="MODFLOW 6" + ) + # 50th transient stress period + plt.plot(analytical_sln[50], z, "-", color="red") + plt.plot(simulated_sln[50], z, "-.", color="blue") + # last stress period + plt.plot(analytical_sln[100], z, "-", color="red") + plt.plot(simulated_sln[100], z, "-.", color="blue") + # add labels + plt.text(11.0, 0.85, "1 day", fontsize=10) + plt.text(12.0, 1.65, "10 days", fontsize=10) + plt.text(14.0, 2.90, "50 days", fontsize=10) + plt.text(16.0, 4.00, "100 days", fontsize=10) + + plt.gca().invert_yaxis() + plt.xlabel("$Energy Flux, -$") + plt.ylabel("$Depth, m$") + plt.minorticks_on() + plt.axhline(y=0.0) + plt.legend(loc="lower right", frameon=False) + plt.savefig(os.path.join(ws, "fit_view.png"), format="png") + + +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_results, idxsim=idx + ), + ws, + ) From cc731bca3237d1bbb9197631574842458f936e28 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Wed, 21 Jun 2023 15:32:54 -0700 Subject: [PATCH 202/212] relax tolerance(s) by 1e-10 --- autotest/test_gwe_uze00_flux.py | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/autotest/test_gwe_uze00_flux.py b/autotest/test_gwe_uze00_flux.py index b1a50352f3a..e8f6fc16c67 100644 --- a/autotest/test_gwe_uze00_flux.py +++ b/autotest/test_gwe_uze00_flux.py @@ -583,7 +583,7 @@ def eval_results(sim): / (analytical_sln[50] * rhowCpw) * 100 ) - <= 0.317103470187 + <= 0.3171034702 ), msg0 assert ( np.min( @@ -591,7 +591,7 @@ def eval_results(sim): / (analytical_sln[50] * rhowCpw) * 100 ) - >= -2.52020856407 + >= -2.52020856408 ), msg0 # Day 100 @@ -601,7 +601,7 @@ def eval_results(sim): / (analytical_sln[100] * rhowCpw) * 100 ) - <= 0.37655443170 + <= 0.37655443171 ), msg0 assert ( np.min( @@ -609,7 +609,7 @@ def eval_results(sim): / (analytical_sln[100] * rhowCpw) * 100 ) - >= -2.56004275225 + >= -2.56004275226 ), msg0 # If plot is needed, change next statement to "if True:" From daff71ec3d0a29b3197af8e244684c61b03aabc6 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 23 Jun 2023 11:48:36 -0700 Subject: [PATCH 203/212] Autotest for conduction among dry cells and a dry 'pass-thru' cell --- autotest/test_gwe_drycell_conduction0.py | 427 +++++++++++++++++++++++ 1 file changed, 427 insertions(+) create mode 100644 autotest/test_gwe_drycell_conduction0.py diff --git a/autotest/test_gwe_drycell_conduction0.py b/autotest/test_gwe_drycell_conduction0.py new file mode 100644 index 00000000000..5109e8fdb66 --- /dev/null +++ b/autotest/test_gwe_drycell_conduction0.py @@ -0,0 +1,427 @@ +# ## Test problem for GWE +# +# Test the energy "flowing" through a dry cell. The test checks for +# some of the flow-through energy being left behind and warming the +# cell it passes through. Based on the model appearing in the +# MT3D-USGS documention, pages 13-14. Dry cell is in layer 1, row 1 +# column 4. +# +# +-------+-------+-------+-------+-------+-------+ +# -> | -> | | | DRY | | | +# | | -> | | CELL| | | +# | | | -> -+-> | | | | +# +-------+-------+-------+---+---+-------+-------+ +# | | | | v | | | +# -> | -> | -> | -> | -> | -> | -> | -> +# | | | | | | | +# +-------+-------+-------+-------+-------+-------+ +# +# ---> Direction of flow ---> + +# Imports + +import os + +import numpy as np +import pytest +import flopy + +from framework import TestFramework +from simulation import TestSimulation + + +# Base simulation and model name and workspace + +scheme = "UPSTREAM" +# scheme = "TVD" + +ex = ["drycell0"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", s)) + +# Model units +length_units = "meters" +time_units = "days" + +# Table MODFLOW 6 GWE comparison to MT3DMS + +nrow = 1 +ncol = 6 +nlay = 2 +delr = 10.0 # Column width ($m$) +delc = 10.0 # Row width ($m$) +top = 20.0 # Top of model +k11 = 100.0 # Horizontal hydraulic conductivity ($m/d$) +ss = 1e-6 # Specific storage +sy = 0.20 # Specific Yield +prsity = 0.20 # Porosity +nper = 2 # Number of periods +perlen = [1, 100] # Simulation time ($days$) +nstp = [1, 10] # 10 day transient time steps +steady = {0: True, 1: False} +transient = {0: False, 1: True} + +# Set some static model parameter values + +k33 = k11 # Vertical hydraulic conductivity ($m/d$) +idomain = 1 # All cells included in the simulation +iconvert = 1 # All cells are convertible + +icelltype = 1 # Cell conversion type (>1: unconfined) + +# Set some static transport related model parameter values +botm = [] +botm.append(np.ones((nrow, ncol), dtype=float) * 10) +botm.append(np.zeros((nrow, ncol), dtype=float)) +botm = np.array(botm) + +# GWE related parameters +rhow = 1000.0 +cpw = 4183.0 +lhv = 2454.0 + +# Head input +left_hd = 15.0 +right_hd = 2.0 +strt_hd1 = np.ones((nrow, ncol), dtype=float) * 11.0 +strt_hd2 = np.ones((nrow, ncol), dtype=float) * 11.0 +strt_hd1[0] = strt_hd2[0] = left_hd +strt_hd1[-1] = strt_hd2[-1] = right_hd +strt_hd = np.array([strt_hd1, strt_hd2]) +strt_temp = 10.0 + +chd_data = {} +chd_data[0] = [ + [(0, 0, 0), left_hd], + [(1, 0, 0), left_hd], + [(1, 0, ncol - 1), right_hd], +] +chd_mf6 = chd_data + +dispersivity = 0.0 # dispersion (remember, 1D model) + +# Set solver parameter values (and related) +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-10, 1e-10, 1.0 +ttsmult = 1.0 + +# Set up temporal data used by TDIS file +tdis_rc = [] +for i in np.arange(nper): + tdis_rc.append((perlen[i], nstp[i], ttsmult)) + +# ### Generate MODFLOW 6 Example test model +# + + +def build_model(idx, dir): + # Base MF6 GWF model type + ws = dir + name = ex[idx] + + print("Building MF6 model...()".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwename1 = "gwe-" + name + + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" + ) + + # Instantiating MODFLOW 6 time discretization + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=tdis_rc, time_units=time_units + ) + + # Instantiating MODFLOW 6 groundwater flow model + gwf = flopy.mf6.ModflowGwf( + sim, + newtonoptions="UNDER_RELAXATION", + modelname=gwfname, + save_flows=True, + model_nam_file="{}.nam".format(gwfname), + ) + + # Instantiating MODFLOW 6 solver for flow model + imsgwf = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(imsgwf, [gwfname]) + + # Instantiating MODFLOW 6 discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=np.ones((nlay, nrow, ncol)), + pname="DIS-1", + filename="{}.dis".format(gwfname), + ) + + # Instantiating MODFLOW 6 storage package + flopy.mf6.ModflowGwfsto( + gwf, + ss=ss, + sy=sy, + iconvert=iconvert, + steady_state=steady, + transient=transient, + pname="STO", + filename="{}.sto".format(gwfname), + ) + + # Instantiating MODFLOW 6 node-property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_flows=True, + icelltype=icelltype, + k=k11, + k33=k33, + alternative_cell_averaging="AMT-HMK", + save_specific_discharge=True, + pname="NPF-1", + filename="{}.npf".format(gwfname), + ) + + # Instantiating MODFLOW 6 constant head package + flopy.mf6.ModflowGwfchd( + gwf, + stress_period_data=chd_mf6, + filename="{}.chd".format(gwfname), + ) + + # Instantiating MODFLOW 6 initial conditions package for flow model + flopy.mf6.ModflowGwfic(gwf, strt=strt_hd, filename="{}.ic".format(gwfname)) + + # Instantiating MODFLOW 6 output control package for flow model + flopy.mf6.ModflowGwfoc( + gwf, + pname="OC-1", + head_filerecord="{}.hds".format(gwfname), + budget_filerecord="{}.cbc".format(gwfname), + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # ---------------------------------------------------- + # Instantiating MODFLOW 6 GWE model + # ---------------------------------------------------- + gwe1 = flopy.mf6.ModflowGwe( + sim, modelname=gwename1, model_nam_file="{}.nam".format(gwename1) + ) + gwe1.name_file.save_flows = True + imsgwe1 = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename1), + ) + sim.register_ims_package(imsgwe1, [gwe1.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe1, + nogrb=True, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=1, + pname="DIS-2", + filename="{}.dis".format(gwename1), + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe1, strt=strt_temp, pname="IC-2", filename="{}.ic".format(gwename1) + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGweadv( + gwe1, scheme=scheme, pname="ADV-2", filename="{}.adv".format(gwename1) + ) + + # Instantiating MODFLOW 6 transport dispersion package + flopy.mf6.ModflowGwedsp( + gwe1, + xt3d_off=False, + alh=dispersivity, + ath1=dispersivity, + ktw=0.5918 * 86400, + # ktw=0.0, + kts=0.2700 * 86400, + # kts=0.0, + pname="DSP-2", + filename="{}.dsp".format(gwename1), + ) + + # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) + flopy.mf6.ModflowGwemst( + gwe1, + save_flows=True, + porosity=prsity, + cps=760.0, + rhos=1500.0, + packagedata=[cpw, rhow, lhv], + pname="MST-2", + filename="{}.mst".format(gwename1), + ) + + # Instantiating MODFLOW 6 heat transport source-sink mixing package + flopy.mf6.ModflowGwessm( + gwe1, sources=[[]], pname="SSM-2", filename="{}.ssm".format(gwename1) + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe1, + pname="OC-2", + budget_filerecord="{}.cbc".format(gwename1), + temperature_filerecord="{}.ucn".format(gwename1), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + ) + + # Instantiate a constant temperature in 1 of the dry cells + ctmpspd = { + 0: [[(0, 0, 0), strt_temp], [(1, 0, 0), strt_temp]], + 1: [[(0, 0, 0), strt_temp + 10], [(1, 0, 0), strt_temp + 10]], + } + flopy.mf6.ModflowGwetmp( + gwe1, + stress_period_data=ctmpspd, + pname="CTMP-2", + filename="{}.ctmp".format(gwename1), + ) + + # Instantiating MODFLOW 6 flow-transport exchange mechanism + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename1, + pname="GWFGWE1", + filename="{}.gwfgwe1".format(gwename1), + ) + + return sim, None + + +def eval_model(sim): + print("evaluating results...") + + # read transport results from GWE model + name = ex[sim.idxsim] + gwename = "gwe-" + name + + fpth = os.path.join(sim.simpath, f"{gwename}.ucn") + try: + # load temperatures + cobj = flopy.utils.HeadFile( + fpth, precision="double", text="TEMPERATURE" + ) + conc1 = cobj.get_alldata() + except: + assert False, f'could not load temperature data from "{fpth}"' + + # Check that the two perpetually dry cells: + # 1) after warming begins (2nd stress period onward), should be greater + # than their initial condition + msg0 = "There should be warming in a dry cell via conduction" + assert np.all(conc1[1:, 0, 0, 4] > 10.0), msg0 + assert np.all(conc1[1:, 0, 0, 5] > 10.0), msg0 + + msg1 = ( + "Cell at 1, 1, 5 should be warmer than the cell at 1, 1, 6 " + "throughout the simulation by virtue of it being physically " + "upstream" + ) + assert np.all(conc1[1:, 0, 0, 4] > conc1[1:, 0, 0, 5]), msg1 + + # 2) monotonically increase from being in contact with the warmer + # water passing by the cells below + msg2 = ( + "Perpetually dry cell should be steadily warming as a result of it " + "being in contact with warming cell below it." + ) + assert np.all(np.diff(conc1[:, 0, 0, 5]) > 0), msg2 + assert np.all(np.diff(conc1[:, 0, 0, 4]) > 0), msg2 + + # Because this is a steady flow problem, the largest incremental warming + # increments happen in the first two stress periods. After that, the amount + # of warming from time step to time step decreases. + msg3 = ( + "After the first two stress periods, the relative amount of " + "warming in layer 1, row 1, and column 4 should slow, but isn't" + ) + assert np.all(np.diff(np.diff(conc1[2:, 0, 0, 4])) < 0), msg3 + + # The 'pass-through' cell (layer 1, row 1, column 4 - see diagram at top + # of script) should be warming more than its two neighbors to the right. + msg4 = ( + "Pass through cell should be warming up at a higher rate than " + "the dry cells." + ) + assert np.all(conc1[:, 0, 0, 3] > conc1[:, 0, 0, 4]), msg4 + + # Pass through cell should not be as warm as the cell from which it + # receives water, since that cell will have already robbed the water + # passing through of some of its heat + msg5 = ( + "Pass through cell should not be as warm as its neighbor to " + "the left" + ) + assert np.all(conc1[:, 0, 0, 2] > conc1[:, 0, 0, 3]), msg5 + + +# - No need to change any code below +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_model, idxsim=idx + ), + ws, + ) From e9cde270d79ae9b7e8ae68f24c7cf7fb2f095c3a Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 23 Jun 2023 11:49:32 -0700 Subject: [PATCH 204/212] 2nd autotest for conduction among neighboring dry cells --- autotest/test_gwe_drycell_conduction1.py | 483 +++++++++++++++++++++++ 1 file changed, 483 insertions(+) create mode 100644 autotest/test_gwe_drycell_conduction1.py diff --git a/autotest/test_gwe_drycell_conduction1.py b/autotest/test_gwe_drycell_conduction1.py new file mode 100644 index 00000000000..78e917ec6ed --- /dev/null +++ b/autotest/test_gwe_drycell_conduction1.py @@ -0,0 +1,483 @@ +# ## Test problem for GWE +# +# Test the energy "flowing" between two dry cells via conduction +# only using a temperature gradient +# +# ~: Represents conduction +# +# A) 1st model configuration +# +# +---------+---------+ +# | |~ | +# | |~ | +# +---------+---------+ +# +# B) 2nd model configuration +# +# +---------+ +# | | +# | ~ ~ | +# +---------+ +# | | +# | | +# +---------+ +# +# C) 3rd model configuration +# +# +---------+ +# +---------+ | +# | |~ | +# | +---------+ +# +---------+ +# +# Imports + +import os +import numpy as np +import pytest +import flopy + +from framework import TestFramework +from simulation import TestSimulation + + +# Monotonicity function +def isMonotonic(A): + x, y = [], [] + x.extend(A) + y.extend(A) + x.sort() + y.sort(reverse=True) + if np.all(x == A) or np.all(y == A): + return True + return False + + +# Base simulation and model name and workspace + +scheme = "UPSTREAM" +# scheme = "TVD" + +ex = [ + "drycell2-a", # 2-cell model, horizontally connected with tops and bots aligned + "drycell2-b", # 2-cell model, vertically connected + "drycell2-c", # 2-cell model, horizontally connected with staggered alignment (reduced shared cell face area) +] + +conn_types = ( + "horizontal", + "vertical", + "staggered", +) + +dis_data = { + conn_types[0]: { + "nrow": 1, + "ncol": 2, + "nlay": 1, + "top": np.ones(2, dtype=float), + "bot": np.zeros(2, dtype=float), + "strthd": np.zeros(2, dtype=float), + }, + conn_types[1]: { + "nrow": 1, + "ncol": 1, + "nlay": 2, + "top": 2, + "bot": np.array([[[1.0]], [[0.0]]], dtype=float), + "strthd": np.zeros(2, dtype=float), + }, + conn_types[2]: { + "nrow": 2, + "ncol": 1, + "nlay": 1, + "top": np.array([[[1.0], [1.5]]], dtype=float), + "bot": np.array([[[0.0], [0.5]]], dtype=float), + "strthd": -1 * np.ones(2, dtype=float), + }, +} + +# Model units +length_units = "meters" +time_units = "days" + +# Table MODFLOW 6 GWE comparison to MT3DMS + +delr = 1.0 # Column width ($m$) +delc = 1.0 # Row width ($m$) +k11 = 1.0 # Horizontal hydraulic conductivity ($m/d$) +ss = 1e-6 # Specific storage +sy = 0.20 # Specific Yield +prsity = 0.20 # Porosity +nper = 4 # Number of periods +perlen = [1, 1000, 1, 1000] # Simulation time ($days$) +nstp = [1, 10, 1, 10] # 10 day transient time steps +steady = {0: False} +transient = {0: True} + +# Set some static model parameter values + +k33 = k11 # Vertical hydraulic conductivity ($m/d$) +idomain = 1 # All cells included in the simulation +iconvert = 1 # All cells are convertible + +icelltype = 1 # Cell conversion type (>1: unconfined) + +# Set some static transport related model parameter values +strt_temp1 = 4.0 +strt_temp2 = 34.0 +dispersivity = 0.0 # dispersion (remember, 1D model) + +# GWE related parameters +rhow = 1000.0 +cpw = 4183.0 +lhv = 2454.0 + +# Set solver parameter values (and related) +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-10, 1e-10, 1.0 +ttsmult = 1.0 + +# Set up temporal data used by TDIS file +tdis_rc = [] +for i in np.arange(nper): + tdis_rc.append((perlen[i], nstp[i], ttsmult)) + +# ### Create MODFLOW 6 GWE MT3DMS Example 1 Boundary Conditions +# +# No GWF, only Heat conduction simulated + + +def build_model(idx, dir): + conn_type = conn_types[idx] + + # Base MF6 GWF model type + ws = dir + name = ex[idx] + + print("Building MF6 model...()".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwename1 = "gwe-" + name + + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" + ) + + # Instantiating MODFLOW 6 time discretization + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=tdis_rc, time_units=time_units + ) + + # Instantiating MODFLOW 6 groundwater flow model + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + model_nam_file="{}.nam".format(gwfname), + ) + + # Instantiating MODFLOW 6 solver for flow model + imsgwf = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="CG", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(imsgwf, [gwfname]) + + # Instantiating MODFLOW 6 discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=dis_data[conn_type]["nlay"], + nrow=dis_data[conn_type]["nrow"], + ncol=dis_data[conn_type]["ncol"], + delr=delr, + delc=delc, + top=dis_data[conn_type]["top"], + botm=dis_data[conn_type]["bot"], + idomain=np.ones( + ( + dis_data[conn_type]["nlay"], + dis_data[conn_type]["nrow"], + dis_data[conn_type]["ncol"], + ), + dtype=int, + ), + pname="DIS-1", + filename="{}.dis".format(gwfname), + ) + + # Instantiating MODFLOW 6 storage package + flopy.mf6.ModflowGwfsto( + gwf, + ss=ss, + sy=sy, + iconvert=iconvert, + steady_state=steady, + transient=transient, + pname="STO", + filename="{}.sto".format(gwfname), + ) + + # Instantiating MODFLOW 6 node-property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_flows=True, + icelltype=icelltype, + k=k11, + k33=k33, + save_specific_discharge=True, + pname="NPF-1", + filename="{}.npf".format(gwfname), + ) + + # Instantiating MODFLOW 6 initial conditions package for flow model + flopy.mf6.ModflowGwfic( + gwf, + strt=dis_data[conn_type]["strthd"], + filename="{}.ic".format(gwfname), + ) + + # Instantiating MODFLOW 6 output control package for flow model + flopy.mf6.ModflowGwfoc( + gwf, + pname="OC-1", + head_filerecord="{}.hds".format(gwfname), + budget_filerecord="{}.cbc".format(gwfname), + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # ---------------------------------------------------- + # Instantiating MODFLOW 6 GWE model + # ---------------------------------------------------- + gwe1 = flopy.mf6.ModflowGwe( + sim, modelname=gwename1, model_nam_file="{}.nam".format(gwename1) + ) + gwe1.name_file.save_flows = True + imsgwe1 = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename1), + ) + sim.register_ims_package(imsgwe1, [gwe1.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe1, + nogrb=True, + nlay=dis_data[conn_type]["nlay"], + nrow=dis_data[conn_type]["nrow"], + ncol=dis_data[conn_type]["ncol"], + delr=delr, + delc=delc, + top=dis_data[conn_type]["top"], + botm=dis_data[conn_type]["bot"], + idomain=1, + pname="DIS-2", + filename="{}.dis".format(gwename1), + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe1, strt=strt_temp1, pname="IC-2", filename="{}.ic".format(gwename1) + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGweadv( + gwe1, scheme=scheme, pname="ADV-2", filename="{}.adv".format(gwename1) + ) + + # Instantiating MODFLOW 6 transport dispersion package + flopy.mf6.ModflowGwedsp( + gwe1, + xt3d_off=True, + alh=dispersivity, + ath1=dispersivity, + ktw=0.5918 * 86400, + kts=0.2700 * 86400, + pname="DSP-2", + filename="{}.dsp".format(gwename1), + ) + + # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) + flopy.mf6.ModflowGwemst( + gwe1, + save_flows=True, + porosity=prsity, + cps=760.0, + rhos=1500.0, + packagedata=[cpw, rhow, lhv], + pname="MST-2", + filename="{}.mst".format(gwename1), + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe1, + pname="OC-2", + budget_filerecord="{}.cbc".format(gwename1), + temperature_filerecord="{}.ucn".format(gwename1), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + ) + + # Instantiate a constant temperature in 1 of the dry cells + ctmpspd = { + 0: [ + [(0, 0, 0), strt_temp1], + [ + ( + dis_data[conn_type]["nlay"] - 1, + dis_data[conn_type]["nrow"] - 1, + dis_data[conn_type]["ncol"] - 1, + ), + strt_temp1 + 10, + ], + ], + 1: [], + 2: [ + [(0, 0, 0), strt_temp2], + [ + ( + dis_data[conn_type]["nlay"] - 1, + dis_data[conn_type]["nrow"] - 1, + dis_data[conn_type]["ncol"] - 1, + ), + strt_temp2 - 10, + ], + ], + 3: [], + } + flopy.mf6.ModflowGwetmp( + gwe1, + stress_period_data=ctmpspd, + pname="CTMP-2", + filename="{}.ctmp".format(gwename1), + ) + + # Instantiating MODFLOW 6 flow-transport exchange mechanism + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename1, + pname="GWFGWE1", + filename="{}.gwfgwe1".format(gwename1), + ) + + return sim, None + + +def eval_model(sim): + print("evaluating results...") + + # read transport results from GWE model + name = ex[sim.idxsim] + gwename = "gwe-" + name + + # All indices are 0 based + # initialize + idxl = 0 + idxr = 0 + idxc = 0 + # override depending on scenario + if sim.idxsim == 0: + idxc = 1 + + if sim.idxsim == 1: + idxl = 1 + + if sim.idxsim == 2: + idxr = 1 + + fpth = os.path.join(sim.simpath, f"{gwename}.ucn") + try: + # load temperatures + cobj = flopy.utils.HeadFile( + fpth, precision="double", text="TEMPERATURE" + ) + conc1 = cobj.get_alldata() + except: + assert False, f'could not load temperature data from "{fpth}"' + + # Ensure constant temperatures are initiated properly in teh 1st and 3rd + # stress periods, which are separated by period of "turning off" the + # constant temperature boundary + msg0 = "Grid cell temperatures do not reflect user-specified difference" + assert conc1[0, 0, 0, 0] + 10.0 == conc1[0, idxl, idxr, idxc], msg0 + assert conc1[11, 0, 0, 0] - 10.0 == conc1[11, idxl, idxr, idxc], msg0 + + # After running transient stress period, temperatures in grid cells + # should equilibrate through the process of conduction only (there + # is no gwf flow) + msg1 = "Grid cell temperatures should have equilabrated via conduction" + assert np.isclose(conc1[10, 0, 0, 0], conc1[10, idxl, idxr, idxc]), msg1 + assert np.isclose(conc1[21, 0, 0, 0], conc1[21, idxl, idxr, idxc]), msg1 + + # Ensure that as the cells equilibrate, they do so in a monotonic manner + msg2 = "There should be a monotonic increase as the 2 cells equilibrate" + msg3 = "There should be a monotonic decrease as the 2 cells equilibrate" + assert isMonotonic(np.diff(conc1[1:11, 0, 0, 0])), msg2 + assert isMonotonic(np.diff(conc1[1:11, idxl, idxr, idxc])), msg3 + assert isMonotonic(np.diff(conc1[12:, 0, 0, 0])), msg3 + assert isMonotonic(np.diff(conc1[12:, idxl, idxr, idxc])), msg2 + + # Ensure that the equilibrated temperature is half the starting difference between the cells + msg4 = ( + "The final equilibrated cell temperature does not split the " + "difference of the starting temperature" + ) + initTdiff1 = abs(conc1[0, 0, 0, 0] - conc1[0, idxl, idxr, idxc]) + initTdiff2 = abs(conc1[11, 0, 0, 0] - conc1[11, idxl, idxr, idxc]) + assert np.isclose( + conc1[10, 0, 0, 0], + conc1[0, 0, 0, 0] + initTdiff1 / 2, + ), msg4 + assert np.isclose( + conc1[21, 0, 0, 0], + conc1[11, 0, 0, 0] - initTdiff2 / 2, + ), msg4 + + +# - No need to change any code below +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_model, idxsim=idx + ), + ws, + ) From 13e9c558d9fe13c9e2f9a5c835605510fe517ca7 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 23 Jun 2023 16:14:22 -0700 Subject: [PATCH 205/212] These changes were made with cb11acf, that under the GWE refactor go in tsp1.f90 instead --- src/Model/TransportModel/tsp1.f90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 3e0e810ff35..4816e2a2ac4 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -678,23 +678,23 @@ subroutine ftype_check(this, indis, inmst) ! ! -- Check for IC6, DIS(u), and MST. Stop if not present. if (this%inic == 0) then - write (errmsg, '(1x,a)') & - 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.' + write (errmsg, '(a)') & + 'Initial conditions (IC6) package not specified.' call store_error(errmsg) end if if (indis == 0) then - write (errmsg, '(1x,a)') & - 'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.' + write (errmsg, '(a)') & + 'Discretization (DIS6 or DISU6) package not specified.' call store_error(errmsg) end if if (inmst == 0) then - write (errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) & - &PACKAGE NOT SPECIFIED.' + write (errmsg, '(a)') 'Mass storage and transfer (MST6) & + &package not specified.' call store_error(errmsg) end if ! if (count_errors() > 0) then - write (errmsg, '(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.' + write (errmsg, '(a)') 'Required package(s) not specified.' call store_error(errmsg) call store_error_filename(this%filename) end if From 8ab06958d0c991f12ba632c0510732b514195397 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 23 Jun 2023 16:49:03 -0700 Subject: [PATCH 206/212] These changes were made with cb11acfbut were lost in a merge conflict, reinstating --- src/Model/TransportModel/tsp1apt1.f90 | 32 +++++++++++++-------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Model/TransportModel/tsp1apt1.f90 b/src/Model/TransportModel/tsp1apt1.f90 index b867c025b7f..71bdcd5fdb0 100644 --- a/src/Model/TransportModel/tsp1apt1.f90 +++ b/src/Model/TransportModel/tsp1apt1.f90 @@ -352,8 +352,8 @@ subroutine apt_ar(this) end if end do if (this%iauxfpconc == 0) then - errmsg = 'COULD NOT FIND AUXILIARY VARIABLE '// & - trim(adjustl(this%cauxfpconc))//' IN FLOW PACKAGE '// & + errmsg = 'Could not find auxiliary variable '// & + trim(adjustl(this%cauxfpconc))//' in flow package '// & trim(adjustl(this%flowpackagename)) call store_error(errmsg) call this%parser%StoreErrorUnit() @@ -632,8 +632,8 @@ function apt_check_valid(this, itemno) result(ierr) ! ------------------------------------------------------------------------------ ierr = 0 if (itemno < 1 .or. itemno > this%ncv) then - write (errmsg, '(4x,a,1x,i6,1x,a,1x,i6)') & - '****ERROR. FEATURENO ', itemno, 'MUST BE > 0 and <= ', this%ncv + write (errmsg, '(a,1x,i6,1x,a,1x,i6)') & + 'Featureno ', itemno, 'must be > 0 and <= ', this%ncv call store_error(errmsg) ierr = 1 end if @@ -1433,14 +1433,14 @@ subroutine apt_options(this, option, found) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) this%iconcout = getunit() - call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & + call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & form, access, 'REPLACE') write (this%iout, fmtaptbin) & trim(adjustl(this%text)), trim(adjustl(this%tsplab%depvartype)), & trim(fname), this%iconcout else - write (errmsg, "('OPTIONAL', 1x, a, 1x, 'KEYWORD MUST & - &BE FOLLOWED BY FILEOUT')") this%tsplab%depvartype + write (errmsg, "('Optional', 1x, a, 1X, 'keyword must & + &be followed by FILEOUT')") this%tsplab%depvartype call store_error(errmsg) end if case ('BUDGET') @@ -1453,7 +1453,7 @@ subroutine apt_options(this, option, found) write (this%iout, fmtaptbin) trim(adjustl(this%text)), 'BUDGET', & trim(fname), this%ibudgetout else - call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT') + call store_error('Optional BUDGET keyword must be followed by FILEOUT') end if case ('BUDGETCSV') call this%parser%GetStringCaps(keyword) @@ -1465,7 +1465,7 @@ subroutine apt_options(this, option, found) write (this%iout, fmtaptbin) trim(adjustl(this%text)), 'BUDGET CSV', & trim(fname), this%ibudcsv else - call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY & + call store_error('Optional BUDGETCSV keyword must be followed by & &FILEOUT') end if case default @@ -1520,8 +1520,8 @@ subroutine apt_read_dimensions(this) ! ! -- Check for errors if (this%ncv < 0) then - write (errmsg, '(1x,a)') & - 'ERROR: NUMBER OF CONTROL VOLUMES COULD NOT BE DETERMINED CORRECTLY.' + write (errmsg, '(a)') & + 'Number of control volumes could not be determined correctly.' call store_error(errmsg) end if ! @@ -1634,8 +1634,8 @@ subroutine apt_read_cvs(this) n = this%parser%GetInteger() if (n < 1 .or. n > this%ncv) then - write (errmsg, '(4x,a,1x,i6)') & - '****ERROR. itemno MUST BE > 0 and <= ', this%ncv + write (errmsg, '(a,1x,i6)') & + 'Itemno must be > 0 and <= ', this%ncv call store_error(errmsg) cycle end if @@ -1698,11 +1698,11 @@ subroutine apt_read_cvs(this) ! -- check for duplicate or missing lakes do n = 1, this%ncv if (nboundchk(n) == 0) then - write (errmsg, '(a,1x,i0)') 'ERROR. NO DATA SPECIFIED FOR FEATURE', n + write (errmsg, '(a,1x,i0)') 'No data specified for feature', n call store_error(errmsg) else if (nboundchk(n) > 1) then write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') & - 'ERROR. DATA FOR FEATURE', n, 'SPECIFIED', nboundchk(n), 'TIMES' + 'Data for feature', n, 'specified', nboundchk(n), 'times' call store_error(errmsg) end if end do @@ -1710,7 +1710,7 @@ subroutine apt_read_cvs(this) write (this%iout, '(1x,a)') & 'END OF '//trim(adjustl(this%text))//' PACKAGEDATA' else - call store_error('ERROR. REQUIRED PACKAGEDATA BLOCK NOT FOUND.') + call store_error('Required packagedata block not found.') end if ! ! -- terminate if any errors were detected From e6d9255704a824c4e28c0d0a9fdff7a52ce72b43 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 27 Jun 2023 09:42:01 -0700 Subject: [PATCH 207/212] fprettify --- src/Model/TransportModel/tsp1apt1.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Model/TransportModel/tsp1apt1.f90 b/src/Model/TransportModel/tsp1apt1.f90 index 71bdcd5fdb0..dbb7cbffd56 100644 --- a/src/Model/TransportModel/tsp1apt1.f90 +++ b/src/Model/TransportModel/tsp1apt1.f90 @@ -1433,7 +1433,7 @@ subroutine apt_options(this, option, found) if (keyword == 'FILEOUT') then call this%parser%GetString(fname) this%iconcout = getunit() - call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & + call openfile(this%iconcout, this%iout, fname, 'DATA(BINARY)', & form, access, 'REPLACE') write (this%iout, fmtaptbin) & trim(adjustl(this%text)), trim(adjustl(this%tsplab%depvartype)), & From 7ef5f5ba3b8e59ffcaf6b0f3d32f6041631abb07 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 27 Jun 2023 09:42:35 -0700 Subject: [PATCH 208/212] Another drycell conduction-only autotest --- autotest/test_gwe_drycell_conduction2.py | 674 +++++++++++++++++++++++ 1 file changed, 674 insertions(+) create mode 100644 autotest/test_gwe_drycell_conduction2.py diff --git a/autotest/test_gwe_drycell_conduction2.py b/autotest/test_gwe_drycell_conduction2.py new file mode 100644 index 00000000000..3f91e02cdce --- /dev/null +++ b/autotest/test_gwe_drycell_conduction2.py @@ -0,0 +1,674 @@ +# ## Test problem for GWE +# +# Test conduction from a partially saturated group of cells into their dry +# neighbors. Referring to this test as a flowing trough problem. +# +# +# Profile (side) view w/ approximate water table profile shown +# +-------+-------+-------+-------+-------+-------+-------+-------+-------+-------+-------+-------+ +# |-------|_______|_______| | | | | | | | | | +# | | | |-------|_______| | | | | | | | +# | | | | | |-------|_______| | | | | | +# | | | | | | | |-------| | | | | +# | | | | | | | | |-------| | | | +# | | | | | | | | | |-------| | | +# | | | | | | | | | | |-------| | +# | | | | | | | | | | | |-------| +# | | | | | | | | | | | | | +# | | | | | | | | | | | | | +# | | | | | | | | | | | | | +# | | | | | | | | | | | | | +# +-------+-------+-------+-------+-------+-------+-------+-------+-------+-------+-------+-------+ +# +# ^ +# | +# v +# +# Profile view (all rows) +# +-------+-------+ +# | | | +# | | | <- dry cell that checked for warming owing to increasing +# | v +-------+ temperature of neighboring cell +# |-------| <- water table +# | | +# | | +# | | +# | | +# | | +# | | +# | | +# | | +# +-------+ +# +# +# Imports + +import os + +import numpy as np +import pytest +import flopy + +from framework import TestFramework +from simulation import TestSimulation + +# Base simulation and model name and workspace + + +def my_ceil(a, precision=0): + return np.round(a + 0.5 * 10 ** (-precision), precision) + + +def my_floor(a, precision=0): + return np.round(a - 0.5 * 10 ** (-precision), precision) + + +# Monotonicity function +def isMonotonic(A): + x, y = [], [] + x.extend(A) + y.extend(A) + x.sort() + y.sort(reverse=True) + if np.all(x == A) or np.all(y == A): + return True + return False + + +scheme = "UPSTREAM" +# scheme = "TVD" + +ex = ["drycl-cnduct"] +exdirs = [] +for s in ex: + exdirs.append(os.path.join("temp", s)) + +# Model units +length_units = "meters" +time_units = "days" + +# Table MODFLOW 6 GWE comparison to MT3DMS + +nlay = 1 # Number of layers +ncol = 12 # Number of columns +nrow = 2 # Number of rows +delr = 1.0 # Column width ($m$) +delc = 1.0 # Row width ($m$) +top = 10.0 # Top of the model ($m$) +k11 = 4.61426 # Horizontal hydraulic conductivity ($m/d$) +ss = 1e-6 # Specific storage +sy = 0.20 # Specific Yield +nper = 11 # Number of periods +perlen = 1 # Simulation time ($days$) +nstp = 1 # One day time steps +steady = {0: True, 1: False} +transient = {0: False, 1: True} + + +# Set some static model parameter values +k33 = k11 # Vertical hydraulic conductivity ($m/d$) +idomain = 1 # All cells included in the simulation +iconvert = 1 # All cells are convertible + +bot_r1 = np.zeros(ncol).tolist() +# This is the head solution for row 1, so round up to ensure neighboring cells remain dry +r2 = [ + 6.99850, + 6.78111, + 6.55650, + 6.32391, + 6.08242, + 5.83092, + 5.56805, + 5.29211, + 5.00092, + 4.69161, + 4.36032, + 4.00150, +] +bot_r2 = [my_ceil(val, precision=1) for val in r2] +botm = np.array([bot_r1, bot_r2]) + +strtdry = [my_floor(val, precision=2) for val in r2] +strt = np.array([strtdry, strtdry]) # Starting head ($m$) +icelltype = 1 # Cell conversion type (>1: unconfined) + +# Set some static transport related model parameter values +prsity = 0.20 # Porosity +strt_conc = np.ones((nlay, nrow, ncol), dtype=float) * 4.0 +strt_temp = np.ones((nlay, nrow, ncol), dtype=float) * 4.0 +dispersivity = 0.1 # dispersion (remember, 1D model) +cpw = 4183.0 +cps = 760.0 +rhow = 1000.0 +rhos = 1500.0 +lhv = 2454.0 +ktw = 0.5918 * 86400 +kts = 0.2700 * 86400 + +# Parameter equivalents: +# ---------------------- +# "Distribution Coefficient" +Kd = cps / (cpw * rhow) +# "Bulk Density" +rhob = (1 - prsity) * rhos +# "Molecular Diffusion" +Kt_bulk = prsity * ktw + (1 - prsity) * kts +Dm = Kt_bulk / (prsity * rhow * cpw) + +# Set solver parameter values (and related) +nouter, ninner = 100, 300 +hclose, rclose, relax = 1e-10, 1e-10, 1.0 +ttsmult = 1.0 + +# Set up temporal data used by TDIS file +tdis_rc = [] +for i in np.arange(nper): + tdis_rc.append((perlen, nstp, ttsmult)) + +# ### Create MODFLOW 6 GWE MT3DMS Example 1 Boundary Conditions +# +# Constant head cells are specified on both ends of the model + +# Scenario 1a (GHB to GHB) +ghbcond = 1000.0 +ghb_conc = 4.0 +ghb_temp = 4.0 +ghb_conc_warmup = 30.0 +ghb_temp_warmup = 30.0 +# left boundary: cellid, elv, cond, conc, temp; right bnd: cellid, elv, cond, conc, temp +ghbspd = { + # Steady state stress period + 0: [ + [(0, 0, 0), 7.0, ghbcond, ghb_conc, ghb_temp], + [(0, 0, ncol - 1), 4.0, ghbcond, ghb_conc, ghb_temp], + ], + # First transient stress period + 1: [ + [(0, 0, 0), 7.0, ghbcond, ghb_conc_warmup, ghb_temp_warmup], + [(0, 0, ncol - 1), 4.0, ghbcond, ghb_conc, ghb_temp], + ], +} + + +def build_model(idx, dir): + # Base MF6 GWF model type + ws = dir + name = ex[idx] + + print("Building MF6 model...()".format(name)) + + # generate names for each model + gwfname = "gwf-" + name + gwtname = "gwt-" + name + gwename = "gwe-" + name + + sim_ws = os.path.join(ws) + sim = flopy.mf6.MFSimulation( + sim_name=name, sim_ws=ws, exe_name="mf6", version="mf6" + ) + + # Instantiating MODFLOW 6 time discretization + flopy.mf6.ModflowTdis( + sim, nper=nper, perioddata=tdis_rc, time_units=time_units + ) + + # Instantiating MODFLOW 6 groundwater flow model + gwf = flopy.mf6.ModflowGwf( + sim, + modelname=gwfname, + save_flows=True, + model_nam_file="{}.nam".format(gwfname), + ) + + # Instantiating MODFLOW 6 solver for flow model + imsgwf = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="CG", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwfname), + ) + sim.register_ims_package(imsgwf, [gwfname]) + + # Instantiating MODFLOW 6 discretization package + flopy.mf6.ModflowGwfdis( + gwf, + length_units=length_units, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=np.ones((nlay, nrow, ncol), dtype=int), + pname="DIS-1", + filename="{}.dis".format(gwfname), + ) + + # Instantiating MODFLOW 6 storage package + flopy.mf6.ModflowGwfsto( + gwf, + ss=ss, + sy=sy, + iconvert=iconvert, + steady_state=steady, + transient=transient, + pname="STO", + filename="{}.sto".format(gwfname), + ) + + # Instantiating MODFLOW 6 node-property flow package + flopy.mf6.ModflowGwfnpf( + gwf, + save_flows=True, + icelltype=icelltype, + k=k11, + k33=k33, + save_specific_discharge=True, + pname="NPF-1", + filename="{}.npf".format(gwfname), + ) + + # Instantiating MODFLOW 6 initial conditions package for flow model + flopy.mf6.ModflowGwfic(gwf, strt=strt, filename="{}.ic".format(gwfname)) + + # Instatiate left and right general-head boundaries for driving flow + flopy.mf6.ModflowGwfghb( + gwf, + maxbound=len(ghbspd[0]), + stress_period_data=ghbspd, + auxiliary=["CONCENTRATION", "TEMPERATURE"], + save_flows=True, + pname="GHB-1", + filename="{}.ghb".format(gwfname), + ) + + # Instantiating MODFLOW 6 output control package for flow model + flopy.mf6.ModflowGwfoc( + gwf, + pname="OC-1", + head_filerecord="{}.hds".format(gwfname), + budget_filerecord="{}.cbc".format(gwfname), + headprintrecord=[("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL")], + saverecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + printrecord=[("HEAD", "ALL"), ("BUDGET", "ALL")], + ) + + # ---------------------------------------------------- + # Instantiating MODFLOW 6 GWT model + # ---------------------------------------------------- + gwt = flopy.mf6.MFModel( + sim, + model_type="gwt6", + modelname=gwtname, + model_nam_file="{}.nam".format(gwtname), + ) + gwt.name_file.save_flows = True + imsgwt = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwtname), + ) + sim.register_ims_package(imsgwt, [gwt.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwtdis( + gwt, + nogrb=True, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=1, + pname="DIS-2", + filename="{}.dis".format(gwtname), + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGwtic( + gwt, strt=strt_conc, pname="IC-2", filename="{}.ic".format(gwtname) + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGwtadv( + gwt, scheme=scheme, pname="ADV-2", filename="{}.adv".format(gwtname) + ) + + # Instantiating MODFLOW 6 transport dispersion package + if dispersivity != 0: + flopy.mf6.ModflowGwtdsp( + gwt, + xt3d_off=True, + alh=dispersivity, + ath1=dispersivity, + atv=dispersivity, + diffc=Dm, + pname="DSP-2", + filename="{}.dsp".format(gwtname), + ) + + # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) + flopy.mf6.ModflowGwtmst( + gwt, + porosity=prsity, + first_order_decay=False, + decay=None, + decay_sorbed=None, + sorption="linear", + bulk_density=rhob, + distcoef=Kd, + save_flows=True, + pname="MST-2", + filename="{}.mst".format(gwtname), + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + global pname + srctype = "AUX" + auxname = "CONCENTRATION" + pname = ["GHB-1"] + # Inpput to SSM is: + sources = [[itm, srctype, auxname] for itm in pname] + + flopy.mf6.ModflowGwtssm( + gwt, sources=sources, pname="SSM-2", filename="{}.ssm".format(gwtname) + ) + + # Instantiate MODFLOW 6 solute transport output control package + flopy.mf6.ModflowGwtoc( + gwt, + pname="OC-2", + budget_filerecord="{}.cbc".format(gwtname), + concentration_filerecord="{}.ucn".format(gwtname), + concentrationprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("CONCENTRATION", "ALL"), ("BUDGET", "ALL")], + printrecord=[("CONCENTRATION", "ALL"), ("BUDGET", "ALL")], + ) + + # Instantiating MODFLOW 6 flow-transport exchange mechanism + flopy.mf6.ModflowGwfgwt( + sim, + exgtype="GWF6-GWT6", + exgmnamea=gwfname, + exgmnameb=gwtname, + pname="GWFGWT", + filename="{}.gwfgwt".format(gwtname), + ) + + # --------------------------------------------------------- + # Instantiating MODFLOW 6 GWE model + # --------------------------------------------------------- + gwe = flopy.mf6.MFModel( + sim, + model_type="gwe6", + modelname=gwename, + model_nam_file="{}.nam".format(gwename), + ) + gwe.name_file.save_flows = True + imsgwe = flopy.mf6.ModflowIms( + sim, + print_option="SUMMARY", + outer_dvclose=hclose, + outer_maximum=nouter, + under_relaxation="NONE", + inner_maximum=ninner, + inner_dvclose=hclose, + rcloserecord=rclose, + linear_acceleration="BICGSTAB", + scaling_method="NONE", + reordering_method="NONE", + relaxation_factor=relax, + filename="{}.ims".format(gwename), + ) + sim.register_ims_package(imsgwe, [gwe.name]) + + # Instantiating MODFLOW 6 transport discretization package + flopy.mf6.ModflowGwedis( + gwe, + nogrb=True, + nlay=nlay, + nrow=nrow, + ncol=ncol, + delr=delr, + delc=delc, + top=top, + botm=botm, + idomain=1, + pname="DIS-3", + filename="{}.dis".format(gwename), + ) + + # Instantiating MODFLOW 6 transport initial concentrations + flopy.mf6.ModflowGweic( + gwe, strt=strt_temp, pname="IC-3", filename="{}.ic".format(gwename) + ) + + # Instantiating MODFLOW 6 transport advection package + flopy.mf6.ModflowGweadv( + gwe, scheme=scheme, pname="ADV-3", filename="{}.adv".format(gwename) + ) + + # Instantiating MODFLOW 6 transport dispersion package + if dispersivity != 0: + flopy.mf6.ModflowGwedsp( + gwe, + xt3d_off=False, + alh=dispersivity, + ath1=dispersivity, + ktw=ktw, + kts=kts, + pname="DSP-3", + filename="{}.dsp".format(gwename), + ) + + # Instantiating MODFLOW 6 transport mass storage package (formerly "reaction" package in MT3DMS) + flopy.mf6.ModflowGwemst( + gwe, + save_flows=True, + porosity=prsity, + cps=cps, + rhos=rhos, + packagedata=[cpw, rhow, lhv], + pname="MST-3", + filename="{}.mst".format(gwename), + ) + + # Instantiating MODFLOW 6 transport source-sink mixing package + srctype = "AUX" + auxname = "TEMPERATURE" + pname = ["GHB-1"] + # Inpput to SSM is: + sources = [[itm, srctype, auxname] for itm in pname] + + flopy.mf6.ModflowGwessm( + gwe, sources=sources, pname="SSM-3", filename="{}.ssm".format(gwename) + ) + + # Instantiate MODFLOW 6 heat transport output control package + flopy.mf6.ModflowGweoc( + gwe, + pname="OC-3", + budget_filerecord="{}.cbc".format(gwename), + temperature_filerecord="{}.ucn".format(gwename), + temperatureprintrecord=[ + ("COLUMNS", 10, "WIDTH", 15, "DIGITS", 6, "GENERAL") + ], + saverecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + printrecord=[("TEMPERATURE", "ALL"), ("BUDGET", "ALL")], + ) + + # Instantiating MODFLOW 6 flow-transport exchange mechanism + flopy.mf6.ModflowGwfgwe( + sim, + exgtype="GWF6-GWE6", + exgmnamea=gwfname, + exgmnameb=gwename, + pname="GWFGWE", + filename="{}.gwfgwe".format(gwename), + ) + + return sim, None + + +def eval_model(sim): + print("evaluating results...") + + # read transport results from GWE model + name = ex[sim.idxsim] + gwfname = "gwf-" + name + gwtname = "gwt-" + name + gwename = "gwe-" + name + + # Pull gw heads from GWF + fpth = os.path.join(sim.simpath, f"{gwfname}.hds") + try: + # load temperatures + hobj = flopy.utils.HeadFile(fpth, precision="double", text="HEAD") + hds = hobj.get_alldata() + except: + assert False, f'could not load head data from "{fpth}"' + + # Pull parameter-equivalent calculated temperatures from GWT + fpth = os.path.join(sim.simpath, f"{gwtname}.ucn") + try: + # load temperatures + cobj = flopy.utils.HeadFile( + fpth, precision="double", text="CONCENTRATION" + ) + conc1 = cobj.get_alldata() + except: + assert False, f'could not load concentration data from "{fpth}"' + + # Pull natively-calculated temperature output from GWE + fpth = os.path.join(sim.simpath, f"{gwename}.ucn") + try: + # load temperatures + tobj = flopy.utils.HeadFile( + fpth, precision="double", text="TEMPERATURE" + ) + temp1 = tobj.get_alldata() + except: + assert False, f'could not load temperature data from "{fpth}"' + + # Check heads satisfy problem set up (i.e., all of row 2 is dry) + hdsr1 = hds[0, 0, 0, :] + assert np.all( + hdsr1 < bot_r2 + ), "heads in row 1 should be below bottom elevation of row 2" + assert np.all(hds[0, 0, 1, :] < 0), "row 2 is not dry" + + # Starting temperatures after steady flow period should be 4.0 degrees + np.all( + np.isclose(temp1[0], strt_temp, atol=1e-10) + ), "Steady state temperatures not as expected" + # Same with concentrations in non-dry cells + assert np.all( + np.isclose(conc1[0, :, 0], strt_conc[:, 0]) + ), "Steady state concentrations not as expected" + # Unlike GWE, GWT will not keep dry cells active and output should reflect this + assert np.all( + conc1[:, :, 1, :] < 0 + ), "Concentrations should be set to 'inactive' (-1.e+30) in row 2" + + # Starting in the transient stress period, the water entering in the + # 'trough' row is warmed to 30.0 C. First check that this is the case + assert np.all( + temp1[-1] > temp1[0] + ), "Transient period temperature increase does not appear to have kicked in" + # Dry cell temperatures are only warmed through conduction with neighboring + # 'trough' cells and shouldn't be as warm as wet cells at the end of the + # warming period + assert np.all( + temp1[-1, :, 0] > temp1[-1, 0, 1] + ), "Cells with water should be warmer than dry cells" + + # None of the cells should reach the temperature of the incoming water + # during the simulation period owing to the thermal bleeding that occurs + # to the adjacent dry cells. + assert np.all( + temp1[-1] < ghb_temp_warmup + ), "Cells should not reach the temperature of the incoming water" + + # An increasing amount of thermal bleeding should occur moving in the + # direction of flow since the thickness of the dry cells increases in the + # downstream direction + assert np.all( + np.diff(temp1[-1, :, 0, :-1]) < 0 + ), "Temperature change in the downstream direction should be negative" + assert isMonotonic( + np.diff(temp1[-1, :, 0, :-1]) + ), "A monotonic increase in the amount of heat lost to neighboring dry " \ + "cells is expected" + + # Check temporal changes in temperature in the most upstream and downstream + # dry cells. Cell bottoms in row 2 were calculated using a rounding function + # to the nearest tenth place and as a result a monotonic tapering-off of + # the temperature increase in the in the interior cells cannot be + # guaranteed because of conduction with not only the wet cell in row 1, but + # also conduction among its two dry neighbors (also with variable thickness + colid = 0 + m_arr = np.diff(temp1[1:, 0, 1, colid]) + assert isMonotonic( + m_arr + ), "Temperatures should be monotonically tapering-off in their " \ + "relative temperature increase with time in the upstream-most" \ + "dry cell" + + colid = 11 + m_arr = np.diff(temp1[1:, 0, 1, colid]) + assert isMonotonic( + m_arr + ), "Temperatures should be monotonically tapering-off in their " \ + "relative temperature increase with time in the downstream-most" \ + "dry cell" + + # Run a few checks between GWE and its GWT counterpart + # In GWT there is no solute interaction with a dry cell, so concentrations + # in the dry cell should remain inactive (i.e., no "molecular diffusion") + # and greater than their GWE counterpart temperatures since there is + # no "retardation" of concentration (temperature) owing to conduction + assert np.all(conc1[:, :, 1, :] < 0), "The dry cells should never have a non-inactive concentration value" + + + + +# - No need to change any code below +@pytest.mark.parametrize( + "idx, name", + list(enumerate(ex)), +) +def test_mf6model(idx, name, function_tmpdir, targets): + ws = str(function_tmpdir) + test = TestFramework() + test.build(build_model, idx, ws) + test.run( + TestSimulation( + name=name, exe_dict=targets, exfunc=eval_model, idxsim=idx + ), + ws, + ) From 8508a2f8e50d0577134570c5678da7dee701b002 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Tue, 27 Jun 2023 09:48:13 -0700 Subject: [PATCH 209/212] Restore a fix that was lost during a merge conflict. This fix was originally part of cb11acf (#1267) --- src/Model/TransportModel/tsp1cnc1.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Model/TransportModel/tsp1cnc1.f90 b/src/Model/TransportModel/tsp1cnc1.f90 index 538f5ff252d..8157b4827ec 100644 --- a/src/Model/TransportModel/tsp1cnc1.f90 +++ b/src/Model/TransportModel/tsp1cnc1.f90 @@ -166,7 +166,7 @@ subroutine cnc_rp(this) call this%dis%noder_to_string(node, nodestr) dvtype = trim(this%tsplab%depvartype) call lowcase(dvtype) - call store_error('Error. Cell is already a constant ' & + call store_error('Cell is already a constant ' & //dvtype//': '//trim(adjustl(nodestr))) ierr = ierr + 1 else @@ -238,7 +238,7 @@ subroutine cnc_ck(this) integer(I4B) :: node ! -- formats character(len=*), parameter :: fmtcncerr = & - &"('CNC BOUNDARY ',i0,' CONC (',g0,') IS LESS THAN ZERO FOR CELL', a)" + &"('CNC boundary ',i0,' conc (',g0,') is less than zero for cell', a)" ! ------------------------------------------------------------------------------ ! ! -- check stress period data From aac5e52e35840cdd6e07f6d1b04a1bf7c2111308 Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Fri, 21 Jul 2023 05:07:49 -0700 Subject: [PATCH 210/212] The missing gfortran12 link? --- utils/zonebudget/make/makefile | 7 +++++-- utils/zonebudget/pymake/extrafiles.txt | 1 + 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/utils/zonebudget/make/makefile b/utils/zonebudget/make/makefile index 092dc3b0294..f2ee8667c27 100644 --- a/utils/zonebudget/make/makefile +++ b/utils/zonebudget/make/makefile @@ -5,11 +5,13 @@ include ./makedefaults # Define the source file directories SOURCEDIR1=../src -SOURCEDIR2=../../../src/Utilities +SOURCEDIR2=../../../src/Model/ModelUtilities +SOURCEDIR3=../../../src\Utilities VPATH = \ ${SOURCEDIR1} \ -${SOURCEDIR2} +${SOURCEDIR2} \ +${SOURCEDIR3} .SUFFIXES: .f90 .F90 .o @@ -29,6 +31,7 @@ $(OBJDIR)/InputOutput.o \ $(OBJDIR)/sort.o \ $(OBJDIR)/BlockParser.o \ $(OBJDIR)/ArrayReaders.o \ +$(OBJDIR)/TspLabels.o \ $(OBJDIR)/zone.o \ $(OBJDIR)/Budget.o \ $(OBJDIR)/zoneoutput.o \ diff --git a/utils/zonebudget/pymake/extrafiles.txt b/utils/zonebudget/pymake/extrafiles.txt index c4cfdf23967..63a6508bf5c 100644 --- a/utils/zonebudget/pymake/extrafiles.txt +++ b/utils/zonebudget/pymake/extrafiles.txt @@ -1,3 +1,4 @@ +../../../src/Model/ModelUtilities/TspLabels.f90 ../../../src/Utilities/ArrayHandlers.f90 ../../../src/Utilities/ArrayReaders.f90 ../../../src/Utilities/BlockParser.f90 From 1dfc08f07326da78ed64b4246b838dfdd0d4ba6c Mon Sep 17 00:00:00 2001 From: w-bonelli Date: Fri, 21 Jul 2023 14:16:38 -0400 Subject: [PATCH 211/212] update makefiles --- make/makedefaults | 2 +- make/makefile | 69 +++++++++++++++--------------- utils/mf5to6/make/makedefaults | 2 +- utils/mf5to6/make/makefile | 10 ++--- utils/zonebudget/make/makedefaults | 2 +- utils/zonebudget/make/makefile | 4 +- 6 files changed, 44 insertions(+), 45 deletions(-) diff --git a/make/makedefaults b/make/makedefaults index 7bbd4dd3293..a9174e9746d 100644 --- a/make/makedefaults +++ b/make/makedefaults @@ -1,4 +1,4 @@ -# makedefaults created by pymake (version 1.2.7) for the 'mf6' executable. +# makedefaults created by pymake (version 1.2.9.dev0) for the 'mf6' executable. # determine OS ifeq ($(OS), Windows_NT) diff --git a/make/makefile b/make/makefile index a5c8a208cb4..6b0dea26681 100644 --- a/make/makefile +++ b/make/makefile @@ -1,41 +1,41 @@ -# makefile created by pymake (version 1.2.7) for the 'mf6' executable. +# makefile created by pymake (version 1.2.9.dev0) for the 'mf6' executable. include ./makedefaults # Define the source file directories -SOURCEDIR1=..\src -SOURCEDIR2=..\src\Distributed -SOURCEDIR3=..\src\Exchange -SOURCEDIR4=..\src\Model -SOURCEDIR5=..\src\Model\Connection -SOURCEDIR6=..\src\Model\Geometry -SOURCEDIR7=..\src\Model\GroundWaterEnergy -SOURCEDIR8=..\src\Model\GroundWaterFlow -SOURCEDIR9=..\src\Model\GroundWaterTransport -SOURCEDIR10=..\src\Model\ModelUtilities -SOURCEDIR11=..\src\Model\TransportModel -SOURCEDIR12=..\src\Solution -SOURCEDIR13=..\src\Solution\LinearMethods -SOURCEDIR14=..\src\Solution\PETSc -SOURCEDIR15=..\src\Timing -SOURCEDIR16=..\src\Utilities -SOURCEDIR17=..\src\Utilities\ArrayRead -SOURCEDIR18=..\src\Utilities\Idm -SOURCEDIR19=..\src\Utilities\Idm\mf6blockfile -SOURCEDIR20=..\src\Utilities\Idm\selector -SOURCEDIR21=..\src\Utilities\Libraries -SOURCEDIR22=..\src\Utilities\Libraries\blas -SOURCEDIR23=..\src\Utilities\Libraries\daglib -SOURCEDIR24=..\src\Utilities\Libraries\rcm -SOURCEDIR25=..\src\Utilities\Libraries\sparsekit -SOURCEDIR26=..\src\Utilities\Libraries\sparskit2 -SOURCEDIR27=..\src\Utilities\Matrix -SOURCEDIR28=..\src\Utilities\Memory -SOURCEDIR29=..\src\Utilities\Observation -SOURCEDIR30=..\src\Utilities\OutputControl -SOURCEDIR31=..\src\Utilities\TimeSeries -SOURCEDIR32=..\src\Utilities\Vector +SOURCEDIR1=../src +SOURCEDIR2=../src/Exchange +SOURCEDIR3=../src/Model +SOURCEDIR4=../src/Model/Geometry +SOURCEDIR5=../src/Model/TransportModel +SOURCEDIR6=../src/Model/ModelUtilities +SOURCEDIR7=../src/Model/Connection +SOURCEDIR8=../src/Model/GroundWaterEnergy +SOURCEDIR9=../src/Model/GroundWaterTransport +SOURCEDIR10=../src/Model/GroundWaterFlow +SOURCEDIR11=../src/Distributed +SOURCEDIR12=../src/Solution +SOURCEDIR13=../src/Solution/PETSc +SOURCEDIR14=../src/Solution/LinearMethods +SOURCEDIR15=../src/Timing +SOURCEDIR16=../src/Utilities +SOURCEDIR17=../src/Utilities/TimeSeries +SOURCEDIR18=../src/Utilities/Libraries +SOURCEDIR19=../src/Utilities/Libraries/rcm +SOURCEDIR20=../src/Utilities/Libraries/sparsekit +SOURCEDIR21=../src/Utilities/Libraries/sparskit2 +SOURCEDIR22=../src/Utilities/Libraries/blas +SOURCEDIR23=../src/Utilities/Libraries/daglib +SOURCEDIR24=../src/Utilities/Idm +SOURCEDIR25=../src/Utilities/Idm/selector +SOURCEDIR26=../src/Utilities/Idm/mf6blockfile +SOURCEDIR27=../src/Utilities/Matrix +SOURCEDIR28=../src/Utilities/Vector +SOURCEDIR29=../src/Utilities/Observation +SOURCEDIR30=../src/Utilities/OutputControl +SOURCEDIR31=../src/Utilities/Memory +SOURCEDIR32=../src/Utilities/ArrayRead VPATH = \ ${SOURCEDIR1} \ @@ -201,6 +201,7 @@ $(OBJDIR)/IdmGweDfnSelector.o \ $(OBJDIR)/UzfCellGroup.o \ $(OBJDIR)/Xt3dInterface.o \ $(OBJDIR)/gwf3tvk8.o \ +$(OBJDIR)/gwf3vsc8.o \ $(OBJDIR)/GwfNpfOptions.o \ $(OBJDIR)/NumericalSolution.o \ $(OBJDIR)/InterfaceMap.o \ @@ -323,9 +324,7 @@ $(OBJDIR)/sparsekit.o \ $(OBJDIR)/rcm.o \ $(OBJDIR)/blas1_d.o \ $(OBJDIR)/Iunit.o \ -$(OBJDIR)/LatHeatVapor.o \ $(OBJDIR)/GwtAdvOptions.o \ -$(OBJDIR)/gwf3vsc8.o \ $(OBJDIR)/RectangularGeometry.o \ $(OBJDIR)/CircularGeometry.o diff --git a/utils/mf5to6/make/makedefaults b/utils/mf5to6/make/makedefaults index fdc2fdb51cb..bcea1425b67 100644 --- a/utils/mf5to6/make/makedefaults +++ b/utils/mf5to6/make/makedefaults @@ -1,4 +1,4 @@ -# makedefaults created by pymake (version 1.2.7) for the 'mf5to6' executable. +# makedefaults created by pymake (version 1.2.9.dev0) for the 'mf5to6' executable. # determine OS ifeq ($(OS), Windows_NT) diff --git a/utils/mf5to6/make/makefile b/utils/mf5to6/make/makefile index d8eb7e6963d..d593ea91224 100644 --- a/utils/mf5to6/make/makefile +++ b/utils/mf5to6/make/makefile @@ -1,14 +1,14 @@ -# makefile created by pymake (version 1.2.7) for the 'mf5to6' executable. +# makefile created by pymake (version 1.2.9.dev0) for the 'mf5to6' executable. include ./makedefaults # Define the source file directories SOURCEDIR1=../src -SOURCEDIR2=../src/NWT -SOURCEDIR3=../src/LGR -SOURCEDIR4=../src/Preproc -SOURCEDIR5=../src/MF2005 +SOURCEDIR2=../src/LGR +SOURCEDIR3=../src/Preproc +SOURCEDIR4=../src/MF2005 +SOURCEDIR5=../src/NWT SOURCEDIR6=../../../src/Utilities/Memory SOURCEDIR7=../../../src/Utilities/TimeSeries SOURCEDIR8=../../../src/Utilities diff --git a/utils/zonebudget/make/makedefaults b/utils/zonebudget/make/makedefaults index 919f5ed9b06..e27dfca39de 100644 --- a/utils/zonebudget/make/makedefaults +++ b/utils/zonebudget/make/makedefaults @@ -1,4 +1,4 @@ -# makedefaults created by pymake (version 1.2.7) for the 'zbud6' executable. +# makedefaults created by pymake (version 1.2.9.dev0) for the 'zbud6' executable. # determine OS ifeq ($(OS), Windows_NT) diff --git a/utils/zonebudget/make/makefile b/utils/zonebudget/make/makefile index f2ee8667c27..d40eb8ff0db 100644 --- a/utils/zonebudget/make/makefile +++ b/utils/zonebudget/make/makefile @@ -1,4 +1,4 @@ -# makefile created by pymake (version 1.2.7) for the 'zbud6' executable. +# makefile created by pymake (version 1.2.9.dev0) for the 'zbud6' executable. include ./makedefaults @@ -6,7 +6,7 @@ include ./makedefaults # Define the source file directories SOURCEDIR1=../src SOURCEDIR2=../../../src/Model/ModelUtilities -SOURCEDIR3=../../../src\Utilities +SOURCEDIR3=../../../src/Utilities VPATH = \ ${SOURCEDIR1} \ From fe20af1a13259bd6b531ddc8c3763c6010f343dc Mon Sep 17 00:00:00 2001 From: Eric Morway Date: Thu, 10 Aug 2023 15:47:29 -0700 Subject: [PATCH 212/212] Goes with https://github.com/MODFLOW-USGS/modflow6/pull/1306#discussion_r1272267932 --- src/Model/TransportModel/tsp1.f90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Model/TransportModel/tsp1.f90 b/src/Model/TransportModel/tsp1.f90 index 4816e2a2ac4..0d019921cee 100644 --- a/src/Model/TransportModel/tsp1.f90 +++ b/src/Model/TransportModel/tsp1.f90 @@ -92,8 +92,9 @@ module TransportModelModule 'ADV6 ', 'DSP6 ', 'SSM6 ', ' ', 'CNC6 ', & ! 10 'OC6 ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15 'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20 - 'API6 ', ' ', 'SFE6 ', 'UZE6 ', ' ', & ! 25 - 75*' '/ + 'API6 ', ' ', 'LKE6 ', 'SFE6 ', 'MWE6 ', & ! 25 + 'UZE6 ', ' ', ' ', ' ', ' ', & ! 30 + 70*' '/ contains