prtocmodule Module Reference

Data Types
type	prtoctype
	@ brief Output control for particle tracking models More...

Functions/Subroutines
subroutine, public	oc_cr (ocobj, name_model, inunit, iout)
	@ brief Create an output control object More...
subroutine	prt_oc_allocate_scalars (this, name_model)
subroutine	oc_ar (this, dis, dnodata)
	@ brief Setup output control variables. More...
subroutine	prt_oc_da (this)
subroutine	prt_oc_read_options (this)
subroutine	prt_oc_read_dimensions (this)
	Read the dimensions block. More...
subroutine	prt_oc_read_tracktimes (this)
	Read the tracking times block. More...

Function/Subroutine Documentation

oc_ar()

subroutine prtocmodule::oc_ar ( class(prtoctype)  this, class(disbasetype), intent(in), pointer  dis, real(dp), intent(in)  dnodata  )

private

Parameters

	this	PrtOcType object
[in]	dis	model discretization package
[in]	dnodata	no data value

Definition at line 123 of file prt-oc.f90.

    ! dummy
    class(PrtOcType) :: this !< PrtOcType object
    class(DisBaseType), pointer, intent(in) :: dis !< model discretization package
    real(DP), intent(in) :: dnodata !< no data value
    ! local
    integer(I4B) :: i, nocdobj, inodata
    type(OutputControlDataType), pointer :: ocdobjptr
    real(DP), dimension(:), pointer, contiguous :: nullvec => null()
 
    ! Allocate and initialize variables
    allocate (this%tracktimes)
    call this%tracktimes%init()
    inodata = 0
    nocdobj = 1
    allocate (this%ocds(nocdobj))
    do i = 1, nocdobj
      call ocd_cr(ocdobjptr)
      select case (i)
      case (1)
        call ocdobjptr%init_dbl('BUDGET', nullvec, dis, 'PRINT LAST ', &
                                'COLUMNS 10 WIDTH 11 DIGITS 4 GENERAL ', &
                                this%iout, dnodata)
      end select
      this%ocds(i) = ocdobjptr
      deallocate (ocdobjptr)
    end do
 
    ! Read options, dimensions, and tracktimes
    ! blocks if this package is enabled
    if (this%inunit <= 0) return
    call this%read_options()
    call this%prt_oc_read_dimensions()
    call this%prt_oc_read_tracktimes()
 

Here is the call graph for this function:

oc_cr()

subroutine, public prtocmodule::oc_cr	(	type(prtoctype), pointer	ocobj,
		character(len=*), intent(in)	name_model,
		integer(i4b), intent(in)	inunit,
		integer(i4b), intent(in)	iout
	)

Parameters

	ocobj	PrtOcType object
[in]	name_model	name of the model
[in]	inunit	unit number for input
[in]	iout	unit number for output

Definition at line 52 of file prt-oc.f90.

    type(PrtOcType), pointer :: ocobj !< PrtOcType object
    character(len=*), intent(in) :: name_model !< name of the model
    integer(I4B), intent(in) :: inunit !< unit number for input
    integer(I4B), intent(in) :: iout !< unit number for output
 
    ! Create the object
    allocate (ocobj)
 
    ! Allocate scalars
    call ocobj%allocate_scalars(name_model)
 
    ! Save unit numbers
    ocobj%inunit = inunit
    ocobj%iout = iout
 
    ! Initialize block parser
    call ocobj%parser%Initialize(inunit, iout)

Here is the caller graph for this function:

prt_oc_allocate_scalars()

subroutine prtocmodule::prt_oc_allocate_scalars ( class(prtoctype)  this, character(len=*), intent(in)  name_model  )

private

Parameters

[in]

name_model

name of model

