MODFLOW 6  version 6.5.0.dev2
MODFLOW 6 Code Documentation
tsp-fmi.f90
Go to the documentation of this file.
2 
3  use kindmodule, only: dp, i4b
7  use simvariablesmodule, only: errmsg
9  use basedismodule, only: disbasetype
10  use listmodule, only: listtype
16 
17  implicit none
18  private
19  public :: tspfmitype
20  public :: fmi_cr
21 
22  character(len=LENPACKAGENAME) :: text = ' GWTFMI'
23 
24  integer(I4B), parameter :: nbditems = 2
25  character(len=LENBUDTXT), dimension(NBDITEMS) :: budtxt
26  data budtxt/' FLOW-ERROR', ' FLOW-CORRECTION'/
27 
29  real(dp), dimension(:), contiguous, pointer :: concpack => null()
30  real(dp), dimension(:), contiguous, pointer :: qmfrommvr => null()
31  end type
32 
34  type(budgetobjecttype), pointer :: ptr
35  end type budobjptrarray
36 
38 
39  integer(I4B), dimension(:), pointer, contiguous :: iatp => null() !< advanced transport package applied to gwfpackages
40  integer(I4B), pointer :: iflowerr => null() !< add the flow error correction
41  real(dp), dimension(:), pointer, contiguous :: flowcorrect => null() !< mass flow correction
42  real(dp), pointer :: eqnsclfac => null() !< governing equation scale factor; =1. for solute; =rhow*cpw for energy
44  dimension(:), pointer, contiguous :: datp => null()
45  type(budobjptrarray), dimension(:), allocatable :: aptbudobj !< flow budget objects for the advanced packages
46 
47  contains
48 
49  procedure :: allocate_arrays => gwtfmi_allocate_arrays
50  procedure :: allocate_gwfpackages => gwtfmi_allocate_gwfpackages
51  procedure :: allocate_scalars => gwtfmi_allocate_scalars
52  procedure :: deallocate_gwfpackages => gwtfmi_deallocate_gwfpackages
53  procedure :: fmi_rp
54  procedure :: fmi_ad
55  procedure :: fmi_fc
56  procedure :: fmi_cq
57  procedure :: fmi_bd
58  procedure :: fmi_ot_flow
59  procedure :: fmi_da => gwtfmi_da
60  procedure :: gwfsatold
63  procedure :: read_options => gwtfmi_read_options
64  procedure :: set_aptbudobj_pointer
65  procedure :: read_packagedata => gwtfmi_read_packagedata
66  procedure :: set_active_status
67 
68  end type tspfmitype
69 
70 contains
71 
72  !> @brief Create a new FMI object
73  !<
74  subroutine fmi_cr(fmiobj, name_model, inunit, iout, eqnsclfac, depvartype)
75  ! -- dummy
76  type(tspfmitype), pointer :: fmiobj
77  character(len=*), intent(in) :: name_model
78  integer(I4B), intent(in) :: inunit
79  integer(I4B), intent(in) :: iout
80  real(dp), intent(in), pointer :: eqnsclfac !< governing equation scale factor
81  character(len=LENVARNAME), intent(in) :: depvartype
82  !
83  ! -- Create the object
84  allocate (fmiobj)
85  !
86  ! -- create name and memory path
87  call fmiobj%set_names(1, name_model, 'FMI', 'FMI')
88  fmiobj%text = text
89  !
90  ! -- Allocate scalars
91  call fmiobj%allocate_scalars()
92  !
93  ! -- Set variables
94  fmiobj%inunit = inunit
95  fmiobj%iout = iout
96  !
97  ! -- Initialize block parser
98  call fmiobj%parser%Initialize(fmiobj%inunit, fmiobj%iout)
99  !
100  ! -- Assign label based on dependent variable
101  fmiobj%depvartype = depvartype
102  !
103  ! -- Store pointer to governing equation scale factor
104  fmiobj%eqnsclfac => eqnsclfac
105  !
106  ! -- Return
107  return
108  end subroutine fmi_cr
109 
110  !> @brief Read and prepare
111  !<
112  subroutine fmi_rp(this, inmvr)
113  ! -- modules
114  use tdismodule, only: kper, kstp
115  ! -- dummy
116  class(tspfmitype) :: this
117  integer(I4B), intent(in) :: inmvr
118  ! -- local
119  ! -- formats
120  !
121  ! --Check to make sure MVT Package is active if mvr flows are available.
122  ! This cannot be checked until RP because exchange doesn't set a pointer
123  ! to mvrbudobj until exg_ar().
124  if (kper * kstp == 1) then
125  if (associated(this%mvrbudobj) .and. inmvr == 0) then
126  write (errmsg, '(a)') 'GWF water mover is active but the GWT MVT &
127  &package has not been specified. activate GWT MVT package.'
128  call store_error(errmsg, terminate=.true.)
129  end if
130  if (.not. associated(this%mvrbudobj) .and. inmvr > 0) then
131  write (errmsg, '(a)') 'GWF water mover terms are not available &
132  &but the GWT MVT package has been activated. Activate GWF-GWT &
133  &exchange or specify GWFMOVER in FMI PACKAGEDATA.'
134  call store_error(errmsg, terminate=.true.)
135  end if
136  end if
137  !
138  ! -- Return
139  return
140  end subroutine fmi_rp
141 
142  !> @brief Advance routine for FMI object
143  !<
144  subroutine fmi_ad(this, cnew)
145  ! -- modules
146  use constantsmodule, only: dhdry
147  ! -- dummy
148  class(tspfmitype) :: this
149  real(DP), intent(inout), dimension(:) :: cnew
150  ! -- local
151  integer(I4B) :: n
152  character(len=*), parameter :: fmtdry = &
153  &"(/1X,'WARNING: DRY CELL ENCOUNTERED AT ',a,'; RESET AS INACTIVE &
154  &WITH DRY CONCENTRATION = ', G13.5)"
155  character(len=*), parameter :: fmtrewet = &
156  &"(/1X,'DRY CELL REACTIVATED AT ', a,&
157  &' WITH STARTING CONCENTRATION =',G13.5)"
158  !
159  ! -- Set flag to indicated that flows are being updated. For the case where
160  ! flows may be reused (only when flows are read from a file) then set
161  ! the flag to zero to indicated that flows were not updated
162  this%iflowsupdated = 1
163  !
164  ! -- If reading flows from a budget file, read the next set of records
165  if (this%iubud /= 0) then
166  call this%advance_bfr()
167  end if
168  !
169  ! -- If reading heads from a head file, read the next set of records
170  if (this%iuhds /= 0) then
171  call this%advance_hfr()
172  end if
173  !
174  ! -- If mover flows are being read from file, read the next set of records
175  if (this%iumvr /= 0) then
176  call this%mvrbudobj%bfr_advance(this%dis, this%iout)
177  end if
178  !
179  ! -- If advanced package flows are being read from file, read the next set of records
180  if (this%flows_from_file .and. this%inunit /= 0) then
181  do n = 1, size(this%aptbudobj)
182  call this%aptbudobj(n)%ptr%bfr_advance(this%dis, this%iout)
183  end do
184  end if
185  !
186  ! -- set inactive transport cell status
187  if (this%idryinactive /= 0) then
188  call this%set_active_status(cnew)
189  end if
190  !
191  ! -- Return
192  return
193  end subroutine fmi_ad
194 
195  !> @brief Calculate coefficients and fill matrix and rhs terms associated
196  !! with FMI object
197  !<
198  subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs)
199  ! -- dummy
200  class(tspfmitype) :: this
201  integer, intent(in) :: nodes
202  real(DP), intent(in), dimension(nodes) :: cold
203  integer(I4B), intent(in) :: nja
204  class(matrixbasetype), pointer :: matrix_sln
205  integer(I4B), intent(in), dimension(nja) :: idxglo
206  real(DP), intent(inout), dimension(nodes) :: rhs
207  ! -- local
208  integer(I4B) :: n, idiag, idiag_sln
209  real(DP) :: qcorr
210  !
211  ! -- Calculate the flow imbalance error and make a correction for it
212  if (this%iflowerr /= 0) then
213  !
214  ! -- Correct the transport solution for the flow imbalance by adding
215  ! the flow residual to the diagonal
216  do n = 1, nodes
217  idiag = this%dis%con%ia(n)
218  idiag_sln = idxglo(idiag)
219  !call matrix_sln%add_value_pos(idiag_sln, -this%gwfflowja(idiag))
220  qcorr = -this%gwfflowja(idiag) * this%eqnsclfac
221  call matrix_sln%add_value_pos(idiag_sln, qcorr)
222  end do
223  end if
224  !
225  ! -- Return
226  return
227  end subroutine fmi_fc
228 
229  !> @brief Calculate flow correction
230  !!
231  !! Where there is a flow imbalance for a given cell, a correction may be
232  !! applied if selected
233  !<
234  subroutine fmi_cq(this, cnew, flowja)
235  ! -- modules
236  ! -- dummy
237  class(tspfmitype) :: this
238  real(DP), intent(in), dimension(:) :: cnew
239  real(DP), dimension(:), contiguous, intent(inout) :: flowja
240  ! -- local
241  integer(I4B) :: n
242  integer(I4B) :: idiag
243  real(DP) :: rate
244  !
245  ! -- If not adding flow error correction, return
246  if (this%iflowerr /= 0) then
247  !
248  ! -- Accumulate the flow correction term
249  do n = 1, this%dis%nodes
250  rate = dzero
251  idiag = this%dis%con%ia(n)
252  if (this%ibound(n) > 0) then
253  rate = -this%gwfflowja(idiag) * cnew(n) * this%eqnsclfac
254  end if
255  this%flowcorrect(n) = rate
256  flowja(idiag) = flowja(idiag) + rate
257  end do
258  end if
259  !
260  ! -- Return
261  return
262  end subroutine fmi_cq
263 
264  !> @brief Calculate budget terms associated with FMI object
265  !<
266  subroutine fmi_bd(this, isuppress_output, model_budget)
267  ! -- modules
268  use tdismodule, only: delt
270  ! -- dummy
271  class(tspfmitype) :: this
272  integer(I4B), intent(in) :: isuppress_output
273  type(budgettype), intent(inout) :: model_budget
274  ! -- local
275  real(DP) :: rin
276  real(DP) :: rout
277  !
278  ! -- flow correction
279  if (this%iflowerr /= 0) then
280  call rate_accumulator(this%flowcorrect, rin, rout)
281  call model_budget%addentry(rin, rout, delt, budtxt(2), isuppress_output)
282  end if
283  !
284  ! -- Return
285  return
286  end subroutine fmi_bd
287 
288  !> @brief Save budget terms associated with FMI object
289  !<
290  subroutine fmi_ot_flow(this, icbcfl, icbcun)
291  ! -- dummy
292  class(tspfmitype) :: this
293  integer(I4B), intent(in) :: icbcfl
294  integer(I4B), intent(in) :: icbcun
295  ! -- local
296  integer(I4B) :: ibinun
297  integer(I4B) :: iprint, nvaluesp, nwidthp
298  character(len=1) :: cdatafmp = ' ', editdesc = ' '
299  real(DP) :: dinact
300  !
301  ! -- Set unit number for binary output
302  if (this%ipakcb < 0) then
303  ibinun = icbcun
304  elseif (this%ipakcb == 0) then
305  ibinun = 0
306  else
307  ibinun = this%ipakcb
308  end if
309  if (icbcfl == 0) ibinun = 0
310  !
311  ! -- Do not save flow corrections if not active
312  if (this%iflowerr == 0) ibinun = 0
313  !
314  ! -- Record the storage rates if requested
315  if (ibinun /= 0) then
316  iprint = 0
317  dinact = dzero
318  !
319  ! -- flow correction
320  call this%dis%record_array(this%flowcorrect, this%iout, iprint, -ibinun, &
321  budtxt(2), cdatafmp, nvaluesp, &
322  nwidthp, editdesc, dinact)
323  end if
324  !
325  ! -- Return
326  return
327  end subroutine fmi_ot_flow
328 
329  !> @brief Deallocate variables
330  !!
331  !! Deallocate memory associated with FMI object
332  !<
333  subroutine gwtfmi_da(this)
334  ! -- modules
336  ! -- dummy
337  class(tspfmitype) :: this
338  ! -- todo: finalize hfr and bfr either here or in a finalize routine
339  !
340  ! -- deallocate any memory stored with gwfpackages
341  call this%deallocate_gwfpackages()
342  !
343  ! -- deallocate fmi arrays
344  if (associated(this%datp)) then
345  deallocate (this%datp)
346  deallocate (this%gwfpackages)
347  deallocate (this%flowpacknamearray)
348  call mem_deallocate(this%iatp)
349  call mem_deallocate(this%igwfmvrterm)
350  end if
351 
352  deallocate (this%aptbudobj)
353  call mem_deallocate(this%flowcorrect)
354  call mem_deallocate(this%ibdgwfsat0)
355  if (this%flows_from_file) then
356  call mem_deallocate(this%gwfstrgss)
357  call mem_deallocate(this%gwfstrgsy)
358  end if
359  !
360  ! -- special treatment, these could be from mem_checkin
361  call mem_deallocate(this%gwfhead, 'GWFHEAD', this%memoryPath)
362  call mem_deallocate(this%gwfsat, 'GWFSAT', this%memoryPath)
363  call mem_deallocate(this%gwfspdis, 'GWFSPDIS', this%memoryPath)
364  call mem_deallocate(this%gwfflowja, 'GWFFLOWJA', this%memoryPath)
365  !
366  ! -- deallocate scalars
367  call mem_deallocate(this%flows_from_file)
368  call mem_deallocate(this%iflowsupdated)
369  call mem_deallocate(this%iflowerr)
370  call mem_deallocate(this%igwfstrgss)
371  call mem_deallocate(this%igwfstrgsy)
372  call mem_deallocate(this%iubud)
373  call mem_deallocate(this%iuhds)
374  call mem_deallocate(this%iumvr)
375  call mem_deallocate(this%nflowpack)
376  call mem_deallocate(this%idryinactive)
377  !
378  ! -- deallocate parent
379  call this%NumericalPackageType%da()
380  !
381  ! -- Return
382  return
383  end subroutine gwtfmi_da
384 
385  !> @ brief Allocate scalars
386  !!
387  !! Allocate scalar variables for an FMI object
388  !<
389  subroutine gwtfmi_allocate_scalars(this)
390  ! -- modules
392  ! -- dummy
393  class(tspfmitype) :: this
394  ! -- local
395  !
396  ! -- allocate scalars in parent
397  call this%FlowModelInterfaceType%allocate_scalars()
398  !
399  ! -- Allocate
400  call mem_allocate(this%iflowerr, 'IFLOWERR', this%memoryPath)
401  !
402  ! -- Although not a scalar, allocate the advanced package transport
403  ! budget object to zero so that it can be dynamically resized later
404  allocate (this%aptbudobj(0))
405  !
406  ! -- Initialize
407  this%iflowerr = 0
408  !
409  ! -- Return
410  return
411  end subroutine gwtfmi_allocate_scalars
412 
413  !> @ brief Allocate arrays for FMI object
414  !!
415  !! Method to allocate arrays for the FMI package.
416  !<
417  subroutine gwtfmi_allocate_arrays(this, nodes)
419  ! -- modules
420  use constantsmodule, only: dzero
421  ! -- dummy
422  class(tspfmitype) :: this
423  integer(I4B), intent(in) :: nodes
424  ! -- local
425  integer(I4B) :: n
426  !
427  ! -- allocate parent arrays
428  call this%FlowModelInterfaceType%allocate_arrays(nodes)
429  !
430  ! -- Allocate variables needed for all cases
431  if (this%iflowerr == 0) then
432  call mem_allocate(this%flowcorrect, 1, 'FLOWCORRECT', this%memoryPath)
433  else
434  call mem_allocate(this%flowcorrect, nodes, 'FLOWCORRECT', this%memoryPath)
435  end if
436  do n = 1, size(this%flowcorrect)
437  this%flowcorrect(n) = dzero
438  end do
439  !
440  ! -- return
441  return
442  end subroutine gwtfmi_allocate_arrays
443 
444  !> @brief Set gwt transport cell status
445  !!
446  !! Dry GWF cells are treated differently by GWT and GWE. Transport does not
447  !! occur in deactivated GWF cells; however, GWE still simulates conduction
448  !! through dry cells.
449  !<
450  subroutine set_active_status(this, cnew)
451  ! -- modules
452  use constantsmodule, only: dhdry
453  ! -- dummy
454  class(tspfmitype) :: this
455  real(DP), intent(inout), dimension(:) :: cnew
456  ! -- local
457  integer(I4B) :: n
458  integer(I4B) :: m
459  integer(I4B) :: ipos
460  real(DP) :: crewet, tflow, flownm
461  character(len=15) :: nodestr
462  ! -- formats
463  character(len=*), parameter :: fmtoutmsg1 = &
464  "(1x,'WARNING: DRY CELL ENCOUNTERED AT ', a,'; RESET AS INACTIVE WITH &
465  &DRY ', a, '=', G13.5)"
466  character(len=*), parameter :: fmtoutmsg2 = &
467  &"(1x,'DRY CELL REACTIVATED AT', a, 'WITH STARTING', a, '=', G13.5)"
468  !
469  do n = 1, this%dis%nodes
470  ! -- Calculate the ibound-like array that has 0 if saturation
471  ! is zero and 1 otherwise
472  if (this%gwfsat(n) > dzero) then
473  this%ibdgwfsat0(n) = 1
474  else
475  this%ibdgwfsat0(n) = 0
476  end if
477  !
478  ! -- Check if active transport cell is inactive for flow
479  if (this%ibound(n) > 0) then
480  if (this%gwfhead(n) == dhdry) then
481  ! -- transport cell should be made inactive
482  this%ibound(n) = 0
483  cnew(n) = dhdry
484  call this%dis%noder_to_string(n, nodestr)
485  write (this%iout, fmtoutmsg1) &
486  trim(nodestr), trim(adjustl(this%depvartype)), dhdry
487  end if
488  end if
489  end do
490  !
491  ! -- if flow cell is dry, then set gwt%ibound = 0 and conc to dry
492  do n = 1, this%dis%nodes
493  !
494  ! -- Convert dry transport cell to active if flow has rewet
495  if (cnew(n) == dhdry) then
496  if (this%gwfhead(n) /= dhdry) then
497  !
498  ! -- obtain weighted concentration/temperature
499  crewet = dzero
500  tflow = dzero
501  do ipos = this%dis%con%ia(n) + 1, this%dis%con%ia(n + 1) - 1
502  m = this%dis%con%ja(ipos)
503  flownm = this%gwfflowja(ipos)
504  if (flownm > 0) then
505  if (this%ibound(m) /= 0) then
506  crewet = crewet + cnew(m) * flownm ! kluge note: apparently no need to multiply flows by eqnsclfac
507  tflow = tflow + this%gwfflowja(ipos) ! since it will divide out below anyway
508  end if
509  end if
510  end do
511  if (tflow > dzero) then
512  crewet = crewet / tflow
513  else
514  crewet = dzero
515  end if
516  !
517  ! -- cell is now wet
518  this%ibound(n) = 1
519  cnew(n) = crewet
520  call this%dis%noder_to_string(n, nodestr)
521  write (this%iout, fmtoutmsg2) &
522  trim(nodestr), trim(adjustl(this%depvartype)), crewet
523  end if
524  end if
525  end do
526  !
527  ! -- Return
528  return
529  end subroutine set_active_status
530 
531  !> @brief Calculate the previous saturation level
532  !!
533  !! Calculate the groundwater cell head saturation for the end of
534  !! the last time step
535  !<
536  function gwfsatold(this, n, delt) result(satold)
537  ! -- modules
538  ! -- dummy
539  class(tspfmitype) :: this
540  integer(I4B), intent(in) :: n
541  real(dp), intent(in) :: delt
542  ! -- result
543  real(dp) :: satold
544  ! -- local
545  real(dp) :: vcell
546  real(dp) :: vnew
547  real(dp) :: vold
548  !
549  ! -- calculate the value
550  vcell = this%dis%area(n) * (this%dis%top(n) - this%dis%bot(n))
551  vnew = vcell * this%gwfsat(n)
552  vold = vnew
553  if (this%igwfstrgss /= 0) vold = vold + this%gwfstrgss(n) * delt
554  if (this%igwfstrgsy /= 0) vold = vold + this%gwfstrgsy(n) * delt
555  satold = vold / vcell
556  !
557  ! -- Return
558  return
559  end function gwfsatold
560 
561  !> @brief Read options from input file
562  !<
563  subroutine gwtfmi_read_options(this)
564  ! -- modules
565  use constantsmodule, only: linelength, dem6
568  ! -- dummy
569  class(tspfmitype) :: this
570  ! -- local
571  character(len=LINELENGTH) :: keyword
572  integer(I4B) :: ierr
573  logical :: isfound, endOfBlock
574  character(len=*), parameter :: fmtisvflow = &
575  "(4x,'CELL-BY-CELL FLOW INFORMATION WILL BE SAVED TO BINARY FILE &
576  &WHENEVER ICBCFL IS NOT ZERO AND FLOW IMBALANCE CORRECTION ACTIVE.')"
577  character(len=*), parameter :: fmtifc = &
578  &"(4x,'MASS WILL BE ADDED OR REMOVED TO COMPENSATE FOR FLOW IMBALANCE.')"
579  !
580  ! -- get options block
581  call this%parser%GetBlock('OPTIONS', isfound, ierr, blockrequired=.false., &
582  supportopenclose=.true.)
583  !
584  ! -- parse options block if detected
585  if (isfound) then
586  write (this%iout, '(1x,a)') 'PROCESSING FMI OPTIONS'
587  do
588  call this%parser%GetNextLine(endofblock)
589  if (endofblock) exit
590  call this%parser%GetStringCaps(keyword)
591  select case (keyword)
592  case ('SAVE_FLOWS')
593  this%ipakcb = -1
594  write (this%iout, fmtisvflow)
595  case ('FLOW_IMBALANCE_CORRECTION')
596  write (this%iout, fmtifc)
597  this%iflowerr = 1
598  case default
599  write (errmsg, '(a,a)') 'Unknown FMI option: ', &
600  trim(keyword)
601  call store_error(errmsg)
602  call this%parser%StoreErrorUnit()
603  end select
604  end do
605  write (this%iout, '(1x,a)') 'END OF FMI OPTIONS'
606  end if
607  !
608  ! -- Return
609  return
610  end subroutine gwtfmi_read_options
611 
612  !> @brief Read PACKAGEDATA block
613  !!
614  !! Read packagedata block from input file
615  !<
616  subroutine gwtfmi_read_packagedata(this)
617  ! -- modules
618  use openspecmodule, only: access, form
622  ! -- dummy
623  class(tspfmitype) :: this
624  ! -- local
625  type(budgetobjecttype), pointer :: budobjptr
626  character(len=LINELENGTH) :: keyword, fname
627  character(len=LENPACKAGENAME) :: pname
628  integer(I4B) :: i
629  integer(I4B) :: ierr
630  integer(I4B) :: inunit
631  integer(I4B) :: iapt
632  logical :: isfound, endOfBlock
633  logical :: blockrequired
634  logical :: exist
635  type(budobjptrarray), dimension(:), allocatable :: tmpbudobj
636  !
637  ! -- initialize
638  iapt = 0
639  blockrequired = .true.
640  !
641  ! -- get options block
642  call this%parser%GetBlock('PACKAGEDATA', isfound, ierr, &
643  blockrequired=blockrequired, &
644  supportopenclose=.true.)
645  !
646  ! -- parse options block if detected
647  if (isfound) then
648  write (this%iout, '(1x,a)') 'PROCESSING FMI PACKAGEDATA'
649  do
650  call this%parser%GetNextLine(endofblock)
651  if (endofblock) exit
652  call this%parser%GetStringCaps(keyword)
653  select case (keyword)
654  case ('GWFBUDGET')
655  call this%parser%GetStringCaps(keyword)
656  if (keyword /= 'FILEIN') then
657  call store_error('GWFBUDGET keyword must be followed by '// &
658  '"FILEIN" then by filename.')
659  call this%parser%StoreErrorUnit()
660  end if
661  call this%parser%GetString(fname)
662  inunit = getunit()
663  inquire (file=trim(fname), exist=exist)
664  if (.not. exist) then
665  call store_error('Could not find file '//trim(fname))
666  call this%parser%StoreErrorUnit()
667  end if
668  call openfile(inunit, this%iout, fname, 'DATA(BINARY)', form, &
669  access, 'UNKNOWN')
670  this%iubud = inunit
671  call this%initialize_bfr()
672  case ('GWFHEAD')
673  call this%parser%GetStringCaps(keyword)
674  if (keyword /= 'FILEIN') then
675  call store_error('GWFHEAD keyword must be followed by '// &
676  '"FILEIN" then by filename.')
677  call this%parser%StoreErrorUnit()
678  end if
679  call this%parser%GetString(fname)
680  inquire (file=trim(fname), exist=exist)
681  if (.not. exist) then
682  call store_error('Could not find file '//trim(fname))
683  call this%parser%StoreErrorUnit()
684  end if
685  inunit = getunit()
686  call openfile(inunit, this%iout, fname, 'DATA(BINARY)', form, &
687  access, 'UNKNOWN')
688  this%iuhds = inunit
689  call this%initialize_hfr()
690  case ('GWFMOVER')
691  call this%parser%GetStringCaps(keyword)
692  if (keyword /= 'FILEIN') then
693  call store_error('GWFMOVER keyword must be followed by '// &
694  '"FILEIN" then by filename.')
695  call this%parser%StoreErrorUnit()
696  end if
697  call this%parser%GetString(fname)
698  inunit = getunit()
699  call openfile(inunit, this%iout, fname, 'DATA(BINARY)', form, &
700  access, 'UNKNOWN')
701  this%iumvr = inunit
702  call budgetobject_cr_bfr(this%mvrbudobj, 'MVT', this%iumvr, &
703  this%iout)
704  call this%mvrbudobj%fill_from_bfr(this%dis, this%iout)
705  case default
706  !
707  ! --expand the size of aptbudobj, which stores a pointer to the budobj
708  allocate (tmpbudobj(iapt))
709  do i = 1, size(this%aptbudobj)
710  tmpbudobj(i)%ptr => this%aptbudobj(i)%ptr
711  end do
712  deallocate (this%aptbudobj)
713  allocate (this%aptbudobj(iapt + 1))
714  do i = 1, size(tmpbudobj)
715  this%aptbudobj(i)%ptr => tmpbudobj(i)%ptr
716  end do
717  deallocate (tmpbudobj)
718  !
719  ! -- Open the budget file and start filling it
720  iapt = iapt + 1
721  pname = keyword(1:lenpackagename)
722  call this%parser%GetStringCaps(keyword)
723  if (keyword /= 'FILEIN') then
724  call store_error('Package name must be followed by '// &
725  '"FILEIN" then by filename.')
726  call this%parser%StoreErrorUnit()
727  end if
728  call this%parser%GetString(fname)
729  inunit = getunit()
730  call openfile(inunit, this%iout, fname, 'DATA(BINARY)', form, &
731  access, 'UNKNOWN')
732  call budgetobject_cr_bfr(budobjptr, pname, inunit, &
733  this%iout, colconv2=['GWF '])
734  call budobjptr%fill_from_bfr(this%dis, this%iout)
735  this%aptbudobj(iapt)%ptr => budobjptr
736  end select
737  end do
738  write (this%iout, '(1x,a)') 'END OF FMI PACKAGEDATA'
739  end if
740  !
741  ! -- Return
742  return
743  end subroutine gwtfmi_read_packagedata
744 
745  !> @brief Set the pointer to a budget object
746  !!
747  !! An advanced transport can pass in a name and a
748  !! pointer budget object, and this routine will look through the budget
749  !! objects managed by FMI and point to the one with the same name, such as
750  !! LAK-1, SFR-1, etc.
751  !<
752  subroutine set_aptbudobj_pointer(this, name, budobjptr)
753  ! -- modules
754  class(tspfmitype) :: this
755  ! -- dumm
756  character(len=*), intent(in) :: name
757  type(budgetobjecttype), pointer :: budobjptr
758  ! -- local
759  integer(I4B) :: i
760  !
761  ! -- find and set the pointer
762  do i = 1, size(this%aptbudobj)
763  if (this%aptbudobj(i)%ptr%name == name) then
764  budobjptr => this%aptbudobj(i)%ptr
765  exit
766  end if
767  end do
768  !
769  ! -- Return
770  return
771  end subroutine set_aptbudobj_pointer
772 
773  !> @brief Initialize the groundwater flow terms based on the budget file
774  !! reader
775  !!
776  !! Initialize terms and figure out how many different terms and packages
777  !! are contained within the file
778  !<
780  ! -- modules
783  ! -- dummy
784  class(tspfmitype) :: this
785  ! -- local
786  integer(I4B) :: nflowpack
787  integer(I4B) :: i, ip
788  integer(I4B) :: naux
789  logical :: found_flowja
790  logical :: found_dataspdis
791  logical :: found_datasat
792  logical :: found_stoss
793  logical :: found_stosy
794  integer(I4B), dimension(:), allocatable :: imap
795  !
796  ! -- Calculate the number of gwf flow packages
797  allocate (imap(this%bfr%nbudterms))
798  imap(:) = 0
799  nflowpack = 0
800  found_flowja = .false.
801  found_dataspdis = .false.
802  found_datasat = .false.
803  found_stoss = .false.
804  found_stosy = .false.
805  do i = 1, this%bfr%nbudterms
806  select case (trim(adjustl(this%bfr%budtxtarray(i))))
807  case ('FLOW-JA-FACE')
808  found_flowja = .true.
809  case ('DATA-SPDIS')
810  found_dataspdis = .true.
811  case ('DATA-SAT')
812  found_datasat = .true.
813  case ('STO-SS')
814  found_stoss = .true.
815  this%igwfstrgss = 1
816  case ('STO-SY')
817  found_stosy = .true.
818  this%igwfstrgsy = 1
819  case default
820  nflowpack = nflowpack + 1
821  imap(i) = 1
822  end select
823  end do
824  !
825  ! -- allocate gwfpackage arrays (gwfpackages, iatp, datp, ...)
826  call this%allocate_gwfpackages(nflowpack)
827  !
828  ! -- Copy the package name and aux names from budget file reader
829  ! to the gwfpackages derived-type variable
830  ip = 1
831  do i = 1, this%bfr%nbudterms
832  if (imap(i) == 0) cycle
833  call this%gwfpackages(ip)%set_name(this%bfr%dstpackagenamearray(i), &
834  this%bfr%budtxtarray(i))
835  naux = this%bfr%nauxarray(i)
836  call this%gwfpackages(ip)%set_auxname(naux, &
837  this%bfr%auxtxtarray(1:naux, i))
838  ip = ip + 1
839  end do
840  !
841  ! -- Copy just the package names for the boundary packages into
842  ! the flowpacknamearray
843  ip = 1
844  do i = 1, size(imap)
845  if (imap(i) == 1) then
846  this%flowpacknamearray(ip) = this%bfr%dstpackagenamearray(i)
847  ip = ip + 1
848  end if
849  end do
850  !
851  ! -- Error if specific discharge, saturation or flowja not found
852  if (.not. found_dataspdis) then
853  write (errmsg, '(a)') 'Specific discharge not found in &
854  &budget file. SAVE_SPECIFIC_DISCHARGE and &
855  &SAVE_FLOWS must be activated in the NPF package.'
856  call store_error(errmsg)
857  end if
858  if (.not. found_datasat) then
859  write (errmsg, '(a)') 'Saturation not found in &
860  &budget file. SAVE_SATURATION and &
861  &SAVE_FLOWS must be activated in the NPF package.'
862  call store_error(errmsg)
863  end if
864  if (.not. found_flowja) then
865  write (errmsg, '(a)') 'FLOWJA not found in &
866  &budget file. SAVE_FLOWS must &
867  &be activated in the NPF package.'
868  call store_error(errmsg)
869  end if
870  if (count_errors() > 0) then
871  call this%parser%StoreErrorUnit()
872  end if
873  !
874  ! -- Return
875  return
876  end subroutine initialize_gwfterms_from_bfr
877 
878  !> @brief Initialize groundwater flow terms from the groundwater budget
879  !!
880  !! Flows are coming from a gwf-gwt exchange object
881  !<
883  ! -- modules
884  use bndmodule, only: bndtype, getbndfromlist
885  ! -- dummy
886  class(tspfmitype) :: this
887  ! -- local
888  integer(I4B) :: ngwfpack
889  integer(I4B) :: ngwfterms
890  integer(I4B) :: ip
891  integer(I4B) :: imover
892  integer(I4B) :: ntomvr
893  integer(I4B) :: iterm
894  character(len=LENPACKAGENAME) :: budtxt
895  class(bndtype), pointer :: packobj => null()
896  !
897  ! -- determine size of gwf terms
898  ngwfpack = this%gwfbndlist%Count()
899  !
900  ! -- Count number of to-mvr terms, but do not include advanced packages
901  ! as those mover terms are not losses from the cell, but rather flows
902  ! within the advanced package
903  ntomvr = 0
904  do ip = 1, ngwfpack
905  packobj => getbndfromlist(this%gwfbndlist, ip)
906  imover = packobj%imover
907  if (packobj%isadvpak /= 0) imover = 0
908  if (imover /= 0) then
909  ntomvr = ntomvr + 1
910  end if
911  end do
912  !
913  ! -- Allocate arrays in fmi of size ngwfterms, which is the number of
914  ! packages plus the number of packages with mover terms.
915  ngwfterms = ngwfpack + ntomvr
916  call this%allocate_gwfpackages(ngwfterms)
917  !
918  ! -- Assign values in the fmi package
919  iterm = 1
920  do ip = 1, ngwfpack
921  !
922  ! -- set and store names
923  packobj => getbndfromlist(this%gwfbndlist, ip)
924  budtxt = adjustl(packobj%text)
925  call this%gwfpackages(iterm)%set_name(packobj%packName, budtxt)
926  this%flowpacknamearray(iterm) = packobj%packName
927  call this%gwfpackages(iterm)%set_auxname(packobj%naux, &
928  packobj%auxname)
929  iterm = iterm + 1
930  !
931  ! -- if this package has a mover associated with it, then add another
932  ! term that corresponds to the mover flows
933  imover = packobj%imover
934  if (packobj%isadvpak /= 0) imover = 0
935  if (imover /= 0) then
936  budtxt = trim(adjustl(packobj%text))//'-TO-MVR'
937  call this%gwfpackages(iterm)%set_name(packobj%packName, budtxt)
938  this%flowpacknamearray(iterm) = packobj%packName
939  call this%gwfpackages(iterm)%set_auxname(packobj%naux, &
940  packobj%auxname)
941  this%igwfmvrterm(iterm) = 1
942  iterm = iterm + 1
943  end if
944  end do
945  !
946  ! -- Return
947  return
949 
950  !> @brief Initialize an array for storing PackageBudget objects.
951  !!
952  !! This routine allocates gwfpackages (an array of PackageBudget
953  !! objects) to the proper size and initializes member variables.
954  !<
955  subroutine gwtfmi_allocate_gwfpackages(this, ngwfterms)
956  ! -- modules
957  use constantsmodule, only: lenmempath
959  ! -- dummy
960  class(tspfmitype) :: this
961  integer(I4B), intent(in) :: ngwfterms
962  ! -- local
963  integer(I4B) :: n
964  character(len=LENMEMPATH) :: memPath
965  !
966  ! -- direct allocate
967  allocate (this%gwfpackages(ngwfterms))
968  allocate (this%flowpacknamearray(ngwfterms))
969  allocate (this%datp(ngwfterms))
970  !
971  ! -- mem_allocate
972  call mem_allocate(this%iatp, ngwfterms, 'IATP', this%memoryPath)
973  call mem_allocate(this%igwfmvrterm, ngwfterms, 'IGWFMVRTERM', this%memoryPath)
974  !
975  ! -- initialize
976  this%nflowpack = ngwfterms
977  do n = 1, this%nflowpack
978  this%iatp(n) = 0
979  this%igwfmvrterm(n) = 0
980  this%flowpacknamearray(n) = ''
981  !
982  ! -- Create a mempath for each individual flow package data set
983  ! of the form, MODELNAME/FMI-FTn
984  write (mempath, '(a, i0)') trim(this%memoryPath)//'-FT', n
985  call this%gwfpackages(n)%initialize(mempath)
986  end do
987  !
988  ! -- Return
989  return
990  end subroutine gwtfmi_allocate_gwfpackages
991 
992  !> @brief Deallocate memory
993  !!
994  !! Deallocate memory that stores the gwfpackages array
995  !<
997  ! -- modules
998  ! -- dummy
999  class(tspfmitype) :: this
1000  ! -- local
1001  integer(I4B) :: n
1002  !
1003  ! -- initialize
1004  do n = 1, this%nflowpack
1005  call this%gwfpackages(n)%da()
1006  end do
1007  !
1008  ! -- Return
1009  return
1010  end subroutine gwtfmi_deallocate_gwfpackages
1011 
1012 end module tspfmimodule
This module contains the base boundary package.
class(bndtype) function, pointer, public getbndfromlist(list, idx)
Get boundary from package list.
This module contains the BudgetModule.
Definition: Budget.f90:20
subroutine, public rate_accumulator(flow, rin, rout)
@ brief Rate accumulator subroutine
Definition: Budget.f90:664
subroutine, public budgetobject_cr_bfr(this, name, ibinun, iout, colconv1, colconv2)
Create a new budget object from a binary flow file.
This module contains simulation constants.
Definition: Constants.f90:9
integer(i4b), parameter linelength
maximum length of a standard line
Definition: Constants.f90:44
real(dp), parameter dhdry
real dry cell constant
Definition: Constants.f90:93
integer(i4b), parameter lenpackagename
maximum length of the package name
Definition: Constants.f90:22
integer(i4b), parameter lenvarname
maximum length of a variable name
Definition: Constants.f90:17
real(dp), parameter dhalf
real constant 1/2
Definition: Constants.f90:67
real(dp), parameter dem6
real constant 1e-6
Definition: Constants.f90:108
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:64
integer(i4b), parameter lenbudtxt
maximum length of a budget component names
Definition: Constants.f90:36
integer(i4b), parameter lenmempath
maximum length of the memory path
Definition: Constants.f90:26
real(dp), parameter done
real constant 1
Definition: Constants.f90:75
subroutine, public urdaux(naux, inunit, iout, lloc, istart, istop, auxname, line, text)
Read auxiliary variables from an input line.
integer(i4b) function, public getunit()
Get a free unit number.
subroutine, public openfile(iu, iout, fname, ftype, fmtarg_opt, accarg_opt, filstat_opt, mode_opt)
Open a file.
Definition: InputOutput.f90:30
This module defines variable data types.
Definition: kind.f90:8
character(len=20) access
Definition: OpenSpec.f90:7
character(len=20) form
Definition: OpenSpec.f90:7
This module contains the PackageBudgetModule Module.
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_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), 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
real(dp) function gwfsatold(this, n, delt)
Calculate the previous saturation level.
Definition: tsp-fmi.f90:537
integer(i4b), parameter nbditems
Definition: tsp-fmi.f90:24
subroutine fmi_bd(this, isuppress_output, model_budget)
Calculate budget terms associated with FMI object.
Definition: tsp-fmi.f90:267
subroutine gwtfmi_deallocate_gwfpackages(this)
Deallocate memory.
Definition: tsp-fmi.f90:997
character(len=lenbudtxt), dimension(nbditems) budtxt
Definition: tsp-fmi.f90:25
subroutine gwtfmi_allocate_scalars(this)
@ brief Allocate scalars
Definition: tsp-fmi.f90:390
subroutine gwtfmi_allocate_arrays(this, nodes)
@ brief Allocate arrays for FMI object
Definition: tsp-fmi.f90:418
subroutine initialize_gwfterms_from_gwfbndlist(this)
Initialize groundwater flow terms from the groundwater budget.
Definition: tsp-fmi.f90:883
subroutine gwtfmi_allocate_gwfpackages(this, ngwfterms)
Initialize an array for storing PackageBudget objects.
Definition: tsp-fmi.f90:956
subroutine fmi_fc(this, nodes, cold, nja, matrix_sln, idxglo, rhs)
Calculate coefficients and fill matrix and rhs terms associated with FMI object.
Definition: tsp-fmi.f90:199
subroutine initialize_gwfterms_from_bfr(this)
Initialize the groundwater flow terms based on the budget file reader.
Definition: tsp-fmi.f90:780
subroutine fmi_rp(this, inmvr)
Read and prepare.
Definition: tsp-fmi.f90:113
subroutine gwtfmi_read_options(this)
Read options from input file.
Definition: tsp-fmi.f90:564
subroutine set_aptbudobj_pointer(this, name, budobjptr)
Set the pointer to a budget object.
Definition: tsp-fmi.f90:753
subroutine set_active_status(this, cnew)
Set gwt transport cell status.
Definition: tsp-fmi.f90:451
subroutine fmi_ot_flow(this, icbcfl, icbcun)
Save budget terms associated with FMI object.
Definition: tsp-fmi.f90:291
character(len=lenpackagename) text
Definition: tsp-fmi.f90:22
subroutine fmi_ad(this, cnew)
Advance routine for FMI object.
Definition: tsp-fmi.f90:145
subroutine fmi_cq(this, cnew, flowja)
Calculate flow correction.
Definition: tsp-fmi.f90:235
subroutine gwtfmi_da(this)
Deallocate variables.
Definition: tsp-fmi.f90:334
subroutine gwtfmi_read_packagedata(this)
Read PACKAGEDATA block.
Definition: tsp-fmi.f90:617
subroutine, public fmi_cr(fmiobj, name_model, inunit, iout, eqnsclfac, depvartype)
Create a new FMI object.
Definition: tsp-fmi.f90:75
@ brief BndType
Derived type for the Budget object.
Definition: Budget.f90:39
A generic heterogeneous doubly-linked list.
Definition: List.f90:10
Derived type for storing flows.