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