Definition at line 72 of file prt-oc.f90.

    class(PrtOcType) :: this
    character(len=*), intent(in) :: name_model !< name of model
 
    this%memoryPath = create_mem_path(name_model, 'OC')
 
    allocate (this%name_model)
    call mem_allocate(this%dump_event_trace, 'DUMP_EVENT_TRACE', this%memoryPath)
    call mem_allocate(this%inunit, 'INUNIT', this%memoryPath)
    call mem_allocate(this%iout, 'IOUT', this%memoryPath)
    call mem_allocate(this%ibudcsv, 'IBUDCSV', this%memoryPath)
    call mem_allocate(this%iperoc, 'IPEROC', this%memoryPath)
    call mem_allocate(this%iocrep, 'IOCREP', this%memoryPath)
    call mem_allocate(this%itrkout, 'ITRKOUT', this%memoryPath)
    call mem_allocate(this%itrkhdr, 'ITRKHDR', this%memoryPath)
    call mem_allocate(this%itrkcsv, 'ITRKCSV', this%memoryPath)
    call mem_allocate(this%itrktls, 'ITRKTLS', this%memoryPath)
    call mem_allocate(this%trackrelease, 'ITRACKRELEASE', this%memoryPath)
    call mem_allocate(this%trackfeatexit, 'ITRACKFEATEXIT', this%memoryPath)
    call mem_allocate(this%tracktimestep, 'ITRACKTIMESTEP', this%memoryPath)
    call mem_allocate(this%trackterminate, 'ITRACKTERMINATE', this%memoryPath)
    call mem_allocate(this%trackweaksink, 'ITRACKWEAKSINK', this%memoryPath)
    call mem_allocate(this%trackusertime, 'ITRACKUSERTIME', this%memoryPath)
    call mem_allocate(this%tracksubfexit, 'ITRACKSUBFEXIT', this%memoryPath)
    call mem_allocate(this%trackdropped, 'ITRACKDROPPED', this%memoryPath)
    call mem_allocate(this%ntracktimes, 'NTRACKTIMES', this%memoryPath)
 
    this%name_model = name_model
    this%dump_event_trace = .false.
    this%inunit = 0
    this%iout = 0
    this%ibudcsv = 0
    this%iperoc = 0
    this%iocrep = 0
    this%itrkout = 0
    this%itrkhdr = 0
    this%itrkcsv = 0
    this%itrktls = 0
    this%trackrelease = .false.
    this%trackfeatexit = .false.
    this%tracktimestep = .false.
    this%trackterminate = .false.
    this%trackweaksink = .false.
    this%trackusertime = .false.
    this%tracksubfexit = .false.
    this%trackdropped = .false.
    this%ntracktimes = 0
 

Here is the call graph for this function:

prt_oc_da()

subroutine prtocmodule::prt_oc_da ( class(prtoctype)  this )

private

Definition at line 160 of file prt-oc.f90.

    ! dummy
    class(PrtOcType) :: this
    ! local
    integer(I4B) :: i
 
    call this%tracktimes%deallocate()
 
    do i = 1, size(this%ocds)
      call this%ocds(i)%ocd_da()
    end do
    deallocate (this%ocds)
 
    deallocate (this%name_model)
    call mem_deallocate(this%dump_event_trace)
    call mem_deallocate(this%inunit)
    call mem_deallocate(this%iout)
    call mem_deallocate(this%ibudcsv)
    call mem_deallocate(this%iperoc)
    call mem_deallocate(this%iocrep)
    call mem_deallocate(this%itrkout)
    call mem_deallocate(this%itrkhdr)
    call mem_deallocate(this%itrkcsv)
    call mem_deallocate(this%itrktls)
    call mem_deallocate(this%trackrelease)
    call mem_deallocate(this%trackfeatexit)
    call mem_deallocate(this%tracktimestep)
    call mem_deallocate(this%trackterminate)
    call mem_deallocate(this%trackweaksink)
    call mem_deallocate(this%trackusertime)
    call mem_deallocate(this%tracksubfexit)
    call mem_deallocate(this%trackdropped)
    call mem_deallocate(this%ntracktimes)
 

prt_oc_read_dimensions()

subroutine prtocmodule::prt_oc_read_dimensions

(

class(prtoctype), intent(inout)

this

)

