16 integer(I4B),
pointer :: npoints
17 real(dp),
pointer,
dimension(:),
contiguous :: station => null()
18 real(dp),
pointer,
dimension(:),
contiguous :: height => null()
19 real(dp),
pointer,
dimension(:),
contiguous :: roughfraction => null()
20 logical(LGP),
pointer,
dimension(:),
contiguous :: valid => null()
24 integer(I4B),
pointer :: iout => null()
25 integer(I4B),
pointer :: iprpak => null()
26 integer(I4B),
pointer :: nreaches => null()
27 integer(I4B),
pointer :: invalid => null()
28 character(len=LINELENGTH),
dimension(:),
allocatable :: filenames
29 integer(I4B),
pointer,
dimension(:),
contiguous :: npoints => null()
31 pointer,
dimension(:),
contiguous :: cross_sections => null()
60 integer(I4B),
pointer,
intent(in) :: iout
61 integer(I4B),
pointer,
intent(in) :: iprpak
62 integer(I4B),
pointer,
intent(in) :: nreaches
65 if (
associated(this))
then
77 this%nreaches => nreaches
89 subroutine initialize(this, ncrossptstot, ncrosspts, iacross, &
90 station, height, roughfraction)
93 integer(I4B),
intent(in) :: ncrossptstot
94 integer(I4B),
dimension(this%nreaches),
intent(in) :: ncrosspts
95 integer(I4B),
dimension(this%nreaches + 1),
intent(in) :: iacross
96 real(DP),
dimension(ncrossptstot),
intent(in) :: station
97 real(DP),
dimension(ncrossptstot),
intent(in) :: height
98 real(DP),
dimension(ncrossptstot),
intent(in) :: roughfraction
102 integer(I4B) :: npoints
108 allocate (this%invalid)
114 allocate (this%filenames(this%nreaches))
115 allocate (this%npoints(this%nreaches))
116 allocate (this%cross_sections(this%nreaches))
117 do n = 1, this%nreaches
118 npoints = ncrosspts(n)
119 allocate (this%cross_sections(n)%npoints)
120 allocate (this%cross_sections(n)%station(npoints))
121 allocate (this%cross_sections(n)%height(npoints))
122 allocate (this%cross_sections(n)%roughfraction(npoints))
123 allocate (this%cross_sections(n)%valid(npoints))
127 do n = 1, this%nreaches
128 this%filenames(n) =
'NONE'
129 this%cross_sections(n)%npoints = ncrosspts(n)
130 this%npoints(n) = ncrosspts(n)
132 i1 = iacross(n + 1) - 1
135 this%cross_sections(n)%station(ipos) = station(i)
136 this%cross_sections(n)%height(ipos) = height(i)
137 this%cross_sections(n)%roughfraction(ipos) = roughfraction(i)
138 this%cross_sections(n)%valid(ipos) = .true.
159 integer(I4B),
intent(in) :: irch
160 real(DP),
intent(in) :: width
161 character(len=*),
intent(in) :: filename
163 character(len=LINELENGTH) :: tag
164 character(len=LINELENGTH) :: keyword
167 logical :: endOfBlock
181 write (tag,
"('Reach',1x,i0,1x,'(',a, ')')") &
182 irch, trim(adjustl(filename))
186 call openfile(iu, this%iout, filename,
'SFR TABLE')
187 call parser%Initialize(iu, this%iout)
190 call parser%GetBlock(
'DIMENSIONS', isfound, ierr, supportopenclose=.true.)
196 if (this%iprpak /= 0)
then
197 write (this%iout,
'(/1x,a)') &
198 'PROCESSING '//trim(adjustl(tag))//
' DIMENSIONS'
201 call parser%GetNextLine(endofblock)
203 call parser%GetStringCaps(keyword)
204 select case (keyword)
206 n = parser%GetInteger()
208 write (
errmsg,
'(a)')
'Table NROW must be > 0'
212 j = parser%GetInteger()
215 write (
errmsg,
'(a,1x,i0)')
'Table NCOL must be >= ', jmin
220 'UNKNOWN '//trim(adjustl(tag))//
' DIMENSIONS keyword: ', &
225 if (this%iprpak /= 0)
then
226 write (this%iout,
'(1x,a)') &
227 'END OF '//trim(adjustl(tag))//
' DIMENSIONS'
230 call store_error(
'Required DIMENSIONS block not found.')
236 'NROW not specified in the table DIMENSIONS block'
241 'NCOL not specified in the table DIMENSIONS block'
250 this%filenames(irch) = filename
251 this%npoints(irch) = n
254 deallocate (this%cross_sections(irch)%npoints)
255 deallocate (this%cross_sections(irch)%station)
256 deallocate (this%cross_sections(irch)%height)
257 deallocate (this%cross_sections(irch)%roughfraction)
258 deallocate (this%cross_sections(irch)%valid)
261 allocate (this%cross_sections(irch)%npoints)
262 allocate (this%cross_sections(irch)%station(n))
263 allocate (this%cross_sections(irch)%height(n))
264 allocate (this%cross_sections(irch)%roughfraction(n))
265 allocate (this%cross_sections(irch)%valid(n))
268 this%cross_sections(irch)%npoints = n
271 call parser%GetBlock(
'TABLE', isfound, ierr, supportopenclose=.true.)
277 if (this%iprpak /= 0)
then
278 write (this%iout,
'(/1x,a)') &
279 'PROCESSING '//trim(adjustl(tag))//
' TABLE'
283 call parser%GetNextLine(endofblock)
286 if (ipos > this%npoints(irch))
then
289 this%cross_sections(irch)%station(ipos) = parser%GetDouble() * width
290 this%cross_sections(irch)%height(ipos) = parser%GetDouble()
292 this%cross_sections(irch)%roughfraction(ipos) = parser%GetDouble()
294 this%cross_sections(irch)%roughfraction(ipos) = done
296 this%cross_sections(irch)%valid(ipos) = .true.
299 if (this%iprpak /= 0)
then
300 write (this%iout,
'(1x,a)') &
301 'END OF '//trim(adjustl(tag))//
' TABLE'
304 call store_error(
'Required TABLE block not found.')
308 if (ipos /= this%npoints(irch))
then
309 write (
errmsg,
'(a,1x,i0,1x,a,1x,i0,1x,a)') &
310 'NROW set to', this%npoints(irch),
'but', ipos,
'rows were read'
321 call this%validate(irch)
340 integer(I4B),
intent(in) :: irch
342 logical(LGP) :: station_error
343 logical(LGP) :: height_error
344 logical(LGP) :: height_zero_error
345 logical(LGP) :: roughness_error
346 character(len=LINELENGTH) :: filename
353 real(DP) :: roughfraction
358 real(DP),
dimension(:),
allocatable :: heights
359 real(DP),
dimension(:),
allocatable :: unique_heights
360 real(DP),
dimension(3) :: factor
363 station_error = .false.
364 height_error = .false.
365 height_zero_error = .true.
366 roughness_error = .false.
367 npts = this%npoints(irch)
371 station = this%cross_sections(irch)%station(n)
372 if (station < dzero)
then
373 station_error = .true.
375 height = this%cross_sections(irch)%height(n)
376 if (height < dzero)
then
377 height_error = .true.
378 else if (height == dzero)
then
379 height_zero_error = .false.
381 roughfraction = this%cross_sections(irch)%roughfraction(n)
382 if (roughfraction <= dzero)
then
383 roughness_error = .true.
385 if (station_error .and. height_error .and. &
386 roughness_error)
then
392 if (station_error .or. height_error .or. &
393 height_zero_error .or. roughness_error)
then
394 filename = this%filenames(irch)
395 if (station_error)
then
396 write (
errmsg,
'(3a,1x,i0,1x,a)') &
397 "All xfraction data in '", trim(adjustl(filename)), &
398 "' for reach", irch,
'must be greater than or equal to zero.'
401 if (height_error)
then
402 write (
errmsg,
'(3a,1x,i0,1x,a)') &
403 "All height data in '", trim(adjustl(filename)), &
404 "' for reach", irch,
'must be greater than or equal to zero.'
407 if (height_zero_error)
then
408 write (
errmsg,
'(3a,1x,i0,1x,a)') &
409 "At least one height data value in '", trim(adjustl(filename)), &
410 "' for reach", irch,
'must be equal to zero.'
413 if (roughness_error)
then
414 write (
errmsg,
'(3a,1x,i0,1x,a)') &
415 "All manfraction data in '", trim(adjustl(filename)), &
416 "' for reach", irch,
'must be greater than zero.'
422 allocate (heights(npts))
424 heights(n) = this%cross_sections(irch)%height(n)
432 do n = 1,
size(unique_heights)
433 if (unique_heights(n) <= dzero) cycle
436 height = unique_heights(n) + real(i, dp) *
dem6
438 this%cross_sections(irch)%height, height)
440 this%cross_sections(irch)%height, height)
446 dc0 = (factor(2) - factor(1)) /
dem6
447 dc1 = (factor(3) - factor(2)) /
dem6
450 if (dc0 < dzero .or. dc1 < dzero)
then
451 this%invalid = this%invalid + 1
452 height = unique_heights(n)
454 if (this%cross_sections(irch)%height(i) == height)
then
455 this%cross_sections(irch)%valid(i) = .false.
463 deallocate (unique_heights)
475 subroutine output(this, widths, roughs, kstp, kper)
480 real(DP),
dimension(this%nreaches),
intent(in) :: widths
481 real(DP),
dimension(this%nreaches),
intent(in) :: roughs
482 integer(I4B),
intent(in),
optional :: kstp
483 integer(I4B),
intent(in),
optional :: kper
485 character(len=LINELENGTH) :: title
486 character(len=LINELENGTH) :: text
487 character(len=LINELENGTH) :: filename
488 character(len=10) :: cvalid
489 logical(LGP) :: transient
490 integer(I4B) :: kkstp
491 integer(I4B) :: kkper
494 integer(I4B) :: ntabcols
495 integer(I4B) :: ninvalid_reaches
497 real(DP) :: xfraction
500 integer(I4B),
dimension(this%nreaches) :: reach_fail
507 if (
present(kstp))
then
510 if (
present(kper))
then
515 if (kkstp > 0 .and. kkper > 0)
then
522 do irch = 1, this%nreaches
523 filename = this%filenames(irch)
527 if (trim(adjustl(filename)) /=
'NONE')
then
528 do n = 1, this%npoints(irch)
529 if (.not. this%cross_sections(irch)%valid(n))
then
530 reach_fail(irch) = reach_fail(irch) + 1
537 do irch = 1, this%nreaches
538 filename = this%filenames(irch)
541 if (trim(adjustl(filename)) /=
'NONE')
then
545 if (this%iprpak > 0 .or. reach_fail(irch) > 0)
then
548 if (reach_fail(irch) > 0)
then
555 write (title,
'(a,1x,i0,1x,3a)') &
556 'CROSS_SECTION DATA FOR REACH', irch,
"FROM TAB6 FILE ('", &
557 trim(adjustl(filename)),
"')"
558 call table_cr(this%inputtab, trim(adjustl(filename)), title)
559 call this%inputtab%table_df(this%npoints(irch), ntabcols, &
560 this%iout, finalize=.false., &
563 call this%inputtab%set_kstpkper(kkstp, kkper)
566 call this%inputtab%initialize_column(text, 20, alignment=
tableft)
568 call this%inputtab%initialize_column(text, 20, alignment=
tableft)
570 call this%inputtab%initialize_column(text, 20, alignment=
tableft)
572 call this%inputtab%initialize_column(text, 20, alignment=
tableft)
573 text =
"MANNING'S ROUGHNESS COEFFICIENT"
574 call this%inputtab%initialize_column(text, 20, alignment=
tableft)
575 if (reach_fail(irch) > 0)
then
576 text =
'NEEDS ADJUSTMENT'
577 call this%inputtab%initialize_column(text, 10, alignment=
tableft)
585 do n = 1, this%npoints(irch)
586 xfraction = this%cross_sections(irch)%station(n) / width
587 r = this%cross_sections(irch)%roughfraction(n) * rough
588 call this%inputtab%add_term(xfraction)
589 call this%inputtab%add_term(this%cross_sections(irch)%station(n))
590 call this%inputtab%add_term(this%cross_sections(irch)%height(n))
591 call this%inputtab%add_term(&
592 &this%cross_sections(irch)%roughfraction(n))
593 call this%inputtab%add_term(r)
594 if (reach_fail(irch) > 0)
then
595 if (this%cross_sections(irch)%valid(n))
then
600 call this%inputtab%add_term(cvalid)
605 call this%inputtab%finalize_table()
611 if (this%invalid > 0)
then
613 do irch = 1, this%nreaches
614 if (reach_fail(irch) > 0)
then
615 ninvalid_reaches = ninvalid_reaches + 1
618 write (
warnmsg,
'(a,1x,i0,7(1x,a))') &
619 'Cross-section data for', ninvalid_reaches, &
620 'reaches include one or more points that result in a', &
621 'non-unique depth-conveyance relation. This occurs when', &
622 'there are horizontal sections at non-zero heights', &
623 '(for example, flat overbank sections). This can usually', &
624 'be resolved by adding a small slope to these flat', &
625 'sections. See the cross-section tables in the model', &
626 'listing file for more information.'
644 integer(I4B) :: nptstot
649 do n = 1, this%nreaches
650 nptstot = nptstot + this%npoints(n)
662 subroutine pack(this, ncrossptstot, ncrosspts, iacross, &
663 station, height, roughfraction)
666 integer(I4B),
intent(in) :: ncrossptstot
667 integer(I4B),
dimension(this%nreaches),
intent(inout) :: ncrosspts
668 integer(I4B),
dimension(this%nreaches + 1),
intent(inout) :: iacross
669 real(DP),
dimension(ncrossptstot),
intent(inout) :: station
670 real(DP),
dimension(ncrossptstot),
intent(inout) :: height
671 real(DP),
dimension(ncrossptstot),
intent(inout) :: roughfraction
675 integer(I4B) :: npoints
681 do n = 1, this%nreaches
682 npoints = this%npoints(n)
683 ncrosspts(n) = npoints
685 station(ipos) = this%cross_sections(n)%station(i)
686 height(ipos) = this%cross_sections(n)%height(i)
687 roughfraction(ipos) = this%cross_sections(n)%roughfraction(i)
690 iacross(n + 1) = ipos
709 deallocate (this%npoints)
710 nullify (this%npoints)
711 do n = 1, this%nreaches
712 deallocate (this%cross_sections(n)%npoints)
713 nullify (this%cross_sections(n)%npoints)
714 deallocate (this%cross_sections(n)%station)
715 nullify (this%cross_sections(n)%station)
716 deallocate (this%cross_sections(n)%height)
717 nullify (this%cross_sections(n)%height)
718 deallocate (this%cross_sections(n)%roughfraction)
719 nullify (this%cross_sections(n)%roughfraction)
720 deallocate (this%cross_sections(n)%valid)
721 nullify (this%cross_sections(n)%valid)
723 deallocate (this%cross_sections)
724 nullify (this%cross_sections)
727 if (
associated(this%inputtab))
then
728 call this%inputtab%table_da()
729 deallocate (this%inputtab)
730 nullify (this%inputtab)
734 deallocate (this%invalid)
735 nullify (this%invalid)
739 nullify (this%iprpak)
740 nullify (this%nreaches)
This module contains block parser methods.
This module contains simulation constants.
integer(i4b), parameter linelength
maximum length of a standard line
@ tableft
left justified table column
real(dp), parameter dtwothirds
real constant 2/3
real(dp), parameter dem6
real constant 1e-6
real(dp), parameter dzero
real constant zero
integer(i4b), parameter iuoc
open/close file unit number
real(dp), parameter done
real constant 1
This module contains stateless sfr subroutines and functions.
real(dp) function, public get_cross_section_area(npts, stations, heights, d)
Calculate the cross-sectional area for a reach.
real(dp) function, public get_hydraulic_radius(npts, stations, heights, d)
Calculate the hydraulic radius for a reach.
This module defines variable data types.
integer(i4b) function get_ncrossptstot(this)
Get the total number of cross-section points.
subroutine, public cross_section_cr(this, iout, iprpak, nreaches)
Create a cross-section object.
subroutine output(this, widths, roughs, kstp, kper)
Write cross-section tables.
subroutine destroy(this)
Deallocate the cross-section object.
subroutine read_table(this, irch, width, filename)
Read a cross-section table.
subroutine validate(this, irch)
Validate cross-section tables.
subroutine initialize(this, ncrossptstot, ncrosspts, iacross, station, height, roughfraction)
Initialize a cross-section object.
subroutine pack(this, ncrossptstot, ncrosspts, iacross, station, height, roughfraction)
Pack the cross-section object.
This module contains simulation methods.
subroutine, public store_warning(msg, substring)
Store warning message.
subroutine, public store_error(msg, terminate)
Store an error message.
This module contains simulation variables.
character(len=maxcharlen) errmsg
error message string
character(len=maxcharlen) warnmsg
warning message string
subroutine, public table_cr(this, name, title)