MODFLOW 6  version 6.7.0.dev3
USGS Modular Hydrologic Model
gwf-hfb.f90
Go to the documentation of this file.
1 
3 
4  use kindmodule, only: dp, i4b
5  use simvariablesmodule, only: errmsg
7  use xt3dmodule, only: xt3dtype
8  use gwfvscmodule, only: gwfvsctype
10  use basedismodule, only: disbasetype
12 
13  implicit none
14 
15  private
16  public :: gwfhfbtype
17  public :: hfb_cr
18 
19  type, extends(numericalpackagetype) :: gwfhfbtype
20 
21  type(gwfvsctype), pointer :: vsc => null() !< viscosity object
22  integer(I4B), pointer :: maxhfb => null() !< max number of hfb's
23  integer(I4B), pointer :: nhfb => null() !< number of hfb's
24  integer(I4B), dimension(:), pointer, contiguous :: noden => null() !< first cell
25  integer(I4B), dimension(:), pointer, contiguous :: nodem => null() !< second cell
26  integer(I4B), dimension(:), pointer, contiguous :: idxloc => null() !< position in model ja
27  real(dp), dimension(:), pointer, contiguous :: hydchr => null() !< hydraulic characteristic of the barrier
28  real(dp), dimension(:), pointer, contiguous :: csatsav => null() !< value of condsat prior to hfb modification
29  real(dp), dimension(:), pointer, contiguous :: condsav => null() !< saved conductance of combined npf and hfb
30  type(xt3dtype), pointer :: xt3d => null() !< pointer to xt3d object
31  !
32  integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !< pointer to model ibound
33  integer(I4B), dimension(:), pointer, contiguous :: icelltype => null() !< pointer to model icelltype
34  integer(I4B), dimension(:), pointer, contiguous :: ihc => null() !< pointer to model ihc
35  integer(I4B), dimension(:), pointer, contiguous :: ia => null() !< pointer to model ia
36  integer(I4B), dimension(:), pointer, contiguous :: ja => null() !< pointer to model ja
37  integer(I4B), dimension(:), pointer, contiguous :: jas => null() !< pointer to model jas
38  integer(I4B), dimension(:), pointer, contiguous :: isym => null() !< pointer to model isym
39  real(dp), dimension(:), pointer, contiguous :: condsat => null() !< pointer to model condsat
40  real(dp), dimension(:), pointer, contiguous :: top => null() !< pointer to model top
41  real(dp), dimension(:), pointer, contiguous :: bot => null() !< pointer to model bot
42  real(dp), dimension(:), pointer, contiguous :: hwva => null() !< pointer to model hwva
43  real(dp), dimension(:), pointer, contiguous :: hnew => null() !< pointer to model xnew
44  !
45  ! -- viscosity flag
46  integer(I4B), pointer :: ivsc => null() !< flag indicating if viscosity is active in the model
47 
48  contains
49 
50  procedure :: hfb_ar
51  procedure :: hfb_rp
52  procedure :: hfb_fc
53  procedure :: hfb_cq
54  procedure :: hfb_da
55  procedure :: allocate_scalars
56  procedure, private :: allocate_arrays
57  procedure, private :: source_options
58  procedure, private :: source_dimensions
59  procedure, private :: source_data
60  procedure, private :: check_data
61  procedure, private :: condsat_reset
62  procedure, private :: condsat_modify
63 
64  end type gwfhfbtype
65 
66 contains
67 
68  !> @brief Create a new hfb object
69  !<
70  subroutine hfb_cr(hfbobj, name_model, input_mempath, inunit, iout)
71  ! -- dummy
72  type(gwfhfbtype), pointer :: hfbobj
73  character(len=*), intent(in) :: name_model
74  character(len=*), intent(in) :: input_mempath
75  integer(I4B), intent(in) :: inunit
76  integer(I4B), intent(in) :: iout
77  !
78  ! -- Create the object
79  allocate (hfbobj)
80  !
81  ! -- create name and memory path
82  call hfbobj%set_names(1, name_model, 'HFB', 'HFB', input_mempath)
83  !
84  ! -- Allocate scalars
85  call hfbobj%allocate_scalars()
86  !
87  ! -- Save unit numbers
88  hfbobj%inunit = inunit
89  hfbobj%iout = iout
90  end subroutine hfb_cr
91 
92  !> @brief Allocate and read
93  !<
94  subroutine hfb_ar(this, ibound, xt3d, dis, invsc, vsc)
95  ! -- modules
98  ! -- dummy
99  class(gwfhfbtype) :: this
100  integer(I4B), dimension(:), pointer, contiguous :: ibound
101  type(xt3dtype), pointer :: xt3d
102  class(disbasetype), pointer, intent(inout) :: dis !< discretization package
103  integer(I4B), pointer :: invsc !< indicates if viscosity package is active
104  type(gwfvsctype), pointer, intent(in) :: vsc !< viscosity package
105  ! -- formats
106  character(len=*), parameter :: fmtheader = &
107  "(1x, /1x, 'HFB -- HORIZONTAL FLOW BARRIER PACKAGE, VERSION 8, ', &
108  &'4/24/2015 INPUT READ FROM MEMPATH: ', a, /)"
109  !
110  ! -- Print a message identifying the node property flow package.
111  write (this%iout, fmtheader) this%input_mempath
112  !
113  ! -- Set pointers
114  this%dis => dis
115  this%ibound => ibound
116  this%xt3d => xt3d
117  !
118  call mem_setptr(this%icelltype, 'ICELLTYPE', &
119  create_mem_path(this%name_model, 'NPF'))
120  call mem_setptr(this%ihc, 'IHC', create_mem_path(this%name_model, 'CON'))
121  call mem_setptr(this%ia, 'IA', create_mem_path(this%name_model, 'CON'))
122  call mem_setptr(this%ja, 'JA', create_mem_path(this%name_model, 'CON'))
123  call mem_setptr(this%jas, 'JAS', create_mem_path(this%name_model, 'CON'))
124  call mem_setptr(this%isym, 'ISYM', create_mem_path(this%name_model, 'CON'))
125  call mem_setptr(this%condsat, 'CONDSAT', create_mem_path(this%name_model, &
126  'NPF'))
127  call mem_setptr(this%top, 'TOP', create_mem_path(this%name_model, 'DIS'))
128  call mem_setptr(this%bot, 'BOT', create_mem_path(this%name_model, 'DIS'))
129  call mem_setptr(this%hwva, 'HWVA', create_mem_path(this%name_model, 'CON'))
130  !
131  call this%source_options()
132  call this%source_dimensions()
133  call this%allocate_arrays()
134  !
135  ! -- If vsc package active, set ivsc
136  if (invsc /= 0) then
137  this%ivsc = 1
138  this%vsc => vsc
139  !
140  ! -- Notify user via listing file viscosity accounted for by HFB package
141  write (this%iout, '(/1x,a,a)') 'Viscosity active in ', &
142  trim(this%filtyp)//' Package calculations: '//trim(adjustl(this%packName))
143  end if
144  end subroutine hfb_ar
145 
146  !> @brief Check for new HFB stress period data
147  !<
148  subroutine hfb_rp(this)
149  ! -- modules
151  use tdismodule, only: kper
152  ! -- dummy
153  class(gwfhfbtype) :: this
154  ! -- local
155  integer(I4B), pointer :: iper
156  ! -- formats
157  character(len=*), parameter :: fmtlsp = &
158  &"(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')"
159 
160  call mem_setptr(iper, 'IPER', this%input_mempath)
161  if (iper == kper) then
162  call this%condsat_reset()
163  call this%source_data()
164  call this%condsat_modify()
165  else
166  write (this%iout, fmtlsp) 'HFB'
167  end if
168  end subroutine hfb_rp
169 
170  !> @brief Fill matrix terms
171  !!
172  !! Fill amatsln for the following conditions:
173  !! 1. XT3D
174  !! OR
175  !! 2. Not Newton, and
176  !! 3. Cell type n is convertible or cell type m is convertible
177  !<
178  subroutine hfb_fc(this, kiter, matrix_sln, idxglo, rhs, hnew)
179  ! -- modules
180  use constantsmodule, only: dhalf, dzero, done
181  ! -- dummy
182  class(gwfhfbtype) :: this
183  integer(I4B) :: kiter
184  class(matrixbasetype), pointer :: matrix_sln
185  integer(I4B), intent(in), dimension(:) :: idxglo
186  real(DP), intent(inout), dimension(:) :: rhs
187  real(DP), intent(inout), dimension(:) :: hnew
188  ! -- local
189  integer(I4B) :: nodes, nja
190  integer(I4B) :: ihfb, n, m
191  integer(I4B) :: ipos
192  integer(I4B) :: idiag, isymcon
193  integer(I4B) :: ixt3d
194  real(DP) :: cond, condhfb, aterm
195  real(DP) :: fawidth, faheight, faarea
196  real(DP) :: topn, topm, botn, botm
197  real(DP) :: viscratio
198  !
199  ! -- initialize variables
200  viscratio = done
201  nodes = this%dis%nodes
202  nja = this%dis%con%nja
203  if (associated(this%xt3d%ixt3d)) then
204  ixt3d = this%xt3d%ixt3d
205  else
206  ixt3d = 0
207  end if
208  !
209  if (ixt3d > 0) then
210  !
211  do ihfb = 1, this%nhfb
212  n = min(this%noden(ihfb), this%nodem(ihfb))
213  m = max(this%noden(ihfb), this%nodem(ihfb))
214  ! -- Skip if either cell is inactive.
215  if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
216  !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then
217  if (this%ivsc /= 0) then
218  call this%vsc%get_visc_ratio(n, m, hnew(n), hnew(m), viscratio)
219  end if
220  ! -- Compute scale factor for hfb correction
221  if (this%hydchr(ihfb) > dzero) then
222  if (this%inewton == 0) then
223  ipos = this%idxloc(ihfb)
224  topn = this%top(n)
225  topm = this%top(m)
226  botn = this%bot(n)
227  botm = this%bot(m)
228  if (this%icelltype(n) == 1) then
229  if (hnew(n) < topn) topn = hnew(n)
230  end if
231  if (this%icelltype(m) == 1) then
232  if (hnew(m) < topm) topm = hnew(m)
233  end if
234  if (this%ihc(this%jas(ipos)) == 2) then
235  faheight = min(topn, topm) - max(botn, botm)
236  else
237  faheight = dhalf * ((topn - botn) + (topm - botm))
238  end if
239 
240  if (this%ihc(this%jas(ipos)) == 0) then
241  faarea = this%hwva(this%jas(ipos))
242  else
243  fawidth = this%hwva(this%jas(ipos))
244  faarea = fawidth * faheight
245  end if
246 
247  condhfb = this%hydchr(ihfb) * viscratio * faarea
248  else
249  condhfb = this%hydchr(ihfb) * viscratio
250  end if
251  else
252  condhfb = this%hydchr(ihfb)
253  end if
254  ! -- Make hfb corrections for xt3d
255  call this%xt3d%xt3d_fhfb(kiter, nodes, nja, matrix_sln, idxglo, &
256  rhs, hnew, n, m, condhfb)
257  end do
258  !
259  else
260  !
261  ! -- For Newton, the effect of the barrier is included in condsat.
262  if (this%inewton == 0) then
263  do ihfb = 1, this%nhfb
264  ipos = this%idxloc(ihfb)
265  aterm = matrix_sln%get_value_pos(idxglo(ipos))
266  n = this%noden(ihfb)
267  m = this%nodem(ihfb)
268  if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
269  !
270  if (this%ivsc /= 0) then
271  call this%vsc%get_visc_ratio(n, m, hnew(n), hnew(m), viscratio)
272  end if
273  !
274  if (this%icelltype(n) == 1 .or. this%icelltype(m) == 1 .or. &
275  this%ivsc /= 0) then
276  !
277  ! -- Calculate hfb conductance
278  topn = this%top(n)
279  topm = this%top(m)
280  botn = this%bot(n)
281  botm = this%bot(m)
282  if (this%icelltype(n) == 1) then
283  if (hnew(n) < topn) topn = hnew(n)
284  end if
285  if (this%icelltype(m) == 1) then
286  if (hnew(m) < topm) topm = hnew(m)
287  end if
288  if (this%ihc(this%jas(ipos)) == 2) then
289  faheight = min(topn, topm) - max(botn, botm)
290  else
291  faheight = dhalf * ((topn - botn) + (topm - botm))
292  end if
293 
294  if (this%ihc(this%jas(ipos)) == 0) then
295  faarea = this%hwva(this%jas(ipos))
296  else
297  fawidth = this%hwva(this%jas(ipos))
298  faarea = fawidth * faheight
299  end if
300 
301  if (this%hydchr(ihfb) > dzero) then
302  condhfb = this%hydchr(ihfb) * viscratio * faarea
303  cond = aterm * condhfb / (aterm + condhfb)
304  else
305  cond = -aterm * this%hydchr(ihfb)
306  end if
307  !
308  ! -- Save cond for budget calculation
309  this%condsav(ihfb) = cond
310  !
311  ! -- Fill row n diag and off diag
312  idiag = this%ia(n)
313  call matrix_sln%add_value_pos(idxglo(idiag), aterm - cond)
314  call matrix_sln%set_value_pos(idxglo(ipos), cond)
315  !
316  ! -- Fill row m diag and off diag
317  isymcon = this%isym(ipos)
318  idiag = this%ia(m)
319  call matrix_sln%add_value_pos(idxglo(idiag), aterm - cond)
320  call matrix_sln%set_value_pos(idxglo(isymcon), cond)
321  !
322  end if
323  end do
324  end if
325  !
326  end if
327  end subroutine hfb_fc
328 
329  !> @brief flowja will automatically include the effects of the hfb for
330  !! confined and newton cases when xt3d is not used.
331  !!
332  !! This method recalculates flowja for the other cases.
333  !<
334  subroutine hfb_cq(this, hnew, flowja)
335  ! -- modules
336  use constantsmodule, only: dhalf, dzero, done
337  ! -- dummy
338  class(gwfhfbtype) :: this
339  real(DP), intent(inout), dimension(:) :: hnew
340  real(DP), intent(inout), dimension(:) :: flowja
341  ! -- local
342  integer(I4B) :: ihfb, n, m
343  integer(I4B) :: ipos
344  real(DP) :: qnm
345  real(DP) :: cond
346  integer(I4B) :: ixt3d
347  real(DP) :: condhfb
348  real(DP) :: fawidth, faheight, faarea
349  real(DP) :: topn, topm, botn, botm
350  real(DP) :: viscratio
351  !
352  ! -- initialize viscratio
353  viscratio = done
354  !
355  if (associated(this%xt3d%ixt3d)) then
356  ixt3d = this%xt3d%ixt3d
357  else
358  ixt3d = 0
359  end if
360  !
361  if (ixt3d > 0) then
362  !
363  do ihfb = 1, this%nhfb
364  n = min(this%noden(ihfb), this%nodem(ihfb))
365  m = max(this%noden(ihfb), this%nodem(ihfb))
366  ! -- Skip if either cell is inactive.
367  if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
368  !!! if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then
369  if (this%ivsc /= 0) then
370  call this%vsc%get_visc_ratio(n, m, hnew(n), hnew(m), viscratio)
371  end if
372  !
373  ! -- Compute scale factor for hfb correction
374  if (this%hydchr(ihfb) > dzero) then
375  if (this%inewton == 0) then
376  ipos = this%idxloc(ihfb)
377  topn = this%top(n)
378  topm = this%top(m)
379  botn = this%bot(n)
380  botm = this%bot(m)
381  if (this%icelltype(n) == 1) then
382  if (hnew(n) < topn) topn = hnew(n)
383  end if
384  if (this%icelltype(m) == 1) then
385  if (hnew(m) < topm) topm = hnew(m)
386  end if
387  if (this%ihc(this%jas(ipos)) == 2) then
388  faheight = min(topn, topm) - max(botn, botm)
389  else
390  faheight = dhalf * ((topn - botn) + (topm - botm))
391  end if
392 
393  if (this%ihc(this%jas(ipos)) == 0) then
394  faarea = this%hwva(this%jas(ipos))
395  else
396  fawidth = this%hwva(this%jas(ipos))
397  faarea = fawidth * faheight
398  end if
399 
400  fawidth = this%hwva(this%jas(ipos))
401  condhfb = this%hydchr(ihfb) * viscratio * faarea
402  else
403  condhfb = this%hydchr(ihfb)
404  end if
405  else
406  condhfb = this%hydchr(ihfb)
407  end if
408  ! -- Make hfb corrections for xt3d
409  call this%xt3d%xt3d_flowjahfb(n, m, hnew, flowja, condhfb)
410  end do
411  !
412  else
413  !
414  ! -- Recalculate flowja for non-newton unconfined.
415  if (this%inewton == 0) then
416  do ihfb = 1, this%nhfb
417  n = this%noden(ihfb)
418  m = this%nodem(ihfb)
419  if (this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
420  if (this%icelltype(n) == 1 .or. this%icelltype(m) == 1 .or. &
421  this%ivsc /= 0) then
422  ipos = this%dis%con%getjaindex(n, m)
423  !
424  ! -- condsav already accnts for visc adjustment
425  cond = this%condsav(ihfb)
426  qnm = cond * (hnew(m) - hnew(n))
427  flowja(ipos) = qnm
428  ipos = this%dis%con%getjaindex(m, n)
429  flowja(ipos) = -qnm
430  !
431  end if
432  end do
433  end if
434  !
435  end if
436  end subroutine hfb_cq
437 
438  !> @brief Deallocate memory
439  !<
440  subroutine hfb_da(this)
441  ! -- modules
443  ! -- dummy
444  class(gwfhfbtype) :: this
445  !
446  ! -- Scalars
447  call mem_deallocate(this%maxhfb)
448  call mem_deallocate(this%nhfb)
449  call mem_deallocate(this%ivsc)
450  !
451  ! -- Arrays
452  if (this%inunit > 0) then
453  call mem_deallocate(this%noden)
454  call mem_deallocate(this%nodem)
455  call mem_deallocate(this%hydchr)
456  call mem_deallocate(this%idxloc)
457  call mem_deallocate(this%csatsav)
458  call mem_deallocate(this%condsav)
459  end if
460  !
461  ! -- deallocate parent
462  call this%NumericalPackageType%da()
463  !
464  ! -- nullify pointers
465  this%xt3d => null()
466  this%inewton => null()
467  this%ibound => null()
468  this%icelltype => null()
469  this%ihc => null()
470  this%ia => null()
471  this%ja => null()
472  this%jas => null()
473  this%isym => null()
474  this%condsat => null()
475  this%top => null()
476  this%bot => null()
477  this%hwva => null()
478  this%vsc => null()
479  end subroutine hfb_da
480 
481  !> @brief Allocate package scalars
482  !<
483  subroutine allocate_scalars(this)
484  ! -- modules
486  ! -- dummy
487  class(gwfhfbtype) :: this
488  !
489  ! -- allocate scalars in NumericalPackageType
490  call this%NumericalPackageType%allocate_scalars()
491  !
492  ! -- allocate scalars
493  call mem_allocate(this%maxhfb, 'MAXHFB', this%memoryPath)
494  call mem_allocate(this%nhfb, 'NHFB', this%memoryPath)
495  !
496  ! -- allocate flag for determining if vsc active
497  call mem_allocate(this%ivsc, 'IVSC', this%memoryPath)
498  !
499  ! -- initialize
500  this%maxhfb = 0
501  this%nhfb = 0
502  this%ivsc = 0
503  end subroutine allocate_scalars
504 
505  !> @brief Allocate package arrays
506  !<
507  subroutine allocate_arrays(this)
508  ! -- modules
510  ! -- dummy
511  class(gwfhfbtype) :: this
512  ! -- local
513  integer(I4B) :: ihfb
514  !
515  call mem_allocate(this%noden, this%maxhfb, 'NODEN', this%memoryPath)
516  call mem_allocate(this%nodem, this%maxhfb, 'NODEM', this%memoryPath)
517  call mem_allocate(this%hydchr, this%maxhfb, 'HYDCHR', this%memoryPath)
518  call mem_allocate(this%idxloc, this%maxhfb, 'IDXLOC', this%memoryPath)
519  call mem_allocate(this%csatsav, this%maxhfb, 'CSATSAV', this%memoryPath)
520  call mem_allocate(this%condsav, this%maxhfb, 'CONDSAV', this%memoryPath)
521  !
522  ! -- initialize idxloc to 0
523  do ihfb = 1, this%maxhfb
524  this%idxloc(ihfb) = 0
525  end do
526  end subroutine allocate_arrays
527 
528  !> @ brief Source hfb input options
529  !<
530  subroutine source_options(this)
531  ! -- modules
534  ! -- dummy
535  class(gwfhfbtype) :: this
536  ! -- local
537  type(gwfhfbparamfoundtype) :: found
538 
539  ! update options from input context
540  call mem_set_value(this%iprpak, 'PRINT_INPUT', this%input_mempath, &
541  found%print_input)
542 
543  ! log options
544  write (this%iout, '(1x,a)') 'PROCESSING HFB OPTIONS'
545  if (found%print_input) then
546  write (this%iout, '(4x,a)') &
547  'THE LIST OF HFBS WILL BE PRINTED.'
548  end if
549  write (this%iout, '(1x,a)') 'END OF HFB OPTIONS'
550  end subroutine source_options
551 
552  !> @ brief Source hfb input options
553  !<
554  subroutine source_dimensions(this)
555  ! -- modules
558  ! -- dummy
559  class(gwfhfbtype) :: this
560  ! -- local
561  type(gwfhfbparamfoundtype) :: found
562 
563  ! update dimensions from input context
564  call mem_set_value(this%maxhfb, 'MAXBOUND', this%input_mempath, &
565  found%maxbound)
566 
567  ! log dimensions
568  write (this%iout, '(/1x,a)') 'PROCESSING HFB DIMENSIONS'
569  write (this%iout, '(4x,a,i7)') 'MAXHFB = ', this%maxhfb
570  write (this%iout, '(1x,a)') 'END OF HFB DIMENSIONS'
571 
572  ! check dimensions
573  if (this%maxhfb <= 0) then
574  write (errmsg, '(a)') &
575  'MAXHFB must be specified with value greater than zero.'
576  call store_error(errmsg)
577  call store_error_filename(this%input_mempath)
578  end if
579  end subroutine source_dimensions
580 
581  !> @ brief source hfb period data
582  !<
583  subroutine source_data(this)
584  ! -- modules
585  use tdismodule, only: kper
586  use constantsmodule, only: linelength
588  use geomutilmodule, only: get_node
589  ! -- dummy
590  class(gwfhfbtype), intent(inout) :: this
591  ! -- local
592  integer(I4B), dimension(:, :), pointer, contiguous :: cellids1, cellids2
593  integer(I4B), dimension(:), pointer :: cellid1, cellid2
594  real(DP), dimension(:), pointer, contiguous :: hydchr
595  character(len=LINELENGTH) :: nodenstr, nodemstr
596  integer(I4B), pointer :: nbound
597  integer(I4B) :: n, nodeu1, nodeu2, noder1, noder2
598  ! -- formats
599  character(len=*), parameter :: fmthfb = "(i10, 2a10, 1(1pg15.6))"
600 
601  ! set input context pointers
602  call mem_setptr(nbound, 'NBOUND', this%input_mempath)
603  call mem_setptr(cellids1, 'CELLID1', this%input_mempath)
604  call mem_setptr(cellids2, 'CELLID2', this%input_mempath)
605  call mem_setptr(hydchr, 'HYDCHR', this%input_mempath)
606 
607  ! set nhfb
608  this%nhfb = nbound
609 
610  ! log data
611  write (this%iout, '(//,1x,a)') 'READING HFB DATA'
612  if (this%iprpak > 0) then
613  write (this%iout, '(3a10, 1a15)') 'HFB NUM', 'CELL1', 'CELL2', &
614  'HYDCHR'
615  end if
616 
617  ! update state
618  do n = 1, this%nhfb
619 
620  ! set cellid
621  cellid1 => cellids1(:, n)
622  cellid2 => cellids2(:, n)
623 
624  ! set node user
625  if (this%dis%ndim == 1) then
626  nodeu1 = cellid1(1)
627  nodeu2 = cellid2(1)
628  elseif (this%dis%ndim == 2) then
629  nodeu1 = get_node(cellid1(1), 1, cellid1(2), &
630  this%dis%mshape(1), 1, &
631  this%dis%mshape(2))
632  nodeu2 = get_node(cellid2(1), 1, cellid2(2), &
633  this%dis%mshape(1), 1, &
634  this%dis%mshape(2))
635  else
636  nodeu1 = get_node(cellid1(1), cellid1(2), cellid1(3), &
637  this%dis%mshape(1), &
638  this%dis%mshape(2), &
639  this%dis%mshape(3))
640  nodeu2 = get_node(cellid2(1), cellid2(2), cellid2(3), &
641  this%dis%mshape(1), &
642  this%dis%mshape(2), &
643  this%dis%mshape(3))
644  end if
645 
646  ! set nodes
647  noder1 = this%dis%get_nodenumber(nodeu1, 1)
648  noder2 = this%dis%get_nodenumber(nodeu2, 1)
649  if (noder1 <= 0 .or. &
650  noder2 <= 0) then
651  cycle
652  else
653  this%noden(n) = noder1
654  this%nodem(n) = noder2
655  end if
656 
657  this%hydchr(n) = hydchr(n)
658 
659  ! print input if requested
660  if (this%iprpak /= 0) then
661  call this%dis%noder_to_string(this%noden(n), nodenstr)
662  call this%dis%noder_to_string(this%nodem(n), nodemstr)
663  write (this%iout, fmthfb) n, trim(adjustl(nodenstr)), &
664  trim(adjustl(nodemstr)), this%hydchr(n)
665  end if
666  end do
667 
668  ! check errors
669  if (count_errors() > 0) then
670  call store_error('Errors encountered in HFB input file.')
671  call store_error_filename(this%input_fname)
672  end if
673 
674  ! finalize logging
675  write (this%iout, '(3x,i0,a,i0)') this%nhfb, &
676  ' HFBs READ FOR STRESS PERIOD ', kper
677  write (this%iout, '(1x,a)') 'END READING HFB DATA'
678 
679  ! input data check
680  call this%check_data()
681  end subroutine source_data
682 
683  !> @brief Check for hfb's between two unconnected cells and write a warning
684  !!
685  !! Store ipos in idxloc
686  !<
687  subroutine check_data(this)
688  ! -- modules
689  use constantsmodule, only: linelength
690  ! -- dummy
691  class(gwfhfbtype) :: this
692  ! -- local
693  integer(I4B) :: ihfb, n, m
694  integer(I4B) :: ipos
695  character(len=LINELENGTH) :: nodenstr, nodemstr
696  logical :: found
697  ! -- formats
698  character(len=*), parameter :: fmterr = "(1x, 'HFB no. ',i0, &
699  &' is between two unconnected cells: ', a, ' and ', a)"
700  character(len=*), parameter :: fmtverr = "(1x, 'HFB no. ',i0, &
701  &' is between two cells not horizontally connected: ', a, ' and ', a)"
702  !
703  do ihfb = 1, this%nhfb
704  n = this%noden(ihfb)
705  m = this%nodem(ihfb)
706  found = .false.
707  do ipos = this%ia(n) + 1, this%ia(n + 1) - 1
708  if (m == this%ja(ipos)) then
709  found = .true.
710  this%idxloc(ihfb) = ipos
711  exit
712  end if
713  end do
714  !
715  ! -- check to make sure cells are connected
716  if (.not. found) then
717  call this%dis%noder_to_string(n, nodenstr)
718  call this%dis%noder_to_string(m, nodemstr)
719  write (errmsg, fmterr) ihfb, trim(adjustl(nodenstr)), &
720  trim(adjustl(nodemstr))
721  call store_error(errmsg)
722  end if
723  end do
724  !
725  ! -- Stop if errors detected
726  if (count_errors() > 0) then
727  call store_error_filename(this%input_fname)
728  end if
729  end subroutine check_data
730 
731  !> @brief Reset condsat to its value prior to being modified by hfb's
732  !<
733  subroutine condsat_reset(this)
734  ! -- dummy
735  class(gwfhfbtype) :: this
736  ! -- local
737  integer(I4B) :: ihfb
738  integer(I4B) :: ipos
739  !
740  do ihfb = 1, this%nhfb
741  ipos = this%idxloc(ihfb)
742  this%condsat(this%jas(ipos)) = this%csatsav(ihfb)
743  end do
744  end subroutine condsat_reset
745 
746  !> @brief Modify condsat
747  !!
748  !! Modify condsat for the following conditions:
749  !! 1. If Newton is active
750  !! 2. If icelltype for n and icelltype for m is 0
751  !<
752  subroutine condsat_modify(this)
753  ! -- modules
754  use constantsmodule, only: dhalf, dzero
755  ! -- dummy
756  class(gwfhfbtype) :: this
757  ! -- local
758  integer(I4B) :: ihfb, n, m
759  integer(I4B) :: ipos
760  real(DP) :: cond, condhfb
761  real(DP) :: fawidth, faheight, faarea
762  real(DP) :: topn, topm, botn, botm
763  !
764  do ihfb = 1, this%nhfb
765  ipos = this%idxloc(ihfb)
766  cond = this%condsat(this%jas(ipos))
767  this%csatsav(ihfb) = cond
768  n = this%noden(ihfb)
769  m = this%nodem(ihfb)
770  !
771  if (this%inewton == 1 .or. &
772  (this%icelltype(n) == 0 .and. this%icelltype(m) == 0)) then
773  !
774  ! -- Calculate hfb conductance
775  topn = this%top(n)
776  topm = this%top(m)
777  botn = this%bot(n)
778  botm = this%bot(m)
779  if (this%ihc(this%jas(ipos)) == 2) then
780  faheight = min(topn, topm) - max(botn, botm)
781  else
782  faheight = dhalf * ((topn - botn) + (topm - botm))
783  end if
784 
785  if (this%ihc(this%jas(ipos)) == 0) then
786  faarea = this%hwva(this%jas(ipos))
787  else
788  fawidth = this%hwva(this%jas(ipos))
789  faarea = fawidth * faheight
790  end if
791 
792  if (this%hydchr(ihfb) > dzero) then
793  condhfb = this%hydchr(ihfb) * faarea
794  cond = cond * condhfb / (cond + condhfb)
795  else
796  cond = -cond * this%hydchr(ihfb)
797  end if
798  this%condsat(this%jas(ipos)) = cond
799  end if
800  end do
801  end subroutine condsat_modify
802 
803 end module gwfhfbmodule
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 dhalf
real constant 1/2
Definition: Constants.f90:68
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:65
real(dp), parameter done
real constant 1
Definition: Constants.f90:76
integer(i4b) function, public get_node(ilay, irow, icol, nlay, nrow, ncol)
Get node number, given layer, row, and column indices for a structured grid. If any argument is inval...
Definition: GeomUtil.f90:83
subroutine hfb_fc(this, kiter, matrix_sln, idxglo, rhs, hnew)
Fill matrix terms.
Definition: gwf-hfb.f90:179
subroutine check_data(this)
Check for hfb's between two unconnected cells and write a warning.
Definition: gwf-hfb.f90:688
subroutine hfb_da(this)
Deallocate memory.
Definition: gwf-hfb.f90:441
subroutine hfb_cq(this, hnew, flowja)
flowja will automatically include the effects of the hfb for confined and newton cases when xt3d is n...
Definition: gwf-hfb.f90:335
subroutine, public hfb_cr(hfbobj, name_model, input_mempath, inunit, iout)
Create a new hfb object.
Definition: gwf-hfb.f90:71
subroutine allocate_scalars(this)
Allocate package scalars.
Definition: gwf-hfb.f90:484
subroutine condsat_modify(this)
Modify condsat.
Definition: gwf-hfb.f90:753
subroutine condsat_reset(this)
Reset condsat to its value prior to being modified by hfb's.
Definition: gwf-hfb.f90:734
subroutine source_data(this)
@ brief source hfb period data
Definition: gwf-hfb.f90:584
subroutine source_dimensions(this)
@ brief Source hfb input options
Definition: gwf-hfb.f90:555
subroutine hfb_rp(this)
Check for new HFB stress period data.
Definition: gwf-hfb.f90:149
subroutine allocate_arrays(this)
Allocate package arrays.
Definition: gwf-hfb.f90:508
subroutine hfb_ar(this, ibound, xt3d, dis, invsc, vsc)
Allocate and read.
Definition: gwf-hfb.f90:95
subroutine source_options(this)
@ brief Source hfb input options
Definition: gwf-hfb.f90:531
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 base numerical package type.
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 store_error_filename(filename, terminate)
Store the erroring file name.
Definition: Sim.f90:203
This module contains simulation variables.
Definition: SimVariables.f90:9
character(len=maxcharlen) errmsg
error message string
integer(i4b), pointer, public kper
current stress period number
Definition: tdis.f90:23