Definition at line 362 of file prt-oc.f90.

    use constantsmodule, only: linelength
    use simmodule, only: store_error, count_errors
    ! dummy
    class(PrtOcType), intent(inout) :: this
    ! local
    character(len=LINELENGTH) :: keyword
    integer(I4B) :: ierr
    logical(LGP) :: isfound, endOfBlock
 
    ! initialize dimensions to -1
    this%ntracktimes = -1
 
    ! get dimensions block
    call this%parser%GetBlock('DIMENSIONS', isfound, ierr, &
                              supportopenclose=.true., &
                              blockrequired=.false.)
 
    ! parse dimensions block if detected
    if (.not. isfound) return
    write (this%iout, '(/1x,a)') &
      'PROCESSING OUTPUT CONTROL DIMENSIONS'
    do
      call this%parser%GetNextLine(endofblock)
      if (endofblock) exit
      call this%parser%GetStringCaps(keyword)
      select case (keyword)
      case ('NTRACKTIMES')
        this%ntracktimes = this%parser%GetInteger()
        write (this%iout, '(4x,a,i7)') 'NTRACKTIMES = ', this%ntracktimes
      case default
        write (errmsg, '(a,a)') &
          'UNKNOWN OUTPUT CONTROL DIMENSION: ', trim(keyword)
        call store_error(errmsg)
      end select
    end do
    write (this%iout, '(1x,a)') &
      'END OF OUTPUT CONTROL DIMENSIONS'
 
    if (this%ntracktimes < 0) then
      write (errmsg, '(a)') &
        'NTRACKTIMES WAS NOT SPECIFIED OR WAS SPECIFIED INCORRECTLY.'
      call store_error(errmsg)
    end if
 
    ! stop if errors were encountered in the block
    if (count_errors() > 0) &
      call this%parser%StoreErrorUnit()
 

Here is the call graph for this function:

prt_oc_read_options()

subroutine prtocmodule::prt_oc_read_options ( class(prtoctype)  this )

private

