diff --git a/src/Utilities/ListReader.f90 b/src/Utilities/ListReader.f90 index db38583f1b5..99c39aaf077 100644 --- a/src/Utilities/ListReader.f90 +++ b/src/Utilities/ListReader.f90 @@ -1,4 +1,5 @@ -! -- Generic List Reader Module +!> @brief Generic List Reader Module +!< module ListReaderModule use KindModule, only: DP, I4B @@ -14,37 +15,39 @@ module ListReaderModule public ListReaderType type :: ListReaderType - integer(I4B) :: in = 0 ! unit number of file containing control record - integer(I4B) :: inlist = 0 ! unit number of file from which list will be read - integer(I4B) :: iout = 0 ! unit number to output messages - integer(I4B) :: inamedbound = 0 ! flag indicating boundary names are to be read - integer(I4B) :: ierr = 0 ! error flag - integer(I4B) :: nlist = 0 ! number of entries in list. -1 indicates number will be automatically determined - integer(I4B) :: ibinary = 0 ! flag indicating to read binary list - integer(I4B) :: istart = 0 ! string starting location - integer(I4B) :: istop = 0 ! string ending location - integer(I4B) :: lloc = 0 ! entry number in line - integer(I4B) :: iclose = 0 ! flag indicating whether or not to close file - integer(I4B) :: ndim = 0 ! number of dimensions in model - integer(I4B) :: ntxtrlist = 0 ! number of text entries found in rlist - integer(I4B) :: ntxtauxvar = 0 ! number of text entries found in auxvar - character(len=LENLISTLABEL) :: label = '' ! label for printing list - character(len=:), allocatable, private :: line ! current line - integer(I4B), dimension(:), pointer, contiguous :: mshape => null() ! pointer to model shape - integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() ! pointer to nodelist - real(DP), dimension(:, :), pointer, contiguous :: rlist => null() ! pointer to rlist - real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() ! pointer to auxvar - character(len=16), dimension(:), pointer :: auxname => null() ! pointer to aux names + integer(I4B) :: in = 0 !< unit number of file containing control record + integer(I4B) :: inlist = 0 !< unit number of file from which list will be read + integer(I4B) :: iout = 0 !< unit number to output messages + integer(I4B) :: inamedbound = 0 !< flag indicating boundary names are to be read + integer(I4B) :: ierr = 0 !< error flag + integer(I4B) :: nlist = 0 !< number of entries in list. -1 indicates number will be automatically determined + integer(I4B) :: ibinary = 0 !< flag indicating to read binary list + integer(I4B) :: istart = 0 !< string starting location + integer(I4B) :: istop = 0 !< string ending location + integer(I4B) :: lloc = 0 !< entry number in line + integer(I4B) :: iclose = 0 !< flag indicating whether or not to close file + integer(I4B) :: ndim = 0 !< number of dimensions in model + integer(I4B) :: ntxtrlist = 0 !< number of text entries found in rlist + integer(I4B) :: ntxtauxvar = 0 !< number of text entries found in auxvar + character(len=LENLISTLABEL) :: label = '' !< label for printing list + character(len=:), allocatable, private :: line !< current line + integer(I4B), dimension(:), pointer, contiguous :: mshape => null() !< pointer to model shape + integer(I4B), dimension(:), pointer, contiguous :: nodelist => null() !< pointer to nodelist + real(DP), dimension(:, :), pointer, contiguous :: rlist => null() !< pointer to rlist + real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !< pointer to auxvar + character(len=16), dimension(:), pointer :: auxname => null() !< pointer to aux names character(len=LENBOUNDNAME), dimension(:), pointer, & - contiguous :: boundname => null() ! pointer to boundname - integer(I4B), dimension(:), allocatable :: idxtxtrow ! row locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtcol ! col locations of text in rlist - integer(I4B), dimension(:), allocatable :: idxtxtauxrow ! row locations of text in auxvar - integer(I4B), dimension(:), allocatable :: idxtxtauxcol ! col locations of text in auxvar - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist ! text found in rlist - character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar ! text found in auxvar + contiguous :: boundname => null() !< pointer to boundname + integer(I4B), dimension(:), allocatable :: idxtxtrow !< row locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtcol !< col locations of text in rlist + integer(I4B), dimension(:), allocatable :: idxtxtauxrow !< row locations of text in auxvar + integer(I4B), dimension(:), allocatable :: idxtxtauxcol !< col locations of text in auxvar + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtrlist !< text found in rlist + character(len=LENTIMESERIESNAME), dimension(:), allocatable :: txtauxvar !< text found in auxvar type(LongLineReaderType), pointer :: line_reader => null() + contains + procedure :: read_list procedure :: write_list procedure, private :: read_control_record @@ -56,15 +59,11 @@ module ListReaderModule contains + !> @brief Initialize the reader + !< subroutine read_list(this, line_reader, in, iout, nlist, inamedbound, & mshape, nodelist, rlist, auxvar, auxname, boundname, & label) -! ****************************************************************************** -! init -- Initialize the reader -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBOUNDNAME ! -- dummy @@ -82,8 +81,6 @@ subroutine read_list(this, line_reader, in, iout, nlist, inamedbound, & character(len=LENBOUNDNAME), & dimension(:), pointer, contiguous, intent(inout) :: boundname character(len=LENLISTLABEL), intent(in) :: label - ! -- local -! ------------------------------------------------------------------------------ ! ! -- Copy variables this%in = in @@ -119,17 +116,13 @@ subroutine read_list(this, line_reader, in, iout, nlist, inamedbound, & ! -- Set nlist for return nlist = this%nlist ! - ! -- return + ! -- Return return end subroutine read_list + !> @brief Check for a control record, and parse if found + !< subroutine read_control_record(this) -! ****************************************************************************** -! read_control_record -- Check for a control record, and parse if found -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use InputOutputModule, only: urword ! -- dummy @@ -140,7 +133,6 @@ subroutine read_control_record(this) ! -- formats character(len=*), parameter :: fmtlsf = & "(1X,'LIST SCALING FACTOR=',1PG12.5)" -! ------------------------------------------------------------------------------ ! ! -- Set default values, which may be changed by control record this%inlist = this%in @@ -159,19 +151,15 @@ subroutine read_control_record(this) call this%set_openclose() end select ! - ! -- return + ! -- Return return end subroutine read_control_record + !> @brief Set up for open/close file + !! + !! OPEN/CLOSE fname [(BINARY)] + !< subroutine set_openclose(this) -! ****************************************************************************** -! set_openclose -- set up for open/close file -! -! OPEN/CLOSE fname [(BINARY)] -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use InputOutputModule, only: urword, openfile use OpenSpecModule, only: form, access @@ -195,14 +183,13 @@ subroutine set_openclose(this) &"(1x,'TO READ ', I0, ' RECORDS.')" character(len=*), parameter :: fmtof = & &"(1X,/1X,'OPENING FILE ON UNIT ',I0,':',/1X,A)" -! ------------------------------------------------------------------------------ ! - ! -- get filename + ! -- Get filename call urword(this%line, this%lloc, this%istart, this%istop, 0, idum, r, & this%iout, this%in) fname = this%line(this%istart:this%istop) ! - ! -- check to see if file OPEN/CLOSE file exists + ! -- Check to see if file OPEN/CLOSE file exists inquire (file=fname, exist=exists) if (.not. exists) then write (errmsg, fmtocne) this%line(this%istart:this%istop) @@ -247,23 +234,15 @@ subroutine set_openclose(this) call this%line_reader%rdcom(this%inlist, this%iout, this%line, & this%ierr) ! - ! -- return + ! -- Return return end subroutine set_openclose + !> @brief Read the data + !< subroutine read_data(this) -! ****************************************************************************** -! read_data -- read the data -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ - ! -- modules ! -- dummy class(ListReaderType) :: this - ! -- local - ! -- formats -! ------------------------------------------------------------------------------ ! ! -- Read the list if (this%ibinary == 1) then @@ -272,21 +251,18 @@ subroutine read_data(this) call this%read_ascii() end if ! - ! -- if open/close, then close file + ! -- If open/close, then close file if (this%iclose == 1) then close (this%inlist) end if - ! -- return + ! + ! -- Return return end subroutine read_data + !> @brief Read the data from a binary file + !< subroutine read_binary(this) -! ****************************************************************************** -! read_binary -- read the data from a binary file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH, LENBIGLINE ! -- dummy @@ -305,9 +281,8 @@ subroutine read_binary(this) character(len=*), parameter :: fmtlsterronly = & "('ERROR READING LIST FROM FILE: ',& &1x,a,1x,' ON UNIT: ',I0)" -! ------------------------------------------------------------------------------ ! - ! -- determine array sizes + ! -- Determine array sizes mxlist = size(this%rlist, 2) ldim = size(this%rlist, 1) naux = size(this%auxvar, 1) @@ -318,7 +293,7 @@ subroutine read_binary(this) ii = 1 readloop: do ! - ! -- read layer, row, col, or cell number + ! -- Read layer, row, col, or cell number read (this%inlist, iostat=this%ierr) cellid ! ! -- If not end of record, then store nodenumber, else @@ -326,7 +301,7 @@ subroutine read_binary(this) select case (this%ierr) case (0) ! - ! -- ensure cellid is valid, store an error otherwise + ! -- Ensure cellid is valid, store an error otherwise call check_cellid(ii, cellid, this%mshape, this%ndim) ! ! -- Check range @@ -347,7 +322,7 @@ subroutine read_binary(this) this%mshape(1), this%mshape(2), this%mshape(3)) end if this%nodelist(ii) = nod - + ! ! -- Read remainder of record read (this%inlist, iostat=this%ierr) (this%rlist(jj, ii), jj=1, ldim), & (this%auxvar(jj, ii), jj=1, naux) @@ -377,7 +352,7 @@ subroutine read_binary(this) if (ii == this%nlist) exit readloop end if ! - ! -- increment ii + ! -- Increment ii ii = ii + 1 ! end do readloop @@ -387,17 +362,13 @@ subroutine read_binary(this) call store_error_unit(this%inlist) end if ! - ! -- return + ! -- Return return end subroutine read_binary + !> @brief Read the data from an ascii file + !< subroutine read_ascii(this) -! ****************************************************************************** -! read_ascii -- read the data from an ascii file -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LENBOUNDNAME, LINELENGTH, DZERO use InputOutputModule, only: urword @@ -417,9 +388,8 @@ subroutine read_ascii(this) &the maximum number of records. Number of records found is ',I0,& &' but MAXBOUND is ', I0, '. Try increasing MAXBOUND for this list. & &Error occurred reading the following line: ', a, 5x, '>>> ', a)" -! ------------------------------------------------------------------------------ ! - ! -- determine array sizes + ! -- Determine array sizes mxlist = size(this%rlist, 2) ldim = size(this%rlist, 1) naux = size(this%auxvar, 1) @@ -443,8 +413,8 @@ subroutine read_ascii(this) call urword(this%line, this%lloc, this%istart, this%istop, 1, idum, r, & this%iout, this%inlist) if (this%line(this%istart:this%istop) == 'END' .or. this%ierr < 0) then - ! If END was found then call line_reader backspace - ! emulator so that caller can proceed with reading END. + ! -- If END was found then call line_reader backspace + ! emulator so that caller can proceed with reading END. if (this%ierr == 0) then call this%line_reader%bkspc(this%inlist) end if @@ -477,7 +447,7 @@ subroutine read_ascii(this) cellid(3), r, this%iout, this%inlist) end if ! - ! -- ensure cellid is valid, store an error otherwise + ! -- Ensure cellid is valid, store an error otherwise call check_cellid(ii, cellid, this%mshape, this%ndim) ! ! -- Calculate user node number @@ -567,7 +537,7 @@ subroutine read_ascii(this) if (ii == this%nlist) exit readloop end if ! - ! -- increment ii row counter + ! -- Increment ii row counter ii = ii + 1 ! end do readloop @@ -577,18 +547,21 @@ subroutine read_ascii(this) call store_error_unit(this%inlist) end if ! - ! -- return + ! -- Return return end subroutine read_ascii - !> @ brief Check for valid cellid + !> @brief Check for valid cellid !< subroutine check_cellid(ii, cellid, mshape, ndim) + ! -- dummy integer(I4B), intent(in) :: ii integer(I4B), dimension(:), intent(in) :: cellid !< cellid integer(I4B), dimension(:), intent(in) :: mshape !< model shape integer(I4B), intent(in) :: ndim !< size of mshape + ! -- local character(len=20) :: cellstr, mshstr + ! -- formats character(len=*), parameter :: fmterr = & "('List entry ',i0,' contains cellid ',a,' but this cellid is invalid & &for model with shape ', a)" @@ -598,6 +571,7 @@ subroutine check_cellid(ii, cellid, mshape, ndim) "('(',i0,',',i0,')')" character(len=*), parameter :: fmtndim3 = & "('(',i0,',',i0,',',i0,')')" + ! if (ndim == 1) then if (cellid(1) < 1 .or. cellid(1) > mshape(1)) then write (cellstr, fmtndim1) cellid(1) @@ -623,16 +597,14 @@ subroutine check_cellid(ii, cellid, mshape, ndim) call store_error(errmsg) end if end if + ! + ! -- Return return end subroutine check_cellid + !> @brief Write input data to a list + !< subroutine write_list(this) -! ****************************************************************************** -! write_list -- Write input data to a list -! ****************************************************************************** -! -! SPECIFICATIONS: -! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, & TABLEFT, TABCENTER @@ -653,16 +625,15 @@ subroutine write_list(this) type(TableType), pointer :: inputtab => null() ! -- formats character(len=LINELENGTH) :: fmtlstbn -! ------------------------------------------------------------------------------ ! ! -- Determine sizes ldim = size(this%rlist, 1) naux = size(this%auxvar, 1) ! - ! -- dimension table + ! -- Dimension table ntabrows = this%nlist ! - ! -- start building format statement to parse this%label, which + ! -- Start building format statement to parse this%label, which ! contains the column headers (except for boundname and auxnames) ipos = index(this%label, 'NO.') if (ipos /= 0) then @@ -671,17 +642,17 @@ subroutine write_list(this) else fmtlstbn = '(a7' end if - ! -- sequence number, layer, row, and column. + ! -- Sequence number, layer, row, and column. if (size(this%mshape) == 3) then ntabcols = 4 fmtlstbn = trim(fmtlstbn)//',a7,a7,a7' ! - ! -- sequence number, layer, and cell2d. + ! -- Sequence number, layer, and cell2d. else if (size(this%mshape) == 2) then ntabcols = 3 fmtlstbn = trim(fmtlstbn)//',a7,a7' ! - ! -- sequence number and node. + ! -- Sequence number and node. else ntabcols = 2 fmtlstbn = trim(fmtlstbn)//',a7' @@ -706,40 +677,40 @@ subroutine write_list(this) end do fmtlstbn = trim(fmtlstbn)//')' ! - ! -- allocate words + ! -- Allocate words allocate (words(ntabcols)) ! - ! -- parse this%label into words + ! -- Parse this%label into words read (this%label, fmtlstbn) (words(i), i=1, ntabcols) ! - ! -- initialize the input table object + ! -- Initialize the input table object call table_cr(inputtab, ' ', ' ') call inputtab%table_df(ntabrows, ntabcols, this%iout) ! - ! -- add the columns + ! -- Add the columns ipos = 1 call inputtab%initialize_column(words(ipos), 10, alignment=TABCENTER) ! - ! -- discretization + ! -- Discretization do i = 1, size(this%mshape) ipos = ipos + 1 call inputtab%initialize_column(words(ipos), 7, alignment=TABCENTER) end do ! - ! -- non-optional variables + ! -- Non-optional variables do i = 1, ldim ipos = ipos + 1 call inputtab%initialize_column(words(ipos), 16, alignment=TABCENTER) end do ! - ! -- boundname + ! -- Boundname if (this%inamedbound == 1) then ipos = ipos + 1 tag = 'BOUNDNAME' call inputtab%initialize_column(tag, LENBOUNDNAME, alignment=TABLEFT) end if ! - ! -- aux variables + ! -- Aux variables do i = 1, naux call inputtab%initialize_column(this%auxname(i), 16, alignment=TABCENTER) end do @@ -748,7 +719,7 @@ subroutine write_list(this) do ii = 1, this%nlist call inputtab%add_term(ii) ! - ! -- discretization + ! -- Discretization if (size(this%mshape) == 3) then nod = this%nodelist(ii) call get_ijk(nod, this%mshape(2), this%mshape(3), this%mshape(1), & @@ -766,29 +737,29 @@ subroutine write_list(this) call inputtab%add_term(nod) end if ! - ! -- non-optional variables + ! -- Non-optional variables do jj = 1, ldim call inputtab%add_term(this%rlist(jj, ii)) end do ! - ! -- boundname + ! -- Boundname if (this%inamedbound == 1) then call inputtab%add_term(this%boundname(ii)) end if ! - ! -- aux variables + ! -- Aux variables do jj = 1, naux call inputtab%add_term(this%auxvar(jj, ii)) end do end do ! - ! -- deallocate the local variables + ! -- Deallocate the local variables call inputtab%table_da() deallocate (inputtab) nullify (inputtab) deallocate (words) ! - ! -- return + ! -- Return return end subroutine write_list