MODFLOW 6  version 6.7.0.dev0
USGS Modular Hydrologic Model
gwe-lke.f90
Go to the documentation of this file.
1 ! -- Lake Energy Transport Module
2 ! -- todo: what to do about reactions in lake? Decay?
3 ! -- todo: save the lke temperatures into the lak aux variable?
4 !
5 ! LAK flows (lakbudptr) index var LKT term Transport Type
6 !---------------------------------------------------------------------------------
7 
8 ! -- terms from LAK that will be handled by parent APT Package
9 ! FLOW-JA-FACE idxbudfjf FLOW-JA-FACE cv2cv
10 ! GWF (aux FLOW-AREA) idxbudgwf GWF cv2gwf
11 ! STORAGE (aux VOLUME) idxbudsto none used for cv volumes
12 ! FROM-MVR idxbudfmvr FROM-MVR q * cext = this%qfrommvr(:)
13 ! TO-MVR idxbudtmvr TO-MVR q * cfeat
14 
15 ! -- LAK terms
16 ! RAINFALL idxbudrain RAINFALL q * crain
17 ! EVAPORATION idxbudevap EVAPORATION cfeat<cevap: q*cfeat, else: q*cevap
18 ! RUNOFF idxbudroff RUNOFF q * croff
19 ! EXT-INFLOW idxbudiflw EXT-INFLOW q * ciflw
20 ! WITHDRAWAL idxbudwdrl WITHDRAWAL q * cfeat
21 ! EXT-OUTFLOW idxbudoutf EXT-OUTFLOW q * cfeat
22 ! LAKEBED-COND idxbudlbcd LAKEBED-COND ! kluge note: expression for this
23 
24 ! -- terms from a flow file that should be skipped
25 ! CONSTANT none none none
26 ! AUXILIARY none none none
27 
28 ! -- terms that are written to the transport budget file
29 ! none none STORAGE (aux MASS) dM/dt
30 ! none none AUXILIARY none
31 ! none none CONSTANT accumulate
32 !
33 !
35 
36  use kindmodule, only: dp, i4b
38  use simvariablesmodule, only: errmsg
40  use bndmodule, only: bndtype, getbndfromlist
41  use tspfmimodule, only: tspfmitype
42  use lakmodule, only: laktype
43  use observemodule, only: observetype
48 
49  implicit none
50 
51  public lke_create
52 
53  character(len=*), parameter :: ftype = 'LKE'
54  character(len=*), parameter :: flowtype = 'LAK'
55  character(len=16) :: text = ' LKE'
56 
57  type, extends(tspapttype) :: gwelketype
58 
59  type(gweinputdatatype), pointer :: gwecommon => null() !< pointer to shared gwe data used by multiple packages but set in mst
60 
61  integer(I4B), pointer :: idxbudrain => null() ! index of rainfall terms in flowbudptr
62  integer(I4B), pointer :: idxbudevap => null() ! index of evaporation terms in flowbudptr
63  integer(I4B), pointer :: idxbudroff => null() ! index of runoff terms in flowbudptr
64  integer(I4B), pointer :: idxbudiflw => null() ! index of inflow terms in flowbudptr
65  integer(I4B), pointer :: idxbudwdrl => null() ! index of withdrawal terms in flowbudptr
66  integer(I4B), pointer :: idxbudoutf => null() ! index of outflow terms in flowbudptr
67  integer(I4B), pointer :: idxbudlbcd => null() ! index of lakebed conduction terms in flowbudptr
68 
69  real(dp), dimension(:), pointer, contiguous :: temprain => null() ! rainfall temperature
70  real(dp), dimension(:), pointer, contiguous :: tempevap => null() ! evaporation temperature
71  real(dp), dimension(:), pointer, contiguous :: temproff => null() ! runoff temperature
72  real(dp), dimension(:), pointer, contiguous :: tempiflw => null() ! inflow temperature
73  real(dp), dimension(:), pointer, contiguous :: ktf => null() !< thermal conductivity between the lke and groundwater cell
74  real(dp), dimension(:), pointer, contiguous :: rfeatthk => null() !< thickness of lakebed material through which thermal conduction occurs
75 
76  contains
77 
78  procedure :: bnd_da => lke_da
79  procedure :: allocate_scalars
80  procedure :: apt_allocate_arrays => lke_allocate_arrays
81  procedure :: find_apt_package => find_lke_package
82  procedure :: pak_fc_expanded => lke_fc_expanded
83  procedure :: pak_solve => lke_solve
84  procedure :: pak_get_nbudterms => lke_get_nbudterms
85  procedure :: pak_setup_budobj => lke_setup_budobj
86  procedure :: pak_fill_budobj => lke_fill_budobj
87  procedure :: lke_rain_term
88  procedure :: lke_evap_term
89  procedure :: lke_roff_term
90  procedure :: lke_iflw_term
91  procedure :: lke_wdrl_term
92  procedure :: lke_outf_term
93  procedure :: pak_df_obs => lke_df_obs
94  procedure :: pak_rp_obs => lke_rp_obs
95  procedure :: pak_bd_obs => lke_bd_obs
96  procedure :: pak_set_stressperiod => lke_set_stressperiod
97  procedure :: apt_read_cvs => lke_read_cvs
98 
99  end type gwelketype
100 
101 contains
102 
103  !> @brief Create a new lke package
104  !<
105  subroutine lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, &
106  fmi, eqnsclfac, gwecommon, dvt, dvu, dvua)
107  ! -- dummy
108  class(bndtype), pointer :: packobj
109  integer(I4B), intent(in) :: id
110  integer(I4B), intent(in) :: ibcnum
111  integer(I4B), intent(in) :: inunit
112  integer(I4B), intent(in) :: iout
113  character(len=*), intent(in) :: namemodel
114  character(len=*), intent(in) :: pakname
115  type(tspfmitype), pointer :: fmi
116  real(dp), intent(in), pointer :: eqnsclfac !< governing equation scale factor
117  type(gweinputdatatype), intent(in), target :: gwecommon !< shared data container for use by multiple GWE packages
118  character(len=*), intent(in) :: dvt !< For GWE, set to "TEMPERATURE" in TspAptType
119  character(len=*), intent(in) :: dvu !< For GWE, set to "energy" in TspAptType
120  character(len=*), intent(in) :: dvua !< For GWE, set to "E" in TspAptType
121  ! -- local
122  type(gwelketype), pointer :: lkeobj
123  !
124  ! -- Allocate the object and assign values to object variables
125  allocate (lkeobj)
126  packobj => lkeobj
127  !
128  ! -- Create name and memory path
129  call packobj%set_names(ibcnum, namemodel, pakname, ftype)
130  packobj%text = text
131  !
132  ! -- Allocate scalars
133  call lkeobj%allocate_scalars()
134  !
135  ! -- Initialize package
136  call packobj%pack_initialize()
137  !
138  packobj%inunit = inunit
139  packobj%iout = iout
140  packobj%id = id
141  packobj%ibcnum = ibcnum
142  packobj%ncolbnd = 1
143  packobj%iscloc = 1
144  !
145  ! -- Store pointer to flow model interface. When the GwfGwe exchange is
146  ! created, it sets fmi%bndlist so that the GWE model has access to all
147  ! the flow packages
148  lkeobj%fmi => fmi
149  !
150  ! -- Store pointer to governing equation scale factor
151  lkeobj%eqnsclfac => eqnsclfac
152  !
153  ! -- Store pointer to shared data module for accessing cpw, rhow
154  ! for the budget calculations, and for accessing the latent heat of
155  ! vaporization for evaporative cooling.
156  lkeobj%gwecommon => gwecommon
157  !
158  ! -- Set labels that will be used in generalized APT class
159  lkeobj%depvartype = dvt
160  lkeobj%depvarunit = dvu
161  lkeobj%depvarunitabbrev = dvua
162  end subroutine lke_create
163 
164  !> @brief Find corresponding lke package
165  !<
166  subroutine find_lke_package(this)
167  ! -- modules
169  ! -- dummy
170  class(gwelketype) :: this
171  ! -- local
172  character(len=LINELENGTH) :: errmsg
173  class(bndtype), pointer :: packobj
174  integer(I4B) :: ip, icount
175  integer(I4B) :: nbudterm
176  logical :: found
177  !
178  ! -- Initialize found to false, and error later if flow package cannot
179  ! be found
180  found = .false.
181  !
182  ! -- If user is specifying flows in a binary budget file, then set up
183  ! the budget file reader, otherwise set a pointer to the flow package
184  ! budobj
185  if (this%fmi%flows_from_file) then
186  call this%fmi%set_aptbudobj_pointer(this%flowpackagename, this%flowbudptr)
187  if (associated(this%flowbudptr)) found = .true.
188  !
189  else
190  if (associated(this%fmi%gwfbndlist)) then
191  ! -- Look through gwfbndlist for a flow package with the same name as
192  ! this transport package name
193  do ip = 1, this%fmi%gwfbndlist%Count()
194  packobj => getbndfromlist(this%fmi%gwfbndlist, ip)
195  if (packobj%packName == this%flowpackagename) then
196  found = .true.
197  !
198  ! -- Store BndType pointer to packobj, and then
199  ! use the select type to point to the budobj in flow package
200  this%flowpackagebnd => packobj
201  select type (packobj)
202  type is (laktype)
203  this%flowbudptr => packobj%budobj
204  end select
205  end if
206  if (found) exit
207  end do
208  end if
209  end if
210  !
211  ! -- Error if flow package not found
212  if (.not. found) then
213  write (errmsg, '(a)') 'Could not find flow package with name '&
214  &//trim(adjustl(this%flowpackagename))//'.'
215  call store_error(errmsg)
216  call this%parser%StoreErrorUnit()
217  end if
218  !
219  ! -- Allocate space for idxbudssm, which indicates whether this is a
220  ! special budget term or one that is a general source and sink
221  nbudterm = this%flowbudptr%nbudterm
222  call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%memoryPath)
223  !
224  ! -- Process budget terms and identify special budget terms
225  write (this%iout, '(/, a, a)') &
226  'PROCESSING '//ftype//' INFORMATION FOR ', this%packName
227  write (this%iout, '(a)') ' IDENTIFYING FLOW TERMS IN '//flowtype//' PACKAGE'
228  write (this%iout, '(a, i0)') &
229  ' NUMBER OF '//flowtype//' = ', this%flowbudptr%ncv
230  icount = 1
231  do ip = 1, this%flowbudptr%nbudterm
232  select case (trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)))
233  case ('FLOW-JA-FACE')
234  this%idxbudfjf = ip
235  this%idxbudssm(ip) = 0
236  case ('GWF')
237  this%idxbudgwf = ip
238  this%idxbudlbcd = ip
239  this%idxbudssm(ip) = 0
240  case ('STORAGE')
241  this%idxbudsto = ip
242  this%idxbudssm(ip) = 0
243  case ('RAINFALL')
244  this%idxbudrain = ip
245  this%idxbudssm(ip) = 0
246  case ('EVAPORATION')
247  this%idxbudevap = ip
248  this%idxbudssm(ip) = 0
249  case ('RUNOFF')
250  this%idxbudroff = ip
251  this%idxbudssm(ip) = 0
252  case ('EXT-INFLOW')
253  this%idxbudiflw = ip
254  this%idxbudssm(ip) = 0
255  case ('WITHDRAWAL')
256  this%idxbudwdrl = ip
257  this%idxbudssm(ip) = 0
258  case ('EXT-OUTFLOW')
259  this%idxbudoutf = ip
260  this%idxbudssm(ip) = 0
261  case ('TO-MVR')
262  this%idxbudtmvr = ip
263  this%idxbudssm(ip) = 0
264  case ('FROM-MVR')
265  this%idxbudfmvr = ip
266  this%idxbudssm(ip) = 0
267  case ('AUXILIARY')
268  this%idxbudaux = ip
269  this%idxbudssm(ip) = 0
270  case default
271  !
272  ! -- Set idxbudssm equal to a column index for where the temperatures
273  ! are stored in the tempbud(nbudssm, ncv) array
274  this%idxbudssm(ip) = icount
275  icount = icount + 1
276  end select
277  write (this%iout, '(a, i0, " = ", a,/, a, i0)') &
278  ' TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), &
279  ' MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist
280  end do
281  write (this%iout, '(a, //)') 'DONE PROCESSING '//ftype//' INFORMATION'
282  end subroutine find_lke_package
283 
284  !> @brief Add matrix terms related to LKE
285  !!
286  !! This will be called from TspAptType%apt_fc_expanded()
287  !! in order to add matrix terms specifically for LKE
288  !<
289  subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln)
290  ! -- dummy
291  class(gwelketype) :: this
292  real(DP), dimension(:), intent(inout) :: rhs
293  integer(I4B), dimension(:), intent(in) :: ia
294  integer(I4B), dimension(:), intent(in) :: idxglo
295  class(matrixbasetype), pointer :: matrix_sln
296  ! -- local
297  integer(I4B) :: j, n, n1, n2
298  integer(I4B) :: iloc
299  integer(I4B) :: iposd, iposoffd
300  integer(I4B) :: ipossymd, ipossymoffd
301  integer(I4B) :: auxpos
302  real(DP) :: rrate
303  real(DP) :: rhsval
304  real(DP) :: hcofval
305  real(DP) :: ctherm !< thermal conductance
306  real(DP) :: wa !< wetted area
307  real(DP) :: ktf !< thermal conductivity of streambed material
308  real(DP) :: s !< thickness of conductive streambed material
309  !
310  ! -- Add rainfall contribution
311  if (this%idxbudrain /= 0) then
312  do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist
313  call this%lke_rain_term(j, n1, n2, rrate, rhsval, hcofval)
314  iloc = this%idxlocnode(n1)
315  iposd = this%idxpakdiag(n1)
316  call matrix_sln%add_value_pos(iposd, hcofval)
317  rhs(iloc) = rhs(iloc) + rhsval
318  end do
319  end if
320  !
321  ! -- Add evaporation contribution
322  if (this%idxbudevap /= 0) then
323  do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist
324  call this%lke_evap_term(j, n1, n2, rrate, rhsval, hcofval)
325  iloc = this%idxlocnode(n1)
326  iposd = this%idxpakdiag(n1)
327  call matrix_sln%add_value_pos(iposd, hcofval)
328  rhs(iloc) = rhs(iloc) + rhsval
329  end do
330  end if
331  !
332  ! -- Add runoff contribution
333  if (this%idxbudroff /= 0) then
334  do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist
335  call this%lke_roff_term(j, n1, n2, rrate, rhsval, hcofval)
336  iloc = this%idxlocnode(n1)
337  iposd = this%idxpakdiag(n1)
338  call matrix_sln%add_value_pos(iposd, hcofval)
339  rhs(iloc) = rhs(iloc) + rhsval
340  end do
341  end if
342  !
343  ! -- Add inflow contribution
344  if (this%idxbudiflw /= 0) then
345  do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist
346  call this%lke_iflw_term(j, n1, n2, rrate, rhsval, hcofval)
347  iloc = this%idxlocnode(n1)
348  iposd = this%idxpakdiag(n1)
349  call matrix_sln%add_value_pos(iposd, hcofval)
350  rhs(iloc) = rhs(iloc) + rhsval
351  end do
352  end if
353  !
354  ! -- Add withdrawal contribution
355  if (this%idxbudwdrl /= 0) then
356  do j = 1, this%flowbudptr%budterm(this%idxbudwdrl)%nlist
357  call this%lke_wdrl_term(j, n1, n2, rrate, rhsval, hcofval)
358  iloc = this%idxlocnode(n1)
359  iposd = this%idxpakdiag(n1)
360  call matrix_sln%add_value_pos(iposd, hcofval)
361  rhs(iloc) = rhs(iloc) + rhsval
362  end do
363  end if
364  !
365  ! -- Add outflow contribution
366  if (this%idxbudoutf /= 0) then
367  do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist
368  call this%lke_outf_term(j, n1, n2, rrate, rhsval, hcofval)
369  iloc = this%idxlocnode(n1)
370  iposd = this%idxpakdiag(n1)
371  call matrix_sln%add_value_pos(iposd, hcofval)
372  rhs(iloc) = rhs(iloc) + rhsval
373  end do
374  end if
375  !
376  ! -- Add lakebed conduction contribution
377  do j = 1, this%flowbudptr%budterm(this%idxbudgwf)%nlist
378  !
379  ! -- Set n to feature number and process if active feature
380  n = this%flowbudptr%budterm(this%idxbudgwf)%id1(j)
381  if (this%iboundpak(n) /= 0) then
382  !
383  ! -- Set acoef and rhs to negative so they are relative to sfe and not gwe
384  auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux
385  wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j)
386  ktf = this%ktf(n)
387  s = this%rfeatthk(n)
388  ctherm = ktf * wa / s
389  !
390  ! -- Add to sfe row
391  iposd = this%idxdglo(j)
392  iposoffd = this%idxoffdglo(j)
393  call matrix_sln%add_value_pos(iposd, -ctherm) ! kluge note: make sure the signs on ctherm are correct here and below
394  call matrix_sln%add_value_pos(iposoffd, ctherm)
395  !
396  ! -- Add to gwe row for sfe connection
397  ipossymd = this%idxsymdglo(j)
398  ipossymoffd = this%idxsymoffdglo(j)
399  call matrix_sln%add_value_pos(ipossymd, -ctherm)
400  call matrix_sln%add_value_pos(ipossymoffd, ctherm)
401  end if
402  end do
403  end subroutine lke_fc_expanded
404 
405  !> @brief Add terms specific to lakes to the explicit lake solve
406  !<
407  subroutine lke_solve(this)
408  ! -- dummy
409  class(gwelketype) :: this
410  ! -- local
411  integer(I4B) :: j
412  integer(I4B) :: n1, n2
413  real(DP) :: rrate
414  !
415  ! -- Add rainfall contribution
416  if (this%idxbudrain /= 0) then
417  do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist
418  call this%lke_rain_term(j, n1, n2, rrate)
419  this%dbuff(n1) = this%dbuff(n1) + rrate
420  end do
421  end if
422  !
423  ! -- Add evaporation contribution
424  if (this%idxbudevap /= 0) then
425  do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist
426  call this%lke_evap_term(j, n1, n2, rrate)
427  this%dbuff(n1) = this%dbuff(n1) + rrate
428  end do
429  end if
430  !
431  ! -- Add runoff contribution
432  if (this%idxbudroff /= 0) then
433  do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist
434  call this%lke_roff_term(j, n1, n2, rrate)
435  this%dbuff(n1) = this%dbuff(n1) + rrate
436  end do
437  end if
438  !
439  ! -- Add inflow contribution
440  if (this%idxbudiflw /= 0) then
441  do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist
442  call this%lke_iflw_term(j, n1, n2, rrate)
443  this%dbuff(n1) = this%dbuff(n1) + rrate
444  end do
445  end if
446  !
447  ! -- Add withdrawal contribution
448  if (this%idxbudwdrl /= 0) then
449  do j = 1, this%flowbudptr%budterm(this%idxbudwdrl)%nlist
450  call this%lke_wdrl_term(j, n1, n2, rrate)
451  this%dbuff(n1) = this%dbuff(n1) + rrate
452  end do
453  end if
454  !
455  ! -- Add outflow contribution
456  if (this%idxbudoutf /= 0) then
457  do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist
458  call this%lke_outf_term(j, n1, n2, rrate)
459  this%dbuff(n1) = this%dbuff(n1) + rrate
460  end do
461  end if
462  end subroutine lke_solve
463 
464  !> @brief Function to return the number of budget terms just for this package.
465  !!
466  !! This overrides a function in the parent class.
467  !<
468  function lke_get_nbudterms(this) result(nbudterms)
469  ! -- dummy
470  class(gwelketype) :: this
471  ! -- Return
472  integer(I4B) :: nbudterms
473  !
474  ! -- Number of budget terms is 7
475  ! 1) rainfall
476  ! 2) evap
477  ! 3) runoff
478  ! 4) ext-inflow
479  ! 5) withdrawal
480  ! 6) ext-outflow
481  ! 7) lakebed-cond
482  !
483  nbudterms = 7
484  end function lke_get_nbudterms
485 
486  !> @brief Set up the budget object that stores all the lake flows
487  !<
488  subroutine lke_setup_budobj(this, idx)
489  ! -- modules
490  use constantsmodule, only: lenbudtxt
491  ! -- dummy
492  class(gwelketype) :: this
493  integer(I4B), intent(inout) :: idx
494  ! -- local
495  integer(I4B) :: n, n1, n2
496  integer(I4B) :: maxlist, naux
497  real(DP) :: q
498  character(len=LENBUDTXT) :: text
499  !
500  ! -- Addition of heat associated with rainfall directly on the lake surface
501  text = ' RAINFALL'
502  idx = idx + 1
503  maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist
504  naux = 0
505  call this%budobj%budterm(idx)%initialize(text, &
506  this%name_model, &
507  this%packName, &
508  this%name_model, &
509  this%packName, &
510  maxlist, .false., .false., &
511  naux)
512  !
513  ! -- Evaporative cooling from lake surface
514  text = ' EVAPORATION'
515  idx = idx + 1
516  maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist
517  naux = 0
518  call this%budobj%budterm(idx)%initialize(text, &
519  this%name_model, &
520  this%packName, &
521  this%name_model, &
522  this%packName, &
523  maxlist, .false., .false., &
524  naux)
525  !
526  ! -- Addition of heat associated with runoff that flows to the lake
527  text = ' RUNOFF'
528  idx = idx + 1
529  maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist
530  naux = 0
531  call this%budobj%budterm(idx)%initialize(text, &
532  this%name_model, &
533  this%packName, &
534  this%name_model, &
535  this%packName, &
536  maxlist, .false., .false., &
537  naux)
538  !
539  ! -- Addition of heat associated with user-specified inflow to the lake
540  text = ' EXT-INFLOW'
541  idx = idx + 1
542  maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist
543  naux = 0
544  call this%budobj%budterm(idx)%initialize(text, &
545  this%name_model, &
546  this%packName, &
547  this%name_model, &
548  this%packName, &
549  maxlist, .false., .false., &
550  naux)
551  !
552  ! -- Removal of heat associated with user-specified withdrawal from lake
553  text = ' WITHDRAWAL'
554  idx = idx + 1
555  maxlist = this%flowbudptr%budterm(this%idxbudwdrl)%maxlist
556  naux = 0
557  call this%budobj%budterm(idx)%initialize(text, &
558  this%name_model, &
559  this%packName, &
560  this%name_model, &
561  this%packName, &
562  maxlist, .false., .false., &
563  naux)
564  !
565  ! -- Removal of heat associated with outflow from lake that leaves
566  ! model domain
567  text = ' EXT-OUTFLOW'
568  idx = idx + 1
569  maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist
570  naux = 0
571  call this%budobj%budterm(idx)%initialize(text, &
572  this%name_model, &
573  this%packName, &
574  this%name_model, &
575  this%packName, &
576  maxlist, .false., .false., &
577  naux)
578  !
579  ! -- Conductive exchange of heat through the wetted lakebed
580  text = ' LAKEBED-COND'
581  idx = idx + 1
582  maxlist = this%flowbudptr%budterm(this%idxbudlbcd)%maxlist
583  naux = 0
584  call this%budobj%budterm(idx)%initialize(text, &
585  this%name_model, &
586  this%packName, &
587  this%name_model, &
588  this%packName, &
589  maxlist, .false., .false., &
590  naux)
591  call this%budobj%budterm(idx)%reset(maxlist)
592  q = dzero
593  do n = 1, maxlist
594  n1 = this%flowbudptr%budterm(this%idxbudgwf)%id1(n)
595  n2 = this%flowbudptr%budterm(this%idxbudgwf)%id2(n)
596  call this%budobj%budterm(idx)%update_term(n1, n2, q)
597  end do
598  end subroutine lke_setup_budobj
599 
600  !> @brief Copy flow terms into this%budobj
601  !<
602  subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout)
603  ! -- dummy
604  class(gwelketype) :: this
605  integer(I4B), intent(inout) :: idx
606  real(DP), dimension(:), intent(in) :: x
607  real(DP), dimension(:), contiguous, intent(inout) :: flowja
608  real(DP), intent(inout) :: ccratin
609  real(DP), intent(inout) :: ccratout
610  ! -- local
611  integer(I4B) :: j, n1, n2
612  integer(I4B) :: nlist
613  integer(I4B) :: igwfnode
614  integer(I4B) :: idiag
615  integer(I4B) :: auxpos
616  real(DP) :: q
617  real(DP) :: ctherm !< thermal conductance
618  real(DP) :: wa !< wetted area
619  real(DP) :: ktf !< thermal conductivity of streambed material
620  real(DP) :: s !< thickness of conductive streambed materia
621  !
622  ! -- Rain
623  idx = idx + 1
624  nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist
625  call this%budobj%budterm(idx)%reset(nlist)
626  do j = 1, nlist
627  call this%lke_rain_term(j, n1, n2, q)
628  call this%budobj%budterm(idx)%update_term(n1, n2, q)
629  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
630  end do
631  !
632  ! -- Evaporation
633  idx = idx + 1
634  nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist
635  call this%budobj%budterm(idx)%reset(nlist)
636  do j = 1, nlist
637  call this%lke_evap_term(j, n1, n2, q)
638  call this%budobj%budterm(idx)%update_term(n1, n2, q)
639  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
640  end do
641  !
642  ! -- Runoff
643  idx = idx + 1
644  nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist
645  call this%budobj%budterm(idx)%reset(nlist)
646  do j = 1, nlist
647  call this%lke_roff_term(j, n1, n2, q)
648  call this%budobj%budterm(idx)%update_term(n1, n2, q)
649  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
650  end do
651  !
652  ! -- Est-Inflow
653  idx = idx + 1
654  nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist
655  call this%budobj%budterm(idx)%reset(nlist)
656  do j = 1, nlist
657  call this%lke_iflw_term(j, n1, n2, q)
658  call this%budobj%budterm(idx)%update_term(n1, n2, q)
659  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
660  end do
661  !
662  ! -- Withdrawal
663  idx = idx + 1
664  nlist = this%flowbudptr%budterm(this%idxbudwdrl)%nlist
665  call this%budobj%budterm(idx)%reset(nlist)
666  do j = 1, nlist
667  call this%lke_wdrl_term(j, n1, n2, q)
668  call this%budobj%budterm(idx)%update_term(n1, n2, q)
669  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
670  end do
671  !
672  ! -- Ext-Outflow
673  idx = idx + 1
674  nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist
675  call this%budobj%budterm(idx)%reset(nlist)
676  do j = 1, nlist
677  call this%lke_outf_term(j, n1, n2, q)
678  call this%budobj%budterm(idx)%update_term(n1, n2, q)
679  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
680  end do
681  !
682  ! -- Lakebed-Cond
683  idx = idx + 1
684  call this%budobj%budterm(idx)%reset(this%maxbound)
685  do j = 1, this%flowbudptr%budterm(this%idxbudlbcd)%nlist
686  q = dzero
687  n1 = this%flowbudptr%budterm(this%idxbudlbcd)%id1(j)
688  if (this%iboundpak(n1) /= 0) then
689  igwfnode = this%flowbudptr%budterm(this%idxbudlbcd)%id2(j)
690  auxpos = this%flowbudptr%budterm(this%idxbudgwf)%naux ! for now there is only 1 aux variable under 'GWF'
691  wa = this%flowbudptr%budterm(this%idxbudgwf)%auxvar(auxpos, j)
692  ktf = this%ktf(n1)
693  s = this%rfeatthk(n1)
694  ctherm = ktf * wa / s
695  q = ctherm * (x(igwfnode) - this%xnewpak(n1))
696  end if
697  call this%budobj%budterm(idx)%update_term(n1, igwfnode, q)
698  call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
699  if (this%iboundpak(n1) /= 0) then
700  ! -- Contribution to gwe cell budget
701  this%simvals(n1) = this%simvals(n1) - q
702  idiag = this%dis%con%ia(igwfnode)
703  flowja(idiag) = flowja(idiag) - q
704  end if
705  end do
706  end subroutine lke_fill_budobj
707 
708  !> @brief Allocate scalars specific to the lake energy transport (LKE)
709  !! package.
710  !<
711  subroutine allocate_scalars(this)
712  ! -- modules
714  ! -- dummy
715  class(gwelketype) :: this
716  !
717  ! -- Allocate scalars in TspAptType
718  call this%TspAptType%allocate_scalars()
719  !
720  ! -- Allocate
721  call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%memoryPath)
722  call mem_allocate(this%idxbudevap, 'IDXBUDEVAP', this%memoryPath)
723  call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%memoryPath)
724  call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%memoryPath)
725  call mem_allocate(this%idxbudwdrl, 'IDXBUDWDRL', this%memoryPath)
726  call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%memoryPath)
727  call mem_allocate(this%idxbudlbcd, 'IDXBUDLBCD', this%memoryPath)
728  !
729  ! -- Initialize
730  this%idxbudrain = 0
731  this%idxbudevap = 0
732  this%idxbudroff = 0
733  this%idxbudiflw = 0
734  this%idxbudwdrl = 0
735  this%idxbudoutf = 0
736  this%idxbudlbcd = 0
737  end subroutine allocate_scalars
738 
739  !> @brief Allocate arrays specific to the lake energy transport (LKE)
740  !! package.
741  !<
742  subroutine lke_allocate_arrays(this)
743  ! -- modules
745  ! -- dummy
746  class(gwelketype), intent(inout) :: this
747  ! -- local
748  integer(I4B) :: n
749  !
750  ! -- Time series
751  call mem_allocate(this%temprain, this%ncv, 'TEMPRAIN', this%memoryPath)
752  call mem_allocate(this%tempevap, this%ncv, 'TEMPEVAP', this%memoryPath)
753  call mem_allocate(this%temproff, this%ncv, 'TEMPROFF', this%memoryPath)
754  call mem_allocate(this%tempiflw, this%ncv, 'TEMPIFLW', this%memoryPath)
755  !
756  ! -- Call standard TspAptType allocate arrays
757  call this%TspAptType%apt_allocate_arrays()
758  !
759  ! -- Initialize
760  do n = 1, this%ncv
761  this%temprain(n) = dzero
762  this%tempevap(n) = dzero
763  this%temproff(n) = dzero
764  this%tempiflw(n) = dzero
765  end do
766  !
767  end subroutine lke_allocate_arrays
768 
769  !> @brief Deallocate memory
770  !<
771  subroutine lke_da(this)
772  ! -- modules
774  ! -- dummy
775  class(gwelketype) :: this
776  !
777  ! -- Deallocate scalars
778  call mem_deallocate(this%idxbudrain)
779  call mem_deallocate(this%idxbudevap)
780  call mem_deallocate(this%idxbudroff)
781  call mem_deallocate(this%idxbudiflw)
782  call mem_deallocate(this%idxbudwdrl)
783  call mem_deallocate(this%idxbudoutf)
784  call mem_deallocate(this%idxbudlbcd)
785  !
786  ! -- Deallocate time series
787  call mem_deallocate(this%temprain)
788  call mem_deallocate(this%tempevap)
789  call mem_deallocate(this%temproff)
790  call mem_deallocate(this%tempiflw)
791  !
792  ! -- Deallocate arrays
793  call mem_deallocate(this%ktf)
794  call mem_deallocate(this%rfeatthk)
795  !
796  ! -- Deallocate scalars in TspAptType
797  call this%TspAptType%bnd_da()
798  end subroutine lke_da
799 
800  !> @brief Rain term
801  !<
802  subroutine lke_rain_term(this, ientry, n1, n2, rrate, &
803  rhsval, hcofval)
804  ! -- dummy
805  class(gwelketype) :: this
806  integer(I4B), intent(in) :: ientry
807  integer(I4B), intent(inout) :: n1
808  integer(I4B), intent(inout) :: n2
809  real(DP), intent(inout), optional :: rrate
810  real(DP), intent(inout), optional :: rhsval
811  real(DP), intent(inout), optional :: hcofval
812  ! -- local
813  real(DP) :: qbnd
814  real(DP) :: ctmp
815  !
816  n1 = this%flowbudptr%budterm(this%idxbudrain)%id1(ientry)
817  n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry)
818  qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry)
819  ctmp = this%temprain(n1)
820  if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac
821  if (present(rhsval)) rhsval = -rrate
822  if (present(hcofval)) hcofval = dzero
823  end subroutine lke_rain_term
824 
825  !> @brief Evaporative term
826  !<
827  subroutine lke_evap_term(this, ientry, n1, n2, rrate, &
828  rhsval, hcofval)
829  ! -- dummy
830  class(gwelketype) :: this
831  integer(I4B), intent(in) :: ientry
832  integer(I4B), intent(inout) :: n1
833  integer(I4B), intent(inout) :: n2
834  real(DP), intent(inout), optional :: rrate
835  real(DP), intent(inout), optional :: rhsval
836  real(DP), intent(inout), optional :: hcofval
837  ! -- local
838  real(DP) :: qbnd
839  real(DP) :: heatlat
840  !
841  n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry)
842  n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry)
843  ! -- Note that qbnd is negative for evap
844  qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry)
845  heatlat = this%gwecommon%gwerhow * this%gwecommon%gwelatheatvap
846  if (present(rrate)) rrate = qbnd * heatlat
847  if (present(rhsval)) rhsval = -rrate
848  if (present(hcofval)) hcofval = dzero
849  end subroutine lke_evap_term
850 
851  !> @brief Runoff term
852  !<
853  subroutine lke_roff_term(this, ientry, n1, n2, rrate, &
854  rhsval, hcofval)
855  ! -- dummy
856  class(gwelketype) :: this
857  integer(I4B), intent(in) :: ientry
858  integer(I4B), intent(inout) :: n1
859  integer(I4B), intent(inout) :: n2
860  real(DP), intent(inout), optional :: rrate
861  real(DP), intent(inout), optional :: rhsval
862  real(DP), intent(inout), optional :: hcofval
863  ! -- local
864  real(DP) :: qbnd
865  real(DP) :: ctmp
866  !
867  n1 = this%flowbudptr%budterm(this%idxbudroff)%id1(ientry)
868  n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry)
869  qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry)
870  ctmp = this%temproff(n1)
871  if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac
872  if (present(rhsval)) rhsval = -rrate
873  if (present(hcofval)) hcofval = dzero
874  end subroutine lke_roff_term
875 
876  !> @brief Inflow Term
877  !!
878  !! Accounts for energy flowing into a lake from a connected stream, for
879  !! example.
880  !<
881  subroutine lke_iflw_term(this, ientry, n1, n2, rrate, &
882  rhsval, hcofval)
883  ! -- dummy
884  class(gwelketype) :: this
885  integer(I4B), intent(in) :: ientry
886  integer(I4B), intent(inout) :: n1
887  integer(I4B), intent(inout) :: n2
888  real(DP), intent(inout), optional :: rrate
889  real(DP), intent(inout), optional :: rhsval
890  real(DP), intent(inout), optional :: hcofval
891  ! -- local
892  real(DP) :: qbnd
893  real(DP) :: ctmp
894  !
895  n1 = this%flowbudptr%budterm(this%idxbudiflw)%id1(ientry)
896  n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry)
897  qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry)
898  ctmp = this%tempiflw(n1)
899  if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac
900  if (present(rhsval)) rhsval = -rrate
901  if (present(hcofval)) hcofval = dzero
902  end subroutine lke_iflw_term
903 
904  !> @brief Specified withdrawal term
905  !!
906  !! Accounts for energy associated with a withdrawal of water from a lake
907  !! or group of lakes.
908  !<
909  subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, &
910  rhsval, hcofval)
911  ! -- dummy
912  class(gwelketype) :: this
913  integer(I4B), intent(in) :: ientry
914  integer(I4B), intent(inout) :: n1
915  integer(I4B), intent(inout) :: n2
916  real(DP), intent(inout), optional :: rrate
917  real(DP), intent(inout), optional :: rhsval
918  real(DP), intent(inout), optional :: hcofval
919  ! -- local
920  real(DP) :: qbnd
921  real(DP) :: ctmp
922  !
923  n1 = this%flowbudptr%budterm(this%idxbudwdrl)%id1(ientry)
924  n2 = this%flowbudptr%budterm(this%idxbudwdrl)%id2(ientry)
925  qbnd = this%flowbudptr%budterm(this%idxbudwdrl)%flow(ientry)
926  ctmp = this%xnewpak(n1)
927  if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac
928  if (present(rhsval)) rhsval = dzero
929  if (present(hcofval)) hcofval = qbnd * this%eqnsclfac
930  end subroutine lke_wdrl_term
931 
932  !> @brief Outflow term
933  !!
934  !! Accounts for the energy leaving a lake, for example, energy exiting a
935  !! lake via a flow into a draining stream channel.
936  !<
937  subroutine lke_outf_term(this, ientry, n1, n2, rrate, &
938  rhsval, hcofval)
939  ! -- dummy
940  class(gwelketype) :: this
941  integer(I4B), intent(in) :: ientry
942  integer(I4B), intent(inout) :: n1
943  integer(I4B), intent(inout) :: n2
944  real(DP), intent(inout), optional :: rrate
945  real(DP), intent(inout), optional :: rhsval
946  real(DP), intent(inout), optional :: hcofval
947  ! -- local
948  real(DP) :: qbnd
949  real(DP) :: ctmp
950  !
951  n1 = this%flowbudptr%budterm(this%idxbudoutf)%id1(ientry)
952  n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry)
953  qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry)
954  ctmp = this%xnewpak(n1)
955  if (present(rrate)) rrate = ctmp * qbnd * this%eqnsclfac
956  if (present(rhsval)) rhsval = dzero
957  if (present(hcofval)) hcofval = qbnd * this%eqnsclfac
958  end subroutine lke_outf_term
959 
960  !> @brief Defined observation types
961  !!
962  !! Store the observation type supported by the APT package and override
963  !! BndType%bnd_df_obs
964  !<
965  subroutine lke_df_obs(this)
966  ! -- dummy
967  class(gwelketype) :: this
968  ! -- local
969  integer(I4B) :: indx
970  !
971  ! -- Store obs type and assign procedure pointer
972  ! for temperature observation type.
973  call this%obs%StoreObsType('temperature', .false., indx)
974  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
975  !
976  ! -- Store obs type and assign procedure pointer
977  ! for flow between features, such as lake to lake.
978  call this%obs%StoreObsType('flow-ja-face', .true., indx)
979  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid12
980  !
981  ! -- Store obs type and assign procedure pointer
982  ! for from-mvr observation type.
983  call this%obs%StoreObsType('from-mvr', .true., indx)
984  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
985  !
986  ! -- Store obs type and assign procedure pointer
987  ! for to-mvr observation type.
988  call this%obs%StoreObsType('to-mvr', .true., indx)
989  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
990  !
991  ! -- Store obs type and assign procedure pointer
992  ! for storage observation type.
993  call this%obs%StoreObsType('storage', .true., indx)
994  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
995  !
996  ! -- Store obs type and assign procedure pointer
997  ! for constant observation type.
998  call this%obs%StoreObsType('constant', .true., indx)
999  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1000  !
1001  ! -- Store obs type and assign procedure pointer
1002  ! for observation type: lke
1003  call this%obs%StoreObsType('lke', .true., indx)
1004  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1005  !
1006  ! -- Store obs type and assign procedure pointer
1007  ! for rainfall observation type.
1008  call this%obs%StoreObsType('rainfall', .true., indx)
1009  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1010  !
1011  ! -- Store obs type and assign procedure pointer
1012  ! for evaporation observation type.
1013  call this%obs%StoreObsType('evaporation', .true., indx)
1014  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1015  !
1016  ! -- Store obs type and assign procedure pointer
1017  ! for runoff observation type.
1018  call this%obs%StoreObsType('runoff', .true., indx)
1019  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1020  !
1021  ! -- Store obs type and assign procedure pointer
1022  ! for inflow observation type.
1023  call this%obs%StoreObsType('ext-inflow', .true., indx)
1024  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1025  !
1026  ! -- Store obs type and assign procedure pointer
1027  ! for withdrawal observation type.
1028  call this%obs%StoreObsType('withdrawal', .true., indx)
1029  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1030  !
1031  ! -- Store obs type and assign procedure pointer
1032  ! for ext-outflow observation type.
1033  call this%obs%StoreObsType('ext-outflow', .true., indx)
1034  this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsid
1035  end subroutine lke_df_obs
1036 
1037  !> @brief Process package specific obs
1038  !!
1039  !! Method to process specific observations for this package.
1040  !<
1041  subroutine lke_rp_obs(this, obsrv, found)
1042  ! -- dummy
1043  class(gwelketype), intent(inout) :: this !< package class
1044  type(observetype), intent(inout) :: obsrv !< observation object
1045  logical, intent(inout) :: found !< indicate whether observation was found
1046  !
1047  found = .true.
1048  select case (obsrv%ObsTypeId)
1049  case ('RAINFALL')
1050  call this%rp_obs_byfeature(obsrv)
1051  case ('EVAPORATION')
1052  call this%rp_obs_byfeature(obsrv)
1053  case ('RUNOFF')
1054  call this%rp_obs_byfeature(obsrv)
1055  case ('EXT-INFLOW')
1056  call this%rp_obs_byfeature(obsrv)
1057  case ('WITHDRAWAL')
1058  call this%rp_obs_byfeature(obsrv)
1059  case ('EXT-OUTFLOW')
1060  call this%rp_obs_byfeature(obsrv)
1061  case ('TO-MVR')
1062  call this%rp_obs_budterm(obsrv, &
1063  this%flowbudptr%budterm(this%idxbudtmvr))
1064  case default
1065  found = .false.
1066  end select
1067  end subroutine lke_rp_obs
1068 
1069  !> @brief Calculate observation value and pass it back to APT
1070  !<
1071  subroutine lke_bd_obs(this, obstypeid, jj, v, found)
1072  ! -- dummy
1073  class(gwelketype), intent(inout) :: this
1074  character(len=*), intent(in) :: obstypeid
1075  real(DP), intent(inout) :: v
1076  integer(I4B), intent(in) :: jj
1077  logical, intent(inout) :: found
1078  ! -- local
1079  integer(I4B) :: n1, n2
1080  !
1081  found = .true.
1082  select case (obstypeid)
1083  case ('RAINFALL')
1084  if (this%iboundpak(jj) /= 0) then
1085  call this%lke_rain_term(jj, n1, n2, v)
1086  end if
1087  case ('EVAPORATION')
1088  if (this%iboundpak(jj) /= 0) then
1089  call this%lke_evap_term(jj, n1, n2, v)
1090  end if
1091  case ('RUNOFF')
1092  if (this%iboundpak(jj) /= 0) then
1093  call this%lke_roff_term(jj, n1, n2, v)
1094  end if
1095  case ('EXT-INFLOW')
1096  if (this%iboundpak(jj) /= 0) then
1097  call this%lke_iflw_term(jj, n1, n2, v)
1098  end if
1099  case ('WITHDRAWAL')
1100  if (this%iboundpak(jj) /= 0) then
1101  call this%lke_wdrl_term(jj, n1, n2, v)
1102  end if
1103  case ('EXT-OUTFLOW')
1104  if (this%iboundpak(jj) /= 0) then
1105  call this%lke_outf_term(jj, n1, n2, v)
1106  end if
1107  case default
1108  found = .false.
1109  end select
1110  end subroutine lke_bd_obs
1111 
1112  !> @brief Sets the stress period attributes for keyword use.
1113  !<
1114  subroutine lke_set_stressperiod(this, itemno, keyword, found)
1115  ! -- modules
1117  ! -- dummy
1118  class(gwelketype), intent(inout) :: this
1119  integer(I4B), intent(in) :: itemno
1120  character(len=*), intent(in) :: keyword
1121  logical, intent(inout) :: found
1122  ! -- local
1123  character(len=LINELENGTH) :: text
1124  integer(I4B) :: ierr
1125  integer(I4B) :: jj
1126  real(DP), pointer :: bndElem => null()
1127  !
1128  ! RAINFALL <rainfall>
1129  ! EVAPORATION <evaporation>
1130  ! RUNOFF <runoff>
1131  ! EXT-INFLOW <inflow>
1132  ! WITHDRAWAL <withdrawal>
1133  !
1134  found = .true.
1135  select case (keyword)
1136  case ('RAINFALL')
1137  ierr = this%apt_check_valid(itemno)
1138  if (ierr /= 0) then
1139  goto 999
1140  end if
1141  call this%parser%GetString(text)
1142  jj = 1
1143  bndelem => this%temprain(itemno)
1144  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
1145  this%packName, 'BND', this%tsManager, &
1146  this%iprpak, 'RAINFALL')
1147  case ('EVAPORATION')
1148  ierr = this%apt_check_valid(itemno)
1149  if (ierr /= 0) then
1150  goto 999
1151  end if
1152  call this%parser%GetString(text)
1153  jj = 1
1154  bndelem => this%tempevap(itemno)
1155  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
1156  this%packName, 'BND', this%tsManager, &
1157  this%iprpak, 'EVAPORATION')
1158  case ('RUNOFF')
1159  ierr = this%apt_check_valid(itemno)
1160  if (ierr /= 0) then
1161  goto 999
1162  end if
1163  call this%parser%GetString(text)
1164  jj = 1
1165  bndelem => this%temproff(itemno)
1166  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
1167  this%packName, 'BND', this%tsManager, &
1168  this%iprpak, 'RUNOFF')
1169  case ('EXT-INFLOW')
1170  ierr = this%apt_check_valid(itemno)
1171  if (ierr /= 0) then
1172  goto 999
1173  end if
1174  call this%parser%GetString(text)
1175  jj = 1
1176  bndelem => this%tempiflw(itemno)
1177  call read_value_or_time_series_adv(text, itemno, jj, bndelem, &
1178  this%packName, 'BND', this%tsManager, &
1179  this%iprpak, 'EXT-INFLOW')
1180  case default
1181  !
1182  ! -- Keyword not recognized so return to caller with found = .false.
1183  found = .false.
1184  end select
1185  !
1186 999 continue
1187  end subroutine lke_set_stressperiod
1188 
1189  !> @brief Read feature information for this advanced package
1190  !<
1191  subroutine lke_read_cvs(this)
1192  ! -- modules
1195  ! -- dummy
1196  class(gwelketype), intent(inout) :: this
1197  ! -- local
1198  character(len=LINELENGTH) :: text
1199  character(len=LENBOUNDNAME) :: bndName, bndNameTemp
1200  character(len=9) :: cno
1201  character(len=50), dimension(:), allocatable :: caux
1202  integer(I4B) :: ierr
1203  logical :: isfound, endOfBlock
1204  integer(I4B) :: n
1205  integer(I4B) :: ii, jj
1206  integer(I4B) :: iaux
1207  integer(I4B) :: itmp
1208  integer(I4B) :: nlak
1209  integer(I4B) :: nconn
1210  integer(I4B), dimension(:), pointer, contiguous :: nboundchk
1211  real(DP), pointer :: bndElem => null()
1212  !
1213  ! -- initialize itmp
1214  itmp = 0
1215  !
1216  ! -- allocate apt data
1217  call mem_allocate(this%strt, this%ncv, 'STRT', this%memoryPath)
1218  call mem_allocate(this%ktf, this%ncv, 'KTF', this%memoryPath)
1219  call mem_allocate(this%rfeatthk, this%ncv, 'RFEATTHK', this%memoryPath)
1220  call mem_allocate(this%lauxvar, this%naux, this%ncv, 'LAUXVAR', &
1221  this%memoryPath)
1222  !
1223  ! -- lake boundary and concentrations
1224  if (this%imatrows == 0) then
1225  call mem_allocate(this%iboundpak, this%ncv, 'IBOUND', this%memoryPath)
1226  call mem_allocate(this%xnewpak, this%ncv, 'XNEWPAK', this%memoryPath)
1227  end if
1228  call mem_allocate(this%xoldpak, this%ncv, 'XOLDPAK', this%memoryPath)
1229  !
1230  ! -- allocate character storage not managed by the memory manager
1231  allocate (this%featname(this%ncv)) ! ditch after boundnames allocated??
1232  !allocate(this%status(this%ncv))
1233  !
1234  do n = 1, this%ncv
1235  this%strt(n) = dep20
1236  this%ktf(n) = dzero
1237  this%rfeatthk(n) = dzero
1238  this%lauxvar(:, n) = dzero
1239  this%xoldpak(n) = dep20
1240  if (this%imatrows == 0) then
1241  this%iboundpak(n) = 1
1242  this%xnewpak(n) = dep20
1243  end if
1244  end do
1245  !
1246  ! -- allocate local storage for aux variables
1247  if (this%naux > 0) then
1248  allocate (caux(this%naux))
1249  end if
1250  !
1251  ! -- allocate and initialize temporary variables
1252  allocate (nboundchk(this%ncv))
1253  do n = 1, this%ncv
1254  nboundchk(n) = 0
1255  end do
1256  !
1257  ! -- get packagedata block
1258  call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, &
1259  supportopenclose=.true.)
1260  !
1261  ! -- parse locations block if detected
1262  if (isfound) then
1263  write (this%iout, '(/1x,a)') 'PROCESSING '//trim(adjustl(this%text))// &
1264  ' PACKAGEDATA'
1265  nlak = 0
1266  nconn = 0
1267  do
1268  call this%parser%GetNextLine(endofblock)
1269  if (endofblock) exit
1270  n = this%parser%GetInteger()
1271 
1272  if (n < 1 .or. n > this%ncv) then
1273  write (errmsg, '(a,1x,i6)') &
1274  'Itemno must be > 0 and <= ', this%ncv
1275  call store_error(errmsg)
1276  cycle
1277  end if
1278  !
1279  ! -- increment nboundchk
1280  nboundchk(n) = nboundchk(n) + 1
1281  !
1282  ! -- strt
1283  this%strt(n) = this%parser%GetDouble()
1284  !
1285  ! -- read additional thermal conductivity terms
1286  this%ktf(n) = this%parser%GetDouble()
1287  this%rfeatthk(n) = this%parser%GetDouble()
1288  if (this%rfeatthk(n) <= dzero) then
1289  write (errmsg, '(4x,a)') &
1290  '****ERROR. Specified thickness used for thermal &
1291  &conduction MUST BE > 0 else divide by zero error occurs'
1292  call store_error(errmsg)
1293  cycle
1294  end if
1295  !
1296  ! -- get aux data
1297  do iaux = 1, this%naux
1298  call this%parser%GetString(caux(iaux))
1299  end do
1300 
1301  ! -- set default bndName
1302  write (cno, '(i9.9)') n
1303  bndname = 'Feature'//cno
1304 
1305  ! -- featname
1306  if (this%inamedbound /= 0) then
1307  call this%parser%GetStringCaps(bndnametemp)
1308  if (bndnametemp /= '') then
1309  bndname = bndnametemp
1310  end if
1311  end if
1312  this%featname(n) = bndname
1313 
1314  ! -- fill time series aware data
1315  ! -- fill aux data
1316  do jj = 1, this%naux
1317  text = caux(jj)
1318  ii = n
1319  bndelem => this%lauxvar(jj, ii)
1320  call read_value_or_time_series_adv(text, ii, jj, bndelem, &
1321  this%packName, 'AUX', &
1322  this%tsManager, this%iprpak, &
1323  this%auxname(jj))
1324  end do
1325  !
1326  nlak = nlak + 1
1327  end do
1328  !
1329  ! -- check for duplicate or missing lakes
1330  do n = 1, this%ncv
1331  if (nboundchk(n) == 0) then
1332  write (errmsg, '(a,1x,i0)') 'No data specified for feature', n
1333  call store_error(errmsg)
1334  else if (nboundchk(n) > 1) then
1335  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
1336  'Data for feature', n, 'specified', nboundchk(n), 'times'
1337  call store_error(errmsg)
1338  end if
1339  end do
1340  !
1341  write (this%iout, '(1x,a)') &
1342  'END OF '//trim(adjustl(this%text))//' PACKAGEDATA'
1343  else
1344  call store_error('Required packagedata block not found.')
1345  end if
1346  !
1347  ! -- terminate if any errors were detected
1348  if (count_errors() > 0) then
1349  call this%parser%StoreErrorUnit()
1350  end if
1351  !
1352  ! -- deallocate local storage for aux variables
1353  if (this%naux > 0) then
1354  deallocate (caux)
1355  end if
1356  !
1357  ! -- deallocate local storage for nboundchk
1358  deallocate (nboundchk)
1359  end subroutine lke_read_cvs
1360 
1361 end module gwelkemodule
This module contains the base boundary package.
class(bndtype) function, pointer, public getbndfromlist(list, idx)
Get boundary from package list.
This module contains simulation constants.
Definition: Constants.f90:9
integer(i4b), parameter linelength
maximum length of a standard line
Definition: Constants.f90:45
real(dp), parameter dep20
real constant 1e20
Definition: Constants.f90:91
integer(i4b), parameter lenboundname
maximum length of a bound name
Definition: Constants.f90:36
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:65
integer(i4b), parameter lenbudtxt
maximum length of a budget component names
Definition: Constants.f90:37
real(dp), parameter done
real constant 1
Definition: Constants.f90:76
subroutine lke_rain_term(this, ientry, n1, n2, rrate, rhsval, hcofval)
Rain term.
Definition: gwe-lke.f90:804
subroutine lke_read_cvs(this)
Read feature information for this advanced package.
Definition: gwe-lke.f90:1192
subroutine lke_iflw_term(this, ientry, n1, n2, rrate, rhsval, hcofval)
Inflow Term.
Definition: gwe-lke.f90:883
subroutine lke_roff_term(this, ientry, n1, n2, rrate, rhsval, hcofval)
Runoff term.
Definition: gwe-lke.f90:855
character(len= *), parameter ftype
Definition: gwe-lke.f90:53
subroutine lke_solve(this)
Add terms specific to lakes to the explicit lake solve.
Definition: gwe-lke.f90:408
subroutine lke_outf_term(this, ientry, n1, n2, rrate, rhsval, hcofval)
Outflow term.
Definition: gwe-lke.f90:939
subroutine lke_setup_budobj(this, idx)
Set up the budget object that stores all the lake flows.
Definition: gwe-lke.f90:489
subroutine lke_wdrl_term(this, ientry, n1, n2, rrate, rhsval, hcofval)
Specified withdrawal term.
Definition: gwe-lke.f90:911
subroutine lke_bd_obs(this, obstypeid, jj, v, found)
Calculate observation value and pass it back to APT.
Definition: gwe-lke.f90:1072
subroutine lke_allocate_arrays(this)
Allocate arrays specific to the lake energy transport (LKE) package.
Definition: gwe-lke.f90:743
subroutine allocate_scalars(this)
Allocate scalars specific to the lake energy transport (LKE) package.
Definition: gwe-lke.f90:712
subroutine lke_set_stressperiod(this, itemno, keyword, found)
Sets the stress period attributes for keyword use.
Definition: gwe-lke.f90:1115
subroutine lke_fill_budobj(this, idx, x, flowja, ccratin, ccratout)
Copy flow terms into thisbudobj.
Definition: gwe-lke.f90:603
subroutine, public lke_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, fmi, eqnsclfac, gwecommon, dvt, dvu, dvua)
Create a new lke package.
Definition: gwe-lke.f90:107
subroutine find_lke_package(this)
Find corresponding lke package.
Definition: gwe-lke.f90:167
subroutine lke_rp_obs(this, obsrv, found)
Process package specific obs.
Definition: gwe-lke.f90:1042
subroutine lke_fc_expanded(this, rhs, ia, idxglo, matrix_sln)
Add matrix terms related to LKE.
Definition: gwe-lke.f90:290
character(len= *), parameter flowtype
Definition: gwe-lke.f90:54
subroutine lke_evap_term(this, ientry, n1, n2, rrate, rhsval, hcofval)
Evaporative term.
Definition: gwe-lke.f90:829
subroutine lke_df_obs(this)
Defined observation types.
Definition: gwe-lke.f90:966
integer(i4b) function lke_get_nbudterms(this)
Function to return the number of budget terms just for this package.
Definition: gwe-lke.f90:469
subroutine lke_da(this)
Deallocate memory.
Definition: gwe-lke.f90:772
character(len=16) text
Definition: gwe-lke.f90:55
This module defines variable data types.
Definition: kind.f90:8
This module contains the derived types ObserveType and ObsDataType.
Definition: Observe.f90:15
This module contains simulation methods.
Definition: Sim.f90:10
subroutine, public store_error(msg, terminate)
Store an error message.
Definition: Sim.f90:92
integer(i4b) function, public count_errors()
Return number of errors.
Definition: Sim.f90:59
This module contains simulation variables.
Definition: SimVariables.f90:9
character(len=maxcharlen) errmsg
error message string
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).
subroutine, public apt_process_obsid(obsrv, dis, inunitobs, iout)
Process observation IDs for an advanced package.
Definition: tsp-apt.f90:2827
subroutine, public apt_process_obsid12(obsrv, dis, inunitobs, iout)
Process observation IDs for a package.
Definition: tsp-apt.f90:2870
@ brief BndType
Data for sharing among multiple packages. Originally read in from.