MODFLOW 6  version 6.5.0.dev2
MODFLOW 6 Code Documentation
gwf-uzf.f90
Go to the documentation of this file.
1 ! -- Uzf module
2 module uzfmodule
3 
4  use kindmodule, only: dp, i4b
5  use constantsmodule, only: dzero, dem6, dem4, dem2, dem1, dhalf, &
6  done, dhundred, &
10  dhnoflo, dhdry, &
16  use sparsemodule, only: sparsematrix
17  use bndmodule, only: bndtype
20  use basedismodule, only: disbasetype
21  use observemodule, only: observetype
22  use obsmodule, only: obstype
23  use inputoutputmodule, only: urword
28  use tablemodule, only: tabletype, table_cr
30 
31  implicit none
32 
33  character(len=LENFTYPE) :: ftype = 'UZF'
34  character(len=LENPACKAGENAME) :: text = ' UZF CELLS'
35 
36  private
37  public :: uzf_create
38  public :: uzftype
39 
40  type, extends(bndtype) :: uzftype
41  ! output integers
42  integer(I4B), pointer :: iprwcont => null()
43  integer(I4B), pointer :: iwcontout => null()
44  integer(I4B), pointer :: ibudgetout => null()
45  integer(I4B), pointer :: ibudcsv => null() !< unit number for csv budget output file
46  integer(I4B), pointer :: ipakcsv => null()
47  !
48  type(budgetobjecttype), pointer :: budobj => null()
49  integer(I4B), pointer :: bditems => null() !< number of budget items
50  integer(I4B), pointer :: nbdtxt => null() !< number of budget text items
51  character(len=LENBUDTXT), dimension(:), pointer, &
52  contiguous :: bdtxt => null() !< budget items written to cbc file
53  character(len=LENBOUNDNAME), dimension(:), pointer, &
54  contiguous :: uzfname => null()
55  !
56  ! -- uzf table objects
57  type(tabletype), pointer :: pakcsvtab => null()
58  !
59  ! -- uzf kinematic object
60  type(uzfcellgrouptype), pointer :: uzfobj => null()
61  type(uzfcellgrouptype) :: uzfobjwork
62  !
63  ! -- pointer to gwf variables
64  integer(I4B), pointer :: gwfiss => null()
65  real(dp), dimension(:), pointer, contiguous :: gwfhcond => null()
66  !
67  ! -- uzf data
68  integer(I4B), pointer :: nwav_pvar => null()
69  integer(I4B), pointer :: ntrail_pvar => null()
70  integer(I4B), pointer :: nsets => null()
71  integer(I4B), pointer :: nodes => null()
72  integer(I4B), pointer :: readflag => null()
73  integer(I4B), pointer :: ietflag => null() !< et flag, 0 is off, 1 or 2 are different types
74  integer(I4B), pointer :: igwetflag => null()
75  integer(I4B), pointer :: iseepflag => null()
76  integer(I4B), pointer :: imaxcellcnt => null()
77  integer(I4B), pointer :: iuzf2uzf => null()
78  ! -- integer vectors
79  integer(I4B), dimension(:), pointer, contiguous :: igwfnode => null()
80  integer(I4B), dimension(:), pointer, contiguous :: ia => null()
81  integer(I4B), dimension(:), pointer, contiguous :: ja => null()
82  ! -- double precision output vectors
83  real(dp), dimension(:), pointer, contiguous :: appliedinf => null()
84  real(dp), dimension(:), pointer, contiguous :: rejinf => null()
85  real(dp), dimension(:), pointer, contiguous :: rejinf0 => null()
86  real(dp), dimension(:), pointer, contiguous :: rejinftomvr => null()
87  real(dp), dimension(:), pointer, contiguous :: infiltration => null()
88  real(dp), dimension(:), pointer, contiguous :: gwet_pvar => null()
89  real(dp), dimension(:), pointer, contiguous :: uzet => null()
90  real(dp), dimension(:), pointer, contiguous :: gwd => null()
91  real(dp), dimension(:), pointer, contiguous :: gwd0 => null()
92  real(dp), dimension(:), pointer, contiguous :: gwdtomvr => null()
93  real(dp), dimension(:), pointer, contiguous :: rch => null()
94  real(dp), dimension(:), pointer, contiguous :: rch0 => null()
95  real(dp), dimension(:), pointer, contiguous :: qsto => null() !< change in stored mobile water per time for this time step
96  real(dp), dimension(:), pointer, contiguous :: wcnew => null() !< water content for this time step
97  real(dp), dimension(:), pointer, contiguous :: wcold => null() !< water content for previous time step
98  !
99  ! -- timeseries aware package variables; these variables with
100  ! _pvar have uzfobj counterparts
101  real(dp), dimension(:), pointer, contiguous :: sinf_pvar => null()
102  real(dp), dimension(:), pointer, contiguous :: pet_pvar => null()
103  real(dp), dimension(:), pointer, contiguous :: extdp => null()
104  real(dp), dimension(:), pointer, contiguous :: extwc_pvar => null()
105  real(dp), dimension(:), pointer, contiguous :: ha_pvar => null()
106  real(dp), dimension(:), pointer, contiguous :: hroot_pvar => null()
107  real(dp), dimension(:), pointer, contiguous :: rootact_pvar => null()
108  !
109  ! -- aux variable
110  real(dp), dimension(:, :), pointer, contiguous :: uauxvar => null()
111  !
112  ! -- convergence check
113  integer(I4B), pointer :: iconvchk => null()
114  !
115  ! formulate variables
116  real(dp), dimension(:), pointer, contiguous :: deriv => null()
117  !
118  ! budget variables
119  real(dp), pointer :: totfluxtot => null()
120  integer(I4B), pointer :: issflag => null()
121  integer(I4B), pointer :: issflagold => null()
122  integer(I4B), pointer :: istocb => null()
123  !
124  ! -- uzf cbc budget items
125  integer(I4B), pointer :: cbcauxitems => null()
126  character(len=16), dimension(:), pointer, contiguous :: cauxcbc => null()
127  real(dp), dimension(:), pointer, contiguous :: qauxcbc => null()
128 
129  contains
130 
131  procedure :: uzf_allocate_arrays
132  procedure :: uzf_allocate_scalars
133  procedure :: bnd_options => uzf_options
134  procedure :: read_dimensions => uzf_readdimensions
135  procedure :: bnd_ar => uzf_ar
136  procedure :: bnd_rp => uzf_rp
137  procedure :: bnd_ad => uzf_ad
138  procedure :: bnd_cf => uzf_cf
139  procedure :: bnd_cc => uzf_cc
140  procedure :: bnd_cq => uzf_cq
141  procedure :: bnd_bd => uzf_bd
142  procedure :: bnd_ot_model_flows => uzf_ot_model_flows
143  procedure :: bnd_ot_package_flows => uzf_ot_package_flows
144  procedure :: bnd_ot_dv => uzf_ot_dv
145  procedure :: bnd_ot_bdsummary => uzf_ot_bdsummary
146  procedure :: bnd_fc => uzf_fc
147  procedure :: bnd_fn => uzf_fn
148  procedure :: bnd_da => uzf_da
149  procedure :: define_listlabel
150  !
151  ! -- methods for observations
152  procedure, public :: bnd_obs_supported => uzf_obs_supported
153  procedure, public :: bnd_df_obs => uzf_df_obs
154  procedure, public :: bnd_rp_obs => uzf_rp_obs
155  procedure, public :: bnd_bd_obs => uzf_bd_obs
156  !
157  ! -- methods specific for uzf
158  procedure, private :: uzf_solve
159  procedure, private :: read_cell_properties
160  procedure, private :: print_cell_properties
161  procedure, private :: findcellabove
162  procedure, private :: check_cell_area
163  !
164  ! -- budget
165  procedure, private :: uzf_setup_budobj
166  procedure, private :: uzf_fill_budobj
167 
168  end type uzftype
169 
170 contains
171 
172  !> @brief Create a New UZF Package and point packobj to the new package
173  !<
174  subroutine uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
175  ! -- modules
177  ! -- dummy
178  class(bndtype), pointer :: packobj
179  integer(I4B), intent(in) :: id
180  integer(I4B), intent(in) :: ibcnum
181  integer(I4B), intent(in) :: inunit
182  integer(I4B), intent(in) :: iout
183  character(len=*), intent(in) :: namemodel
184  character(len=*), intent(in) :: pakname
185  ! -- local
186  type(uzftype), pointer :: uzfobj
187  !
188  ! -- allocate the object and assign values to object variables
189  allocate (uzfobj)
190  packobj => uzfobj
191  !
192  ! -- create name and memory path
193  call packobj%set_names(ibcnum, namemodel, pakname, ftype)
194  packobj%text = text
195  !
196  ! -- allocate scalars
197  call uzfobj%uzf_allocate_scalars()
198  !
199  ! -- initialize package
200  call packobj%pack_initialize()
201  !
202  packobj%inunit = inunit
203  packobj%iout = iout
204  packobj%id = id
205  packobj%ibcnum = ibcnum
206  packobj%ncolbnd = 1
207  packobj%iscloc = 0 ! not supported
208  packobj%isadvpak = 1
209  packobj%ictMemPath = create_mem_path(namemodel, 'NPF')
210  !
211  ! -- Return
212  return
213  end subroutine uzf_create
214 
215  !> @brief Allocate and Read
216  !<
217  subroutine uzf_ar(this)
218  ! -- modules
220  ! -- dummy
221  class(uzftype), intent(inout) :: this
222  ! -- local
223  integer(I4B) :: n, i
224  real(DP) :: hgwf
225  !
226  call this%obs%obs_ar()
227  !
228  ! -- call standard BndType allocate scalars
229  call this%BndType%allocate_arrays()
230  !
231  ! -- set pointers now that data is available
232  call mem_setptr(this%gwfhcond, 'CONDSAT', create_mem_path(this%name_model, &
233  'NPF'))
234  call mem_setptr(this%gwfiss, 'ISS', create_mem_path(this%name_model))
235  !
236  ! -- set boundname for each connection
237  if (this%inamedbound /= 0) then
238  do n = 1, this%nodes
239  this%boundname(n) = this%uzfname(n)
240  end do
241  end if
242  !
243  ! -- copy boundname into boundname_cst
244  call this%copy_boundname()
245  !
246  ! -- copy igwfnode into nodelist and set water table
247  do i = 1, this%nodes
248  this%nodelist(i) = this%igwfnode(i)
249  n = this%igwfnode(i)
250  hgwf = this%xnew(n)
251  call this%uzfobj%sethead(i, hgwf)
252  end do
253  !
254  ! -- setup pakmvrobj
255  if (this%imover /= 0) then
256  allocate (this%pakmvrobj)
257  call this%pakmvrobj%ar(this%maxbound, this%maxbound, this%memoryPath)
258  end if
259  !
260  ! -- Return
261  return
262  end subroutine uzf_ar
263 
264  !> @brief Allocate arrays used for uzf
265  !<
266  subroutine uzf_allocate_arrays(this)
267  ! -- dummy
268  class(uzftype), intent(inout) :: this
269  ! -- local
270  integer(I4B) :: i
271  integer(I4B) :: j
272  !
273  ! -- call standard BndType allocate scalars (now done from AR)
274  !call this%BndType%allocate_arrays()
275  !
276  ! -- allocate uzf specific arrays
277  call mem_allocate(this%igwfnode, this%nodes, 'IGWFNODE', this%memoryPath)
278  call mem_allocate(this%appliedinf, this%nodes, 'APPLIEDINF', this%memoryPath)
279  call mem_allocate(this%rejinf, this%nodes, 'REJINF', this%memoryPath)
280  call mem_allocate(this%rejinf0, this%nodes, 'REJINF0', this%memoryPath)
281  call mem_allocate(this%rejinftomvr, this%nodes, 'REJINFTOMVR', &
282  this%memoryPath)
283  call mem_allocate(this%infiltration, this%nodes, 'INFILTRATION', &
284  this%memoryPath)
285  call mem_allocate(this%gwet_pvar, this%nodes, 'GWET_PVAR', this%memoryPath)
286  call mem_allocate(this%uzet, this%nodes, 'UZET', this%memoryPath)
287  call mem_allocate(this%gwd, this%nodes, 'GWD', this%memoryPath)
288  call mem_allocate(this%gwd0, this%nodes, 'GWD0', this%memoryPath)
289  call mem_allocate(this%gwdtomvr, this%nodes, 'GWDTOMVR', this%memoryPath)
290  call mem_allocate(this%rch, this%nodes, 'RCH', this%memoryPath)
291  call mem_allocate(this%rch0, this%nodes, 'RCH0', this%memoryPath)
292  call mem_allocate(this%qsto, this%nodes, 'QSTO', this%memoryPath)
293  call mem_allocate(this%deriv, this%nodes, 'DERIV', this%memoryPath)
294  !
295  ! -- integer vectors
296  call mem_allocate(this%ia, this%dis%nodes + 1, 'IA', this%memoryPath)
297  call mem_allocate(this%ja, this%nodes, 'JA', this%memoryPath)
298  !
299  ! -- allocate timeseries aware variables
300  call mem_allocate(this%sinf_pvar, this%nodes, 'SINF_PVAR', this%memoryPath)
301  call mem_allocate(this%pet_pvar, this%nodes, 'PET_PVAR', this%memoryPath)
302  call mem_allocate(this%extdp, this%nodes, 'EXDP_PVAR', this%memoryPath)
303  call mem_allocate(this%extwc_pvar, this%nodes, 'EXTWC_PVAR', this%memoryPath)
304  call mem_allocate(this%ha_pvar, this%nodes, 'HA_PVAR', this%memoryPath)
305  call mem_allocate(this%hroot_pvar, this%nodes, 'HROOT_PVAR', this%memoryPath)
306  call mem_allocate(this%rootact_pvar, this%nodes, 'ROOTACT_PVAR', &
307  this%memoryPath)
308  call mem_allocate(this%uauxvar, this%naux, this%nodes, 'UAUXVAR', &
309  this%memoryPath)
310  !
311  ! -- initialize
312  do i = 1, this%nodes
313  this%appliedinf(i) = dzero
314  this%rejinf(i) = dzero
315  this%rejinf0(i) = dzero
316  this%rejinftomvr(i) = dzero
317  this%gwet_pvar(i) = dzero
318  this%uzet(i) = dzero
319  this%gwd(i) = dzero
320  this%gwd0(i) = dzero
321  this%gwdtomvr(i) = dzero
322  this%rch(i) = dzero
323  this%rch0(i) = dzero
324  this%qsto(i) = dzero
325  this%deriv(i) = dzero
326  ! -- integer variables
327  this%ja(i) = 0
328  ! -- timeseries aware variables
329  this%sinf_pvar(i) = dzero
330  this%pet_pvar(i) = dzero
331  this%extdp(i) = dzero
332  this%extwc_pvar(i) = dzero
333  this%ha_pvar(i) = dzero
334  this%hroot_pvar(i) = dzero
335  this%rootact_pvar(i) = dzero
336  do j = 1, this%naux
337  if (this%iauxmultcol > 0 .and. j == this%iauxmultcol) then
338  this%uauxvar(j, i) = done
339  else
340  this%uauxvar(j, i) = dzero
341  end if
342  end do
343  end do
344  do i = 1, this%dis%nodes + 1
345  this%ia(i) = 0
346  end do
347  !
348  ! -- allocate and initialize character array for budget text
349  allocate (this%bdtxt(this%nbdtxt))
350  this%bdtxt(1) = ' UZF-INF'
351  this%bdtxt(2) = ' UZF-GWRCH'
352  this%bdtxt(3) = ' UZF-GWD'
353  this%bdtxt(4) = ' UZF-GWET'
354  this%bdtxt(5) = ' UZF-GWD TO-MVR'
355  !
356  ! -- allocate and initialize watercontent arrays
357  call mem_allocate(this%wcnew, this%nodes, 'WCNEW', this%memoryPath)
358  call mem_allocate(this%wcold, this%nodes, 'WCOLD', this%memoryPath)
359  do i = 1, this%nodes
360  this%wcnew(i) = dzero
361  this%wcold(i) = dzero
362  end do
363  !
364  ! -- allocate character array for aux budget text
365  allocate (this%cauxcbc(this%cbcauxitems))
366  allocate (this%uzfname(this%nodes))
367  !
368  ! -- allocate and initialize qauxcbc
369  call mem_allocate(this%qauxcbc, this%cbcauxitems, 'QAUXCBC', this%memoryPath)
370  do i = 1, this%cbcauxitems
371  this%qauxcbc(i) = dzero
372  end do
373  !
374  ! -- Return
375  return
376  end subroutine uzf_allocate_arrays
377 
378  !> @brief Set options specific to UzfType
379  !!
380  !! Overrides BoundaryPackageType%child_class_options
381  !<
382  subroutine uzf_options(this, option, found)
383  ! -- modules
384  use constantsmodule, only: dzero, mnormal
385  use openspecmodule, only: access, form
386  use simmodule, only: store_error
388  implicit none
389  ! -- dummy
390  class(uzftype), intent(inout) :: this
391  character(len=*), intent(inout) :: option
392  logical, intent(inout) :: found
393  ! -- local
394  character(len=MAXCHARLEN) :: fname, keyword
395  ! -- formats
396  character(len=*), parameter :: fmtnotfound = &
397  &"(4x, 'NO UZF OPTIONS WERE FOUND.')"
398  character(len=*), parameter :: fmtet = &
399  "(4x, 'ET WILL BE SIMULATED WITHIN UZ AND GW ZONES, WITH LINEAR ', &
400  &'GWET IF OPTION NOT SPECIFIED OTHERWISE.')"
401  character(len=*), parameter :: fmtgwetlin = &
402  &"(4x, 'GROUNDWATER ET FUNCTION WILL BE LINEAR.')"
403  character(len=*), parameter :: fmtgwetsquare = &
404  &"(4x, 'GROUNDWATER ET FUNCTION WILL BE SQUARE WITH SMOOTHING.')"
405  character(len=*), parameter :: fmtgwseepout = &
406  &"(4x, 'GROUNDWATER DISCHARGE TO LAND SURFACE WILL BE SIMULATED.')"
407  character(len=*), parameter :: fmtuzetwc = &
408  &"(4x, 'UNSATURATED ET FUNCTION OF WATER CONTENT.')"
409  character(len=*), parameter :: fmtuzetae = &
410  &"(4x, 'UNSATURATED ET FUNCTION OF AIR ENTRY PRESSURE.')"
411  character(len=*), parameter :: fmtuznlay = &
412  &"(4x, 'UNSATURATED FLOW WILL BE SIMULATED SEPARATELY IN EACH LAYER.')"
413  character(len=*), parameter :: fmtuzfbin = &
414  "(4x, 'UZF ', 1x, a, 1x, ' WILL BE SAVED TO FILE: ', &
415  &a, /4x, 'OPENED ON UNIT: ', I0)"
416  character(len=*), parameter :: fmtuzfopt = &
417  &"(4x, 'UZF ', a, ' VALUE (',g15.7,') SPECIFIED.')"
418  !
419  !
420  found = .true.
421  select case (option)
422  !case ('PRINT_WATER-CONTENT')
423  ! this%iprwcont = 1
424  ! write(this%iout,'(4x,a)') trim(adjustl(this%text))// &
425  ! ' WATERCONTENT WILL BE PRINTED TO LISTING FILE.'
426  case ('WATER_CONTENT')
427  call this%parser%GetStringCaps(keyword)
428  if (keyword == 'FILEOUT') then
429  call this%parser%GetString(fname)
430  this%iwcontout = getunit()
431  call openfile(this%iwcontout, this%iout, fname, 'DATA(BINARY)', &
432  form, access, 'REPLACE', mode_opt=mnormal)
433  write (this%iout, fmtuzfbin) 'WATER-CONTENT', trim(adjustl(fname)), &
434  this%iwcontout
435  else
436  call store_error('OPTIONAL WATER_CONTENT KEYWORD &
437  &MUST BE FOLLOWED BY FILEOUT')
438  end if
439  case ('BUDGET')
440  call this%parser%GetStringCaps(keyword)
441  if (keyword == 'FILEOUT') then
442  call this%parser%GetString(fname)
443  this%ibudgetout = getunit()
444  call openfile(this%ibudgetout, this%iout, fname, 'DATA(BINARY)', &
445  form, access, 'REPLACE', mode_opt=mnormal)
446  write (this%iout, fmtuzfbin) 'BUDGET', trim(adjustl(fname)), &
447  this%ibudgetout
448  else
449  call store_error('OPTIONAL BUDGET KEYWORD MUST BE FOLLOWED BY FILEOUT')
450  end if
451  case ('BUDGETCSV')
452  call this%parser%GetStringCaps(keyword)
453  if (keyword == 'FILEOUT') then
454  call this%parser%GetString(fname)
455  this%ibudcsv = getunit()
456  call openfile(this%ibudcsv, this%iout, fname, 'CSV', &
457  filstat_opt='REPLACE')
458  write (this%iout, fmtuzfbin) 'BUDGET CSV', trim(adjustl(fname)), &
459  this%ibudcsv
460  else
461  call store_error('OPTIONAL BUDGETCSV KEYWORD MUST BE FOLLOWED BY &
462  &FILEOUT')
463  end if
464  case ('PACKAGE_CONVERGENCE')
465  call this%parser%GetStringCaps(keyword)
466  if (keyword == 'FILEOUT') then
467  call this%parser%GetString(fname)
468  this%ipakcsv = getunit()
469  call openfile(this%ipakcsv, this%iout, fname, 'CSV', &
470  filstat_opt='REPLACE', mode_opt=mnormal)
471  write (this%iout, fmtuzfbin) 'PACKAGE_CONVERGENCE', &
472  trim(adjustl(fname)), this%ipakcsv
473  else
474  call store_error('OPTIONAL PACKAGE_CONVERGENCE KEYWORD MUST BE '// &
475  'FOLLOWED BY FILEOUT')
476  end if
477  case ('SIMULATE_ET')
478  this%ietflag = 1 !default
479  this%igwetflag = 0
480  write (this%iout, fmtet)
481  case ('LINEAR_GWET')
482  this%igwetflag = 1
483  write (this%iout, fmtgwetlin)
484  case ('SQUARE_GWET')
485  this%igwetflag = 2
486  write (this%iout, fmtgwetsquare)
487  case ('SIMULATE_GWSEEP')
488  this%iseepflag = 1
489  write (this%iout, fmtgwseepout)
490  !
491  ! -- Create warning message
492  write (warnmsg, '(a)') &
493  'USE DRN PACKAGE TO SIMULATE GROUNDWATER DISCHARGE TO LAND SURFACE '// &
494  'INSTEAD'
495  !
496  ! -- Create deprecation warning
497  call deprecation_warning('OPTIONS', 'SIMULATE_GWSEEP', '6.5.0', &
498  warnmsg, this%parser%GetUnit())
499  case ('UNSAT_ETWC')
500  this%ietflag = 1
501  write (this%iout, fmtuzetwc)
502  case ('UNSAT_ETAE')
503  this%ietflag = 2
504  write (this%iout, fmtuzetae)
505  case ('MOVER')
506  this%imover = 1
507  !
508  ! -- right now these are options that are available but may not be available in
509  ! the release (or in documentation)
510  case ('DEV_NO_FINAL_CHECK')
511  call this%parser%DevOpt()
512  this%iconvchk = 0
513  write (this%iout, '(4x,a)') &
514  'A FINAL CONVERGENCE CHECK OF THE CHANGE IN UZF RECHARGE &
515  &WILL NOT BE MADE'
516  !case('DEV_MAXIMUM_PERCENT_DIFFERENCE')
517  ! call this%parser%DevOpt()
518  ! r = this%parser%GetDouble()
519  ! if (r > DZERO) then
520  ! this%pdmax = r
521  ! write(this%iout, fmtuzfopt) 'MAXIMUM_PERCENT_DIFFERENCE', this%pdmax
522  ! else
523  ! write(this%iout, fmtuzfopt) 'INVALID MAXIMUM_PERCENT_DIFFERENCE', r
524  ! write(this%iout, fmtuzfopt) 'USING DEFAULT MAXIMUM_PERCENT_DIFFERENCE', this%pdmax
525  ! end if
526  case default
527  ! -- No options found
528  found = .false.
529  end select
530  ! -- Return
531  return
532  end subroutine uzf_options
533 !
534  !> @brief Set dimensions specific to UzfType
535  !<
536  subroutine uzf_readdimensions(this)
537  ! -- modules
538  use inputoutputmodule, only: urword
540  class(uzftype), intent(inout) :: this
541  character(len=LINELENGTH) :: keyword
542  integer(I4B) :: ierr
543  logical :: isfound, endOfBlock
544  !
545  ! -- initialize dimensions to -1
546  this%nodes = -1
547  this%ntrail_pvar = 0
548  this%nsets = 0
549  !
550  ! -- get dimensions block
551  call this%parser%GetBlock('DIMENSIONS', isfound, ierr, &
552  supportopenclose=.true.)
553  !
554  ! -- parse dimensions block if detected
555  if (isfound) then
556  write (this%iout, '(/1x,a)') &
557  'PROCESSING '//trim(adjustl(this%text))//' DIMENSIONS'
558  do
559  call this%parser%GetNextLine(endofblock)
560  if (endofblock) exit
561  call this%parser%GetStringCaps(keyword)
562  select case (keyword)
563  case ('NUZFCELLS')
564  this%nodes = this%parser%GetInteger()
565  write (this%iout, '(4x,a,i0)') 'NUZFCELLS = ', this%nodes
566  case ('NTRAILWAVES')
567  this%ntrail_pvar = this%parser%GetInteger()
568  write (this%iout, '(4x,a,i0)') 'NTRAILWAVES = ', this%ntrail_pvar
569  case ('NWAVESETS')
570  this%nsets = this%parser%GetInteger()
571  write (this%iout, '(4x,a,i0)') 'NTRAILSETS = ', this%nsets
572  case default
573  write (errmsg, '(a,a)') &
574  'Unknown '//trim(this%text)//' dimension: ', trim(keyword)
575  end select
576  end do
577  write (this%iout, '(1x,a)') &
578  'END OF '//trim(adjustl(this%text))//' DIMENSIONS'
579  else
580  call store_error('Required dimensions block not found.')
581  end if
582  !
583  ! -- increment maxbound
584  this%maxbound = this%maxbound + this%nodes
585  this%nbound = this%maxbound
586  !
587  ! -- verify dimensions were set
588  if (this%nodes <= 0) then
589  write (errmsg, '(a)') &
590  'NUZFCELLS was not specified or was specified incorrectly.'
591  call store_error(errmsg)
592  end if
593 
594  if (this%ntrail_pvar <= 0) then
595  write (errmsg, '(a)') &
596  'NTRAILWAVES was not specified or was specified incorrectly.'
597  call store_error(errmsg)
598  end if
599  !
600  if (this%nsets <= 0) then
601  write (errmsg, '(a)') &
602  'NWAVESETS was not specified or was specified incorrectly.'
603  call store_error(errmsg)
604  end if
605  !
606  ! -- terminate if there are dimension errors
607  if (count_errors() > 0) then
608  call this%parser%StoreErrorUnit()
609  end if
610  !
611  ! -- set the number of waves
612  this%nwav_pvar = this%ntrail_pvar * this%nsets
613  !
614  ! -- Call define_listlabel to construct the list label that is written
615  ! when PRINT_INPUT option is used.
616  call this%define_listlabel()
617  !
618  ! -- Allocate arrays in package superclass
619  call this%uzf_allocate_arrays()
620  !
621  ! -- initialize uzf group object
622  allocate (this%uzfobj)
623  call this%uzfobj%init(this%nodes, this%nwav_pvar, this%memoryPath)
624  call this%uzfobjwork%init(1, this%nwav_pvar)
625  !
626  !--Read uzf cell properties and set values
627  call this%read_cell_properties()
628  !
629  ! -- print cell data
630  if (this%iprpak /= 0) then
631  call this%print_cell_properties()
632  end if
633  !
634  ! -- setup the budget object
635  call this%uzf_setup_budobj()
636  !
637  ! -- Return
638  return
639  end subroutine uzf_readdimensions
640 
641  !> @brief Read stress data
642  !!
643  !! - check if bc changes
644  !! - read new bc for stress period
645  !! - set kinematic variables to bc values
646  !<
647  subroutine uzf_rp(this)
648  ! -- modules
649  use tdismodule, only: kper, nper
651  use inputoutputmodule, only: urword
653  ! -- dummy
654  class(uzftype), intent(inout) :: this
655  ! -- local
656  character(len=LENBOUNDNAME) :: bndName
657  character(len=LINELENGTH) :: text
658  character(len=LINELENGTH) :: line
659  logical :: isfound
660  logical :: endOfBlock
661  integer(I4B) :: i
662  integer(I4B) :: j
663  integer(I4B) :: jj
664  integer(I4B) :: ierr
665  real(DP), pointer :: bndElem => null()
666  ! -- table output
667  character(len=20) :: cellid
668  character(len=LINELENGTH) :: title
669  character(len=LINELENGTH) :: tag
670  integer(I4B) :: ntabrows
671  integer(I4B) :: ntabcols
672  integer(I4B) :: node
673  !-- formats
674  character(len=*), parameter :: fmtlsp = &
675  &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')"
676  character(len=*), parameter :: fmtblkerr = &
677  &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')"
678  character(len=*), parameter :: fmtisvflow = &
679  "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE &
680  &WHENEVER ICBCFL IS NOT ZERO.')"
681  character(len=*), parameter :: fmtflow = &
682  &"(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)"
683  !
684  ! -- Set ionper to the stress period number for which a new block of data
685  ! will be read.
686  if (this%inunit == 0) return
687  !
688  ! -- get stress period data
689  if (this%ionper < kper) then
690  !
691  ! -- get period block
692  call this%parser%GetBlock('PERIOD', isfound, ierr, &
693  supportopenclose=.true., &
694  blockrequired=.false.)
695  if (isfound) then
696  !
697  ! -- read ionper and check for increasing period numbers
698  call this%read_check_ionper()
699  else
700  !
701  ! -- PERIOD block not found
702  if (ierr < 0) then
703  ! -- End of file found; data applies for remainder of simulation.
704  this%ionper = nper + 1
705  else
706  ! -- Found invalid block
707  call this%parser%GetCurrentLine(line)
708  write (errmsg, fmtblkerr) adjustl(trim(line))
709  call store_error(errmsg)
710  call this%parser%StoreErrorUnit()
711  end if
712  end if
713  end if
714  !
715  ! -- set steady-state flag based on gwfiss
716  this%issflag = this%gwfiss
717  !
718  ! -- read data if ionper == kper
719  if (this%ionper == kper) then
720  !
721  ! -- write header
722  if (this%iprpak /= 0) then
723  !
724  ! -- setup inputtab tableobj
725  !
726  ! -- table dimensions
727  ntabrows = 1
728  ntabcols = 3
729  if (this%ietflag /= 0) then
730  ntabcols = ntabcols + 3
731  if (this%ietflag == 2) then
732  ntabcols = ntabcols + 3
733  end if
734  end if
735  if (this%inamedbound == 1) then
736  ntabcols = ntabcols + 1
737  end if
738  !
739  ! -- initialize table and define columns
740  title = trim(adjustl(this%text))//' PACKAGE ('// &
741  trim(adjustl(this%packName))//') DATA FOR PERIOD'
742  write (title, '(a,1x,i6)') trim(adjustl(title)), kper
743  call table_cr(this%inputtab, this%packName, title)
744  call this%inputtab%table_df(ntabrows, ntabcols, this%iout, &
745  finalize=.false.)
746  tag = 'NUMBER'
747  call this%inputtab%initialize_column(tag, 10)
748  tag = 'CELLID'
749  call this%inputtab%initialize_column(tag, 20, alignment=tableft)
750  tag = 'FINF'
751  call this%inputtab%initialize_column(tag, 12)
752  if (this%ietflag /= 0) then
753  tag = 'PET'
754  call this%inputtab%initialize_column(tag, 12)
755  tag = 'EXTDEP'
756  call this%inputtab%initialize_column(tag, 12)
757  tag = 'EXTWC'
758  call this%inputtab%initialize_column(tag, 12)
759  if (this%ietflag == 2) then
760  tag = 'HA'
761  call this%inputtab%initialize_column(tag, 12)
762  tag = 'HROOT'
763  call this%inputtab%initialize_column(tag, 12)
764  tag = 'ROOTACT'
765  call this%inputtab%initialize_column(tag, 12)
766  end if
767  end if
768  if (this%inamedbound == 1) then
769  tag = 'BOUNDNAME'
770  call this%inputtab%initialize_column(tag, lenboundname, &
771  alignment=tableft)
772  end if
773  end if
774  !
775  ! -- read the stress period data
776  do
777  call this%parser%GetNextLine(endofblock)
778  if (endofblock) exit
779  !
780  ! -- check for valid uzf node
781  i = this%parser%GetInteger()
782  if (i < 1 .or. i > this%nodes) then
783  tag = trim(adjustl(this%text))//' PACKAGE ('// &
784  trim(adjustl(this%packName))//') DATA FOR PERIOD'
785  write (tag, '(a,1x,i0)') trim(adjustl(tag)), kper
786 
787  write (errmsg, '(a,a,i0,1x,a,i0,a)') &
788  trim(adjustl(tag)), ': UZFNO ', i, &
789  'must be greater than 0 and less than or equal to ', this%nodes, '.'
790  call store_error(errmsg)
791  cycle
792  end if
793  !
794  ! -- Setup boundname
795  if (this%inamedbound > 0) then
796  bndname = this%boundname(i)
797  else
798  bndname = ''
799  end if
800  !
801  ! -- FINF
802  call this%parser%GetStringCaps(text)
803  jj = 1 ! For SINF
804  bndelem => this%sinf_pvar(i)
805  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
806  'BND', this%tsManager, this%iprpak, &
807  'SINF')
808  !
809  ! -- PET
810  call this%parser%GetStringCaps(text)
811  jj = 1 ! For PET
812  bndelem => this%pet_pvar(i)
813  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
814  'BND', this%tsManager, this%iprpak, &
815  'PET')
816  !
817  ! -- EXTD
818  call this%parser%GetStringCaps(text)
819  jj = 1 ! For EXTDP
820  bndelem => this%extdp(i)
821  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
822  'BND', this%tsManager, this%iprpak, &
823  'EXTDP')
824  !
825  ! -- EXTWC
826  call this%parser%GetStringCaps(text)
827  jj = 1 ! For EXTWC
828  bndelem => this%extwc_pvar(i)
829  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
830  'BND', this%tsManager, this%iprpak, &
831  'EXTWC')
832  !
833  ! -- HA
834  call this%parser%GetStringCaps(text)
835  jj = 1 ! For HA
836  bndelem => this%ha_pvar(i)
837  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
838  'BND', this%tsManager, this%iprpak, &
839  'HA')
840  !
841  ! -- HROOT
842  call this%parser%GetStringCaps(text)
843  jj = 1 ! For HROOT
844  bndelem => this%hroot_pvar(i)
845  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
846  'BND', this%tsManager, this%iprpak, &
847  'HROOT')
848  !
849  ! -- ROOTACT
850  call this%parser%GetStringCaps(text)
851  jj = 1 ! For ROOTACT
852  bndelem => this%rootact_pvar(i)
853  call read_value_or_time_series_adv(text, i, jj, bndelem, this%packName, &
854  'BND', this%tsManager, this%iprpak, &
855  'ROOTACT')
856  !
857  ! -- read auxiliary variables
858  do j = 1, this%naux
859  call this%parser%GetStringCaps(text)
860  bndelem => this%uauxvar(j, i)
861  call read_value_or_time_series_adv(text, i, j, bndelem, this%packName, &
862  'AUX', this%tsManager, this%iprpak, &
863  this%auxname(j))
864  end do
865  !
866  ! -- write line
867  if (this%iprpak /= 0) then
868  !
869  ! -- get cellid
870  node = this%igwfnode(i)
871  if (node > 0) then
872  call this%dis%noder_to_string(node, cellid)
873  else
874  cellid = 'none'
875  end if
876  !
877  ! -- write data to the table
878  call this%inputtab%add_term(i)
879  call this%inputtab%add_term(cellid)
880  call this%inputtab%add_term(this%sinf_pvar(i))
881  if (this%ietflag /= 0) then
882  call this%inputtab%add_term(this%pet_pvar(i))
883  call this%inputtab%add_term(this%extdp(i))
884  call this%inputtab%add_term(this%extwc_pvar(i))
885  if (this%ietflag == 2) then
886  call this%inputtab%add_term(this%ha_pvar(i))
887  call this%inputtab%add_term(this%hroot_pvar(i))
888  call this%inputtab%add_term(this%rootact_pvar(i))
889  end if
890  end if
891  if (this%inamedbound == 1) then
892  call this%inputtab%add_term(this%boundname(i))
893  end if
894  end if
895 
896  end do
897  !
898  ! -- finalize the table
899  if (this%iprpak /= 0) then
900  call this%inputtab%finalize_table()
901  end if
902  !
903  ! -- using stress period data from the previous stress period
904  else
905  write (this%iout, fmtlsp) trim(this%filtyp)
906  end if
907  !
908  ! -- write summary of uzf stress period error messages
909  ierr = count_errors()
910  if (ierr > 0) then
911  call this%parser%StoreErrorUnit()
912  end if
913  !
914  ! -- set wave data for first stress period and second that follows SS
915  if ((this%issflag == 0 .AND. kper == 1) .or. &
916  (kper == 2 .AND. this%issflagold == 1)) then
917  do i = 1, this%nodes
918  call this%uzfobj%setwaves(i)
919  end do
920  end if
921  !
922  ! -- Initialize the water content
923  if (kper == 1) then
924  do i = 1, this%nodes
925  this%wcnew(i) = this%uzfobj%get_wcnew(i)
926  end do
927  end if
928  !
929  ! -- Save old ss flag
930  this%issflagold = this%issflag
931  !
932  ! -- Return
933  return
934  end subroutine uzf_rp
935 
936  !> @brief Advance UZF Package
937  !<
938  subroutine uzf_ad(this)
939  ! -- modules
941  ! -- dummy
942  class(uzftype) :: this
943  ! -- locals
944  integer(I4B) :: i
945  integer(I4B) :: ivertflag
946  integer(I4B) :: n, iaux
947  real(DP) :: rval1, rval2, rval3
948  !
949  ! -- Advance the time series
950  call this%TsManager%ad()
951  !
952  ! -- update auxiliary variables by copying from the derived-type time
953  ! series variable into the bndpackage auxvar variable so that this
954  ! information is properly written to the GWF budget file
955  if (this%naux > 0) then
956  do n = 1, this%maxbound
957  do iaux = 1, this%naux
958  if (this%noupdateauxvar(iaux) /= 0) cycle
959  this%auxvar(iaux, n) = this%uauxvar(iaux, n)
960  end do
961  end do
962  end if
963  !
964  ! -- Update or restore state
965  if (ifailedstepretry == 0) then
966  !
967  ! -- reset old water content to new water content
968  do i = 1, this%nodes
969  this%wcold(i) = this%wcnew(i)
970  end do
971  else
972  !
973  ! -- Copy wcold back into wcnew as this is a retry of this time step.
974  ! Note that there is no need to reset the waves as they are not
975  ! advanced to their new state until the _ot() method is called,
976  ! and that doesn't happen until a successful solution is obtained.
977  do i = 1, this%nodes
978  this%wcnew(i) = this%wcold(i)
979  end do
980  end if
981  !
982  ! -- advance each uzf obj
983  do i = 1, this%nodes
984  call this%uzfobj%advance(i)
985  end do
986  !
987  ! -- update uzf objects with timeseries aware variables
988  do i = 1, this%nodes
989  !
990  ! -- Set ivertflag
991  ivertflag = this%uzfobj%ivertcon(i)
992  !
993  ! -- recalculate uzfarea
994  if (this%iauxmultcol > 0) then
995  rval1 = this%uauxvar(this%iauxmultcol, i)
996  call this%uzfobj%setdatauzfarea(i, rval1)
997  end if
998  !
999  ! -- FINF
1000  rval1 = this%sinf_pvar(i)
1001  call this%uzfobj%setdatafinf(i, rval1)
1002  !
1003  ! -- PET, EXTDP
1004  rval1 = this%pet_pvar(i)
1005  rval2 = this%extdp(i)
1006  call this%uzfobj%setdataet(i, ivertflag, rval1, rval2)
1007  !
1008  ! -- ETWC
1009  rval1 = this%extwc_pvar(i)
1010  call this%uzfobj%setdataetwc(i, ivertflag, rval1)
1011  !
1012  ! -- HA, HROOT, ROOTACT
1013  rval1 = this%ha_pvar(i)
1014  rval2 = this%hroot_pvar(i)
1015  rval3 = this%rootact_pvar(i)
1016  call this%uzfobj%setdataetha(i, ivertflag, rval1, rval2, rval3)
1017  end do
1018  !
1019  ! -- check uzfarea
1020  if (this%iauxmultcol > 0) then
1021  call this%check_cell_area()
1022  end if
1023  !
1024  ! -- pakmvrobj ad
1025  if (this%imover == 1) then
1026  call this%pakmvrobj%ad()
1027  end if
1028  !
1029  ! -- For each observation, push simulated value and corresponding
1030  ! simulation time from "current" to "preceding" and reset
1031  ! "current" value.
1032  call this%obs%obs_ad()
1033  !
1034  ! -- Return
1035  return
1036  end subroutine uzf_ad
1037 
1038  !> @brief Formulate the HCOF and RHS terms
1039  !!
1040  !! - skip if no UZF cells
1041  !! - calculate hcof and rhs
1042  !<
1043  subroutine uzf_cf(this)
1044  ! -- modules
1045  ! -- dummy
1046  class(uzftype) :: this
1047  ! -- locals
1048  integer(I4B) :: n
1049  !
1050  ! -- Return if no UZF cells
1051  if (this%nodes == 0) return
1052  !
1053  ! -- Store values at start of outer iteration to compare with calculated
1054  ! values for convergence check
1055  do n = 1, this%maxbound
1056  this%rejinf0(n) = this%rejinf(n)
1057  this%rch0(n) = this%rch(n)
1058  this%gwd0(n) = this%gwd(n)
1059  end do
1060  !
1061  ! -- Return
1062  return
1063  end subroutine uzf_cf
1064 
1065  !> @brief Copy rhs and hcof into solution rhs and amat
1066  !<
1067  subroutine uzf_fc(this, rhs, ia, idxglo, matrix_sln)
1068  ! -- dummy
1069  class(uzftype) :: this
1070  real(DP), dimension(:), intent(inout) :: rhs
1071  integer(I4B), dimension(:), intent(in) :: ia
1072  integer(I4B), dimension(:), intent(in) :: idxglo
1073  class(matrixbasetype), pointer :: matrix_sln
1074  ! -- local
1075  integer(I4B) :: i, n, ipos
1076  !
1077  ! -- pakmvrobj fc
1078  if (this%imover == 1) then
1079  call this%pakmvrobj%fc()
1080  end if
1081  !
1082  ! -- Solve UZF; set reset_state to true so that waves are reset back to
1083  ! initial position for each outer iteration
1084  call this%uzf_solve(reset_state=.true.)
1085  !
1086  ! -- Copy package rhs and hcof into solution rhs and amat
1087  do i = 1, this%nodes
1088  n = this%nodelist(i)
1089  rhs(n) = rhs(n) + this%rhs(i)
1090  ipos = ia(n)
1091  call matrix_sln%add_value_pos(idxglo(ipos), this%hcof(i))
1092  end do
1093  !
1094  ! -- Return
1095  return
1096  end subroutine uzf_fc
1097 
1098  !> @brief Fill newton terms
1099  !<
1100  subroutine uzf_fn(this, rhs, ia, idxglo, matrix_sln)
1101  ! -- dummy
1102  class(uzftype) :: this
1103  real(DP), dimension(:), intent(inout) :: rhs
1104  integer(I4B), dimension(:), intent(in) :: ia
1105  integer(I4B), dimension(:), intent(in) :: idxglo
1106  class(matrixbasetype), pointer :: matrix_sln
1107  ! -- local
1108  integer(I4B) :: i, n
1109  integer(I4B) :: ipos
1110  !
1111  ! -- Add derivative terms to rhs and amat
1112  do i = 1, this%nodes
1113  n = this%nodelist(i)
1114  ipos = ia(n)
1115  call matrix_sln%add_value_pos(idxglo(ipos), this%deriv(i))
1116  rhs(n) = rhs(n) + this%deriv(i) * this%xnew(n)
1117  end do
1118  !
1119  ! -- Return
1120  return
1121  end subroutine uzf_fn
1122 
1123  !> @brief Final convergence check for package
1124  !<
1125  subroutine uzf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak)
1126  ! -- modules
1127  use tdismodule, only: totim, kstp, kper, delt
1128  ! -- dummy
1129  class(uzftype), intent(inout) :: this
1130  integer(I4B), intent(in) :: innertot
1131  integer(I4B), intent(in) :: kiter
1132  integer(I4B), intent(in) :: icnvgmod
1133  integer(I4B), intent(in) :: iend
1134  character(len=LENPAKLOC), intent(inout) :: cpak
1135  integer(I4B), intent(inout) :: ipak
1136  real(DP), intent(inout) :: dpak
1137  ! -- local
1138  character(len=LENPAKLOC) :: cloc
1139  character(len=LINELENGTH) :: tag
1140  integer(I4B) :: icheck
1141  integer(I4B) :: ipakfail
1142  integer(I4B) :: locdrejinfmax
1143  integer(I4B) :: locdrchmax
1144  integer(I4B) :: locdseepmax
1145  integer(I4B) :: locdqfrommvrmax
1146  integer(I4B) :: ntabrows
1147  integer(I4B) :: ntabcols
1148  integer(I4B) :: n
1149  real(DP) :: q
1150  real(DP) :: q0
1151  real(DP) :: qtolfact
1152  real(DP) :: drejinf
1153  real(DP) :: drejinfmax
1154  real(DP) :: drch
1155  real(DP) :: drchmax
1156  real(DP) :: dseep
1157  real(DP) :: dseepmax
1158  real(DP) :: dqfrommvr
1159  real(DP) :: dqfrommvrmax
1160  !
1161  ! -- initialize local variables
1162  icheck = this%iconvchk
1163  ipakfail = 0
1164  locdrejinfmax = 0
1165  locdrchmax = 0
1166  locdseepmax = 0
1167  locdqfrommvrmax = 0
1168  drejinfmax = dzero
1169  drchmax = dzero
1170  dseepmax = dzero
1171  dqfrommvrmax = dzero
1172  !
1173  ! -- if not saving package convergence data on check convergence if
1174  ! the model is considered converged
1175  if (this%ipakcsv == 0) then
1176  if (icnvgmod == 0) then
1177  icheck = 0
1178  end if
1179  else
1180  !
1181  ! -- header for package csv
1182  if (.not. associated(this%pakcsvtab)) then
1183  !
1184  ! -- determine the number of columns and rows
1185  ntabrows = 1
1186  ntabcols = 9
1187  if (this%iseepflag == 1) then
1188  ntabcols = ntabcols + 2
1189  end if
1190  if (this%imover == 1) then
1191  ntabcols = ntabcols + 2
1192  end if
1193  !
1194  ! -- setup table
1195  call table_cr(this%pakcsvtab, this%packName, '')
1196  call this%pakcsvtab%table_df(ntabrows, ntabcols, this%ipakcsv, &
1197  lineseparator=.false., separator=',', &
1198  finalize=.false.)
1199  !
1200  ! -- add columns to package csv
1201  tag = 'total_inner_iterations'
1202  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
1203  tag = 'totim'
1204  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
1205  tag = 'kper'
1206  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
1207  tag = 'kstp'
1208  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
1209  tag = 'nouter'
1210  call this%pakcsvtab%initialize_column(tag, 10, alignment=tableft)
1211  tag = 'drejinfmax'
1212  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1213  tag = 'drejinfmax_loc'
1214  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1215  tag = 'drchmax'
1216  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1217  tag = 'drchmax_loc'
1218  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1219  if (this%iseepflag == 1) then
1220  tag = 'dseepmax'
1221  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1222  tag = 'dseepmax_loc'
1223  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1224  end if
1225  if (this%imover == 1) then
1226  tag = 'dqfrommvrmax'
1227  call this%pakcsvtab%initialize_column(tag, 15, alignment=tableft)
1228  tag = 'dqfrommvrmax_loc'
1229  call this%pakcsvtab%initialize_column(tag, 16, alignment=tableft)
1230  end if
1231  end if
1232  end if
1233  !
1234  ! -- perform package convergence check
1235  if (icheck /= 0) then
1236  final_check: do n = 1, this%nodes
1237  !
1238  ! -- set the Q to length factor
1239  qtolfact = delt / this%uzfobj%uzfarea(n)
1240  !
1241  ! -- rejected infiltration
1242  drejinf = qtolfact * (this%rejinf0(n) - this%rejinf(n))
1243  !
1244  ! -- groundwater recharge
1245  drch = qtolfact * (this%rch0(n) - this%rch(n))
1246  !
1247  ! -- groundwater seepage to the land surface
1248  dseep = dzero
1249  if (this%iseepflag == 1) then
1250  dseep = qtolfact * (this%gwd0(n) - this%gwd(n))
1251  end if
1252  !
1253  ! -- q from mvr
1254  dqfrommvr = dzero
1255  if (this%imover == 1) then
1256  q = this%pakmvrobj%get_qfrommvr(n)
1257  q0 = this%pakmvrobj%get_qfrommvr0(n)
1258  dqfrommvr = qtolfact * (q0 - q)
1259  end if
1260  !
1261  ! -- evaluate magnitude of differences
1262  if (n == 1) then
1263  drejinfmax = drejinf
1264  locdrejinfmax = n
1265  drchmax = drch
1266  locdrchmax = n
1267  dseepmax = dseep
1268  locdseepmax = n
1269  dqfrommvrmax = dqfrommvr
1270  locdqfrommvrmax = n
1271  else
1272  if (abs(drejinf) > abs(drejinfmax)) then
1273  drejinfmax = drejinf
1274  locdrejinfmax = n
1275  end if
1276  if (abs(drch) > abs(drchmax)) then
1277  drchmax = drch
1278  locdrchmax = n
1279  end if
1280  if (abs(dseep) > abs(dseepmax)) then
1281  dseepmax = dseep
1282  locdseepmax = n
1283  end if
1284  if (abs(dqfrommvr) > abs(dqfrommvrmax)) then
1285  dqfrommvrmax = dqfrommvr
1286  locdqfrommvrmax = n
1287  end if
1288  end if
1289  end do final_check
1290  !
1291  ! -- set dpak and cpak
1292  if (abs(drejinfmax) > abs(dpak)) then
1293  ipak = locdrejinfmax
1294  dpak = drejinfmax
1295  write (cloc, "(a,'-',a)") trim(this%packName), 'rejinf'
1296  cpak = trim(cloc)
1297  end if
1298  if (abs(drchmax) > abs(dpak)) then
1299  ipak = locdrchmax
1300  dpak = drchmax
1301  write (cloc, "(a,'-',a)") trim(this%packName), 'rech'
1302  cpak = trim(cloc)
1303  end if
1304  if (this%iseepflag == 1) then
1305  if (abs(dseepmax) > abs(dpak)) then
1306  ipak = locdseepmax
1307  dpak = dseepmax
1308  write (cloc, "(a,'-',a)") trim(this%packName), 'seep'
1309  cpak = trim(cloc)
1310  end if
1311  end if
1312  if (this%imover == 1) then
1313  if (abs(dqfrommvrmax) > abs(dpak)) then
1314  ipak = locdqfrommvrmax
1315  dpak = dqfrommvrmax
1316  write (cloc, "(a,'-',a)") trim(this%packName), 'qfrommvr'
1317  cpak = trim(cloc)
1318  end if
1319  end if
1320  !
1321  ! -- write convergence data to package csv
1322  if (this%ipakcsv /= 0) then
1323  !
1324  ! -- write the data
1325  call this%pakcsvtab%add_term(innertot)
1326  call this%pakcsvtab%add_term(totim)
1327  call this%pakcsvtab%add_term(kper)
1328  call this%pakcsvtab%add_term(kstp)
1329  call this%pakcsvtab%add_term(kiter)
1330  call this%pakcsvtab%add_term(drejinfmax)
1331  call this%pakcsvtab%add_term(locdrejinfmax)
1332  call this%pakcsvtab%add_term(drchmax)
1333  call this%pakcsvtab%add_term(locdrchmax)
1334  if (this%iseepflag == 1) then
1335  call this%pakcsvtab%add_term(dseepmax)
1336  call this%pakcsvtab%add_term(locdseepmax)
1337  end if
1338  if (this%imover == 1) then
1339  call this%pakcsvtab%add_term(dqfrommvrmax)
1340  call this%pakcsvtab%add_term(locdqfrommvrmax)
1341  end if
1342  !
1343  ! -- finalize the package csv
1344  if (iend == 1) then
1345  call this%pakcsvtab%finalize_table()
1346  end if
1347  end if
1348  end if
1349  !
1350  ! -- Return
1351  return
1352  end subroutine uzf_cc
1353 
1354  !> @brief Calculate flows
1355  !<
1356  subroutine uzf_cq(this, x, flowja, iadv)
1357  ! -- modules
1358  use tdismodule, only: delt
1360  use budgetmodule, only: budgettype
1361  ! -- dummy
1362  class(uzftype), intent(inout) :: this
1363  real(DP), dimension(:), intent(in) :: x
1364  real(DP), dimension(:), contiguous, intent(inout) :: flowja
1365  integer(I4B), optional, intent(in) :: iadv
1366  ! -- local
1367  integer(I4B) :: i
1368  integer(I4B) :: n
1369  real(DP) :: qout
1370  real(DP) :: qfact
1371  real(DP) :: qtomvr
1372  real(DP) :: q
1373  ! -- for observations
1374  ! -- formats
1375  character(len=*), parameter :: fmttkk = &
1376  &"(1X,/1X,A,' PERIOD ',I0,' STEP ',I0)"
1377  !
1378  ! -- Make uzf solution for budget calculations, and then reset waves.
1379  ! Final uzf solve will be done as part of ot().
1380  call this%uzf_solve(reset_state=.true.)
1381  !
1382  ! -- call base functionality in bnd_cq. This will calculate uzf-gwf flows
1383  ! and put them into this%simvals and this%simvtomvr
1384  call this%BndType%bnd_cq(x, flowja, iadv=1)
1385  !
1386  ! -- Go through and process each UZF cell
1387  do i = 1, this%nodes
1388  !
1389  ! -- Initialize variables
1390  n = this%nodelist(i)
1391  !
1392  ! -- Skip if cell is not active
1393  if (this%ibound(n) < 1) cycle
1394  !
1395  ! -- infiltration terms
1396  this%appliedinf(i) = this%uzfobj%sinf(i) * this%uzfobj%uzfarea(i)
1397  this%infiltration(i) = this%uzfobj%surflux(i) * this%uzfobj%uzfarea(i)
1398  !
1399  ! -- qtomvr
1400  qout = this%rejinf(i) + this%uzfobj%surfseep(i)
1401  qtomvr = dzero
1402  if (this%imover == 1) then
1403  qtomvr = this%pakmvrobj%get_qtomvr(i)
1404  end if
1405  !
1406  ! -- rejected infiltration
1407  qfact = dzero
1408  if (qout > dzero) then
1409  qfact = this%rejinf(i) / qout
1410  end if
1411  q = this%rejinf(i)
1412  this%rejinftomvr(i) = qfact * qtomvr
1413  !
1414  ! -- set rejected infiltration to the remainder
1415  q = q - this%rejinftomvr(i)
1416  !
1417  ! -- values less than zero represent a volumetric error resulting
1418  ! from qtomvr being greater than water available to the mover
1419  if (q < dzero) then
1420  q = dzero
1421  end if
1422  this%rejinf(i) = q
1423  !
1424  ! -- calculate groundwater discharge and what goes to mover
1425  this%gwd(i) = this%uzfobj%surfseep(i)
1426  qfact = dzero
1427  if (qout > dzero) then
1428  qfact = this%gwd(i) / qout
1429  end if
1430  q = this%gwd(i)
1431  this%gwdtomvr(i) = qfact * qtomvr
1432  !
1433  ! -- set groundwater discharge to the remainder
1434  q = q - this%gwdtomvr(i)
1435  !
1436  ! -- values less than zero represent a volumetric error resulting
1437  ! from qtomvr being greater than water available to the mover
1438  if (q < dzero) then
1439  q = dzero
1440  end if
1441  this%gwd(i) = q
1442  !
1443  ! -- calculate and store remaining budget terms
1444  this%gwet_pvar(i) = this%uzfobj%gwet(i)
1445  this%uzet(i) = this%uzfobj%etact(i) * this%uzfobj%uzfarea(i) / delt
1446  !
1447  ! -- End of UZF cell loop
1448  !
1449  end do
1450  !
1451  ! -- fill the budget object
1452  call this%uzf_fill_budobj()
1453  !
1454  ! -- Return
1455  return
1456  end subroutine uzf_cq
1457 
1458  function get_storage_change(top, bot, carea, hold, hnew, wcold, wcnew, &
1459  thtr, delt, iss) result(qsto)
1460  ! -- dummy
1461  real(dp), intent(in) :: top
1462  real(dp), intent(in) :: bot
1463  real(dp), intent(in) :: hold
1464  real(dp), intent(in) :: hnew
1465  real(dp), intent(in) :: wcold
1466  real(dp), intent(in) :: wcnew
1467  real(dp), intent(in) :: thtr
1468  real(dp), intent(in) :: carea
1469  real(dp), intent(in) :: delt
1470  integer(I4B) :: iss
1471  ! -- return
1472  real(dp) :: qsto
1473  ! -- local
1474  real(dp) :: thknew
1475  real(dp) :: thkold
1476  if (iss == 0) then
1477  thknew = top - max(bot, hnew)
1478  thkold = top - max(bot, hold)
1479  qsto = dzero
1480  if (thknew > dzero) then
1481  qsto = qsto + thknew * (wcnew - thtr)
1482  end if
1483  if (thkold > dzero) then
1484  qsto = qsto - thkold * (wcold - thtr)
1485  end if
1486  qsto = qsto * carea / delt
1487  else
1488  qsto = dzero
1489  end if
1490  !
1491  ! -- Return
1492  return
1493  end function get_storage_change
1494 
1495  !> @brief Add package ratin/ratout to model budget
1496  !<
1497  subroutine uzf_bd(this, model_budget)
1498  ! -- add package ratin/ratout to model budget
1499  use tdismodule, only: delt
1501  class(uzftype) :: this
1502  type(budgettype), intent(inout) :: model_budget
1503  real(DP) :: ratin
1504  real(DP) :: ratout
1505  integer(I4B) :: isuppress_output
1506  isuppress_output = 0
1507  !
1508  ! -- Calculate flow from uzf to gwf (UZF-GWRCH)
1509  call rate_accumulator(this%rch, ratin, ratout)
1510  call model_budget%addentry(ratin, ratout, delt, this%bdtxt(2), &
1511  isuppress_output, this%packName)
1512  !
1513  ! -- GW discharge and GW discharge to mover
1514  if (this%iseepflag == 1) then
1515  call rate_accumulator(-this%gwd, ratin, ratout)
1516  call model_budget%addentry(ratin, ratout, delt, this%bdtxt(3), &
1517  isuppress_output, this%packName)
1518  if (this%imover == 1) then
1519  call rate_accumulator(-this%gwdtomvr, ratin, ratout)
1520  call model_budget%addentry(ratin, ratout, delt, this%bdtxt(5), &
1521  isuppress_output, this%packName)
1522  end if
1523  end if
1524  !
1525  ! -- groundwater et (gwet array is positive, so switch ratin/ratout)
1526  if (this%igwetflag /= 0) then
1527  call rate_accumulator(-this%gwet_pvar, ratin, ratout)
1528  call model_budget%addentry(ratin, ratout, delt, this%bdtxt(4), &
1529  isuppress_output, this%packName)
1530  end if
1531  !
1532  ! -- Return
1533  return
1534  end subroutine uzf_bd
1535 
1536  !> @brief Write flows to binary file and/or print flows to budget
1537  !<
1538  subroutine uzf_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap)
1539  ! -- modules
1540  use constantsmodule, only: lenboundname, dzero
1542  ! -- dummy
1543  class(uzftype) :: this
1544  integer(I4B), intent(in) :: icbcfl
1545  integer(I4B), intent(in) :: ibudfl
1546  integer(I4B), intent(in) :: icbcun
1547  integer(I4B), dimension(:), optional, intent(in) :: imap
1548  ! -- local
1549  character(len=LINELENGTH) :: title
1550  integer(I4B) :: itxt
1551  !
1552  ! -- UZF-GWRCH
1553  itxt = 2
1554  title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// &
1555  trim(this%packName)//') FLOW RATES'
1556  call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, &
1557  this%outputtab, this%nbound, this%nodelist, &
1558  this%rch, this%ibound, title, this%bdtxt(itxt), &
1559  this%ipakcb, this%dis, this%naux, &
1560  this%name_model, this%name_model, &
1561  this%name_model, this%packName, this%auxname, &
1562  this%auxvar, this%iout, this%inamedbound, &
1563  this%boundname)
1564  !
1565  ! -- UZF-GWD
1566  if (this%iseepflag == 1) then
1567  itxt = 3
1568  title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// &
1569  trim(this%packName)//') FLOW RATES'
1570  call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, &
1571  this%outputtab, this%nbound, this%nodelist, &
1572  -this%gwd, this%ibound, title, &
1573  this%bdtxt(itxt), this%ipakcb, this%dis, &
1574  this%naux, this%name_model, this%name_model, &
1575  this%name_model, this%packName, this%auxname, &
1576  this%auxvar, this%iout, this%inamedbound, &
1577  this%boundname)
1578  !
1579  ! -- UZF-GWD TO-MVR
1580  if (this%imover == 1) then
1581  itxt = 5
1582  title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// &
1583  trim(this%packName)//') FLOW RATES'
1584  call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, &
1585  this%outputtab, this%nbound, this%nodelist, &
1586  -this%gwdtomvr, this%ibound, title, &
1587  this%bdtxt(itxt), this%ipakcb, this%dis, &
1588  this%naux, this%name_model, this%name_model, &
1589  this%name_model, this%packName, &
1590  this%auxname, this%auxvar, this%iout, &
1591  this%inamedbound, this%boundname)
1592  end if
1593  end if
1594  !
1595  ! -- UZF-GWET
1596  if (this%igwetflag /= 0) then
1597  itxt = 4
1598  title = trim(adjustl(this%bdtxt(itxt)))//' PACKAGE ('// &
1599  trim(this%packName)//') FLOW RATES'
1600  call save_print_model_flows(icbcfl, ibudfl, icbcun, this%iprflow, &
1601  this%outputtab, this%nbound, this%nodelist, &
1602  -this%gwet_pvar, this%ibound, title, &
1603  this%bdtxt(itxt), this%ipakcb, this%dis, &
1604  this%naux, this%name_model, this%name_model, &
1605  this%name_model, this%packName, this%auxname, &
1606  this%auxvar, this%iout, this%inamedbound, &
1607  this%boundname)
1608  end if
1609  !
1610  ! -- Return
1611  return
1612  end subroutine uzf_ot_model_flows
1613 
1614  !> @brief Output UZF package flow terms
1615  !<
1616  subroutine uzf_ot_package_flows(this, icbcfl, ibudfl)
1617  ! -- modules
1618  use tdismodule, only: kstp, kper, delt, pertim, totim
1619  ! -- dummy
1620  class(uzftype) :: this
1621  integer(I4B), intent(in) :: icbcfl
1622  integer(I4B), intent(in) :: ibudfl
1623  integer(I4B) :: ibinun
1624  !
1625  ! -- write the flows from the budobj
1626  ibinun = 0
1627  if (this%ibudgetout /= 0) then
1628  ibinun = this%ibudgetout
1629  end if
1630  if (icbcfl == 0) ibinun = 0
1631  if (ibinun > 0) then
1632  call this%budobj%save_flows(this%dis, ibinun, kstp, kper, delt, &
1633  pertim, totim, this%iout)
1634  end if
1635  !
1636  ! -- Print lake flows table
1637  if (ibudfl /= 0 .and. this%iprflow /= 0) then
1638  call this%budobj%write_flowtable(this%dis, kstp, kper)
1639  end if
1640  !
1641  ! -- Return
1642  return
1643  end subroutine uzf_ot_package_flows
1644 
1645  !> @brief Save UZF-calculated values to binary file
1646  !<
1647  subroutine uzf_ot_dv(this, idvsave, idvprint)
1648  ! -- modules
1649  use tdismodule, only: kstp, kper, pertim, totim
1650  ! -- dummy
1651  use inputoutputmodule, only: ulasav
1652  class(uzftype) :: this
1653  integer(I4B), intent(in) :: idvsave
1654  integer(I4B), intent(in) :: idvprint
1655  ! -- local
1656  integer(I4B) :: ibinun
1657  !
1658  ! -- set unit number for binary dependent variable output
1659  ibinun = 0
1660  if (this%iwcontout /= 0) then
1661  ibinun = this%iwcontout
1662  end if
1663  if (idvsave == 0) ibinun = 0
1664  !
1665  ! -- write uzf binary moisture-content output
1666  if (ibinun > 0) then
1667  call ulasav(this%wcnew, ' WATER-CONTENT', kstp, kper, pertim, &
1668  totim, this%nodes, 1, 1, ibinun)
1669  end if
1670  !
1671  ! -- Return
1672  return
1673  end subroutine uzf_ot_dv
1674 
1675  !> @brief Write UZF budget to listing file
1676  !<
1677  subroutine uzf_ot_bdsummary(this, kstp, kper, iout, ibudfl)
1678  ! -- module
1679  use tdismodule, only: totim, delt
1680  ! -- dummy
1681  class(uzftype) :: this !< UzfType object
1682  integer(I4B), intent(in) :: kstp !< time step number
1683  integer(I4B), intent(in) :: kper !< period number
1684  integer(I4B), intent(in) :: iout !< flag and unit number for the model listing file
1685  integer(I4B), intent(in) :: ibudfl !< flag indicating budget should be written
1686  !
1687  call this%budobj%write_budtable(kstp, kper, iout, ibudfl, totim, delt)
1688  !
1689  ! -- Return
1690  return
1691  end subroutine uzf_ot_bdsummary
1692 
1693  !> @brief Formulate the HCOF and RHS terms
1694  !<
1695  subroutine uzf_solve(this, reset_state)
1696  ! -- modules
1697  use tdismodule, only: delt
1698  logical, intent(in) :: reset_state !< flag indicating that waves should be reset after solution
1699  ! -- dummy
1700  class(uzftype) :: this
1701  ! -- locals
1702  integer(I4B) :: i, ivertflag
1703  integer(I4B) :: n, m, ierr
1704  real(DP) :: trhs1, thcof1, trhs2, thcof2
1705  real(DP) :: hgwf, uzderiv, derivgwet
1706  real(DP) :: qfrommvr
1707  real(DP) :: qformvr
1708  real(DP) :: wc
1709  real(DP) :: watabold
1710  !
1711  ! -- Initialize
1712  ierr = 0
1713  do i = 1, this%nodes
1714  this%uzfobj%pet(i) = this%uzfobj%petmax(i)
1715  end do
1716  !
1717  ! -- Calculate hcof and rhs for each UZF entry
1718  do i = 1, this%nodes
1719  !
1720  ! -- Initialize hcof/rhs terms
1721  this%hcof(i) = dzero
1722  this%rhs(i) = dzero
1723  thcof1 = dzero
1724  thcof2 = dzero
1725  trhs1 = dzero
1726  trhs2 = dzero
1727  uzderiv = dzero
1728  derivgwet = dzero
1729  !
1730  ! -- Initialize variables
1731  n = this%nodelist(i)
1732  ivertflag = this%uzfobj%ivertcon(i)
1733  watabold = this%uzfobj%watabold(i)
1734  !
1735  if (this%ibound(n) > 0) then
1736  !
1737  ! -- Water mover added to infiltration
1738  qfrommvr = dzero
1739  qformvr = dzero
1740  if (this%imover == 1) then
1741  qfrommvr = this%pakmvrobj%get_qfrommvr(i)
1742  end if
1743  !
1744  hgwf = this%xnew(n)
1745  m = n
1746  !
1747  ! -- solve for current uzf cell
1748  call this%uzfobj%solve(this%uzfobjwork, ivertflag, i, &
1749  this%totfluxtot, this%ietflag, &
1750  this%issflag, this%iseepflag, hgwf, &
1751  qfrommvr, ierr, &
1752  reset_state=reset_state, &
1753  trhs=trhs1, thcof=thcof1, deriv=uzderiv, &
1754  watercontent=wc)
1755  !
1756  ! -- terminate if an error condition has occurred
1757  if (ierr > 0) then
1758  if (ierr == 1) &
1759  errmsg = 'UZF variable NWAVESETS needs to be increased.'
1760  call store_error(errmsg, terminate=.true.)
1761  end if
1762  !
1763  ! -- Calculate gwet
1764  if (this%igwetflag > 0) then
1765  call this%uzfobj%setgwpet(i)
1766  call this%uzfobj%simgwet(this%igwetflag, i, hgwf, trhs2, thcof2, &
1767  derivgwet)
1768  end if
1769  !
1770  ! -- distribute PET to deeper cells
1771  if (this%ietflag > 0) then
1772  if (this%uzfobj%ivertcon(i) > 0) then
1773  call this%uzfobj%setbelowpet(i, ivertflag)
1774  end if
1775  end if
1776  !
1777  ! -- store derivative for Newton addition to equations in _fn()
1778  this%deriv(i) = uzderiv + derivgwet
1779  !
1780  ! -- save current rejected infiltration, groundwater recharge, and
1781  ! groundwater discharge
1782  this%rejinf(i) = this%uzfobj%finf_rej(i) * this%uzfobj%uzfarea(i)
1783  this%rch(i) = this%uzfobj%totflux(i) * this%uzfobj%uzfarea(i) / delt
1784  this%gwd(i) = this%uzfobj%surfseep(i)
1785  !
1786  ! -- add to hcof and rhs
1787  this%hcof(i) = thcof1 + thcof2
1788  this%rhs(i) = -trhs1 + trhs2
1789  !
1790  ! -- add spring discharge and rejected infiltration to mover
1791  if (this%imover == 1) then
1792  qformvr = this%gwd(i) + this%rejinf(i)
1793  call this%pakmvrobj%accumulate_qformvr(i, qformvr)
1794  end if
1795  !
1796  ! -- Store water content
1797  this%wcnew(i) = wc
1798  !
1799  ! -- Calculate change in mobile storage
1800  this%qsto(i) = get_storage_change(this%uzfobj%celtop(i), &
1801  this%uzfobj%celbot(i), &
1802  this%uzfobj%uzfarea(i), &
1803  watabold, &
1804  this%uzfobj%watab(i), &
1805  this%wcold(i), this%wcnew(i), &
1806  this%uzfobj%thtr(i), delt, this%issflag)
1807  !
1808  end if
1809  end do
1810  !
1811  ! -- Return
1812  return
1813  end subroutine uzf_solve
1814 
1815  !> @brief Define the list heading that is written to iout when PRINT_INPUT
1816  !! option is used
1817  !<
1818  subroutine define_listlabel(this)
1819  ! -- dummy
1820  class(uzftype), intent(inout) :: this
1821  !
1822  ! -- create the header list label
1823  this%listlabel = trim(this%filtyp)//' NO.'
1824  if (this%dis%ndim == 3) then
1825  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER'
1826  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'ROW'
1827  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'COL'
1828  elseif (this%dis%ndim == 2) then
1829  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'LAYER'
1830  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'CELL2D'
1831  else
1832  write (this%listlabel, '(a, a7)') trim(this%listlabel), 'NODE'
1833  end if
1834  write (this%listlabel, '(a, a16)') trim(this%listlabel), 'STRESS RATE'
1835  if (this%inamedbound == 1) then
1836  write (this%listlabel, '(a, a16)') trim(this%listlabel), 'BOUNDARY NAME'
1837  end if
1838  !
1839  ! -- Return
1840  return
1841  end subroutine define_listlabel
1842 
1843  !> @brief Identify overlying cell ID based on user-specified mapping
1844  !<
1845  subroutine findcellabove(this, n, nml)
1846  ! -- dummy
1847  class(uzftype) :: this
1848  integer(I4B), intent(in) :: n
1849  integer(I4B), intent(inout) :: nml
1850  ! -- local
1851  integer(I4B) :: m, ipos
1852  !
1853  ! -- Return nml = n if no cell is above it
1854  nml = n
1855  do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1
1856  m = this%dis%con%ja(ipos)
1857  if (this%dis%con%ihc(ipos) /= 0) then
1858  if (n < m) then
1859  ! -- m is beneath n
1860  else
1861  nml = m ! -- m is above n
1862  exit
1863  end if
1864  end if
1865  end do
1866  !
1867  ! -- Return
1868  return
1869  end subroutine findcellabove
1870 
1871  !> @brief Read UZF cell properties and set them for UzfCellGroup type
1872  !<
1873  subroutine read_cell_properties(this)
1874  ! -- modules
1875  use inputoutputmodule, only: urword
1876  use simmodule, only: store_error, count_errors
1877  ! -- dummy
1878  class(uzftype), intent(inout) :: this
1879  ! -- local
1880  character(len=LINELENGTH) :: cellid
1881  integer(I4B) :: ierr
1882  integer(I4B) :: i, n
1883  integer(I4B) :: j
1884  integer(I4B) :: ic
1885  integer(I4B) :: jcol
1886  logical :: isfound, endOfBlock
1887  integer(I4B) :: landflag
1888  integer(I4B) :: ivertcon
1889  real(DP) :: surfdep, vks, thtr, thts, thti, eps, hgwf
1890  integer(I4B), dimension(:), allocatable :: rowmaxnnz
1891  type(sparsematrix) :: sparse
1892  integer(I4B), dimension(:), allocatable :: nboundchk
1893  !
1894  ! -- allocate space for node counter and initialize
1895  allocate (rowmaxnnz(this%dis%nodes))
1896  do n = 1, this%dis%nodes
1897  rowmaxnnz(n) = 0
1898  end do
1899  !
1900  ! -- allocate space for local variables
1901  allocate (nboundchk(this%nodes))
1902  do n = 1, this%nodes
1903  nboundchk(n) = 0
1904  end do
1905  !
1906  ! -- initialize variables
1907  landflag = 0
1908  ivertcon = 0
1909  surfdep = dzero
1910  vks = dzero
1911  thtr = dzero
1912  thts = dzero
1913  thti = dzero
1914  eps = dzero
1915  hgwf = dzero
1916  !
1917  ! -- get uzf properties block
1918  call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, &
1919  supportopenclose=.true.)
1920  !
1921  ! -- parse locations block if detected
1922  if (isfound) then
1923  write (this%iout, '(/1x,3a)') 'PROCESSING ', trim(adjustl(this%text)), &
1924  ' PACKAGEDATA'
1925  do
1926  call this%parser%GetNextLine(endofblock)
1927  if (endofblock) exit
1928  !
1929  ! -- get uzf cell number
1930  i = this%parser%GetInteger()
1931 
1932  if (i < 1 .or. i > this%nodes) then
1933  write (errmsg, '(2(a,1x),i0,a)') &
1934  'IUZNO must be greater than 0 and less than', &
1935  'or equal to', this%nodes, '.'
1936  call store_error(errmsg)
1937  cycle
1938  end if
1939  !
1940  ! -- increment nboundchk
1941  nboundchk(i) = nboundchk(i) + 1
1942  !
1943  ! -- store the reduced gwf nodenumber in igwfnode
1944  call this%parser%GetCellid(this%dis%ndim, cellid)
1945  ic = this%dis%noder_from_cellid(cellid, &
1946  this%parser%iuactive, this%iout)
1947  this%igwfnode(i) = ic
1948  rowmaxnnz(ic) = rowmaxnnz(ic) + 1
1949  !
1950  ! -- landflag
1951  landflag = this%parser%GetInteger()
1952  if (landflag < 0 .OR. landflag > 1) then
1953  write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') &
1954  'LANDFLAG for uzf cell', i, &
1955  'must be 0 or 1 (specified value is', landflag, ').'
1956  call store_error(errmsg)
1957  end if
1958  !
1959  ! -- ivertcon
1960  ivertcon = this%parser%GetInteger()
1961  if (ivertcon < 0 .OR. ivertcon > this%nodes) then
1962  write (errmsg, '(a,1x,i0,1x,a,1x,i0,a)') &
1963  'IVERTCON for uzf cell', i, &
1964  'must be 0 or less than NUZFCELLS (specified value is', &
1965  ivertcon, ').'
1966  call store_error(errmsg)
1967  end if
1968  !
1969  ! -- surfdep
1970  surfdep = this%parser%GetDouble()
1971  if (surfdep <= dzero .and. landflag > 0) then !need to check for cell thickness
1972  write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') &
1973  'SURFDEP for uzf cell', i, &
1974  'must be greater than 0 (specified value is', surfdep, ').'
1975  call store_error(errmsg)
1976  end if
1977  if (surfdep >= this%dis%top(ic) - this%dis%bot(ic)) then
1978  write (errmsg, '(a,1x,i0,1x,a)') &
1979  'SURFDEP for uzf cell', i, &
1980  'cannot be greater than the cell thickness.'
1981  call store_error(errmsg)
1982  end if
1983  !
1984  ! -- vks
1985  vks = this%parser%GetDouble()
1986  if (vks <= dzero) then
1987  write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') &
1988  'VKS for uzf cell', i, &
1989  'must be greater than 0 (specified value ia', vks, ').'
1990  call store_error(errmsg)
1991  end if
1992  !
1993  ! -- thtr
1994  thtr = this%parser%GetDouble()
1995  if (thtr <= dzero) then
1996  write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') &
1997  'THTR for uzf cell', i, &
1998  'must be greater than 0 (specified value is', thtr, ').'
1999  call store_error(errmsg)
2000  end if
2001  !
2002  ! -- thts
2003  thts = this%parser%GetDouble()
2004  if (thts <= thtr) then
2005  write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') &
2006  'THTS for uzf cell', i, &
2007  'must be greater than THTR (specified value is', thts, ').'
2008  call store_error(errmsg)
2009  end if
2010  !
2011  ! -- thti
2012  thti = this%parser%GetDouble()
2013  if (thti < thtr .OR. thti > thts) then
2014  write (errmsg, '(a,1x,i0,1x,a,1x,a,1x,g0,a)') &
2015  'THTI for uzf cell', i, &
2016  'must be greater than or equal to THTR AND less than THTS', &
2017  '(specified value is', thti, ').'
2018  call store_error(errmsg)
2019  end if
2020  !
2021  ! -- eps
2022  eps = this%parser%GetDouble()
2023  if (eps < 3.5 .OR. eps > 14) then
2024  write (errmsg, '(a,1x,i0,1x,a,1x,g0,a)') &
2025  'EPSILON for uzf cell', i, &
2026  'must be between 3.5 and 14.0 (specified value is', eps, ').'
2027  call store_error(errmsg)
2028  end if
2029  !
2030  ! -- boundname
2031  if (this%inamedbound == 1) then
2032  call this%parser%GetStringCaps(this%uzfname(i))
2033  end if
2034  !
2035  ! -- set data if there are no data errors
2036  if (count_errors() == 0) then
2037  n = this%igwfnode(i)
2038  call this%uzfobj%setdata(i, this%dis%area(n), this%dis%top(n), &
2039  this%dis%bot(n), surfdep, vks, thtr, thts, &
2040  thti, eps, this%ntrail_pvar, landflag, &
2041  ivertcon)
2042  if (ivertcon > 0) then
2043  this%iuzf2uzf = 1
2044  end if
2045  end if
2046  !
2047  end do
2048  else
2049  call store_error('Required packagedata block not found.')
2050  end if
2051  !
2052  ! -- check for duplicate or missing uzf cells
2053  do i = 1, this%nodes
2054  if (nboundchk(i) == 0) then
2055  write (errmsg, '(a,1x,i0,a)') &
2056  'No data specified for uzf cell', i, '.'
2057  call store_error(errmsg)
2058  else if (nboundchk(i) > 1) then
2059  write (errmsg, '(a,1x,i0,1x,a,1x,i0,1x,a)') &
2060  'Data for uzf cell', i, 'specified', nboundchk(i), 'times.'
2061  call store_error(errmsg)
2062  end if
2063  end do
2064  !
2065  ! -- write summary of UZF cell property error messages
2066  if (count_errors() > 0) then
2067  call this%parser%StoreErrorUnit()
2068  end if
2069  !
2070  ! -- setup sparse for connectivity used to identify multiple uzf cells per
2071  ! GWF model cell
2072  call sparse%init(this%dis%nodes, this%dis%nodes, rowmaxnnz)
2073  ! --
2074  do i = 1, this%nodes
2075  ic = this%igwfnode(i)
2076  call sparse%addconnection(ic, i, 1)
2077  end do
2078  !
2079  ! -- create ia and ja from sparse
2080  call sparse%filliaja(this%ia, this%ja, ierr)
2081  !
2082  ! -- set imaxcellcnt
2083  do i = 1, this%dis%nodes
2084  jcol = 0
2085  do j = this%ia(i), this%ia(i + 1) - 1
2086  jcol = jcol + 1
2087  end do
2088  if (jcol > this%imaxcellcnt) then
2089  this%imaxcellcnt = jcol
2090  end if
2091  end do
2092  !
2093  ! -- do an initial evaluation of the sum of uzfarea relative to the
2094  ! GWF cell area in the case that there is more than one UZF cell
2095  ! in a GWF cell and a auxmult value is not being applied to the
2096  ! calculate the UZF cell area from the GWF cell area.
2097  if (this%imaxcellcnt > 1 .and. this%iauxmultcol < 1) then
2098  call this%check_cell_area()
2099  end if
2100  !
2101  ! -- deallocate local variables
2102  deallocate (rowmaxnnz)
2103  deallocate (nboundchk)
2104  !
2105  ! -- Return
2106  return
2107  end subroutine read_cell_properties
2108 
2109  !> @brief Read UZF cell properties and set them for UZFCellGroup type
2110  !<
2111  subroutine print_cell_properties(this)
2112  ! -- dummy
2113  class(uzftype), intent(inout) :: this
2114  ! -- local
2115  character(len=20) :: cellid
2116  character(len=LINELENGTH) :: title
2117  character(len=LINELENGTH) :: tag
2118  integer(I4B) :: ntabrows
2119  integer(I4B) :: ntabcols
2120  integer(I4B) :: i
2121  integer(I4B) :: node
2122  !
2123  ! -- setup inputtab tableobj
2124  !
2125  ! -- table dimensions
2126  ntabrows = this%nodes
2127  ntabcols = 10
2128  if (this%inamedbound == 1) then
2129  ntabcols = ntabcols + 1
2130  end if
2131  !
2132  ! -- initialize table and define columns
2133  title = trim(adjustl(this%text))//' PACKAGE ('// &
2134  trim(adjustl(this%packName))//') STATIC UZF CELL DATA'
2135  call table_cr(this%inputtab, this%packName, title)
2136  call this%inputtab%table_df(ntabrows, ntabcols, this%iout)
2137  tag = 'NUMBER'
2138  call this%inputtab%initialize_column(tag, 10)
2139  tag = 'CELLID'
2140  call this%inputtab%initialize_column(tag, 20, alignment=tableft)
2141  tag = 'LANDFLAG'
2142  call this%inputtab%initialize_column(tag, 12)
2143  tag = 'IVERTCON'
2144  call this%inputtab%initialize_column(tag, 12)
2145  tag = 'SURFDEP'
2146  call this%inputtab%initialize_column(tag, 12)
2147  tag = 'VKS'
2148  call this%inputtab%initialize_column(tag, 12)
2149  tag = 'THTR'
2150  call this%inputtab%initialize_column(tag, 12)
2151  tag = 'THTS'
2152  call this%inputtab%initialize_column(tag, 12)
2153  tag = 'THTI'
2154  call this%inputtab%initialize_column(tag, 12)
2155  tag = 'EPS'
2156  call this%inputtab%initialize_column(tag, 12)
2157  if (this%inamedbound == 1) then
2158  tag = 'BOUNDNAME'
2159  call this%inputtab%initialize_column(tag, lenboundname, alignment=tableft)
2160  end if
2161  !
2162  ! -- write data for each cell
2163  do i = 1, this%nodes
2164  !
2165  ! -- get cellid
2166  node = this%igwfnode(i)
2167  if (node > 0) then
2168  call this%dis%noder_to_string(node, cellid)
2169  else
2170  cellid = 'none'
2171  end if
2172  !
2173  ! -- add data
2174  call this%inputtab%add_term(i)
2175  call this%inputtab%add_term(cellid)
2176  call this%inputtab%add_term(this%uzfobj%landflag(i))
2177  call this%inputtab%add_term(this%uzfobj%ivertcon(i))
2178  call this%inputtab%add_term(this%uzfobj%surfdep(i))
2179  call this%inputtab%add_term(this%uzfobj%vks(i))
2180  call this%inputtab%add_term(this%uzfobj%thtr(i))
2181  call this%inputtab%add_term(this%uzfobj%thts(i))
2182  call this%inputtab%add_term(this%uzfobj%thti(i))
2183  call this%inputtab%add_term(this%uzfobj%eps(i))
2184  if (this%inamedbound == 1) then
2185  call this%inputtab%add_term(this%uzfname(i))
2186  end if
2187  end do
2188  !
2189  ! -- Return
2190  return
2191  end subroutine print_cell_properties
2192 
2193  !> @brief Check UZF cell areas
2194  !<
2195  subroutine check_cell_area(this)
2196  ! -- modules
2197  use inputoutputmodule, only: urword
2198  use simmodule, only: store_error, count_errors
2199  ! -- dummy
2200  class(uzftype) :: this
2201  ! -- local
2202  character(len=16) :: cuzf
2203  character(len=20) :: cellid
2204  character(len=LINELENGTH) :: cuzfcells
2205  integer(I4B) :: i
2206  integer(I4B) :: i2
2207  integer(I4B) :: j
2208  integer(I4B) :: n
2209  integer(I4B) :: i0
2210  integer(I4B) :: i1
2211  real(DP) :: area
2212  real(DP) :: area2
2213  real(DP) :: sumarea
2214  real(DP) :: cellarea
2215  real(DP) :: d
2216  !
2217  ! -- check that the area of vertically connected uzf cells is the equal
2218  do i = 1, this%nodes
2219  !
2220  ! -- Initialize variables
2221  i2 = this%uzfobj%ivertcon(i)
2222  area = this%uzfobj%uzfarea(i)
2223  !
2224  ! Create pointer to object below
2225  if (i2 > 0) then
2226  area2 = this%uzfobj%uzfarea(i2)
2227  d = abs(area - area2)
2228  if (d > dem6) then
2229  write (errmsg, '(2(a,1x,g0,1x,a,1x,i0,1x),a)') &
2230  'UZF cell area (', area, ') for cell ', i, &
2231  'does not equal uzf cell area (', area2, ') for cell ', i2, '.'
2232  call store_error(errmsg)
2233  end if
2234  end if
2235  end do
2236  !
2237  ! -- check that the area of uzf cells in a GWF cell is less than or equal
2238  ! to the GWF cell area
2239  do n = 1, this%dis%nodes
2240  i0 = this%ia(n)
2241  i1 = this%ia(n + 1)
2242  ! -- skip gwf cells with no UZF cells
2243  if ((i1 - i0) < 1) cycle
2244  sumarea = dzero
2245  cellarea = dzero
2246  cuzfcells = ''
2247  do j = i0, i1 - 1
2248  i = this%ja(j)
2249  write (cuzf, '(i0)') i
2250  cuzfcells = trim(adjustl(cuzfcells))//' '//trim(adjustl(cuzf))
2251  sumarea = sumarea + this%uzfobj%uzfarea(i)
2252  cellarea = this%uzfobj%cellarea(i)
2253  end do
2254  ! -- calculate the difference between the sum of UZF areas and GWF cell area
2255  d = abs(sumarea - cellarea)
2256  if (d > dem6) then
2257  call this%dis%noder_to_string(n, cellid)
2258  write (errmsg, '(a,1x,g0,1x,a,1x,g0,1x,a,1x,a,1x,a,a,a)') &
2259  'Total uzf cell area (', sumarea, &
2260  ') exceeds the gwf cell area (', cellarea, ') of cell', cellid, &
2261  'which includes uzf cell(s): ', trim(adjustl(cuzfcells)), '.'
2262  call store_error(errmsg)
2263  end if
2264  end do
2265  !
2266  ! -- terminate if errors were encountered
2267  if (count_errors() > 0) then
2268  call this%parser%StoreErrorUnit()
2269  end if
2270  ! -- Return
2271  return
2272  end subroutine check_cell_area
2273 
2274  ! -- Procedures related to observations (type-bound)
2275 
2276  !> @brief Return true because uzf package supports observations
2277  !!
2278  !! Overrides BndType%bnd_obs_supported
2279  !<
2280  logical function uzf_obs_supported(this)
2281  ! -- dummy
2282  class(uzftype) :: this
2283  !
2284  uzf_obs_supported = .true.
2285  !
2286  ! -- Return
2287  return
2288  end function uzf_obs_supported
2289 
2290  !> @brief Implements bnd_df_obs
2291  !!
2292  !! Store observation type supported by uzf package.
2293  !! Overrides BndType%bnd_df_obs
2294  !<
2295  subroutine uzf_df_obs(this)
2296  ! -- dummy
2297  class(uzftype) :: this
2298  ! -- local
2299  integer(I4B) :: indx
2300  !
2301  ! -- Store obs type and assign procedure pointer
2302  !
2303  ! for recharge observation type.
2304  call this%obs%StoreObsType('uzf-gwrch', .true., indx)
2305  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2306  !
2307  ! for discharge observation type.
2308  call this%obs%StoreObsType('uzf-gwd', .true., indx)
2309  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2310  !
2311  ! for discharge observation type.
2312  call this%obs%StoreObsType('uzf-gwd-to-mvr', .true., indx)
2313  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2314  !
2315  ! for gwet observation type.
2316  call this%obs%StoreObsType('uzf-gwet', .true., indx)
2317  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2318  !
2319  ! for infiltration observation type.
2320  call this%obs%StoreObsType('infiltration', .true., indx)
2321  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2322  !
2323  ! for from mover observation type.
2324  call this%obs%StoreObsType('from-mvr', .true., indx)
2325  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2326  !
2327  ! for rejected infiltration observation type.
2328  call this%obs%StoreObsType('rej-inf', .true., indx)
2329  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2330  !
2331  ! for rejected infiltration to mover observation type.
2332  call this%obs%StoreObsType('rej-inf-to-mvr', .true., indx)
2333  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2334  !
2335  ! for uzet observation type.
2336  call this%obs%StoreObsType('uzet', .true., indx)
2337  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2338  !
2339  ! for storage observation type.
2340  call this%obs%StoreObsType('storage', .true., indx)
2341  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2342  !
2343  ! for net infiltration observation type.
2344  call this%obs%StoreObsType('net-infiltration', .true., indx)
2345  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2346  !
2347  ! for water-content observation type.
2348  call this%obs%StoreObsType('water-content', .false., indx)
2349  this%obs%obsData(indx)%ProcessIdPtr => uzf_process_obsid
2350  !
2351  ! -- Return
2352  return
2353  end subroutine uzf_df_obs
2354 
2355  !> @brief Calculate observations this time step and call ObsType%SaveOneSimval
2356  !! for each UzfType observation
2357  !<
2358  subroutine uzf_bd_obs(this)
2359  ! -- dummy
2360  class(uzftype) :: this
2361  ! -- local
2362  integer(I4B) :: i
2363  integer(I4B) :: ii
2364  integer(I4B) :: n
2365  real(DP) :: v
2366  type(observetype), pointer :: obsrv => null()
2367  !
2368  ! -- Make final uzf solution, and do not reset waves. This will advance
2369  ! the waves to their new state at the end of the time step. This should
2370  ! be the first step of the uzf ot() routines.
2371  call this%uzf_solve(reset_state=.false.)
2372  !
2373  ! Write simulated values for all uzf observations
2374  if (this%obs%npakobs > 0) then
2375  call this%obs%obs_bd_clear()
2376  do i = 1, this%obs%npakobs
2377  obsrv => this%obs%pakobs(i)%obsrv
2378  do ii = 1, obsrv%indxbnds_count
2379  n = obsrv%indxbnds(ii)
2380  v = dnodata
2381  select case (obsrv%ObsTypeId)
2382  case ('UZF-GWRCH')
2383  v = this%rch(n)
2384  case ('UZF-GWD')
2385  v = this%gwd(n)
2386  if (v > dzero) then
2387  v = -v
2388  end if
2389  case ('UZF-GWD-TO-MVR')
2390  if (this%imover == 1) then
2391  v = this%gwdtomvr(n)
2392  if (v > dzero) then
2393  v = -v
2394  end if
2395  end if
2396  case ('UZF-GWET')
2397  if (this%igwetflag > 0) then
2398  v = this%gwet_pvar(n)
2399  if (v > dzero) then
2400  v = -v
2401  end if
2402  end if
2403  case ('INFILTRATION')
2404  v = this%appliedinf(n)
2405  case ('FROM-MVR')
2406  if (this%imover == 1) then
2407  v = this%pakmvrobj%get_qfrommvr(n)
2408  end if
2409  case ('REJ-INF')
2410  v = this%rejinf(n)
2411  if (v > dzero) then
2412  v = -v
2413  end if
2414  case ('REJ-INF-TO-MVR')
2415  if (this%imover == 1) then
2416  v = this%rejinftomvr(n)
2417  if (v > dzero) then
2418  v = -v
2419  end if
2420  end if
2421  case ('UZET')
2422  if (this%ietflag /= 0) then
2423  v = this%uzet(n)
2424  if (v > dzero) then
2425  v = -v
2426  end if
2427  end if
2428  case ('STORAGE')
2429  v = -this%qsto(n)
2430  case ('NET-INFILTRATION')
2431  v = this%infiltration(n)
2432  case ('WATER-CONTENT')
2433  v = this%uzfobj%get_water_content_at_depth(n, obsrv%obsDepth)
2434  case default
2435  errmsg = 'Unrecognized observation type: '//trim(obsrv%ObsTypeId)
2436  call store_error(errmsg)
2437  end select
2438  call this%obs%SaveOneSimval(obsrv, v)
2439  end do
2440  end do
2441  !
2442  ! -- write summary of error messages
2443  if (count_errors() > 0) then
2444  call this%parser%StoreErrorUnit()
2445  end if
2446  end if
2447  !
2448  ! -- Return
2449  return
2450  end subroutine uzf_bd_obs
2451 
2452  !> @brief Process each observation
2453  !!
2454  !! Only done the first stress period since boundaries are fixed for the
2455  !! simulation
2456  !<
2457  subroutine uzf_rp_obs(this)
2458  ! -- modules
2459  use tdismodule, only: kper
2460  ! -- dummy
2461  class(uzftype), intent(inout) :: this
2462  ! -- local
2463  integer(I4B) :: i
2464  integer(I4B) :: j
2465  integer(I4B) :: n
2466  integer(I4B) :: nn
2467  integer(I4B) :: iuzid
2468  real(DP) :: obsdepth
2469  real(DP) :: dmax
2470  character(len=LENBOUNDNAME) :: bname
2471  class(observetype), pointer :: obsrv => null()
2472  ! -- formats
2473 60 format('Invalid node number in OBS input: ', i0)
2474  !
2475  if (kper == 1) then
2476  do i = 1, this%obs%npakobs
2477  obsrv => this%obs%pakobs(i)%obsrv
2478  !
2479  ! -- get node number 1
2480  nn = obsrv%NodeNumber
2481  if (nn == namedboundflag) then
2482  bname = obsrv%FeatureName
2483  !
2484  ! -- Observation location(s) is(are) based on a boundary name.
2485  ! Iterate through all boundaries to identify and store
2486  ! corresponding index(indices) in bound array.
2487  do j = 1, this%nodes
2488  if (this%boundname(j) == bname) then
2489  obsrv%BndFound = .true.
2490  obsrv%CurrentTimeStepEndValue = dzero
2491  call obsrv%AddObsIndex(j)
2492  if (obsrv%indxbnds_count == 1) then
2493  !
2494  ! -- Define intPak1 so that obs_theta is stored (for first uzf
2495  ! cell if multiple cells share the same boundname).
2496  obsrv%intPak1 = j
2497  end if
2498  end if
2499  end do
2500  else
2501  !
2502  ! -- get node number
2503  nn = obsrv%NodeNumber
2504  !
2505  ! -- put nn (a value meaningful only to UZF) in intPak1
2506  obsrv%intPak1 = nn
2507  ! -- check that node number is valid; call store_error if not
2508  if (nn < 1 .or. nn > this%nodes) then
2509  write (errmsg, 60) nn
2510  call store_error(errmsg)
2511  else
2512  obsrv%BndFound = .true.
2513  end if
2514  obsrv%CurrentTimeStepEndValue = dzero
2515  call obsrv%AddObsIndex(nn)
2516  end if
2517  !
2518  ! -- catch non-cumulative observation assigned to observation defined
2519  ! by a boundname that is assigned to more than one element
2520  if (obsrv%ObsTypeId == 'WATER-CONTENT') then
2521  n = obsrv%indxbnds_count
2522  if (n /= 1) then
2523  write (errmsg, '(a,3(1x,a))') &
2524  trim(adjustl(obsrv%ObsTypeId)), 'for observation', &
2525  trim(adjustl(obsrv%Name)), &
2526  'must be assigned to a UZF cell with a unique boundname.'
2527  call store_error(errmsg, terminate=.true.)
2528  end if
2529  !
2530  ! -- check WATER-CONTENT depth
2531  obsdepth = obsrv%Obsdepth
2532  !
2533  ! -- put obsdepth (a value meaningful only to UZF) in dblPak1
2534  obsrv%dblPak1 = obsdepth
2535  !
2536  ! -- determine maximum cell depth
2537  ! -- This is presently complicated for landflag = 1 cells and surfdep
2538  ! greater than zero. In this case, celtop is dis%top - surfdep.
2539  iuzid = obsrv%intPak1
2540  dmax = this%uzfobj%celtop(iuzid) - this%uzfobj%celbot(iuzid)
2541  ! -- check that obs depth is valid; call store_error if not
2542  ! -- need to think about a way to put bounds on this depth
2543  ! -- Also, an observation depth of 0.0, whether a landflag == 1 object
2544  ! -- or a subsurface object, is not legit since this would be at a
2545  ! -- a layer interface and therefore a discontinuity.
2546  if (obsdepth <= dzero .or. obsdepth > dmax) then
2547  write (errmsg, '(a,3(1x,a),1x,g0,1x,a,1x,g0,a)') &
2548  trim(adjustl(obsrv%ObsTypeId)), 'for observation', &
2549  trim(adjustl(obsrv%Name)), 'specified depth (', obsdepth, &
2550  ') must be greater than 0.0 and less than ', dmax, '.'
2551  call store_error(errmsg)
2552  end if
2553  else
2554  do j = 1, obsrv%indxbnds_count
2555  nn = obsrv%indxbnds(j)
2556  if (nn < 1 .or. nn > this%maxbound) then
2557  write (errmsg, '(a,2(1x,a),1x,i0,1x,a,1x,i0,a)') &
2558  trim(adjustl(obsrv%ObsTypeId)), 'uzfno must be greater than 0 ', &
2559  'and less than or equal to', this%maxbound, &
2560  '(specified value is ', nn, ').'
2561  call store_error(errmsg)
2562  end if
2563  end do
2564  end if
2565  end do
2566  !
2567  ! -- evaluate if there are any observation errors
2568  if (count_errors() > 0) then
2569  call store_error_unit(this%inunit)
2570  end if
2571  end if
2572  !
2573  ! -- Return
2574  return
2575  end subroutine uzf_rp_obs
2576 
2577  ! -- Procedures related to observations (NOT type-bound)
2578 
2579  !> @brief This procedure is pointed to by ObsDataType%ProcesssIdPtr
2580  !!
2581  !! Process the ID string of an observation definition for UZF-package
2582  !! observations
2583  !<
2584  subroutine uzf_process_obsid(obsrv, dis, inunitobs, iout)
2585  ! -- .
2586  ! -- dummy
2587  type(observetype), intent(inout) :: obsrv
2588  class(disbasetype), intent(in) :: dis
2589  integer(I4B), intent(in) :: inunitobs
2590  integer(I4B), intent(in) :: iout
2591  ! -- local
2592  integer(I4B) :: n, nn
2593  real(DP) :: obsdepth
2594  integer(I4B) :: icol, istart, istop, istat
2595  real(DP) :: r
2596  character(len=LINELENGTH) :: string
2597  ! formats
2598 30 format(i10)
2599  !
2600  string = obsrv%IDstring
2601  ! -- Extract node number from string and store it.
2602  ! If 1st item is not an integer(I4B), it should be a
2603  ! feature name--deal with it.
2604  icol = 1
2605  ! -- get node number
2606  call urword(string, icol, istart, istop, 1, n, r, iout, inunitobs)
2607  read (string(istart:istop), 30, iostat=istat) nn
2608  if (istat == 0) then
2609  ! -- store uzf node number (NodeNumber)
2610  obsrv%NodeNumber = nn
2611  else
2612  ! Integer can't be read from string; it's presumed to be a boundary
2613  ! name (already converted to uppercase)
2614  obsrv%FeatureName = string(istart:istop)
2615  !obsrv%FeatureName = trim(adjustl(string))
2616  ! -- Observation may require summing rates from multiple boundaries,
2617  ! so assign NodeNumber as a value that indicates observation
2618  ! is for a named boundary or group of boundaries.
2619  obsrv%NodeNumber = namedboundflag
2620  end if
2621  !
2622  ! -- for soil water observation, store depth
2623  if (obsrv%ObsTypeId == 'WATER-CONTENT') then
2624  call urword(string, icol, istart, istop, 3, n, r, iout, inunitobs)
2625  obsdepth = r
2626  ! -- store observations depth
2627  obsrv%Obsdepth = obsdepth
2628  end if
2629  !
2630  ! -- Return
2631  return
2632  end subroutine uzf_process_obsid
2633 
2634  !> @brief Allocate scalar members
2635  !<
2636  subroutine uzf_allocate_scalars(this)
2637  ! -- modules
2639  ! -- dummy
2640  class(uzftype) :: this
2641  !
2642  ! -- call standard BndType allocate scalars
2643  call this%BndType%allocate_scalars()
2644  !
2645  ! -- allocate uzf specific scalars
2646  call mem_allocate(this%iprwcont, 'IPRWCONT', this%memoryPath)
2647  call mem_allocate(this%iwcontout, 'IWCONTOUT', this%memoryPath)
2648  call mem_allocate(this%ibudgetout, 'IBUDGETOUT', this%memoryPath)
2649  call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath)
2650  call mem_allocate(this%ipakcsv, 'IPAKCSV', this%memoryPath)
2651  call mem_allocate(this%ntrail_pvar, 'NTRAIL', this%memoryPath)
2652  call mem_allocate(this%nsets, 'NSETS', this%memoryPath)
2653  call mem_allocate(this%nodes, 'NODES', this%memoryPath)
2654  call mem_allocate(this%istocb, 'ISTOCB', this%memoryPath)
2655  call mem_allocate(this%nwav_pvar, 'NWAV_PVAR', this%memoryPath)
2656  call mem_allocate(this%totfluxtot, 'TOTFLUXTOT', this%memoryPath)
2657  call mem_allocate(this%bditems, 'BDITEMS', this%memoryPath)
2658  call mem_allocate(this%nbdtxt, 'NBDTXT', this%memoryPath)
2659  call mem_allocate(this%issflag, 'ISSFLAG', this%memoryPath)
2660  call mem_allocate(this%issflagold, 'ISSFLAGOLD', this%memoryPath)
2661  call mem_allocate(this%readflag, 'READFLAG', this%memoryPath)
2662  call mem_allocate(this%iseepflag, 'ISEEPFLAG', this%memoryPath)
2663  call mem_allocate(this%imaxcellcnt, 'IMAXCELLCNT', this%memoryPath)
2664  call mem_allocate(this%ietflag, 'IETFLAG', this%memoryPath)
2665  call mem_allocate(this%igwetflag, 'IGWETFLAG', this%memoryPath)
2666  call mem_allocate(this%iuzf2uzf, 'IUZF2UZF', this%memoryPath)
2667  call mem_allocate(this%cbcauxitems, 'CBCAUXITEMS', this%memoryPath)
2668  !
2669  call mem_allocate(this%iconvchk, 'ICONVCHK', this%memoryPath)
2670  !
2671  ! -- initialize scalars
2672  this%iprwcont = 0
2673  this%iwcontout = 0
2674  this%ibudgetout = 0
2675  this%ibudcsv = 0
2676  this%ipakcsv = 0
2677  this%istocb = 0
2678  this%bditems = 7
2679  this%nbdtxt = 5
2680  this%issflag = 0
2681  this%issflagold = 0
2682  this%ietflag = 0
2683  this%igwetflag = 0
2684  this%iseepflag = 0
2685  this%imaxcellcnt = 0
2686  this%iuzf2uzf = 0
2687  this%cbcauxitems = 1
2688  this%imover = 0
2689  !
2690  ! -- convergence check
2691  this%iconvchk = 1
2692  !
2693  ! -- Return
2694  return
2695  end subroutine uzf_allocate_scalars
2696 
2697  !> @brief Deallocate objects
2698  !<
2699  subroutine uzf_da(this)
2700  ! -- modules
2702  ! -- dummy
2703  class(uzftype) :: this
2704  !
2705  ! -- deallocate uzf objects
2706  call this%uzfobj%dealloc()
2707  deallocate (this%uzfobj)
2708  nullify (this%uzfobj)
2709  call this%uzfobjwork%dealloc()
2710  !
2711  call this%budobj%budgetobject_da()
2712  deallocate (this%budobj)
2713  nullify (this%budobj)
2714  !
2715  ! -- character arrays
2716  deallocate (this%bdtxt)
2717  deallocate (this%cauxcbc)
2718  deallocate (this%uzfname)
2719  !
2720  ! -- package csv table
2721  if (this%ipakcsv > 0) then
2722  if (associated(this%pakcsvtab)) then
2723  call this%pakcsvtab%table_da()
2724  deallocate (this%pakcsvtab)
2725  nullify (this%pakcsvtab)
2726  end if
2727  end if
2728  !
2729  ! -- deallocate scalars
2730  call mem_deallocate(this%iprwcont)
2731  call mem_deallocate(this%iwcontout)
2732  call mem_deallocate(this%ibudgetout)
2733  call mem_deallocate(this%ibudcsv)
2734  call mem_deallocate(this%ipakcsv)
2735  call mem_deallocate(this%ntrail_pvar)
2736  call mem_deallocate(this%nsets)
2737  call mem_deallocate(this%nodes)
2738  call mem_deallocate(this%istocb)
2739  call mem_deallocate(this%nwav_pvar)
2740  call mem_deallocate(this%totfluxtot)
2741  call mem_deallocate(this%bditems)
2742  call mem_deallocate(this%nbdtxt)
2743  call mem_deallocate(this%issflag)
2744  call mem_deallocate(this%issflagold)
2745  call mem_deallocate(this%readflag)
2746  call mem_deallocate(this%iseepflag)
2747  call mem_deallocate(this%imaxcellcnt)
2748  call mem_deallocate(this%ietflag)
2749  call mem_deallocate(this%igwetflag)
2750  call mem_deallocate(this%iuzf2uzf)
2751  call mem_deallocate(this%cbcauxitems)
2752  !
2753  ! -- convergence check
2754  call mem_deallocate(this%iconvchk)
2755  !
2756  ! -- deallocate arrays
2757  call mem_deallocate(this%igwfnode)
2758  call mem_deallocate(this%appliedinf)
2759  call mem_deallocate(this%rejinf)
2760  call mem_deallocate(this%rejinf0)
2761  call mem_deallocate(this%rejinftomvr)
2762  call mem_deallocate(this%infiltration)
2763  call mem_deallocate(this%gwet_pvar)
2764  call mem_deallocate(this%uzet)
2765  call mem_deallocate(this%gwd)
2766  call mem_deallocate(this%gwd0)
2767  call mem_deallocate(this%gwdtomvr)
2768  call mem_deallocate(this%rch)
2769  call mem_deallocate(this%rch0)
2770  call mem_deallocate(this%qsto)
2771  call mem_deallocate(this%deriv)
2772  call mem_deallocate(this%qauxcbc)
2773  call mem_deallocate(this%wcnew)
2774  call mem_deallocate(this%wcold)
2775  !
2776  ! -- deallocate integer arrays
2777  call mem_deallocate(this%ia)
2778  call mem_deallocate(this%ja)
2779  !
2780  ! -- deallocate timeseries aware variables
2781  call mem_deallocate(this%sinf_pvar)
2782  call mem_deallocate(this%pet_pvar)
2783  call mem_deallocate(this%extdp)
2784  call mem_deallocate(this%extwc_pvar)
2785  call mem_deallocate(this%ha_pvar)
2786  call mem_deallocate(this%hroot_pvar)
2787  call mem_deallocate(this%rootact_pvar)
2788  call mem_deallocate(this%uauxvar)
2789  !
2790  ! -- Parent object
2791  call this%BndType%bnd_da()
2792  !
2793  ! -- Return
2794  return
2795  end subroutine uzf_da
2796 
2797  !> @brief Set up the budget object that stores all the uzf flows
2798  !!
2799  !! The terms listed here must correspond in number and order to the ones
2800  !! listed in the uzf_fill_budobj routine
2801  !<
2802  subroutine uzf_setup_budobj(this)
2803  ! -- modules
2804  use constantsmodule, only: lenbudtxt
2805  ! -- dummy
2806  class(uzftype) :: this
2807  ! -- local
2808  integer(I4B) :: nbudterm
2809  integer(I4B) :: maxlist, naux
2810  integer(I4B) :: idx
2811  integer(I4B) :: nlen
2812  integer(I4B) :: n, n1, n2
2813  integer(I4B) :: ivertflag
2814  real(DP) :: q
2815  character(len=LENBUDTXT) :: text
2816  character(len=LENBUDTXT), dimension(1) :: auxtxt
2817  !
2818  ! -- Determine the number of uzf to uzf connections
2819  nlen = 0
2820  do n = 1, this%nodes
2821  ivertflag = this%uzfobj%ivertcon(n)
2822  if (ivertflag > 0) then
2823  nlen = nlen + 1
2824  end if
2825  end do
2826  !
2827  ! -- Determine the number of uzf budget terms. These are fixed for
2828  ! the simulation and cannot change. This includes FLOW-JA-FACE
2829  ! so they can be written to the binary budget files, but these internal
2830  ! flows are not included as part of the budget table.
2831  nbudterm = 4
2832  if (nlen > 0) nbudterm = nbudterm + 1
2833  if (this%ietflag /= 0) nbudterm = nbudterm + 1
2834  if (this%imover == 1) nbudterm = nbudterm + 2
2835  if (this%naux > 0) nbudterm = nbudterm + 1
2836  !
2837  ! -- set up budobj
2838  call budgetobject_cr(this%budobj, this%packName)
2839  call this%budobj%budgetobject_df(this%maxbound, nbudterm, 0, 0, &
2840  ibudcsv=this%ibudcsv)
2841  idx = 0
2842  !
2843  ! -- Go through and set up each budget term
2844  text = ' FLOW-JA-FACE'
2845  if (nlen > 0) then
2846  idx = idx + 1
2847  maxlist = nlen * 2
2848  naux = 1
2849  auxtxt(1) = ' FLOW-AREA'
2850  call this%budobj%budterm(idx)%initialize(text, &
2851  this%name_model, &
2852  this%packName, &
2853  this%name_model, &
2854  this%packName, &
2855  maxlist, .false., .false., &
2856  naux, auxtxt, ordered_id1=.false.)
2857  !
2858  ! -- store connectivity
2859  call this%budobj%budterm(idx)%reset(nlen * 2)
2860  q = dzero
2861  do n = 1, this%nodes
2862  ivertflag = this%uzfobj%ivertcon(n)
2863  if (ivertflag > 0) then
2864  n1 = n
2865  n2 = ivertflag
2866  call this%budobj%budterm(idx)%update_term(n1, n2, q)
2867  call this%budobj%budterm(idx)%update_term(n2, n1, -q)
2868  end if
2869  end do
2870  end if
2871  !
2872  ! --
2873  text = ' GWF'
2874  idx = idx + 1
2875  maxlist = this%nodes
2876  naux = 1
2877  auxtxt(1) = ' FLOW-AREA'
2878  call this%budobj%budterm(idx)%initialize(text, &
2879  this%name_model, &
2880  this%packName, &
2881  this%name_model, &
2882  this%name_model, &
2883  maxlist, .false., .true., &
2884  naux, auxtxt)
2885  call this%budobj%budterm(idx)%reset(this%nodes)
2886  q = dzero
2887  do n = 1, this%nodes
2888  n2 = this%igwfnode(n)
2889  call this%budobj%budterm(idx)%update_term(n, n2, q)
2890  end do
2891  !
2892  ! --
2893  text = ' INFILTRATION'
2894  idx = idx + 1
2895  maxlist = this%nodes
2896  naux = 0
2897  call this%budobj%budterm(idx)%initialize(text, &
2898  this%name_model, &
2899  this%packName, &
2900  this%name_model, &
2901  this%packName, &
2902  maxlist, .false., .false., &
2903  naux)
2904  !
2905  ! --
2906  text = ' REJ-INF'
2907  idx = idx + 1
2908  maxlist = this%nodes
2909  naux = 0
2910  call this%budobj%budterm(idx)%initialize(text, &
2911  this%name_model, &
2912  this%packName, &
2913  this%name_model, &
2914  this%packName, &
2915  maxlist, .false., .false., &
2916  naux)
2917  !
2918  ! --
2919  text = ' UZET'
2920  if (this%ietflag /= 0) then
2921  idx = idx + 1
2922  maxlist = this%maxbound
2923  naux = 0
2924  call this%budobj%budterm(idx)%initialize(text, &
2925  this%name_model, &
2926  this%packName, &
2927  this%name_model, &
2928  this%packName, &
2929  maxlist, .false., .false., &
2930  naux)
2931  end if
2932  !
2933  ! --
2934  text = ' STORAGE'
2935  idx = idx + 1
2936  maxlist = this%nodes
2937  naux = 1
2938  auxtxt(1) = ' VOLUME'
2939  call this%budobj%budterm(idx)%initialize(text, &
2940  this%name_model, &
2941  this%packName, &
2942  this%name_model, &
2943  this%packName, &
2944  maxlist, .false., .false., &
2945  naux, auxtxt)
2946  !
2947  ! --
2948  if (this%imover == 1) then
2949  !
2950  ! --
2951  text = ' FROM-MVR'
2952  idx = idx + 1
2953  maxlist = this%nodes
2954  naux = 0
2955  call this%budobj%budterm(idx)%initialize(text, &
2956  this%name_model, &
2957  this%packName, &
2958  this%name_model, &
2959  this%packName, &
2960  maxlist, .false., .false., &
2961  naux)
2962  !
2963  ! --
2964  text = ' REJ-INF-TO-MVR'
2965  idx = idx + 1
2966  maxlist = this%nodes
2967  naux = 0
2968  call this%budobj%budterm(idx)%initialize(text, &
2969  this%name_model, &
2970  this%packName, &
2971  this%name_model, &
2972  this%packName, &
2973  maxlist, .false., .false., &
2974  naux)
2975  end if
2976  !
2977  ! --
2978  naux = this%naux
2979  if (naux > 0) then
2980  !
2981  ! --
2982  text = ' AUXILIARY'
2983  idx = idx + 1
2984  maxlist = this%maxbound
2985  call this%budobj%budterm(idx)%initialize(text, &
2986  this%name_model, &
2987  this%packName, &
2988  this%name_model, &
2989  this%packName, &
2990  maxlist, .false., .false., &
2991  naux, this%auxname)
2992  end if
2993  !
2994  ! -- if uzf flow for each reach are written to the listing file
2995  if (this%iprflow /= 0) then
2996  call this%budobj%flowtable_df(this%iout, cellids='GWF')
2997  end if
2998  !
2999  ! -- Return
3000  return
3001  end subroutine uzf_setup_budobj
3002 
3003  !> @brief Copy flow terms into this%budobj
3004  !<
3005  subroutine uzf_fill_budobj(this)
3006  ! -- dummy
3007  class(uzftype) :: this
3008  ! -- local
3009  integer(I4B) :: naux
3010  integer(I4B) :: nlen
3011  integer(I4B) :: ivertflag
3012  integer(I4B) :: n, n1, n2
3013  integer(I4B) :: idx
3014  real(DP) :: q
3015  real(DP) :: a
3016  real(DP) :: top
3017  real(DP) :: bot
3018  real(DP) :: thick
3019  real(DP) :: fm
3020  real(DP) :: v
3021  !
3022  ! -- initialize counter
3023  idx = 0
3024  !
3025  ! -- FLOW JA FACE
3026  nlen = 0
3027  do n = 1, this%nodes
3028  ivertflag = this%uzfobj%ivertcon(n)
3029  if (ivertflag > 0) then
3030  nlen = nlen + 1
3031  end if
3032  end do
3033  if (nlen > 0) then
3034  idx = idx + 1
3035  call this%budobj%budterm(idx)%reset(nlen * 2)
3036  do n = 1, this%nodes
3037  ivertflag = this%uzfobj%ivertcon(n)
3038  if (ivertflag > 0) then
3039  a = this%uzfobj%uzfarea(n)
3040  q = this%uzfobj%surfluxbelow(n) * a
3041  this%qauxcbc(1) = a
3042  if (q > dzero) then
3043  q = -q
3044  end if
3045  n1 = n
3046  n2 = ivertflag
3047  call this%budobj%budterm(idx)%update_term(n1, n2, q, this%qauxcbc)
3048  call this%budobj%budterm(idx)%update_term(n2, n1, -q, this%qauxcbc)
3049  end if
3050  end do
3051  end if
3052  !
3053  ! -- GWF (LEAKAGE)
3054  idx = idx + 1
3055  call this%budobj%budterm(idx)%reset(this%nodes)
3056  do n = 1, this%nodes
3057  this%qauxcbc(1) = this%uzfobj%uzfarea(n)
3058  n2 = this%igwfnode(n)
3059  q = -this%rch(n)
3060  call this%budobj%budterm(idx)%update_term(n, n2, q, this%qauxcbc)
3061  end do
3062  !
3063  ! -- INFILTRATION
3064  idx = idx + 1
3065  call this%budobj%budterm(idx)%reset(this%nodes)
3066  do n = 1, this%nodes
3067  q = this%appliedinf(n)
3068  call this%budobj%budterm(idx)%update_term(n, n, q)
3069  end do
3070  !
3071  ! -- REJECTED INFILTRATION
3072  idx = idx + 1
3073  call this%budobj%budterm(idx)%reset(this%nodes)
3074  do n = 1, this%nodes
3075  q = this%rejinf(n)
3076  if (q > dzero) then
3077  q = -q
3078  end if
3079  call this%budobj%budterm(idx)%update_term(n, n, q)
3080  end do
3081  !
3082  ! -- UNSATURATED EVT
3083  if (this%ietflag /= 0) then
3084  idx = idx + 1
3085  call this%budobj%budterm(idx)%reset(this%nodes)
3086  do n = 1, this%nodes
3087  q = this%uzet(n)
3088  if (q > dzero) then
3089  q = -q
3090  end if
3091  call this%budobj%budterm(idx)%update_term(n, n, q)
3092  end do
3093  end if
3094  !
3095  ! -- STORAGE
3096  idx = idx + 1
3097  call this%budobj%budterm(idx)%reset(this%nodes)
3098  do n = 1, this%nodes
3099  q = -this%qsto(n)
3100  top = this%uzfobj%celtop(n)
3101  bot = this%uzfobj%watab(n)
3102  thick = top - bot
3103  if (thick > dzero) then
3104  fm = thick * (this%wcnew(n) - this%uzfobj%thtr(n))
3105  v = fm * this%uzfobj%uzfarea(n)
3106  else
3107  v = dzero
3108  end if
3109  ! -- save mobile water volume into aux variable
3110  this%qauxcbc(1) = v
3111  call this%budobj%budterm(idx)%update_term(n, n, q, this%qauxcbc)
3112  end do
3113  !
3114  ! -- MOVER
3115  if (this%imover == 1) then
3116  !
3117  ! -- FROM MOVER
3118  idx = idx + 1
3119  call this%budobj%budterm(idx)%reset(this%nodes)
3120  do n = 1, this%nodes
3121  q = this%pakmvrobj%get_qfrommvr(n)
3122  call this%budobj%budterm(idx)%update_term(n, n, q)
3123  end do
3124  !
3125  ! -- REJ-INF-TO-MVR
3126  idx = idx + 1
3127  call this%budobj%budterm(idx)%reset(this%nodes)
3128  do n = 1, this%nodes
3129  q = this%rejinftomvr(n)
3130  if (q > dzero) then
3131  q = -q
3132  end if
3133  call this%budobj%budterm(idx)%update_term(n, n, q)
3134  end do
3135 
3136  end if
3137  !
3138  ! -- AUXILIARY VARIABLES
3139  naux = this%naux
3140  if (naux > 0) then
3141  idx = idx + 1
3142  call this%budobj%budterm(idx)%reset(this%nodes)
3143  do n = 1, this%nodes
3144  q = dzero
3145  call this%budobj%budterm(idx)%update_term(n, n, q, this%auxvar(:, n))
3146  end do
3147  end if
3148  !
3149  ! --Terms are filled, now accumulate them for this time step
3150  call this%budobj%accumulate_terms()
3151  !
3152  ! -- Return
3153  return
3154  end subroutine uzf_fill_budobj
3155 
3156 end module uzfmodule
This module contains block parser methods.
Definition: BlockParser.f90:7
This module contains the base boundary package.
subroutine, public save_print_model_flows(icbcfl, ibudfl, icbcun, iprflow, outputtab, nbound, nodelist, flow, ibound, title, text, ipakcb, dis, naux, textmodel, textpackage, dstmodel, dstpackage, auxname, auxvar, iout, inamedbound, boundname, imap)
Save and/or print flows for a package.
This module contains the BudgetModule.
Definition: Budget.f90:20
subroutine, public rate_accumulator(flow, rin, rout)
@ brief Rate accumulator subroutine
Definition: Budget.f90:664
subroutine, public budgetobject_cr(this, name)
Create a new budget object.
This module contains simulation constants.
Definition: Constants.f90:9
integer(i4b), parameter linelength
maximum length of a standard line
Definition: Constants.f90:44
real(dp), parameter dhdry
real dry cell constant
Definition: Constants.f90:93
@ tabcenter
centered table column
Definition: Constants.f90:171
@ tabright
right justified table column
Definition: Constants.f90:172
@ tableft
left justified table column
Definition: Constants.f90:170
@ mnormal
normal output mode
Definition: Constants.f90:205
@ tabucstring
upper case string table data
Definition: Constants.f90:179
@ tabstring
string table data
Definition: Constants.f90:178
@ tabreal
real table data
Definition: Constants.f90:181
@ tabinteger
integer table data
Definition: Constants.f90:180
integer(i4b), parameter lenpackagename
maximum length of the package name
Definition: Constants.f90:22
integer(i4b), parameter namedboundflag
named bound flag
Definition: Constants.f90:48
real(dp), parameter dnodata
real no data constant
Definition: Constants.f90:94
real(dp), parameter dhnoflo
real no flow constant
Definition: Constants.f90:92
real(dp), parameter dhundred
real constant 100
Definition: Constants.f90:85
integer(i4b), parameter lenpakloc
maximum length of a package location
Definition: Constants.f90:49
real(dp), parameter dem1
real constant 1e-1
Definition: Constants.f90:102
real(dp), parameter dhalf
real constant 1/2
Definition: Constants.f90:67
integer(i4b), parameter lenftype
maximum length of a package type (DIS, WEL, OC, etc.)
Definition: Constants.f90:38
integer(i4b), parameter lenboundname
maximum length of a bound name
Definition: Constants.f90:35
real(dp), parameter dem4
real constant 1e-4
Definition: Constants.f90:106
real(dp), parameter dem6
real constant 1e-6
Definition: Constants.f90:108
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:64
integer(i4b), parameter maxcharlen
maximum length of char string
Definition: Constants.f90:46
real(dp), parameter dem2
real constant 1e-2
Definition: Constants.f90:104
integer(i4b), parameter lenbudtxt
maximum length of a budget component names
Definition: Constants.f90:36
real(dp), parameter done
real constant 1
Definition: Constants.f90:75
integer(i4b) function, public getunit()
Get a free unit number.
subroutine, public ulasav(buf, text, kstp, kper, pertim, totim, ncol, nrow, ilay, ichn)
Save 1 layer array on disk.
subroutine, public openfile(iu, iout, fname, ftype, fmtarg_opt, accarg_opt, filstat_opt, mode_opt)
Open a file.
Definition: InputOutput.f90:30
subroutine, public urword(line, icol, istart, istop, ncode, n, r, iout, in)
Extract a word from a string.
This module defines variable data types.
Definition: kind.f90:8
character(len=lenmempath) function create_mem_path(component, subcomponent, context)
returns the path to the memory object
This module contains the derived types ObserveType and ObsDataType.
Definition: Observe.f90:15
This module contains the derived type ObsType.
Definition: Obs.f90:127
character(len=20) access
Definition: OpenSpec.f90:7
character(len=20) form
Definition: OpenSpec.f90:7
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
subroutine, public deprecation_warning(cblock, cvar, cver, endmsg, iunit)
Store deprecation warning message.
Definition: Sim.f90:259
subroutine, public store_error_unit(iunit, terminate)
Store the file unit number.
Definition: Sim.f90:168
This module contains simulation variables.
Definition: SimVariables.f90:9
character(len=maxcharlen) errmsg
error message string
integer(i4b) ifailedstepretry
current retry for this time step
character(len=maxcharlen) warnmsg
warning message string
subroutine, public table_cr(this, name, title)
Definition: Table.f90:85
real(dp), pointer, public pertim
time relative to start of stress period
Definition: tdis.f90:30
real(dp), pointer, public totim
time relative to start of simulation
Definition: tdis.f90:32
integer(i4b), pointer, public kstp
current time step number
Definition: tdis.f90:24
integer(i4b), pointer, public kper
current stress period number
Definition: tdis.f90:23
real(dp), pointer, public delt
length of the current time step
Definition: tdis.f90:29
integer(i4b), pointer, public nper
number of stress period
Definition: tdis.f90:21
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 uzf_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname)
Create a New UZF Package and point packobj to the new package.
Definition: gwf-uzf.f90:175
subroutine uzf_ar(this)
Allocate and Read.
Definition: gwf-uzf.f90:218
subroutine uzf_fc(this, rhs, ia, idxglo, matrix_sln)
Copy rhs and hcof into solution rhs and amat.
Definition: gwf-uzf.f90:1068
subroutine uzf_ot_dv(this, idvsave, idvprint)
Save UZF-calculated values to binary file.
Definition: gwf-uzf.f90:1648
subroutine define_listlabel(this)
Define the list heading that is written to iout when PRINT_INPUT option is used.
Definition: gwf-uzf.f90:1819
subroutine uzf_da(this)
Deallocate objects.
Definition: gwf-uzf.f90:2700
logical function uzf_obs_supported(this)
Return true because uzf package supports observations.
Definition: gwf-uzf.f90:2281
subroutine uzf_setup_budobj(this)
Set up the budget object that stores all the uzf flows.
Definition: gwf-uzf.f90:2803
subroutine uzf_cq(this, x, flowja, iadv)
Calculate flows.
Definition: gwf-uzf.f90:1357
subroutine uzf_allocate_arrays(this)
Allocate arrays used for uzf.
Definition: gwf-uzf.f90:267
character(len=lenftype) ftype
Definition: gwf-uzf.f90:33
subroutine uzf_ot_bdsummary(this, kstp, kper, iout, ibudfl)
Write UZF budget to listing file.
Definition: gwf-uzf.f90:1678
subroutine uzf_process_obsid(obsrv, dis, inunitobs, iout)
This procedure is pointed to by ObsDataTypeProcesssIdPtr.
Definition: gwf-uzf.f90:2585
subroutine uzf_rp_obs(this)
Process each observation.
Definition: gwf-uzf.f90:2458
real(dp) function get_storage_change(top, bot, carea, hold, hnew, wcold, wcnew, thtr, delt, iss)
Definition: gwf-uzf.f90:1460
subroutine uzf_readdimensions(this)
Set dimensions specific to UzfType.
Definition: gwf-uzf.f90:537
subroutine uzf_cf(this)
Formulate the HCOF and RHS terms.
Definition: gwf-uzf.f90:1044
subroutine uzf_fn(this, rhs, ia, idxglo, matrix_sln)
Fill newton terms.
Definition: gwf-uzf.f90:1101
subroutine uzf_fill_budobj(this)
Copy flow terms into thisbudobj.
Definition: gwf-uzf.f90:3006
subroutine uzf_df_obs(this)
Implements bnd_df_obs.
Definition: gwf-uzf.f90:2296
subroutine uzf_ot_model_flows(this, icbcfl, ibudfl, icbcun, imap)
Write flows to binary file and/or print flows to budget.
Definition: gwf-uzf.f90:1539
subroutine findcellabove(this, n, nml)
Identify overlying cell ID based on user-specified mapping.
Definition: gwf-uzf.f90:1846
subroutine print_cell_properties(this)
Read UZF cell properties and set them for UZFCellGroup type.
Definition: gwf-uzf.f90:2112
subroutine uzf_bd(this, model_budget)
Add package ratin/ratout to model budget.
Definition: gwf-uzf.f90:1498
subroutine uzf_allocate_scalars(this)
Allocate scalar members.
Definition: gwf-uzf.f90:2637
subroutine uzf_rp(this)
Read stress data.
Definition: gwf-uzf.f90:648
subroutine uzf_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak)
Final convergence check for package.
Definition: gwf-uzf.f90:1126
subroutine check_cell_area(this)
Check UZF cell areas.
Definition: gwf-uzf.f90:2196
subroutine uzf_bd_obs(this)
Calculate observations this time step and call ObsTypeSaveOneSimval for each UzfType observation.
Definition: gwf-uzf.f90:2359
character(len=lenpackagename) text
Definition: gwf-uzf.f90:34
subroutine uzf_ot_package_flows(this, icbcfl, ibudfl)
Output UZF package flow terms.
Definition: gwf-uzf.f90:1617
subroutine uzf_options(this, option, found)
Set options specific to UzfType.
Definition: gwf-uzf.f90:383
subroutine uzf_solve(this, reset_state)
Formulate the HCOF and RHS terms.
Definition: gwf-uzf.f90:1696
subroutine uzf_ad(this)
Advance UZF Package.
Definition: gwf-uzf.f90:939
subroutine read_cell_properties(this)
Read UZF cell properties and set them for UzfCellGroup type.
Definition: gwf-uzf.f90:1874
@ brief BndType
Derived type for the Budget object.
Definition: Budget.f90:39