33 integer(I4B),
pointer :: iper
35 integer(I4B),
dimension(:, :),
pointer,
contiguous :: cellid => null()
57 logical :: naux = .false.
58 logical :: ipakcb = .false.
59 logical :: iprpak = .false.
60 logical :: iprflow = .false.
61 logical :: boundnames = .false.
62 logical :: auxmultname = .false.
63 logical :: inewton = .false.
64 logical :: auxiliary = .false.
65 logical :: maxbound = .false.
84 integer(I4B),
intent(inout) :: neq
93 call tasmanager_cr(this%TasManager, dis, this%name_model, this%iout)
96 call obs_cr(this%obs, this%inobspkg)
99 write (this%iout, 1) this%filtyp, trim(adjustl(this%text)), this%input_mempath
100 1
format(1x, /1x, a,
' -- ', a,
' PACKAGE, VERSION 8, 2/22/2014', &
101 ' INPUT READ FROM MEMPATH: ', a)
104 call this%source_options()
107 call this%tsmanager%tsmanager_df()
108 call this%tasmanager%tasmanager_df()
111 call this%source_dimensions()
114 if (this%npakeq > 0)
then
115 this%ioffset = neq - this%dis%nodes
119 neq = neq + this%npakeq
122 if (this%bnd_obs_supported())
then
123 call this%obs%obs_df(this%iout, this%packName, this%filtyp, this%dis)
124 call this%bnd_df_obs()
139 logical(LGP) :: found
142 if (this%iper /=
kper)
return
145 call mem_set_value(this%nbound,
'NBOUND', this%input_mempath, &
149 call this%nodelist_update()
152 if (this%inamedbound /= 0)
then
153 do n = 1,
size(this%boundname_cst)
154 this%boundname(n) = this%boundname_cst(n)
172 call mem_deallocate(this%boundname_cst,
'BOUNDNAME_IDM', this%memoryPath)
176 call mem_setptr(this%boundname_cst,
'BOUNDNAME_CST', this%memoryPath)
177 call mem_setptr(this%auxvar,
'AUXVAR', this%memoryPath)
183 call this%BndType%bnd_da()
205 character(len=LENMEMPATH) :: input_mempath
211 call this%BndType%allocate_scalars()
214 call mem_setptr(this%iper,
'IPER', input_mempath)
233 integer(I4B),
dimension(:),
pointer,
contiguous,
optional :: nodelist
234 real(DP),
dimension(:, :),
pointer,
contiguous,
optional :: auxvar
237 call this%BndType%allocate_arrays(nodelist, auxvar)
240 call mem_setptr(this%cellid,
'CELLID', this%input_mempath)
241 call mem_setptr(this%boundname_cst,
'BOUNDNAME', this%input_mempath)
244 call mem_checkin(this%cellid,
'CELLID', this%memoryPath, &
245 'CELLID', this%input_mempath)
247 this%memoryPath,
'BOUNDNAME', this%input_mempath)
249 if (
present(auxvar))
then
253 call mem_setptr(this%auxvar,
'AUXVAR', this%input_mempath)
256 call mem_checkin(this%auxvar,
'AUXVAR_IDM', this%memoryPath, &
257 'AUXVAR', this%input_mempath)
277 character(len=LENAUXNAME) :: sfacauxname
281 call mem_set_value(this%naux,
'NAUX', this%input_mempath, found%naux)
282 call mem_set_value(this%ipakcb,
'IPAKCB', this%input_mempath, found%ipakcb)
283 call mem_set_value(this%iprpak,
'IPRPAK', this%input_mempath, found%iprpak)
284 call mem_set_value(this%iprflow,
'IPRFLOW', this%input_mempath, found%iprflow)
285 call mem_set_value(this%inamedbound,
'BOUNDNAMES', this%input_mempath, &
287 call mem_set_value(sfacauxname,
'AUXMULTNAME', this%input_mempath, &
289 call mem_set_value(this%inewton,
'INEWTON', this%input_mempath, found%inewton)
292 call this%log_options(found, sfacauxname)
295 if (found%naux .and. this%naux > 0)
then
297 'AUXNAME', this%memoryPath)
299 'AUXNAME_CST', this%memoryPath)
300 call mem_set_value(this%auxname_cst,
'AUXILIARY', this%input_mempath, &
304 this%auxname(n) = this%auxname_cst(n)
309 if (found%ipakcb) this%ipakcb = -1
312 if (found%auxmultname) this%iauxmultcol = -1
316 if (
filein_fname(this%obs%inputFilename,
'OBS6_FILENAME', &
317 this%input_mempath, this%input_fname))
then
318 this%obs%active = .true.
320 call openfile(this%obs%inUnitObs, this%iout, this%obs%inputFilename,
'OBS')
324 if (found%inewton) this%inewton = 0
327 if (this%iauxmultcol < 0)
then
330 if (this%naux == 0)
then
331 write (
errmsg,
'(a,2(1x,a))') &
332 'AUXMULTNAME was specified as', trim(adjustl(sfacauxname)), &
333 'but no AUX variables specified.'
340 if (sfacauxname == this%auxname(n))
then
347 if (this%iauxmultcol == 0)
then
348 write (
errmsg,
'(a,2(1x,a))') &
349 'AUXMULTNAME was specified as', trim(adjustl(sfacauxname)), &
350 'but no AUX variable found with this name.'
371 character(len=*),
intent(in) :: sfacauxname
374 character(len=*),
parameter :: fmtflow = &
375 &
"(4x, 'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL')"
376 character(len=*),
parameter :: fmttas = &
377 &
"(4x, 'TIME-ARRAY SERIES DATA WILL BE READ FROM FILE: ', a)"
378 character(len=*),
parameter :: fmtts = &
379 &
"(4x, 'TIME-SERIES DATA WILL BE READ FROM FILE: ', a)"
380 character(len=*),
parameter :: fmtnme = &
384 write (this%iout,
'(/1x,a)')
'PROCESSING '//trim(adjustl(this%text)) &
387 if (found%ipakcb)
then
388 write (this%iout, fmtflow)
391 if (found%iprpak)
then
392 write (this%iout,
'(4x,a)') &
393 'LISTS OF '//trim(adjustl(this%text))//
' CELLS WILL BE PRINTED.'
396 if (found%iprflow)
then
397 write (this%iout,
'(4x,a)') trim(adjustl(this%text))// &
398 ' FLOWS WILL BE PRINTED TO LISTING FILE.'
401 if (found%boundnames)
then
402 write (this%iout,
'(4x,a)') trim(adjustl(this%text))// &
403 ' BOUNDARIES HAVE NAMES IN LAST COLUMN.'
406 if (found%auxmultname)
then
407 write (this%iout,
'(4x,a,a)') &
408 'AUXILIARY MULTIPLIER NAME: ', sfacauxname
411 if (found%inewton)
then
412 write (this%iout,
'(4x,a)') &
413 'NEWTON-RAPHSON method disabled for unconfined cells'
417 write (this%iout,
'(1x,a)') &
418 'END OF '//trim(adjustl(this%text))//
' BASE OPTIONS'
434 write (this%iout,
'(/1x,a)')
'PROCESSING '//trim(adjustl(this%text))// &
438 call mem_set_value(this%maxbound,
'MAXBOUND', this%input_mempath, &
441 write (this%iout,
'(4x,a,i7)')
'MAXBOUND = ', this%maxbound
444 write (this%iout,
'(1x,a)') &
445 'END OF '//trim(adjustl(this%text))//
' BASE DIMENSIONS'
448 if (this%maxbound <= 0)
then
449 write (
errmsg,
'(a)')
'MAXBOUND must be an integer greater than zero.'
456 call this%define_listlabel()
473 integer(I4B),
dimension(:),
pointer :: cellid
474 integer(I4B) :: n, nodeu, noder
475 character(len=LINELENGTH) :: nodestr
478 do n = 1, this%nbound
481 cellid => this%cellid(:, n)
484 call this%check_cellid(n, cellid, this%dis%mshape, this%dis%ndim)
487 if (this%dis%ndim == 1)
then
489 elseif (this%dis%ndim == 2)
then
490 nodeu =
get_node(cellid(1), 1, cellid(2), &
491 this%dis%mshape(1), 1, &
494 nodeu =
get_node(cellid(1), cellid(2), cellid(3), &
495 this%dis%mshape(1), &
496 this%dis%mshape(2), &
501 if (this%dis%nodes < this%dis%nodesuser)
then
503 noder = this%dis%get_nodenumber(nodeu, 0)
505 call this%dis%nodeu_to_string(nodeu, nodestr)
507 ' Cell is outside active grid domain: '// &
508 trim(adjustl(nodestr))
511 this%nodelist(n) = noder
513 this%nodelist(n) = nodeu
536 integer(I4B),
intent(in) :: ii
537 integer(I4B),
dimension(:),
intent(in) :: cellid
538 integer(I4B),
dimension(:),
intent(in) :: mshape
539 integer(I4B),
intent(in) :: ndim
540 character(len=20) :: cellstr, mshstr
541 character(len=*),
parameter :: fmterr = &
542 "('List entry ',i0,' contains cellid ',a,' but this cellid is invalid &
543 &for model with shape ', a)"
544 character(len=*),
parameter :: fmtndim1 = &
546 character(len=*),
parameter :: fmtndim2 = &
547 "('(',i0,',',i0,')')"
548 character(len=*),
parameter :: fmtndim3 = &
549 "('(',i0,',',i0,',',i0,')')"
553 if (cellid(1) < 1 .or. cellid(1) > mshape(1))
then
554 write (cellstr, fmtndim1) cellid(1)
555 write (mshstr, fmtndim1) mshape(1)
556 write (
errmsg, fmterr) ii, trim(adjustl(cellstr)), trim(adjustl(mshstr))
562 if (cellid(1) < 1 .or. cellid(1) > mshape(1) .or. &
563 cellid(2) < 1 .or. cellid(2) > mshape(2))
then
564 write (cellstr, fmtndim2) cellid(1), cellid(2)
565 write (mshstr, fmtndim2) mshape(1), mshape(2)
566 write (
errmsg, fmterr) ii, trim(adjustl(cellstr)), trim(adjustl(mshstr))
572 if (cellid(1) < 1 .or. cellid(1) > mshape(1) .or. &
573 cellid(2) < 1 .or. cellid(2) > mshape(2) .or. &
574 cellid(3) < 1 .or. cellid(3) > mshape(3))
then
575 write (cellstr, fmtndim3) cellid(1), cellid(2), cellid(3)
576 write (mshstr, fmtndim3) mshape(1), mshape(2), mshape(3)
577 write (
errmsg, fmterr) ii, trim(adjustl(cellstr)), trim(adjustl(mshstr))
603 character(len=10) :: cpos
604 character(len=LINELENGTH) :: tag
605 character(len=LINELENGTH),
allocatable,
dimension(:) :: words
606 integer(I4B) :: ntabrows
607 integer(I4B) :: ntabcols
609 integer(I4B) :: ii, jj, i, j, k, nod
612 type(
tabletype),
pointer :: inputtab => null()
614 character(len=LINELENGTH) :: fmtlstbn
619 naux =
size(this%auxvar, 1)
622 ntabrows = this%nbound
626 ipos = index(this%listlabel,
'NO.')
628 write (cpos,
'(i10)') ipos + 3
629 fmtlstbn =
'(a'//trim(adjustl(cpos))
634 if (
size(this%dis%mshape) == 3)
then
636 fmtlstbn = trim(fmtlstbn)//
',a7,a7,a7'
639 else if (
size(this%dis%mshape) == 2)
then
641 fmtlstbn = trim(fmtlstbn)//
',a7,a7'
646 fmtlstbn = trim(fmtlstbn)//
',a7'
650 ntabcols = ntabcols + ldim
652 fmtlstbn = trim(fmtlstbn)//
',a16'
656 if (this%inamedbound == 1)
then
657 ntabcols = ntabcols + 1
658 fmtlstbn = trim(fmtlstbn)//
',a16'
662 ntabcols = ntabcols + naux
664 fmtlstbn = trim(fmtlstbn)//
',a16'
666 fmtlstbn = trim(fmtlstbn)//
')'
669 allocate (words(ntabcols))
672 read (this%listlabel, fmtlstbn) (words(i), i=1, ntabcols)
676 call inputtab%table_df(ntabrows, ntabcols, this%iout)
680 call inputtab%initialize_column(words(ipos), 10, alignment=
tabcenter)
683 do i = 1,
size(this%dis%mshape)
685 call inputtab%initialize_column(words(ipos), 7, alignment=
tabcenter)
691 call inputtab%initialize_column(words(ipos), 16, alignment=
tabcenter)
695 if (this%inamedbound == 1)
then
703 call inputtab%initialize_column(this%auxname(i), 16, alignment=
tabcenter)
707 do ii = 1, this%nbound
708 call inputtab%add_term(ii)
711 if (
size(this%dis%mshape) == 3)
then
712 nod = this%nodelist(ii)
713 call get_ijk(nod, this%dis%mshape(2), this%dis%mshape(3), &
714 this%dis%mshape(1), i, j, k)
715 call inputtab%add_term(k)
716 call inputtab%add_term(i)
717 call inputtab%add_term(j)
718 else if (
size(this%dis%mshape) == 2)
then
719 nod = this%nodelist(ii)
720 call get_ijk(nod, 1, this%dis%mshape(2), this%dis%mshape(1), i, j, k)
721 call inputtab%add_term(k)
722 call inputtab%add_term(j)
724 nod = this%nodelist(ii)
725 call inputtab%add_term(nod)
730 call inputtab%add_term(this%bound_value(jj, ii))
734 if (this%inamedbound == 1)
then
735 call inputtab%add_term(this%boundname(ii))
740 call inputtab%add_term(this%auxvar(jj, ii))
745 call inputtab%table_da()
746 deallocate (inputtab)
766 integer(I4B),
intent(in) :: col
767 integer(I4B),
intent(in) :: row
This module contains the extended boundary package.
subroutine bndext_rp(this)
subroutine write_list(this)
@ brief Log package list input
subroutine bndext_allocate_arrays(this, nodelist, auxvar)
@ brief Allocate package arrays
subroutine nodelist_update(this)
@ brief Update package nodelist
subroutine bndext_df(this, neq, dis)
@ brief Define boundary package options and dimensions
subroutine bndext_da(this)
@ brief Deallocate package memory
subroutine log_options(this, found, sfacauxname)
@ brief Log package options
subroutine source_dimensions(this)
@ brief Source package dimensions from input context
subroutine check_cellid(this, ii, cellid, mshape, ndim)
@ brief Check for valid cellid
real(dp) function bound_value(this, col, row)
@ brief Return a bound value
subroutine source_options(this)
@ brief Source package options from input context
subroutine bndext_allocate_scalars(this)
@ brief Allocate package scalars
This module contains the base boundary package.
This module contains simulation constants.
integer(i4b), parameter linelength
maximum length of a standard line
@ tabcenter
centered table column
@ tableft
left justified table column
real(dp), parameter dnodata
real no data constant
integer(i4b), parameter lenauxname
maximum length of a aux variable
integer(i4b), parameter lenboundname
maximum length of a bound name
real(dp), parameter dzero
real constant zero
integer(i4b), parameter lenmempath
maximum length of the memory path
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...
subroutine, public get_ijk(nodenumber, nrow, ncol, nlay, irow, icol, ilay)
Get row, column and layer indices from node number and grid dimensions. If nodenumber is invalid,...
This module defines variable data types.
character(len=lenmempath) function create_mem_path(component, subcomponent, context)
returns the path to the memory object
This module contains the derived type ObsType.
subroutine, public obs_cr(obs, inobs)
@ brief Create a new ObsType object
This module contains simulation methods.
subroutine, public store_error(msg, terminate)
Store an error message.
integer(i4b) function, public count_errors()
Return number of errors.
subroutine, public store_error_filename(filename, terminate)
Store the erroring file name.
This module contains simulation variables.
character(len=maxcharlen) errmsg
error message string
character(len=linelength) idm_context
This module contains the SourceCommonModule.
logical(lgp) function, public filein_fname(filename, tagname, input_mempath, input_fname)
enforce and set a single input filename provided via FILEIN keyword
subroutine, public table_cr(this, name, title)
integer(i4b), pointer, public kper
current stress period number
subroutine, public tasmanager_cr(this, dis, modelname, iout)
Create the time-array series manager.
subroutine, public tsmanager_cr(this, iout, removeTsLinksOnCompletion, extendTsToEndOfSimulation)
Create the tsmanager.
This class is used to store a single deferred-length character string. It was designed to work in an ...