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