Definition at line 196 of file prt-oc.f90.

    ! modules
    use openspecmodule, only: access, form
    use inputoutputmodule, only: getunit, openfile, lowcase
    use constantsmodule, only: linelength
    use particletracksmodule, only: trackheader, trackdtypes
    use simmodule, only: store_error, store_error_unit
    use inputoutputmodule, only: openfile, getunit
    ! dummy
    class(PrtOcType) :: this
    ! local
    character(len=LINELENGTH) :: keyword
    character(len=LINELENGTH) :: keyword2
    character(len=LINELENGTH) :: fname
    character(len=:), allocatable :: line
    integer(I4B) :: ierr, ipos
    logical(LGP) :: block_found, param_found, event_found, eob
    type(OutputControlDataType), pointer :: ocdobjptr
    ! formats
    character(len=*), parameter :: fmttrkbin = &
      "(4x, 'PARTICLE TRACKS WILL BE SAVED TO BINARY FILE: ', a, /4x, &
    &'OPENED ON UNIT: ', I0)"
    character(len=*), parameter :: fmttrkcsv = &
      "(4x, 'PARTICLE TRACKS WILL BE SAVED TO CSV FILE: ', a, /4x, &
    &'OPENED ON UNIT: ', I0)"
 
    ! get options block
    call this%parser%GetBlock('OPTIONS', block_found, ierr, &
                              supportopenclose=.true., blockrequired=.false.)
 
    ! parse options block if detected
    if (block_found) then
      write (this%iout, '(/,1x,a,/)') 'PROCESSING OC OPTIONS'
      event_found = .false.
      do
        call this%parser%GetNextLine(eob)
        if (eob) exit
        call this%parser%GetStringCaps(keyword)
        param_found = .false.
        select case (keyword)
        case ('BUDGETCSV')
          call this%parser%GetStringCaps(keyword2)
          if (keyword2 /= 'FILEOUT') then
            errmsg = "BUDGETCSV must be followed by FILEOUT and then budget &
              &csv file name.  Found '"//trim(keyword2)//"'."
            call store_error(errmsg)
            call this%parser%StoreErrorUnit()
          end if
          call this%parser%GetString(fname)
          this%ibudcsv = getunit()
          call openfile(this%ibudcsv, this%iout, fname, 'CSV', &
                        filstat_opt='REPLACE')
          param_found = .true.
        case ('TRACK')
          call this%parser%GetStringCaps(keyword)
          if (keyword == 'FILEOUT') then
            ! parse filename
            call this%parser%GetString(fname)
            ! open binary track output file
            this%itrkout = getunit()
            call openfile(this%itrkout, this%iout, fname, 'DATA(BINARY)', &
                          form, access, filstat_opt='REPLACE', &
                          mode_opt=mnormal)
            write (this%iout, fmttrkbin) trim(adjustl(fname)), this%itrkout
            ! open and write ascii track header file
            this%itrkhdr = getunit()
            fname = trim(fname)//'.hdr'
            call openfile(this%itrkhdr, this%iout, fname, 'CSV', &
                          filstat_opt='REPLACE', mode_opt=mnormal)
            write (this%itrkhdr, '(a,/,a)') trackheader, trackdtypes
          else
            call store_error('OPTIONAL TRACK KEYWORD MUST BE '// &
                             'FOLLOWED BY FILEOUT')
          end if
          param_found = .true.
        case ('TRACKCSV')
          call this%parser%GetStringCaps(keyword)
          if (keyword == 'FILEOUT') then
            ! parse filename
            call this%parser%GetString(fname)
            ! open CSV track output file and write headers
            this%itrkcsv = getunit()
            call openfile(this%itrkcsv, this%iout, fname, 'CSV', &
                          filstat_opt='REPLACE')
            write (this%iout, fmttrkcsv) trim(adjustl(fname)), this%itrkcsv
            write (this%itrkcsv, '(a)') trackheader
          else
            call store_error('OPTIONAL TRACKCSV KEYWORD MUST BE &
              &FOLLOWED BY FILEOUT')
          end if
          param_found = .true.
        case ('TRACK_RELEASE')
          this%trackrelease = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_EXIT')
          this%trackfeatexit = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_TIMESTEP')
          this%tracktimestep = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_TERMINATE')
          this%trackterminate = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_WEAKSINK')
          this%trackweaksink = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_USERTIME')
          this%trackusertime = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_SUBFEATURE_EXIT')
          this%tracksubfexit = .true.
          event_found = .true.
          param_found = .true.
        case ('TRACK_DROPPED')
          this%trackdropped = .true.
          event_found = .true.
          param_found = .true.
        case ('DEV_DUMP_EVENT_TRACE')
          this%dump_event_trace = .true.
          param_found = .true.
        case default
          param_found = .false.
        end select
 
        ! check if we're done
        if (.not. param_found) then
          do ipos = 1, size(this%ocds)
            ocdobjptr => this%ocds(ipos)
            if (keyword == trim(ocdobjptr%cname)) then
              param_found = .true.
              exit
            end if
          end do
          if (.not. param_found) then
            errmsg = "UNKNOWN OC OPTION '"//trim(keyword)//"'."
            call store_error(errmsg)
            call this%parser%StoreErrorUnit()
          end if
          call this%parser%GetRemainingLine(line)
          call ocdobjptr%set_option(line, this%parser%iuactive, this%iout)
        end if
      end do
 
      ! default events
      if (.not. event_found) then
        this%trackrelease = .true.
        this%trackfeatexit = .true.
        this%tracktimestep = .true.
        this%trackterminate = .true.
        this%trackweaksink = .true.
        this%trackusertime = .true.
        this%trackdropped = .true.
      end if
 
      ! logging
      write (this%iout, '(1x,a)') 'END OF OC OPTIONS'
    end if

Here is the call graph for this function:

prt_oc_read_tracktimes()

subroutine prtocmodule::prt_oc_read_tracktimes

(

class(prtoctype), intent(inout)

this

)

Definition at line 414 of file prt-oc.f90.

    ! dummy
    class(PrtOcType), intent(inout) :: this
    ! local
    integer(I4B) :: i, ierr
    logical(LGP) :: eob, found, success
    real(DP) :: t
 
    ! get tracktimes block
    call this%parser%GetBlock('TRACKTIMES', found, ierr, &
                              supportopenclose=.true., &
                              blockrequired=.false.)
 
    ! raise an error if tracktimes has a dimension
    ! but no block was found, otherwise return early
    if (.not. found) then
      if (this%ntracktimes <= 0) return
      write (errmsg, '(a, i0)') &
        "Expected TRACKTIMES with length ", this%ntracktimes
      call store_error(errmsg)
      call this%parser%StoreErrorUnit(terminate=.true.)
    end if
 
    ! allocate time selection
    call this%tracktimes%expand(this%ntracktimes)
 
    ! read the block
    write (this%iout, '(/1x,a)') &
      'PROCESSING OUTPUT CONTROL TRACKTIMES'
    do i = 1, this%ntracktimes
      call this%parser%GetNextLine(eob)
      if (eob) exit
      call this%parser%TryGetDouble(t, success)
      if (.not. success) then
        errmsg = "Failed to read double precision value"
        call store_error(errmsg)
        call this%parser%StoreErrorUnit(terminate=.true.)
      end if
      this%tracktimes%times(i) = t
    end do
 
    ! make sure times strictly increase
    if (.not. this%tracktimes%increasing()) then
      errmsg = "TRACKTIMES must strictly increase"
      call store_error(errmsg)
      call this%parser%StoreErrorUnit(terminate=.true.)
    end if
 

Here is the call graph for this function: