MODFLOW 6  version 6.9.0.dev0
USGS Modular Hydrologic Model
gwf-lak.f90
Go to the documentation of this file.
1 module lakmodule
2  !
3  use kindmodule, only: dp, i4b, lgp
4  use constantsmodule, only: linelength, lenboundname, lentimeseriesname, &
5  iwetlake, maxadpit, dzero, dprec, dem30, dem9, &
6  dem6, dem5, dem4, dem2, dem1, dhalf, dp7, dp9, &
7  dp999, done, dtwo, dpi, dthree, deight, dten, &
8  dep20, donethird, dtwothirds, dfivethirds, &
9  dgravity, dcd, namedboundflag, lenftype, &
10  lenpackagename, lenpakloc, dnodata, tableft, &
11  tabcenter, tabright, tabstring, tabucstring, &
12  tabinteger, tabreal
13  use memorymanagermodule, only: mem_allocate, mem_reallocate, mem_setptr, &
14  mem_deallocate
15  use memoryhelpermodule, only: create_mem_path
16  use smoothingmodule, only: squadraticsaturation, sqsaturation, &
17  squadraticsaturationderivative, &
18  sqsaturationderivative
19  use bndmodule, only: bndtype
20  use budgetobjectmodule, only: budgetobjecttype, budgetobject_cr
21  use tablemodule, only: tabletype, table_cr
22  use observemodule, only: observetype
23  use obsmodule, only: obstype
24  use geomutilmodule, only: get_node
25  use inputoutputmodule, only: urword, extract_idnum_or_bndname
26  use basedismodule, only: disbasetype
27  use simmodule, only: count_errors, store_error, store_error_unit, &
28  store_warning, deprecation_warning
29  use mathutilmodule, only: is_close
30  use blockparsermodule, only: blockparsertype
31  use basedismodule, only: disbasetype
32  use simvariablesmodule, only: errmsg, warnmsg
33  use matrixbasemodule
34  !
35  implicit none
36  !
37  private
38  public :: laktype
39  public :: lak_create
40  !
41  character(len=LENFTYPE) :: ftype = 'LAK'
42  character(len=LENPACKAGENAME) :: text = ' LAK'
43  !
44  type laktabtype
45  real(dp), dimension(:), pointer, contiguous :: tabstage => null()
46  real(dp), dimension(:), pointer, contiguous :: tabvolume => null()
47  real(dp), dimension(:), pointer, contiguous :: tabsarea => null()
48  real(dp), dimension(:), pointer, contiguous :: tabwarea => null()
49  end type laktabtype
50  !
51  type, extends(bndtype) :: laktype
52  ! -- scalars
53  ! -- characters
54  character(len=16), dimension(:), pointer, contiguous :: clakbudget => null()
55  character(len=16), dimension(:), pointer, contiguous :: cauxcbc => null()
56  ! -- control variables
57  ! -- integers
58  integer(I4B), pointer :: iprhed => null()
59  integer(I4B), pointer :: istageout => null()
60  integer(I4B), pointer :: ibudgetout => null()
61  integer(I4B), pointer :: ibudcsv => null()
62  integer(I4B), pointer :: ipakcsv => null()
63  character(len=:), allocatable :: pakcsvfile !< requested PACKAGE_CONVERGENCE file, opened in lak_ar once the IMPLICIT option is known
64  integer(I4B), pointer :: cbcauxitems => null()
65  integer(I4B), pointer :: nlakes => null()
66  integer(I4B), pointer :: noutlets => null()
67  integer(I4B), pointer :: ntables => null()
68  real(dp), pointer :: convlength => null()
69  real(dp), pointer :: convtime => null()
70  real(dp), pointer :: outdmax => null()
71  integer(I4B), pointer :: igwhcopt => null()
72  integer(I4B), pointer :: iconvchk => null()
73  integer(I4B), pointer :: maxlakit => null() !< maximum number of iterations in LAK solve
74  real(dp), pointer :: surfdep => null()
75  real(dp), pointer :: dmaxchg => null()
76  real(dp), pointer :: delh => null()
77  integer(I4B), pointer :: check_attr => null()
78  ! -- implicit formulation: solve the lake stage as an unknown in the
79  ! groundwater flow matrix instead of by the legacy substitution iteration
80  integer(I4B), pointer :: iimplicit => null() !< flag: solve lake stage in the gwf matrix
81  integer(I4B), pointer :: iforceleg => null() !< flag (dev): force every active lake onto the legacy solver
82  integer(I4B), pointer :: iforceleglak => null() !< lake (dev) forced onto the legacy solver, 0 if none
83  ! -- for budgets
84  integer(I4B), pointer :: bditems => null()
85  ! -- vectors
86  ! -- lake data
87  integer(I4B), dimension(:), pointer, contiguous :: nlakeconn => null()
88  integer(I4B), dimension(:), pointer, contiguous :: idxlakeconn => null()
89  integer(I4B), dimension(:), pointer, contiguous :: ntabrow => null()
90  real(dp), dimension(:), pointer, contiguous :: strt => null()
91  real(dp), dimension(:), pointer, contiguous :: laketop => null()
92  real(dp), dimension(:), pointer, contiguous :: lakebot => null()
93  real(dp), dimension(:), pointer, contiguous :: sareamax => null()
94  character(len=LENBOUNDNAME), dimension(:), pointer, &
95  contiguous :: lakename => null()
96  character(len=8), dimension(:), pointer, contiguous :: status => null()
97  real(dp), dimension(:), pointer, contiguous :: avail => null()
98  real(dp), dimension(:), pointer, contiguous :: lkgwsink => null()
99  real(dp), dimension(:), pointer, contiguous :: stage => null()
100  real(dp), dimension(:), pointer, contiguous :: rainfall => null()
101  real(dp), dimension(:), pointer, contiguous :: evaporation => null()
102  real(dp), dimension(:), pointer, contiguous :: runoff => null()
103  real(dp), dimension(:), pointer, contiguous :: inflow => null()
104  real(dp), dimension(:), pointer, contiguous :: withdrawal => null()
105  real(dp), dimension(:, :), pointer, contiguous :: lauxvar => null()
106  !
107  ! -- table data
108  integer(I4B), dimension(:), pointer, contiguous :: ialaktab => null()
109  real(dp), dimension(:), pointer, contiguous :: tabstage => null()
110  real(dp), dimension(:), pointer, contiguous :: tabvolume => null()
111  real(dp), dimension(:), pointer, contiguous :: tabsarea => null()
112  real(dp), dimension(:), pointer, contiguous :: tabwarea => null()
113  !
114  ! -- lake solution data
115  integer(I4B), dimension(:), pointer, contiguous :: ncncvr => null()
116  ! -- IMPLICIT legacy solve: solve flagged lakes by substitution,
117  ! and a per-lake count of consecutive non-converging outer iterations used
118  ! to decide when to switch a stalled IMPLICIT lake to the legacy solver
119  integer(I4B), dimension(:), pointer, contiguous :: ilegacy => null()
120  integer(I4B), dimension(:), pointer, contiguous :: nstuck => null()
121  real(dp), dimension(:), pointer, contiguous :: surfin => null()
122  real(dp), dimension(:), pointer, contiguous :: surfout => null()
123  real(dp), dimension(:), pointer, contiguous :: surfout1 => null()
124  real(dp), dimension(:), pointer, contiguous :: precip => null()
125  real(dp), dimension(:), pointer, contiguous :: precip1 => null()
126  real(dp), dimension(:), pointer, contiguous :: evap => null()
127  real(dp), dimension(:), pointer, contiguous :: evap1 => null()
128  real(dp), dimension(:), pointer, contiguous :: evapo => null()
129  real(dp), dimension(:), pointer, contiguous :: withr => null()
130  real(dp), dimension(:), pointer, contiguous :: withr1 => null()
131  real(dp), dimension(:), pointer, contiguous :: flwin => null()
132  real(dp), dimension(:), pointer, contiguous :: flwiter => null()
133  real(dp), dimension(:), pointer, contiguous :: flwiter1 => null()
134  real(dp), dimension(:), pointer, contiguous :: seep => null()
135  real(dp), dimension(:), pointer, contiguous :: seep1 => null()
136  real(dp), dimension(:), pointer, contiguous :: seep0 => null()
137  real(dp), dimension(:), pointer, contiguous :: stageiter => null()
138  real(dp), dimension(:), pointer, contiguous :: chterm => null()
139  !
140  ! -- lake convergence
141  integer(I4B), dimension(:), pointer, contiguous :: iseepc => null()
142  integer(I4B), dimension(:), pointer, contiguous :: idhc => null()
143  real(dp), dimension(:), pointer, contiguous :: en1 => null()
144  real(dp), dimension(:), pointer, contiguous :: en2 => null()
145  real(dp), dimension(:), pointer, contiguous :: r1 => null()
146  real(dp), dimension(:), pointer, contiguous :: r2 => null()
147  real(dp), dimension(:), pointer, contiguous :: dh0 => null()
148  real(dp), dimension(:), pointer, contiguous :: s0 => null()
149  real(dp), dimension(:), pointer, contiguous :: qgwf0 => null()
150  ! -- groundwater flow matrix bookkeeping for the implicit formulation
151  integer(I4B), dimension(:), pointer, contiguous :: idxlocnode => null() !< local index of each lake row in x/rhs
152  integer(I4B), dimension(:), pointer, contiguous :: idxdiag => null() !< position of lake-row diagonal (per lake)
153  integer(I4B), dimension(:), pointer, contiguous :: idxoffdglo => null() !< position of lake-row -> gwf column (per connection)
154  integer(I4B), dimension(:), pointer, contiguous :: idxsymdglo => null() !< position of gwf-row diagonal (per connection)
155  integer(I4B), dimension(:), pointer, contiguous :: idxsymoffdglo => null() !< position of gwf-row -> lake column (per connection)
156  !
157  ! -- lake connection data
158  integer(I4B), dimension(:), pointer, contiguous :: imap => null()
159  integer(I4B), dimension(:), pointer, contiguous :: cellid => null()
160  integer(I4B), dimension(:), pointer, contiguous :: nodesontop => null()
161  integer(I4B), dimension(:), pointer, contiguous :: ictype => null()
162  real(dp), dimension(:), pointer, contiguous :: bedleak => null()
163  real(dp), dimension(:), pointer, contiguous :: belev => null()
164  real(dp), dimension(:), pointer, contiguous :: telev => null()
165  real(dp), dimension(:), pointer, contiguous :: connlength => null()
166  real(dp), dimension(:), pointer, contiguous :: connwidth => null()
167  real(dp), dimension(:), pointer, contiguous :: sarea => null()
168  real(dp), dimension(:), pointer, contiguous :: warea => null()
169  real(dp), dimension(:), pointer, contiguous :: satcond => null()
170  real(dp), dimension(:), pointer, contiguous :: simcond => null()
171  real(dp), dimension(:), pointer, contiguous :: simlakgw => null()
172  !
173  ! -- lake outlet data
174  integer(I4B), dimension(:), pointer, contiguous :: lakein => null()
175  integer(I4B), dimension(:), pointer, contiguous :: lakeout => null()
176  integer(I4B), dimension(:), pointer, contiguous :: iouttype => null()
177  real(dp), dimension(:), pointer, contiguous :: outrate => null()
178  real(dp), dimension(:), pointer, contiguous :: outinvert => null()
179  real(dp), dimension(:), pointer, contiguous :: outwidth => null()
180  real(dp), dimension(:), pointer, contiguous :: outrough => null()
181  real(dp), dimension(:), pointer, contiguous :: outslope => null()
182  real(dp), dimension(:), pointer, contiguous :: simoutrate => null()
183  !
184  ! -- lake output data
185  real(dp), dimension(:), pointer, contiguous :: qauxcbc => null()
186  real(dp), dimension(:), pointer, contiguous :: dbuff => null()
187  real(dp), dimension(:), pointer, contiguous :: qleak => null()
188  ! -- connected-cell head at the previous outer iteration (per connection),
189  ! used by the IMPLICIT legacy-switch detection to compare a lake's stage change
190  ! against the change in its connected aquifer heads
191  real(dp), dimension(:), pointer, contiguous :: holdconn => null()
192  real(dp), dimension(:), pointer, contiguous :: qsto => null()
193  !
194  ! -- pointer to gwf iss and gwf hk
195  integer(I4B), pointer :: gwfiss => null()
196  real(dp), dimension(:), pointer, contiguous :: gwfk11 => null()
197  real(dp), dimension(:), pointer, contiguous :: gwfk33 => null()
198  real(dp), dimension(:), pointer, contiguous :: gwfsat => null()
199  integer(I4B), pointer :: gwfik33 => null()
200  !
201  ! -- package x, xold, and ibound
202  integer(I4B), dimension(:), pointer, contiguous :: iboundpak => null() !package ibound
203  real(dp), dimension(:), pointer, contiguous :: xnewpak => null() !package x vector
204  real(dp), dimension(:), pointer, contiguous :: xoldpak => null() !package xold vector
205  !
206  ! -- lake budget object
207  type(budgetobjecttype), pointer :: budobj => null()
208  !
209  ! -- lake table objects
210  type(tabletype), pointer :: stagetab => null()
211  type(tabletype), pointer :: pakcsvtab => null()
212  !
213  ! -- density variables
214  integer(I4B), pointer :: idense
215  real(dp), dimension(:, :), pointer, contiguous :: denseterms => null()
216  !
217  ! -- viscosity variables
218  real(dp), dimension(:, :), pointer, contiguous :: viscratios => null() !< viscosity ratios (1: lak vsc ratio; 2: gwf vsc ratio)
219  !
220  ! -- type bound procedures
221 
222  contains
223 
224  procedure :: lak_allocate_scalars
225  procedure :: lak_allocate_arrays
226  procedure :: bnd_options => lak_options
227  procedure :: read_dimensions => lak_read_dimensions
228  procedure :: read_initial_attr => lak_read_initial_attr
229  procedure :: set_pointers => lak_set_pointers
230  procedure :: bnd_ar => lak_ar
231  procedure :: bnd_ac => lak_ac
232  procedure :: bnd_mc => lak_mc
233  procedure :: bnd_rp => lak_rp
234  procedure :: bnd_ad => lak_ad
235  procedure :: bnd_cf => lak_cf
236  procedure :: bnd_fc => lak_fc
237  procedure :: bnd_fn => lak_fn
238  procedure :: bnd_nur => lak_nur
239  procedure :: bnd_cc => lak_cc
240  procedure, private :: lak_set_legacy
241  procedure, private :: lak_check_disconnected
242  procedure :: bnd_cq => lak_cq
243  procedure :: bnd_ot_model_flows => lak_ot_model_flows
244  procedure :: bnd_ot_package_flows => lak_ot_package_flows
245  procedure :: bnd_ot_dv => lak_ot_dv
246  procedure :: bnd_ot_bdsummary => lak_ot_bdsummary
247  procedure :: bnd_da => lak_da
248  procedure :: define_listlabel
249  ! -- methods for observations
250  procedure, public :: bnd_obs_supported => lak_obs_supported
251  procedure, public :: bnd_df_obs => lak_df_obs
252  procedure, public :: bnd_rp_obs => lak_rp_obs
253  procedure, public :: bnd_bd_obs => lak_bd_obs
254  ! -- private procedures
255  procedure, private :: lak_read_lakes
256  procedure, private :: lak_read_lake_connections
257  procedure, private :: lak_read_outlets
258  procedure, private :: lak_read_tables
259  procedure, private :: lak_read_table
260  procedure, private :: lak_check_valid
261  procedure, private :: lak_set_stressperiod
262  procedure, private :: lak_set_attribute_error
263  procedure, private :: lak_bound_update
264  procedure, private :: lak_calculate_sarea
265  procedure, private :: lak_calculate_warea
266  procedure, private :: lak_calculate_conn_warea
267  procedure, public :: lak_calculate_vol
268  procedure, private :: lak_calculate_conductance
269  procedure, private :: lak_calculate_cond_head
270  procedure, private :: lak_calculate_conn_conductance
271  procedure, private :: lak_calculate_exchange
272  procedure, private :: lak_calculate_conn_exchange
273  procedure, private :: lak_calculate_conn_exchange_deriv
274  procedure, private :: lak_estimate_conn_exchange
275  procedure, private :: lak_calculate_storagechange
276  procedure, private :: lak_calculate_rainfall
277  procedure, private :: lak_calculate_runoff
278  procedure, private :: lak_calculate_inflow
279  procedure, private :: lak_calculate_external
280  procedure, private :: lak_calculate_withdrawal
281  procedure, private :: lak_calculate_evaporation
282  procedure, private :: lak_calculate_outlet_inflow
283  procedure, private :: lak_calculate_outlet_outflow
284  procedure, private :: lak_get_internal_inlet
285  procedure, private :: lak_get_internal_outlet
286  procedure, private :: lak_get_external_outlet
287  procedure, private :: lak_get_internal_mover
288  procedure, private :: lak_get_external_mover
289  procedure, private :: lak_get_outlet_tomover
290  procedure, private :: lak_accumulate_chterm
291  procedure, private :: lak_vol2stage
292  procedure, private :: lak_solve
293  procedure, private :: lak_solve_single
294  procedure, private :: lak_estimate_seepage_single
295  procedure, private :: lak_fc_implicit
296  procedure, private :: lak_budget_nogwf
297  procedure, private :: lak_outlet_outflow_rate
298  procedure, private :: lak_bisection
299  procedure, private :: lak_calculate_available
300  procedure, private :: lak_calculate_residual
301  procedure, private :: lak_linear_interpolation
302  procedure, private :: lak_setup_budobj
303  procedure, private :: lak_fill_budobj
304  procedure, private :: laktables_to_vectors
305  ! -- table
306  procedure, private :: lak_setup_tableobj
307  ! -- density
308  procedure :: lak_activate_density
309  procedure, private :: lak_calculate_density_exchange
310  ! -- viscosity
311  procedure :: lak_activate_viscosity
312  end type laktype
313 
314  ! -- implicit-formulation procedures, implemented in the gwf-lak-implicit
315  ! submodule (submodules/gwf-lak-implicit.f90)
316  interface
317  module subroutine lak_budget_nogwf(this, n, stage, b)
318  class(laktype), intent(inout) :: this
319  integer(I4B), intent(in) :: n
320  real(dp), intent(in) :: stage
321  real(dp), intent(inout) :: b
322  end subroutine
323  end interface
324 
325  interface
326  module subroutine lak_fc_implicit(this, rhs, matrix_sln)
327  class(laktype) :: this
328  real(dp), dimension(:), intent(inout) :: rhs
329  class(matrixbasetype), pointer :: matrix_sln
330  end subroutine
331  end interface
332 
333  interface
334  module subroutine lak_set_legacy(this, kiter, icnvgmod)
335  class(laktype), intent(inout) :: this
336  integer(I4B), intent(in) :: kiter !< outer (Picard) iteration number
337  integer(I4B), intent(in) :: icnvgmod !< 0 if the model has not converged
338  end subroutine
339  end interface
340 
341  interface
342  module subroutine lak_check_disconnected(this)
343  class(laktype), intent(inout) :: this
344  end subroutine
345  end interface
346 
347 contains
348 
349  !> @brief Create a new LAK Package and point bndobj to the new package
350  !<
351  subroutine lak_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
352  ! -- dummy
353  class(bndtype), pointer :: packobj
354  integer(I4B), intent(in) :: id
355  integer(I4B), intent(in) :: ibcnum
356  integer(I4B), intent(in) :: inunit
357  integer(I4B), intent(in) :: iout
358  character(len=*), intent(in) :: namemodel
359  character(len=*), intent(in) :: pakname
360  ! -- local
361  type(laktype), pointer :: lakobj
362  !
363  ! -- allocate the object and assign values to object variables
364  allocate (lakobj)
365  packobj => lakobj
366  !
367  ! -- create name and memory path
368  call packobj%set_names(ibcnum, namemodel, pakname, ftype)
369  packobj%text = text
370  !
371  ! -- allocate scalars
372  call lakobj%lak_allocate_scalars()
373  !
374  ! -- initialize package
375  call packobj%pack_initialize()
376  !
377  packobj%inunit = inunit
378  packobj%iout = iout
379  packobj%id = id
380  packobj%ibcnum = ibcnum
381  packobj%ncolbnd = 3
382  packobj%iscloc = 0 ! not supported
383  packobj%isadvpak = 1
384  packobj%ictMemPath = create_mem_path(namemodel, 'NPF')
385  end subroutine lak_create
386 
387  !> @brief Allocate scalar members
388  !<
389  subroutine lak_allocate_scalars(this)
390  ! -- dummy
391  class(laktype), intent(inout) :: this
392  !
393  ! -- call standard BndType allocate scalars
394  call this%BndType%allocate_scalars()
395  !
396  ! -- allocate the object and assign values to object variables
397  call mem_allocate(this%iprhed, 'IPRHED', this%memoryPath)
398  call mem_allocate(this%istageout, 'ISTAGEOUT', this%memoryPath)
399  call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%memoryPath)
400  call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath)
401  call mem_allocate(this%ipakcsv, 'IPAKCSV', this%memoryPath)
402  call mem_allocate(this%nlakes, 'NLAKES', this%memoryPath)
403  call mem_allocate(this%noutlets, 'NOUTLETS', this%memoryPath)
404  call mem_allocate(this%ntables, 'NTABLES', this%memoryPath)
405  call mem_allocate(this%convlength, 'CONVLENGTH', this%memoryPath)
406  call mem_allocate(this%convtime, 'CONVTIME', this%memoryPath)
407  call mem_allocate(this%outdmax, 'OUTDMAX', this%memoryPath)
408  call mem_allocate(this%igwhcopt, 'IGWHCOPT', this%memoryPath)
409  call mem_allocate(this%iconvchk, 'ICONVCHK', this%memoryPath)
410  call mem_allocate(this%maxlakit, 'MAXLAKIT', this%memoryPath)
411  call mem_allocate(this%surfdep, 'SURFDEP', this%memoryPath)
412  call mem_allocate(this%dmaxchg, 'DMAXCHG', this%memoryPath)
413  call mem_allocate(this%delh, 'DELH', this%memoryPath)
414  call mem_allocate(this%check_attr, 'CHECK_ATTR', this%memoryPath)
415  call mem_allocate(this%iimplicit, 'IIMPLICIT', this%memoryPath)
416  call mem_allocate(this%iforceleg, 'IFORCELEG', this%memoryPath)
417  call mem_allocate(this%iforceleglak, 'IFORCELEGLAK', this%memoryPath)
418  call mem_allocate(this%bditems, 'BDITEMS', this%memoryPath)
419  call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%memoryPath)
420  call mem_allocate(this%idense, 'IDENSE', this%memoryPath)
421  !
422  ! -- Set values
423  this%iprhed = 0
424  this%istageout = 0
425  this%ibudgetout = 0
426  this%ibudcsv = 0
427  this%ipakcsv = 0
428  this%nlakes = 0
429  this%noutlets = 0
430  this%ntables = 0
431  this%convlength = done
432  this%convtime = done
433  this%outdmax = dzero
434  this%igwhcopt = 0
435  this%iconvchk = 1
436  this%maxlakit = maxadpit
437  this%surfdep = dzero
438  this%dmaxchg = dem5
439  this%delh = dp999 * this%dmaxchg
440  this%iimplicit = 0
441  this%iforceleg = 0
442  this%iforceleglak = 0
443  this%bditems = 11
444  this%cbcauxitems = 1
445  this%idense = 0
446  this%ivsc = 0
447  end subroutine lak_allocate_scalars
448 
449  !> @brief Allocate scalar members
450  !<
451  subroutine lak_allocate_arrays(this)
452  ! -- modules
453  ! -- dummy
454  class(laktype), intent(inout) :: this
455  ! -- local
456  integer(I4B) :: i
457  !
458  ! -- call standard BndType allocate scalars
459  call this%BndType%allocate_arrays()
460  !
461  ! -- allocate character array for budget text
462  allocate (this%clakbudget(this%bditems))
463  !
464  !-- fill clakbudget
465  this%clakbudget(1) = ' GWF'
466  this%clakbudget(2) = ' RAINFALL'
467  this%clakbudget(3) = ' EVAPORATION'
468  this%clakbudget(4) = ' RUNOFF'
469  this%clakbudget(5) = ' EXT-INFLOW'
470  this%clakbudget(6) = ' WITHDRAWAL'
471  this%clakbudget(7) = ' EXT-OUTFLOW'
472  this%clakbudget(8) = ' STORAGE'
473  this%clakbudget(9) = ' CONSTANT'
474  this%clakbudget(10) = ' FROM-MVR'
475  this%clakbudget(11) = ' TO-MVR'
476  !
477  ! -- allocate and initialize dbuff
478  if (this%istageout > 0) then
479  call mem_allocate(this%dbuff, this%nlakes, 'DBUFF', this%memoryPath)
480  do i = 1, this%nlakes
481  this%dbuff(i) = dzero
482  end do
483  else
484  call mem_allocate(this%dbuff, 0, 'DBUFF', this%memoryPath)
485  end if
486  !
487  ! -- allocate character array for budget text
488  allocate (this%cauxcbc(this%cbcauxitems))
489  !
490  ! -- allocate and initialize qauxcbc
491  call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%memoryPath)
492  do i = 1, this%cbcauxitems
493  this%qauxcbc(i) = dzero
494  end do
495  !
496  ! -- allocate qleak and qsto
497  call mem_allocate(this%qleak, this%maxbound, 'QLEAK', this%memoryPath)
498  do i = 1, this%maxbound
499  this%qleak(i) = dzero
500  end do
501  ! -- holdconn is only used by the implicit legacy-switch detector; allocate it at
502  ! size 0 otherwise so legacy LAK runs do not pay the maxbound memory cost
503  if (this%iimplicit /= 0) then
504  call mem_allocate(this%holdconn, this%maxbound, 'HOLDCONN', this%memoryPath)
505  do i = 1, this%maxbound
506  this%holdconn(i) = dzero
507  end do
508  else
509  call mem_allocate(this%holdconn, 0, 'HOLDCONN', this%memoryPath)
510  end if
511  call mem_allocate(this%qsto, this%nlakes, 'QSTO', this%memoryPath)
512  do i = 1, this%nlakes
513  this%qsto(i) = dzero
514  end do
515  !
516  ! -- allocate denseterms to size 0
517  call mem_allocate(this%denseterms, 3, 0, 'DENSETERMS', this%memoryPath)
518  !
519  ! -- allocate viscratios to size 0
520  call mem_allocate(this%viscratios, 2, 0, 'VISCRATIOS', this%memoryPath)
521  end subroutine lak_allocate_arrays
522 
523  !> @brief Read the dimensions for this package
524  !<
525  subroutine lak_read_lakes(this)
526  ! -- modules
527  use constantsmodule, only: linelength
528  use simmodule, only: store_error, count_errors, store_error_unit
529  use timeseriesmanagermodule, only: read_value_or_time_series_adv
530  ! -- dummy
531  class(laktype), intent(inout) :: this
532  ! -- local
533  character(len=LINELENGTH) :: text
534  character(len=LENBOUNDNAME) :: bndName, bndNameTemp
535  character(len=9) :: cno
536  character(len=50), dimension(:), allocatable :: caux
537  integer(I4B) :: ierr, ival
538  logical(LGP) :: isfound, endOfBlock
539  integer(I4B) :: n
540  integer(I4B) :: ii, jj
541  integer(I4B) :: iaux
542  integer(I4B) :: itmp
543  integer(I4B) :: nlak
544  integer(I4B) :: nconn
545  integer(I4B), dimension(:), pointer, contiguous :: nboundchk
546  real(DP), pointer :: bndElem => null()
547  !
548  ! -- initialize itmp
549  itmp = 0
550  !
551  ! -- allocate lake data
552  call mem_allocate(this%nlakeconn, this%nlakes, 'NLAKECONN', this%memoryPath)
553  call mem_allocate(this%idxlakeconn, this%nlakes + 1, 'IDXLAKECONN', &
554  this%memoryPath)
555  call mem_allocate(this%ntabrow, this%nlakes, 'NTABROW', this%memoryPath)
556  call mem_allocate(this%strt, this%nlakes, 'STRT', this%memoryPath)
557  call mem_allocate(this%laketop, this%nlakes, 'LAKETOP', this%memoryPath)
558  call mem_allocate(this%lakebot, this%nlakes, 'LAKEBOT', this%memoryPath)
559  call mem_allocate(this%sareamax, this%nlakes, 'SAREAMAX', this%memoryPath)
560  call mem_allocate(this%stage, this%nlakes, 'STAGE', this%memoryPath)
561  call mem_allocate(this%rainfall, this%nlakes, 'RAINFALL', this%memoryPath)
562  call mem_allocate(this%evaporation, this%nlakes, 'EVAPORATION', &
563  this%memoryPath)
564  call mem_allocate(this%runoff, this%nlakes, 'RUNOFF', this%memoryPath)
565  call mem_allocate(this%inflow, this%nlakes, 'INFLOW', this%memoryPath)
566  call mem_allocate(this%withdrawal, this%nlakes, 'WITHDRAWAL', this%memoryPath)
567  call mem_allocate(this%lauxvar, this%naux, this%nlakes, 'LAUXVAR', &
568  this%memoryPath)
569  call mem_allocate(this%avail, this%nlakes, 'AVAIL', this%memoryPath)
570  call mem_allocate(this%lkgwsink, this%nlakes, 'LKGWSINK', this%memoryPath)
571  call mem_allocate(this%ncncvr, this%nlakes, 'NCNCVR', this%memoryPath)
572  call mem_allocate(this%ilegacy, this%nlakes, 'ILEGACY', this%memoryPath)
573  call mem_allocate(this%nstuck, this%nlakes, 'NSTUCK', this%memoryPath)
574  call mem_allocate(this%surfin, this%nlakes, 'SURFIN', this%memoryPath)
575  call mem_allocate(this%surfout, this%nlakes, 'SURFOUT', this%memoryPath)
576  call mem_allocate(this%surfout1, this%nlakes, 'SURFOUT1', this%memoryPath)
577  call mem_allocate(this%precip, this%nlakes, 'PRECIP', this%memoryPath)
578  call mem_allocate(this%precip1, this%nlakes, 'PRECIP1', this%memoryPath)
579  call mem_allocate(this%evap, this%nlakes, 'EVAP', this%memoryPath)
580  call mem_allocate(this%evap1, this%nlakes, 'EVAP1', this%memoryPath)
581  call mem_allocate(this%evapo, this%nlakes, 'EVAPO', this%memoryPath)
582  call mem_allocate(this%withr, this%nlakes, 'WITHR', this%memoryPath)
583  call mem_allocate(this%withr1, this%nlakes, 'WITHR1', this%memoryPath)
584  call mem_allocate(this%flwin, this%nlakes, 'FLWIN', this%memoryPath)
585  call mem_allocate(this%flwiter, this%nlakes, 'FLWITER', this%memoryPath)
586  call mem_allocate(this%flwiter1, this%nlakes, 'FLWITER1', this%memoryPath)
587  call mem_allocate(this%seep, this%nlakes, 'SEEP', this%memoryPath)
588  call mem_allocate(this%seep1, this%nlakes, 'SEEP1', this%memoryPath)
589  call mem_allocate(this%seep0, this%nlakes, 'SEEP0', this%memoryPath)
590  call mem_allocate(this%stageiter, this%nlakes, 'STAGEITER', this%memoryPath)
591  call mem_allocate(this%chterm, this%nlakes, 'CHTERM', this%memoryPath)
592  !
593  ! -- lake boundary and stages. In the implicit formulation iboundpak
594  ! and xnewpak are aliased to slices of the global ibound/x vectors in
595  ! lak_set_pointers (called before this routine), so they are not
596  ! allocated here.
597  if (this%iimplicit == 0) then
598  call mem_allocate(this%iboundpak, this%nlakes, 'IBOUND', this%memoryPath)
599  call mem_allocate(this%xnewpak, this%nlakes, 'XNEWPAK', this%memoryPath)
600  end if
601  call mem_allocate(this%xoldpak, this%nlakes, 'XOLDPAK', this%memoryPath)
602  !
603  ! -- lake iteration variables
604  call mem_allocate(this%iseepc, this%nlakes, 'ISEEPC', this%memoryPath)
605  call mem_allocate(this%idhc, this%nlakes, 'IDHC', this%memoryPath)
606  call mem_allocate(this%en1, this%nlakes, 'EN1', this%memoryPath)
607  call mem_allocate(this%en2, this%nlakes, 'EN2', this%memoryPath)
608  call mem_allocate(this%r1, this%nlakes, 'R1', this%memoryPath)
609  call mem_allocate(this%r2, this%nlakes, 'R2', this%memoryPath)
610  call mem_allocate(this%dh0, this%nlakes, 'DH0', this%memoryPath)
611  call mem_allocate(this%s0, this%nlakes, 'S0', this%memoryPath)
612  call mem_allocate(this%qgwf0, this%nlakes, 'QGWF0', this%memoryPath)
613  !
614  ! -- allocate character storage not managed by the memory manager
615  allocate (this%lakename(this%nlakes)) ! ditch after boundnames allocated??
616  allocate (this%status(this%nlakes))
617  !
618  do n = 1, this%nlakes
619  this%ntabrow(n) = 0
620  this%status(n) = 'ACTIVE'
621  this%laketop(n) = -dep20
622  this%lakebot(n) = dep20
623  this%sareamax(n) = dzero
624  ! -- in the implicit formulation iboundpak/xnewpak are not yet associated
625  ! (they are aliased to the global arrays later in lak_set_pointers and
626  ! initialized in lak_read_initial_attr); only touch them here for the
627  ! legacy formulation
628  if (this%iimplicit == 0) then
629  this%iboundpak(n) = 1
630  this%xnewpak(n) = dep20
631  end if
632  this%xoldpak(n) = dep20
633  !
634  ! -- initialize boundary values to zero
635  this%rainfall(n) = dzero
636  this%evaporation(n) = dzero
637  this%runoff(n) = dzero
638  this%inflow(n) = dzero
639  this%withdrawal(n) = dzero
640  this%ilegacy(n) = 0
641  this%nstuck(n) = 0
642  end do
643  !
644  ! -- allocate local storage for aux variables
645  if (this%naux > 0) then
646  allocate (caux(this%naux))
647  end if
648  !
649  ! -- allocate and initialize temporary variables
650  allocate (nboundchk(this%nlakes))
651  do n = 1, this%nlakes
652  nboundchk(n) = 0
653  end do
654  !
655  ! -- read lake well data
656  ! -- get lakes block
657  call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, &
658  supportopenclose=.true.)
659  !
660  ! -- parse locations block if detected
661  if (isfound) then
662  write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// &
663  ' PACKAGEDATA'
664  nlak = 0
665  nconn = 0
666  do
667  call this%parser%GetNextLine(endofblock)
668  if (endofblock) exit
669  n = this%parser%GetInteger()
670  !
671  if (n < 1 .or. n > this%nlakes) then
672  write (errmsg, '(a,1x,i0)') 'lakeno MUST BE > 0 and <= ', this%nlakes
673  call store_error(errmsg)
674  cycle
675  end if
676  !
677  ! -- increment nboundchk
678  nboundchk(n) = nboundchk(n) + 1
679  !
680  ! -- strt
681  this%strt(n) = this%parser%GetDouble()
682  !
683  ! nlakeconn
684  ival = this%parser%GetInteger()
685  !
686  if (ival < 0) then
687  write (errmsg, '(a,1x,i0)') 'nlakeconn MUST BE >= 0 for lake ', n
688  call store_error(errmsg)
689  end if
690  !
691  ! -- the IMPLICIT formulation solves the lake stage as a matrix unknown,
692  ! which requires at least one groundwater connection to give the lake
693  ! row a non-zero diagonal; a lake with no connections is not supported
694  if (this%iimplicit /= 0 .and. ival == 0) then
695  write (errmsg, '(a,1x,i0,1x,a)') &
696  'lake', n, 'has no connections; the IMPLICIT option requires &
697  &each lake to have at least one GWF connection.'
698  call store_error(errmsg)
699  end if
700  !
701  nconn = nconn + ival
702  this%nlakeconn(n) = ival
703  !
704  ! -- get aux data
705  do iaux = 1, this%naux
706  call this%parser%GetString(caux(iaux))
707  end do
708  !
709  ! -- set default bndName
710  write (cno, '(i9.9)') n
711  bndname = 'Lake'//cno
712  !
713  ! -- lakename
714  if (this%inamedbound /= 0) then
715  call this%parser%GetStringCaps(bndnametemp)
716  if (bndnametemp /= '') then
717  bndname = bndnametemp
718  end if
719  end if
720  this%lakename(n) = bndname
721  !
722  ! -- fill time series aware data
723  ! -- fill aux data
724  do jj = 1, this%naux
725  text = caux(jj)
726  ii = n
727  bndelem => this%lauxvar(jj, ii)
728  call read_value_or_time_series_adv(text, ii, jj, bndelem, &
729  this%packName, 'AUX', &
730  this%tsManager, this%iprpak, &
731  this%auxname(jj))
732  end do
733  !
734  nlak = nlak + 1
735  end do
736  !
737  ! -- check for duplicate or missing lakes
738  do n = 1, this%nlakes
739  if (nboundchk(n) == 0) then
740  write (errmsg, '(a,1x,i0)') 'NO DATA SPECIFIED FOR LAKE', n
741  call store_error(errmsg)
742  else if (nboundchk(n) > 1) then
743  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
744  'DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES'
745  call store_error(errmsg)
746  end if
747  end do
748  !
749  write (this%iout, '(1x,a)') 'END OF '//trim(adjustl(this%text))// &
750  ' PACKAGEDATA'
751  else
752  call store_error('REQUIRED PACKAGEDATA BLOCK NOT FOUND.')
753  end if
754  !
755  ! -- terminate if any errors were detected
756  if (count_errors() > 0) then
757  call this%parser%StoreErrorUnit()
758  end if
759  !
760  ! -- set MAXBOUND
761  this%MAXBOUND = nconn
762  write (this%iout, '(//4x,a,i7)') 'MAXBOUND = ', this%maxbound
763  !
764  ! -- set idxlakeconn
765  this%idxlakeconn(1) = 1
766  do n = 1, this%nlakes
767  this%idxlakeconn(n + 1) = this%idxlakeconn(n) + this%nlakeconn(n)
768  end do
769  !
770  ! -- deallocate local storage for aux variables
771  if (this%naux > 0) then
772  deallocate (caux)
773  end if
774  !
775  ! -- deallocate local storage for nboundchk
776  deallocate (nboundchk)
777  end subroutine lak_read_lakes
778 
779  !> @brief Read the lake connections for this package
780  !<
781  subroutine lak_read_lake_connections(this)
782  use constantsmodule, only: linelength, lenvarname
783  use simmodule, only: store_error, count_errors
784  ! -- dummy
785  class(laktype), intent(inout) :: this
786  ! -- local
787  character(len=LINELENGTH) :: keyword, cellid
788  integer(I4B) :: ierr, ival
789  logical(LGP) :: isfound, endOfBlock
790  logical(LGP) :: is_lake_bed
791  real(DP) :: rval
792  integer(I4B) :: j, n
793  integer(I4B) :: nn
794  integer(I4B) :: ipos, ipos0
795  integer(I4B) :: icellid, icellid0
796  real(DP) :: top
797  real(DP) :: bot
798  integer(I4B), dimension(:), pointer, contiguous :: nboundchk
799  character(len=LENVARNAME) :: ctypenm
800  !
801  ! -- allocate local storage
802  allocate (nboundchk(this%MAXBOUND))
803  do n = 1, this%MAXBOUND
804  nboundchk(n) = 0
805  end do
806  !
807  ! -- get connectiondata block
808  call this%parser%GetBlock('CONNECTIONDATA', isfound, ierr, &
809  supportopenclose=.true.)
810  !
811  ! -- parse connectiondata block if detected
812  if (isfound) then
813  ! -- allocate connection data using memory manager
814  call mem_allocate(this%imap, this%MAXBOUND, 'IMAP', this%memoryPath)
815  call mem_allocate(this%cellid, this%MAXBOUND, 'CELLID', this%memoryPath)
816  call mem_allocate(this%nodesontop, this%MAXBOUND, 'NODESONTOP', &
817  this%memoryPath)
818  call mem_allocate(this%ictype, this%MAXBOUND, 'ICTYPE', this%memoryPath)
819  call mem_allocate(this%bedleak, this%MAXBOUND, 'BEDLEAK', this%memoryPath) ! don't need to save this - use a temporary vector
820  call mem_allocate(this%belev, this%MAXBOUND, 'BELEV', this%memoryPath)
821  call mem_allocate(this%telev, this%MAXBOUND, 'TELEV', this%memoryPath)
822  call mem_allocate(this%connlength, this%MAXBOUND, 'CONNLENGTH', &
823  this%memoryPath)
824  call mem_allocate(this%connwidth, this%MAXBOUND, 'CONNWIDTH', &
825  this%memoryPath)
826  call mem_allocate(this%sarea, this%MAXBOUND, 'SAREA', this%memoryPath)
827  call mem_allocate(this%warea, this%MAXBOUND, 'WAREA', this%memoryPath)
828  call mem_allocate(this%satcond, this%MAXBOUND, 'SATCOND', this%memoryPath)
829  call mem_allocate(this%simcond, this%MAXBOUND, 'SIMCOND', this%memoryPath)
830  call mem_allocate(this%simlakgw, this%MAXBOUND, 'SIMLAKGW', this%memoryPath)
831  !
832  ! -- process the lake connection data
833  write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// &
834  ' LAKE_CONNECTIONS'
835  do
836  call this%parser%GetNextLine(endofblock)
837  if (endofblock) exit
838  n = this%parser%GetInteger()
839  !
840  if (n < 1 .or. n > this%nlakes) then
841  write (errmsg, '(a,1x,i0)') 'lakeno MUST BE > 0 and <= ', this%nlakes
842  call store_error(errmsg)
843  cycle
844  end if
845  !
846  ! -- read connection number
847  ival = this%parser%GetInteger()
848  if (ival < 1 .or. ival > this%nlakeconn(n)) then
849  write (errmsg, '(a,1x,i0,1x,a,1x,i0)') &
850  'iconn FOR LAKE ', n, 'MUST BE > 1 and <= ', this%nlakeconn(n)
851  call store_error(errmsg)
852  cycle
853  end if
854  !
855  j = ival
856  ipos = this%idxlakeconn(n) + ival - 1
857  !
858  ! -- set imap
859  this%imap(ipos) = n
860  !
861  !
862  ! -- increment nboundchk
863  nboundchk(ipos) = nboundchk(ipos) + 1
864  !
865  ! -- read gwfnodes from the line
866  call this%parser%GetCellid(this%dis%ndim, cellid)
867  nn = this%dis%noder_from_cellid(cellid, &
868  this%parser%iuactive, this%iout)
869  !
870  ! -- determine if a valid cell location was provided
871  if (nn < 1) then
872  write (errmsg, '(a,1x,i0,1x,a,1x,i0)') &
873  'INVALID cellid FOR LAKE ', n, 'connection', j
874  call store_error(errmsg)
875  end if
876  !
877  ! -- set gwf cellid for connection
878  this%cellid(ipos) = nn
879  this%nodesontop(ipos) = nn
880  !
881  ! -- read ictype
882  call this%parser%GetStringCaps(keyword)
883  select case (keyword)
884  case ('VERTICAL')
885  this%ictype(ipos) = 0
886  case ('HORIZONTAL')
887  this%ictype(ipos) = 1
888  case ('EMBEDDEDH')
889  this%ictype(ipos) = 2
890  case ('EMBEDDEDV')
891  this%ictype(ipos) = 3
892  case default
893  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,a,a)') &
894  'UNKNOWN ctype FOR LAKE ', n, 'connection', j, &
895  '(', trim(keyword), ')'
896  call store_error(errmsg)
897  end select
898  write (ctypenm, '(a16)') keyword
899  !
900  ! -- bed leakance
901  !this%bedleak(ipos) = this%parser%GetDouble() !TODO: use this when NONE keyword deprecated
902  call this%parser%GetStringCaps(keyword)
903  select case (keyword)
904  case ('NONE')
905  is_lake_bed = .false.
906  this%bedleak(ipos) = dnodata
907  !
908  ! -- create warning message
909  write (warnmsg, '(2(a,1x,i0,1x),a,1pe8.1,a)') &
910  'BEDLEAK for connection', j, 'in lake', n, 'is specified to '// &
911  'be NONE. Lake connections where the lake-GWF connection '// &
912  'conductance is solely a function of aquifer properties '// &
913  'in the connected GWF cell should be specified with a '// &
914  'DNODATA (', dnodata, ') value.'
915  !
916  ! -- create deprecation warning
917  call deprecation_warning('CONNECTIONDATA', 'bedleak=NONE', '6.4.3', &
918  warnmsg, this%parser%GetUnit())
919  case default
920  read (keyword, *) rval
921  if (is_close(rval, dnodata)) then
922  is_lake_bed = .false.
923  else
924  is_lake_bed = .true.
925  end if
926  this%bedleak(ipos) = rval
927  end select
928  !
929  if (is_lake_bed .and. this%bedleak(ipos) < dzero) then
930  write (errmsg, '(a,1x,i0,1x,a)') 'bedleak FOR LAKE ', n, 'MUST BE >= 0'
931  call store_error(errmsg)
932  end if
933  !
934  ! -- belev
935  this%belev(ipos) = this%parser%GetDouble()
936  !
937  ! -- telev
938  this%telev(ipos) = this%parser%GetDouble()
939  !
940  ! -- connection length
941  rval = this%parser%GetDouble()
942  if (rval <= dzero) then
943  if (this%ictype(ipos) == 1 .or. this%ictype(ipos) == 2 .or. &
944  this%ictype(ipos) == 3) then
945  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,a,1x,a)') &
946  'connection length (connlen) FOR LAKE ', n, &
947  ', CONNECTION NO.', j, ', MUST BE > 0 FOR SPECIFIED ', &
948  'connection type (ctype)', ctypenm
949  call store_error(errmsg)
950  else
951  rval = dzero
952  end if
953  end if
954  this%connlength(ipos) = rval
955  !
956  ! -- connection width
957  rval = this%parser%GetDouble()
958  if (rval < dzero) then
959  if (this%ictype(ipos) == 1) then
960  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
961  'cell width (connwidth) FOR LAKE ', n, &
962  ' HORIZONTAL CONNECTION ', j, 'MUST BE >= 0'
963  call store_error(errmsg)
964  else
965  rval = dzero
966  end if
967  end if
968  this%connwidth(ipos) = rval
969  end do
970  write (this%iout, '(1x,a)') &
971  'END OF '//trim(adjustl(this%text))//' CONNECTIONDATA'
972  else
973  call store_error('REQUIRED CONNECTIONDATA BLOCK NOT FOUND.')
974  end if
975  !
976  ! -- terminate if any errors were detected
977  if (count_errors() > 0) then
978  call this%parser%StoreErrorUnit()
979  end if
980  !
981  ! -- check that embedded lakes have only one connection
982  do n = 1, this%nlakes
983  j = 0
984  do ipos = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
985  if (this%ictype(ipos) /= 2 .and. this%ictype(ipos) /= 3) cycle
986  j = j + 1
987  if (j > 1) then
988  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
989  'nlakeconn FOR LAKE', n, 'EMBEDDED CONNECTION', j, ' EXCEEDS 1.'
990  call store_error(errmsg)
991  end if
992  end do
993  end do
994  ! -- check that an embedded lake is not in the same cell as a lake
995  ! with a vertical connection
996  do n = 1, this%nlakes
997  ipos0 = this%idxlakeconn(n)
998  icellid0 = this%cellid(ipos0)
999  if (this%ictype(ipos0) /= 2 .and. this%ictype(ipos0) /= 3) cycle
1000  do nn = 1, this%nlakes
1001  if (nn == n) cycle
1002  j = 0
1003  do ipos = this%idxlakeconn(nn), this%idxlakeconn(nn + 1) - 1
1004  j = j + 1
1005  icellid = this%cellid(ipos)
1006  if (icellid == icellid0) then
1007  if (this%ictype(ipos) == 0) then
1008  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') &
1009  'EMBEDDED LAKE', n, &
1010  'CANNOT COINCIDE WITH VERTICAL CONNECTION', j, &
1011  'IN LAKE', nn, '.'
1012  call store_error(errmsg)
1013  end if
1014  end if
1015  end do
1016  end do
1017  end do
1018  !
1019  ! -- process the data
1020  do n = 1, this%nlakes
1021  j = 0
1022  do ipos = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
1023  j = j + 1
1024  nn = this%cellid(ipos)
1025  top = this%dis%top(nn)
1026  bot = this%dis%bot(nn)
1027  ! vertical connection
1028  if (this%ictype(ipos) == 0) then
1029  this%telev(ipos) = top + this%surfdep
1030  this%belev(ipos) = top
1031  this%lakebot(n) = min(this%belev(ipos), this%lakebot(n))
1032  ! horizontal connection
1033  else if (this%ictype(ipos) == 1) then
1034  if (this%belev(ipos) == this%telev(ipos)) then
1035  this%telev(ipos) = top
1036  this%belev(ipos) = bot
1037  else
1038  if (this%belev(ipos) >= this%telev(ipos)) then
1039  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
1040  'telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, &
1041  'MUST BE >= belev'
1042  call store_error(errmsg)
1043  else if (this%belev(ipos) < bot) then
1044  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,g15.7,1x,a)') &
1045  'belev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, &
1046  'MUST BE >= cell bottom (', bot, ')'
1047  call store_error(errmsg)
1048  else if (this%telev(ipos) > top) then
1049  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,g15.7,1x,a)') &
1050  'telev FOR LAKE ', n, ' HORIZONTAL CONNECTION ', j, &
1051  'MUST BE <= cell top (', top, ')'
1052  call store_error(errmsg)
1053  end if
1054  end if
1055  this%laketop(n) = max(this%telev(ipos), this%laketop(n))
1056  this%lakebot(n) = min(this%belev(ipos), this%lakebot(n))
1057  ! embedded connections
1058  else if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then
1059  this%telev(ipos) = top
1060  this%belev(ipos) = bot
1061  this%lakebot(n) = bot
1062  end if
1063  !
1064  ! -- check for missing or duplicate lake connections
1065  if (nboundchk(ipos) == 0) then
1066  write (errmsg, '(a,1x,i0,1x,a,1x,i0)') &
1067  'NO DATA SPECIFIED FOR LAKE', n, 'CONNECTION', j
1068  call store_error(errmsg)
1069  else if (nboundchk(ipos) > 1) then
1070  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a,1x,i0,1x,a)') &
1071  'DATA FOR LAKE', n, 'CONNECTION', j, &
1072  'SPECIFIED', nboundchk(ipos), 'TIMES'
1073  call store_error(errmsg)
1074  end if
1075  !
1076  ! -- set laketop if it has not been assigned
1077  end do
1078  if (this%laketop(n) == -dep20) then
1079  this%laketop(n) = this%lakebot(n) + 100.
1080  end if
1081  end do
1082  !
1083  ! -- deallocate local variable
1084  deallocate (nboundchk)
1085  !
1086  ! -- write summary of lake_connection error messages
1087  if (count_errors() > 0) then
1088  call this%parser%StoreErrorUnit()
1089  end if
1090  end subroutine lak_read_lake_connections
1091 
1092  !> @brief Read the lake tables for this package
1093  !<
1094  subroutine lak_read_tables(this)
1095  use constantsmodule, only: linelength
1096  use simmodule, only: store_error, count_errors
1097  ! -- dummy
1098  class(laktype), intent(inout) :: this
1099  ! -- local
1100  type(laktabtype), dimension(:), allocatable :: laketables
1101  character(len=LINELENGTH) :: line
1102  character(len=LINELENGTH) :: keyword
1103  integer(I4B) :: ierr
1104  logical(LGP) :: isfound, endOfBlock
1105  integer(I4B) :: n
1106  integer(I4B) :: iconn
1107  integer(I4B) :: ntabs
1108  integer(I4B), dimension(:), pointer, contiguous :: nboundchk
1109  !
1110  ! -- skip of no outlets
1111  if (this%ntables < 1) return
1112  !
1113  ! -- allocate and initialize nboundchk
1114  allocate (nboundchk(this%nlakes))
1115  do n = 1, this%nlakes
1116  nboundchk(n) = 0
1117  end do
1118  !
1119  ! -- allocate derived type for table data
1120  allocate (laketables(this%nlakes))
1121  !
1122  ! -- get lake_tables block
1123  call this%parser%GetBlock('TABLES', isfound, ierr, &
1124  supportopenclose=.true.)
1125  !
1126  ! -- parse lake_tables block if detected
1127  if (isfound) then
1128  ntabs = 0
1129  ! -- process the lake table data
1130  write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// &
1131  ' LAKE_TABLES'
1132  readtable: do
1133  call this%parser%GetNextLine(endofblock)
1134  if (endofblock) exit
1135  n = this%parser%GetInteger()
1136  !
1137  if (n < 1 .or. n > this%nlakes) then
1138  write (errmsg, '(a,1x,i0)') 'lakeno MUST BE > 0 and <= ', this%nlakes
1139  call store_error(errmsg)
1140  cycle readtable
1141  end if
1142  !
1143  ! -- increment ntab and nboundchk
1144  ntabs = ntabs + 1
1145  nboundchk(n) = nboundchk(n) + 1
1146  !
1147  ! -- read FILE keyword
1148  call this%parser%GetStringCaps(keyword)
1149  select case (keyword)
1150  case ('TAB6')
1151  call this%parser%GetStringCaps(keyword)
1152  if (trim(adjustl(keyword)) /= 'FILEIN') then
1153  errmsg = 'TAB6 keyword must be followed by "FILEIN" '// &
1154  'then by filename.'
1155  call store_error(errmsg)
1156  cycle readtable
1157  end if
1158  call this%parser%GetString(line)
1159  call this%lak_read_table(n, line, laketables(n))
1160  case default
1161  write (errmsg, '(a,1x,i0,1x,a)') &
1162  'LAKE TABLE ENTRY for LAKE ', n, 'MUST INCLUDE TAB6 KEYWORD'
1163  call store_error(errmsg)
1164  cycle readtable
1165  end select
1166  end do readtable
1167  !
1168  write (this%iout, '(1x,a)') &
1169  'END OF '//trim(adjustl(this%text))//' LAKE_TABLES'
1170  !
1171  ! -- check for missing or duplicate lake connections
1172  if (ntabs < this%ntables) then
1173  write (errmsg, '(a,1x,i0,1x,a,1x,i0)') &
1174  'TABLE DATA ARE SPECIFIED', ntabs, &
1175  'TIMES BUT NTABLES IS SET TO', this%ntables
1176  call store_error(errmsg)
1177  end if
1178  do n = 1, this%nlakes
1179  if (this%ntabrow(n) > 0 .and. nboundchk(n) > 1) then
1180  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
1181  'TABLE DATA FOR LAKE', n, 'SPECIFIED', nboundchk(n), 'TIMES'
1182  call store_error(errmsg)
1183  end if
1184  end do
1185  else
1186  call store_error('REQUIRED TABLES BLOCK NOT FOUND.')
1187  end if
1188  !
1189  ! -- deallocate local storage
1190  deallocate (nboundchk)
1191  !
1192  ! -- write summary of lake_table error messages
1193  if (count_errors() > 0) then
1194  call this%parser%StoreErrorUnit()
1195  end if
1196  !
1197  ! -- convert laketables to vectors
1198  call this%laktables_to_vectors(laketables)
1199  !
1200  ! -- destroy laketables
1201  do n = 1, this%nlakes
1202  if (this%ntabrow(n) > 0) then
1203  deallocate (laketables(n)%tabstage)
1204  deallocate (laketables(n)%tabvolume)
1205  deallocate (laketables(n)%tabsarea)
1206  iconn = this%idxlakeconn(n)
1207  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
1208  deallocate (laketables(n)%tabwarea)
1209  end if
1210  end if
1211  end do
1212  deallocate (laketables)
1213  end subroutine lak_read_tables
1214 
1215  !> @brief Copy the laketables structure data into flattened vectors that are
1216  !! stored in the memory manager
1217  !<
1218  subroutine laktables_to_vectors(this, laketables)
1219  class(laktype), intent(inout) :: this
1220  type(laktabtype), intent(in), dimension(:), contiguous :: laketables
1221  integer(I4B) :: n
1222  integer(I4B) :: ntabrows
1223  integer(I4B) :: j
1224  integer(I4B) :: ipos
1225  integer(I4B) :: iconn
1226  !
1227  ! -- allocate index array for lak tables
1228  call mem_allocate(this%ialaktab, this%nlakes + 1, 'IALAKTAB', this%memoryPath)
1229  !
1230  ! -- Move the laktables structure information into flattened arrays
1231  this%ialaktab(1) = 1
1232  do n = 1, this%nlakes
1233  ! -- ialaktab contains a pointer into the flattened lak table data
1234  this%ialaktab(n + 1) = this%ialaktab(n) + this%ntabrow(n)
1235  end do
1236  !
1237  ! -- Allocate vectors for storing all lake table data
1238  ntabrows = this%ialaktab(this%nlakes + 1) - 1
1239  call mem_allocate(this%tabstage, ntabrows, 'TABSTAGE', this%memoryPath)
1240  call mem_allocate(this%tabvolume, ntabrows, 'TABVOLUME', this%memoryPath)
1241  call mem_allocate(this%tabsarea, ntabrows, 'TABSAREA', this%memoryPath)
1242  call mem_allocate(this%tabwarea, ntabrows, 'TABWAREA', this%memoryPath)
1243  !
1244  ! -- Copy data from laketables into vectors
1245  do n = 1, this%nlakes
1246  j = 1
1247  do ipos = this%ialaktab(n), this%ialaktab(n + 1) - 1
1248  this%tabstage(ipos) = laketables(n)%tabstage(j)
1249  this%tabvolume(ipos) = laketables(n)%tabvolume(j)
1250  this%tabsarea(ipos) = laketables(n)%tabsarea(j)
1251  iconn = this%idxlakeconn(n)
1252  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
1253  !
1254  ! -- tabwarea only filled for ictype 2 and 3
1255  this%tabwarea(ipos) = laketables(n)%tabwarea(j)
1256  else
1257  this%tabwarea(ipos) = dzero
1258  end if
1259  j = j + 1
1260  end do
1261  end do
1262  end subroutine laktables_to_vectors
1263 
1264  !> @brief Read the lake table for this package
1265  !<
1266  subroutine lak_read_table(this, ilak, filename, laketable)
1267  use constantsmodule, only: linelength
1268  use inputoutputmodule, only: openfile
1269  use simmodule, only: store_error, count_errors
1270  ! -- dummy
1271  class(laktype), intent(inout) :: this
1272  integer(I4B), intent(in) :: ilak
1273  character(len=*), intent(in) :: filename
1274  type(laktabtype), intent(inout) :: laketable
1275  ! -- local
1276  character(len=LINELENGTH) :: keyword
1277  integer(I4B) :: ierr
1278  logical(LGP) :: isfound, endOfBlock
1279  integer(I4B) :: iu
1280  integer(I4B) :: n
1281  integer(I4B) :: ipos
1282  integer(I4B) :: j
1283  integer(I4B) :: jmin
1284  integer(I4B) :: iconn
1285  real(DP) :: vol
1286  real(DP) :: sa
1287  real(DP) :: wa
1288  real(DP) :: v
1289  real(DP) :: v0
1290  type(blockparsertype) :: parser
1291  ! -- formats
1292  character(len=*), parameter :: fmttaberr = &
1293  &'(a,1x,i0,1x,a,1x,g15.6,1x,a,1x,i0,1x,a,1x,i0,1x,a,1x,g15.6,1x,a)'
1294  !
1295  ! -- initialize locals
1296  n = 0
1297  j = 0
1298  !
1299  ! -- open the table file
1300  iu = 0
1301  call openfile(iu, this%iout, filename, 'LAKE TABLE')
1302  call parser%Initialize(iu, this%iout)
1303  !
1304  ! -- get dimensions block
1305  call parser%GetBlock('DIMENSIONS', isfound, ierr, supportopenclose=.true.)
1306  !
1307  ! -- parse lak table dimensions block if detected
1308  if (isfound) then
1309  ! -- process the lake table dimension data
1310  if (this%iprpak /= 0) then
1311  write (this%iout, '(/1x,a)') &
1312  'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS'
1313  end if
1314  readdims: do
1315  call parser%GetNextLine(endofblock)
1316  if (endofblock) exit
1317  call parser%GetStringCaps(keyword)
1318  select case (keyword)
1319  case ('NROW')
1320  n = parser%GetInteger()
1321 
1322  if (n < 1) then
1323  write (errmsg, '(a)') 'LAKE TABLE NROW MUST BE > 0'
1324  call store_error(errmsg)
1325  end if
1326  case ('NCOL')
1327  j = parser%GetInteger()
1328 
1329  if (this%ictype(ilak) == 2 .or. this%ictype(ilak) == 3) then
1330  jmin = 4
1331  else
1332  jmin = 3
1333  end if
1334  if (j < jmin) then
1335  write (errmsg, '(a,1x,i0)') 'LAKE TABLE NCOL MUST BE >= ', jmin
1336  call store_error(errmsg)
1337  end if
1338  !
1339  case default
1340  write (errmsg, '(a,a)') &
1341  'UNKNOWN '//trim(this%text)//' DIMENSIONS KEYWORD: ', trim(keyword)
1342  call store_error(errmsg)
1343  end select
1344  end do readdims
1345  if (this%iprpak /= 0) then
1346  write (this%iout, '(1x,a)') &
1347  'END OF '//trim(adjustl(this%text))//' DIMENSIONS'
1348  end if
1349  else
1350  call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.')
1351  end if
1352  !
1353  ! -- check that ncol and nrow have been specified
1354  if (n < 1) then
1355  write (errmsg, '(a)') &
1356  'NROW NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK'
1357  call store_error(errmsg)
1358  end if
1359  if (j < 1) then
1360  write (errmsg, '(a)') &
1361  'NCOL NOT SPECIFIED IN THE LAKE TABLE DIMENSIONS BLOCK'
1362  call store_error(errmsg)
1363  end if
1364  !
1365  ! -- only read the lake table data if n and j are specified to be greater
1366  ! than zero
1367  if (n * j > 0) then
1368  !
1369  ! -- allocate space
1370  this%ntabrow(ilak) = n
1371  allocate (laketable%tabstage(n))
1372  allocate (laketable%tabvolume(n))
1373  allocate (laketable%tabsarea(n))
1374  ipos = this%idxlakeconn(ilak)
1375  if (this%ictype(ipos) == 2 .or. this%ictype(ipos) == 3) then
1376  allocate (laketable%tabwarea(n))
1377  end if
1378  !
1379  ! -- get table block
1380  call parser%GetBlock('TABLE', isfound, ierr, supportopenclose=.true.)
1381  !
1382  ! -- parse well_connections block if detected
1383  if (isfound) then
1384  !
1385  ! -- process the table data
1386  if (this%iprpak /= 0) then
1387  write (this%iout, '(/1x,a)') &
1388  'PROCESSING '//trim(adjustl(this%text))//' TABLE'
1389  end if
1390  iconn = this%idxlakeconn(ilak)
1391  ipos = 0
1392  readtabledata: do
1393  call parser%GetNextLine(endofblock)
1394  if (endofblock) exit
1395  ipos = ipos + 1
1396  if (ipos > this%ntabrow(ilak)) then
1397  cycle readtabledata
1398  end if
1399  laketable%tabstage(ipos) = parser%GetDouble()
1400  laketable%tabvolume(ipos) = parser%GetDouble()
1401  laketable%tabsarea(ipos) = parser%GetDouble()
1402  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
1403  laketable%tabwarea(ipos) = parser%GetDouble()
1404  end if
1405  end do readtabledata
1406  !
1407  if (this%iprpak /= 0) then
1408  write (this%iout, '(1x,a)') &
1409  'END OF '//trim(adjustl(this%text))//' TABLE'
1410  end if
1411  else
1412  call store_error('REQUIRED TABLE BLOCK NOT FOUND.')
1413  end if
1414  !
1415  ! -- error condition if number of rows read are not equal to nrow
1416  if (ipos /= this%ntabrow(ilak)) then
1417  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
1418  'NROW SET TO', this%ntabrow(ilak), 'BUT', ipos, 'ROWS WERE READ'
1419  call store_error(errmsg)
1420  end if
1421  !
1422  ! -- set lake bottom based on table if it is an embedded lake
1423  iconn = this%idxlakeconn(ilak)
1424  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
1425  do n = 1, this%ntabrow(ilak)
1426  vol = laketable%tabvolume(n)
1427  sa = laketable%tabsarea(n)
1428  wa = laketable%tabwarea(n)
1429  vol = vol * sa * wa
1430  ! -- check if all entries are zero
1431  if (vol > dzero) exit
1432  ! -- set lake bottom
1433  this%lakebot(ilak) = laketable%tabstage(n)
1434  this%belev(ilak) = laketable%tabstage(n)
1435  end do
1436  ! -- set maximum surface area for rainfall
1437  n = this%ntabrow(ilak)
1438  this%sareamax(ilak) = laketable%tabsarea(n)
1439  end if
1440  !
1441  ! -- verify the table data
1442  do n = 2, this%ntabrow(ilak)
1443  v = laketable%tabstage(n)
1444  v0 = laketable%tabstage(n - 1)
1445  if (v <= v0) then
1446  write (errmsg, fmttaberr) &
1447  'TABLE STAGE ENTRY', n, '(', laketable%tabstage(n), ') FOR LAKE ', &
1448  ilak, 'MUST BE GREATER THAN THE PREVIOUS STAGE ENTRY', &
1449  n - 1, '(', laketable%tabstage(n - 1), ')'
1450  call store_error(errmsg)
1451  end if
1452  v = laketable%tabvolume(n)
1453  v0 = laketable%tabvolume(n - 1)
1454  if (v <= v0) then
1455  write (errmsg, fmttaberr) &
1456  'TABLE VOLUME ENTRY', n, '(', laketable%tabvolume(n), &
1457  ') FOR LAKE ', &
1458  ilak, 'MUST BE GREATER THAN THE PREVIOUS VOLUME ENTRY', &
1459  n - 1, '(', laketable%tabvolume(n - 1), ')'
1460  call store_error(errmsg)
1461  end if
1462  v = laketable%tabsarea(n)
1463  v0 = laketable%tabsarea(n - 1)
1464  if (v < v0) then
1465  write (errmsg, fmttaberr) &
1466  'TABLE SURFACE AREA ENTRY', n, '(', &
1467  laketable%tabsarea(n), ') FOR LAKE ', ilak, &
1468  'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS SURFACE AREA ENTRY', &
1469  n - 1, '(', laketable%tabsarea(n - 1), ')'
1470  call store_error(errmsg)
1471  end if
1472  iconn = this%idxlakeconn(ilak)
1473  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
1474  v = laketable%tabwarea(n)
1475  v0 = laketable%tabwarea(n - 1)
1476  if (v < v0) then
1477  write (errmsg, fmttaberr) &
1478  'TABLE EXCHANGE AREA ENTRY', n, '(', &
1479  laketable%tabwarea(n), ') FOR LAKE ', ilak, &
1480  'MUST BE GREATER THAN OR EQUAL TO THE PREVIOUS EXCHANGE AREA '// &
1481  'ENTRY', n - 1, '(', laketable%tabwarea(n - 1), ')'
1482  call store_error(errmsg)
1483  end if
1484  end if
1485  end do
1486  end if
1487  !
1488  ! -- write summary of lake table error messages
1489  if (count_errors() > 0) then
1490  call parser%StoreErrorUnit()
1491  end if
1492  !
1493  ! Close the table file and clear other parser members
1494  call parser%Clear()
1495  end subroutine lak_read_table
1496 
1497  !> @brief Read the lake outlets for this package
1498  !<
1499  subroutine lak_read_outlets(this)
1500  use constantsmodule, only: linelength
1501  use simmodule, only: store_error, count_errors
1502  use timeseriesmanagermodule, only: read_value_or_time_series_adv
1503  ! -- dummy
1504  class(laktype), intent(inout) :: this
1505  ! -- local
1506  character(len=LINELENGTH) :: text, keyword
1507  character(len=LENBOUNDNAME) :: bndName
1508  character(len=9) :: citem
1509  integer(I4B) :: ierr, ival
1510  logical(LGP) :: isfound, endOfBlock
1511  integer(I4B) :: n
1512  integer(I4B) :: jj
1513  integer(I4B), dimension(:), pointer, contiguous :: nboundchk
1514  real(DP), pointer :: bndElem => null()
1515  !
1516  ! -- get well_connections block
1517  call this%parser%GetBlock('OUTLETS', isfound, ierr, &
1518  supportopenclose=.true., blockrequired=.false.)
1519  !
1520  ! -- parse outlets block if detected
1521  if (isfound) then
1522  if (this%noutlets > 0) then
1523  !
1524  ! -- allocate and initialize local variables
1525  allocate (nboundchk(this%noutlets))
1526  do n = 1, this%noutlets
1527  nboundchk(n) = 0
1528  end do
1529  !
1530  ! -- allocate outlet data using memory manager
1531  call mem_allocate(this%lakein, this%NOUTLETS, 'LAKEIN', this%memoryPath)
1532  call mem_allocate(this%lakeout, this%NOUTLETS, 'LAKEOUT', this%memoryPath)
1533  call mem_allocate(this%iouttype, this%NOUTLETS, 'IOUTTYPE', &
1534  this%memoryPath)
1535  call mem_allocate(this%outrate, this%NOUTLETS, 'OUTRATE', this%memoryPath)
1536  call mem_allocate(this%outinvert, this%NOUTLETS, 'OUTINVERT', &
1537  this%memoryPath)
1538  call mem_allocate(this%outwidth, this%NOUTLETS, 'OUTWIDTH', &
1539  this%memoryPath)
1540  call mem_allocate(this%outrough, this%NOUTLETS, 'OUTROUGH', &
1541  this%memoryPath)
1542  call mem_allocate(this%outslope, this%NOUTLETS, 'OUTSLOPE', &
1543  this%memoryPath)
1544  call mem_allocate(this%simoutrate, this%NOUTLETS, 'SIMOUTRATE', &
1545  this%memoryPath)
1546  !
1547  ! -- initialize outlet rate
1548  do n = 1, this%noutlets
1549  this%outrate(n) = dzero
1550  end do
1551  !
1552  ! -- process the lake connection data
1553  write (this%iout, '(/1x,a)') &
1554  'PROCESSING '//trim(adjustl(this%text))//' OUTLETS'
1555  readoutlet: do
1556  call this%parser%GetNextLine(endofblock)
1557  if (endofblock) exit
1558  n = this%parser%GetInteger()
1559 
1560  if (n < 1 .or. n > this%noutlets) then
1561  write (errmsg, '(a,1x,i0)') &
1562  'outletno MUST BE > 0 and <= ', this%noutlets
1563  call store_error(errmsg)
1564  cycle readoutlet
1565  end if
1566  !
1567  ! -- increment nboundchk
1568  nboundchk(n) = nboundchk(n) + 1
1569  !
1570  ! -- read outlet lakein
1571  ival = this%parser%GetInteger()
1572  if (ival < 1 .or. ival > this%nlakes) then
1573  write (errmsg, '(a,1x,i0,1x,a,1x,i0)') &
1574  'lakein FOR OUTLET ', n, 'MUST BE > 0 and <= ', this%nlakes
1575  call store_error(errmsg)
1576  cycle readoutlet
1577  end if
1578  this%lakein(n) = ival
1579  !
1580  ! -- read outlet lakeout
1581  ival = this%parser%GetInteger()
1582  if (ival < 0 .or. ival > this%nlakes) then
1583  write (errmsg, '(a,1x,i0,1x,a,1x,i0)') &
1584  'lakeout FOR OUTLET ', n, 'MUST BE >= 0 and <= ', this%nlakes
1585  call store_error(errmsg)
1586  cycle readoutlet
1587  end if
1588  this%lakeout(n) = ival
1589  !
1590  ! -- read ictype
1591  call this%parser%GetStringCaps(keyword)
1592  select case (keyword)
1593  case ('SPECIFIED')
1594  this%iouttype(n) = 0
1595  case ('MANNING')
1596  this%iouttype(n) = 1
1597  case ('WEIR')
1598  this%iouttype(n) = 2
1599  case default
1600  write (errmsg, '(a,1x,i0,1x,a,a,a)') &
1601  'UNKNOWN couttype FOR OUTLET ', n, '(', trim(keyword), ')'
1602  call store_error(errmsg)
1603  cycle readoutlet
1604  end select
1605  !
1606  ! -- build bndname for outlet
1607  write (citem, '(i9.9)') n
1608  bndname = 'OUTLET'//citem
1609  !
1610  ! -- set a few variables for timeseries aware variables
1611  jj = 1
1612  !
1613  ! -- outlet invert
1614  call this%parser%GetString(text)
1615  bndelem => this%outinvert(n)
1616  call read_value_or_time_series_adv(text, n, jj, bndelem, &
1617  this%packName, 'BND', &
1618  this%tsManager, this%iprpak, &
1619  'INVERT')
1620  !
1621  ! -- outlet width
1622  call this%parser%GetString(text)
1623  bndelem => this%outwidth(n)
1624  call read_value_or_time_series_adv(text, n, jj, bndelem, &
1625  this%packName, 'BND', &
1626  this%tsManager, this%iprpak, 'WIDTH')
1627  !
1628  ! -- outlet roughness
1629  call this%parser%GetString(text)
1630  bndelem => this%outrough(n)
1631  call read_value_or_time_series_adv(text, n, jj, bndelem, &
1632  this%packName, 'BND', &
1633  this%tsManager, this%iprpak, 'ROUGH')
1634  !
1635  ! -- outlet slope
1636  call this%parser%GetString(text)
1637  bndelem => this%outslope(n)
1638  call read_value_or_time_series_adv(text, n, jj, bndelem, &
1639  this%packName, 'BND', &
1640  this%tsManager, this%iprpak, 'SLOPE')
1641  end do readoutlet
1642  write (this%iout, '(1x,a)') 'END OF '//trim(adjustl(this%text))// &
1643  ' OUTLETS'
1644  !
1645  ! -- check for duplicate or missing outlets
1646  do n = 1, this%noutlets
1647  if (nboundchk(n) == 0) then
1648  write (errmsg, '(a,1x,i0)') 'NO DATA SPECIFIED FOR OUTLET', n
1649  call store_error(errmsg)
1650  else if (nboundchk(n) > 1) then
1651  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
1652  'DATA FOR OUTLET', n, 'SPECIFIED', nboundchk(n), 'TIMES'
1653  call store_error(errmsg)
1654  end if
1655  end do
1656  !
1657  ! -- deallocate local storage
1658  deallocate (nboundchk)
1659  else
1660  write (errmsg, '(a,1x,a)') &
1661  'AN OUTLETS BLOCK SHOULD NOT BE SPECIFIED IF NOUTLETS IS NOT', &
1662  'SPECIFIED OR IS SPECIFIED TO BE 0.'
1663  call store_error(errmsg)
1664  end if
1665  !
1666  else
1667  if (this%noutlets > 0) then
1668  call store_error('REQUIRED OUTLETS BLOCK NOT FOUND.')
1669  end if
1670  end if
1671  !
1672  ! -- write summary of lake_connection error messages
1673  ierr = count_errors()
1674  if (ierr > 0) then
1675  call this%parser%StoreErrorUnit()
1676  end if
1677  end subroutine lak_read_outlets
1678 
1679  !> @brief Read the dimensions for this package
1680  !<
1681  subroutine lak_read_dimensions(this)
1682  use constantsmodule, only: linelength
1683  use simmodule, only: store_error, count_errors
1684  ! -- dummy
1685  class(laktype), intent(inout) :: this
1686  ! -- local
1687  character(len=LINELENGTH) :: keyword
1688  integer(I4B) :: ierr
1689  logical(LGP) :: isfound, endOfBlock
1690  !
1691  ! -- initialize dimensions to -1
1692  this%nlakes = -1
1693  this%maxbound = -1
1694  !
1695  ! -- get dimensions block
1696  call this%parser%GetBlock('DIMENSIONS', isfound, ierr, &
1697  supportopenclose=.true.)
1698  !
1699  ! -- parse dimensions block if detected
1700  if (isfound) then
1701  write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// &
1702  ' DIMENSIONS'
1703  do
1704  call this%parser%GetNextLine(endofblock)
1705  if (endofblock) exit
1706  call this%parser%GetStringCaps(keyword)
1707  select case (keyword)
1708  case ('NLAKES')
1709  this%nlakes = this%parser%GetInteger()
1710  write (this%iout, '(4x,a,i7)') 'NLAKES = ', this%nlakes
1711  case ('NOUTLETS')
1712  this%noutlets = this%parser%GetInteger()
1713  write (this%iout, '(4x,a,i7)') 'NOUTLETS = ', this%noutlets
1714  case ('NTABLES')
1715  this%ntables = this%parser%GetInteger()
1716  write (this%iout, '(4x,a,i7)') 'NTABLES = ', this%ntables
1717  case default
1718  write (errmsg, '(a,a)') &
1719  'UNKNOWN '//trim(this%text)//' DIMENSION: ', trim(keyword)
1720  call store_error(errmsg)
1721  end select
1722  end do
1723  write (this%iout, '(1x,a)') &
1724  'END OF '//trim(adjustl(this%text))//' DIMENSIONS'
1725  else
1726  call store_error('REQUIRED DIMENSIONS BLOCK NOT FOUND.')
1727  end if
1728  !
1729  if (this%nlakes < 0) then
1730  write (errmsg, '(a)') &
1731  'NLAKES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.'
1732  call store_error(errmsg)
1733  end if
1734  !
1735  if (this%iforceleglak /= 0) then
1736  if (this%iforceleglak < 1 .or. this%iforceleglak > this%nlakes) then
1737  write (errmsg, '(a,i0,a,i0,a)') &
1738  'DEV_FORCE_LEGACY_LAKE (', this%iforceleglak, &
1739  ') MUST BE BETWEEN 1 AND NLAKES (', this%nlakes, ').'
1740  call store_error(errmsg)
1741  end if
1742  end if
1743  !
1744  ! -- stop if errors were encountered in the DIMENSIONS block
1745  if (count_errors() > 0) then
1746  call this%parser%StoreErrorUnit()
1747  end if
1748  !
1749  ! -- for the implicit formulation each lake adds one equation (one row and
1750  ! column) to the groundwater flow matrix
1751  if (this%iimplicit /= 0) then
1752  this%npakeq = this%nlakes
1753  ! -- the implicit lake-aquifer coupling is asymmetric for perched
1754  ! connections, so flag the coefficient matrix as asymmetric (which
1755  ! requires the BICGSTAB linear acceleration). Only raise the flag; never
1756  ! clear an asymmetry already indicated elsewhere.
1757  this%iasym = 1
1758  end if
1759  !
1760  ! -- read lakes block
1761  call this%lak_read_lakes()
1762  !
1763  ! -- read lake_connections block
1764  call this%lak_read_lake_connections()
1765  !
1766  ! -- read tables block
1767  call this%lak_read_tables()
1768  !
1769  ! -- read outlets block
1770  call this%lak_read_outlets()
1771  !
1772  ! -- Call define_listlabel to construct the list label that is written
1773  ! when PRINT_INPUT option is used.
1774  call this%define_listlabel()
1775  !
1776  ! -- setup the budget object
1777  call this%lak_setup_budobj()
1778  !
1779  ! -- setup the stage table object
1780  call this%lak_setup_tableobj()
1781  end subroutine lak_read_dimensions
1782 
1783  !> @brief Read the initial parameters for this package
1784  !<
1785  subroutine lak_read_initial_attr(this)
1786  use constantsmodule, only: linelength
1787  use memoryhelpermodule, only: create_mem_path
1788  use simmodule, only: store_error, count_errors
1789  use timeseriesmanagermodule, only: read_value_or_time_series_adv
1790  ! -- dummy
1791  class(laktype), intent(inout) :: this
1792  ! -- local
1793  character(len=LINELENGTH) :: text
1794  integer(I4B) :: j, jj, n
1795  integer(I4B) :: nn
1796  integer(I4B) :: idx
1797  real(DP) :: top
1798  real(DP) :: bot
1799  real(DP) :: k
1800  real(DP) :: area
1801  real(DP) :: length
1802  real(DP) :: s
1803  real(DP) :: dx
1804  real(DP) :: c
1805  real(DP) :: sa
1806  real(DP) :: wa
1807  real(DP) :: v
1808  real(DP) :: fact
1809  real(DP) :: c1
1810  real(DP) :: c2
1811  real(DP), allocatable, dimension(:) :: clb, caq
1812  character(len=14) :: cbedleak
1813  character(len=14) :: cbedcond
1814  character(len=10), dimension(0:3) :: ctype
1815  character(len=15) :: nodestr
1816  real(DP), pointer :: bndElem => null()
1817  ! -- data
1818  data ctype(0)/'VERTICAL '/
1819  data ctype(1)/'HORIZONTAL'/
1820  data ctype(2)/'EMBEDDEDH '/
1821  data ctype(3)/'EMBEDDEDV '/
1822  !
1823  ! -- initialize xnewpak and set stage
1824  do n = 1, this%nlakes
1825  this%xnewpak(n) = this%strt(n)
1826  write (text, '(g15.7)') this%strt(n)
1827  jj = 1 ! For STAGE
1828  bndelem => this%stage(n)
1829  call read_value_or_time_series_adv(text, n, jj, bndelem, this%packName, &
1830  'BND', this%tsManager, this%iprpak, &
1831  'STAGE')
1832  end do
1833  !
1834  ! -- initialize status (iboundpak) of lakes to active
1835  do n = 1, this%nlakes
1836  if (this%status(n) == 'CONSTANT') then
1837  this%iboundpak(n) = -1
1838  else if (this%status(n) == 'INACTIVE') then
1839  this%iboundpak(n) = 0
1840  else if (this%status(n) == 'ACTIVE ') then
1841  this%iboundpak(n) = 1
1842  end if
1843  end do
1844  !
1845  ! -- set boundname for each connection
1846  if (this%inamedbound /= 0) then
1847  do n = 1, this%nlakes
1848  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
1849  this%boundname(j) = this%lakename(n)
1850  end do
1851  end do
1852  end if
1853  !
1854  ! -- copy boundname into boundname_cst
1855  call this%copy_boundname()
1856  !
1857  ! -- set pointer to gwf iss and gwf hk
1858  call mem_setptr(this%gwfiss, 'ISS', create_mem_path(this%name_model))
1859  call mem_setptr(this%gwfk11, 'K11', create_mem_path(this%name_model, 'NPF'))
1860  call mem_setptr(this%gwfk33, 'K33', create_mem_path(this%name_model, 'NPF'))
1861  call mem_setptr(this%gwfik33, 'IK33', create_mem_path(this%name_model, 'NPF'))
1862  call mem_setptr(this%gwfsat, 'SAT', create_mem_path(this%name_model, 'NPF'))
1863  !
1864  ! -- allocate temporary storage
1865  allocate (clb(this%MAXBOUND))
1866  allocate (caq(this%MAXBOUND))
1867  !
1868  ! -- calculate saturated conductance for each connection
1869  do n = 1, this%nlakes
1870  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
1871  nn = this%cellid(j)
1872  top = this%dis%top(nn)
1873  bot = this%dis%bot(nn)
1874  ! vertical connection
1875  if (this%ictype(j) == 0) then
1876  area = this%dis%area(nn)
1877  this%sarea(j) = area
1878  this%warea(j) = area
1879  this%sareamax(n) = this%sareamax(n) + area
1880  if (this%gwfik33 == 0) then
1881  k = this%gwfk11(nn)
1882  else
1883  k = this%gwfk33(nn)
1884  end if
1885  length = dhalf * (top - bot)
1886  ! horizontal connection
1887  else if (this%ictype(j) == 1) then
1888  area = (this%telev(j) - this%belev(j)) * this%connwidth(j)
1889  ! -- recalculate area if connected cell is confined and lake
1890  ! connection top and bot are equal to the cell top and bot
1891  if (top == this%telev(j) .and. bot == this%belev(j)) then
1892  if (this%icelltype(nn) == 0) then
1893  area = this%gwfsat(nn) * (top - bot) * this%connwidth(j)
1894  end if
1895  end if
1896  this%sarea(j) = dzero
1897  this%warea(j) = area
1898  this%sareamax(n) = this%sareamax(n) + dzero
1899  k = this%gwfk11(nn)
1900  length = this%connlength(j)
1901  ! embedded horizontal connection
1902  else if (this%ictype(j) == 2) then
1903  area = done
1904  this%sarea(j) = dzero
1905  this%warea(j) = area
1906  this%sareamax(n) = this%sareamax(n) + dzero
1907  k = this%gwfk11(nn)
1908  length = this%connlength(j)
1909  ! embedded vertical connection
1910  else if (this%ictype(j) == 3) then
1911  area = done
1912  this%sarea(j) = dzero
1913  this%warea(j) = area
1914  this%sareamax(n) = this%sareamax(n) + dzero
1915  if (this%gwfik33 == 0) then
1916  k = this%gwfk11(nn)
1917  else
1918  k = this%gwfk33(nn)
1919  end if
1920  length = this%connlength(j)
1921  end if
1922  if (is_close(this%bedleak(j), dnodata)) then
1923  clb(j) = dnodata
1924  else if (this%bedleak(j) > dzero) then
1925  clb(j) = done / this%bedleak(j)
1926  else
1927  clb(j) = dzero
1928  end if
1929  if (k > dzero) then
1930  caq(j) = length / k
1931  else
1932  caq(j) = dzero
1933  end if
1934  if (is_close(this%bedleak(j), dnodata)) then
1935  this%satcond(j) = area / caq(j)
1936  else if (clb(j) * caq(j) > dzero) then
1937  this%satcond(j) = area / (clb(j) + caq(j))
1938  else
1939  this%satcond(j) = dzero
1940  end if
1941  end do
1942  end do
1943  !
1944  ! -- write a summary of the conductance
1945  if (this%iprpak > 0) then
1946  write (this%iout, '(//,29x,a,/)') &
1947  'INTERFACE CONDUCTANCE BETWEEN LAKE AND AQUIFER CELLS'
1948  write (this%iout, '(1x,a)') &
1949  & ' LAKE CONNECTION CONNECTION LAKEBED'// &
1950  & ' C O N D U C T A N C E S '
1951  write (this%iout, '(1x,a)') &
1952  & ' NUMBER NUMBER CELLID DIRECTION LEAKANCE'// &
1953  & ' LAKEBED AQUIFER COMBINED'
1954  write (this%iout, "(1x,108('-'))")
1955  do n = 1, this%nlakes
1956  idx = 0
1957  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
1958  idx = idx + 1
1959  fact = done
1960  if (this%ictype(j) == 1) then
1961  fact = this%telev(j) - this%belev(j)
1962  if (abs(fact) > dzero) then
1963  fact = done / fact
1964  end if
1965  end if
1966  nn = this%cellid(j)
1967  area = this%warea(j)
1968  c1 = dzero
1969  if (is_close(clb(j), dnodata)) then
1970  cbedleak = ' NONE '
1971  cbedcond = ' NONE '
1972  else if (clb(j) > dzero) then
1973  c1 = area * fact / clb(j)
1974  write (cbedleak, '(g14.5)') this%bedleak(j)
1975  write (cbedcond, '(g14.5)') c1
1976  else
1977  write (cbedleak, '(g14.5)') c1
1978  write (cbedcond, '(g14.5)') c1
1979  end if
1980  c2 = dzero
1981  if (caq(j) > dzero) then
1982  c2 = area * fact / caq(j)
1983  end if
1984  call this%dis%noder_to_string(nn, nodestr)
1985  write (this%iout, &
1986  '(1x,i10,1x,i10,1x,a15,1x,a10,2(1x,a14),2(1x,g14.5))') &
1987  n, idx, nodestr, ctype(this%ictype(j)), cbedleak, &
1988  cbedcond, c2, this%satcond(j) * fact
1989  end do
1990  end do
1991  write (this%iout, "(1x,108('-'))")
1992  write (this%iout, '(1x,a)') &
1993  'IF VERTICAL CONNECTION, CONDUCTANCE (L^2/T) IS &
1994  &BETWEEN AQUIFER CELL AND OVERLYING LAKE CELL.'
1995  write (this%iout, '(1x,a)') &
1996  'IF HORIZONTAL CONNECTION, CONDUCTANCES ARE PER &
1997  &UNIT SATURATED THICKNESS (L/T).'
1998  write (this%iout, '(1x,a)') &
1999  'IF EMBEDDED CONNECTION, CONDUCTANCES ARE PER &
2000  &UNIT EXCHANGE AREA (1/T).'
2001  !
2002  ! write(this%iout,*) n, idx, nodestr, this%sarea(j), this%warea(j)
2003  !
2004  ! -- calculate stage, surface area, wetted area, volume relation
2005  do n = 1, this%nlakes
2006  write (this%iout, '(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n
2007  write (this%iout, '(/1x,5(a14))') ' STAGE', ' SURFACE AREA', &
2008  & ' WETTED AREA', ' CONDUCTANCE', &
2009  & ' VOLUME'
2010  write (this%iout, "(1x,70('-'))")
2011  dx = (this%laketop(n) - this%lakebot(n)) / 150.
2012  s = this%lakebot(n)
2013  do j = 1, 151
2014  call this%lak_calculate_conductance(n, s, c)
2015  call this%lak_calculate_sarea(n, s, sa)
2016  call this%lak_calculate_warea(n, s, wa, s)
2017  call this%lak_calculate_vol(n, s, v)
2018  write (this%iout, '(1x,5(E14.5))') s, sa, wa, c, v
2019  s = s + dx
2020  end do
2021  write (this%iout, "(1x,70('-'))")
2022  !
2023  write (this%iout, '(//1x,a,1x,i10)') 'STAGE/VOLUME RELATION FOR LAKE ', n
2024  write (this%iout, '(/1x,4(a14))') ' ', ' ', &
2025  & ' CALCULATED', ' STAGE'
2026  write (this%iout, '(1x,4(a14))') ' STAGE', ' VOLUME', &
2027  & ' STAGE', ' DIFFERENCE'
2028  write (this%iout, "(1x,56('-'))")
2029  s = this%lakebot(n) - dx
2030  do j = 1, 156
2031  call this%lak_calculate_vol(n, s, v)
2032  call this%lak_vol2stage(n, v, c)
2033  write (this%iout, '(1x,4(E14.5))') s, v, c, s - c
2034  s = s + dx
2035  end do
2036  write (this%iout, "(1x,56('-'))")
2037  end do
2038  end if
2039  !
2040  ! -- finished with pointer to gwf hydraulic conductivity
2041  this%gwfk11 => null()
2042  this%gwfk33 => null()
2043  this%gwfsat => null()
2044  this%gwfik33 => null()
2045  !
2046  ! -- deallocate temporary storage
2047  deallocate (clb)
2048  deallocate (caq)
2049  end subroutine lak_read_initial_attr
2050 
2051  !> @brief Perform linear interpolation of two vectors.
2052  !!
2053  !! Function assumes x data is sorted in ascending order
2054  !<
2055  subroutine lak_linear_interpolation(this, n, x, y, z, v)
2056  ! -- dummy
2057  class(laktype), intent(inout) :: this
2058  integer(I4B), intent(in) :: n
2059  real(DP), dimension(n), intent(in) :: x
2060  real(DP), dimension(n), intent(in) :: y
2061  real(DP), intent(in) :: z
2062  real(DP), intent(inout) :: v
2063  ! -- local
2064  integer(I4B) :: i
2065  real(DP) :: dx, dydx
2066  ! code
2067  v = dzero
2068  ! below bottom of range - set to lowest value
2069  if (z <= x(1)) then
2070  v = y(1)
2071  ! above highest value
2072  ! slope calculated from interval between n and n-1
2073  else if (z > x(n)) then
2074  dx = x(n) - x(n - 1)
2075  dydx = dzero
2076  if (abs(dx) > dzero) then
2077  dydx = (y(n) - y(n - 1)) / dx
2078  end if
2079  dx = (z - x(n))
2080  v = y(n) + dydx * dx
2081  ! between lowest and highest value in current interval
2082  else
2083  do i = 2, n
2084  dx = x(i) - x(i - 1)
2085  dydx = dzero
2086  if (z >= x(i - 1) .and. z <= x(i)) then
2087  if (abs(dx) > dzero) then
2088  dydx = (y(i) - y(i - 1)) / dx
2089  end if
2090  dx = (z - x(i - 1))
2091  v = y(i - 1) + dydx * dx
2092  exit
2093  end if
2094  end do
2095  end if
2096  end subroutine lak_linear_interpolation
2097 
2098  !> @brief Calculate the surface area of a lake at a given stage
2099  !<
2100  subroutine lak_calculate_sarea(this, ilak, stage, sarea)
2101  ! -- dummy
2102  class(laktype), intent(inout) :: this
2103  integer(I4B), intent(in) :: ilak
2104  real(DP), intent(in) :: stage
2105  real(DP), intent(inout) :: sarea
2106  ! -- local
2107  integer(I4B) :: i
2108  integer(I4B) :: ifirst
2109  integer(I4B) :: ilast
2110  real(DP) :: topl
2111  real(DP) :: botl
2112  real(DP) :: sat
2113  real(DP) :: sa
2114  !
2115  sarea = dzero
2116  i = this%ntabrow(ilak)
2117  if (i > 0) then
2118  ifirst = this%ialaktab(ilak)
2119  ilast = this%ialaktab(ilak + 1) - 1
2120  if (stage <= this%tabstage(ifirst)) then
2121  sarea = this%tabsarea(ifirst)
2122  else if (stage >= this%tabstage(ilast)) then
2123  sarea = this%tabsarea(ilast)
2124  else
2125  call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), &
2126  this%tabsarea(ifirst:ilast), &
2127  stage, sarea)
2128  end if
2129  else
2130  do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1
2131  topl = this%telev(i)
2132  botl = this%belev(i)
2133  sat = squadraticsaturation(topl, botl, stage)
2134  sa = sat * this%sarea(i)
2135  sarea = sarea + sa
2136  end do
2137  end if
2138  end subroutine lak_calculate_sarea
2139 
2140  !> @brief Calculate the wetted area of a lake at a given stage.
2141  !<
2142  subroutine lak_calculate_warea(this, ilak, stage, warea, hin)
2143  ! -- dummy
2144  class(laktype), intent(inout) :: this
2145  integer(I4B), intent(in) :: ilak
2146  real(DP), intent(in) :: stage
2147  real(DP), intent(inout) :: warea
2148  real(DP), optional, intent(inout) :: hin
2149  ! -- local
2150  integer(I4B) :: i
2151  integer(I4B) :: igwfnode
2152  real(DP) :: head
2153  real(DP) :: wa
2154  !
2155  warea = dzero
2156  do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1
2157  if (present(hin)) then
2158  head = hin
2159  else
2160  igwfnode = this%cellid(i)
2161  head = this%xnew(igwfnode)
2162  end if
2163  call this%lak_calculate_conn_warea(ilak, i, stage, head, wa)
2164  warea = warea + wa
2165  end do
2166  end subroutine lak_calculate_warea
2167 
2168  !> @brief Calculate the wetted area of a lake connection at a given stage
2169  !<
2170  subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa)
2171  ! -- dummy
2172  class(laktype), intent(inout) :: this
2173  integer(I4B), intent(in) :: ilak
2174  integer(I4B), intent(in) :: iconn
2175  real(DP), intent(in) :: stage
2176  real(DP), intent(in) :: head
2177  real(DP), intent(inout) :: wa
2178  ! -- local
2179  integer(I4B) :: i
2180  integer(I4B) :: ifirst
2181  integer(I4B) :: ilast
2182  integer(I4B) :: node
2183  real(DP) :: topl
2184  real(DP) :: botl
2185  real(DP) :: vv
2186  real(DP) :: sat
2187  !
2188  wa = dzero
2189  topl = this%telev(iconn)
2190  botl = this%belev(iconn)
2191  call this%lak_calculate_cond_head(iconn, stage, head, vv)
2192  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
2193  if (vv > topl) vv = topl
2194  i = this%ntabrow(ilak)
2195  ifirst = this%ialaktab(ilak)
2196  ilast = this%ialaktab(ilak + 1) - 1
2197  if (vv <= this%tabstage(ifirst)) then
2198  wa = this%tabwarea(ifirst)
2199  else if (vv >= this%tabstage(ilast)) then
2200  wa = this%tabwarea(ilast)
2201  else
2202  call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), &
2203  this%tabwarea(ifirst:ilast), &
2204  vv, wa)
2205  end if
2206  else
2207  node = this%cellid(iconn)
2208  ! -- confined cell
2209  if (this%icelltype(node) == 0) then
2210  sat = done
2211  ! -- convertible cell
2212  else
2213  sat = squadraticsaturation(topl, botl, vv)
2214  end if
2215  wa = sat * this%warea(iconn)
2216  end if
2217  end subroutine lak_calculate_conn_warea
2218 
2219  !> @brief Calculate the volume of a lake at a given stage
2220  !<
2221  subroutine lak_calculate_vol(this, ilak, stage, volume)
2222  ! -- dummy
2223  class(laktype), intent(inout) :: this
2224  integer(I4B), intent(in) :: ilak
2225  real(DP), intent(in) :: stage
2226  real(DP), intent(inout) :: volume
2227  ! -- local
2228  integer(I4B) :: i
2229  integer(I4B) :: ifirst
2230  integer(I4B) :: ilast
2231  real(DP) :: topl
2232  real(DP) :: botl
2233  real(DP) :: ds
2234  real(DP) :: sa
2235  real(DP) :: v
2236  real(DP) :: sat
2237  !
2238  volume = dzero
2239  i = this%ntabrow(ilak)
2240  if (i > 0) then
2241  ifirst = this%ialaktab(ilak)
2242  ilast = this%ialaktab(ilak + 1) - 1
2243  if (stage <= this%tabstage(ifirst)) then
2244  volume = this%tabvolume(ifirst)
2245  else if (stage >= this%tabstage(ilast)) then
2246  ds = stage - this%tabstage(ilast)
2247  sa = this%tabsarea(ilast)
2248  volume = this%tabvolume(ilast) + ds * sa
2249  else
2250  call this%lak_linear_interpolation(i, this%tabstage(ifirst:ilast), &
2251  this%tabvolume(ifirst:ilast), &
2252  stage, volume)
2253  end if
2254  else
2255  do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1
2256  topl = this%telev(i)
2257  botl = this%belev(i)
2258  sat = squadraticsaturation(topl, botl, stage)
2259  sa = sat * this%sarea(i)
2260  if (stage < botl) then
2261  v = dzero
2262  else if (stage > botl .and. stage < topl) then
2263  v = sa * (stage - botl)
2264  else
2265  v = sa * (topl - botl) + sa * (stage - topl)
2266  end if
2267  volume = volume + v
2268  end do
2269  end if
2270  end subroutine lak_calculate_vol
2271 
2272  !> @brief Calculate the total conductance for a lake at a provided stage
2273  !<
2274  subroutine lak_calculate_conductance(this, ilak, stage, conductance)
2275  ! -- dummy
2276  class(laktype), intent(inout) :: this
2277  integer(I4B), intent(in) :: ilak
2278  real(DP), intent(in) :: stage
2279  real(DP), intent(inout) :: conductance
2280  ! -- local
2281  integer(I4B) :: i
2282  real(DP) :: c
2283  !
2284  conductance = dzero
2285  do i = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1
2286  call this%lak_calculate_conn_conductance(ilak, i, stage, stage, c)
2287  conductance = conductance + c
2288  end do
2289  end subroutine lak_calculate_conductance
2290 
2291  !> @brief Calculate the controlling lake stage or groundwater head used to
2292  !! calculate the conductance for a lake connection from a provided stage and
2293  !! groundwater head
2294  !<
2295  subroutine lak_calculate_cond_head(this, iconn, stage, head, vv)
2296  ! -- dummy
2297  class(laktype), intent(inout) :: this
2298  integer(I4B), intent(in) :: iconn
2299  real(DP), intent(in) :: stage
2300  real(DP), intent(in) :: head
2301  real(DP), intent(inout) :: vv
2302  ! -- local
2303  real(DP) :: ss
2304  real(DP) :: hh
2305  real(DP) :: topl
2306  real(DP) :: botl
2307  !
2308  topl = this%telev(iconn)
2309  botl = this%belev(iconn)
2310  ss = min(stage, topl)
2311  hh = min(head, topl)
2312  if (this%igwhcopt > 0) then
2313  vv = hh
2314  else if (this%inewton > 0) then
2315  vv = max(ss, hh)
2316  else
2317  vv = dhalf * (ss + hh)
2318  end if
2319  end subroutine lak_calculate_cond_head
2320 
2321  !> @brief Calculate the conductance for a lake connection at a provided stage
2322  !! and groundwater head
2323  !<
2324  subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond)
2325  ! -- dummy
2326  class(laktype), intent(inout) :: this
2327  integer(I4B), intent(in) :: ilak
2328  integer(I4B), intent(in) :: iconn
2329  real(DP), intent(in) :: stage
2330  real(DP), intent(in) :: head
2331  real(DP), intent(inout) :: cond
2332  ! -- local
2333  integer(I4B) :: node
2334  !real(DP) :: ss
2335  !real(DP) :: hh
2336  real(DP) :: vv
2337  real(DP) :: topl
2338  real(DP) :: botl
2339  real(DP) :: sat
2340  real(DP) :: wa
2341  real(DP) :: vscratio
2342  !
2343  cond = dzero
2344  vscratio = done
2345  topl = this%telev(iconn)
2346  botl = this%belev(iconn)
2347  call this%lak_calculate_cond_head(iconn, stage, head, vv)
2348  sat = squadraticsaturation(topl, botl, vv)
2349  ! vertical connection
2350  ! use full saturated conductance if top and bottom of the lake connection
2351  ! are equal
2352  if (this%ictype(iconn) == 0) then
2353  if (abs(topl - botl) < dprec) then
2354  sat = done
2355  end if
2356  ! horizontal connection
2357  ! use full saturated conductance if the connected cell is not convertible
2358  else if (this%ictype(iconn) == 1) then
2359  node = this%cellid(iconn)
2360  if (this%icelltype(node) == 0) then
2361  sat = done
2362  end if
2363  ! embedded connection
2364  else if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
2365  node = this%cellid(iconn)
2366  if (this%icelltype(node) == 0) then
2367  vv = this%telev(iconn)
2368  call this%lak_calculate_conn_warea(ilak, iconn, vv, vv, wa)
2369  else
2370  call this%lak_calculate_conn_warea(ilak, iconn, stage, head, wa)
2371  end if
2372  sat = wa
2373  end if
2374  !
2375  ! -- account for viscosity effects (if vsc active)
2376  if (this%ivsc == 1) then
2377  ! flow from lake to aquifer
2378  if (stage > head) then
2379  vscratio = this%viscratios(1, iconn)
2380  ! flow from aquifer to lake
2381  else
2382  vscratio = this%viscratios(2, iconn)
2383  end if
2384  end if
2385  cond = sat * this%satcond(iconn) * vscratio
2386  end subroutine lak_calculate_conn_conductance
2387 
2388  !> @brief Calculate the total groundwater-lake flow at a provided stage
2389  !<
2390  subroutine lak_calculate_exchange(this, ilak, stage, totflow)
2391  ! -- dummy
2392  class(laktype), intent(inout) :: this
2393  integer(I4B), intent(in) :: ilak
2394  real(DP), intent(in) :: stage
2395  real(DP), intent(inout) :: totflow
2396  ! -- local
2397  integer(I4B) :: j
2398  integer(I4B) :: igwfnode
2399  real(DP) :: flow
2400  real(DP) :: hgwf
2401  !
2402  totflow = dzero
2403  do j = this%idxlakeconn(ilak), this%idxlakeconn(ilak + 1) - 1
2404  igwfnode = this%cellid(j)
2405  hgwf = this%xnew(igwfnode)
2406  call this%lak_calculate_conn_exchange(ilak, j, stage, hgwf, flow)
2407  totflow = totflow + flow
2408  end do
2409  end subroutine lak_calculate_exchange
2410 
2411  !> @brief Calculate the groundwater-lake flow at a provided stage and
2412  !! groundwater head
2413  !<
2414  subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, &
2415  gwfhcof, gwfrhs)
2416  ! -- dummy
2417  class(laktype), intent(inout) :: this
2418  integer(I4B), intent(in) :: ilak
2419  integer(I4B), intent(in) :: iconn
2420  real(DP), intent(in) :: stage
2421  real(DP), intent(in) :: head
2422  real(DP), intent(inout) :: flow
2423  real(DP), intent(inout), optional :: gwfhcof
2424  real(DP), intent(inout), optional :: gwfrhs
2425  ! -- local
2426  real(DP) :: botl
2427  real(DP) :: cond
2428  real(DP) :: ss
2429  real(DP) :: hh
2430  real(DP) :: gwfhcof0
2431  real(DP) :: gwfrhs0
2432  !
2433  flow = dzero
2434  call this%lak_calculate_conn_conductance(ilak, iconn, stage, head, cond)
2435  botl = this%belev(iconn)
2436  !
2437  ! -- Set ss to stage or botl
2438  if (stage >= botl) then
2439  ss = stage
2440  else
2441  ss = botl
2442  end if
2443  !
2444  ! -- set hh to head or botl
2445  if (head >= botl) then
2446  hh = head
2447  else
2448  hh = botl
2449  end if
2450  !
2451  ! -- calculate flow, positive into lake
2452  flow = cond * (hh - ss)
2453  !
2454  ! -- Calculate gwfhcof and gwfrhs
2455  if (head >= botl) then
2456  gwfhcof0 = -cond
2457  gwfrhs0 = -cond * ss
2458  else
2459  gwfhcof0 = dzero
2460  gwfrhs0 = flow
2461  end if
2462  !
2463  ! Add density contributions, if active
2464  if (this%idense /= 0) then
2465  call this%lak_calculate_density_exchange(iconn, stage, head, cond, botl, &
2466  flow, gwfhcof0, gwfrhs0)
2467  end if
2468  !
2469  ! -- If present update gwfhcof and gwfrhs
2470  if (present(gwfhcof)) gwfhcof = gwfhcof0
2471  if (present(gwfrhs)) gwfrhs = gwfrhs0
2472  end subroutine lak_calculate_conn_exchange
2473 
2474  !> @brief Lakebed seepage and its derivatives for a connection (IMPLICIT)
2475  !!
2476  !! Returns the lakebed seepage for one connection, positive into the lake,
2477  !! and optionally its stage and head derivatives. The stage and the connected-
2478  !! cell head are each held at or above the lake bottom, the same wet/dry cutoff
2479  !! used by the default formulation, so the implicit seepage matches the default
2480  !! formulation exactly. lak_fc_implicit uses this to assemble the matrix and
2481  !! lak_cq uses it to report the budget, so the two are consistent.
2482  !<
2483  subroutine lak_calculate_conn_exchange_deriv(this, ilak, iconn, stage, &
2484  head, flow, dqds, dqdh)
2485  ! -- dummy
2486  class(laktype), intent(inout) :: this
2487  integer(I4B), intent(in) :: ilak
2488  integer(I4B), intent(in) :: iconn
2489  real(DP), intent(in) :: stage
2490  real(DP), intent(in) :: head
2491  real(DP), intent(inout) :: flow
2492  real(DP), intent(inout), optional :: dqds
2493  real(DP), intent(inout), optional :: dqdh
2494  ! -- local
2495  real(DP) :: cond, botl, dps, dph, ss, hh
2496  !
2497  call this%lak_calculate_conn_conductance(ilak, iconn, stage, head, cond)
2498  botl = this%belev(iconn)
2499  if (stage >= botl) then
2500  ss = stage
2501  dps = done
2502  else
2503  ss = botl
2504  dps = dzero
2505  end if
2506  if (head >= botl) then
2507  hh = head
2508  dph = done
2509  else
2510  hh = botl
2511  dph = dzero
2512  end if
2513  flow = cond * (hh - ss)
2514  if (present(dqds)) dqds = -cond * dps
2515  if (present(dqdh)) dqdh = cond * dph
2516  end subroutine lak_calculate_conn_exchange_deriv
2517 
2518  !> @brief Calculate the groundwater-lake flow at a provided stage and
2519  !! groundwater head
2520  !<
2521  subroutine lak_estimate_conn_exchange(this, iflag, ilak, iconn, idry, stage, &
2522  head, flow, source, gwfhcof, gwfrhs)
2523  ! -- dummy
2524  class(laktype), intent(inout) :: this
2525  integer(I4B), intent(in) :: iflag
2526  integer(I4B), intent(in) :: ilak
2527  integer(I4B), intent(in) :: iconn
2528  integer(I4B), intent(inout) :: idry
2529  real(DP), intent(in) :: stage
2530  real(DP), intent(in) :: head
2531  real(DP), intent(inout) :: flow
2532  real(DP), intent(inout) :: source
2533  real(DP), intent(inout), optional :: gwfhcof
2534  real(DP), intent(inout), optional :: gwfrhs
2535  ! -- local
2536  real(DP) :: gwfhcof0, gwfrhs0
2537  !
2538  flow = dzero
2539  idry = 0
2540  call this%lak_calculate_conn_exchange(ilak, iconn, stage, head, flow, &
2541  gwfhcof0, gwfrhs0)
2542  if (iflag == 1) then
2543  if (flow > dzero) then
2544  source = source + flow
2545  end if
2546  else if (iflag == 2) then
2547  if (-flow > source) then
2548  flow = -source
2549  source = dzero
2550  idry = 1
2551  else if (flow < dzero) then
2552  source = source + flow
2553  end if
2554  end if
2555  !
2556  ! -- Set gwfhcof and gwfrhs if present
2557  if (present(gwfhcof)) gwfhcof = gwfhcof0
2558  if (present(gwfrhs)) gwfrhs = gwfrhs0
2559  end subroutine lak_estimate_conn_exchange
2560 
2561  !> @brief Calculate the storage change in a lake based on provided stages
2562  !! and a passed delt
2563  !<
2564  subroutine lak_calculate_storagechange(this, ilak, stage, stage0, delt, dvr)
2565  ! -- dummy
2566  class(laktype), intent(inout) :: this
2567  integer(I4B), intent(in) :: ilak
2568  real(DP), intent(in) :: stage
2569  real(DP), intent(in) :: stage0
2570  real(DP), intent(in) :: delt
2571  real(DP), intent(inout) :: dvr
2572  ! -- local
2573  real(DP) :: v
2574  real(DP) :: v0
2575  !
2576  dvr = dzero
2577  if (this%gwfiss /= 1) then
2578  call this%lak_calculate_vol(ilak, stage, v)
2579  call this%lak_calculate_vol(ilak, stage0, v0)
2580  dvr = (v0 - v) / delt
2581  end if
2582  end subroutine lak_calculate_storagechange
2583 
2584  !> @brief Calculate the rainfall for a lake
2585  !<
2586  subroutine lak_calculate_rainfall(this, ilak, stage, ra)
2587  ! -- dummy
2588  class(laktype), intent(inout) :: this
2589  integer(I4B), intent(in) :: ilak
2590  real(DP), intent(in) :: stage
2591  real(DP), intent(inout) :: ra
2592  ! -- local
2593  integer(I4B) :: iconn
2594  real(DP) :: sa
2595  !
2596  ! -- rainfall
2597  iconn = this%idxlakeconn(ilak)
2598  if (this%ictype(iconn) == 2 .or. this%ictype(iconn) == 3) then
2599  sa = this%sareamax(ilak)
2600  else
2601  call this%lak_calculate_sarea(ilak, stage, sa)
2602  end if
2603  ra = this%rainfall(ilak) * sa
2604  end subroutine lak_calculate_rainfall
2605 
2606  !> @brief Calculate runoff to a lake
2607  !<
2608  subroutine lak_calculate_runoff(this, ilak, ro)
2609  ! -- dummy
2610  class(laktype), intent(inout) :: this
2611  integer(I4B), intent(in) :: ilak
2612  real(DP), intent(inout) :: ro
2613  !
2614  ! -- runoff
2615  ro = this%runoff(ilak)
2616  end subroutine lak_calculate_runoff
2617 
2618  !> @brief Calculate specified inflow to a lake
2619  !<
2620  subroutine lak_calculate_inflow(this, ilak, qin)
2621  ! -- dummy
2622  class(laktype), intent(inout) :: this
2623  integer(I4B), intent(in) :: ilak
2624  real(DP), intent(inout) :: qin
2625  !
2626  ! -- inflow to lake
2627  qin = this%inflow(ilak)
2628  end subroutine lak_calculate_inflow
2629 
2630  !> @brief Calculate the external flow terms to a lake
2631  !<
2632  subroutine lak_calculate_external(this, ilak, ex)
2633  ! -- dummy
2634  class(laktype), intent(inout) :: this
2635  integer(I4B), intent(in) :: ilak
2636  real(DP), intent(inout) :: ex
2637  !
2638  ! -- If mover is active, add receiver water to rhs and
2639  ! store available water (as positive value)
2640  ex = dzero
2641  if (this%imover == 1) then
2642  ex = this%pakmvrobj%get_qfrommvr(ilak)
2643  end if
2644  end subroutine lak_calculate_external
2645 
2646  !> @brief Calculate the withdrawal from a lake subject to an available volume
2647  !<
2648  subroutine lak_calculate_withdrawal(this, ilak, avail, wr)
2649  ! -- dummy
2650  class(laktype), intent(inout) :: this
2651  integer(I4B), intent(in) :: ilak
2652  real(DP), intent(inout) :: avail
2653  real(DP), intent(inout) :: wr
2654  !
2655  ! -- withdrawals - limit to sum of inflows and available volume
2656  wr = this%withdrawal(ilak)
2657  if (wr > avail) then
2658  wr = -avail
2659  else
2660  if (wr > dzero) then
2661  wr = -wr
2662  end if
2663  end if
2664  avail = avail + wr
2665  end subroutine lak_calculate_withdrawal
2666 
2667  !> @brief Calculate the evaporation from a lake at a provided stage subject
2668  !! to an available volume
2669  !<
2670  subroutine lak_calculate_evaporation(this, ilak, stage, avail, ev)
2671  ! -- dummy
2672  class(laktype), intent(inout) :: this
2673  integer(I4B), intent(in) :: ilak
2674  real(DP), intent(in) :: stage
2675  real(DP), intent(inout) :: avail
2676  real(DP), intent(inout) :: ev
2677  ! -- local
2678  real(DP) :: sa
2679  !
2680  ! -- evaporation - limit to sum of inflows and available volume
2681  call this%lak_calculate_sarea(ilak, stage, sa)
2682  ev = sa * this%evaporation(ilak)
2683  if (ev > avail) then
2684  if (is_close(avail, dprec)) then
2685  ev = dzero
2686  else
2687  ev = -avail
2688  end if
2689  else
2690  ev = -ev
2691  end if
2692  avail = avail + ev
2693  end subroutine lak_calculate_evaporation
2694 
2695  !> @brief Calculate the outlet inflow to a lake
2696  !<
2697  subroutine lak_calculate_outlet_inflow(this, ilak, outinf)
2698  ! -- dummy
2699  class(laktype), intent(inout) :: this
2700  integer(I4B), intent(in) :: ilak
2701  real(DP), intent(inout) :: outinf
2702  ! -- local
2703  integer(I4B) :: n
2704  !
2705  outinf = dzero
2706  do n = 1, this%noutlets
2707  if (this%lakeout(n) == ilak) then
2708  outinf = outinf - this%simoutrate(n)
2709  if (this%imover == 1) then
2710  outinf = outinf - this%pakmvrobj%get_qtomvr(n)
2711  end if
2712  end if
2713  end do
2714  end subroutine lak_calculate_outlet_inflow
2715 
2716  !> @brief Calculate the outlet outflow from a lake
2717  !<
2718  subroutine lak_calculate_outlet_outflow(this, ilak, stage, avail, outoutf)
2719  ! -- dummy
2720  class(laktype), intent(inout) :: this
2721  integer(I4B), intent(in) :: ilak
2722  real(DP), intent(in) :: stage
2723  real(DP), intent(inout) :: avail
2724  real(DP), intent(inout) :: outoutf
2725  ! -- local
2726  integer(I4B) :: n
2727  real(DP) :: g
2728  real(DP) :: d
2729  real(DP) :: c
2730  real(DP) :: gsm
2731  real(DP) :: rate
2732  !
2733  outoutf = dzero
2734  do n = 1, this%noutlets
2735  if (this%lakein(n) == ilak) then
2736  rate = dzero
2737  d = stage - this%outinvert(n)
2738  if (this%outdmax > dzero) then
2739  if (d > this%outdmax) d = this%outdmax
2740  end if
2741  g = dgravity * this%convlength * this%convtime * this%convtime
2742  select case (this%iouttype(n))
2743  ! specified rate
2744  case (0)
2745  rate = this%outrate(n)
2746  if (-rate > avail) then
2747  rate = -avail
2748  end if
2749  ! manning
2750  case (1)
2751  if (d > dzero) then
2752  c = (this%convlength**donethird) * this%convtime
2753  gsm = dzero
2754  if (this%outrough(n) > dzero) then
2755  gsm = done / this%outrough(n)
2756  end if
2757  rate = -c * gsm * this%outwidth(n) * (d**dfivethirds) * &
2758  sqrt(this%outslope(n))
2759  end if
2760  ! weir
2761  case (2)
2762  if (d > dzero) then
2763  rate = -dtwothirds * dcd * this%outwidth(n) * d * &
2764  sqrt(dtwo * g * d)
2765  end if
2766  end select
2767  this%simoutrate(n) = rate
2768  avail = avail + rate
2769  outoutf = outoutf + rate
2770  end if
2771  end do
2772  end subroutine lak_calculate_outlet_outflow
2773 
2774  !> @brief Total uncapped outlet outflow rate from a lake at a provided stage
2775  !!
2776  !! Side-effect-free companion to lak_calculate_outlet_outflow used by the
2777  !! implicit formulation: returns the summed (negative) rating-curve outflow for
2778  !! all outlets whose source is ilak, without applying the available-water cap or
2779  !! updating simoutrate. Used to linearize the outlet-outflow sink on the lake
2780  !! row in stage.
2781  !<
2782  subroutine lak_outlet_outflow_rate(this, ilak, stage, qout)
2783  ! -- dummy
2784  class(laktype), intent(inout) :: this
2785  integer(I4B), intent(in) :: ilak
2786  real(DP), intent(in) :: stage
2787  real(DP), intent(inout) :: qout
2788  ! -- local
2789  integer(I4B) :: n
2790  real(DP) :: g, d, c, gsm, rate
2791  !
2792  qout = dzero
2793  do n = 1, this%noutlets
2794  if (this%lakein(n) /= ilak) cycle
2795  rate = dzero
2796  d = stage - this%outinvert(n)
2797  if (this%outdmax > dzero .and. d > this%outdmax) d = this%outdmax
2798  g = dgravity * this%convlength * this%convtime * this%convtime
2799  select case (this%iouttype(n))
2800  case (0) ! specified rate
2801  rate = this%outrate(n)
2802  case (1) ! manning
2803  if (d > dzero) then
2804  c = (this%convlength**donethird) * this%convtime
2805  gsm = dzero
2806  if (this%outrough(n) > dzero) gsm = done / this%outrough(n)
2807  rate = -c * gsm * this%outwidth(n) * (d**dfivethirds) * &
2808  sqrt(this%outslope(n))
2809  end if
2810  case (2) ! weir
2811  if (d > dzero) then
2812  rate = -dtwothirds * dcd * this%outwidth(n) * d * sqrt(dtwo * g * d)
2813  end if
2814  end select
2815  qout = qout + rate
2816  end do
2817  end subroutine lak_outlet_outflow_rate
2818 
2819  !> @brief Get the outlet inflow to a lake from another lake
2820  !<
2821  subroutine lak_get_internal_inlet(this, ilak, outinf)
2822  ! -- dummy
2823  class(laktype), intent(inout) :: this
2824  integer(I4B), intent(in) :: ilak
2825  real(DP), intent(inout) :: outinf
2826  ! -- local
2827  integer(I4B) :: n
2828  !
2829  outinf = dzero
2830  do n = 1, this%noutlets
2831  if (this%lakeout(n) == ilak) then
2832  outinf = outinf - this%simoutrate(n)
2833  if (this%imover == 1) then
2834  outinf = outinf - this%pakmvrobj%get_qtomvr(n)
2835  end if
2836  end if
2837  end do
2838  end subroutine lak_get_internal_inlet
2839 
2840  !> @brief Get the outlet from a lake to another lake
2841  !<
2842  subroutine lak_get_internal_outlet(this, ilak, outoutf)
2843  ! -- dummy
2844  class(laktype), intent(inout) :: this
2845  integer(I4B), intent(in) :: ilak
2846  real(DP), intent(inout) :: outoutf
2847  ! -- local
2848  integer(I4B) :: n
2849  !
2850  outoutf = dzero
2851  do n = 1, this%noutlets
2852  if (this%lakein(n) == ilak) then
2853  if (this%lakeout(n) < 1) cycle
2854  outoutf = outoutf + this%simoutrate(n)
2855  end if
2856  end do
2857  end subroutine lak_get_internal_outlet
2858 
2859  !> @brief Get the outlet outflow from a lake to an external boundary
2860  !<
2861  subroutine lak_get_external_outlet(this, ilak, outoutf)
2862  ! -- dummy
2863  class(laktype), intent(inout) :: this
2864  integer(I4B), intent(in) :: ilak
2865  real(DP), intent(inout) :: outoutf
2866  ! -- local
2867  integer(I4B) :: n
2868  !
2869  outoutf = dzero
2870  do n = 1, this%noutlets
2871  if (this%lakein(n) == ilak) then
2872  if (this%lakeout(n) > 0) cycle
2873  outoutf = outoutf + this%simoutrate(n)
2874  end if
2875  end do
2876  end subroutine lak_get_external_outlet
2877 
2878  !> @brief Get the mover outflow from a lake to an external boundary
2879  !<
2880  subroutine lak_get_external_mover(this, ilak, outoutf)
2881  ! -- dummy
2882  class(laktype), intent(inout) :: this
2883  integer(I4B), intent(in) :: ilak
2884  real(DP), intent(inout) :: outoutf
2885  ! -- local
2886  integer(I4B) :: n
2887  !
2888  outoutf = dzero
2889  if (this%imover == 1) then
2890  do n = 1, this%noutlets
2891  if (this%lakein(n) == ilak) then
2892  if (this%lakeout(n) > 0) cycle
2893  outoutf = outoutf + this%pakmvrobj%get_qtomvr(n)
2894  end if
2895  end do
2896  end if
2897  end subroutine lak_get_external_mover
2898 
2899  !> @brief Get the mover outflow from a lake to another lake
2900  !<
2901  subroutine lak_get_internal_mover(this, ilak, outoutf)
2902  ! -- dummy
2903  class(laktype), intent(inout) :: this
2904  integer(I4B), intent(in) :: ilak
2905  real(DP), intent(inout) :: outoutf
2906  ! -- local
2907  integer(I4B) :: n
2908  !
2909  outoutf = dzero
2910  if (this%imover == 1) then
2911  do n = 1, this%noutlets
2912  if (this%lakein(n) == ilak) then
2913  if (this%lakeout(n) < 1) cycle
2914  outoutf = outoutf + this%pakmvrobj%get_qtomvr(n)
2915  end if
2916  end do
2917  end if
2918  end subroutine lak_get_internal_mover
2919 
2920  !> @brief Get the outlet to mover from a lake
2921  !<
2922  subroutine lak_get_outlet_tomover(this, ilak, outoutf)
2923  ! -- dummy
2924  class(laktype), intent(inout) :: this
2925  integer(I4B), intent(in) :: ilak
2926  real(DP), intent(inout) :: outoutf
2927  ! -- local
2928  integer(I4B) :: n
2929  !
2930  outoutf = dzero
2931  if (this%imover == 1) then
2932  do n = 1, this%noutlets
2933  if (this%lakein(n) == ilak) then
2934  outoutf = outoutf + this%pakmvrobj%get_qtomvr(n)
2935  end if
2936  end do
2937  end if
2938  end subroutine lak_get_outlet_tomover
2939 
2940  !> @brief Determine the stage from a provided volume
2941  !<
2942  subroutine lak_vol2stage(this, ilak, vol, stage)
2943  ! -- dummy
2944  class(laktype), intent(inout) :: this
2945  integer(I4B), intent(in) :: ilak
2946  real(DP), intent(in) :: vol
2947  real(DP), intent(inout) :: stage
2948  ! -- local
2949  integer(I4B) :: i
2950  integer(I4B) :: ibs
2951  real(DP) :: s0, s1, sm
2952  real(DP) :: v0, v1, vm
2953  real(DP) :: f0, f1, fm
2954  real(DP) :: sa
2955  real(DP) :: en0, en1
2956  real(DP) :: ds, ds0
2957  real(DP) :: denom
2958  !
2959  s0 = this%lakebot(ilak)
2960  call this%lak_calculate_vol(ilak, s0, v0)
2961  s1 = this%laketop(ilak)
2962  call this%lak_calculate_vol(ilak, s1, v1)
2963  ! -- zero volume
2964  if (vol <= v0) then
2965  stage = s0
2966  ! -- linear relation between stage and volume above top of lake
2967  else if (vol >= v1) then
2968  call this%lak_calculate_sarea(ilak, s1, sa)
2969  stage = s1 + (vol - v1) / sa
2970  ! -- use combination of secant and bisection
2971  else
2972  en0 = s0
2973  en1 = s1
2974  ! sm = s1 ! causes divide by zero in 1st line in secantbisection loop
2975  ! sm = s0 ! causes divide by zero in 1st line in secantbisection loop
2976  sm = dzero
2977  f0 = vol - v0
2978  f1 = vol - v1
2979  ibs = 0
2980  secantbisection: do i = 1, 150
2981  denom = f1 - f0
2982  if (denom /= dzero) then
2983  ds = f1 * (s1 - s0) / denom
2984  else
2985  ibs = 13
2986  end if
2987  if (i == 1) then
2988  ds0 = ds
2989  end if
2990  ! -- use bisection if end points are exceeded
2991  if (sm < en0 .or. sm > en1) ibs = 13
2992  ! -- use bisection if secant method stagnates or if
2993  ! ds exceeds previous ds - bisection would occur
2994  ! after conditions exceeded in 13 iterations
2995  if (ds * ds0 < dprec .or. abs(ds) > abs(ds0)) ibs = ibs + 1
2996  if (ibs > 12) then
2997  ds = dhalf * (s1 - s0)
2998  ibs = 0
2999  end if
3000  sm = s1 - ds
3001  if (abs(ds) < dem6) then
3002  exit secantbisection
3003  end if
3004  call this%lak_calculate_vol(ilak, sm, vm)
3005  fm = vol - vm
3006  s0 = s1
3007  f0 = f1
3008  s1 = sm
3009  f1 = fm
3010  ds0 = ds
3011  end do secantbisection
3012  stage = sm
3013  if (abs(ds) >= dem6) then
3014  write (this%iout, '(1x,a,1x,i0,4(1x,a,1x,g15.6))') &
3015  & 'LAK_VOL2STAGE failed for lake', ilak, 'volume error =', fm, &
3016  & 'finding stage (', stage, ') for volume =', vol, &
3017  & 'final change in stage =', ds
3018  end if
3019  end if
3020  end subroutine lak_vol2stage
3021 
3022  !> @brief Determine if a valid lake or outlet number has been specified
3023  function lak_check_valid(this, itemno) result(ierr)
3024  ! -- modules
3025  use simmodule, only: store_error
3026  ! -- return
3027  integer(I4B) :: ierr
3028  ! -- dummy
3029  class(laktype), intent(inout) :: this
3030  integer(I4B), intent(in) :: itemno
3031  ! -- local
3032  integer(I4B) :: ival
3033  !
3034  ierr = 0
3035  ival = abs(itemno)
3036  if (itemno > 0) then
3037  if (ival < 1 .or. ival > this%nlakes) then
3038  write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') &
3039  'LAKENO', itemno, 'must be greater than 0 and less than or equal to', &
3040  this%nlakes, '.'
3041  call store_error(errmsg)
3042  ierr = 1
3043  end if
3044  else
3045  if (ival < 1 .or. ival > this%noutlets) then
3046  write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') &
3047  'IOUTLET', itemno, 'must be greater than 0 and less than or equal to', &
3048  this%noutlets, '.'
3049  call store_error(errmsg)
3050  ierr = 1
3051  end if
3052  end if
3053  end function lak_check_valid
3054 
3055  !> @brief Set a stress period attribute for lakweslls(itemno) using keywords
3056  !<
3057  subroutine lak_set_stressperiod(this, itemno)
3058  ! -- modules
3059  use timeseriesmanagermodule, only: read_value_or_time_series_adv
3060  use simmodule, only: store_error
3061  ! -- dummy
3062  class(laktype), intent(inout) :: this
3063  integer(I4B), intent(in) :: itemno
3064  ! -- local
3065  character(len=LINELENGTH) :: text
3066  character(len=LINELENGTH) :: caux
3067  character(len=LINELENGTH) :: keyword
3068  integer(I4B) :: ierr
3069  integer(I4B) :: ii
3070  integer(I4B) :: jj
3071  real(DP), pointer :: bndElem => null()
3072  !
3073  ! -- read line
3074  call this%parser%GetStringCaps(keyword)
3075  select case (keyword)
3076  case ('STATUS')
3077  ierr = this%lak_check_valid(itemno)
3078  if (ierr /= 0) then
3079  goto 999
3080  end if
3081  call this%parser%GetStringCaps(text)
3082  this%status(itemno) = text(1:8)
3083  if (text == 'CONSTANT') then
3084  this%iboundpak(itemno) = -1
3085  else if (text == 'INACTIVE') then
3086  this%iboundpak(itemno) = 0
3087  else if (text == 'ACTIVE') then
3088  this%iboundpak(itemno) = 1
3089  else
3090  write (errmsg, '(a,a)') &
3091  'Unknown '//trim(this%text)//' lak status keyword: ', text//'.'
3092  call store_error(errmsg)
3093  end if
3094  case ('STAGE')
3095  ierr = this%lak_check_valid(itemno)
3096  if (ierr /= 0) then
3097  goto 999
3098  end if
3099  call this%parser%GetString(text)
3100  jj = 1 ! For STAGE
3101  bndelem => this%stage(itemno)
3102  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3103  this%packName, 'BND', this%tsManager, &
3104  this%iprpak, 'STAGE')
3105  case ('RAINFALL')
3106  ierr = this%lak_check_valid(itemno)
3107  if (ierr /= 0) then
3108  goto 999
3109  end if
3110  call this%parser%GetString(text)
3111  jj = 1 ! For RAINFALL
3112  bndelem => this%rainfall(itemno)
3113  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3114  this%packName, 'BND', this%tsManager, &
3115  this%iprpak, 'RAINFALL')
3116  if (this%rainfall(itemno) < dzero) then
3117  write (errmsg, '(a,i0,a,G0,a)') &
3118  'Lake ', itemno, ' was assigned a rainfall value of ', &
3119  this%rainfall(itemno), '. Rainfall must be positive.'
3120  call store_error(errmsg)
3121  end if
3122  case ('EVAPORATION')
3123  ierr = this%lak_check_valid(itemno)
3124  if (ierr /= 0) then
3125  goto 999
3126  end if
3127  call this%parser%GetString(text)
3128  jj = 1 ! For EVAPORATION
3129  bndelem => this%evaporation(itemno)
3130  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3131  this%packName, 'BND', this%tsManager, &
3132  this%iprpak, 'EVAPORATION')
3133  if (this%evaporation(itemno) < dzero) then
3134  write (errmsg, '(a,i0,a,G0,a)') &
3135  'Lake ', itemno, ' was assigned an evaporation value of ', &
3136  this%evaporation(itemno), '. Evaporation must be positive.'
3137  call store_error(errmsg)
3138  end if
3139  case ('RUNOFF')
3140  ierr = this%lak_check_valid(itemno)
3141  if (ierr /= 0) then
3142  goto 999
3143  end if
3144  call this%parser%GetString(text)
3145  jj = 1 ! For RUNOFF
3146  bndelem => this%runoff(itemno)
3147  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3148  this%packName, 'BND', this%tsManager, &
3149  this%iprpak, 'RUNOFF')
3150  if (this%runoff(itemno) < dzero) then
3151  write (errmsg, '(a,i0,a,G0,a)') &
3152  'Lake ', itemno, ' was assigned a runoff value of ', &
3153  this%runoff(itemno), '. Runoff must be positive.'
3154  call store_error(errmsg)
3155  end if
3156  case ('INFLOW')
3157  ierr = this%lak_check_valid(itemno)
3158  if (ierr /= 0) then
3159  goto 999
3160  end if
3161  call this%parser%GetString(text)
3162  jj = 1 ! For specified INFLOW
3163  bndelem => this%inflow(itemno)
3164  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3165  this%packName, 'BND', this%tsManager, &
3166  this%iprpak, 'INFLOW')
3167  if (this%inflow(itemno) < dzero) then
3168  write (errmsg, '(a,i0,a,G0,a)') &
3169  'Lake ', itemno, ' was assigned an inflow value of ', &
3170  this%inflow(itemno), '. Inflow must be positive.'
3171  call store_error(errmsg)
3172  end if
3173  case ('WITHDRAWAL')
3174  ierr = this%lak_check_valid(itemno)
3175  if (ierr /= 0) then
3176  goto 999
3177  end if
3178  call this%parser%GetString(text)
3179  jj = 1 ! For specified WITHDRAWAL
3180  bndelem => this%withdrawal(itemno)
3181  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3182  this%packName, 'BND', this%tsManager, &
3183  this%iprpak, 'WITHDRAWAL')
3184  if (this%withdrawal(itemno) < dzero) then
3185  write (errmsg, '(a,i0,a,G0,a)') &
3186  'Lake ', itemno, ' was assigned a withdrawal value of ', &
3187  this%withdrawal(itemno), '. Withdrawal must be positive.'
3188  call store_error(errmsg)
3189  end if
3190  case ('RATE')
3191  ierr = this%lak_check_valid(-itemno)
3192  if (ierr /= 0) then
3193  goto 999
3194  end if
3195  call this%parser%GetString(text)
3196  jj = 1 ! For specified OUTLET RATE
3197  bndelem => this%outrate(itemno)
3198  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3199  this%packName, 'BND', this%tsManager, &
3200  this%iprpak, 'RATE')
3201  case ('INVERT')
3202  ierr = this%lak_check_valid(-itemno)
3203  if (ierr /= 0) then
3204  goto 999
3205  end if
3206  call this%parser%GetString(text)
3207  jj = 1 ! For OUTLET INVERT
3208  bndelem => this%outinvert(itemno)
3209  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3210  this%packName, 'BND', this%tsManager, &
3211  this%iprpak, 'INVERT')
3212  case ('WIDTH')
3213  ierr = this%lak_check_valid(-itemno)
3214  if (ierr /= 0) then
3215  goto 999
3216  end if
3217  call this%parser%GetString(text)
3218  jj = 1 ! For OUTLET WIDTH
3219  bndelem => this%outwidth(itemno)
3220  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3221  this%packName, 'BND', this%tsManager, &
3222  this%iprpak, 'WIDTH')
3223  case ('ROUGH')
3224  ierr = this%lak_check_valid(-itemno)
3225  if (ierr /= 0) then
3226  goto 999
3227  end if
3228  call this%parser%GetString(text)
3229  jj = 1 ! For OUTLET ROUGHNESS
3230  bndelem => this%outrough(itemno)
3231  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3232  this%packName, 'BND', this%tsManager, &
3233  this%iprpak, 'ROUGH')
3234  case ('SLOPE')
3235  ierr = this%lak_check_valid(-itemno)
3236  if (ierr /= 0) then
3237  goto 999
3238  end if
3239  call this%parser%GetString(text)
3240  jj = 1 ! For OUTLET SLOPE
3241  bndelem => this%outslope(itemno)
3242  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3243  this%packName, 'BND', this%tsManager, &
3244  this%iprpak, 'SLOPE')
3245  case ('AUXILIARY')
3246  ierr = this%lak_check_valid(itemno)
3247  if (ierr /= 0) then
3248  goto 999
3249  end if
3250  call this%parser%GetStringCaps(caux)
3251  do jj = 1, this%naux
3252  if (trim(adjustl(caux)) /= trim(adjustl(this%auxname(jj)))) cycle
3253  call this%parser%GetString(text)
3254  ii = itemno
3255  bndelem => this%lauxvar(jj, ii)
3256  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
3257  this%packName, 'AUX', &
3258  this%tsManager, this%iprpak, &
3259  this%auxname(jj))
3260  exit
3261  end do
3262  case default
3263  write (errmsg, '(2a)') &
3264  'Unknown '//trim(this%text)//' lak data keyword: ', &
3265  trim(keyword)//'.'
3266  end select
3267  !
3268  ! -- Return
3269 999 return
3270  end subroutine lak_set_stressperiod
3271 
3272  !> @brief Issue a parameter error for lakweslls(ilak)
3273  !!
3274  !! Read itmp and new boundaries if itmp > 0
3275  !<
3276  subroutine lak_set_attribute_error(this, ilak, keyword, msg)
3277  ! -- modules
3278  use simmodule, only: store_error
3279  ! -- dummy
3280  class(laktype), intent(inout) :: this
3281  integer(I4B), intent(in) :: ilak
3282  character(len=*), intent(in) :: keyword
3283  character(len=*), intent(in) :: msg
3284  !
3285  if (len(msg) == 0) then
3286  write (errmsg, '(a,1x,a,1x,i0,1x,a)') &
3287  keyword, ' for LAKE', ilak, 'has already been set.'
3288  else
3289  write (errmsg, '(a,1x,a,1x,i0,1x,a)') keyword, ' for LAKE', ilak, msg
3290  end if
3291  call store_error(errmsg)
3292  end subroutine lak_set_attribute_error
3293 
3294  !> @brief Set options specific to LakType
3295  !!
3296  !! lak_options overrides BndType%bnd_options
3297  !<
3298  subroutine lak_options(this, option, found)
3299  ! -- modules
3300  use constantsmodule, only: maxcharlen, dzero, mnormal
3301  use openspecmodule, only: access, form
3302  use simmodule, only: store_error
3303  use inputoutputmodule, only: urword, getunit, assign_iounit, openfile
3304  ! -- dummy
3305  class(laktype), intent(inout) :: this
3306  character(len=*), intent(inout) :: option
3307  logical(LGP), intent(inout) :: found
3308  ! -- local
3309  character(len=MAXCHARLEN) :: fname, keyword
3310  real(DP) :: r
3311  ! -- formats
3312  character(len=*), parameter :: fmtlengthconv = &
3313  &"(4x, 'LENGTH CONVERSION VALUE (',g15.7,') SPECIFIED.')"
3314  character(len=*), parameter :: fmttimeconv = &
3315  &"(4x, 'TIME CONVERSION VALUE (',g15.7,') SPECIFIED.')"
3316  character(len=*), parameter :: fmtoutdmax = &
3317  &"(4x, 'MAXIMUM OUTLET WATER DEPTH (',g15.7,') SPECIFIED.')"
3318  character(len=*), parameter :: fmtlakeopt = &
3319  &"(4x, 'LAKE ', a, ' VALUE (',g15.7,') SPECIFIED.')"
3320  character(len=*), parameter :: fmtlakbin = &
3321  "(4x, 'LAK ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', &
3322  &a, /4x, 'OPENED ON UNIT: ', I0)"
3323  character(len=*), parameter :: fmtiter = &
3324  &"(4x, 'MAXIMUM LAK ITERATION VALUE (',i0,') SPECIFIED.')"
3325  character(len=*), parameter :: fmtdmaxchg = &
3326  &"(4x, 'MAXIMUM STAGE CHANGE VALUE (',g0,') SPECIFIED.')"
3327  !
3328  found = .true.
3329  select case (option)
3330  case ('PRINT_STAGE')
3331  this%iprhed = 1
3332  write (this%iout, '(4x,a)') trim(adjustl(this%text))// &
3333  ' STAGES WILL BE PRINTED TO LISTING FILE.'
3334  case ('STAGE')
3335  call this%parser%GetStringCaps(keyword)
3336  if (keyword == 'FILEOUT') then
3337  call this%parser%GetString(fname)
3338  this%istageout = getunit()
3339  call openfile(this%istageout, this%iout, fname, 'DATA(BINARY)', &
3340  form, access, 'REPLACE', mode_opt=mnormal)
3341  write (this%iout, fmtlakbin) 'STAGE', trim(adjustl(fname)), &
3342  this%istageout
3343  else
3344  call store_error('OPTIONAL STAGE KEYWORD MUST BE FOLLOWED BY FILEOUT')
3345  end if
3346  case ('BUDGET')
3347  call this%parser%GetStringCaps(keyword)
3348  if (keyword == 'FILEOUT') then
3349  call this%parser%GetString(fname)
3350  call assign_iounit(this%ibudgetout, this%inunit, "BUDGET fileout")
3351  call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', &
3352  form, access, 'REPLACE', mode_opt=mnormal)
3353  write (this%iout, fmtlakbin) 'BUDGET', trim(adjustl(fname)), &
3354  this%ibudgetout
3355  else
3356  call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT')
3357  end if
3358  case ('BUDGETCSV')
3359  call this%parser%GetStringCaps(keyword)
3360  if (keyword == 'FILEOUT') then
3361  call this%parser%GetString(fname)
3362  call assign_iounit(this%ibudcsv, this%inunit, "BUDGETCSV fileout")
3363  call openfile(this%ibudcsv, this%iout, fname, 'CSV', &
3364  filstat_opt='REPLACE')
3365  write (this%iout, fmtlakbin) 'BUDGET CSV', trim(adjustl(fname)), &
3366  this%ibudcsv
3367  else
3368  call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY &
3369  &FILEOUT')
3370  end if
3371  case ('PACKAGE_CONVERGENCE')
3372  call this%parser%GetStringCaps(keyword)
3373  if (keyword == 'FILEOUT') then
3374  call this%parser%GetString(fname)
3375  ! -- defer opening until lak_ar, where the IMPLICIT option is known. The
3376  ! file is not opened for the implicit formulation (lak_cc does not
3377  ! write package convergence in that case).
3378  this%pakcsvfile = trim(adjustl(fname))
3379  else
3380  call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE '// &
3381  'FOLLOWED BY FILEOUT')
3382  end if
3383  case ('MOVER')
3384  this%imover = 1
3385  write (this%iout, '(4x,A)') 'MOVER OPTION ENABLED'
3386  case ('LENGTH_CONVERSION')
3387  this%convlength = this%parser%GetDouble()
3388  write (this%iout, fmtlengthconv) this%convlength
3389  case ('TIME_CONVERSION')
3390  this%convtime = this%parser%GetDouble()
3391  write (this%iout, fmttimeconv) this%convtime
3392  case ('SURFDEP')
3393  r = this%parser%GetDouble()
3394  if (r < dzero) then
3395  r = dzero
3396  end if
3397  this%surfdep = r
3398  write (this%iout, fmtlakeopt) 'SURFDEP', this%surfdep
3399  case ('MAXIMUM_ITERATIONS')
3400  this%maxlakit = this%parser%GetInteger()
3401  write (this%iout, fmtiter) this%maxlakit
3402  case ('MAXIMUM_STAGE_CHANGE')
3403  r = this%parser%GetDouble()
3404  this%dmaxchg = r
3405  this%delh = dp999 * r
3406  write (this%iout, fmtdmaxchg) this%dmaxchg
3407  !
3408  ! -- right now these are options that are only available in the
3409  ! development version and are not included in the documentation.
3410  ! These options are only available when IDEVELOPMODE in
3411  ! constants module is set to 1
3412  case ('DEV_GROUNDWATER_HEAD_CONDUCTANCE')
3413  call this%parser%DevOpt()
3414  this%igwhcopt = 1
3415  write (this%iout, '(4x,a)') &
3416  'CONDUCTANCE FOR HORIZONTAL CONNECTIONS WILL BE CALCULATED &
3417  &USING THE GROUNDWATER HEAD'
3418  case ('DEV_MAXIMUM_OUTLET_DEPTH')
3419  call this%parser%DevOpt()
3420  this%outdmax = this%parser%GetDouble()
3421  write (this%iout, fmtoutdmax) this%outdmax
3422  case ('IMPLICIT')
3423  this%iimplicit = 1
3424  write (this%iout, '(4x,a)') &
3425  'LAKE STAGE WILL BE SOLVED AS AN UNKNOWN IN THE GROUNDWATER FLOW '// &
3426  'MATRIX (IMPLICIT FORMULATION)'
3427  case ('DEV_FORCE_LEGACY')
3428  call this%parser%DevOpt()
3429  this%iforceleg = 1
3430  write (this%iout, '(4x,a)') &
3431  'EVERY ACTIVE LAKE WILL BE SOLVED WITH THE LEGACY SUBSTITUTION '// &
3432  'SOLVER UNDER THE IMPLICIT FORMULATION'
3433  if (this%iforceleglak /= 0) then
3434  call store_error('DEV_FORCE_LEGACY and DEV_FORCE_LEGACY_LAKE '// &
3435  'cannot both be specified.')
3436  end if
3437  case ('DEV_FORCE_LEGACY_LAKE')
3438  call this%parser%DevOpt()
3439  this%iforceleglak = this%parser%GetInteger()
3440  write (this%iout, '(4x,a,i0,a)') 'LAKE ', this%iforceleglak, &
3441  ' WILL BE SOLVED WITH THE LEGACY SUBSTITUTION SOLVER UNDER THE '// &
3442  'IMPLICIT FORMULATION'
3443  if (this%iforceleg /= 0) then
3444  call store_error('DEV_FORCE_LEGACY and DEV_FORCE_LEGACY_LAKE '// &
3445  'cannot both be specified.')
3446  end if
3447  case ('DEV_NO_FINAL_CHECK')
3448  call this%parser%DevOpt()
3449  this%iconvchk = 0
3450  write (this%iout, '(4x,a)') &
3451  'A FINAL CONVERGENCE CHECK OF THE CHANGE IN LAKE STAGES &
3452  &WILL NOT BE MADE'
3453  case default
3454  !
3455  ! -- No options found
3456  found = .false.
3457  end select
3458  end subroutine lak_options
3459 
3460  !> @brief Allocate and Read
3461  !!
3462  !! Create new LAK package and point bndobj to the new package
3463  !<
3464  subroutine lak_ar(this)
3465  ! -- modules
3466  use constantsmodule, only: mnormal
3467  use inputoutputmodule, only: getunit, openfile
3468  ! -- dummy
3469  class(laktype), intent(inout) :: this
3470  ! -- formats
3471  character(len=*), parameter :: fmtlakbin = &
3472  "(4x, 'LAK ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', &
3473  &a, /4x, 'OPENED ON UNIT: ', I0)"
3474  !
3475  ! -- open the deferred PACKAGE_CONVERGENCE file now that all options have
3476  ! been read. lak_cc does not write package convergence for the implicit
3477  ! formulation, because the lake stage is part of the solver (IMS)
3478  ! convergence check. With the IMPLICIT option the file is therefore left
3479  ! unopened (ipakcsv stays 0) and a warning is issued instead.
3480  if (allocated(this%pakcsvfile)) then
3481  if (this%iimplicit /= 0) then
3482  write (warnmsg, '(a)') &
3483  'PACKAGE_CONVERGENCE output file "'//trim(this%pakcsvfile)// &
3484  '" is not written when the IMPLICIT option is active; the lake '// &
3485  'stage is part of the solver (IMS) convergence check.'
3486  call store_warning(warnmsg)
3487  else
3488  this%ipakcsv = getunit()
3489  call openfile(this%ipakcsv, this%iout, this%pakcsvfile, 'CSV', &
3490  filstat_opt='REPLACE', mode_opt=mnormal)
3491  write (this%iout, fmtlakbin) 'PACKAGE_CONVERGENCE', &
3492  trim(this%pakcsvfile), this%ipakcsv
3493  end if
3494  deallocate (this%pakcsvfile)
3495  end if
3496  !
3497  call this%obs%obs_ar()
3498  !
3499  ! -- Allocate arrays in LAK and in package superclass
3500  call this%lak_allocate_arrays()
3501  !
3502  ! -- read optional initial package parameters
3503  call this%read_initial_attr()
3504  !
3505  ! -- setup pakmvrobj
3506  if (this%imover /= 0) then
3507  allocate (this%pakmvrobj)
3508  call this%pakmvrobj%ar(this%noutlets, this%nlakes, this%memoryPath)
3509  end if
3510  end subroutine lak_ar
3511 
3512  !> @brief Read and Prepare
3513  !!
3514  !! Read itmp and read new boundaries if itmp > 0
3515  !<
3516  subroutine lak_rp(this)
3517  ! -- modules
3518  use constantsmodule, only: linelength
3519  use tdismodule, only: kper, nper
3520  use simmodule, only: store_error, count_errors
3521  ! -- dummy
3522  class(laktype), intent(inout) :: this
3523  ! -- local
3524  character(len=LINELENGTH) :: title
3525  character(len=LINELENGTH) :: line
3526  character(len=LINELENGTH) :: text
3527  logical(LGP) :: isfound
3528  logical(LGP) :: endOfBlock
3529  integer(I4B) :: ierr
3530  integer(I4B) :: node
3531  integer(I4B) :: n
3532  integer(I4B) :: itemno
3533  integer(I4B) :: j
3534  ! -- formats
3535  character(len=*), parameter :: fmtblkerr = &
3536  &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')"
3537  character(len=*), parameter :: fmtlsp = &
3538  &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')"
3539  !
3540  ! -- set nbound to maxbound
3541  this%nbound = this%maxbound
3542  !
3543  ! -- Set ionper to the stress period number for which a new block of data
3544  ! will be read.
3545  if (this%inunit == 0) return
3546  !
3547  ! -- get stress period data
3548  if (this%ionper < kper) then
3549  !
3550  ! -- get period block
3551  call this%parser%GetBlock('PERIOD', isfound, ierr, &
3552  supportopenclose=.true., &
3553  blockrequired=.false.)
3554  if (isfound) then
3555  !
3556  ! -- read ionper and check for increasing period numbers
3557  call this%read_check_ionper()
3558  else
3559  !
3560  ! -- PERIOD block not found
3561  if (ierr < 0) then
3562  ! -- End of file found; data applies for remainder of simulation.
3563  this%ionper = nper + 1
3564  else
3565  ! -- Found invalid block
3566  call this%parser%GetCurrentLine(line)
3567  write (errmsg, fmtblkerr) adjustl(trim(line))
3568  call store_error(errmsg)
3569  call this%parser%StoreErrorUnit()
3570  end if
3571  end if
3572  end if
3573  !
3574  ! -- Read data if ionper == kper
3575  if (this%ionper == kper) then
3576  !
3577  ! -- setup table for period data
3578  if (this%iprpak /= 0) then
3579  !
3580  ! -- reset the input table object
3581  title = trim(adjustl(this%text))//' PACKAGE ('// &
3582  trim(adjustl(this%packName))//') DATA FOR PERIOD'
3583  write (title, '(a,1x,i6)') trim(adjustl(title)), kper
3584  call table_cr(this%inputtab, this%packName, title)
3585  call this%inputtab%table_df(1, 4, this%iout, finalize=.false.)
3586  text = 'NUMBER'
3587  call this%inputtab%initialize_column(text, 10, alignment=tabcenter)
3588  text = 'KEYWORD'
3589  call this%inputtab%initialize_column(text, 20, alignment=tableft)
3590  do n = 1, 2
3591  write (text, '(a,1x,i6)') 'VALUE', n
3592  call this%inputtab%initialize_column(text, 15, alignment=tabcenter)
3593  end do
3594  end if
3595  !
3596  ! -- read the data
3597  this%check_attr = 1
3598  stressperiod: do
3599  call this%parser%GetNextLine(endofblock)
3600  if (endofblock) exit
3601  !
3602  ! -- get lake or outlet number
3603  itemno = this%parser%GetInteger()
3604  !
3605  ! -- read data from the rest of the line
3606  call this%lak_set_stressperiod(itemno)
3607  !
3608  ! -- write line to table
3609  if (this%iprpak /= 0) then
3610  call this%parser%GetCurrentLine(line)
3611  call this%inputtab%line_to_columns(line)
3612  end if
3613  end do stressperiod
3614  !
3615  if (this%iprpak /= 0) then
3616  call this%inputtab%finalize_table()
3617  end if
3618  !
3619  ! -- using stress period data from the previous stress period
3620  else
3621  write (this%iout, fmtlsp) trim(this%filtyp)
3622  end if
3623  !
3624  ! -- write summary of lake stress period error messages
3625  if (count_errors() > 0) then
3626  call this%parser%StoreErrorUnit()
3627  end if
3628  !
3629  ! -- fill bound array with lake stage, conductance, and bottom elevation
3630  do n = 1, this%nlakes
3631  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
3632  node = this%cellid(j)
3633  this%nodelist(j) = node
3634  this%bound(1, j) = this%xnewpak(n)
3635  this%bound(2, j) = this%satcond(j)
3636  this%bound(3, j) = this%belev(j)
3637  end do
3638  end do
3639  !
3640  ! -- copy lakein into iprmap so mvr budget contains lake instead of outlet
3641  if (this%imover == 1) then
3642  do n = 1, this%noutlets
3643  this%pakmvrobj%iprmap(n) = this%lakein(n)
3644  end do
3645  end if
3646  end subroutine lak_rp
3647 
3648  !> @brief Add package connection to matrix
3649  !<
3650  subroutine lak_ad(this)
3651  ! -- modules
3652  use simvariablesmodule, only: ifailedstepretry
3653  ! -- dummy
3654  class(laktype) :: this
3655  ! -- local
3656  integer(I4B) :: n
3657  integer(I4B) :: j
3658  integer(I4B) :: iaux
3659  !
3660  ! -- Advance the time series
3661  call this%TsManager%ad()
3662  !
3663  ! -- update auxiliary variables by copying from the derived-type time
3664  ! series variable into the bndpackage auxvar variable so that this
3665  ! information is properly written to the GWF budget file
3666  if (this%naux > 0) then
3667  do n = 1, this%nlakes
3668  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
3669  do iaux = 1, this%naux
3670  if (this%noupdateauxvar(iaux) /= 0) cycle
3671  this%auxvar(iaux, j) = this%lauxvar(iaux, n)
3672  end do
3673  end do
3674  end do
3675  end if
3676  !
3677  ! -- Update or restore state
3678  if (ifailedstepretry == 0) then
3679  !
3680  ! -- copy xnew into xold and set xnewpak to stage for
3681  ! constant stage lakes
3682  do n = 1, this%nlakes
3683  this%xoldpak(n) = this%xnewpak(n)
3684  this%stageiter(n) = this%xnewpak(n)
3685  if (this%iboundpak(n) < 0) then
3686  this%xnewpak(n) = this%stage(n)
3687  end if
3688  this%seep0(n) = dzero
3689  end do
3690  else
3691  !
3692  ! -- copy xold back into xnew as this is a
3693  ! retry of this time step
3694  do n = 1, this%nlakes
3695  this%xnewpak(n) = this%xoldpak(n)
3696  this%stageiter(n) = this%xnewpak(n)
3697  if (this%iboundpak(n) < 0) then
3698  this%xnewpak(n) = this%stage(n)
3699  end if
3700  this%seep0(n) = dzero
3701  end do
3702  end if
3703  !
3704  ! -- pakmvrobj ad
3705  if (this%imover == 1) then
3706  call this%pakmvrobj%ad()
3707  end if
3708  !
3709  ! -- For each observation, push simulated value and corresponding
3710  ! simulation time from "current" to "preceding" and reset
3711  ! "current" value.
3712  call this%obs%obs_ad()
3713  end subroutine lak_ad
3714 
3715  !> @brief Formulate the HCOF and RHS terms
3716  !!
3717  !! Skip if no lakes, otherwise calculate hcof and rhs
3718  !<
3719  subroutine lak_cf(this)
3720  ! -- dummy
3721  class(laktype) :: this
3722  ! -- local
3723  integer(I4B) :: j, n
3724  integer(I4B) :: igwfnode
3725  real(DP) :: hlak, bottom_lake
3726  !
3727  ! -- save groundwater seepage for lake solution
3728  do n = 1, this%nlakes
3729  this%seep0(n) = this%seep(n)
3730  end do
3731  !
3732  ! -- save variables for convergence check
3733  do n = 1, this%nlakes
3734  this%s0(n) = this%xnewpak(n)
3735  call this%lak_calculate_exchange(n, this%s0(n), this%qgwf0(n))
3736  end do
3737  !
3738  ! -- find highest active cell
3739  do n = 1, this%nlakes
3740  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
3741  ! -- skip horizontal connections
3742  if (this%ictype(j) /= 0) then
3743  cycle
3744  end if
3745  igwfnode = this%nodesontop(j)
3746  if (this%ibound(igwfnode) == 0) then
3747  call this%dis%highest_active(igwfnode, this%ibound)
3748  end if
3749  this%nodelist(j) = igwfnode
3750  this%cellid(j) = igwfnode
3751  end do
3752  end do
3753  !
3754  ! -- reset ibound for cells where lake stage is above the bottom
3755  ! of the lake in the cell or the lake is inactive - only applied to
3756  ! vertical connections
3757  do n = 1, this%nlakes
3758  !
3759  hlak = this%xnewpak(n)
3760  !
3761  ! -- Go through lake connections
3762  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
3763  !
3764  ! -- assign gwf node number
3765  igwfnode = this%cellid(j)
3766  !
3767  ! -- skip inactive or constant head GWF cells
3768  if (this%ibound(igwfnode) < 1) then
3769  cycle
3770  end if
3771  !
3772  ! -- skip horizontal connections
3773  if (this%ictype(j) /= 0) then
3774  cycle
3775  end if
3776  !
3777  ! -- skip embedded lakes
3778  if (this%ictype(j) == 2 .or. this%ictype(j) == 3) then
3779  cycle
3780  end if
3781  !
3782  ! -- Mark ibound for wet lakes or inactive lakes; reset to 1 otherwise
3783  bottom_lake = this%belev(j)
3784  if (hlak > bottom_lake .or. this%iboundpak(n) == 0) then
3785  this%ibound(igwfnode) = iwetlake
3786  else
3787  this%ibound(igwfnode) = 1
3788  end if
3789  end do
3790  !
3791  end do
3792  !
3793  ! -- Store the lake stage and cond in bound array for other
3794  ! packages, such as the BUY package
3795  call this%lak_bound_update()
3796  end subroutine lak_cf
3797 
3798  !> @brief Copy rhs and hcof into solution rhs and amat
3799  !<
3800  subroutine lak_fc(this, rhs, ia, idxglo, matrix_sln)
3801  ! -- dummy
3802  class(laktype) :: this
3803  real(DP), dimension(:), intent(inout) :: rhs
3804  integer(I4B), dimension(:), intent(in) :: ia
3805  integer(I4B), dimension(:), intent(in) :: idxglo
3806  class(matrixbasetype), pointer :: matrix_sln
3807  ! -- local
3808  integer(I4B) :: j, n
3809  integer(I4B) :: igwfnode
3810  integer(I4B) :: ipossymd
3811  !
3812  ! -- pakmvrobj fc
3813  if (this%imover == 1) then
3814  call this%pakmvrobj%fc()
3815  end if
3816  !
3817  ! -- implicit formulation: assemble the lake equations directly into the
3818  ! groundwater flow matrix instead of solving the stage by substitution
3819  if (this%iimplicit /= 0) then
3820  call this%lak_fc_implicit(rhs, matrix_sln)
3821  return
3822  end if
3823  !
3824  ! -- legacy formulation: solve the lake stage by substitution, then add the
3825  ! resulting lake-aquifer exchange terms to the groundwater flow matrix
3826  call this%lak_solve()
3827  do n = 1, this%nlakes
3828  if (this%iboundpak(n) == 0) cycle
3829  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
3830  igwfnode = this%cellid(j)
3831  if (this%ibound(igwfnode) < 1) cycle
3832  ipossymd = idxglo(ia(igwfnode))
3833  call matrix_sln%add_value_pos(ipossymd, this%hcof(j))
3834  rhs(igwfnode) = rhs(igwfnode) + this%rhs(j)
3835  end do
3836  end do
3837  end subroutine lak_fc
3838 
3839  !> @brief Fill newton terms
3840  !<
3841  subroutine lak_fn(this, rhs, ia, idxglo, matrix_sln)
3842  ! -- dummy
3843  class(laktype) :: this
3844  real(DP), dimension(:), intent(inout) :: rhs
3845  integer(I4B), dimension(:), intent(in) :: ia
3846  integer(I4B), dimension(:), intent(in) :: idxglo
3847  class(matrixbasetype), pointer :: matrix_sln
3848  ! -- local
3849  integer(I4B) :: j, n
3850  integer(I4B) :: ipos
3851  integer(I4B) :: igwfnode
3852  integer(I4B) :: idry
3853  real(DP) :: hlak
3854  real(DP) :: avail
3855  real(DP) :: ra
3856  real(DP) :: ro
3857  real(DP) :: qinf
3858  real(DP) :: ex
3859  real(DP) :: head
3860  real(DP) :: q
3861  real(DP) :: q1
3862  real(DP) :: rterm
3863  real(DP) :: drterm
3864  !
3865  ! -- implicit formulation: the lakebed seepage Jacobian is already
3866  ! assembled exactly in lak_fc_implicit for constant-conductance
3867  ! (confined / saturated) connections. Nonlinear conductance Newton terms
3868  ! are Phase 2.
3869  if (this%iimplicit /= 0) then
3870  return
3871  end if
3872  !
3873  do n = 1, this%nlakes
3874  if (this%iboundpak(n) == 0) cycle
3875  hlak = this%xnewpak(n)
3876  call this%lak_calculate_available(n, hlak, avail, &
3877  ra, ro, qinf, ex, this%delh)
3878  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
3879  igwfnode = this%cellid(j)
3880  ipos = ia(igwfnode)
3881  head = this%xnew(igwfnode)
3882  if (-this%hcof(j) > dzero) then
3883  if (this%ibound(igwfnode) > 0) then
3884  ! -- estimate lake-aquifer exchange with perturbed groundwater head
3885  ! exchange is relative to the lake
3886  !avail = DEP20
3887  call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, &
3888  head + this%delh, q1, avail)
3889  q1 = -q1
3890  ! -- calculate unperturbed lake-aquifer exchange
3891  q = this%hcof(j) * head - this%rhs(j)
3892  ! -- calculate rterm
3893  rterm = this%hcof(j) * head
3894  ! -- calculate derivative
3895  drterm = (q1 - q) / this%delh
3896  ! -- add terms to convert conductance formulation into
3897  ! newton-raphson formulation
3898  call matrix_sln%add_value_pos(idxglo(ipos), drterm - this%hcof(j))
3899  rhs(igwfnode) = rhs(igwfnode) - rterm + drterm * head
3900  end if
3901  end if
3902  end do
3903  end do
3904  end subroutine lak_fn
3905 
3906  !> @brief Apply Newton under-relaxation to the lake stage
3907  !!
3908  !! Implicit formulation only. The model Newton under-relaxation step (gwf_nur)
3909  !! calls this routine with the lake-stage part of the solution. If an updated
3910  !! stage falls below the lake bottom, it is relaxed back toward the bottom (90
3911  !! percent of the way) and its change is zeroed. Active only when the model
3912  !! uses NEWTON UNDER_RELAXATION.
3913  !<
3914  subroutine lak_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax)
3915  ! -- dummy
3916  class(laktype), intent(inout) :: this
3917  integer(I4B), intent(in) :: neqpak
3918  real(DP), dimension(neqpak), intent(inout) :: x
3919  real(DP), dimension(neqpak), intent(in) :: xtemp
3920  real(DP), dimension(neqpak), intent(inout) :: dx
3921  integer(I4B), intent(inout) :: inewtonur
3922  real(DP), intent(inout) :: dxmax
3923  integer(I4B), intent(inout) :: locmax
3924  ! -- local
3925  integer(I4B) :: n
3926  real(DP) :: botl
3927  real(DP) :: xx
3928  real(DP) :: dxx
3929  !
3930  ! -- only the implicit formulation has the lake stage in the global solution
3931  if (this%iimplicit == 0) return
3932  !
3933  ! -- Newton-Raphson under-relaxation: hold the stage at the lake bottom
3934  do n = 1, this%nlakes
3935  if (this%iboundpak(n) < 1) cycle
3936  botl = this%lakebot(n)
3937  !
3938  ! -- only apply under-relaxation if the updated stage is below the bottom
3939  ! of the lake
3940  if (x(n) < botl) then
3941  inewtonur = 1
3942  xx = xtemp(n) * (done - dp9) + botl * dp9
3943  dxx = x(n) - xx
3944  if (abs(dxx) > abs(dxmax)) then
3945  locmax = n
3946  dxmax = dxx
3947  end if
3948  x(n) = xx
3949  dx(n) = dzero
3950  end if
3951  end do
3952  end subroutine lak_nur
3953 
3954  !> @brief Final convergence check for package
3955  !<
3956  subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak)
3957  ! -- modules
3958  use tdismodule, only: totim, kstp, kper, delt
3959  ! -- dummy
3960  class(laktype), intent(inout) :: this
3961  integer(I4B), intent(in) :: innertot
3962  integer(I4B), intent(in) :: kiter
3963  integer(I4B), intent(in) :: iend
3964  integer(I4B), intent(in) :: icnvgmod
3965  character(len=LENPAKLOC), intent(inout) :: cpak
3966  integer(I4B), intent(inout) :: ipak
3967  real(DP), intent(inout) :: dpak
3968  ! -- local
3969  character(len=LENPAKLOC) :: cloc
3970  character(len=LINELENGTH) :: tag
3971  integer(I4B) :: icheck
3972  integer(I4B) :: ipakfail
3973  integer(I4B) :: locdhmax
3974  integer(I4B) :: locresidmax
3975  integer(I4B) :: locdgwfmax
3976  integer(I4B) :: locdqoutmax
3977  integer(I4B) :: locdqfrommvrmax
3978  integer(I4B) :: ntabrows
3979  integer(I4B) :: ntabcols
3980  integer(I4B) :: n
3981  real(DP) :: q
3982  real(DP) :: q0
3983  real(DP) :: qtolfact
3984  real(DP) :: area
3985  real(DP) :: gwf0
3986  real(DP) :: gwf
3987  real(DP) :: dh
3988  real(DP) :: resid
3989  real(DP) :: dgwf
3990  real(DP) :: hlak0
3991  real(DP) :: hlak
3992  real(DP) :: qout0
3993  real(DP) :: qout
3994  real(DP) :: dqout
3995  real(DP) :: inf
3996  real(DP) :: ra
3997  real(DP) :: ro
3998  real(DP) :: qinf
3999  real(DP) :: ex
4000  real(DP) :: dhmax
4001  real(DP) :: residmax
4002  real(DP) :: dgwfmax
4003  real(DP) :: dqoutmax
4004  real(DP) :: dqfrommvr
4005  real(DP) :: dqfrommvrmax
4006  ! -- switch any stalled IMPLICIT lake back to the legacy solver
4007  call this%lak_set_legacy(kiter, icnvgmod)
4008  !
4009  ! -- on the last outer iteration of a solution that has not converged, warn
4010  ! about a perched (disconnected) lake that has no practical steady state.
4011  ! Done for both formulations (the implicit path returns just below).
4012  if (iend /= 0 .and. icnvgmod == 0) then
4013  call this%lak_check_disconnected()
4014  end if
4015  !
4016  ! -- implicit formulation: lake stage is solved in the global matrix,
4017  ! so its convergence is governed by the solution's dvclose check on the
4018  ! stage unknown; no separate package convergence check is performed here.
4019  if (this%iimplicit /= 0) then
4020  return
4021  end if
4022  !
4023  ! -- initialize local variables
4024  icheck = this%iconvchk
4025  ipakfail = 0
4026  locdhmax = 0
4027  locresidmax = 0
4028  locdgwfmax = 0
4029  locdqoutmax = 0
4030  locdqfrommvrmax = 0
4031  dhmax = dzero
4032  residmax = dzero
4033  dgwfmax = dzero
4034  dqoutmax = dzero
4035  dqfrommvrmax = dzero
4036  !
4037  ! -- if not saving package convergence data on check convergence if
4038  ! the model is considered converged
4039  if (this%ipakcsv == 0) then
4040  if (icnvgmod == 0) then
4041  icheck = 0
4042  end if
4043  !
4044  ! -- saving package convergence data
4045  else
4046  !
4047  ! -- header for package csv
4048  if (.not. associated(this%pakcsvtab)) then
4049  !
4050  ! -- determine the number of columns and rows
4051  ntabrows = 1
4052  ntabcols = 11
4053  if (this%noutlets > 0) then
4054  ntabcols = ntabcols + 2
4055  end if
4056  if (this%imover == 1) then
4057  ntabcols = ntabcols + 2
4058  end if
4059  !
4060  ! -- setup table
4061  call table_cr(this%pakcsvtab, this%packName, '')
4062  call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, &
4063  lineseparator=.false., separator=',', &
4064  finalize=.false.)
4065  !
4066  ! -- add columns to package csv
4067  tag = 'total_inner_iterations'
4068  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
4069  tag = 'totim'
4070  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
4071  tag = 'kper'
4072  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
4073  tag = 'kstp'
4074  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
4075  tag = 'nouter'
4076  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
4077  tag = 'dvmax'
4078  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4079  tag = 'dvmax_loc'
4080  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4081  tag = 'residmax'
4082  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4083  tag = 'residmax_loc'
4084  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4085  tag = 'dgwfmax'
4086  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4087  tag = 'dgwfmax_loc'
4088  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4089  if (this%noutlets > 0) then
4090  tag = 'dqoutmax'
4091  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4092  tag = 'dqoutmax_loc'
4093  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4094  end if
4095  if (this%imover == 1) then
4096  tag = 'dqfrommvrmax'
4097  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
4098  tag = 'dqfrommvrmax_loc'
4099  call this%pakcsvtab%initialize_column(tag, 16, alignment=tableft)
4100  end if
4101  end if
4102  end if
4103  !
4104  ! -- perform package convergence check
4105  if (icheck /= 0) then
4106  final_check: do n = 1, this%nlakes
4107  if (this%iboundpak(n) < 1) cycle
4108  !
4109  ! -- set previous and current lake stage
4110  hlak0 = this%s0(n)
4111  hlak = this%xnewpak(n)
4112  !
4113  ! -- stage difference
4114  dh = hlak0 - hlak
4115  !
4116  ! -- calculate surface area
4117  call this%lak_calculate_sarea(n, hlak, area)
4118  !
4119  ! -- set the Q to length factor
4120  if (area > dzero) then
4121  qtolfact = delt / area
4122  else
4123  qtolfact = dzero
4124  end if
4125  !
4126  ! -- difference in the residual
4127  call this%lak_calculate_residual(n, hlak, resid)
4128  resid = resid * qtolfact
4129  !
4130  ! -- change in gwf exchange
4131  dgwf = dzero
4132  if (area > dzero) then
4133  gwf0 = this%qgwf0(n)
4134  call this%lak_calculate_exchange(n, hlak, gwf)
4135  dgwf = (gwf0 - gwf) * qtolfact
4136  end if
4137  !
4138  ! -- change in outflows
4139  dqout = dzero
4140  if (this%noutlets > 0) then
4141  if (area > dzero) then
4142  call this%lak_calculate_available(n, hlak0, inf, ra, ro, qinf, ex)
4143  call this%lak_calculate_outlet_outflow(n, hlak0, inf, qout0)
4144  call this%lak_calculate_available(n, hlak, inf, ra, ro, qinf, ex)
4145  call this%lak_calculate_outlet_outflow(n, hlak, inf, qout)
4146  dqout = (qout0 - qout) * qtolfact
4147  end if
4148  end if
4149  !
4150  ! -- q from mvr
4151  dqfrommvr = dzero
4152  if (this%imover == 1) then
4153  q = this%pakmvrobj%get_qfrommvr(n)
4154  q0 = this%pakmvrobj%get_qfrommvr0(n)
4155  dqfrommvr = qtolfact * (q0 - q)
4156  end if
4157  !
4158  ! -- evaluate magnitude of differences
4159  if (n == 1) then
4160  locdhmax = n
4161  dhmax = dh
4162  locdgwfmax = n
4163  residmax = resid
4164  locresidmax = n
4165  dgwfmax = dgwf
4166  locdqoutmax = n
4167  dqoutmax = dqout
4168  dqfrommvrmax = dqfrommvr
4169  locdqfrommvrmax = n
4170  else
4171  if (abs(dh) > abs(dhmax)) then
4172  locdhmax = n
4173  dhmax = dh
4174  end if
4175  if (abs(resid) > abs(residmax)) then
4176  locresidmax = n
4177  residmax = resid
4178  end if
4179  if (abs(dgwf) > abs(dgwfmax)) then
4180  locdgwfmax = n
4181  dgwfmax = dgwf
4182  end if
4183  if (abs(dqout) > abs(dqoutmax)) then
4184  locdqoutmax = n
4185  dqoutmax = dqout
4186  end if
4187  if (abs(dqfrommvr) > abs(dqfrommvrmax)) then
4188  dqfrommvrmax = dqfrommvr
4189  locdqfrommvrmax = n
4190  end if
4191  end if
4192  end do final_check
4193  !
4194  ! -- set dpak and cpak
4195  if (abs(dhmax) > abs(dpak)) then
4196  ipak = locdhmax
4197  dpak = dhmax
4198  write (cloc, "(a,'-',a)") &
4199  trim(this%packName), 'stage'
4200  cpak = trim(cloc)
4201  end if
4202  if (abs(residmax) > abs(dpak)) then
4203  ipak = locresidmax
4204  dpak = residmax
4205  write (cloc, "(a,'-',a)") &
4206  trim(this%packName), 'residual'
4207  cpak = trim(cloc)
4208  end if
4209  if (abs(dgwfmax) > abs(dpak)) then
4210  ipak = locdgwfmax
4211  dpak = dgwfmax
4212  write (cloc, "(a,'-',a)") &
4213  trim(this%packName), 'gwf'
4214  cpak = trim(cloc)
4215  end if
4216  if (this%noutlets > 0) then
4217  if (abs(dqoutmax) > abs(dpak)) then
4218  ipak = locdqoutmax
4219  dpak = dqoutmax
4220  write (cloc, "(a,'-',a)") &
4221  trim(this%packName), 'outlet'
4222  cpak = trim(cloc)
4223  end if
4224  end if
4225  if (this%imover == 1) then
4226  if (abs(dqfrommvrmax) > abs(dpak)) then
4227  ipak = locdqfrommvrmax
4228  dpak = dqfrommvrmax
4229  write (cloc, "(a,'-',a)") trim(this%packName), 'qfrommvr'
4230  cpak = trim(cloc)
4231  end if
4232  end if
4233  !
4234  ! -- write convergence data to package csv
4235  if (this%ipakcsv /= 0) then
4236  !
4237  ! -- write the data
4238  call this%pakcsvtab%add_term(innertot)
4239  call this%pakcsvtab%add_term(totim)
4240  call this%pakcsvtab%add_term(kper)
4241  call this%pakcsvtab%add_term(kstp)
4242  call this%pakcsvtab%add_term(kiter)
4243  call this%pakcsvtab%add_term(dhmax)
4244  call this%pakcsvtab%add_term(locdhmax)
4245  call this%pakcsvtab%add_term(residmax)
4246  call this%pakcsvtab%add_term(locresidmax)
4247  call this%pakcsvtab%add_term(dgwfmax)
4248  call this%pakcsvtab%add_term(locdgwfmax)
4249  if (this%noutlets > 0) then
4250  call this%pakcsvtab%add_term(dqoutmax)
4251  call this%pakcsvtab%add_term(locdqoutmax)
4252  end if
4253  if (this%imover == 1) then
4254  call this%pakcsvtab%add_term(dqfrommvrmax)
4255  call this%pakcsvtab%add_term(locdqfrommvrmax)
4256  end if
4257  !
4258  ! -- finalize the package csv
4259  if (iend == 1) then
4260  call this%pakcsvtab%finalize_table()
4261  end if
4262  end if
4263  end if
4264  end subroutine lak_cc
4265 
4266  !> @brief Calculate flows
4267  !<
4268  subroutine lak_cq(this, x, flowja, iadv)
4269  ! -- modules
4270  use tdismodule, only: delt
4271  ! -- dummy
4272  class(laktype), intent(inout) :: this
4273  real(DP), dimension(:), intent(in) :: x
4274  real(DP), dimension(:), contiguous, intent(inout) :: flowja
4275  integer(I4B), optional, intent(in) :: iadv
4276  ! -- local
4277  real(DP) :: rrate
4278  real(DP) :: chratin, chratout
4279  ! -- for budget
4280  integer(I4B) :: j, n, igwfnode
4281  real(DP) :: hlak, head, flow, dqdh
4282  real(DP) :: v0, v1, sa, sf
4283  !
4284  call this%lak_solve(update=.false.)
4285  !
4286  ! -- for the IMPLICIT formulation, report the lake terms with the same
4287  ! treatment that lak_fc_implicit assembled into the matrix, so the lake
4288  ! and gwf-cell budgets match the solved flows. lak_solve above set these
4289  ! from the substitution path (hard-cutoff seepage; availability-limited
4290  ! losses), which is correct for a lake on the legacy solver but
4291  ! not for an implicit lake, so overwrite them for the implicit
4292  ! (non-legacy) lakes only.
4293  if (this%iimplicit /= 0) then
4294  do n = 1, this%nlakes
4295  if (this%iboundpak(n) < 1 .or. this%ilegacy(n) /= 0) cycle
4296  hlak = this%xnewpak(n)
4297  !
4298  ! -- lakebed seepage: use the same exchange the matrix assembled
4299  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
4300  igwfnode = this%cellid(j)
4301  if (this%ibound(igwfnode) < 1) cycle
4302  head = this%xnew(igwfnode)
4303  call this%lak_calculate_conn_exchange_deriv(n, j, hlak, head, &
4304  flow, dqdh=dqdh)
4305  this%hcof(j) = -dqdh
4306  this%rhs(j) = -dqdh * head + flow
4307  end do
4308  !
4309  ! -- stage-driven losses: the matrix (lak_budget_nogwf) ramps
4310  ! evaporation and withdrawal toward zero as the lake approaches its
4311  ! bottom with the surfdep factor (sf) rather than the substitution
4312  ! solver's availability limiting, so report them the same way. This
4313  ! keeps the lake budget closed for a drying lake. (The outlet
4314  ! outflow is already near zero at the bottom, as its invert is above
4315  ! the lake bottom, and the storage term reflects the solved stage.)
4316  call this%lak_calculate_sarea(n, hlak, sa)
4317  sf = done
4318  if (this%surfdep > dzero) then
4319  sf = squadraticsaturation(this%lakebot(n) + this%surfdep, &
4320  this%lakebot(n), hlak)
4321  end if
4322  this%evap(n) = -this%evaporation(n) * sa * sf
4323  this%withr(n) = -this%withdrawal(n) * sf
4324  end do
4325  end if
4326  !
4327  ! -- call base functionality in bnd_cq. This will calculate lake-gwf flows
4328  ! and put them into this%simvals
4329  call this%BndType%bnd_cq(x, flowja, iadv=1)
4330  !
4331  ! -- calculate several budget terms
4332  chratin = dzero
4333  chratout = dzero
4334  do n = 1, this%nlakes
4335  this%chterm(n) = dzero
4336  if (this%iboundpak(n) == 0) cycle
4337  hlak = this%xnewpak(n)
4338  call this%lak_calculate_vol(n, hlak, v1)
4339  !
4340  ! -- add budget terms for active lakes
4341  if (this%iboundpak(n) /= 0) then
4342  !
4343  ! -- rainfall
4344  rrate = this%precip(n)
4345  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4346  !
4347  ! -- evaporation
4348  rrate = this%evap(n)
4349  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4350  !
4351  ! -- runoff
4352  rrate = this%runoff(n)
4353  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4354  !
4355  ! -- inflow
4356  rrate = this%inflow(n)
4357  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4358  !
4359  ! -- withdrawals
4360  rrate = this%withr(n)
4361  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4362  !
4363  ! -- add lake storage changes
4364  rrate = dzero
4365  if (this%iboundpak(n) > 0) then
4366  if (this%gwfiss /= 1) then
4367  call this%lak_calculate_vol(n, this%xoldpak(n), v0)
4368  rrate = -(v1 - v0) / delt
4369  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4370  end if
4371  end if
4372  this%qsto(n) = rrate
4373  !
4374  ! -- add external outlets
4375  call this%lak_get_external_outlet(n, rrate)
4376  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4377  !
4378  ! -- add mover terms
4379  if (this%imover == 1) then
4380  if (this%iboundpak(n) /= 0) then
4381  rrate = this%pakmvrobj%get_qfrommvr(n)
4382  else
4383  rrate = dzero
4384  end if
4385  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4386  end if
4387  end if
4388  end do
4389  !
4390  ! -- gwf flow and constant flow to lake
4391  do n = 1, this%nlakes
4392  rrate = dzero
4393  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
4394  ! simvals is from aquifer perspective, and so it is positive
4395  ! for flow into the aquifer. Need to switch sign for lake
4396  ! perspective.
4397  rrate = -this%simvals(j)
4398  this%qleak(j) = rrate
4399  if (this%iboundpak(n) /= 0) then
4400  call this%lak_accumulate_chterm(n, rrate, chratin, chratout)
4401  end if
4402  end do
4403  end do
4404  !
4405  ! -- fill the budget object
4406  call this%lak_fill_budobj()
4407  end subroutine lak_cq
4408 
4409  !> @brief Output LAK package flow terms
4410  !<
4411  subroutine lak_ot_package_flows(this, icbcfl, ibudfl)
4412  use tdismodule, only: kstp, kper, delt, pertim, totim
4413  class(laktype) :: this
4414  integer(I4B), intent(in) :: icbcfl
4415  integer(I4B), intent(in) :: ibudfl
4416  integer(I4B) :: ibinun
4417  !
4418  ! -- write the flows from the budobj
4419  ibinun = 0
4420  if (this%ibudgetout /= 0) then
4421  ibinun = this%ibudgetout
4422  end if
4423  if (icbcfl == 0) ibinun = 0
4424  if (ibinun > 0) then
4425  call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, &
4426  pertim, totim, this%iout)
4427  end if
4428  !
4429  ! -- Print lake flows table
4430  if (ibudfl /= 0 .and. this%iprflow /= 0) then
4431  call this%budobj%write_flowtable(this%dis, kstp, kper)
4432  end if
4433  end subroutine lak_ot_package_flows
4434 
4435  !> @brief Write flows to binary file and/or print flows to budget
4436  !<
4437  subroutine lak_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap)
4438  class(laktype) :: this
4439  integer(I4B), intent(in) :: icbcfl
4440  integer(I4B), intent(in) :: ibudfl
4441  integer(I4B), intent(in) :: icbcun
4442  integer(I4B), dimension(:), optional, intent(in) :: imap
4443  !
4444  ! -- write the flows from the budobj
4445  call this%BndType%bnd_ot_model_flows(icbcfl, ibudfl, icbcun, this%imap)
4446  end subroutine lak_ot_model_flows
4447 
4448  !> @brief Save LAK-calculated values to binary file
4449  !<
4450  subroutine lak_ot_dv(this, idvsave, idvprint)
4451  use tdismodule, only: kstp, kper, pertim, totim
4452  use constantsmodule, only: dhnoflo, dhdry
4453  use inputoutputmodule, only: ulasav
4454  class(laktype) :: this
4455  integer(I4B), intent(in) :: idvsave
4456  integer(I4B), intent(in) :: idvprint
4457  integer(I4B) :: ibinun
4458  integer(I4B) :: n
4459  real(DP) :: v
4460  real(DP) :: d
4461  real(DP) :: stage
4462  real(DP) :: sa
4463  real(DP) :: wa
4464  !
4465  ! -- set unit number for binary dependent variable output
4466  ibinun = 0
4467  if (this%istageout /= 0) then
4468  ibinun = this%istageout
4469  end if
4470  if (idvsave == 0) ibinun = 0
4471  !
4472  ! -- write lake binary output
4473  if (ibinun > 0) then
4474  do n = 1, this%nlakes
4475  v = this%xnewpak(n)
4476  d = v - this%lakebot(n)
4477  if (this%iboundpak(n) == 0) then
4478  v = dhnoflo
4479  else if (d <= dzero) then
4480  v = dhdry
4481  end if
4482  this%dbuff(n) = v
4483  end do
4484  call ulasav(this%dbuff, ' STAGE', kstp, kper, pertim, totim, &
4485  this%nlakes, 1, 1, ibinun)
4486  end if
4487  !
4488  ! -- Print lake stage table
4489  if (idvprint /= 0 .and. this%iprhed /= 0) then
4490  !
4491  ! -- set table kstp and kper
4492  call this%stagetab%set_kstpkper(kstp, kper)
4493  !
4494  ! -- write data
4495  do n = 1, this%nlakes
4496  if (this%iboundpak(n) == 0) then
4497  stage = dhnoflo
4498  sa = dhnoflo
4499  wa = dhnoflo
4500  v = dhnoflo
4501  else
4502  stage = this%xnewpak(n)
4503  call this%lak_calculate_sarea(n, stage, sa)
4504  call this%lak_calculate_warea(n, stage, wa)
4505  call this%lak_calculate_vol(n, stage, v)
4506  end if
4507  if (this%inamedbound == 1) then
4508  call this%stagetab%add_term(this%lakename(n))
4509  end if
4510  call this%stagetab%add_term(n)
4511  call this%stagetab%add_term(stage)
4512  call this%stagetab%add_term(sa)
4513  call this%stagetab%add_term(wa)
4514  call this%stagetab%add_term(v)
4515  end do
4516  end if
4517  end subroutine lak_ot_dv
4518 
4519  !> @brief Write LAK budget to listing file
4520  !<
4521  subroutine lak_ot_bdsummary(this, kstp, kper, iout, ibudfl)
4522  ! -- module
4523  use tdismodule, only: totim, delt
4524  ! -- dummy
4525  class(laktype) :: this !< LakType object
4526  integer(I4B), intent(in) :: kstp !< time step number
4527  integer(I4B), intent(in) :: kper !< period number
4528  integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file
4529  integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written
4530  !
4531  call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim, delt)
4532  end subroutine lak_ot_bdsummary
4533 
4534  !> @brief Deallocate objects
4535  !<
4536  subroutine lak_da(this)
4537  ! -- modules
4538  use memorymanagermodule, only: mem_deallocate
4539  ! -- dummy
4540  class(laktype) :: this
4541  !
4542  ! -- arrays
4543  deallocate (this%lakename)
4544  deallocate (this%status)
4545  deallocate (this%clakbudget)
4546  call mem_deallocate(this%dbuff)
4547  deallocate (this%cauxcbc)
4548  call mem_deallocate(this%qauxcbc)
4549  call mem_deallocate(this%qleak)
4550  call mem_deallocate(this%holdconn)
4551  call mem_deallocate(this%qsto)
4552  call mem_deallocate(this%denseterms)
4553  call mem_deallocate(this%viscratios)
4554  !
4555  ! -- tables
4556  if (this%ntables > 0) then
4557  call mem_deallocate(this%ialaktab)
4558  call mem_deallocate(this%tabstage)
4559  call mem_deallocate(this%tabvolume)
4560  call mem_deallocate(this%tabsarea)
4561  call mem_deallocate(this%tabwarea)
4562  end if
4563  !
4564  ! -- budobj
4565  call this%budobj%budgetobject_da()
4566  deallocate (this%budobj)
4567  nullify (this%budobj)
4568  !
4569  ! -- outlets
4570  if (this%noutlets > 0) then
4571  call mem_deallocate(this%lakein)
4572  call mem_deallocate(this%lakeout)
4573  call mem_deallocate(this%iouttype)
4574  call mem_deallocate(this%outrate)
4575  call mem_deallocate(this%outinvert)
4576  call mem_deallocate(this%outwidth)
4577  call mem_deallocate(this%outrough)
4578  call mem_deallocate(this%outslope)
4579  call mem_deallocate(this%simoutrate)
4580  end if
4581  !
4582  ! -- stage table
4583  if (this%iprhed > 0) then
4584  call this%stagetab%table_da()
4585  deallocate (this%stagetab)
4586  nullify (this%stagetab)
4587  end if
4588  !
4589  ! -- package csv table
4590  if (this%ipakcsv > 0) then
4591  if (associated(this%pakcsvtab)) then
4592  call this%pakcsvtab%table_da()
4593  deallocate (this%pakcsvtab)
4594  nullify (this%pakcsvtab)
4595  end if
4596  end if
4597  !
4598  ! -- scalars
4599  call mem_deallocate(this%iprhed)
4600  call mem_deallocate(this%istageout)
4601  call mem_deallocate(this%ibudgetout)
4602  call mem_deallocate(this%ibudcsv)
4603  call mem_deallocate(this%ipakcsv)
4604  if (allocated(this%pakcsvfile)) deallocate (this%pakcsvfile)
4605  call mem_deallocate(this%nlakes)
4606  call mem_deallocate(this%noutlets)
4607  call mem_deallocate(this%ntables)
4608  call mem_deallocate(this%convlength)
4609  call mem_deallocate(this%convtime)
4610  call mem_deallocate(this%outdmax)
4611  call mem_deallocate(this%igwhcopt)
4612  call mem_deallocate(this%iconvchk)
4613  call mem_deallocate(this%maxlakit)
4614  call mem_deallocate(this%surfdep)
4615  call mem_deallocate(this%dmaxchg)
4616  call mem_deallocate(this%delh)
4617  call mem_deallocate(this%check_attr)
4618  call mem_deallocate(this%iimplicit)
4619  call mem_deallocate(this%iforceleg)
4620  call mem_deallocate(this%iforceleglak)
4621  call mem_deallocate(this%bditems)
4622  call mem_deallocate(this%cbcauxitems)
4623  call mem_deallocate(this%idense)
4624  !
4625  call mem_deallocate(this%nlakeconn)
4626  call mem_deallocate(this%idxlakeconn)
4627  call mem_deallocate(this%ntabrow)
4628  call mem_deallocate(this%strt)
4629  call mem_deallocate(this%laketop)
4630  call mem_deallocate(this%lakebot)
4631  call mem_deallocate(this%sareamax)
4632  call mem_deallocate(this%stage)
4633  call mem_deallocate(this%rainfall)
4634  call mem_deallocate(this%evaporation)
4635  call mem_deallocate(this%runoff)
4636  call mem_deallocate(this%inflow)
4637  call mem_deallocate(this%withdrawal)
4638  call mem_deallocate(this%lauxvar)
4639  call mem_deallocate(this%avail)
4640  call mem_deallocate(this%lkgwsink)
4641  call mem_deallocate(this%ncncvr)
4642  call mem_deallocate(this%ilegacy)
4643  call mem_deallocate(this%nstuck)
4644  call mem_deallocate(this%surfin)
4645  call mem_deallocate(this%surfout)
4646  call mem_deallocate(this%surfout1)
4647  call mem_deallocate(this%precip)
4648  call mem_deallocate(this%precip1)
4649  call mem_deallocate(this%evap)
4650  call mem_deallocate(this%evap1)
4651  call mem_deallocate(this%evapo)
4652  call mem_deallocate(this%withr)
4653  call mem_deallocate(this%withr1)
4654  call mem_deallocate(this%flwin)
4655  call mem_deallocate(this%flwiter)
4656  call mem_deallocate(this%flwiter1)
4657  call mem_deallocate(this%seep)
4658  call mem_deallocate(this%seep1)
4659  call mem_deallocate(this%seep0)
4660  call mem_deallocate(this%stageiter)
4661  call mem_deallocate(this%chterm)
4662  !
4663  ! -- lake boundary and stages
4664  if (this%iimplicit == 0) then
4665  call mem_deallocate(this%iboundpak)
4666  call mem_deallocate(this%xnewpak)
4667  else
4668  ! -- iboundpak aliases the global ibound (not deallocated here); xnewpak
4669  ! was checked in to the global x vector
4670  call mem_deallocate(this%xnewpak, 'XNEWPAK', this%memoryPath)
4671  end if
4672  call mem_deallocate(this%xoldpak)
4673  !
4674  ! -- implicit-formulation matrix-mapping arrays
4675  call mem_deallocate(this%idxlocnode)
4676  call mem_deallocate(this%idxdiag)
4677  call mem_deallocate(this%idxoffdglo)
4678  call mem_deallocate(this%idxsymdglo)
4679  call mem_deallocate(this%idxsymoffdglo)
4680  !
4681  ! -- lake iteration variables
4682  call mem_deallocate(this%iseepc)
4683  call mem_deallocate(this%idhc)
4684  call mem_deallocate(this%en1)
4685  call mem_deallocate(this%en2)
4686  call mem_deallocate(this%r1)
4687  call mem_deallocate(this%r2)
4688  call mem_deallocate(this%dh0)
4689  call mem_deallocate(this%s0)
4690  call mem_deallocate(this%qgwf0)
4691  !
4692  ! -- lake connection variables
4693  call mem_deallocate(this%imap)
4694  call mem_deallocate(this%cellid)
4695  call mem_deallocate(this%nodesontop)
4696  call mem_deallocate(this%ictype)
4697  call mem_deallocate(this%bedleak)
4698  call mem_deallocate(this%belev)
4699  call mem_deallocate(this%telev)
4700  call mem_deallocate(this%connlength)
4701  call mem_deallocate(this%connwidth)
4702  call mem_deallocate(this%sarea)
4703  call mem_deallocate(this%warea)
4704  call mem_deallocate(this%satcond)
4705  call mem_deallocate(this%simcond)
4706  call mem_deallocate(this%simlakgw)
4707  !
4708  ! -- pointers to gwf variables
4709  nullify (this%gwfiss)
4710  !
4711  ! -- Parent object
4712  call this%BndType%bnd_da()
4713  end subroutine lak_da
4714 
4715  !> @brief Define the list heading that is written to iout when PRINT_INPUT
4716  !! option is used
4717  !<
4718  subroutine define_listlabel(this)
4719  ! -- modules
4720  class(laktype), intent(inout) :: this
4721  !
4722  ! -- create the header list label
4723  this%listlabel = trim(this%filtyp)//' NO.'
4724  if (this%dis%ndim == 3) then
4725  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER'
4726  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW'
4727  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL'
4728  elseif (this%dis%ndim == 2) then
4729  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER'
4730  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D'
4731  else
4732  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE'
4733  end if
4734  write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE'
4735  if (this%inamedbound == 1) then
4736  write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME'
4737  end if
4738  end subroutine define_listlabel
4739 
4740  !> @brief Set pointers to model arrays and variables so that a package has
4741  !! access to these things
4742  !<
4743  subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja)
4744  ! -- modules
4745  use memorymanagermodule, only: mem_allocate, mem_checkin
4746  ! -- dummy
4747  class(laktype) :: this
4748  integer(I4B), pointer :: neq
4749  integer(I4B), dimension(:), pointer, contiguous :: ibound
4750  real(DP), dimension(:), pointer, contiguous :: xnew
4751  real(DP), dimension(:), pointer, contiguous :: xold
4752  real(DP), dimension(:), pointer, contiguous :: flowja
4753  ! -- local
4754  integer(I4B) :: n
4755  integer(I4B) :: istart, iend
4756  !
4757  ! -- call base BndType set_pointers
4758  call this%BndType%set_pointers(neq, ibound, xnew, xold, flowja)
4759  !
4760  ! -- for the implicit formulation, point the lake stage and ibound at the
4761  ! matching slice of the model solution (xnew) and ibound vectors so the
4762  ! stage is solved directly in the matrix. (The default formulation keeps
4763  ! these as its own arrays, allocated in lak_allocate_arrays.)
4764  if (this%iimplicit /= 0) then
4765  istart = this%dis%nodes + this%ioffset + 1
4766  iend = istart + this%nlakes - 1
4767  this%iboundpak => this%ibound(istart:iend)
4768  this%xnewpak => this%xnew(istart:iend)
4769  call mem_checkin(this%xnewpak, 'XNEWPAK', this%memoryPath, 'X', &
4770  this%memoryPathModel)
4771  !
4772  ! -- initialize xnewpak
4773  do n = 1, this%nlakes
4774  this%xnewpak(n) = dep20
4775  end do
4776  end if
4777  end subroutine lak_set_pointers
4778 
4779  !> @brief Add the lake rows and columns to the sparse matrix
4780  !!
4781  !! Implicit formulation only. Each lake adds one equation (row and column) to
4782  !! the groundwater flow matrix: a diagonal entry, plus a symmetric off-diagonal
4783  !! pair (lake-to-cell and cell-to-lake) for every lake-cell connection.
4784  !<
4785  subroutine lak_ac(this, moffset, sparse)
4786  use sparsemodule, only: sparsematrix
4787  ! -- dummy
4788  class(laktype), intent(inout) :: this
4789  integer(I4B), intent(in) :: moffset
4790  type(sparsematrix), intent(inout) :: sparse
4791  ! -- local
4792  integer(I4B) :: j, n
4793  integer(I4B) :: jj
4794  integer(I4B) :: jglo
4795  integer(I4B) :: nglo
4796  !
4797  ! -- the default formulation adds no rows to the matrix
4798  if (this%iimplicit == 0) return
4799  !
4800  ! -- add a row for each lake and its connections to the cells
4801  do n = 1, this%nlakes
4802  nglo = moffset + this%dis%nodes + this%ioffset + n
4803  call sparse%addconnection(nglo, nglo, 1)
4804  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
4805  jj = this%cellid(j)
4806  jglo = jj + moffset
4807  call sparse%addconnection(nglo, jglo, 1)
4808  call sparse%addconnection(jglo, nglo, 1)
4809  end do
4810  end do
4811  end subroutine lak_ac
4812 
4813  !> @brief Find the matrix position of each lake row and connection
4814  !!
4815  !! Implicit formulation only. Finds the position in the assembled matrix of
4816  !! each lake-row diagonal, lake-to-cell, cell diagonal, and cell-to-lake entry
4817  !! and stores them in the idx* arrays so they can be filled during assembly.
4818  !<
4819  subroutine lak_mc(this, moffset, matrix_sln)
4820  use memorymanagermodule, only: mem_allocate
4821  ! -- dummy
4822  class(laktype), intent(inout) :: this
4823  integer(I4B), intent(in) :: moffset
4824  class(matrixbasetype), pointer :: matrix_sln
4825  ! -- local
4826  integer(I4B) :: n
4827  integer(I4B) :: j
4828  integer(I4B) :: iglo
4829  integer(I4B) :: jglo
4830  integer(I4B) :: ipos
4831  !
4832  ! -- the connection-mapping vectors are only used by the implicit
4833  ! formulation; allocate them at size 0 otherwise so legacy LAK runs do not
4834  ! pay the maxbound memory cost (lak_da stays symmetric either way)
4835  if (this%iimplicit == 0) then
4836  call mem_allocate(this%idxlocnode, 0, 'IDXLOCNODE', this%memoryPath)
4837  call mem_allocate(this%idxdiag, 0, 'IDXDIAG', this%memoryPath)
4838  call mem_allocate(this%idxoffdglo, 0, 'IDXOFFDGLO', this%memoryPath)
4839  call mem_allocate(this%idxsymdglo, 0, 'IDXSYMDGLO', this%memoryPath)
4840  call mem_allocate(this%idxsymoffdglo, 0, 'IDXSYMOFFDGLO', this%memoryPath)
4841  return
4842  end if
4843  call mem_allocate(this%idxlocnode, this%nlakes, 'IDXLOCNODE', &
4844  this%memoryPath)
4845  call mem_allocate(this%idxdiag, this%nlakes, 'IDXDIAG', this%memoryPath)
4846  call mem_allocate(this%idxoffdglo, this%maxbound, 'IDXOFFDGLO', &
4847  this%memoryPath)
4848  call mem_allocate(this%idxsymdglo, this%maxbound, 'IDXSYMDGLO', &
4849  this%memoryPath)
4850  call mem_allocate(this%idxsymoffdglo, this%maxbound, 'IDXSYMOFFDGLO', &
4851  this%memoryPath)
4852  !
4853  ! -- lake rows: a per-lake diagonal position and the per-connection
4854  ! lake->cell off-diagonals. The diagonal is stored per lake (idxdiag) so a
4855  ! lake with no connections still has a valid diagonal position.
4856  ipos = 1
4857  do n = 1, this%nlakes
4858  iglo = moffset + this%dis%nodes + this%ioffset + n
4859  this%idxlocnode(n) = this%dis%nodes + this%ioffset + n
4860  this%idxdiag(n) = matrix_sln%get_position_diag(iglo)
4861  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
4862  jglo = this%cellid(j) + moffset
4863  this%idxoffdglo(ipos) = matrix_sln%get_position(iglo, jglo)
4864  ipos = ipos + 1
4865  end do
4866  end do
4867  !
4868  ! -- lake contributions to the gwf portion of the global matrix
4869  ipos = 1
4870  do n = 1, this%nlakes
4871  jglo = moffset + this%dis%nodes + this%ioffset + n
4872  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
4873  iglo = this%cellid(j) + moffset
4874  this%idxsymdglo(ipos) = matrix_sln%get_position_diag(iglo)
4875  this%idxsymoffdglo(ipos) = matrix_sln%get_position(iglo, jglo)
4876  ipos = ipos + 1
4877  end do
4878  end do
4879  end subroutine lak_mc
4880 
4881  !> @brief Procedures related to observations (type-bound)
4882  !!
4883  !! Return true because LAK package supports observations. Overrides
4884  !! BndType%bnd_obs_supported()
4885  !<
4886  logical function lak_obs_supported(this)
4887  ! -- dummy
4888  class(laktype) :: this
4889  !
4890  lak_obs_supported = .true.
4891  end function lak_obs_supported
4892 
4893  !> @brief Store observation type supported by LAK package. Overrides
4894  !! BndType%bnd_df_obs
4895  !<
4896  subroutine lak_df_obs(this)
4897  ! -- dummy
4898  class(laktype) :: this
4899  ! -- local
4900  integer(I4B) :: indx
4901  !
4902  ! -- Store obs type and assign procedure pointer
4903  ! for stage observation type.
4904  call this%obs%StoreObsType('stage', .false., indx)
4905  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4906  !
4907  ! -- Store obs type and assign procedure pointer
4908  ! for ext-inflow observation type.
4909  call this%obs%StoreObsType('ext-inflow', .true., indx)
4910  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4911  !
4912  ! -- Store obs type and assign procedure pointer
4913  ! for outlet-inflow observation type.
4914  call this%obs%StoreObsType('outlet-inflow', .true., indx)
4915  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4916  !
4917  ! -- Store obs type and assign procedure pointer
4918  ! for inflow observation type.
4919  call this%obs%StoreObsType('inflow', .true., indx)
4920  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4921  !
4922  ! -- Store obs type and assign procedure pointer
4923  ! for from-mvr observation type.
4924  call this%obs%StoreObsType('from-mvr', .true., indx)
4925  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4926  !
4927  ! -- Store obs type and assign procedure pointer
4928  ! for rainfall observation type.
4929  call this%obs%StoreObsType('rainfall', .true., indx)
4930  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4931  !
4932  ! -- Store obs type and assign procedure pointer
4933  ! for runoff observation type.
4934  call this%obs%StoreObsType('runoff', .true., indx)
4935  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4936  !
4937  ! -- Store obs type and assign procedure pointer
4938  ! for lak observation type.
4939  call this%obs%StoreObsType('lak', .true., indx)
4940  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4941  !
4942  ! -- Store obs type and assign procedure pointer
4943  ! for evaporation observation type.
4944  call this%obs%StoreObsType('evaporation', .true., indx)
4945  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4946  !
4947  ! -- Store obs type and assign procedure pointer
4948  ! for withdrawal observation type.
4949  call this%obs%StoreObsType('withdrawal', .true., indx)
4950  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4951  !
4952  ! -- Store obs type and assign procedure pointer
4953  ! for ext-outflow observation type.
4954  call this%obs%StoreObsType('ext-outflow', .true., indx)
4955  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4956  !
4957  ! -- Store obs type and assign procedure pointer
4958  ! for to-mvr observation type.
4959  call this%obs%StoreObsType('to-mvr', .true., indx)
4960  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4961  !
4962  ! -- Store obs type and assign procedure pointer
4963  ! for storage observation type.
4964  call this%obs%StoreObsType('storage', .true., indx)
4965  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4966  !
4967  ! -- Store obs type and assign procedure pointer
4968  ! for constant observation type.
4969  call this%obs%StoreObsType('constant', .true., indx)
4970  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4971  !
4972  ! -- Store obs type and assign procedure pointer
4973  ! for outlet observation type.
4974  call this%obs%StoreObsType('outlet', .true., indx)
4975  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4976  !
4977  ! -- Store obs type and assign procedure pointer
4978  ! for volume observation type.
4979  call this%obs%StoreObsType('volume', .true., indx)
4980  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4981  !
4982  ! -- Store obs type and assign procedure pointer
4983  ! for surface-area observation type.
4984  call this%obs%StoreObsType('surface-area', .true., indx)
4985  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4986  !
4987  ! -- Store obs type and assign procedure pointer
4988  ! for wetted-area observation type.
4989  call this%obs%StoreObsType('wetted-area', .true., indx)
4990  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4991  !
4992  ! -- Store obs type and assign procedure pointer
4993  ! for conductance observation type.
4994  call this%obs%StoreObsType('conductance', .true., indx)
4995  this%obs%obsData(indx)%ProcessIdPtr => lak_process_obsid
4996  end subroutine lak_df_obs
4997 
4998  !> @brief Calculate observations this time step and call ObsType%SaveOneSimval
4999  !! for each LakType observation.
5000  !<
5001  subroutine lak_bd_obs(this)
5002  ! -- dummy
5003  class(laktype) :: this
5004  ! -- local
5005  integer(I4B) :: i
5006  integer(I4B) :: igwfnode
5007  integer(I4B) :: j
5008  integer(I4B) :: jj
5009  integer(I4B) :: n
5010  real(DP) :: hgwf
5011  real(DP) :: hlak
5012  real(DP) :: v
5013  real(DP) :: v2
5014  type(observetype), pointer :: obsrv => null()
5015  !
5016  ! Write simulated values for all LAK observations
5017  if (this%obs%npakobs > 0) then
5018  call this%obs%obs_bd_clear()
5019  do i = 1, this%obs%npakobs
5020  obsrv => this%obs%pakobs(i)%obsrv
5021  do j = 1, obsrv%indxbnds_count
5022  v = dnodata
5023  jj = obsrv%indxbnds(j)
5024  select case (obsrv%ObsTypeId)
5025  case ('STAGE')
5026  if (this%iboundpak(jj) /= 0) then
5027  v = this%xnewpak(jj)
5028  end if
5029  case ('EXT-INFLOW')
5030  if (this%iboundpak(jj) /= 0) then
5031  call this%lak_calculate_inflow(jj, v)
5032  end if
5033  case ('OUTLET-INFLOW')
5034  if (this%iboundpak(jj) /= 0) then
5035  call this%lak_calculate_outlet_inflow(jj, v)
5036  end if
5037  case ('INFLOW')
5038  if (this%iboundpak(jj) /= 0) then
5039  call this%lak_calculate_inflow(jj, v)
5040  call this%lak_calculate_outlet_inflow(jj, v2)
5041  v = v + v2
5042  end if
5043  case ('FROM-MVR')
5044  if (this%iboundpak(jj) /= 0) then
5045  if (this%imover == 1) then
5046  v = this%pakmvrobj%get_qfrommvr(jj)
5047  end if
5048  end if
5049  case ('RAINFALL')
5050  if (this%iboundpak(jj) /= 0) then
5051  v = this%precip(jj)
5052  end if
5053  case ('RUNOFF')
5054  if (this%iboundpak(jj) /= 0) then
5055  v = this%runoff(jj)
5056  end if
5057  case ('LAK')
5058  n = this%imap(jj)
5059  if (this%iboundpak(n) /= 0) then
5060  igwfnode = this%cellid(jj)
5061  hgwf = this%xnew(igwfnode)
5062  if (this%hcof(jj) /= dzero) then
5063  v = -(this%hcof(jj) * (this%xnewpak(n) - hgwf))
5064  else
5065  v = -this%rhs(jj)
5066  end if
5067  end if
5068  case ('EVAPORATION')
5069  if (this%iboundpak(jj) /= 0) then
5070  v = this%evap(jj)
5071  end if
5072  case ('WITHDRAWAL')
5073  if (this%iboundpak(jj) /= 0) then
5074  v = this%withr(jj)
5075  end if
5076  case ('EXT-OUTFLOW')
5077  n = this%lakein(jj)
5078  if (this%iboundpak(n) /= 0) then
5079  if (this%lakeout(jj) == 0) then
5080  v = this%simoutrate(jj)
5081  if (v < dzero) then
5082  if (this%imover == 1) then
5083  v = v + this%pakmvrobj%get_qtomvr(jj)
5084  end if
5085  end if
5086  end if
5087  end if
5088  case ('TO-MVR')
5089  n = this%lakein(jj)
5090  if (this%iboundpak(n) /= 0) then
5091  if (this%imover == 1) then
5092  v = this%pakmvrobj%get_qtomvr(jj)
5093  if (v > dzero) then
5094  v = -v
5095  end if
5096  end if
5097  end if
5098  case ('STORAGE')
5099  if (this%iboundpak(jj) /= 0) then
5100  v = this%qsto(jj)
5101  end if
5102  case ('CONSTANT')
5103  if (this%iboundpak(jj) /= 0) then
5104  v = this%chterm(jj)
5105  end if
5106  case ('OUTLET')
5107  n = this%lakein(jj)
5108  if (this%iboundpak(n) /= 0) then
5109  v = this%simoutrate(jj)
5110  end if
5111  case ('VOLUME')
5112  if (this%iboundpak(jj) /= 0) then
5113  call this%lak_calculate_vol(jj, this%xnewpak(jj), v)
5114  end if
5115  case ('SURFACE-AREA')
5116  if (this%iboundpak(jj) /= 0) then
5117  hlak = this%xnewpak(jj)
5118  call this%lak_calculate_sarea(jj, hlak, v)
5119  end if
5120  case ('WETTED-AREA')
5121  n = this%imap(jj)
5122  if (this%iboundpak(n) /= 0) then
5123  hlak = this%xnewpak(n)
5124  igwfnode = this%cellid(jj)
5125  hgwf = this%xnew(igwfnode)
5126  call this%lak_calculate_conn_warea(n, jj, hlak, hgwf, v)
5127  end if
5128  case ('CONDUCTANCE')
5129  n = this%imap(jj)
5130  if (this%iboundpak(n) /= 0) then
5131  hlak = this%xnewpak(n)
5132  igwfnode = this%cellid(jj)
5133  hgwf = this%xnew(igwfnode)
5134  call this%lak_calculate_conn_conductance(n, jj, hlak, hgwf, v)
5135  end if
5136  case default
5137  errmsg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId)
5138  call store_error(errmsg)
5139  end select
5140  call this%obs%SaveOneSimval(obsrv, v)
5141  end do
5142  end do
5143  !
5144  ! -- write summary of error messages
5145  if (count_errors() > 0) then
5146  call store_error_unit(this%inunit)
5147  end if
5148  end if
5149  end subroutine lak_bd_obs
5150 
5151  !> @brief Process each observation
5152  !!
5153  !! Only done the first stress period since boundaries are fixed for the
5154  !! simulation
5155  !<
5156  subroutine lak_rp_obs(this)
5157  use tdismodule, only: kper
5158  ! -- dummy
5159  class(laktype), intent(inout) :: this
5160  ! -- local
5161  integer(I4B) :: i
5162  integer(I4B) :: j
5163  integer(I4B) :: nn1
5164  integer(I4B) :: nn2
5165  integer(I4B) :: jj
5166  character(len=LENBOUNDNAME) :: bname
5167  logical(LGP) :: jfound
5168  class(observetype), pointer :: obsrv => null()
5169  ! -- formats
5170 10 format('Boundary "', a, '" for observation "', a, &
5171  '" is invalid in package "', a, '"')
5172  !
5173  ! -- process each package observation
5174  ! only done the first stress period since boundaries are fixed
5175  ! for the simulation
5176  if (kper == 1) then
5177  do i = 1, this%obs%npakobs
5178  obsrv => this%obs%pakobs(i)%obsrv
5179  !
5180  ! -- get node number 1
5181  nn1 = obsrv%NodeNumber
5182  if (nn1 == namedboundflag) then
5183  bname = obsrv%FeatureName
5184  if (bname /= '') then
5185  ! -- Observation lake is based on a boundary name.
5186  ! Iterate through all lakes to identify and store
5187  ! corresponding index in bound array.
5188  jfound = .false.
5189  if (obsrv%ObsTypeId == 'LAK' .or. &
5190  obsrv%ObsTypeId == 'CONDUCTANCE' .or. &
5191  obsrv%ObsTypeId == 'WETTED-AREA') then
5192  do j = 1, this%nlakes
5193  do jj = this%idxlakeconn(j), this%idxlakeconn(j + 1) - 1
5194  if (this%boundname(jj) == bname) then
5195  jfound = .true.
5196  call obsrv%AddObsIndex(jj)
5197  end if
5198  end do
5199  end do
5200  else if (obsrv%ObsTypeId == 'EXT-OUTFLOW' .or. &
5201  obsrv%ObsTypeId == 'TO-MVR' .or. &
5202  obsrv%ObsTypeId == 'OUTLET') then
5203  do j = 1, this%noutlets
5204  jj = this%lakein(j)
5205  if (this%lakename(jj) == bname) then
5206  jfound = .true.
5207  call obsrv%AddObsIndex(j)
5208  end if
5209  end do
5210  else
5211  do j = 1, this%nlakes
5212  if (this%lakename(j) == bname) then
5213  jfound = .true.
5214  call obsrv%AddObsIndex(j)
5215  end if
5216  end do
5217  end if
5218  if (.not. jfound) then
5219  write (errmsg, 10) &
5220  trim(bname), trim(obsrv%Name), trim(this%packName)
5221  call store_error(errmsg)
5222  end if
5223  end if
5224  else
5225  if (obsrv%indxbnds_count == 0) then
5226  if (obsrv%ObsTypeId == 'LAK' .or. &
5227  obsrv%ObsTypeId == 'CONDUCTANCE' .or. &
5228  obsrv%ObsTypeId == 'WETTED-AREA') then
5229  nn2 = obsrv%NodeNumber2
5230  j = this%idxlakeconn(nn1) + nn2 - 1
5231  call obsrv%AddObsIndex(j)
5232  else
5233  call obsrv%AddObsIndex(nn1)
5234  end if
5235  else
5236  errmsg = 'Programming error in lak_rp_obs'
5237  call store_error(errmsg)
5238  end if
5239  end if
5240  !
5241  ! -- catch non-cumulative observation assigned to observation defined
5242  ! by a boundname that is assigned to more than one element
5243  if (obsrv%ObsTypeId == 'STAGE') then
5244  if (obsrv%indxbnds_count > 1) then
5245  write (errmsg, '(a,3(1x,a))') &
5246  trim(adjustl(obsrv%ObsTypeId)), &
5247  'for observation', trim(adjustl(obsrv%Name)), &
5248  ' must be assigned to a lake with a unique boundname.'
5249  call store_error(errmsg)
5250  end if
5251  end if
5252  !
5253  ! -- check that index values are valid
5254  if (obsrv%ObsTypeId == 'TO-MVR' .or. &
5255  obsrv%ObsTypeId == 'EXT-OUTFLOW' .or. &
5256  obsrv%ObsTypeId == 'OUTLET') then
5257  do j = 1, obsrv%indxbnds_count
5258  nn1 = obsrv%indxbnds(j)
5259  if (nn1 < 1 .or. nn1 > this%noutlets) then
5260  write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') &
5261  trim(adjustl(obsrv%ObsTypeId)), &
5262  ' outlet must be > 0 and <=', this%noutlets, &
5263  '(specified value is ', nn1, ')'
5264  call store_error(errmsg)
5265  end if
5266  end do
5267  else if (obsrv%ObsTypeId == 'LAK' .or. &
5268  obsrv%ObsTypeId == 'CONDUCTANCE' .or. &
5269  obsrv%ObsTypeId == 'WETTED-AREA') then
5270  do j = 1, obsrv%indxbnds_count
5271  nn1 = obsrv%indxbnds(j)
5272  if (nn1 < 1 .or. nn1 > this%maxbound) then
5273  write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') &
5274  trim(adjustl(obsrv%ObsTypeId)), &
5275  'lake connection number must be > 0 and <=', this%maxbound, &
5276  '(specified value is ', nn1, ')'
5277  call store_error(errmsg)
5278  end if
5279  end do
5280  else
5281  do j = 1, obsrv%indxbnds_count
5282  nn1 = obsrv%indxbnds(j)
5283  if (nn1 < 1 .or. nn1 > this%nlakes) then
5284  write (errmsg, '(a,1x,a,1x,i0,1x,a,1x,i0,a)') &
5285  trim(adjustl(obsrv%ObsTypeId)), &
5286  ' lake must be > 0 and <=', this%nlakes, &
5287  '(specified value is ', nn1, ')'
5288  call store_error(errmsg)
5289  end if
5290  end do
5291  end if
5292  end do
5293  !
5294  ! -- evaluate if there are any observation errors
5295  if (count_errors() > 0) then
5296  call store_error_unit(this%inunit)
5297  end if
5298  end if
5299  end subroutine lak_rp_obs
5300 
5301  !
5302  ! -- Procedures related to observations (NOT type-bound)
5303 
5304  !> @brief This procedure is pointed to by ObsDataType%ProcesssIdPtr. It
5305  !! processes the ID string of an observation definition for LAK package
5306  !! observations.
5307  !<
5308  subroutine lak_process_obsid(obsrv, dis, inunitobs, iout)
5309  ! -- dummy
5310  type(observetype), intent(inout) :: obsrv
5311  class(disbasetype), intent(in) :: dis
5312  integer(I4B), intent(in) :: inunitobs
5313  integer(I4B), intent(in) :: iout
5314  ! -- local
5315  integer(I4B) :: nn1, nn2
5316  integer(I4B) :: icol, istart, istop
5317  character(len=LINELENGTH) :: string
5318  character(len=LENBOUNDNAME) :: bndname
5319  !
5320  string = obsrv%IDstring
5321  ! -- Extract lake number from string and store it.
5322  ! If 1st item is not an integer(I4B), it should be a
5323  ! lake name--deal with it.
5324  icol = 1
5325  ! -- get lake number or boundary name
5326  call extract_idnum_or_bndname(string, icol, istart, istop, nn1, bndname)
5327  if (nn1 == namedboundflag) then
5328  obsrv%FeatureName = bndname
5329  else
5330  if (obsrv%ObsTypeId == 'LAK' .or. obsrv%ObsTypeId == 'CONDUCTANCE' .or. &
5331  obsrv%ObsTypeId == 'WETTED-AREA') then
5332  call extract_idnum_or_bndname(string, icol, istart, istop, nn2, bndname)
5333  if (len_trim(bndname) < 1 .and. nn2 < 0) then
5334  write (errmsg, '(a,1x,a,a,1x,a,1x,a)') &
5335  'For observation type', trim(adjustl(obsrv%ObsTypeId)), &
5336  ', ID given as an integer and not as boundname,', &
5337  'but ID2 (iconn) is missing. Either change ID to valid', &
5338  'boundname or supply valid entry for ID2.'
5339  call store_error(errmsg)
5340  end if
5341  if (nn2 == namedboundflag) then
5342  obsrv%FeatureName = bndname
5343  ! -- reset nn1
5344  nn1 = nn2
5345  else
5346  obsrv%NodeNumber2 = nn2
5347  end if
5348  end if
5349  end if
5350  ! -- store lake number (NodeNumber)
5351  obsrv%NodeNumber = nn1
5352  end subroutine lak_process_obsid
5353 
5354  !
5355  ! -- private LAK methods
5356  !
5357 
5358  !> @brief Accumulate constant head terms for budget
5359  !<
5360  subroutine lak_accumulate_chterm(this, ilak, rrate, chratin, chratout)
5361  ! -- dummy
5362  class(laktype) :: this
5363  integer(I4B), intent(in) :: ilak
5364  real(DP), intent(in) :: rrate
5365  real(DP), intent(inout) :: chratin
5366  real(DP), intent(inout) :: chratout
5367  ! -- locals
5368  real(DP) :: q
5369  !
5370  ! code
5371  if (this%iboundpak(ilak) < 0) then
5372  q = -rrate
5373  this%chterm(ilak) = this%chterm(ilak) + q
5374  !
5375  ! -- See if flow is into lake or out of lake.
5376  if (q < dzero) then
5377  !
5378  ! -- Flow is out of lake subtract rate from ratout.
5379  chratout = chratout - q
5380  else
5381  !
5382  ! -- Flow is into lake; add rate to ratin.
5383  chratin = chratin + q
5384  end if
5385  end if
5386  end subroutine lak_accumulate_chterm
5387 
5388  !> @brief Store the lake head and connection conductance in the bound array
5389  !<
5390  subroutine lak_bound_update(this)
5391  ! -- dummy
5392  class(laktype), intent(inout) :: this
5393  ! -- local
5394  integer(I4B) :: j, n, node
5395  real(DP) :: hlak, head, clak
5396  !
5397  ! -- Return if no lak lakes
5398  if (this%nbound == 0) return
5399  !
5400  ! -- Calculate hcof and rhs for each lak entry
5401  do n = 1, this%nlakes
5402  hlak = this%xnewpak(n)
5403  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
5404  node = this%cellid(j)
5405  head = this%xnew(node)
5406  call this%lak_calculate_conn_conductance(n, j, hlak, head, clak)
5407  this%bound(1, j) = hlak
5408  this%bound(2, j) = clak
5409  end do
5410  end do
5411  end subroutine lak_bound_update
5412 
5413  !> @brief Solve for lake stage
5414  !!
5415  !! Solve the lake stage by substitution. With only_legacy set, solve only
5416  !! the lakes flagged for the legacy solver (this%ilegacy /= 0) and
5417  !! leave the remaining lakes -- whose stage is solved in the global matrix by
5418  !! the IMPLICIT formulation -- untouched. Without it (the default), every
5419  !! active lake is solved.
5420  !<
5421  subroutine lak_solve(this, update, only_legacy)
5422  ! -- modules
5423  use tdismodule, only: delt
5424  ! -- dummy
5425  class(laktype), intent(inout) :: this
5426  logical(LGP), intent(in), optional :: update
5427  logical(LGP), intent(in), optional :: only_legacy
5428  ! -- local
5429  logical(LGP) :: lupdate
5430  logical(LGP) :: legonly
5431  integer(I4B) :: j
5432  integer(I4B) :: n
5433  integer(I4B) :: iicnvg
5434  integer(I4B) :: iter
5435  integer(I4B) :: maxiter
5436  integer(I4B) :: ncnv
5437  real(DP) :: hlak
5438  real(DP) :: hlak0
5439  real(DP) :: v0
5440  real(DP) :: v1
5441  real(DP) :: ro
5442  real(DP) :: qinf
5443  real(DP) :: ex
5444  real(DP) :: outinf
5445  real(DP) :: avail
5446  !
5447  ! -- set lupdate
5448  if (present(update)) then
5449  lupdate = update
5450  else
5451  lupdate = .true.
5452  end if
5453  !
5454  ! -- set legonly (solve only the lakes flagged for the legacy solver)
5455  if (present(only_legacy)) then
5456  legonly = only_legacy
5457  else
5458  legonly = .false.
5459  end if
5460  !
5461  ! -- initialize
5462  avail = dzero
5463  !
5464  ! -- initialize
5465  do n = 1, this%nlakes
5466  ! -- a lake not being solved on this call (an IMPLICIT lake when only the
5467  ! flagged lakes are solved) is treated as already converged and left
5468  ! untouched
5469  if (legonly .and. this%ilegacy(n) == 0) then
5470  this%ncncvr(n) = 1
5471  cycle
5472  end if
5473  this%ncncvr(n) = 0
5474  this%surfin(n) = dzero
5475  this%surfout(n) = dzero
5476  this%surfout1(n) = dzero
5477  if (this%xnewpak(n) < this%lakebot(n)) then
5478  this%xnewpak(n) = this%lakebot(n)
5479  end if
5480  if (this%gwfiss /= 0) then
5481  this%xoldpak(n) = this%xnewpak(n)
5482  end if
5483  ! -- lake iteration items
5484  this%iseepc(n) = 0
5485  this%idhc(n) = 0
5486  this%en1(n) = this%lakebot(n)
5487  call this%lak_calculate_residual(n, this%en1(n), this%r1(n))
5488  this%en2(n) = this%laketop(n)
5489  call this%lak_calculate_residual(n, this%en2(n), this%r2(n))
5490  end do
5491  ! -- a legacy-only solve keeps the outlet rates of the implicit lakes,
5492  ! which are final and still needed for the mover and downstream lakes
5493  do n = 1, this%noutlets
5494  if (legonly .and. this%ilegacy(this%lakein(n)) == 0) cycle
5495  this%simoutrate(n) = dzero
5496  end do
5497  !
5498  ! -- sum up inflows from mover inflows
5499  do n = 1, this%nlakes
5500  call this%lak_calculate_outlet_inflow(n, this%surfin(n))
5501  end do
5502  !
5503  ! -- sum up overland runoff, inflows, and external flows into lake
5504  ! (includes maximum lake volume)
5505  do n = 1, this%nlakes
5506  hlak0 = this%xoldpak(n)
5507  hlak = this%xnewpak(n)
5508  call this%lak_calculate_runoff(n, ro)
5509  call this%lak_calculate_inflow(n, qinf)
5510  call this%lak_calculate_external(n, ex)
5511  call this%lak_calculate_vol(n, hlak0, v0)
5512  call this%lak_calculate_vol(n, hlak, v1)
5513  this%flwin(n) = this%surfin(n) + ro + qinf + ex + &
5514  max(v0, v1) / delt
5515  end do
5516  !
5517  ! -- sum up inflows from upstream outlets
5518  do n = 1, this%nlakes
5519  call this%lak_calculate_outlet_inflow(n, outinf)
5520  this%flwin(n) = this%flwin(n) + outinf
5521  end do
5522  !
5523  iicnvg = 0
5524  maxiter = this%maxlakit
5525  !
5526  ! -- outer loop
5527  converge: do iter = 1, maxiter
5528  ncnv = 0
5529  do n = 1, this%nlakes
5530  if (this%ncncvr(n) == 0) ncnv = 1
5531  end do
5532  if (iter == maxiter) ncnv = 0
5533  if (ncnv == 0) iicnvg = 1
5534  !
5535  ! -- initialize variables
5536  do n = 1, this%nlakes
5537  this%evap(n) = dzero
5538  this%precip(n) = dzero
5539  this%precip1(n) = dzero
5540  this%seep(n) = dzero
5541  this%seep1(n) = dzero
5542  this%evap(n) = dzero
5543  this%evap1(n) = dzero
5544  this%evapo(n) = dzero
5545  this%withr(n) = dzero
5546  this%withr1(n) = dzero
5547  this%flwiter(n) = this%flwin(n)
5548  this%flwiter1(n) = this%flwin(n)
5549  if (this%gwfiss /= 0) then
5550  this%flwiter(n) = dep20
5551  this%flwiter1(n) = dep20
5552  end if
5553  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
5554  this%hcof(j) = dzero
5555  this%rhs(j) = dzero
5556  end do
5557  end do
5558  !
5559  do n = 1, this%nlakes
5560  if (legonly .and. this%ilegacy(n) == 0) cycle
5561  call this%lak_estimate_seepage_single(n, ncnv)
5562  end do
5563  !
5564  laklevel: do n = 1, this%nlakes
5565  if (legonly .and. this%ilegacy(n) == 0) cycle laklevel
5566  call this%lak_solve_single(n, iter, maxiter, ncnv, lupdate)
5567  end do laklevel
5568  !
5569  if (iicnvg == 1) exit converge
5570  !
5571  end do converge
5572  !
5573  ! -- Mover terms: store outflow after diversion loss
5574  ! as qformvr and reduce outflow (qd)
5575  ! by how much was actually sent to the mover. A legacy-only solve
5576  ! skips this because the implicit formulation accumulates the mover
5577  ! terms for every outlet once the legacy-solved stages are known.
5578  if (this%imover == 1 .and. .not. legonly) then
5579  do n = 1, this%noutlets
5580  call this%pakmvrobj%accumulate_qformvr(n, -this%simoutrate(n))
5581  end do
5582  end if
5583  end subroutine lak_solve
5584 
5585  !> @brief Advance one lake stage by a single substitution iteration
5586  !!
5587  !! Performs one Newton update (with a bisection backup) of lake n's stage in
5588  !! the default substitution solver, using the per-iteration seepage estimate
5589  !! (this%seep / this%seep1) already computed for the lake. Extracted from
5590  !! lak_solve so the same per-lake update can be reused to solve a single lake
5591  !! stage on its own -- the per-lake legacy solve for the IMPLICIT formulation.
5592  !<
5593  subroutine lak_solve_single(this, n, iter, maxiter, ncnv, lupdate)
5594  ! -- modules
5595  use tdismodule, only: delt
5596  ! -- dummy
5597  class(laktype), intent(inout) :: this
5598  integer(I4B), intent(in) :: n
5599  integer(I4B), intent(in) :: iter
5600  integer(I4B), intent(in) :: maxiter
5601  integer(I4B), intent(in) :: ncnv
5602  logical(LGP), intent(in) :: lupdate
5603  ! -- local
5604  integer(I4B) :: ibflg
5605  integer(I4B) :: idhp
5606  real(DP) :: hlak
5607  real(DP) :: hlak0
5608  real(DP) :: ra
5609  real(DP) :: ro
5610  real(DP) :: qinf
5611  real(DP) :: ex
5612  real(DP) :: ev
5613  real(DP) :: wr
5614  real(DP) :: resid
5615  real(DP) :: resid1
5616  real(DP) :: residb
5617  real(DP) :: derv
5618  real(DP) :: dh
5619  real(DP) :: ts
5620  real(DP) :: adh
5621  real(DP) :: adh0
5622  real(DP) :: v0
5623  real(DP) :: v1
5624  real(DP) :: area
5625  real(DP) :: qtolfact
5626  real(DP) :: delh
5627  !
5628  delh = this%delh
5629  !
5630  ! -- skip inactive lakes
5631  if (this%iboundpak(n) == 0) then
5632  this%ncncvr(n) = 1
5633  return
5634  end if
5635  ibflg = 0
5636  hlak = this%xnewpak(n)
5637  if (iter < maxiter) then
5638  this%stageiter(n) = this%xnewpak(n)
5639  end if
5640  call this%lak_calculate_rainfall(n, hlak, ra)
5641  this%precip(n) = ra
5642  this%flwiter(n) = this%flwiter(n) + ra
5643  call this%lak_calculate_rainfall(n, hlak + delh, ra)
5644  this%precip1(n) = ra
5645  this%flwiter1(n) = this%flwiter1(n) + ra
5646  !
5647  ! -- limit withdrawals to lake inflows and lake storage
5648  call this%lak_calculate_withdrawal(n, this%flwiter(n), wr)
5649  this%withr(n) = wr
5650  call this%lak_calculate_withdrawal(n, this%flwiter1(n), wr)
5651  this%withr1(n) = wr
5652  !
5653  ! -- limit evaporation to lake inflows and lake storage
5654  call this%lak_calculate_evaporation(n, hlak, this%flwiter(n), ev)
5655  this%evap(n) = ev
5656  call this%lak_calculate_evaporation(n, hlak + delh, this%flwiter1(n), ev)
5657  this%evap1(n) = ev
5658  !
5659  ! -- no outlet flow if evaporation consumes all water
5660  call this%lak_calculate_outlet_outflow(n, hlak + delh, &
5661  this%flwiter1(n), &
5662  this%surfout1(n))
5663  call this%lak_calculate_outlet_outflow(n, hlak, this%flwiter(n), &
5664  this%surfout(n))
5665  !
5666  ! -- update the surface inflow values
5667  call this%lak_calculate_outlet_inflow(n, this%surfin(n))
5668  !
5669  !
5670  if (ncnv == 1) then
5671  if (this%iboundpak(n) > 0 .and. lupdate .eqv. .true.) then
5672  !
5673  ! -- recalculate flwin
5674  hlak0 = this%xoldpak(n)
5675  hlak = this%xnewpak(n)
5676  call this%lak_calculate_vol(n, hlak0, v0)
5677  call this%lak_calculate_vol(n, hlak, v1)
5678  call this%lak_calculate_runoff(n, ro)
5679  call this%lak_calculate_inflow(n, qinf)
5680  call this%lak_calculate_external(n, ex)
5681  this%flwin(n) = this%surfin(n) + ro + qinf + ex + &
5682  max(v0, v1) / delt
5683  !
5684  ! -- compute new lake stage using Newton's method
5685  resid = this%precip(n) + this%evap(n) + this%withr(n) + ro + &
5686  qinf + ex + this%surfin(n) + &
5687  this%surfout(n) + this%seep(n)
5688  resid1 = this%precip1(n) + this%evap1(n) + this%withr1(n) + ro + &
5689  qinf + ex + this%surfin(n) + &
5690  this%surfout1(n) + this%seep1(n)
5691  !
5692  ! -- add storage changes for transient stress periods
5693  hlak = this%xnewpak(n)
5694  if (this%gwfiss /= 1) then
5695  call this%lak_calculate_vol(n, hlak, v1)
5696  resid = resid + (v0 - v1) / delt
5697  call this%lak_calculate_vol(n, hlak + delh, v1)
5698  resid1 = resid1 + (v0 - v1) / delt
5699  end if
5700  !
5701  ! -- determine the derivative and the stage change
5702  if (abs(resid1 - resid) > dzero) then
5703  derv = (resid1 - resid) / delh
5704  dh = dzero
5705  if (abs(derv) > dprec) then
5706  dh = resid / derv
5707  end if
5708  else
5709  if (resid < dzero) then
5710  resid = dzero
5711  end if
5712  call this%lak_vol2stage(n, resid, dh)
5713  dh = hlak - dh
5714  this%ncncvr(n) = 1
5715  end if
5716  !
5717  ! -- determine if the updated stage is outside the endpoints
5718  ts = hlak - dh
5719  if (iter == 1) this%dh0(n) = dh
5720  adh = abs(dh)
5721  adh0 = abs(this%dh0(n))
5722  if ((ts >= this%en2(n)) .or. (ts < this%en1(n))) then
5723  ! -- use bisection if dh is increasing or updated stage is below the
5724  ! bottom of the lake
5725  if ((adh > adh0) .or. (ts - this%lakebot(n)) < dprec) then
5726  residb = resid
5727  call this%lak_bisection(n, ibflg, hlak, ts, dh, residb)
5728  end if
5729  end if
5730  !
5731  ! -- set seep0 on the first lake iteration
5732  if (iter == 1) then
5733  this%seep0(n) = this%seep(n)
5734  end if
5735  !
5736  ! -- check for slow convergence
5737  if (this%seep(n) * this%seep0(n) < dprec) then
5738  this%iseepc(n) = this%iseepc(n) + 1
5739  else
5740  this%iseepc(n) = 0
5741  end if
5742  ! -- determine of convergence is slow and oscillating
5743  idhp = 0
5744  if (dh * this%dh0(n) < dprec) idhp = 1
5745  ! -- determine if stage change is increasing
5746  adh = abs(dh)
5747  if (adh > adh0) idhp = 1
5748  ! -- increment idhc convergence flag
5749  if (idhp == 1) then
5750  this%idhc(n) = this%idhc(n) + 1
5751  end if
5752  !
5753  ! -- switch to bisection when the Newton-Raphson method oscillates
5754  ! or when convergence is slow
5755  if (ibflg == 1) then
5756  if (this%iseepc(n) > 7 .or. this%idhc(n) > 12) then
5757  call this%lak_bisection(n, ibflg, hlak, ts, dh, residb)
5758  end if
5759  end if
5760  else
5761  dh = dzero
5762  end if
5763  !
5764  ! -- update lake stage
5765  hlak = hlak - dh
5766  if (hlak < this%lakebot(n)) then
5767  hlak = this%lakebot(n)
5768  end if
5769  !
5770  ! -- calculate surface area
5771  call this%lak_calculate_sarea(n, hlak, area)
5772  !
5773  ! -- set the Q to length factor
5774  if (area > dzero) then
5775  qtolfact = delt / area
5776  else
5777  qtolfact = dzero
5778  end if
5779  !
5780  ! -- recalculate the residual
5781  call this%lak_calculate_residual(n, hlak, resid)
5782  !
5783  ! -- evaluate convergence
5784  !if (ABS(dh) < delh) then
5785  if (abs(dh) < delh .and. abs(resid) * qtolfact < this%dmaxchg) then
5786  this%ncncvr(n) = 1
5787  end if
5788  this%xnewpak(n) = hlak
5789  !
5790  ! -- save iterates for lake
5791  this%seep0(n) = this%seep(n)
5792  this%dh0(n) = dh
5793  end if
5794  end subroutine lak_solve_single
5795 
5796  !> @brief Estimate the lakebed seepage for a single lake
5797  !!
5798  !! Runs the two-pass connection-seepage estimate for lake n at its current
5799  !! stage and the perturbed stage, accumulating this%seep(n)/this%seep1(n) and,
5800  !! on the final pass when ncnv == 0, the gwf-cell hcof/rhs contributions. Lakes
5801  !! do not couple within this estimate (each connection touches only its own
5802  !! lake's flwiter), so evaluating both passes per lake is equivalent to the
5803  !! all-lakes-per-pass ordering in lak_solve. Extracted from lak_solve so the
5804  !! same estimate can drive the single-lake legacy solve for the IMPLICIT
5805  !! formulation.
5806  !<
5807  subroutine lak_estimate_seepage_single(this, n, ncnv)
5808  ! -- dummy
5809  class(laktype), intent(inout) :: this
5810  integer(I4B), intent(in) :: n
5811  integer(I4B), intent(in) :: ncnv
5812  ! -- local
5813  integer(I4B) :: i
5814  integer(I4B) :: j
5815  integer(I4B) :: igwfnode
5816  integer(I4B) :: idry
5817  integer(I4B) :: idry1
5818  real(DP) :: hlak
5819  real(DP) :: head
5820  real(DP) :: qlakgw
5821  real(DP) :: qlakgw1
5822  real(DP) :: gwfhcof
5823  real(DP) :: gwfrhs
5824  real(DP) :: delh
5825  !
5826  delh = this%delh
5827  !
5828  ! -- skip inactive lakes
5829  if (this%iboundpak(n) == 0) return
5830  !
5831  estseep: do i = 1, 2
5832  ! - set xoldpak to xnewpak if steady-state
5833  if (this%gwfiss /= 0) then
5834  this%xoldpak(n) = this%xnewpak(n)
5835  end if
5836  hlak = this%xnewpak(n)
5837  calcconnseep: do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
5838  igwfnode = this%cellid(j)
5839  head = this%xnew(igwfnode)
5840  if (this%ncncvr(n) /= 2) then
5841  if (this%ibound(igwfnode) > 0) then
5842  call this%lak_estimate_conn_exchange(i, n, j, idry, hlak, &
5843  head, qlakgw, &
5844  this%flwiter(n), &
5845  gwfhcof, gwfrhs)
5846  call this%lak_estimate_conn_exchange(i, n, j, idry1, &
5847  hlak + delh, head, qlakgw1, &
5848  this%flwiter1(n))
5849  !
5850  ! -- add to gwf matrix
5851  if (ncnv == 0 .and. i == 2) then
5852  if (j == this%maxbound) then
5853  this%ncncvr(n) = 2
5854  end if
5855  if (idry /= 1) then
5856  this%hcof(j) = gwfhcof
5857  this%rhs(j) = gwfrhs
5858  else
5859  this%hcof(j) = dzero
5860  this%rhs(j) = qlakgw
5861  end if
5862  end if
5863  if (i == 2) then
5864  this%seep(n) = this%seep(n) + qlakgw
5865  this%seep1(n) = this%seep1(n) + qlakgw1
5866  end if
5867  end if
5868  end if
5869  end do calcconnseep
5870  end do estseep
5871  end subroutine lak_estimate_seepage_single
5872 
5873  !> @ brief Lake package bisection method
5874  !!
5875  !! Use bisection method to find lake stage that reduces the residual
5876  !<
5877  subroutine lak_bisection(this, n, ibflg, hlak, temporary_stage, dh, residual)
5878  ! -- dummy
5879  class(laktype), intent(inout) :: this
5880  integer(I4B), intent(in) :: n !< lake number
5881  integer(I4B), intent(inout) :: ibflg !< bisection flag
5882  real(DP), intent(in) :: hlak !< lake stage
5883  real(DP), intent(inout) :: temporary_stage !< temporary lake stage
5884  real(DP), intent(inout) :: dh !< lake stage change
5885  real(DP), intent(inout) :: residual !< lake residual
5886  ! -- local
5887  integer(I4B) :: i
5888  real(DP) :: temporary_stage0
5889  real(DP) :: residuala
5890  real(DP) :: endpoint1
5891  real(DP) :: endpoint2
5892  ! -- code
5893  ibflg = 1
5894  temporary_stage0 = hlak
5895  endpoint1 = this%en1(n)
5896  endpoint2 = this%en2(n)
5897  call this%lak_calculate_residual(n, temporary_stage, residuala)
5898  if (hlak > endpoint1 .and. hlak < endpoint2) then
5899  endpoint2 = hlak
5900  end if
5901  do i = 1, this%maxlakit
5902  temporary_stage = dhalf * (endpoint1 + endpoint2)
5903  call this%lak_calculate_residual(n, temporary_stage, residual)
5904  if (abs(residual) == dzero .or. &
5905  abs(temporary_stage0 - temporary_stage) < this%dmaxchg) then
5906  exit
5907  end if
5908  call this%lak_calculate_residual(n, endpoint1, residuala)
5909  ! -- change end points
5910  ! -- root is between temporary_stage and endpoint2
5911  if (sign(done, residuala) == sign(done, residual)) then
5912  endpoint1 = temporary_stage
5913  ! -- root is between endpoint1 and temporary_stage
5914  else
5915  endpoint2 = temporary_stage
5916  end if
5917  temporary_stage0 = temporary_stage
5918  end do
5919  dh = hlak - temporary_stage
5920  end subroutine lak_bisection
5921 
5922  !> @brief Calculate the available volumetric rate for a lake given a passed
5923  !! stage
5924  !<
5925  subroutine lak_calculate_available(this, n, hlak, avail, &
5926  ra, ro, qinf, ex, headp)
5927  ! -- modules
5928  use tdismodule, only: delt
5929  ! -- dummy
5930  class(laktype), intent(inout) :: this
5931  integer(I4B), intent(in) :: n
5932  real(DP), intent(in) :: hlak
5933  real(DP), intent(inout) :: avail
5934  real(DP), intent(inout) :: ra
5935  real(DP), intent(inout) :: ro
5936  real(DP), intent(inout) :: qinf
5937  real(DP), intent(inout) :: ex
5938  real(DP), intent(in), optional :: headp
5939  ! -- local
5940  integer(I4B) :: j
5941  integer(I4B) :: idry
5942  integer(I4B) :: igwfnode
5943  real(DP) :: hp
5944  real(DP) :: head
5945  real(DP) :: qlakgw
5946  real(DP) :: v0
5947  !
5948  ! -- set hp
5949  if (present(headp)) then
5950  hp = headp
5951  else
5952  hp = dzero
5953  end if
5954  !
5955  ! -- initialize
5956  avail = dzero
5957  !
5958  ! -- calculate the aquifer sources to the lake
5959  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
5960  igwfnode = this%cellid(j)
5961  if (this%ibound(igwfnode) == 0) cycle
5962  head = this%xnew(igwfnode) + hp
5963  call this%lak_estimate_conn_exchange(1, n, j, idry, hlak, head, qlakgw, &
5964  avail)
5965  end do
5966  !
5967  ! -- add rainfall
5968  call this%lak_calculate_rainfall(n, hlak, ra)
5969  avail = avail + ra
5970  !
5971  ! -- calculate runoff
5972  call this%lak_calculate_runoff(n, ro)
5973  avail = avail + ro
5974  !
5975  ! -- calculate inflow
5976  call this%lak_calculate_inflow(n, qinf)
5977  avail = avail + qinf
5978  !
5979  ! -- calculate external flow terms
5980  call this%lak_calculate_external(n, ex)
5981  avail = avail + ex
5982  !
5983  ! -- calculate volume available in storage
5984  call this%lak_calculate_vol(n, this%xoldpak(n), v0)
5985  avail = avail + v0 / delt
5986  end subroutine lak_calculate_available
5987 
5988  !> @brief Calculate the residual for a lake given a passed stage
5989  !<
5990  subroutine lak_calculate_residual(this, n, hlak, resid, headp)
5991  ! -- modules
5992  use tdismodule, only: delt
5993  ! -- dummy
5994  class(laktype), intent(inout) :: this
5995  integer(I4B), intent(in) :: n
5996  real(DP), intent(in) :: hlak
5997  real(DP), intent(inout) :: resid
5998  real(DP), intent(in), optional :: headp
5999  ! -- local
6000  integer(I4B) :: j
6001  integer(I4B) :: idry
6002  integer(I4B) :: igwfnode
6003  real(DP) :: hp
6004  real(DP) :: avail
6005  real(DP) :: head
6006  real(DP) :: ra
6007  real(DP) :: ro
6008  real(DP) :: qinf
6009  real(DP) :: ex
6010  real(DP) :: ev
6011  real(DP) :: wr
6012  real(DP) :: sout
6013  real(DP) :: sin
6014  real(DP) :: qlakgw
6015  real(DP) :: seep
6016  real(DP) :: hlak0
6017  real(DP) :: v0
6018  real(DP) :: v1
6019  !
6020  ! -- set hp
6021  if (present(headp)) then
6022  hp = headp
6023  else
6024  hp = dzero
6025  end if
6026  !
6027  ! -- initialize
6028  resid = dzero
6029  avail = dzero
6030  seep = dzero
6031  !
6032  ! -- calculate the available water
6033  call this%lak_calculate_available(n, hlak, avail, &
6034  ra, ro, qinf, ex, hp)
6035  !
6036  ! -- calculate groundwater seepage
6037  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
6038  igwfnode = this%cellid(j)
6039  if (this%ibound(igwfnode) == 0) cycle
6040  head = this%xnew(igwfnode) + hp
6041  call this%lak_estimate_conn_exchange(2, n, j, idry, hlak, head, qlakgw, &
6042  avail)
6043  seep = seep + qlakgw
6044  end do
6045  !
6046  ! -- limit withdrawals to lake inflows and lake storage
6047  call this%lak_calculate_withdrawal(n, avail, wr)
6048  !
6049  ! -- limit evaporation to lake inflows and lake storage
6050  call this%lak_calculate_evaporation(n, hlak, avail, ev)
6051  !
6052  ! -- no outlet flow if evaporation consumes all water
6053  call this%lak_calculate_outlet_outflow(n, hlak, avail, sout)
6054  !
6055  ! -- update the surface inflow values
6056  call this%lak_calculate_outlet_inflow(n, sin)
6057  !
6058  ! -- calculate residual
6059  resid = ra + ev + wr + ro + qinf + ex + sin + sout + seep
6060  !
6061  ! -- include storage
6062  if (this%gwfiss /= 1) then
6063  hlak0 = this%xoldpak(n)
6064  call this%lak_calculate_vol(n, hlak0, v0)
6065  call this%lak_calculate_vol(n, hlak, v1)
6066  resid = resid + (v0 - v1) / delt
6067  end if
6068  end subroutine lak_calculate_residual
6069 
6070  !> @brief Set up the budget object that stores all the lake flows
6071  !<
6072  subroutine lak_setup_budobj(this)
6073  ! -- modules
6074  use constantsmodule, only: lenbudtxt
6075  ! -- dummy
6076  class(laktype) :: this
6077  ! -- local
6078  integer(I4B) :: nbudterm
6079  integer(I4B) :: nlen
6080  integer(I4B) :: j, n, n1, n2
6081  integer(I4B) :: maxlist, naux
6082  integer(I4B) :: idx
6083  real(DP) :: q
6084  character(len=LENBUDTXT) :: text
6085  character(len=LENBUDTXT), dimension(1) :: auxtxt
6086  !
6087  ! -- Determine the number of lake budget terms. These are fixed for
6088  ! the simulation and cannot change
6089  nbudterm = 9
6090  nlen = 0
6091  do n = 1, this%noutlets
6092  if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then
6093  nlen = nlen + 1
6094  end if
6095  end do
6096  if (nlen > 0) nbudterm = nbudterm + 1
6097  if (this%imover == 1) nbudterm = nbudterm + 2
6098  if (this%naux > 0) nbudterm = nbudterm + 1
6099  !
6100  ! -- set up budobj
6101  call budgetobject_cr(this%budobj, this%packName)
6102  call this%budobj%budgetobject_df(this%nlakes, nbudterm, 0, 0, &
6103  ibudcsv=this%ibudcsv)
6104  idx = 0
6105  !
6106  ! -- Go through and set up each budget term. nlen is the number
6107  ! of outlets that discharge into another lake
6108  if (nlen > 0) then
6109  text = ' FLOW-JA-FACE'
6110  idx = idx + 1
6111  maxlist = 2 * nlen
6112  naux = 0
6113  call this%budobj%budterm(idx)%initialize(text, &
6114  this%name_model, &
6115  this%packName, &
6116  this%name_model, &
6117  this%packName, &
6118  maxlist, .false., .false., &
6119  naux, ordered_id1=.false.)
6120  !
6121  ! -- store connectivity
6122  call this%budobj%budterm(idx)%reset(2 * nlen)
6123  q = dzero
6124  do n = 1, this%noutlets
6125  n1 = this%lakein(n)
6126  n2 = this%lakeout(n)
6127  if (n1 > 0 .and. n2 > 0) then
6128  call this%budobj%budterm(idx)%update_term(n1, n2, q)
6129  call this%budobj%budterm(idx)%update_term(n2, n1, -q)
6130  end if
6131  end do
6132  end if
6133  !
6134  ! --
6135  text = ' GWF'
6136  idx = idx + 1
6137  maxlist = this%maxbound
6138  naux = 1
6139  auxtxt(1) = ' FLOW-AREA'
6140  call this%budobj%budterm(idx)%initialize(text, &
6141  this%name_model, &
6142  this%packName, &
6143  this%name_model, &
6144  this%name_model, &
6145  maxlist, .false., .true., &
6146  naux, auxtxt)
6147  call this%budobj%budterm(idx)%reset(this%maxbound)
6148  q = dzero
6149  do n = 1, this%nlakes
6150  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
6151  n2 = this%cellid(j)
6152  call this%budobj%budterm(idx)%update_term(n, n2, q)
6153  end do
6154  end do
6155  !
6156  ! --
6157  text = ' RAINFALL'
6158  idx = idx + 1
6159  maxlist = this%nlakes
6160  naux = 0
6161  call this%budobj%budterm(idx)%initialize(text, &
6162  this%name_model, &
6163  this%packName, &
6164  this%name_model, &
6165  this%packName, &
6166  maxlist, .false., .false., &
6167  naux)
6168  !
6169  ! --
6170  text = ' EVAPORATION'
6171  idx = idx + 1
6172  maxlist = this%nlakes
6173  naux = 0
6174  call this%budobj%budterm(idx)%initialize(text, &
6175  this%name_model, &
6176  this%packName, &
6177  this%name_model, &
6178  this%packName, &
6179  maxlist, .false., .false., &
6180  naux)
6181  !
6182  ! --
6183  text = ' RUNOFF'
6184  idx = idx + 1
6185  maxlist = this%nlakes
6186  naux = 0
6187  call this%budobj%budterm(idx)%initialize(text, &
6188  this%name_model, &
6189  this%packName, &
6190  this%name_model, &
6191  this%packName, &
6192  maxlist, .false., .false., &
6193  naux)
6194  !
6195  ! --
6196  text = ' EXT-INFLOW'
6197  idx = idx + 1
6198  maxlist = this%nlakes
6199  naux = 0
6200  call this%budobj%budterm(idx)%initialize(text, &
6201  this%name_model, &
6202  this%packName, &
6203  this%name_model, &
6204  this%packName, &
6205  maxlist, .false., .false., &
6206  naux)
6207  !
6208  ! --
6209  text = ' WITHDRAWAL'
6210  idx = idx + 1
6211  maxlist = this%nlakes
6212  naux = 0
6213  call this%budobj%budterm(idx)%initialize(text, &
6214  this%name_model, &
6215  this%packName, &
6216  this%name_model, &
6217  this%packName, &
6218  maxlist, .false., .false., &
6219  naux)
6220  !
6221  ! --
6222  text = ' EXT-OUTFLOW'
6223  idx = idx + 1
6224  maxlist = this%nlakes
6225  naux = 0
6226  call this%budobj%budterm(idx)%initialize(text, &
6227  this%name_model, &
6228  this%packName, &
6229  this%name_model, &
6230  this%packName, &
6231  maxlist, .false., .false., &
6232  naux)
6233  !
6234  ! --
6235  text = ' STORAGE'
6236  idx = idx + 1
6237  maxlist = this%nlakes
6238  naux = 1
6239  auxtxt(1) = ' VOLUME'
6240  call this%budobj%budterm(idx)%initialize(text, &
6241  this%name_model, &
6242  this%packName, &
6243  this%name_model, &
6244  this%packName, &
6245  maxlist, .false., .false., &
6246  naux, auxtxt)
6247  !
6248  ! --
6249  text = ' CONSTANT'
6250  idx = idx + 1
6251  maxlist = this%nlakes
6252  naux = 0
6253  call this%budobj%budterm(idx)%initialize(text, &
6254  this%name_model, &
6255  this%packName, &
6256  this%name_model, &
6257  this%packName, &
6258  maxlist, .false., .false., &
6259  naux)
6260  !
6261  ! --
6262  if (this%imover == 1) then
6263  !
6264  ! --
6265  text = ' FROM-MVR'
6266  idx = idx + 1
6267  maxlist = this%nlakes
6268  naux = 0
6269  call this%budobj%budterm(idx)%initialize(text, &
6270  this%name_model, &
6271  this%packName, &
6272  this%name_model, &
6273  this%packName, &
6274  maxlist, .false., .false., &
6275  naux)
6276  !
6277  ! --
6278  text = ' TO-MVR'
6279  idx = idx + 1
6280  maxlist = this%noutlets
6281  naux = 0
6282  call this%budobj%budterm(idx)%initialize(text, &
6283  this%name_model, &
6284  this%packName, &
6285  this%name_model, &
6286  this%packName, &
6287  maxlist, .false., .false., &
6288  naux, ordered_id1=.false.)
6289  !
6290  ! -- store to-mvr connection information
6291  call this%budobj%budterm(idx)%reset(this%noutlets)
6292  q = dzero
6293  do n = 1, this%noutlets
6294  n1 = this%lakein(n)
6295  call this%budobj%budterm(idx)%update_term(n1, n1, q)
6296  end do
6297  end if
6298  !
6299  ! --
6300  naux = this%naux
6301  if (naux > 0) then
6302  !
6303  ! --
6304  text = ' AUXILIARY'
6305  idx = idx + 1
6306  maxlist = this%nlakes
6307  call this%budobj%budterm(idx)%initialize(text, &
6308  this%name_model, &
6309  this%packName, &
6310  this%name_model, &
6311  this%packName, &
6312  maxlist, .false., .false., &
6313  naux, this%auxname)
6314  end if
6315  !
6316  ! -- if lake flow for each reach are written to the listing file
6317  if (this%iprflow /= 0) then
6318  call this%budobj%flowtable_df(this%iout)
6319  end if
6320  end subroutine lak_setup_budobj
6321 
6322  !> @brief Copy flow terms into this%budobj
6323  !<
6324  subroutine lak_fill_budobj(this)
6325  ! -- dummy
6326  class(laktype) :: this
6327  ! -- local
6328  integer(I4B) :: naux
6329  real(DP), dimension(:), allocatable :: auxvartmp
6330  !integer(I4B) :: i
6331  integer(I4B) :: j
6332  integer(I4B) :: n
6333  integer(I4B) :: n1
6334  integer(I4B) :: n2
6335  integer(I4B) :: ii
6336  integer(I4B) :: jj
6337  integer(I4B) :: idx
6338  integer(I4B) :: nlen
6339  real(DP) :: v, v1
6340  real(DP) :: q
6341  real(DP) :: lkstg, gwhead, wa
6342  !
6343  ! -- initialize counter
6344  idx = 0
6345 
6346  ! -- FLOW JA FACE
6347  nlen = 0
6348  do n = 1, this%noutlets
6349  if (this%lakein(n) > 0 .and. this%lakeout(n) > 0) then
6350  nlen = nlen + 1
6351  end if
6352  end do
6353  if (nlen > 0) then
6354  idx = idx + 1
6355  call this%budobj%budterm(idx)%reset(2 * nlen)
6356  do n = 1, this%noutlets
6357  n1 = this%lakein(n)
6358  n2 = this%lakeout(n)
6359  if (n1 > 0 .and. n2 > 0) then
6360  q = this%simoutrate(n)
6361  if (this%imover == 1) then
6362  q = q + this%pakmvrobj%get_qtomvr(n)
6363  end if
6364  call this%budobj%budterm(idx)%update_term(n1, n2, q)
6365  call this%budobj%budterm(idx)%update_term(n2, n1, -q)
6366  end if
6367  end do
6368  end if
6369  !
6370  ! -- GWF (LEAKAGE)
6371  idx = idx + 1
6372  call this%budobj%budterm(idx)%reset(this%maxbound)
6373  do n = 1, this%nlakes
6374  do j = this%idxlakeconn(n), this%idxlakeconn(n + 1) - 1
6375  n2 = this%cellid(j)
6376  q = this%qleak(j)
6377  lkstg = this%xnewpak(n)
6378  ! -- For the case when the lak stage is exactly equal
6379  ! to the lake bottom, the wetted area is not returned
6380  ! equal to 0.0
6381  gwhead = this%xnew(n2)
6382  call this%lak_calculate_conn_warea(n, j, lkstg, gwhead, wa)
6383  ! -- For thermal conduction between a lake and a gw cell,
6384  ! the shared wetted area should be reset to zero when the lake
6385  ! stage is below the cell bottom
6386  if (this%belev(j) > lkstg) wa = dzero
6387  this%qauxcbc(1) = wa
6388  call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc)
6389  end do
6390  end do
6391  !
6392  ! -- RAIN
6393  idx = idx + 1
6394  call this%budobj%budterm(idx)%reset(this%nlakes)
6395  do n = 1, this%nlakes
6396  q = this%precip(n)
6397  call this%budobj%budterm(idx)%update_term(n, n, q)
6398  end do
6399  !
6400  ! -- EVAPORATION
6401  idx = idx + 1
6402  call this%budobj%budterm(idx)%reset(this%nlakes)
6403  do n = 1, this%nlakes
6404  q = this%evap(n)
6405  call this%budobj%budterm(idx)%update_term(n, n, q)
6406  end do
6407  !
6408  ! -- RUNOFF
6409  idx = idx + 1
6410  call this%budobj%budterm(idx)%reset(this%nlakes)
6411  do n = 1, this%nlakes
6412  q = this%runoff(n)
6413  call this%budobj%budterm(idx)%update_term(n, n, q)
6414  end do
6415  !
6416  ! -- INFLOW
6417  idx = idx + 1
6418  call this%budobj%budterm(idx)%reset(this%nlakes)
6419  do n = 1, this%nlakes
6420  q = this%inflow(n)
6421  call this%budobj%budterm(idx)%update_term(n, n, q)
6422  end do
6423  !
6424  ! -- WITHDRAWAL
6425  idx = idx + 1
6426  call this%budobj%budterm(idx)%reset(this%nlakes)
6427  do n = 1, this%nlakes
6428  q = this%withr(n)
6429  call this%budobj%budterm(idx)%update_term(n, n, q)
6430  end do
6431  !
6432  ! -- EXTERNAL OUTFLOW
6433  idx = idx + 1
6434  call this%budobj%budterm(idx)%reset(this%nlakes)
6435  do n = 1, this%nlakes
6436  call this%lak_get_external_outlet(n, q)
6437  ! subtract tomover from external outflow
6438  call this%lak_get_external_mover(n, v)
6439  q = q + v
6440  call this%budobj%budterm(idx)%update_term(n, n, q)
6441  end do
6442  !
6443  ! -- STORAGE
6444  idx = idx + 1
6445  call this%budobj%budterm(idx)%reset(this%nlakes)
6446  do n = 1, this%nlakes
6447  call this%lak_calculate_vol(n, this%xnewpak(n), v1)
6448  q = this%qsto(n)
6449  this%qauxcbc(1) = v1
6450  call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc)
6451  end do
6452  !
6453  ! -- CONSTANT FLOW
6454  idx = idx + 1
6455  call this%budobj%budterm(idx)%reset(this%nlakes)
6456  do n = 1, this%nlakes
6457  q = this%chterm(n)
6458  call this%budobj%budterm(idx)%update_term(n, n, q)
6459  end do
6460  !
6461  ! -- MOVER
6462  if (this%imover == 1) then
6463  !
6464  ! -- FROM MOVER
6465  idx = idx + 1
6466  call this%budobj%budterm(idx)%reset(this%nlakes)
6467  do n = 1, this%nlakes
6468  q = this%pakmvrobj%get_qfrommvr(n)
6469  call this%budobj%budterm(idx)%update_term(n, n, q)
6470  end do
6471  !
6472  ! -- TO MOVER
6473  idx = idx + 1
6474  call this%budobj%budterm(idx)%reset(this%noutlets)
6475  do n = 1, this%noutlets
6476  n1 = this%lakein(n)
6477  q = this%pakmvrobj%get_qtomvr(n)
6478  if (q > dzero) then
6479  q = -q
6480  end if
6481  call this%budobj%budterm(idx)%update_term(n1, n1, q)
6482  end do
6483  !
6484  end if
6485  !
6486  ! -- AUXILIARY VARIABLES
6487  naux = this%naux
6488  if (naux > 0) then
6489  idx = idx + 1
6490  allocate (auxvartmp(naux))
6491  call this%budobj%budterm(idx)%reset(this%nlakes)
6492  do n = 1, this%nlakes
6493  q = dzero
6494  do jj = 1, naux
6495  ii = n
6496  auxvartmp(jj) = this%lauxvar(jj, ii)
6497  end do
6498  call this%budobj%budterm(idx)%update_term(n, n, q, auxvartmp)
6499  end do
6500  deallocate (auxvartmp)
6501  end if
6502  !
6503  ! --Terms are filled, now accumulate them for this time step
6504  call this%budobj%accumulate_terms()
6505  end subroutine lak_fill_budobj
6506 
6507  !> @brief Set up the table object that is used to write the lak stage data
6508  !!
6509  !! The terms listed here must correspond in number and order to the ones
6510  !! written to the stage table in the lak_ot method
6511  !<
6512  subroutine lak_setup_tableobj(this)
6513  ! -- modules
6514  use constantsmodule, only: linelength, lenbudtxt
6515  ! -- dummy
6516  class(laktype) :: this
6517  ! -- local
6518  integer(I4B) :: nterms
6519  character(len=LINELENGTH) :: title
6520  character(len=LINELENGTH) :: text
6521  !
6522  ! -- setup stage table
6523  if (this%iprhed > 0) then
6524  !
6525  ! -- Determine the number of lake stage terms. These are fixed for
6526  ! the simulation and cannot change. This includes FLOW-JA-FACE
6527  ! so they can be written to the binary budget files, but these internal
6528  ! flows are not included as part of the budget table.
6529  nterms = 5
6530  if (this%inamedbound == 1) then
6531  nterms = nterms + 1
6532  end if
6533  !
6534  ! -- set up table title
6535  title = trim(adjustl(this%text))//' PACKAGE ('// &
6536  trim(adjustl(this%packName))//') STAGES FOR EACH CONTROL VOLUME'
6537  !
6538  ! -- set up stage tableobj
6539  call table_cr(this%stagetab, this%packName, title)
6540  call this%stagetab%table_df(this%nlakes, nterms, this%iout, &
6541  transient=.true.)
6542  !
6543  ! -- Go through and set up table budget term
6544  if (this%inamedbound == 1) then
6545  text = 'NAME'
6546  call this%stagetab%initialize_column(text, 20, alignment=tableft)
6547  end if
6548  !
6549  ! -- lake number
6550  text = 'NUMBER'
6551  call this%stagetab%initialize_column(text, 10, alignment=tabcenter)
6552  !
6553  ! -- lake stage
6554  text = 'STAGE'
6555  call this%stagetab%initialize_column(text, 12, alignment=tabcenter)
6556  !
6557  ! -- lake surface area
6558  text = 'SURFACE AREA'
6559  call this%stagetab%initialize_column(text, 12, alignment=tabcenter)
6560  !
6561  ! -- lake wetted area
6562  text = 'WETTED AREA'
6563  call this%stagetab%initialize_column(text, 12, alignment=tabcenter)
6564  !
6565  ! -- lake volume
6566  text = 'VOLUME'
6567  call this%stagetab%initialize_column(text, 12, alignment=tabcenter)
6568  end if
6569  end subroutine lak_setup_tableobj
6570 
6571  !> @brief Activate addition of density terms
6572  !<
6573  subroutine lak_activate_density(this)
6574  ! -- dummy
6575  class(laktype), intent(inout) :: this
6576  ! -- local
6577  integer(I4B) :: i, j
6578  !
6579  ! -- the IMPLICIT formulation does not include the density terms yet
6580  if (this%iimplicit /= 0) then
6581  write (errmsg, '(a)') &
6582  'The IMPLICIT option cannot be used with the BUY package until the &
6583  &implicit formulation includes density terms. Remove the IMPLICIT &
6584  &option from LAK package '//trim(this%packName)//' to simulate &
6585  &density.'
6586  call store_error(errmsg)
6587  call this%parser%StoreErrorUnit()
6588  end if
6589  !
6590  ! -- Set idense and reallocate denseterms to be of size MAXBOUND
6591  this%idense = 1
6592  call mem_reallocate(this%denseterms, 3, this%MAXBOUND, 'DENSETERMS', &
6593  this%memoryPath)
6594  do i = 1, this%maxbound
6595  do j = 1, 3
6596  this%denseterms(j, i) = dzero
6597  end do
6598  end do
6599  write (this%iout, '(/1x,a)') 'DENSITY TERMS HAVE BEEN ACTIVATED FOR LAKE &
6600  &PACKAGE: '//trim(adjustl(this%packName))
6601  end subroutine lak_activate_density
6602 
6603  !> @brief Activate viscosity terms
6604  !!
6605  !! Method to activate addition of viscosity terms for a LAK package reach.
6606  !<
6607  subroutine lak_activate_viscosity(this)
6608  ! -- modules
6609  use memorymanagermodule, only: mem_reallocate
6610  ! -- dummy variables
6611  class(laktype), intent(inout) :: this !< LakType object
6612  ! -- local variables
6613  integer(I4B) :: i
6614  integer(I4B) :: j
6615  !
6616  ! -- Set ivsc and reallocate viscratios to be of size MAXBOUND
6617  this%ivsc = 1
6618  call mem_reallocate(this%viscratios, 2, this%MAXBOUND, 'VISCRATIOS', &
6619  this%memoryPath)
6620  do i = 1, this%maxbound
6621  do j = 1, 2
6622  this%viscratios(j, i) = done
6623  end do
6624  end do
6625  write (this%iout, '(/1x,a)') 'VISCOSITY HAS BEEN ACTIVATED FOR LAK &
6626  &PACKAGE: '//trim(adjustl(this%packName))
6627  end subroutine lak_activate_viscosity
6628 
6629  !> @brief Calculate the groundwater-lake density exchange terms
6630  !!
6631  !! Arguments are as follows:
6632  !! iconn : lak-gwf connection number
6633  !! stage : lake stage
6634  !! head : gwf head
6635  !! cond : conductance
6636  !! botl : bottom elevation of this connection
6637  !! flow : calculated flow, updated here with density terms
6638  !! gwfhcof : gwf head coefficient, updated here with density terms
6639  !! gwfrhs : gwf right-hand-side value, updated here with density terms
6640  !!
6641  !! Member variable used here
6642  !! denseterms : shape (3, MAXBOUND), filled by buoyancy package
6643  !! col 1 is relative density of lake (denselak / denseref)
6644  !! col 2 is relative density of gwf cell (densegwf / denseref)
6645  !! col 3 is elevation of gwf cell
6646  !<
6647  subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, &
6648  botl, flow, gwfhcof, gwfrhs)
6649  ! -- dummy
6650  class(laktype), intent(inout) :: this
6651  integer(I4B), intent(in) :: iconn
6652  real(DP), intent(in) :: stage
6653  real(DP), intent(in) :: head
6654  real(DP), intent(in) :: cond
6655  real(DP), intent(in) :: botl
6656  real(DP), intent(inout) :: flow
6657  real(DP), intent(inout) :: gwfhcof
6658  real(DP), intent(inout) :: gwfrhs
6659  ! -- local
6660  real(DP) :: ss
6661  real(DP) :: hh
6662  real(DP) :: havg
6663  real(DP) :: rdenselak
6664  real(DP) :: rdensegwf
6665  real(DP) :: rdenseavg
6666  real(DP) :: elevlak
6667  real(DP) :: elevgwf
6668  real(DP) :: elevavg
6669  real(DP) :: d1
6670  real(DP) :: d2
6671  logical(LGP) :: stage_below_bot
6672  logical(LGP) :: head_below_bot
6673  !
6674  ! -- Set lak density to lak density or gwf density
6675  if (stage >= botl) then
6676  ss = stage
6677  stage_below_bot = .false.
6678  rdenselak = this%denseterms(1, iconn) ! lak rel density
6679  else
6680  ss = botl
6681  stage_below_bot = .true.
6682  rdenselak = this%denseterms(2, iconn) ! gwf rel density
6683  end if
6684  !
6685  ! -- set hh to head or botl
6686  if (head >= botl) then
6687  hh = head
6688  head_below_bot = .false.
6689  rdensegwf = this%denseterms(2, iconn) ! gwf rel density
6690  else
6691  hh = botl
6692  head_below_bot = .true.
6693  rdensegwf = this%denseterms(1, iconn) ! lak rel density
6694  end if
6695  !
6696  ! -- todo: hack because denseterms not updated in a cf calculation
6697  if (rdensegwf == dzero) return
6698  !
6699  ! -- Update flow
6700  if (stage_below_bot .and. head_below_bot) then
6701  !
6702  ! -- flow is zero, so no terms are updated
6703  !
6704  else
6705  !
6706  ! -- calculate average relative density
6707  rdenseavg = dhalf * (rdenselak + rdensegwf)
6708  !
6709  ! -- Add contribution of first density term:
6710  ! cond * (denseavg/denseref - 1) * (hgwf - hlak)
6711  d1 = cond * (rdenseavg - done)
6712  gwfhcof = gwfhcof - d1
6713  gwfrhs = gwfrhs - d1 * ss
6714  d1 = d1 * (hh - ss)
6715  flow = flow + d1
6716  !
6717  ! -- Add second density term if stage and head not below bottom
6718  if (.not. stage_below_bot .and. .not. head_below_bot) then
6719  !
6720  ! -- Add contribution of second density term:
6721  ! cond * (havg - elevavg) * (densegwf - denselak) / denseref
6722  elevgwf = this%denseterms(3, iconn)
6723  if (this%ictype(iconn) == 0 .or. this%ictype(iconn) == 3) then
6724  ! -- vertical or embedded vertical connection
6725  elevlak = botl
6726  else
6727  ! -- horizontal or embedded horizontal connection
6728  elevlak = elevgwf
6729  end if
6730  elevavg = dhalf * (elevlak + elevgwf)
6731  havg = dhalf * (hh + ss)
6732  d2 = cond * (havg - elevavg) * (rdensegwf - rdenselak)
6733  gwfrhs = gwfrhs + d2
6734  flow = flow + d2
6735  end if
6736  end if
6737  end subroutine lak_calculate_density_exchange
6738 
6739 end module lakmodule
memorymanagermodule::mem_allocate
Definition: MemoryManager.f90:55
memorymanagermodule::mem_checkin
Definition: MemoryManager.f90:72
memorymanagermodule::mem_deallocate
Definition: MemoryManager.f90:129
memorymanagermodule::mem_reallocate
Definition: MemoryManager.f90:82
memorymanagermodule::mem_setptr
Definition: MemoryManager.f90:93
blockparsermodule
This module contains block parser methods.
Definition: BlockParser.f90:7
bndmodule
This module contains the base boundary package.
Definition: BoundaryPackage.f90:7
budgetobjectmodule::budgetobject_cr
subroutine, public budgetobject_cr(this, name)
Create a new budget object.
Definition: BudgetObject.f90:83
constantsmodule
This module contains simulation constants.
Definition: Constants.f90:9
constantsmodule::linelength
integer(i4b), parameter linelength
maximum length of a standard line
Definition: Constants.f90:45
constantsmodule::dhdry
real(dp), parameter dhdry
real dry cell constant
Definition: Constants.f90:94
constantsmodule::tabcenter
@ tabcenter
centered table column
Definition: Constants.f90:173
constantsmodule::tabright
@ tabright
right justified table column
Definition: Constants.f90:174
constantsmodule::tableft
@ tableft
left justified table column
Definition: Constants.f90:172
constantsmodule::mnormal
@ mnormal
normal output mode
Definition: Constants.f90:207
constantsmodule::dtwothirds
real(dp), parameter dtwothirds
real constant 2/3
Definition: Constants.f90:70
constantsmodule::tabucstring
@ tabucstring
upper case string table data
Definition: Constants.f90:181
constantsmodule::tabstring
@ tabstring
string table data
Definition: Constants.f90:180
constantsmodule::tabreal
@ tabreal
real table data
Definition: Constants.f90:183
constantsmodule::tabinteger
@ tabinteger
integer table data
Definition: Constants.f90:182
constantsmodule::lenpackagename
integer(i4b), parameter lenpackagename
maximum length of the package name
Definition: Constants.f90:23
constantsmodule::dp9
real(dp), parameter dp9
real constant 9/10
Definition: Constants.f90:72
constantsmodule::iwetlake
integer(i4b), parameter iwetlake
integer constant for a dry lake
Definition: Constants.f90:52
constantsmodule::deight
real(dp), parameter deight
real constant 8
Definition: Constants.f90:83
constantsmodule::dfivethirds
real(dp), parameter dfivethirds
real constant 5/3
Definition: Constants.f90:78
constantsmodule::dp999
real(dp), parameter dp999
real constant 999/1000
Definition: Constants.f90:74
constantsmodule::namedboundflag
integer(i4b), parameter namedboundflag
named bound flag
Definition: Constants.f90:49
constantsmodule::donethird
real(dp), parameter donethird
real constant 1/3
Definition: Constants.f90:67
constantsmodule::dnodata
real(dp), parameter dnodata
real no data constant
Definition: Constants.f90:95
constantsmodule::dhnoflo
real(dp), parameter dhnoflo
real no flow constant
Definition: Constants.f90:93
constantsmodule::lenpakloc
integer(i4b), parameter lenpakloc
maximum length of a package location
Definition: Constants.f90:50
constantsmodule::lentimeseriesname
integer(i4b), parameter lentimeseriesname
maximum length of a time series name
Definition: Constants.f90:42
constantsmodule::dep20
real(dp), parameter dep20
real constant 1e20
Definition: Constants.f90:91
constantsmodule::dem1
real(dp), parameter dem1
real constant 1e-1
Definition: Constants.f90:103
constantsmodule::maxadpit
integer(i4b), parameter maxadpit
maximum advanced package Newton-Raphson iterations
Definition: Constants.f90:53
constantsmodule::lenvarname
integer(i4b), parameter lenvarname
maximum length of a variable name
Definition: Constants.f90:17
constantsmodule::dhalf
real(dp), parameter dhalf
real constant 1/2
Definition: Constants.f90:68
constantsmodule::lenftype
integer(i4b), parameter lenftype
maximum length of a package type (DIS, WEL, OC, etc.)
Definition: Constants.f90:39
constantsmodule::dgravity
real(dp), parameter dgravity
real constant gravitational acceleration (m/(s s))
Definition: Constants.f90:132
constantsmodule::dpi
real(dp), parameter dpi
real constant
Definition: Constants.f90:128
constantsmodule::lenboundname
integer(i4b), parameter lenboundname
maximum length of a bound name
Definition: Constants.f90:36
constantsmodule::dem4
real(dp), parameter dem4
real constant 1e-4
Definition: Constants.f90:107
constantsmodule::dem30
real(dp), parameter dem30
real constant 1e-30
Definition: Constants.f90:118
constantsmodule::dem6
real(dp), parameter dem6
real constant 1e-6
Definition: Constants.f90:109
constantsmodule::dzero
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:65
constantsmodule::dcd
real(dp), parameter dcd
real constant weir coefficient in SI units
Definition: Constants.f90:133
constantsmodule::dem5
real(dp), parameter dem5
real constant 1e-5
Definition: Constants.f90:108
constantsmodule::dten
real(dp), parameter dten
real constant 10
Definition: Constants.f90:84
constantsmodule::dprec
real(dp), parameter dprec
real constant machine precision
Definition: Constants.f90:120
constantsmodule::maxcharlen
integer(i4b), parameter maxcharlen
maximum length of char string
Definition: Constants.f90:47
constantsmodule::dp7
real(dp), parameter dp7
real constant 7/10
Definition: Constants.f90:71
constantsmodule::dem9
real(dp), parameter dem9
real constant 1e-9
Definition: Constants.f90:112
constantsmodule::dem2
real(dp), parameter dem2
real constant 1e-2
Definition: Constants.f90:105
constantsmodule::dtwo
real(dp), parameter dtwo
real constant 2
Definition: Constants.f90:79
constantsmodule::lenbudtxt
integer(i4b), parameter lenbudtxt
maximum length of a budget component names
Definition: Constants.f90:37
constantsmodule::dthree
real(dp), parameter dthree
real constant 3
Definition: Constants.f90:80
constantsmodule::done
real(dp), parameter done
real constant 1
Definition: Constants.f90:76
geomutilmodule::get_node
integer(i4b) function, public get_node(ilay, irow, icol, nlay, nrow, ncol)
Get node number, given layer, row, and column indices for a structured grid. If any argument is inval...
Definition: GeomUtil.f90:92
inputoutputmodule::assign_iounit
subroutine, public assign_iounit(iounit, errunit, description)
@ brief assign io unit number
Definition: InputOutput.f90:185
inputoutputmodule::extract_idnum_or_bndname
subroutine, public extract_idnum_or_bndname(line, icol, istart, istop, idnum, bndname)
Starting at position icol, define string as line(istart:istop).
Definition: InputOutput.f90:1311
inputoutputmodule::getunit
integer(i4b) function, public getunit()
Get a free unit number.
Definition: InputOutput.f90:166
inputoutputmodule::ulasav
subroutine, public ulasav(buf, text, kstp, kper, pertim, totim, ncol, nrow, ilay, ichn)
Save 1 layer array on disk.
Definition: InputOutput.f90:922
inputoutputmodule::openfile
subroutine, public openfile(iu, iout, fname, ftype, fmtarg_opt, accarg_opt, filstat_opt, mode_opt)
Open a file.
Definition: InputOutput.f90:30
inputoutputmodule::urword
subroutine, public urword(line, icol, istart, istop, ncode, n, r, iout, in)
Extract a word from a string.
Definition: InputOutput.f90:421
kindmodule
This module defines variable data types.
Definition: kind.f90:8
lakmodule::lak_activate_density
subroutine lak_activate_density(this)
Activate addition of density terms.
Definition: gwf-lak.f90:6574
lakmodule::lak_cq
subroutine lak_cq(this, x, flowja, iadv)
Calculate flows.
Definition: gwf-lak.f90:4269
lakmodule::lak_read_outlets
subroutine lak_read_outlets(this)
Read the lake outlets for this package.
Definition: gwf-lak.f90:1500
lakmodule::lak_nur
subroutine lak_nur(this, neqpak, x, xtemp, dx, inewtonur, dxmax, locmax)
Apply Newton under-relaxation to the lake stage.
Definition: gwf-lak.f90:3915
lakmodule::lak_vol2stage
subroutine lak_vol2stage(this, ilak, vol, stage)
Determine the stage from a provided volume.
Definition: gwf-lak.f90:2943
lakmodule::lak_calculate_outlet_outflow
subroutine lak_calculate_outlet_outflow(this, ilak, stage, avail, outoutf)
Calculate the outlet outflow from a lake.
Definition: gwf-lak.f90:2719
lakmodule::lak_read_lake_connections
subroutine lak_read_lake_connections(this)
Read the lake connections for this package.
Definition: gwf-lak.f90:782
lakmodule::lak_calculate_sarea
subroutine lak_calculate_sarea(this, ilak, stage, sarea)
Calculate the surface area of a lake at a given stage.
Definition: gwf-lak.f90:2101
lakmodule::lak_fn
subroutine lak_fn(this, rhs, ia, idxglo, matrix_sln)
Fill newton terms.
Definition: gwf-lak.f90:3842
lakmodule::lak_read_tables
subroutine lak_read_tables(this)
Read the lake tables for this package.
Definition: gwf-lak.f90:1095
lakmodule::lak_set_stressperiod
subroutine lak_set_stressperiod(this, itemno)
Set a stress period attribute for lakweslls(itemno) using keywords.
Definition: gwf-lak.f90:3058
lakmodule::lak_ac
subroutine lak_ac(this, moffset, sparse)
Add the lake rows and columns to the sparse matrix.
Definition: gwf-lak.f90:4786
lakmodule::lak_ot_package_flows
subroutine lak_ot_package_flows(this, icbcfl, ibudfl)
Output LAK package flow terms.
Definition: gwf-lak.f90:4412
lakmodule::lak_accumulate_chterm
subroutine lak_accumulate_chterm(this, ilak, rrate, chratin, chratout)
Accumulate constant head terms for budget.
Definition: gwf-lak.f90:5361
lakmodule::lak_get_external_mover
subroutine lak_get_external_mover(this, ilak, outoutf)
Get the mover outflow from a lake to an external boundary.
Definition: gwf-lak.f90:2881
lakmodule::lak_cf
subroutine lak_cf(this)
Formulate the HCOF and RHS terms.
Definition: gwf-lak.f90:3720
lakmodule::lak_calculate_density_exchange
subroutine lak_calculate_density_exchange(this, iconn, stage, head, cond, botl, flow, gwfhcof, gwfrhs)
Calculate the groundwater-lake density exchange terms.
Definition: gwf-lak.f90:6649
lakmodule::lak_calculate_evaporation
subroutine lak_calculate_evaporation(this, ilak, stage, avail, ev)
Calculate the evaporation from a lake at a provided stage subject to an available volume.
Definition: gwf-lak.f90:2671
lakmodule::lak_read_lakes
subroutine lak_read_lakes(this)
Read the dimensions for this package.
Definition: gwf-lak.f90:526
lakmodule::lak_setup_budobj
subroutine lak_setup_budobj(this)
Set up the budget object that stores all the lake flows.
Definition: gwf-lak.f90:6073
lakmodule::lak_calculate_external
subroutine lak_calculate_external(this, ilak, ex)
Calculate the external flow terms to a lake.
Definition: gwf-lak.f90:2633
lakmodule::lak_calculate_warea
subroutine lak_calculate_warea(this, ilak, stage, warea, hin)
Calculate the wetted area of a lake at a given stage.
Definition: gwf-lak.f90:2143
lakmodule::lak_calculate_vol
subroutine lak_calculate_vol(this, ilak, stage, volume)
Calculate the volume of a lake at a given stage.
Definition: gwf-lak.f90:2222
lakmodule::lak_da
subroutine lak_da(this)
Deallocate objects.
Definition: gwf-lak.f90:4537
lakmodule::lak_calculate_storagechange
subroutine lak_calculate_storagechange(this, ilak, stage, stage0, delt, dvr)
Calculate the storage change in a lake based on provided stages and a passed delt.
Definition: gwf-lak.f90:2565
lakmodule::lak_get_internal_outlet
subroutine lak_get_internal_outlet(this, ilak, outoutf)
Get the outlet from a lake to another lake.
Definition: gwf-lak.f90:2843
lakmodule::lak_calculate_conductance
subroutine lak_calculate_conductance(this, ilak, stage, conductance)
Calculate the total conductance for a lake at a provided stage.
Definition: gwf-lak.f90:2275
lakmodule::laktables_to_vectors
subroutine laktables_to_vectors(this, laketables)
Copy the laketables structure data into flattened vectors that are stored in the memory manager.
Definition: gwf-lak.f90:1219
lakmodule::lak_calculate_residual
subroutine lak_calculate_residual(this, n, hlak, resid, headp)
Calculate the residual for a lake given a passed stage.
Definition: gwf-lak.f90:5991
lakmodule::lak_get_outlet_tomover
subroutine lak_get_outlet_tomover(this, ilak, outoutf)
Get the outlet to mover from a lake.
Definition: gwf-lak.f90:2923
lakmodule::lak_allocate_arrays
subroutine lak_allocate_arrays(this)
Allocate scalar members.
Definition: gwf-lak.f90:452
lakmodule::lak_calculate_available
subroutine lak_calculate_available(this, n, hlak, avail, ra, ro, qinf, ex, headp)
Calculate the available volumetric rate for a lake given a passed stage.
Definition: gwf-lak.f90:5927
lakmodule::lak_obs_supported
logical function lak_obs_supported(this)
Procedures related to observations (type-bound)
Definition: gwf-lak.f90:4887
lakmodule::lak_set_pointers
subroutine lak_set_pointers(this, neq, ibound, xnew, xold, flowja)
Set pointers to model arrays and variables so that a package has access to these things.
Definition: gwf-lak.f90:4744
lakmodule::lak_calculate_inflow
subroutine lak_calculate_inflow(this, ilak, qin)
Calculate specified inflow to a lake.
Definition: gwf-lak.f90:2621
lakmodule::lak_calculate_conn_exchange_deriv
subroutine lak_calculate_conn_exchange_deriv(this, ilak, iconn, stage, head, flow, dqds, dqdh)
Lakebed seepage and its derivatives for a connection (IMPLICIT)
Definition: gwf-lak.f90:2485
lakmodule::text
character(len=lenpackagename) text
Definition: gwf-lak.f90:42
lakmodule::lak_mc
subroutine lak_mc(this, moffset, matrix_sln)
Find the matrix position of each lake row and connection.
Definition: gwf-lak.f90:4820
lakmodule::lak_ot_model_flows
subroutine lak_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap)
Write flows to binary file and/or print flows to budget.
Definition: gwf-lak.f90:4438
lakmodule::lak_rp_obs
subroutine lak_rp_obs(this)
Process each observation.
Definition: gwf-lak.f90:5157
lakmodule::lak_calculate_conn_conductance
subroutine lak_calculate_conn_conductance(this, ilak, iconn, stage, head, cond)
Calculate the conductance for a lake connection at a provided stage and groundwater head.
Definition: gwf-lak.f90:2325
lakmodule::lak_calculate_exchange
subroutine lak_calculate_exchange(this, ilak, stage, totflow)
Calculate the total groundwater-lake flow at a provided stage.
Definition: gwf-lak.f90:2391
lakmodule::lak_linear_interpolation
subroutine lak_linear_interpolation(this, n, x, y, z, v)
Perform linear interpolation of two vectors.
Definition: gwf-lak.f90:2056
lakmodule::lak_setup_tableobj
subroutine lak_setup_tableobj(this)
Set up the table object that is used to write the lak stage data.
Definition: gwf-lak.f90:6513
lakmodule::lak_ot_dv
subroutine lak_ot_dv(this, idvsave, idvprint)
Save LAK-calculated values to binary file.
Definition: gwf-lak.f90:4451
lakmodule::lak_options
subroutine lak_options(this, option, found)
Set options specific to LakType.
Definition: gwf-lak.f90:3299
lakmodule::lak_get_external_outlet
subroutine lak_get_external_outlet(this, ilak, outoutf)
Get the outlet outflow from a lake to an external boundary.
Definition: gwf-lak.f90:2862
lakmodule::lak_calculate_rainfall
subroutine lak_calculate_rainfall(this, ilak, stage, ra)
Calculate the rainfall for a lake.
Definition: gwf-lak.f90:2587
lakmodule::lak_get_internal_inlet
subroutine lak_get_internal_inlet(this, ilak, outinf)
Get the outlet inflow to a lake from another lake.
Definition: gwf-lak.f90:2822
lakmodule::lak_cc
subroutine lak_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak)
Final convergence check for package.
Definition: gwf-lak.f90:3957
lakmodule::lak_rp
subroutine lak_rp(this)
Read and Prepare.
Definition: gwf-lak.f90:3517
lakmodule::lak_read_dimensions
subroutine lak_read_dimensions(this)
Read the dimensions for this package.
Definition: gwf-lak.f90:1682
lakmodule::lak_activate_viscosity
subroutine lak_activate_viscosity(this)
Activate viscosity terms.
Definition: gwf-lak.f90:6608
lakmodule::lak_read_initial_attr
subroutine lak_read_initial_attr(this)
Read the initial parameters for this package.
Definition: gwf-lak.f90:1786
lakmodule::lak_check_valid
integer(i4b) function lak_check_valid(this, itemno)
Determine if a valid lake or outlet number has been specified.
Definition: gwf-lak.f90:3024
lakmodule::lak_bisection
subroutine lak_bisection(this, n, ibflg, hlak, temporary_stage, dh, residual)
@ brief Lake package bisection method
Definition: gwf-lak.f90:5878
lakmodule::lak_ad
subroutine lak_ad(this)
Add package connection to matrix.
Definition: gwf-lak.f90:3651
lakmodule::ftype
character(len=lenftype) ftype
Definition: gwf-lak.f90:41
lakmodule::lak_fc
subroutine lak_fc(this, rhs, ia, idxglo, matrix_sln)
Copy rhs and hcof into solution rhs and amat.
Definition: gwf-lak.f90:3801
lakmodule::lak_set_attribute_error
subroutine lak_set_attribute_error(this, ilak, keyword, msg)
Issue a parameter error for lakweslls(ilak)
Definition: gwf-lak.f90:3277
lakmodule::lak_calculate_runoff
subroutine lak_calculate_runoff(this, ilak, ro)
Calculate runoff to a lake.
Definition: gwf-lak.f90:2609
lakmodule::define_listlabel
subroutine define_listlabel(this)
Define the list heading that is written to iout when PRINT_INPUT option is used.
Definition: gwf-lak.f90:4719
lakmodule::lak_read_table
subroutine lak_read_table(this, ilak, filename, laketable)
Read the lake table for this package.
Definition: gwf-lak.f90:1267
lakmodule::lak_calculate_withdrawal
subroutine lak_calculate_withdrawal(this, ilak, avail, wr)
Calculate the withdrawal from a lake subject to an available volume.
Definition: gwf-lak.f90:2649
lakmodule::lak_calculate_conn_warea
subroutine lak_calculate_conn_warea(this, ilak, iconn, stage, head, wa)
Calculate the wetted area of a lake connection at a given stage.
Definition: gwf-lak.f90:2171
lakmodule::lak_solve
subroutine lak_solve(this, update, only_legacy)
Solve for lake stage.
Definition: gwf-lak.f90:5422
lakmodule::lak_estimate_seepage_single
subroutine lak_estimate_seepage_single(this, n, ncnv)
Estimate the lakebed seepage for a single lake.
Definition: gwf-lak.f90:5808
lakmodule::lak_df_obs
subroutine lak_df_obs(this)
Store observation type supported by LAK package. Overrides BndTypebnd_df_obs.
Definition: gwf-lak.f90:4897
lakmodule::lak_allocate_scalars
subroutine lak_allocate_scalars(this)
Allocate scalar members.
Definition: gwf-lak.f90:390
lakmodule::lak_bound_update
subroutine lak_bound_update(this)
Store the lake head and connection conductance in the bound array.
Definition: gwf-lak.f90:5391
lakmodule::lak_calculate_cond_head
subroutine lak_calculate_cond_head(this, iconn, stage, head, vv)
Calculate the controlling lake stage or groundwater head used to calculate the conductance for a lake...
Definition: gwf-lak.f90:2296
lakmodule::lak_ot_bdsummary
subroutine lak_ot_bdsummary(this, kstp, kper, iout, ibudfl)
Write LAK budget to listing file.
Definition: gwf-lak.f90:4522
lakmodule::lak_create
subroutine, public lak_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
Create a new LAK Package and point bndobj to the new package.
Definition: gwf-lak.f90:352
lakmodule::lak_bd_obs
subroutine lak_bd_obs(this)
Calculate observations this time step and call ObsTypeSaveOneSimval for each LakType observation.
Definition: gwf-lak.f90:5002
lakmodule::lak_estimate_conn_exchange
subroutine lak_estimate_conn_exchange(this, iflag, ilak, iconn, idry, stage, head, flow, source, gwfhcof, gwfrhs)
Calculate the groundwater-lake flow at a provided stage and groundwater head.
Definition: gwf-lak.f90:2523
lakmodule::lak_fill_budobj
subroutine lak_fill_budobj(this)
Copy flow terms into thisbudobj.
Definition: gwf-lak.f90:6325
lakmodule::lak_get_internal_mover
subroutine lak_get_internal_mover(this, ilak, outoutf)
Get the mover outflow from a lake to another lake.
Definition: gwf-lak.f90:2902
lakmodule::lak_calculate_outlet_inflow
subroutine lak_calculate_outlet_inflow(this, ilak, outinf)
Calculate the outlet inflow to a lake.
Definition: gwf-lak.f90:2698
lakmodule::lak_outlet_outflow_rate
subroutine lak_outlet_outflow_rate(this, ilak, stage, qout)
Total uncapped outlet outflow rate from a lake at a provided stage.
Definition: gwf-lak.f90:2783
lakmodule::lak_calculate_conn_exchange
subroutine lak_calculate_conn_exchange(this, ilak, iconn, stage, head, flow, gwfhcof, gwfrhs)
Calculate the groundwater-lake flow at a provided stage and groundwater head.
Definition: gwf-lak.f90:2416
lakmodule::lak_ar
subroutine lak_ar(this)
Allocate and Read.
Definition: gwf-lak.f90:3465
lakmodule::lak_solve_single
subroutine lak_solve_single(this, n, iter, maxiter, ncnv, lupdate)
Advance one lake stage by a single substitution iteration.
Definition: gwf-lak.f90:5594
mathutilmodule::is_close
pure logical function, public is_close(a, b, rtol, atol, symmetric)
Check if a real value is approximately equal to another.
Definition: MathUtil.f90:46
memoryhelpermodule::create_mem_path
character(len=lenmempath) function create_mem_path(component, subcomponent, context)
returns the path to the memory object
Definition: MemoryHelper.f90:22
observemodule
This module contains the derived types ObserveType and ObsDataType.
Definition: Observe.f90:15
obsmodule
This module contains the derived type ObsType.
Definition: Obs.f90:127
openspecmodule::access
character(len=20) access
Definition: OpenSpec.f90:7
openspecmodule::form
character(len=20) form
Definition: OpenSpec.f90:7
simmodule
This module contains simulation methods.
Definition: Sim.f90:10
simmodule::store_warning
subroutine, public store_warning(msg, substring)
Store warning message.
Definition: Sim.f90:237
simmodule::store_error
subroutine, public store_error(msg, terminate)
Store an error message.
Definition: Sim.f90:92
simmodule::count_errors
integer(i4b) function, public count_errors()
Return number of errors.
Definition: Sim.f90:59
simmodule::deprecation_warning
subroutine, public deprecation_warning(cblock, cvar, cver, endmsg, iunit)
Store deprecation warning message.
Definition: Sim.f90:257
simmodule::store_error_unit
subroutine, public store_error_unit(iunit, terminate)
Store the file unit number.
Definition: Sim.f90:169
simvariablesmodule
This module contains simulation variables.
Definition: SimVariables.f90:9
simvariablesmodule::errmsg
character(len=maxcharlen) errmsg
error message string
Definition: SimVariables.f90:28
simvariablesmodule::ifailedstepretry
integer(i4b) ifailedstepretry
current retry for this time step
Definition: SimVariables.f90:43
simvariablesmodule::warnmsg
character(len=maxcharlen) warnmsg
warning message string
Definition: SimVariables.f90:29
smoothingmodule::squadraticsaturation
real(dp) function squadraticsaturation(top, bot, x, eps)
@ brief sQuadraticSaturation
Definition: SmoothingFunctions.f90:310
smoothingmodule::squadraticsaturationderivative
real(dp) function squadraticsaturationderivative(top, bot, x, eps)
@ brief Derivative of the quadratic saturation function
Definition: SmoothingFunctions.f90:399
smoothingmodule::sqsaturationderivative
real(dp) function sqsaturationderivative(top, bot, x, c1, c2)
@ brief sQSaturationDerivative
Definition: SmoothingFunctions.f90:501
smoothingmodule::sqsaturation
real(dp) function sqsaturation(top, bot, x, c1, c2)
@ brief sQSaturation
Definition: SmoothingFunctions.f90:447
tablemodule::table_cr
subroutine, public table_cr(this, name, title)
Definition: Table.f90:87
tdismodule::pertim
real(dp), pointer, public pertim
time relative to start of stress period
Definition: tdis.f90:33
tdismodule::totim
real(dp), pointer, public totim
time relative to start of simulation
Definition: tdis.f90:35
tdismodule::kstp
integer(i4b), pointer, public kstp
current time step number
Definition: tdis.f90:27
tdismodule::kper
integer(i4b), pointer, public kper
current stress period number
Definition: tdis.f90:26
tdismodule::delt
real(dp), pointer, public delt
length of the current time step
Definition: tdis.f90:32
tdismodule::nper
integer(i4b), pointer, public nper
number of stress period
Definition: tdis.f90:24
timeseriesmanagermodule::read_value_or_time_series_adv
subroutine, public read_value_or_time_series_adv(textInput, ii, jj, bndElem, pkgName, auxOrBnd, tsManager, iprpak, varName)
Call this subroutine from advanced packages to define timeseries link for a variable (varName).
Definition: TimeSeriesManager.f90:587
bndmodule::bndtype
@ brief BndType
Definition: BoundaryPackage.f90:47