From 52580179cfa3267585adc844e95087939185cd22 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Wed, 20 May 2020 18:27:39 -0400 Subject: [PATCH 01/11] refactor(MemoryManager): Add string array --- autotest/test_gwf_npf03_sfr.py | 6 +- src/Exchange/GwfGwfExchange.f90 | 89 +++-- src/Exchange/NumericalExchange.f90 | 57 ++- src/Model/GroundWaterFlow/gwf3csub8.f90 | 41 +- src/Model/GroundWaterFlow/gwf3sfr8.f90 | 23 +- src/Model/ModelUtilities/BoundaryPackage.f90 | 66 +-- src/Utilities/DeferredStringObject.f90 | 10 - src/Utilities/InputOutput.f90 | 8 +- src/Utilities/Memory/MemoryManager.f90 | 399 ++++++++++++++----- src/Utilities/SimVariables.f90 | 4 +- 10 files changed, 473 insertions(+), 230 deletions(-) delete mode 100644 src/Utilities/DeferredStringObject.f90 diff --git a/autotest/test_gwf_npf03_sfr.py b/autotest/test_gwf_npf03_sfr.py index ca66fd0a70d..a412c8f0228 100644 --- a/autotest/test_gwf_npf03_sfr.py +++ b/autotest/test_gwf_npf03_sfr.py @@ -83,8 +83,8 @@ def get_model(idx, dir): vr = hbndl[1] for k in range(nlay): for i in range(nrow): - c6left.append([(k, i, 0), vl]) - c6right.append([(k, i, ncols[idx][-1] - 1), vr]) + c6left.append([(k, i, 0), vl, 'left']) + c6right.append([(k, i, ncols[idx][-1] - 1), vr, 'right']) cd6left = {0: c6left} cd6right = {0: c6right} @@ -197,6 +197,7 @@ def get_model(idx, dir): if jdx == 0: fn = '{}.chd1.chd'.format(mname) chd1 = flopy.mf6.modflow.ModflowGwfchd(gwf, + boundnames=True, stress_period_data=cd6left, save_flows=False, filename=fn, pname='chd1', @@ -204,6 +205,7 @@ def get_model(idx, dir): if jdx == nmodels - 1: fn = '{}.chd2.chd'.format(mname) chd2 = flopy.mf6.modflow.ModflowGwfchd(gwf, + boundnames=True, stress_period_data=cd6right, save_flows=False, filename=fn, pname='chd2', diff --git a/src/Exchange/GwfGwfExchange.f90 b/src/Exchange/GwfGwfExchange.f90 index 4a8d121970b..5b7857c6d00 100644 --- a/src/Exchange/GwfGwfExchange.f90 +++ b/src/Exchange/GwfGwfExchange.f90 @@ -1,6 +1,7 @@ module GwfGwfExchangeModule use KindModule, only: DP, I4B + use SimVariablesModule, only: errmsg use ArrayHandlersModule, only: ExpandArray use BaseModelModule, only: GetBaseModelFromList use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList @@ -312,7 +313,6 @@ subroutine gwf_gwf_ar(this) real(DP) :: csat real(DP) :: fawidth real(DP), dimension(3) :: vg - character(len=LINELENGTH) :: errmsg ! ------------------------------------------------------------------------------ ! ! -- If mover is active, then call ar routine @@ -323,9 +323,9 @@ subroutine gwf_gwf_ar(this) ! GWF-GWF exchange (this%ianglex > 0). if(this%gwfmodel1%npf%ik22 /= 0 .or. this%gwfmodel2%npf%ik22 /= 0) then if(this%ianglex == 0) then - write(errmsg, '(a)') 'Error. GWF-GWF requires that ANGLDEGX be ' // & - 'specified as an auxiliary variable because ' // & - 'K22 was specified in one or both ' // & + write(errmsg, '(a)') 'GWF-GWF requires that ANGLDEGX be ' // & + 'specified as an auxiliary variable because ' // & + 'K22 was specified in one or both ' // & 'groundwater models.' call store_error(errmsg) call ustop() @@ -338,17 +338,17 @@ subroutine gwf_gwf_ar(this) if(this%gwfmodel1%npf%icalcspdis /= 0 .or. & this%gwfmodel2%npf%icalcspdis /= 0) then if(this%ianglex == 0) then - write(errmsg, '(a)') 'Error. GWF-GWF requires that ANGLDEGX be ' // & - 'specified as an auxiliary variable because ' // & - 'specific discharge is being calculated in' // & + write(errmsg, '(a)') 'GWF-GWF requires that ANGLDEGX be ' // & + 'specified as an auxiliary variable because ' // & + 'specific discharge is being calculated in' // & ' one or both groundwater models.' call store_error(errmsg) call ustop() endif if(this%icdist == 0) then - write(errmsg, '(a)') 'Error. GWF-GWF requires that CDIST be ' // & - 'specified as an auxiliary variable because ' // & - 'specific discharge is being calculated in' // & + write(errmsg, '(a)') 'GWF-GWF requires that CDIST be ' // & + 'specified as an auxiliary variable because ' // & + 'specific discharge is being calculated in' // & ' one or both groundwater models.' call store_error(errmsg) call ustop() @@ -1170,17 +1170,27 @@ subroutine read_options(this, iout) ! ------------------------------------------------------------------------------ ! -- modules use ArrayHandlersModule, only: ifind - use ConstantsModule, only: LINELENGTH, DEM6 + use ConstantsModule, only: LINELENGTH, LENAUXNAME, DEM6 + use MemoryManagerModule, only: mem_allocate use InputOutputModule, only: getunit, openfile, urdaux use SimModule, only: store_error, store_error_unit, ustop ! -- dummy class(GwfExchangeType) :: this integer(I4B), intent(in) :: iout ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword, fname - integer(I4B) :: istart,istop,lloc,ierr,ival + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: keyword + character(len=LINELENGTH) :: fname + character(len=LENAUXNAME), dimension(:), allocatable :: caux + logical :: isfound + logical :: endOfBlock + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: lloc + integer(I4B) :: ierr + integer(I4B) :: ival integer(I4B) :: inobs - logical :: isfound, endOfBlock + integer(I4B) :: n ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -1192,21 +1202,33 @@ subroutine read_options(this, iout) write(iout,'(1x,a)')'PROCESSING GWF EXCHANGE OPTIONS' do call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit + if (endOfBlock) then + exit + end if call this%parser%GetStringCaps(keyword) select case (keyword) case('AUXILIARY') call this%parser%GetRemainingLine(line) lloc = 1 - call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & - istop, this%auxname, line, 'GWF_GWF_Exchange') + call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & + istop, caux, line, 'GWF_GWF_Exchange') + call mem_allocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', trim(this%name)) + do n = 1, this%naux + this%auxname(n) = caux(n) + end do + deallocate(caux) ! ! -- If ANGLDEGX is an auxiliary variable, then anisotropy can be ! used in either model. Store ANGLDEGX position in this%ianglex ival = ifind(this%auxname, 'ANGLDEGX') - if(ival > 0) this%ianglex = ival + if (ival > 0) then + this%ianglex = ival + end if ival = ifind(this%auxname, 'CDIST') - if(ival > 0) this%icdist = ival + if(ival > 0) then + this%icdist = ival + end if case ('PRINT_INPUT') this%iprpak = 1 write(iout,'(4x,a)') & @@ -1227,8 +1249,7 @@ subroutine read_options(this, iout) case('AMT-LMK') this%icellavg = 2 case default - write(errmsg,'(4x,a,a)')'UNKNOWN CELL AVERAGING METHOD: ', & - trim(keyword) + errmsg = "Unknown cell averaging method '" // trim(keyword) // "'." call store_error(errmsg) call this%parser%StoreErrorUnit() call ustop() @@ -1304,14 +1325,13 @@ subroutine read_options(this, iout) call openfile(inobs, iout, this%obs%inputFilename, 'OBS') this%obs%inUnitObs = inobs case default - write(errmsg,'(4x,a,a)')'***ERROR. UNKNOWN GWF EXCHANGE OPTION: ', & - trim(keyword) + errmsg = "Unknown gwf exchange option '" // trim(keyword) // "'." call store_error(errmsg) call this%parser%StoreErrorUnit() call ustop() end select end do - write(iout,'(1x,a)')'END OF GWF EXCHANGE OPTIONS' + write(iout,'(1x,a)') 'END OF GWF EXCHANGE OPTIONS' end if ! ! -- set omega value used for saturation calculations @@ -1338,7 +1358,7 @@ subroutine read_data(this, iout) class(GwfExchangeType) :: this integer(I4B), intent(in) :: iout ! -- local - character(len=LINELENGTH) :: errmsg, nodestr, node1str, node2str, cellid + character(len=LINELENGTH) :: nodestr, node1str, node2str, cellid character(len=2) :: cnfloat integer(I4B) :: lloc, ierr, nerr, iaux integer(I4B) :: iexg, nodem1, nodem2, nodeum1, nodeum2 @@ -1424,20 +1444,20 @@ subroutine read_data(this, iout) ! -- Check to see if nodem1 is outside of active domain if(nodem1 <= 0) then call this%gwfmodel1%dis%nodeu_to_string(nodeum1, nodestr) - write(errmsg, *) & - trim(adjustl(this%gwfmodel1%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write(errmsg, *) & + trim(adjustl(this%gwfmodel1%name)) // & + ' Cell is outside active grid domain ' // & + trim(adjustl(nodestr)) // '.' call store_error(errmsg) endif ! ! -- Check to see if nodem2 is outside of active domain if(nodem2 <= 0) then call this%gwfmodel2%dis%nodeu_to_string(nodeum2, nodestr) - write(errmsg, *) & - trim(adjustl(this%gwfmodel2%name)) // & - ' Cell is outside active grid domain: ' // & - trim(adjustl(nodestr)) + write(errmsg, *) & + trim(adjustl(this%gwfmodel2%name)) // & + ' Cell is outside active grid domain ' // & + trim(adjustl(nodestr)) // '.' call store_error(errmsg) endif enddo @@ -1452,7 +1472,7 @@ subroutine read_data(this, iout) ! write(iout,'(1x,a)')'END OF EXCHANGEDATA' else - write(errmsg, '(1x,a)')'ERROR. REQUIRED EXCHANGEDATA BLOCK NOT FOUND.' + errmsg = 'Required exchangedata block not found.' call store_error(errmsg) call this%parser%StoreErrorUnit() call ustop() @@ -1477,7 +1497,6 @@ subroutine read_gnc(this, iout) integer(I4B), intent(in) :: iout ! -- local integer(I4B) :: i, nm1, nm2, nmgnc1, nmgnc2 - character(len=LINELENGTH) :: errmsg character(len=*), parameter :: fmterr = & "('EXCHANGE NODES ', i0, ' AND ', i0," // & "' NOT CONSISTENT WITH GNC NODES ', i0, ' AND ', i0)" diff --git a/src/Exchange/NumericalExchange.f90 b/src/Exchange/NumericalExchange.f90 index 028802a3ebb..63a394306a9 100644 --- a/src/Exchange/NumericalExchange.f90 +++ b/src/Exchange/NumericalExchange.f90 @@ -1,10 +1,11 @@ module NumericalExchangeModule use KindModule, only: DP, I4B + use SimVariablesModule, only: errmsg use BaseExchangeModule, only: BaseExchangeType use NumericalModelModule, only: NumericalModelType use BaseExchangeModule, only: BaseExchangeType, AddBaseExchangeToList - use ConstantsModule, only: LINELENGTH, DZERO + use ConstantsModule, only: LINELENGTH, LENAUXNAME, DZERO use ListModule, only: ListType use BlockParserModule, only: BlockParserType @@ -30,7 +31,8 @@ module NumericalExchangeModule class(NumericalModelType), pointer :: m1 => null() !pointer to model 1 class(NumericalModelType), pointer :: m2 => null() !pointer to model 2 integer(I4B), pointer :: naux => null() !number of auxiliary variables - character(len=16), allocatable, dimension(:) :: auxname !array of auxiliary variable names + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: auxname => null() !vector of auxname real(DP), dimension(:, :), pointer, contiguous :: auxvar => null() !array of auxiliary variable values type(BlockParserType) :: parser !block parser contains @@ -405,7 +407,6 @@ subroutine allocate_scalars(this) call mem_allocate(this%ipakcb, 'IPAKCB', this%name) call mem_allocate(this%nexg, 'NEXG', this%name) call mem_allocate(this%naux, 'NAUX', this%name) - allocate(this%auxname(0)) this%filename = '' this%typename = '' this%implicit = .false. @@ -473,7 +474,7 @@ subroutine exg_da(this) call mem_deallocate(this%ipakcb) call mem_deallocate(this%nexg) call mem_deallocate(this%naux) - deallocate(this%auxname) + call mem_deallocate(this%auxname, 'AUXNAME', trim(this%name)) ! ! -- arrays call mem_deallocate(this%nodem1) @@ -495,7 +496,8 @@ subroutine read_options(this, iout) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ - use ConstantsModule, only: LINELENGTH + use ConstantsModule, only: LINELENGTH, LENAUXNAME + use MemoryManagerModule, only: mem_allocate use SimModule, only: store_error, ustop use InputOutputModule, only: urdaux use ArrayHandlersModule, only: expandarray @@ -503,9 +505,16 @@ subroutine read_options(this, iout) class(NumericalExchangeType) :: this integer(I4B), intent(in) :: iout ! -- local - character(len=LINELENGTH) :: line, errmsg, keyword - integer(I4B) :: istart,istop,lloc,ierr - logical :: isfound, endOfBlock + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: keyword + character(len=LENAUXNAME), dimension(:), allocatable :: caux + logical :: isfound + logical :: endOfBlock + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: lloc + integer(I4B) :: ierr + integer(I4B) :: n ! ------------------------------------------------------------------------------ ! ! -- get options block @@ -517,14 +526,22 @@ subroutine read_options(this, iout) write(iout,'(1x,a)')'PROCESSING EXCHANGE OPTIONS' do call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit + if (endOfBlock) then + exit + end if call this%parser%GetStringCaps(keyword) select case (keyword) case('AUX', 'AUXILIARY') call this%parser%GetRemainingLine(line) lloc = 1 - call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & - istop, this%auxname, line, 'NM_NM_Exchange') + call urdaux(this%naux, this%parser%iuactive, iout, lloc, istart, & + istop, caux, line, 'NM_NM_Exchange') + call mem_allocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', trim(this%name)) + do n = 1, this%naux + this%auxname(n) = caux(n) + end do + deallocate(caux) case ('PRINT_INPUT') this%iprpak = 1 write(iout,'(4x,a)') & @@ -534,14 +551,13 @@ subroutine read_options(this, iout) write(iout,'(4x,a)') & 'EXCHANGE FLOWS WILL BE PRINTED TO LIST FILES.' case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN EXCHANGE OPTION: ', & - trim(keyword) + errmsg = "Unknown exchange option '" // trim(keyword) // "'." call store_error(errmsg) call this%parser%StoreErrorUnit() call ustop() end select end do - write(iout,'(1x,a)')'END OF EXCHANGE OPTIONS' + write(iout,'(1x,a)') 'END OF EXCHANGE OPTIONS' end if ! ! -- return @@ -563,7 +579,7 @@ subroutine read_dimensions(this, iout) class(NumericalExchangeType) :: this integer(I4B), intent(in) :: iout ! -- local - character(len=LINELENGTH) :: errmsg, keyword + character(len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock ! ------------------------------------------------------------------------------ @@ -574,7 +590,7 @@ subroutine read_dimensions(this, iout) ! ! -- parse options block if detected if (isfound) then - write(iout,'(1x,a)')'PROCESSING EXCHANGE DIMENSIONS' + write(iout,'(1x,a)') 'PROCESSING EXCHANGE DIMENSIONS' do call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit @@ -582,18 +598,17 @@ subroutine read_dimensions(this, iout) select case (keyword) case ('NEXG') this%nexg = this%parser%GetInteger() - write(iout,'(4x,a,i7)')'NEXG = ', this%nexg + write(iout,'(4x,a,i0)') 'NEXG = ', this%nexg case default - write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN DIMENSION: ', & - trim(keyword) + errmsg = "Unknown dimension '" // trim(keyword) // "'." call store_error(errmsg) call this%parser%StoreErrorUnit() call ustop() end select end do - write(iout,'(1x,a)')'END OF EXCHANGE DIMENSIONS' + write(iout,'(1x,a)') 'END OF EXCHANGE DIMENSIONS' else - call store_error('ERROR. REQUIRED DIMENSIONS BLOCK NOT FOUND.') + call store_error('Required dimensions block not found.') call this%parser%StoreErrorUnit() call ustop() end if diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index f0136c5e77c..ca52970703c 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -20,6 +20,7 @@ module GwfCsubModule use InputOutputModule, only: get_node, extract_idnum_or_bndname use BaseDisModule, only: DisBaseType use SimModule, only: count_errors, store_error, store_error_unit, ustop + use SimVariablesModule, only: errmsg use ArrayHandlersModule, only: ExpandArray use SortModule, only: qsort, selectn ! @@ -50,7 +51,8 @@ module GwfCsubModule type, extends(NumericalPackageType) :: GwfCsubType character(len=LENBOUNDNAME), dimension(:), & pointer, contiguous :: boundname => null() !vector of boundnames - character(len=LENAUXNAME), allocatable, dimension(:) :: auxname !name for each auxiliary variable + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: auxname => null() !vector of auxname character(len=500) :: listlabel = '' !title of table written for RP character(len=LENORIGIN) :: stoname integer(I4B), pointer :: istounit => null() @@ -380,9 +382,6 @@ subroutine csub_allocate_scalars(this) ! -- allocate TS object allocate(this%TsManager) ! - ! -- Allocate text strings - allocate(this%auxname(0)) - ! ! -- initialize values this%istounit = 0 this%inobspkg = 0 @@ -1686,7 +1685,6 @@ subroutine csub_read_packagedata(this) ! -- dummy class(GwfCsubType),intent(inout) :: this ! -- local - character(len=LINELENGTH) :: errmsg character(len=LINELENGTH) :: cellid character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag @@ -2130,18 +2128,20 @@ subroutine read_options(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ use ConstantsModule, only: MAXCHARLEN, DZERO + use MemoryManagerModule, only: mem_allocate use OpenSpecModule, only: access, form use InputOutputModule, only: urword, getunit, urdaux, openfile implicit none ! -- dummy class(GwfCsubType), intent(inout) :: this ! -- local - character(len=LINELENGTH) :: errmsg character(len=LINELENGTH) :: keyword character(len=LINELENGTH) :: line character(len=MAXCHARLEN) :: fname + character(len=LENAUXNAME), dimension(:), allocatable :: caux logical :: isfound logical :: endOfBlock + integer(I4B) :: n integer(I4B) :: lloc integer(I4B) :: istart integer(I4B) :: istop @@ -2184,14 +2184,22 @@ subroutine read_options(this) write(this%iout,'(1x,a)') 'PROCESSING CSUB OPTIONS' do call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit + if (endOfBlock) then + exit + end if call this%parser%GetStringCaps(keyword) select case (keyword) case('AUX', 'AUXILIARY') call this%parser%GetRemainingLine(line) lloc = 1 call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & - istart, istop, this%auxname, line, this%name) + istart, istop, caux, line, this%name) + call mem_allocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', this%origin) + do n = 1, this%naux + this%auxname(n) = caux(n) + end do + deallocate(caux) case ('SAVE_FLOWS') this%ipakcb = -1 write(this%iout, fmtflow2) @@ -2774,8 +2782,8 @@ subroutine csub_da(this) call mem_deallocate(this%cell_thick) ! ! -- interbed storage - deallocate(this%boundname) - deallocate(this%auxname) + call mem_deallocate(this%boundname, 'BOUNDNAME', this%origin) + call mem_deallocate(this%auxname, 'AUXNAME', this%origin) call mem_deallocate(this%auxvar) call mem_deallocate(this%ci) call mem_deallocate(this%rci) @@ -2951,7 +2959,6 @@ subroutine csub_read_dimensions(this) ! -- dummy class(GwfCsubType),intent(inout) :: this ! -- local - character(len=LINELENGTH) :: errmsg character(len=LENBOUNDNAME) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock @@ -3034,7 +3041,6 @@ subroutine csub_ar(this, dis, ibound) ! -- local logical :: isfound, endOfBlock character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg character(len=LINELENGTH) :: keyword character(len=20) :: cellid integer(I4B) :: iske @@ -3415,7 +3421,6 @@ subroutine csub_cg_chk_stress(this) implicit none class(GwfCsubType) :: this ! -- local - character(len=LINELENGTH) :: errmsg character(len=20) :: cellid integer(I4B) :: ierr integer(I4B) :: node @@ -3485,7 +3490,6 @@ subroutine csub_nodelay_update(this, i) class(GwfCsubType), intent(inout) :: this integer(I4B),intent(in) :: i ! locals - character(len=LINELENGTH) :: errmsg real(DP) :: comp real(DP) :: thick real(DP) :: theta @@ -3679,7 +3683,6 @@ subroutine csub_rp(this) class(GwfCsubType),intent(inout) :: this ! -- local character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg character(len=LINELENGTH) :: title character(len=LINELENGTH) :: text character(len=20) :: cellid @@ -3839,7 +3842,6 @@ subroutine csub_ad(this, nodes, hnew) integer(I4B), intent(in) :: nodes real(DP), dimension(nodes), intent(in) :: hnew ! -- local - character(len=LINELENGTH) :: errmsg integer(I4B) :: ib integer(I4B) :: n integer(I4B) :: idelay @@ -3963,7 +3965,6 @@ subroutine csub_set_initial_state(this, nodes, hnew) character(len=LINELENGTH) :: title character(len=LINELENGTH) :: tag character(len=20) :: cellid - character (len=LINELENGTH) :: errmsg integer(I4B) :: ib integer(I4B) :: node integer(I4B) :: n @@ -4718,7 +4719,6 @@ subroutine csub_interbed_fc(this, ib, node, area, hcell, hcellold, hcof, rhs) real(DP), intent(inout) :: rhs ! locals character(len=20) :: cellid - character (len=LINELENGTH) :: errmsg integer(I4B) :: idelaycalc real(DP) :: snnew real(DP) :: snold @@ -5059,7 +5059,6 @@ subroutine csub_cg_update(this, node) class(GwfCsubType), intent(inout) :: this integer(I4B),intent(in) :: node ! locals - character(len=LINELENGTH) :: errmsg character(len=20) :: cellid real(DP) :: comp real(DP) :: thick @@ -5828,7 +5827,6 @@ subroutine csub_delay_chk(this, ib, hcell) integer(I4B), intent(in) :: ib real(DP), intent(in) :: hcell ! -- local variables - character(len=LINELENGTH) :: errmsg character(len=20) :: cellid integer(I4B) :: idelay integer(I4B) :: node @@ -6320,7 +6318,6 @@ subroutine csub_delay_update(this, ib) class(GwfCsubType), intent(inout) :: this integer(I4B), intent(in) :: ib ! -- local variables - character(len=LINELENGTH) :: errmsg integer(I4B) :: idelay integer(I4B) :: n real(DP) :: comp @@ -6676,7 +6673,6 @@ subroutine csub_bd_obs(this) class(GwfCsubType), intent(inout) :: this ! -- local type(ObserveType), pointer :: obsrv => null() - character(len=LINELENGTH) :: errmsg integer(I4B) :: i integer(I4B) :: j integer(I4B) :: n @@ -6898,7 +6894,6 @@ subroutine csub_rp_obs(this) ! -- local class(ObserveType), pointer :: obsrv => null() character(len=LENBOUNDNAME) :: bname - character(len=LINELENGTH) :: errmsg integer(I4B) :: i, j, n integer(I4B) :: n2 integer(I4B) :: idelay diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index 025cf7851a8..267ed16dc97 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -23,6 +23,7 @@ module SfrModule use BaseDisModule, only: DisBaseType use SimModule, only: count_errors, store_error, store_error_unit, & store_warning, ustop + use SimVariablesModule, only: errmsg, warnmsg use GenericUtilitiesModule, only: sim_message use ArrayHandlersModule, only: ExpandArray use BlockParserModule, only: BlockParserType @@ -313,7 +314,8 @@ subroutine sfr_allocate_arrays(this) ! ! -- allocate character array for budget text allocate(this%csfrbudget(this%bditems)) - allocate(this%sfrname(this%maxbound)) + call mem_allocate(this%sfrname, LENBOUNDNAME, this%maxbound, & + 'SFRNAME', this%origin) ! ! -- variables originally in SfrDataType call mem_allocate(this%iboundpak, this%maxbound, 'IBOUNDPAK', this%origin) @@ -465,7 +467,6 @@ subroutine sfr_read_dimensions(this) ! -- dummy class(SfrType),intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg character (len=LINELENGTH) :: keyword integer(I4B) :: ierr logical :: isfound, endOfBlock @@ -750,7 +751,6 @@ subroutine sfr_read_packagedata(this) ! -- dummy class(SfrType),intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg character(len=LINELENGTH) :: text character(len=LINELENGTH) :: cellid character(len=LINELENGTH) :: keyword @@ -962,7 +962,6 @@ subroutine sfr_read_connectiondata(this) class(SfrType),intent(inout) :: this ! -- local character (len=LINELENGTH) :: line - character (len=LINELENGTH) :: errmsg logical :: isfound logical :: endOfBlock integer(I4B) :: n @@ -1178,7 +1177,6 @@ subroutine sfr_read_diversions(this) ! -- dummy class(SfrType),intent(inout) :: this ! -- local - character (len=LINELENGTH) :: errmsg character (len=10) :: cnum character (len=10) :: cval integer(I4B) :: j @@ -1392,7 +1390,6 @@ subroutine sfr_rp(this) ! -- local character(len=LINELENGTH) :: title character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: errmsg integer(I4B) :: ierr integer(I4B) :: n integer(I4B) :: ichkustrm @@ -2164,7 +2161,7 @@ subroutine sfr_da(this) call mem_deallocate(this%qoutflow) call mem_deallocate(this%qextoutflow) deallocate(this%csfrbudget) - deallocate(this%sfrname) + call mem_deallocate(this%sfrname, 'SFRNAME', this%origin) call mem_deallocate(this%dbuff) deallocate(this%cauxcbc) call mem_deallocate(this%qauxcbc) @@ -2514,7 +2511,6 @@ subroutine sfr_rp_obs(this) class(SfrType), intent(inout) :: this ! -- local integer(I4B) :: i, j, n, nn1 - character(len=LINELENGTH) :: errmsg character(len=LENBOUNDNAME) :: bname logical :: jfound class(ObserveType), pointer :: obsrv => null() @@ -2674,7 +2670,6 @@ subroutine sfr_set_stressperiod(this, n, ichkustrm) character(len=LINELENGTH) :: text character(len=LINELENGTH) :: caux character(len=LINELENGTH) :: keyword - character(len=LINELENGTH) :: errmsg integer(I4B) :: ival integer(I4B) :: ii integer(I4B) :: jj @@ -3624,7 +3619,6 @@ subroutine sfr_check_reaches(this) character (len=30) :: nodestr character (len=LINELENGTH) :: title character (len=LINELENGTH) :: text - character (len=LINELENGTH) :: errmsg integer(I4B) :: n, nn real(DP) :: btgwf, bt ! -- code @@ -3738,7 +3732,6 @@ subroutine sfr_check_connections(this) character (len= 5) :: crch2 character (len=LINELENGTH) :: text character (len=LINELENGTH) :: title - character (len=LINELENGTH) :: errmsg integer(I4B) :: n, nn, nc integer(I4B) :: i, ii integer(I4B) :: ifound @@ -3972,7 +3965,6 @@ subroutine sfr_check_diversions(this) character (len= 5) :: cdiv character (len= 5) :: crch2 character (len=10) :: cprior - character (len=LINELENGTH) :: errmsg integer(I4B) :: maxdiv integer(I4B) :: n integer(I4B) :: nn @@ -4077,7 +4069,6 @@ subroutine sfr_check_ustrf(this) logical :: ladd character (len=5) :: crch, crch2 character (len=10) :: cval - character (len=LINELENGTH) :: errmsg integer(I4B) :: maxcols integer(I4B) :: npairs integer(I4B) :: ipair @@ -4175,11 +4166,11 @@ subroutine sfr_check_ustrf(this) if (ids > 1) then call store_error(errmsg) else - write(errmsg, '(a,3(1x,a))') & - trim(errmsg), 'A warning instead of an error is issued because', & + write(warnmsg, '(a,3(1x,a))') & + trim(warnmsg), 'A warning instead of an error is issued because', & 'the reach is only connected to the diversion reach in the ', & 'downstream direction.' - call store_warning(errmsg) + call store_warning(warnmsg) end if end if end do diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 536e6c55c24..95b26ea3929 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -6,6 +6,7 @@ module BndModule LENORIGIN, MAXCHARLEN, LINELENGTH, & DNODATA, LENLISTLABEL, LENPAKLOC, & TABLEFT, TABCENTER + use SimVariablesModule, only: errmsg use SimModule, only: count_errors, store_error, ustop, & store_error_unit use NumericalPackageModule, only: NumericalPackageType @@ -33,7 +34,8 @@ module BndModule ! -- characters character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP character(len=LENPACKAGENAME) :: text = '' - character(len=LENAUXNAME), allocatable, dimension(:) :: auxname !name for each auxiliary variable + character(len=LENAUXNAME), dimension(:), pointer, & + contiguous :: auxname => null() !vector of auxname character(len=LENBOUNDNAME), dimension(:), pointer, & contiguous :: boundname => null() !vector of boundnames ! @@ -288,7 +290,7 @@ subroutine bnd_rp(this) ! -- local integer(I4B) :: ierr, nlist logical :: isfound - character(len=LINELENGTH) :: line, errmsg + character(len=LINELENGTH) :: line ! -- formats character(len=*),parameter :: fmtblkerr = & "('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" @@ -858,8 +860,8 @@ subroutine bnd_da(this) call mem_deallocate(this%simvals) call mem_deallocate(this%simtomvr) call mem_deallocate(this%auxvar) - deallocate(this%boundname) - deallocate(this%auxname) + call mem_deallocate(this%boundname, 'BOUNDNAME', this%origin) + call mem_deallocate(this%auxname, 'AUXNAME', this%origin) nullify(this%icelltype) ! ! -- pakmvrobj @@ -965,9 +967,6 @@ subroutine allocate_scalars(this) allocate(this%TsManager) allocate(this%TasManager) ! - ! -- Allocate text strings - allocate(this%auxname(0)) - ! ! -- Initialize variables this%ibcnum = 0 this%maxbound = 0 @@ -1047,7 +1046,7 @@ subroutine allocate_arrays(this, nodelist, auxvar) if(present(auxvar)) then this%auxvar => auxvar else - call mem_allocate(this%auxvar, this%naux, this%maxbound, 'AUXVAR', & + call mem_allocate(this%auxvar, this%naux, this%maxbound, 'AUXVAR', & this%origin) do i = 1, this%maxbound do j = 1, this%naux @@ -1057,19 +1056,19 @@ subroutine allocate_arrays(this, nodelist, auxvar) endif ! ! -- Allocate boundname - if(this%inamedbound==1) then - allocate(this%boundname(this%maxbound)) - else - allocate(this%boundname(1)) - endif + if (this%inamedbound /= 0) then + call mem_allocate(this%boundname, LENBOUNDNAME, this%maxbound, & + 'BOUNDNAME', this%origin) + end if ! ! -- Set pointer to ICELLTYPE. For GWF boundary packages, ! this%ictorigin will be 'NPF'. If boundary packages do not set ! this%ictorigin, then icelltype will remain as null() - if (this%ictorigin /= '') & + if (this%ictorigin /= '') then call mem_setptr(this%icelltype, 'ICELLTYPE', & trim(adjustl(this%name_model)) // ' ' // & trim(adjustl(this%ictorigin))) + end if ! ! -- Initialize values do j = 1, this%maxbound @@ -1080,11 +1079,7 @@ subroutine allocate_arrays(this, nodelist, auxvar) do i = 1, this%maxbound this%hcof(i) = DZERO this%rhs(i) = DZERO - if(this%inamedbound==1) then - this%boundname(i) = '' - end if end do - if(this%inamedbound /= 1) this%boundname(1) = '' ! ! -- setup the output table call this%pak_setup_outputtab() @@ -1140,17 +1135,25 @@ subroutine bnd_read_options(this) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use ConstantsModule, only: LINELENGTH use InputOutputModule, only: urdaux + use MemoryManagerModule, only: mem_allocate use SimModule, only: ustop, store_error, store_error_unit ! -- dummy class(BndType),intent(inout) :: this ! -- local - character(len=LINELENGTH) :: line, errmsg, fname, keyword + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: keyword character(len=LENAUXNAME) :: sfacauxname - integer(I4B) :: lloc,istart,istop,n,ierr + character(len=LENAUXNAME), dimension(:), allocatable :: caux + integer(I4B) :: lloc + integer(I4B) :: istart + integer(I4B) :: istop + integer(I4B) :: n + integer(I4B) :: ierr integer(I4B) :: inobs - logical :: isfound, endOfBlock + logical :: isfound + logical :: endOfBlock logical :: foundchildclassoption ! -- format character(len=*),parameter :: fmtflow = & @@ -1177,14 +1180,22 @@ subroutine bnd_read_options(this) //' OPTIONS' do call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit + if (endOfBlock) then + exit + end if call this%parser%GetStringCaps(keyword) select case (keyword) case('AUX', 'AUXILIARY') call this%parser%GetRemainingLine(line) lloc = 1 - call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & - istart, istop, this%auxname, line, this%text) + call urdaux(this%naux, this%parser%iuactive, this%iout, lloc, & + istart, istop, caux, line, this%text) + call mem_allocate(this%auxname, LENAUXNAME, this%naux, & + 'AUXNAME', this%origin) + do n = 1, this%naux + this%auxname(n) = caux(n) + end do + deallocate(caux) case ('SAVE_FLOWS') this%ipakcb = -1 write(this%iout, fmtflow2) @@ -1339,9 +1350,10 @@ subroutine bnd_read_dimensions(this) ! -- dummy class(BndType),intent(inout) :: this ! -- local - character(len=LINELENGTH) :: errmsg, keyword + character(len=LINELENGTH) :: keyword + logical :: isfound + logical :: endOfBlock integer(I4B) :: ierr - logical :: isfound, endOfBlock ! -- format ! ------------------------------------------------------------------------------ ! diff --git a/src/Utilities/DeferredStringObject.f90 b/src/Utilities/DeferredStringObject.f90 deleted file mode 100644 index 6889c6d77d9..00000000000 --- a/src/Utilities/DeferredStringObject.f90 +++ /dev/null @@ -1,10 +0,0 @@ -module DeferredStringModule - implicit none - - public :: deferred_string_type - - type deferred_string_type - character(len=:), allocatable :: string - end type deferred_string_type - -end module DeferredStringModule diff --git a/src/Utilities/InputOutput.f90 b/src/Utilities/InputOutput.f90 index cce5b5e738f..a3cc44929a6 100644 --- a/src/Utilities/InputOutput.f90 +++ b/src/Utilities/InputOutput.f90 @@ -1778,8 +1778,7 @@ subroutine extract_idnum_or_bndname(line, icol, istart, istop, idnum, bndname) return end subroutine extract_idnum_or_bndname - subroutine urdaux(naux, inunit, iout, lloc, istart, istop, auxname, line, & - text) + subroutine urdaux(naux, inunit, iout, lloc, istart, istop, auxname, line, text) ! ****************************************************************************** ! Read auxiliary variables from an input line ! ****************************************************************************** @@ -1808,9 +1807,8 @@ subroutine urdaux(naux, inunit, iout, lloc, istart, istop, auxname, line, & ! ------------------------------------------------------------------------------ linelen = len(line) if(naux > 0) then - write(errmsg,'(a)') '****ERROR. AUXILIARY VARIABLES ' // & - 'ALREADY SPECIFIED. AUXILIARY VARIABLES MUST BE SPECIFIED '// & - 'ON ONE LINE IN THE OPTIONS BLOCK.' + write(errmsg,'(a)') 'Auxiliary variables already specified. Auxiliary ' // & + 'variables must be specified on one line in the options block.' call store_error(errmsg) call store_error_unit(inunit) call ustop() diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index 480687c86e5..bb33e7cee35 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -3,7 +3,8 @@ module MemoryManagerModule use KindModule, only: DP, I4B, I8B use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME, LINELENGTH, & LENMEMTYPE - use SimModule, only: store_error, ustop + use SimVariablesModule, only: errmsg + use SimModule, only: store_error, count_errors, ustop use MemoryTypeModule, only: MemoryType use MemoryListModule, only: MemoryListType @@ -29,41 +30,44 @@ module MemoryManagerModule type(MemoryListType) :: memorylist integer(I8B) :: nvalues_alogical = 0 integer(I8B) :: nvalues_achr = 0 + integer(I8B) :: nvalues_astr = 0 integer(I8B) :: nvalues_aint = 0 integer(I8B) :: nvalues_adbl = 0 integer(I4B) :: iprmem = 0 interface mem_allocate - module procedure allocate_logical, & - allocate_int, allocate_int1d, allocate_int2d, & - allocate_int3d, & - allocate_dbl, allocate_dbl1d, allocate_dbl2d, & + module procedure allocate_logical, & + allocate_str1d, & + allocate_int, allocate_int1d, allocate_int2d, & + allocate_int3d, & + allocate_dbl, allocate_dbl1d, allocate_dbl2d, & allocate_dbl3d end interface mem_allocate interface mem_reallocate - module procedure reallocate_int1d, reallocate_int2d, reallocate_dbl1d, & - reallocate_dbl2d + module procedure reallocate_int1d, reallocate_int2d, reallocate_dbl1d, & + reallocate_dbl2d, reallocate_str1d end interface mem_reallocate interface mem_setptr - module procedure setptr_logical, & - setptr_int, setptr_int1d, setptr_int2d, & + module procedure setptr_logical, & + setptr_int, setptr_int1d, setptr_int2d, & setptr_dbl, setptr_dbl1d, setptr_dbl2d end interface mem_setptr interface mem_copyptr - module procedure copyptr_int1d, copyptr_int2d, & + module procedure copyptr_int1d, copyptr_int2d, & copyptr_dbl1d, copyptr_dbl2d end interface mem_copyptr interface mem_reassignptr - module procedure reassignptr_int1d, reassignptr_int2d, & + module procedure reassignptr_int1d, reassignptr_int2d, & reassignptr_dbl1d, reassignptr_dbl2d end interface mem_reassignptr interface mem_deallocate module procedure deallocate_logical, & + deallocate_str1d, & deallocate_int, deallocate_int1d, deallocate_int2d, & deallocate_int3d, & deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & @@ -128,6 +132,8 @@ subroutine get_mem_size(name, origin, size) size = -1 if (found) then select case(mt%memtype(1:index(mt%memtype,' '))) + case ('STRING') + size = 1 case ('INTEGER') size = 4 case ('DOUBLE') @@ -189,7 +195,6 @@ subroutine get_from_memorylist(name, origin, mt, found, check) logical, intent(in), optional :: check integer(I4B) :: ipos logical check_opt - character(len=LINELENGTH) :: ermsg mt => null() found = .false. do ipos = 1, memorylist%count() @@ -198,49 +203,51 @@ subroutine get_from_memorylist(name, origin, mt, found, check) found = .true. exit endif - enddo + end do check_opt = .true. - if (present(check)) check_opt = check + if (present(check)) then + check_opt = check + end if if (check_opt) then if (.not. found) then - ermsg = 'Programming error in memory manager. Variable ' // name // & - ' in origin ' // origin // & - ' cannot be assigned because it does not exist in memory manager. ' - call store_error(ermsg) + errmsg = "Programming error in memory manager. Variable '" // & + trim(name) // "' in origin '" // trim(origin) // "' cannot be " // & + "assigned because it does not exist in memory manager." + call store_error(errmsg) call ustop() - endif + end if end if return end subroutine get_from_memorylist - subroutine allocate_error(varname, origin, istat, errmsg, isize) - use SimModule, only: store_error, ustop + subroutine allocate_error(varname, origin, istat, isize) + !use SimModule, only: store_error, ustop + ! -- dummy character(len=*), intent(in) :: varname character(len=*), intent(in) :: origin + ! -- local + character(len=20) :: csize + character(len=20) :: cstat integer(I4B), intent(in) :: istat - character(len=*), intent(in) :: errmsg integer(I4B), intent(in) :: isize - character(len=20) :: cint - call store_error('Error trying to allocate memory.') - call store_error(' Origin: ' // origin) - call store_error(' Variable name: ' // varname) - write(cint, '(i0)') isize - call store_error(' Size: ' // cint) - call store_error(' Error message: ' // errmsg) - cint = '' - write(cint, '(i0)') istat - call store_error(' Status code: ' // cint) + ! -- code + write(csize, '(i0)') isize + write(cstat, '(i0)') istat + errmsg = "Error trying to allocate memory. Origin '" // trim(origin) // & + "' variable name '" // trim(varname) // "' size '" // trim(csize) // & + "'. Error message is '" // trim(adjustl(errmsg)) // & + "'. Status code is " // trim(cstat) // '.' + call store_error(errmsg) call ustop() end subroutine allocate_error subroutine check_varname(name) character(len=*), intent(in) :: name - character(len=LINELENGTH) :: ermsg if(len(name) > LENVARNAME) then - write(ermsg, '(*(G0))') & - 'Programming error in Memory Manager. Variable ', name, ' must be ', & + write(errmsg, '(*(G0))') & + 'Programming error in Memory Manager. Variable ', name, ' must be ', & LENVARNAME, ' characters or less.' - call store_error(ermsg) + call store_error(errmsg) call ustop() endif end subroutine check_varname @@ -251,9 +258,10 @@ subroutine allocate_logical(logicalsclr, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - character(len=100) :: ermsg - allocate(logicalsclr, stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, 1) + allocate(logicalsclr, stat=istat, errmsg=errmsg) + if(istat /= 0) then + call allocate_error(name, origin, istat, 1) + end if nvalues_alogical = nvalues_alogical + 1 allocate(mt) mt%logicalsclr => logicalsclr @@ -270,10 +278,11 @@ subroutine allocate_int(intsclr, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) - allocate(intsclr, stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, 1) + allocate(intsclr, stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, 1) + end if nvalues_aint = nvalues_aint + 1 allocate(mt) mt%intsclr => intsclr @@ -284,6 +293,64 @@ subroutine allocate_int(intsclr, name, origin) call memorylist%add(mt) end subroutine allocate_int + subroutine allocate_str1d(astr1d, ilen, nrow, name, origin) + ! -- dummy variables + integer(I4B), intent(in) :: ilen + integer(I4B), intent(in) :: nrow + character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr1d + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + ! -- local variables + type(MemoryType), pointer :: mt + character(len=ilen) :: string + integer(I4B) :: n + integer(I4B) :: istat + integer(I4B) :: isize + ! -- code + ! + ! -- initialize string + string = '' + ! + ! -- check that the varible name is not already defined + call check_varname(name) + ! + ! -- calculate isize + isize = ilen * nrow + ! + ! -- allocate defined length string array + if (isize > 0) Then + allocate(astr1d(nrow), stat=istat, errmsg=errmsg) + ! + ! -- check for error condition + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if + ! + ! -- fill deferred length string with empty string + do n = 1, nrow + astr1d(n) = string + end do + ! + ! -- update string counter + nvalues_astr = nvalues_astr + isize + ! + ! -- allocate memory type + allocate(mt) + ! + ! -- set memory type + mt%isize = isize + mt%name = name + mt%origin = origin + write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + ! + ! -- add defined length character array to the memory manager + call memorylist%add(mt) + end if + ! + ! -- return + return + end subroutine allocate_str1d + subroutine allocate_int1d(aint, isize, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint integer(I4B), intent(in) :: isize @@ -291,10 +358,11 @@ subroutine allocate_int1d(aint, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) - allocate(aint(isize), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(aint(isize), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if nvalues_aint = nvalues_aint + isize allocate(mt) mt%aint1d => aint @@ -314,11 +382,12 @@ subroutine allocate_int2d(aint, ncol, nrow, name, origin) integer(I4B) :: istat integer(I4B) :: isize type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow - allocate(aint(ncol, nrow), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(aint(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if nvalues_aint = nvalues_aint + isize allocate(mt) mt%aint2d => aint @@ -339,11 +408,12 @@ subroutine allocate_int3d(aint, ncol, nrow, nlay, name, origin) integer(I4B) :: istat integer(I4B) :: isize type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow * nlay - allocate(aint(ncol, nrow, nlay), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(aint(ncol, nrow, nlay), stat=istat, errmsg=errmsg) + if(istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if nvalues_aint = nvalues_aint + isize allocate(mt) mt%aint3d => aint @@ -361,10 +431,11 @@ subroutine allocate_dbl(dblsclr, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) - allocate(dblsclr, stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, 1) + allocate(dblsclr, stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, 1) + end if nvalues_aint = nvalues_aint + 1 allocate(mt) mt%dblsclr => dblsclr @@ -382,10 +453,11 @@ subroutine allocate_dbl1d(adbl, isize, name, origin) character(len=*), intent(in) :: origin integer(I4B) :: istat type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) - allocate(adbl(isize), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(adbl(isize), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if nvalues_adbl = nvalues_adbl + isize allocate(mt) mt%adbl1d => adbl @@ -405,11 +477,12 @@ subroutine allocate_dbl2d(adbl, ncol, nrow, name, origin) integer(I4B) :: istat integer(I4B) :: isize type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow - allocate(adbl(ncol, nrow), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(adbl(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if nvalues_adbl = nvalues_adbl + isize allocate(mt) mt%adbl2d => adbl @@ -430,11 +503,12 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, origin) integer(I4B) :: istat integer(I4B) :: isize type(MemoryType), pointer :: mt - character(len=100) :: ermsg call check_varname(name) isize = ncol * nrow * nlay - allocate(adbl(ncol, nrow, nlay), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(adbl(ncol, nrow, nlay), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if nvalues_adbl = nvalues_adbl + isize allocate(mt) mt%adbl3d => adbl @@ -446,6 +520,91 @@ subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, origin) call memorylist%add(mt) end subroutine allocate_dbl3d + subroutine reallocate_str1d(astr1d, ilen, nrow, name, origin) + ! -- dummy + integer(I4B), intent(in) :: ilen + integer(I4B), intent(in) :: nrow + character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr1d + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + ! -- local + type(MemoryType), pointer :: mt + logical :: found + character(len=ilen), dimension(:), allocatable :: astrtemp + integer(I4B) :: istat + integer(I4B) :: isize + integer(I4B) :: isize_old + integer(I4B) :: nrow_old + integer(I4B) :: n + ! + ! -- Find and assign mt + call get_from_memorylist(name, origin, mt, found) + ! + ! -- reallocate astr1d + if (found) then + isize_old = mt%isize + if (isize_old > 0) then + nrow_old = size(astr1d) + else + nrow_old = 0 + end if + ! + ! -- calculate isize + isize = ilen * nrow + ! + ! -- allocate astrtemp + allocate(astrtemp(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if + ! + ! -- copy existing values + do n = 1, nrow_old + astrtemp(n) = astr1d(n) + end do + ! + ! -- fill new values with missing values + do n = nrow_old + 1, nrow + astrtemp(n) = '' + end do + ! + ! -- deallocate mt pointer, repoint, recalculate isize + if (isize_old > 0) then + deallocate(astr1d) + end if + ! + ! -- allocate astr1d + allocate(astr1d(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if + ! + ! -- fill the reallocate character array + do n = 1, nrow + astr1d(n) = astrtemp(n) + end do + ! + ! -- deallocate temporary storage + deallocate(astrtemp) + ! + ! -- reset memory manager values + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_astr = nvalues_astr + isize - isize_old + write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + else + errmsg = "Programming error, varible '" // trim(name) // "' from '" // & + trim(origin) // "' is not defined in the memory manager. Use " // & + "mem_allocate instead." + call store_error(errmsg) + call ustop() + end if + ! + ! -- return + return + end subroutine reallocate_str1d + subroutine reallocate_int1d(aint, isize, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint integer(I4B), intent(in) :: isize @@ -455,7 +614,6 @@ subroutine reallocate_int1d(aint, isize, name, origin) type(MemoryType), pointer :: mt integer(I4B) :: i, isizeold integer(I4B) :: ifill - character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt @@ -464,8 +622,10 @@ subroutine reallocate_int1d(aint, isize, name, origin) ! -- Allocate aint and then refill isizeold = size(mt%aint1d) ifill = min(isizeold, isize) - allocate(aint(isize), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(aint(isize), stat=istat, errmsg=errmsg) + if(istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if do i = 1, ifill aint(i) = mt%aint1d(i) enddo @@ -482,6 +642,7 @@ subroutine reallocate_int1d(aint, isize, name, origin) return end subroutine reallocate_int1d + subroutine reallocate_int2d(aint, ncol, nrow, name, origin) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint integer(I4B), intent(in) :: ncol @@ -492,7 +653,6 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, origin) type(MemoryType), pointer :: mt integer(I4B), dimension(2) :: ishape integer(I4B) :: i, j, isize, isizeold - character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt @@ -502,8 +662,10 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, origin) ishape = shape(mt%aint2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate(aint(ncol, nrow), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(aint(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if do i = 1, ishape(2) do j = 1, ishape(1) aint(j, i) = mt%aint2d(j, i) @@ -532,7 +694,6 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) type(MemoryType), pointer :: mt integer(I4B) :: i, isizeold integer(I4B) :: ifill - character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt @@ -541,8 +702,10 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) ! -- Allocate adbl and then refill isizeold = size(mt%adbl1d) ifill = min(isizeold, isize) - allocate(adbl(isize), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(adbl(isize), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if do i = 1, ifill adbl(i) = mt%adbl1d(i) enddo @@ -570,7 +733,6 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) type(MemoryType), pointer :: mt integer(I4B), dimension(2) :: ishape integer(I4B) :: i, j, isize, isizeold - character(len=100) :: ermsg logical :: found ! ! -- Find and assign mt @@ -580,8 +742,10 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) ishape = shape(mt%adbl2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate(adbl(ncol, nrow), stat=istat, errmsg=ermsg) - if(istat /= 0) call allocate_error(name, origin, istat, ermsg, isize) + allocate(adbl(ncol, nrow), stat=istat, errmsg=errmsg) + if(istat /= 0) then + call allocate_error(name, origin, istat, isize) + end if do i = 1, ishape(2) do j = 1, ishape(1) adbl(j, i) = mt%adbl2d(j, i) @@ -956,6 +1120,46 @@ subroutine deallocate_dbl(dblsclr) endif end subroutine deallocate_dbl + subroutine deallocate_str1d(astr1d, name, origin) + ! -- dummy variables + character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d + character(len=*), optional :: name + character(len=*), optional :: origin + ! -- local variables + type(MemoryType), pointer :: mt + logical :: found + !integer(I4B) :: ipos + ! -- code + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found, check=.FALSE.) + else + errmsg = 'Programming error. Name and origin not passed ' // & + 'to deallocate_str1d.' + call store_error(errmsg) + call ustop() + end if + if (.not. found .and. associated(astr1d)) then + errmsg = "Programming error in deallocate_str1d. Variable '" // & + trim(name) // "' from origin '" // trim(origin) // "' is not " // & + "present in the memory manager but is associated." + call store_error(errmsg) + call ustop() + else + if (found) then + if (mt%master) then + if (mt%isize > 0) then + deallocate(astr1d) + end if + else + nullify(astr1d) + end if + end if + endif + ! + ! -- return + return + end subroutine deallocate_str1d + subroutine deallocate_int1d(aint1d, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint1d character(len=*), optional :: name @@ -1172,26 +1376,32 @@ subroutine mem_set_print_option(iout, keyword, errmsg) write(iout, '(4x, a)') & 'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.' case default - write(errmsg,'(4x,a,a)') & - 'UNKNOWN MEMORY PRINT OPTION: ', trim(keyword) + errmsg = "Unknown memory print option '" // trim(keyword) // "." end select return end subroutine mem_set_print_option subroutine mem_usage(iout) + !use TableModule, only: TableType, table_cr + ! -- dummy integer(I4B), intent(in) :: iout + ! -- local class(MemoryType), pointer :: mt + character(len=200) :: msg + character(len=LENORIGIN), allocatable, dimension(:) :: cunique + real(DP) :: bytesmb + integer(I4B) :: ipos + integer(I4B) :: icomp + integer(I4B) :: ilen + integer(I8B) :: nchars + integer(I8B) :: nint + integer(I8B) :: nreal + ! -- formats character(len=*), parameter :: fmt = "(1x, a, i0)" character(len=*), parameter :: fmtd = "(1x, a, 1(1pg15.6))" character(len=*), parameter :: fmttitle = "(/, 1x, a)" character(len=*), parameter :: fmtheader = & "(1x, a40, a20, a20, a10, a10, a10, /, 1x, 110('-'))" - character(len=200) :: msg - character(len=LENORIGIN), allocatable, dimension(:) :: cunique - real(DP) :: bytesmb - integer(I4B) :: ipos - integer(I4B) :: icomp, ilen - integer(I8B) :: nint, nreal ! ! -- Write info to simulation list file write(iout, fmttitle) 'INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' @@ -1207,6 +1417,7 @@ subroutine mem_usage(iout) ' MBYTES ' write(iout, "(56('-'))") do icomp = 1, size(cunique) + nchars = 0 nint = 0 nreal = 0 bytesmb = DZERO @@ -1215,11 +1426,13 @@ subroutine mem_usage(iout) mt => memorylist%Get(ipos) if (cunique(icomp) /= mt%origin(1:ilen)) cycle if (.not. mt%master) cycle + if (mt%memtype(1:6) == 'STRING') nchars = nchars + mt%isize if (mt%memtype(1:7) == 'INTEGER') nint = nint + mt%isize if (mt%memtype(1:6) == 'DOUBLE') nreal = nreal + mt%isize enddo - bytesmb = (nint * I4B + nreal * DP) / 1000000.d0 - write(iout, '(a20, i10, i10, 1pg16.2)') cunique(icomp), nint, nreal, bytesmb + bytesmb = (nchars + nint * I4B + nreal * DP) / 1000000.d0 + write(iout, '(a20, i10, i10, i10, 1pg16.2)') & + cunique(icomp), nchars, nint, nreal, bytesmb enddo endif ! @@ -1240,17 +1453,18 @@ subroutine mem_usage(iout) endif ! ! -- Calculate and write total memory allocation - bytesmb = (nvalues_aint * I4B + & + bytesmb = (nvalues_astr + & + nvalues_aint * I4B + & nvalues_adbl * DP) / 1000000.d0 write(iout, *) + write(iout, fmt) 'Number of allocated characters: ', nvalues_astr write(iout, fmt) 'Number of allocated integer variables: ', nvalues_aint - write(iout, fmt) 'Number of allocated real variables: ', nvalues_adbl - write(iout, fmtd) 'Allocated memory in megabytes: ', bytesmb + write(iout, fmt) 'Number of allocated real variables: ', nvalues_adbl + write(iout, fmtd) 'Allocated memory in megabytes: ', bytesmb write(iout, *) end subroutine mem_usage subroutine mem_da() - use SimModule, only: store_error, ustop, count_errors use VersionModule, only: IDEVELOPMODE class(MemoryType), pointer :: mt integer(I4B) :: ipos @@ -1267,7 +1481,12 @@ subroutine mem_da() deallocate(mt) enddo call memorylist%clear() - if (count_errors() > 0) call ustop() + if (count_errors() > 0) then + call ustop() + end if + ! + ! -- return + return end subroutine mem_da subroutine mem_unique_origins(cunique) diff --git a/src/Utilities/SimVariables.f90 b/src/Utilities/SimVariables.f90 index 0ff2446eb68..83a49033bc7 100644 --- a/src/Utilities/SimVariables.f90 +++ b/src/Utilities/SimVariables.f90 @@ -1,11 +1,13 @@ module SimVariablesModule use, intrinsic :: iso_fortran_env, only: output_unit use KindModule, only: DP, I4B - use ConstantsModule, only: LINELENGTH, IUSTART, VALL + use ConstantsModule, only: LINELENGTH, MAXCHARLEN, IUSTART, VALL public character(len=LINELENGTH) :: simfile = 'mfsim.nam' character(len=LINELENGTH) :: simlstfile = 'mfsim.lst' character(len=LINELENGTH) :: simstdout = 'mfsim.stdout' + character(len=MAXCHARLEN) :: errmsg + character(len=MAXCHARLEN) :: warnmsg integer(I4B) :: istdout = output_unit ! -- unit number for stdout integer(I4B) :: isim_level = VALL ! -- unit number for stdout integer(I4B) :: iout ! -- unit number for simulation output From 0abe56bfdc7e32d3ac835201585854ed10dacc8e Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Thu, 21 May 2020 09:29:14 -0400 Subject: [PATCH 02/11] refactor(MemoryManager): Add string array --- .gitignore | 1 + pymake/depgraph.py | 18 ++++++++++++++++++ src/Model/GroundWaterFlow/gwf3csub8.f90 | 5 ++++- 3 files changed, 23 insertions(+), 1 deletion(-) create mode 100755 pymake/depgraph.py diff --git a/.gitignore b/.gitignore index b135f052d74..9c94190e080 100644 --- a/.gitignore +++ b/.gitignore @@ -77,6 +77,7 @@ distribution/*.zip mod_temp/ obj_temp/ src_temp/ +pymake/dependencies/ trash/ diff --git a/pymake/depgraph.py b/pymake/depgraph.py new file mode 100755 index 00000000000..959351e3533 --- /dev/null +++ b/pymake/depgraph.py @@ -0,0 +1,18 @@ +#! /usr/bin/env python +import os +try: + import pymake +except: + msg = 'Error. Pymake package is not available.\n' + msg += 'Try installing using the following command:\n' + msg += ' pip install https://github.com/modflowpy/pymake/zipball/master' + print(msg) + raise Exception() +import os + +srcpth = os.path.join('..', 'src') +deppth = 'dependencies' +if not os.path.exists(deppth): + os.makedirs(deppth) + +pymake.visualize.make_plots(srcpth, deppth, include_subdir=True) diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index ca52970703c..3a5c90c1c08 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -2683,7 +2683,10 @@ subroutine csub_allocate_arrays(this) ! after number of delay beds is defined ! ! -- allocate boundname - allocate(this%boundname(this%ninterbeds)) + if (this%inamedbound /= 0) then + call mem_allocate(this%boundname, LENBOUNDNAME, this%ninterbeds, & + 'BOUNDNAME', trim(this%origin)) + end if ! ! -- allocate the nodelist and bound arrays if (this%maxsig0 > 0) then From 0657fce62cacc571f98b1303ac423820c892650b Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Thu, 21 May 2020 09:55:36 -0400 Subject: [PATCH 03/11] refactor(MemoryManager): Add string array --- autotest/test_gwf_csub_sub02.py | 7 +++- src/Model/GroundWaterFlow/gwf3csub8.f90 | 51 +++++++++++++------------ 2 files changed, 32 insertions(+), 26 deletions(-) diff --git a/autotest/test_gwf_csub_sub02.py b/autotest/test_gwf_csub_sub02.py index 89e21777d92..1c5c4f1d4e4 100644 --- a/autotest/test_gwf_csub_sub02.py +++ b/autotest/test_gwf_csub_sub02.py @@ -118,7 +118,7 @@ def get_model(idx, dir): cdelays = 'nodelay' sub6 = [[0, (0, 0, 0), cdelays, ini_stress, thick[0], - 1., cc, cr, theta, kv, 0.]] + 1., cc, cr, theta, kv, 0., 'db01']] # build MODFLOW 6 files ws = dir @@ -173,7 +173,10 @@ def get_model(idx, dir): save_flows=False) # csub files - csub = flopy.mf6.ModflowGwfcsub(gwf, head_based=True, + csub = flopy.mf6.ModflowGwfcsub(gwf, + print_input=True, + boundnames=True, + head_based=True, ndelaycells=ndelaycells[idx], ninterbeds=1, beta=0., cg_ske_cr=cg_ske, diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index 3a5c90c1c08..1e20cf3fce1 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -1690,11 +1690,11 @@ subroutine csub_read_packagedata(this) character(len=LINELENGTH) :: tag character(len=20) :: scellid character(len=10) :: text - character(len=LENBOUNDNAME) :: bndName, bndNameTemp + character(len=LENBOUNDNAME) :: bndName character(len=7) :: cdelay - character(len=9) :: cno + logical :: isfound + logical :: endOfBlock integer(I4B) :: ival - logical :: isfound, endOfBlock integer(I4B) :: n integer(I4B) :: nn integer(I4B) :: ib @@ -1729,10 +1729,14 @@ subroutine csub_read_packagedata(this) ' PACKAGEDATA' do call this%parser%GetNextLine(endOfBlock) - if (endOfBlock) exit - ! -- read interbed number + if (endOfBlock) then + exit + end if + ! + ! -- get interbed number itmp = this%parser%GetInteger() - + ! + ! -- check for error condition if (itmp < 1 .or. itmp > this%ninterbeds) then write(errmsg,'(a,1x,i0,2(1x,a),1x,i0,a)') & 'Interbed number (', itmp, ') must be greater than 0 and ', & @@ -1740,10 +1744,10 @@ subroutine csub_read_packagedata(this) call store_error(errmsg) cycle end if - + ! ! -- increment nboundchk nboundchk(itmp) = nboundchk(itmp) + 1 - + ! ! -- read cellid call this%parser%GetCellid(this%dis%ndim, cellid) nn = this%dis%noder_from_cellid(cellid, & @@ -1753,17 +1757,18 @@ subroutine csub_read_packagedata(this) top = this%dis%top(nn) bot = this%dis%bot(nn) baq = top - bot + ! ! -- determine if a valid cell location was provided if (nn < 1) then write(errmsg,'(a,1x,i0,a)') & 'Invalid cellid for packagedata entry', itmp, '.' call store_error(errmsg) end if - + ! ! -- set nodelist and unodelist this%nodelist(itmp) = nn this%unodelist(itmp) = n - + ! ! -- get cdelay call this%parser%GetStringCaps(cdelay) select case (cdelay) @@ -1781,10 +1786,10 @@ subroutine csub_read_packagedata(this) end select idelay = ival this%idelay(itmp) = ival - + ! ! -- get initial preconsolidation stress this%pcs(itmp) = this%parser%GetDouble() - + ! ! -- get thickness or cell fraction rval = this%parser%GetDouble() if (this%icellf == 0) then @@ -1808,7 +1813,7 @@ subroutine csub_read_packagedata(this) if (this%iupdatematprop /= 0) then this%thick(itmp) = rval end if - + ! ! -- get rnb rval = this%parser%GetDouble() if (idelay > 0) then @@ -1873,26 +1878,24 @@ subroutine csub_read_packagedata(this) end if end if this%kv(itmp) = rval - + ! ! -- get h0 rval = this%parser%GetDouble() this%h0(itmp) = rval - + ! ! -- get bound names - write (cno,'(i9.9)') nn - bndName = 'nsystem' // cno if (this%inamedbound /= 0) then - call this%parser%GetStringCaps(bndNameTemp) - if (bndNameTemp /= '') then - bndName = bndNameTemp(1:16) + call this%parser%GetStringCaps(bndName) + if (len_trim(bndName) < 1) then + write(errmsg,'(a,1x,i0,a)') & + 'BOUNDNAME must be specified for packagedata entry', itmp, '.' + call store_error(errmsg) else - write(errmsg,'(a,1x,i0,a)') & - 'BOUNDNAME must be specified for packagedata entry', itmp, '.' - call store_error(errmsg) + this%boundname(itmp) = bndName end if end if - this%boundname(itmp) = bndName end do + write(this%iout,'(1x,a)') & 'END OF ' // trim(adjustl(this%name)) // ' PACKAGEDATA' end if From 90c60b53271d866d82a4cd23fed79eda04ff2530 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Thu, 21 May 2020 16:45:09 -0400 Subject: [PATCH 04/11] refactor(MemoryManager): Add string array Use UWWORD for memory tables --- src/Utilities/Memory/Memory.f90 | 74 ++++++-- src/Utilities/Memory/MemoryManager.f90 | 251 +++++++++++++++++++++---- 2 files changed, 270 insertions(+), 55 deletions(-) diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 1c36b409231..a66334d0e6b 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -2,7 +2,10 @@ module MemoryTypeModule use KindModule, only: DP, I4B use ConstantsModule, only: LENORIGIN, LENTIMESERIESNAME, LENVARNAME, & - MAXMEMRANK, LENMEMTYPE + MAXMEMRANK, LENMEMTYPE, & + TABSTRING, TABINTEGER, & + TABCENTER, TABLEFT, TABRIGHT + use InputOutputModule, only: UWWORD implicit none private public :: MemoryType @@ -31,21 +34,64 @@ module MemoryTypeModule contains - subroutine table_entry(this, msg) + subroutine table_entry(this, line) + ! -- dummy class(MemoryType) :: this - character(len=*), intent(inout) :: msg - character(len=*), parameter :: & - fmt = "(1x, a40, a20, a20, i10, i10, a10, a2)" - character(len=1) :: cptr - character(len=1) :: dastr + character(len=*), intent(inout) :: line + ! -- local + character(len=16) :: cmem + character(len=10) :: cnalloc + character(len=5) :: cptr + character(len=5) :: dastr + integer(I4B) :: ipos + integer(I4B) :: iloc + integer(I4B) :: ival + real(DP) :: rval + ! -- formats ! - ! -- Create the msg table entry - cptr = '' - if (.not. this%master) cptr = 'T' - dastr = '' - if (this%mt_associated() .and. this%isize > 0) dastr='*' - write(msg, fmt) this%origin, this%name, this%memtype, this%isize, & - this%nrealloc, cptr, dastr + ! -- determine memory type + ipos = index(this%memtype, ' (') + if (ipos < 1) then + ipos = 16 + else + ipos = min(16,ipos-1) + end if + cmem = this%memtype(1:ipos) + ! + ! -- set reallocation string + cnalloc = '--' + if (this%nrealloc > 0) then + write(cnalloc, '(i0)') this%nrealloc + end if + ! + ! -- Set pointer and deallocation string + cptr = '--' + if (.not. this%master) then + cptr = 'TRUE' + end if + dastr = '--' + if (this%mt_associated() .and. this%isize > 0) then + dastr='FALSE' + end if + iloc = 1 + line = '' + call UWWORD(line, iloc, LENORIGIN, TABSTRING, this%origin, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, LENVARNAME, TABSTRING, this%name, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 16, TABSTRING, cmem, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 20, TABINTEGER, 'SIZE', this%isize, rval, & + ALIGNMENT=TABRIGHT, SEP=' ') + call UWWORD(line, iloc, 10, TABSTRING, cnalloc, ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 10, TABSTRING, cptr, ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 10, TABSTRING, dastr, ival, rval, & + ALIGNMENT=TABCENTER) + ! + ! -- return + return end subroutine table_entry function mt_associated(this) result(al) diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index bb33e7cee35..a3335a72463 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -2,11 +2,14 @@ module MemoryManagerModule use KindModule, only: DP, I4B, I8B use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME, LINELENGTH, & - LENMEMTYPE + LENMEMTYPE, & + TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & + TABCENTER, TABLEFT, TABRIGHT use SimVariablesModule, only: errmsg use SimModule, only: store_error, count_errors, ustop use MemoryTypeModule, only: MemoryType use MemoryListModule, only: MemoryListType + use InputOutputModule, only: UWWORD implicit none private @@ -1381,41 +1384,214 @@ subroutine mem_set_print_option(iout, keyword, errmsg) return end subroutine mem_set_print_option + subroutine summary_header(iout, linesep) + ! -- dummy + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: linesep + ! -- local + character(len=LINELENGTH) :: line + integer(I4B) :: iloc + integer(I4B) :: ival + real(DP) :: rval + ! -- formats + ! -- code + iloc = 1 + line = '' + call UWWORD(line, iloc, 20, TABSTRING, 'COMPONENT', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 20, TABSTRING, 'NCHARS', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 20, TABSTRING, 'NINTS', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 20, TABSTRING, 'NREALS', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 15, TABSTRING, 'MBYTES', ival, rval, & + ALIGNMENT=TABCENTER) + linesep = repeat('-', iloc) + write(iout, '(1x,a)') trim(linesep) + write(iout, '(1x,a)') trim(line) + write(iout, '(1x,a)') trim(linesep) + ! + ! -- return + return + end subroutine summary_header + + subroutine summary_line(iout, component, nchars, nint, nreal, bytesmb) + ! -- dummy + integer(I4B), intent(in) :: iout + character(len=*), intent(in) :: component + integer(I4B), intent(in) :: nchars + integer(I4B), intent(in) :: nint + integer(I4B), intent(in) :: nreal + real(DP), intent(in) :: bytesmb + ! -- local + character(len=LINELENGTH) :: line + integer(I4B) :: iloc + integer(I4B) :: ival + real(DP) :: rval + ! -- formats + ! -- code + iloc = 1 + line = '' + call UWWORD(line, iloc, 20, TABSTRING, component, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 20, TABINTEGER, 'NCHARS', nchars, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 20, TABINTEGER, 'NINTS', nint, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 20, TABINTEGER, 'NREALS', nreal, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 15, TABREAL, 'MBYTES', ival, bytesmb, & + ALIGNMENT=TABCENTER) + write(iout, '(1x,a)') trim(line) + ! + ! -- return + return + end subroutine summary_line + + subroutine detailed_header(iout, linesep) + ! -- dummy + integer(I4B), intent(in) :: iout + character(len=*), intent(inout) :: linesep + ! -- local + character(len=LINELENGTH) :: line + integer(I4B) :: iloc + integer(I4B) :: ival + real(DP) :: rval + ! -- formats + ! -- code + iloc = 1 + line = '' + call UWWORD(line, iloc, LENORIGIN, TABSTRING, 'ORIGIN', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, LENVARNAME, TABSTRING, 'NAME', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 16, TABSTRING, 'TYPE', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 20, TABSTRING, 'SIZE', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 10, TABSTRING, 'REALLOC.', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 10, TABSTRING, 'POINTER', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 10, TABSTRING, 'DEALLOC.', ival, rval, & + ALIGNMENT=TABCENTER) + linesep = repeat('-', iloc) + write(iout, '(1x,a)') trim(linesep) + write(iout, '(1x,a)') trim(line) + write(iout, '(1x,a)') trim(linesep) + ! + ! -- return + return + end subroutine detailed_header + + subroutine summary_total(iout, bytesmb) + ! -- dummy + integer(I4B), intent(in) :: iout + real(DP), intent(in) :: bytesmb + ! -- local + character(len=LINELENGTH) :: line + character(len=LINELENGTH) :: linesep + character(len=40) :: text + character(len=25) :: cval + integer(I4B) :: iloc + integer(I4B) :: ival + real(DP) :: rval + ! -- formats + ! -- code + ! + ! -- initialize linesep + linesep = repeat('-', 66) + ! + ! -- write initial line + write(iout, '(/1x,a,/1x,a)') & + 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE', trim(linesep) + ! + ! -- header + iloc = 1 + line = '' + call UWWORD(line, iloc, 40, TABSTRING, 'DATA TYPE', ival, rval, & + ALIGNMENT=TABCENTER, SEP=' ') + call UWWORD(line, iloc, 25, TABSTRING, 'ALLOCATED NUMBER', ival, rval, & + ALIGNMENT=TABCENTER) + write(iout, '(1x,a)') trim(line) + write(iout, '(1x,a)') trim(linesep) + + iloc = 1 + line = '' + text = 'Character' + write(cval,'(i0)') nvalues_astr + call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & + ALIGNMENT=TABRIGHT) + write(iout, '(1x,a)') trim(line) + + iloc = 1 + line = '' + text = 'Integer' + write(cval,'(i0)') nvalues_aint + call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & + ALIGNMENT=TABRIGHT) + write(iout, '(1x,a)') trim(line) + + iloc = 1 + line = '' + text = 'Real' + write(cval,'(i0)') nvalues_adbl + call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & + ALIGNMENT=TABRIGHT) + write(iout, '(1x,a)') trim(line) + + write(iout, '(1x,a)') trim(linesep) + iloc = 1 + line = '' + text = 'Total allocated memory in megabytes:' + write(cval,'(1pg25.7)') bytesmb + call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & + ALIGNMENT=TABLEFT, SEP=' ') + call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & + ALIGNMENT=TABRIGHT) + write(iout, '(1x,a)') trim(line) + ! + ! -- write final line + write(iout, '(1x,a,/)') trim(linesep) + ! + ! -- return + return + end subroutine summary_total + subroutine mem_usage(iout) - !use TableModule, only: TableType, table_cr ! -- dummy integer(I4B), intent(in) :: iout ! -- local class(MemoryType), pointer :: mt - character(len=200) :: msg + character(len=LINELENGTH) :: linesep + character(len=LINELENGTH) :: line character(len=LENORIGIN), allocatable, dimension(:) :: cunique real(DP) :: bytesmb integer(I4B) :: ipos integer(I4B) :: icomp integer(I4B) :: ilen - integer(I8B) :: nchars - integer(I8B) :: nint - integer(I8B) :: nreal + integer(I4B) :: nchars + integer(I4B) :: nint + integer(I4B) :: nreal ! -- formats - character(len=*), parameter :: fmt = "(1x, a, i0)" - character(len=*), parameter :: fmtd = "(1x, a, 1(1pg15.6))" - character(len=*), parameter :: fmttitle = "(/, 1x, a)" - character(len=*), parameter :: fmtheader = & - "(1x, a40, a20, a20, a10, a10, a10, /, 1x, 110('-'))" ! ! -- Write info to simulation list file - write(iout, fmttitle) 'INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' + write(iout, "(/,1x,a)") & + 'INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' ! - ! -- Write summary table for simulatation components + ! -- Write summary table for simulation components if (iprmem == 1) then ! - ! -- Find unique names of simulation componenets + ! -- Find unique names of simulation components call mem_unique_origins(cunique) - write(iout, '(*(G0))') ' COMPONENT ', & - ' NINTS ', & - ' NREAL ', & - ' MBYTES ' - write(iout, "(56('-'))") + call summary_header(iout, linesep) do icomp = 1, size(cunique) nchars = 0 nint = 0 @@ -1430,38 +1606,31 @@ subroutine mem_usage(iout) if (mt%memtype(1:7) == 'INTEGER') nint = nint + mt%isize if (mt%memtype(1:6) == 'DOUBLE') nreal = nreal + mt%isize enddo - bytesmb = (nchars + nint * I4B + nreal * DP) / 1000000.d0 - write(iout, '(a20, i10, i10, i10, 1pg16.2)') & - cunique(icomp), nchars, nint, nreal, bytesmb - enddo + bytesmb = (nchars + nint * I4B + nreal * DP) / 1000000_DP + call summary_line(iout, cunique(icomp), nchars, nint, nreal, bytesmb) + end do + write(iout, "(1x,a)") trim(linesep) endif ! ! -- Write table with all variables for iprmem == 2 if (iprmem == 2) then - write(iout, *) - write(iout, fmtheader) ' ORIGIN ', & - ' NAME ', & - ' TYPE ', & - ' SIZE ', & - ' NREALLOC ', & - ' POINTER ' + call detailed_header(iout, linesep) do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - call mt%table_entry(msg) - write(iout, '(a)') msg - enddo - endif + call mt%table_entry(line) + write(iout, '(1x,a)') trim(line) + end do + write(iout, "(1x,a)") trim(linesep) + end if ! ! -- Calculate and write total memory allocation bytesmb = (nvalues_astr + & nvalues_aint * I4B + & - nvalues_adbl * DP) / 1000000.d0 - write(iout, *) - write(iout, fmt) 'Number of allocated characters: ', nvalues_astr - write(iout, fmt) 'Number of allocated integer variables: ', nvalues_aint - write(iout, fmt) 'Number of allocated real variables: ', nvalues_adbl - write(iout, fmtd) 'Allocated memory in megabytes: ', bytesmb - write(iout, *) + nvalues_adbl * DP) / 1000000_DP + call summary_total(iout, bytesmb) + ! + ! -- return + return end subroutine mem_usage subroutine mem_da() From 5b9e428c638559fbd382b3a4edf149af85aea547 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Thu, 21 May 2020 17:44:31 -0400 Subject: [PATCH 05/11] refactor(MemoryManager): Add string array Remove TdisModule dependency in table object. --- src/Exchange/GwfGwfExchange.f90 | 6 ++- src/Model/GroundWaterFlow/gwf3lak8.f90 | 2 +- src/Model/GroundWaterFlow/gwf3maw8.f90 | 5 +- src/Model/GroundWaterFlow/gwf3mvr8.f90 | 4 ++ src/Model/GroundWaterFlow/gwf3sfr8.f90 | 5 +- src/Model/GroundWaterFlow/gwf3uzf8.f90 | 2 +- src/Model/ModelUtilities/BoundaryPackage.f90 | 8 ++- src/Utilities/BudgetObject.f90 | 7 ++- src/Utilities/Table.f90 | 55 +++++++++++++++----- 9 files changed, 74 insertions(+), 20 deletions(-) diff --git a/src/Exchange/GwfGwfExchange.f90 b/src/Exchange/GwfGwfExchange.f90 index 5b7857c6d00..c635cb4ef1c 100644 --- a/src/Exchange/GwfGwfExchange.f90 +++ b/src/Exchange/GwfGwfExchange.f90 @@ -838,7 +838,7 @@ subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) ! ------------------------------------------------------------------------------ ! -- modules use ConstantsModule, only: DZERO, LENBUDTXT, LENPACKAGENAME - !use TdisModule, only: kstp, kper + use TdisModule, only: kstp, kper ! -- dummy class(GwfExchangeType) :: this integer(I4B), intent(inout) :: icnvg @@ -896,6 +896,10 @@ subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) end if end if ! + ! -- set table kstp and kper + call this%outputtab1%set_kstpkper(kstp, kper) + call this%outputtab2%set_kstpkper(kstp, kper) + ! ! -- Print and write budget terms for model 1 ! ! -- Set binary unit numbers for saving flows diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index 41d5624378d..375ad8ee653 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -4343,7 +4343,7 @@ subroutine lak_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! -- Output lake flow table if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) + call this%budobj%write_flowtable(this%dis, kstp, kper) end if ! ! -- Output lake budget diff --git a/src/Model/GroundWaterFlow/gwf3maw8.f90 b/src/Model/GroundWaterFlow/gwf3maw8.f90 index 39c32e2a868..eed72c29479 100644 --- a/src/Model/GroundWaterFlow/gwf3maw8.f90 +++ b/src/Model/GroundWaterFlow/gwf3maw8.f90 @@ -2825,6 +2825,9 @@ subroutine maw_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! -- write maw head table if (ihedfl /= 0 .and. this%iprhed /= 0) then + ! + ! -- set table kstp and kper + call this%headtab%set_kstpkper(kstp, kper) ! ! -- fill stage data do n = 1, this%nmawwells @@ -2838,7 +2841,7 @@ subroutine maw_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! -- Output maw flow table if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) + call this%budobj%write_flowtable(this%dis, kstp, kper) end if ! ! -- Output maw budget diff --git a/src/Model/GroundWaterFlow/gwf3mvr8.f90 b/src/Model/GroundWaterFlow/gwf3mvr8.f90 index 5382bf46988..22f40adcd43 100644 --- a/src/Model/GroundWaterFlow/gwf3mvr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3mvr8.f90 @@ -1313,12 +1313,16 @@ subroutine mvr_print_outputtab(this) ! ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ + use TdisModule, only: kstp, kper ! -- dummy class(GwfMvrType),intent(inout) :: this ! -- local character (len=LINELENGTH) :: title integer(I4B) :: i ! ------------------------------------------------------------------------------ + ! + ! -- set table kstp and kper + call this%outputtab%set_kstpkper(kstp, kper) ! ! -- Add terms and print the table title = 'WATER MOVER PACKAGE (' // trim(this%name) // & diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index 267ed16dc97..c9961699ca4 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -2090,6 +2090,9 @@ subroutine sfr_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! -- write sfr stage and depth table if (ihedfl /= 0 .and. this%iprhed /= 0) then + ! + ! -- set table kstp and kper + call this%stagetab%set_kstpkper(kstp, kper) ! ! -- fill stage data do n = 1, this%maxbound @@ -2133,7 +2136,7 @@ subroutine sfr_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! -- Output sfr flow table if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) + call this%budobj%write_flowtable(this%dis, kstp, kper) end if ! ! -- Output sfr budget diff --git a/src/Model/GroundWaterFlow/gwf3uzf8.f90 b/src/Model/GroundWaterFlow/gwf3uzf8.f90 index 5c8319b485b..9ee681b2f48 100644 --- a/src/Model/GroundWaterFlow/gwf3uzf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3uzf8.f90 @@ -1933,7 +1933,7 @@ subroutine uzf_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! -- Output uzf flow table if (ibudfl /= 0 .and. this%iprflow /= 0) then - call this%budobj%write_flowtable(this%dis) + call this%budobj%write_flowtable(this%dis, kstp, kper) end if ! ! -- Output uzf budget diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 95b26ea3929..24500c0b552 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -550,7 +550,7 @@ subroutine bnd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only: delt + use TdisModule, only: delt, kstp, kper use ConstantsModule, only: LENBOUNDNAME, DZERO use BudgetModule, only: BudgetType ! -- dummy @@ -593,6 +593,12 @@ subroutine bnd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & imover = this%imover end if ! + ! -- set table kstp and kper + maxrows = 0 + if (ibudfl /= 0 .and. this%iprflow /= 0) then + call this%outputtab%set_kstpkper(kstp, kper) + end if + ! ! -- set maxrows maxrows = 0 if (ibudfl /= 0 .and. this%iprflow /= 0) then diff --git a/src/Utilities/BudgetObject.f90 b/src/Utilities/BudgetObject.f90 index 941fb32b777..5fe10d6d81a 100644 --- a/src/Utilities/BudgetObject.f90 +++ b/src/Utilities/BudgetObject.f90 @@ -334,7 +334,7 @@ subroutine accumulate_terms(this) return end subroutine accumulate_terms - subroutine write_flowtable(this, dis) + subroutine write_flowtable(this, dis, kstp, kper) ! ****************************************************************************** ! write_flowtable -- Write the flow table for each advanced package control ! volume @@ -346,6 +346,8 @@ subroutine write_flowtable(this, dis) ! -- dummy class(BudgetObjectType) :: this class(DisBaseType), intent(in) :: dis + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper ! -- dummy character(len=LENBUDTXT) :: flowtype character(len=20) :: cellid @@ -373,6 +375,9 @@ subroutine write_flowtable(this, dis) this%istart(j) = 1 end do ! + ! -- set table kstp and kper + call this%flowtab%set_kstpkper(kstp, kper) + ! ! -- write the table do icv = 1, this%ncv call this%flowtab%add_term(icv) diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 0c306c8663c..9545ef0674f 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -10,7 +10,7 @@ module TableModule use TableTermModule, only: TableTermType use InputOutputModule, only: UWWORD, parseline use SimModule, only: store_error, ustop - use TdisModule, only: kstp, kper + use SimVariablesModule, only: errmsg implicit none @@ -58,6 +58,7 @@ module TableModule procedure :: line_to_columns procedure :: finalize_table procedure :: set_maxbound + procedure :: set_kstpkper procedure :: set_title procedure :: set_iout procedure :: print_list_entry @@ -152,6 +153,8 @@ subroutine table_df(this, maxbound, ntableterm, iout, transient, & ! -- initialize values based on optional dummy variables if (present(transient)) then this%transient = transient + allocate(this%kstp) + allocate(this%kper) else this%transient = .FALSE. end if @@ -203,7 +206,6 @@ subroutine initialize_column(this, text, width, alignment) integer(I4B), intent(in) :: width integer(I4B), intent(in), optional :: alignment ! -- local - character (len=LINELENGTH) :: errmsg integer(I4B) :: idx integer(I4B) :: ialign ! ------------------------------------------------------------------------------ @@ -221,10 +223,11 @@ subroutine initialize_column(this, text, width, alignment) ! ! -- check that ientry is in bounds if (this%ientry > this%ntableterm) then - write(errmsg,'(4x,a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & - '****ERROR. TRYING TO ADD COLUMN "', trim(adjustl(text)), '" (', & - this%ientry, ') IN THE', trim(adjustl(this%name)), 'TABLE ("', & - trim(adjustl(this%title)), '") THAT ONLY HAS', this%ntableterm, 'COLUMNS' + write(errmsg,'(a,a,a,i0,a,1x,a,1x,a,a,a,1x,i0,1x,a)') & + 'Trying to add column "', trim(adjustl(text)), '" (', & + this%ientry, ') in the', trim(adjustl(this%name)), 'table ("', & + trim(adjustl(this%title)), '") that only has', this%ntableterm, & + 'columns.' call store_error(errmsg) call ustop() end if @@ -401,8 +404,8 @@ subroutine write_header(this) ! -- write title title = this%title if (this%transient) then - write(title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', kper - write(title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', kstp + write(title, '(a,a,i6)') trim(adjustl(title)), ' PERIOD ', this%kper + write(title, '(a,a,i8)') trim(adjustl(title)), ' STEP ', this%kstp end if if (len_trim(title) > 0) then write(this%iout, '(/,1x,a)') trim(adjustl(title)) @@ -527,6 +530,10 @@ subroutine table_da(this) deallocate(this%tableterm) ! ! -- deallocate scalars + if (this%transient) then + deallocate(this%kstp) + deallocate(this%kper) + end if deallocate(this%sep) deallocate(this%write_csv) deallocate(this%first_entry) @@ -606,15 +613,14 @@ subroutine add_error(this) ! -- dummy class(TableType) :: this ! -- local - character (len=LINELENGTH) :: errmsg ! ------------------------------------------------------------------------------ ! ! -- check that ientry is within bounds if (this%ientry > this%ntableterm) then - write(errmsg,'(4x,a,1x,i0,5(1x,a),1x,i0,1x,a)') & - '****ERROR. TRYING TO ADD DATA TO COLUMN ', this%ientry, 'IN THE', & - trim(adjustl(this%name)), 'TABLE (', trim(adjustl(this%title)), & - ') THAT ONLY HAS', this%ntableterm, 'COLUMNS' + write(errmsg,'(a,1x,i0,5(1x,a),1x,i0,1x,a)') & + 'Trying to add data to column ', this%ientry, 'in the', & + trim(adjustl(this%name)), 'table (', trim(adjustl(this%title)), & + ') that only has', this%ntableterm, 'columns.' call store_error(errmsg) call ustop() end if @@ -861,6 +867,29 @@ subroutine set_maxbound(this, maxbound) return end subroutine set_maxbound + subroutine set_kstpkper(this, kstp, kper) +! ****************************************************************************** +! set_maxbound -- reset maxbound +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), intent(in) :: kstp + integer(I4B), intent(in) :: kper + ! -- local +! ------------------------------------------------------------------------------ + ! + ! -- set maxbound + this%kstp = kstp + this%kper = kper + ! + ! -- return + return + end subroutine set_kstpkper + subroutine set_title(this, title) ! ****************************************************************************** ! set_maxbound -- reset maxbound From 9f516c584cb9881759d2fbce28ef13d5d344d4b1 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Fri, 22 May 2020 10:28:29 -0400 Subject: [PATCH 06/11] refactor(MemoryManager): Add string array Remove TdisModule dependency in table object. Use table object to print lake stages. --- autotest/test_gwf_ts_sfr01.py | 8 +- src/Exchange/GwfGwfExchange.f90 | 8 +- src/Model/GroundWaterFlow/gwf3chd8.f90 | 5 +- src/Model/GroundWaterFlow/gwf3lak8.f90 | 155 +++++++++++++------ src/Model/GroundWaterFlow/gwf3sfr8.f90 | 4 +- src/Model/GroundWaterFlow/gwf3uzf8.f90 | 4 +- src/Model/ModelUtilities/BoundaryPackage.f90 | 3 +- src/Utilities/Table.f90 | 2 +- 8 files changed, 128 insertions(+), 61 deletions(-) diff --git a/autotest/test_gwf_ts_sfr01.py b/autotest/test_gwf_ts_sfr01.py index a8cbf84c9d5..a63364da3d2 100644 --- a/autotest/test_gwf_ts_sfr01.py +++ b/autotest/test_gwf_ts_sfr01.py @@ -175,6 +175,7 @@ def build_model(ws, name, timeseries=False): budpth = '{}.{}.cbc'.format(name, paktest) cnvgpth = '{}.sfr.cnvg.csv'.format(name) sfr = flopy.mf6.ModflowGwfsfr(gwf, + print_stage=True, maximum_picard_iterations=1, auxiliary=auxnames, print_input=True, @@ -200,7 +201,9 @@ def build_model(ws, name, timeseries=False): [1 - 1, 2 - 1, (2 - 1, 5 - 1, 8 - 1), 0.0, -20, 1.0, 1.1]] perioddata = [[0, 'FLOWING_WELL', 0., 0., 0.], [0, 'RATE', 1.e-3]] - maw = flopy.mf6.ModflowGwfmaw(gwf, mover=True, nmawwells=nmawwells, + maw = flopy.mf6.ModflowGwfmaw(gwf, + print_head=True, + mover=True, nmawwells=nmawwells, packagedata=packagedata, connectiondata=connectiondata, perioddata=perioddata, pname='maw-1') @@ -318,7 +321,8 @@ def build_model(ws, name, timeseries=False): head_filerecord='{}.hds'.format(name), saverecord=[('HEAD', 'ALL'), ('BUDGET', 'ALL')], - printrecord=[('BUDGET', 'LAST')]) + printrecord=[('BUDGET', 'LAST'), + ('HEAD', 'LAST')]) return sim diff --git a/src/Exchange/GwfGwfExchange.f90 b/src/Exchange/GwfGwfExchange.f90 index c635cb4ef1c..42351af573a 100644 --- a/src/Exchange/GwfGwfExchange.f90 +++ b/src/Exchange/GwfGwfExchange.f90 @@ -878,6 +878,10 @@ subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) call this%outputtab2%set_title(packname2) end if ! + ! -- set table kstp and kper + call this%outputtab1%set_kstpkper(kstp, kper) + call this%outputtab2%set_kstpkper(kstp, kper) + ! ! -- update maxbound of tables ntabrows = 0 do i = 1, this%nexg @@ -896,10 +900,6 @@ subroutine gwf_gwf_bd(this, icnvg, isuppress_output, isolnid) end if end if ! - ! -- set table kstp and kper - call this%outputtab1%set_kstpkper(kstp, kper) - call this%outputtab2%set_kstpkper(kstp, kper) - ! ! -- Print and write budget terms for model 1 ! ! -- Set binary unit numbers for saving flows diff --git a/src/Model/GroundWaterFlow/gwf3chd8.f90 b/src/Model/GroundWaterFlow/gwf3chd8.f90 index c88e5853182..6634dc4249e 100644 --- a/src/Model/GroundWaterFlow/gwf3chd8.f90 +++ b/src/Model/GroundWaterFlow/gwf3chd8.f90 @@ -244,7 +244,7 @@ subroutine chd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ ! -- modules - use TdisModule, only: delt + use TdisModule, only: delt, kstp, kper use ConstantsModule, only: LENBOUNDNAME use BudgetModule, only: BudgetType ! -- dummy @@ -297,8 +297,9 @@ subroutine chd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & ! -- If no boundaries, skip flow calculations. if(this%nbound > 0) then ! - ! -- reset size of table + ! -- set kstp and kper and reset size of table if (this%iprflow /= 0) then + call this%outputtab%set_kstpkper(kstp, kper) call this%outputtab%set_maxbound(this%nbound) end if ! diff --git a/src/Model/GroundWaterFlow/gwf3lak8.f90 b/src/Model/GroundWaterFlow/gwf3lak8.f90 index 375ad8ee653..69c5f559def 100644 --- a/src/Model/GroundWaterFlow/gwf3lak8.f90 +++ b/src/Model/GroundWaterFlow/gwf3lak8.f90 @@ -176,7 +176,8 @@ module LakModule ! -- lake budget object type(BudgetObjectType), pointer :: budobj => null() ! - ! -- laketable objects + ! -- lake table objects + type(TableType), pointer :: stagetab => null() type(TableType), pointer :: pakcsvtab => null() ! ! -- density variables @@ -212,7 +213,6 @@ module LakModule procedure, private :: lak_read_outlets procedure, private :: lak_read_tables procedure, private :: lak_read_table - !procedure, private :: lak_check_attributes procedure, private :: lak_check_valid procedure, private :: lak_set_stressperiod procedure, private :: lak_set_attribute_error @@ -252,6 +252,9 @@ module LakModule procedure, private :: lak_linear_interpolation procedure, private :: lak_setup_budobj procedure, private :: lak_fill_budobj + ! -- table + procedure, private :: lak_setup_tableobj + ! -- density procedure :: lak_activate_density procedure, private :: lak_calculate_density_exchange end type LakType @@ -1627,6 +1630,9 @@ subroutine lak_read_dimensions(this) ! -- setup the budget object call this%lak_setup_budobj() ! + ! -- setup the stage table object + call this%lak_setup_tableobj() + ! ! -- return return end subroutine lak_read_dimensions @@ -4147,6 +4153,7 @@ subroutine lak_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & if (this%iboundpak(n) == 0) cycle hlak = this%xnewpak(n) call this%lak_calculate_vol(n, hlak, v1) + ! ! -- add budget terms for active lakes if (this%iboundpak(n) /= 0) then ! @@ -4277,7 +4284,6 @@ subroutine lak_ot(this, kstp, kper, iout, ihedfl, ibudfl) ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- - use InputOutputModule, only: UWWORD ! -- dummy class(LakType) :: this integer(I4B),intent(in) :: kstp @@ -4286,58 +4292,34 @@ subroutine lak_ot(this, kstp, kper, iout, ihedfl, ibudfl) integer(I4B),intent(in) :: ihedfl integer(I4B),intent(in) :: ibudfl ! -- locals - character(len=LINELENGTH) :: line, linesep - character(len=16) :: text integer(I4B) :: n - integer(I4B) :: iloc - real(DP) :: q - ! format - 2000 FORMAT ( 1X, ///1X, A, A, A, ' PERIOD ', I6, ' STEP ', I8) + real(DP) :: stage + real(DP) :: sa + real(DP) :: wa + real(DP) :: v + ! -- format ! -------------------------------------------------------------------------- ! ! -- write lake stage if (ihedfl /= 0 .and. this%iprhed /= 0) then - write(iout, 2000) 'LAKE (', trim(this%name), ') STAGE', kper, kstp - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, TABUCSTRING, & - 'lake', n, q, ALIGNMENT=TABLEFT) - end if - call UWWORD(line, iloc, 6, TABUCSTRING, & - 'lake', n, q, ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 11, TABUCSTRING, & - 'lake', n, q, ALIGNMENT=TABCENTER) - ! -- create line separator - linesep = repeat('-', iloc) - ! -- write first line - write(iout,'(1X,A)') linesep(1:iloc) - write(iout,'(1X,A)') line(1:iloc) - ! -- create second header line - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, TABUCSTRING, & - 'name', n, q, ALIGNMENT=TABLEFT) - end if - call UWWORD(line, iloc, 6, TABUCSTRING, & - 'no.', n, q, ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 11, TABUCSTRING, & - 'stage', n, q, ALIGNMENT=TABCENTER) - ! -- write second line - write(iout,'(1X,A)') line(1:iloc) - write(iout,'(1X,A)') linesep(1:iloc) + ! + ! -- set table kstp and kper + call this%stagetab%set_kstpkper(kstp, kper) + ! ! -- write data do n = 1, this%nlakes - iloc = 1 - line = '' - if (this%inamedbound==1) then - call UWWORD(line, iloc, 16, TABUCSTRING, & - this%lakename(n), n, q, ALIGNMENT=TABLEFT) + stage = this%xnewpak(n) + call this%lak_calculate_sarea(n, stage, sa) + call this%lak_calculate_warea(n, stage, wa) + call this%lak_calculate_vol(n, stage, v) + if(this%inamedbound==1) then + call this%stagetab%add_term(this%lakename(n)) end if - call UWWORD(line, iloc, 6, TABINTEGER, text, n, q, SEP=' ') - call UWWORD(line, iloc, 11, TABREAL, text, n, this%xnewpak(n)) - write(iout, '(1X,A)') line(1:iloc) + call this%stagetab%add_term(n) + call this%stagetab%add_term(stage) + call this%stagetab%add_term(sa) + call this%stagetab%add_term(wa) + call this%stagetab%add_term(v) end do end if ! @@ -4415,6 +4397,13 @@ subroutine lak_da(this) call mem_deallocate(this%simoutrate) endif ! + ! -- stage table + if (this%iprhed > 0) then + call this%stagetab%table_da() + deallocate(this%stagetab) + nullify(this%stagetab) + end if + ! ! -- package csv table if (this%ipakcsv > 0) then call this%pakcsvtab%table_da() @@ -6192,6 +6181,78 @@ subroutine lak_fill_budobj(this) ! -- return return end subroutine lak_fill_budobj + + subroutine lak_setup_tableobj(this) +! ****************************************************************************** +! lak_setup_tableobj -- Set up the table object that is used to write the lak +! stage data. The terms listed here must correspond in +! number and order to the ones written to the stage table +! in the lak_ot method. +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + use ConstantsModule, only: LINELENGTH, LENBUDTXT + ! -- dummy + class(LakType) :: this + ! -- local + integer(I4B) :: nterms + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text +! ------------------------------------------------------------------------------ + ! + ! -- setup stage table + if (this%iprhed > 0) then + ! + ! -- Determine the number of lake stage terms. These are fixed for + ! the simulation and cannot change. This includes FLOW-JA-FACE + ! so they can be written to the binary budget files, but these internal + ! flows are not included as part of the budget table. + nterms = 5 + if (this%inamedbound == 1) then + nterms = nterms + 1 + end if + ! + ! -- set up table title + title = trim(adjustl(this%text)) // ' PACKAGE (' // & + trim(adjustl(this%name)) //') STAGES FOR EACH CONTROL VOLUME' + ! + ! -- set up stage tableobj + call table_cr(this%stagetab, this%name, title) + call this%stagetab%table_df(this%nlakes, nterms, this%iout, & + transient=.TRUE.) + ! + ! -- Go through and set up table budget term + if (this%inamedbound == 1) then + text = 'NAME' + call this%stagetab%initialize_column(text, 20, alignment=TABLEFT) + end if + ! + ! -- lake number + text = 'NUMBER' + call this%stagetab%initialize_column(text, 10, alignment=TABCENTER) + ! + ! -- lake stage + text = 'STAGE' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- lake surface area + text = 'SURFACE AREA' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- lake wetted area + text = 'WETTED AREA' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + ! + ! -- lake volume + text = 'VOLUME' + call this%stagetab%initialize_column(text, 12, alignment=TABCENTER) + end if + ! + ! -- return + return + end subroutine lak_setup_tableobj subroutine lak_activate_density(this) ! ****************************************************************************** diff --git a/src/Model/GroundWaterFlow/gwf3sfr8.f90 b/src/Model/GroundWaterFlow/gwf3sfr8.f90 index c9961699ca4..a6b5a5ed816 100644 --- a/src/Model/GroundWaterFlow/gwf3sfr8.f90 +++ b/src/Model/GroundWaterFlow/gwf3sfr8.f90 @@ -4677,7 +4677,9 @@ subroutine sfr_setup_tableobj(this) ! so they can be written to the binary budget files, but these internal ! flows are not included as part of the budget table. nterms = 8 - if (this%inamedbound == 1) nterms = nterms + 1 + if (this%inamedbound == 1) then + nterms = nterms + 1 + end if ! ! -- set up table title title = trim(adjustl(this%text)) // ' PACKAGE (' // & diff --git a/src/Model/GroundWaterFlow/gwf3uzf8.f90 b/src/Model/GroundWaterFlow/gwf3uzf8.f90 index 9ee681b2f48..faf183e9af2 100644 --- a/src/Model/GroundWaterFlow/gwf3uzf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3uzf8.f90 @@ -1424,9 +1424,10 @@ subroutine uzf_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & qseeptomvr = DZERO qgwet = DZERO ! - ! -- set maxrows + ! -- set kstp, kper, and maxrows maxrows = 0 if (this%iprflow /= 0) then + call this%outputtab%set_kstpkper(kstp, kper) do i = 1, this%nodes node = this%nodelist(i) if (this%ibound(node) > 0) then @@ -1435,7 +1436,6 @@ subroutine uzf_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & end do call this%outputtab%set_maxbound(maxrows) end if - ! ! -- Go through and process each UZF cell do i = 1, this%nodes diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 24500c0b552..41a192cdbea 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -594,8 +594,7 @@ subroutine bnd_bd(this, x, idvfl, icbcfl, ibudfl, icbcun, iprobs, & end if ! ! -- set table kstp and kper - maxrows = 0 - if (ibudfl /= 0 .and. this%iprflow /= 0) then + if (this%iprflow /= 0) then call this%outputtab%set_kstpkper(kstp, kper) end if ! diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 9545ef0674f..15087f9a61f 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -869,7 +869,7 @@ end subroutine set_maxbound subroutine set_kstpkper(this, kstp, kper) ! ****************************************************************************** -! set_maxbound -- reset maxbound +! set_kstpkper -- reset kstp and kper ! ****************************************************************************** ! ! SPECIFICATIONS: From 8f280d642d4b8c8780a52033972010d18a3fd454 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Fri, 22 May 2020 15:25:52 -0400 Subject: [PATCH 07/11] refactor(MemoryManager): Add string array Remove TdisModule dependency in table object. Use table object to print lake stages. --- autotest/test_gwf_npf03_sfr.py | 4 +- src/Model/GroundWaterFlow/gwf3npf8.f90 | 4 +- src/Utilities/Memory/Memory.f90 | 38 +-- src/Utilities/Memory/MemoryManager.f90 | 350 +++++++++++++------------ src/Utilities/Table.f90 | 80 +++++- src/Utilities/kind.f90 | 10 + 6 files changed, 288 insertions(+), 198 deletions(-) diff --git a/autotest/test_gwf_npf03_sfr.py b/autotest/test_gwf_npf03_sfr.py index a412c8f0228..e63d24a1d7c 100644 --- a/autotest/test_gwf_npf03_sfr.py +++ b/autotest/test_gwf_npf03_sfr.py @@ -90,7 +90,9 @@ def get_model(idx, dir): # build MODFLOW 6 files ws = dir - sim = flopy.mf6.MFSimulation(sim_name=name, version='mf6', + sim = flopy.mf6.MFSimulation(sim_name=name, + memory_print_option='all', + version='mf6', exe_name='mf6', sim_ws=ws) # create tdis package diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 9ac8cfce17b..0b7f007cb98 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1047,8 +1047,8 @@ subroutine npf_da(this) ! -- Deallocate arrays call mem_deallocate(this%icelltype) call mem_deallocate(this%k11) - call mem_deallocate(this%k22, 'K22', this%origin) - call mem_deallocate(this%k33, 'K33', this%origin) + call mem_deallocate(this%k22) + call mem_deallocate(this%k33) call mem_deallocate(this%sat) call mem_deallocate(this%condsat) call mem_deallocate(this%wetdry) diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index a66334d0e6b..81158ff4c75 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -1,11 +1,11 @@ module MemoryTypeModule - use KindModule, only: DP, I4B + use KindModule, only: DP, LGP, I4B use ConstantsModule, only: LENORIGIN, LENTIMESERIESNAME, LENVARNAME, & MAXMEMRANK, LENMEMTYPE, & TABSTRING, TABINTEGER, & TABCENTER, TABLEFT, TABRIGHT - use InputOutputModule, only: UWWORD + use TableModule, only: TableType implicit none private public :: MemoryType @@ -18,7 +18,7 @@ module MemoryTypeModule integer(I4B) :: nrealloc = 0 !number of times reallocated integer(I4B) :: isize !size of the array logical :: master = .true. !master copy, others point to this one - logical, pointer :: logicalsclr => null() !pointer to the logical + logical(LGP), pointer :: logicalsclr => null() !pointer to the logical integer(I4B), pointer :: intsclr => null() !pointer to the integer real(DP), pointer :: dblsclr => null() !pointer to the double integer(I4B), dimension(:), pointer, contiguous :: aint1d => null() !pointer to 1d integer array @@ -34,19 +34,16 @@ module MemoryTypeModule contains - subroutine table_entry(this, line) + subroutine table_entry(this, memtab) ! -- dummy class(MemoryType) :: this - character(len=*), intent(inout) :: line + type(TableType), intent(inout) :: memtab ! -- local character(len=16) :: cmem character(len=10) :: cnalloc character(len=5) :: cptr character(len=5) :: dastr integer(I4B) :: ipos - integer(I4B) :: iloc - integer(I4B) :: ival - real(DP) :: rval ! -- formats ! ! -- determine memory type @@ -73,22 +70,15 @@ subroutine table_entry(this, line) if (this%mt_associated() .and. this%isize > 0) then dastr='FALSE' end if - iloc = 1 - line = '' - call UWWORD(line, iloc, LENORIGIN, TABSTRING, this%origin, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, LENVARNAME, TABSTRING, this%name, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 16, TABSTRING, cmem, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 20, TABINTEGER, 'SIZE', this%isize, rval, & - ALIGNMENT=TABRIGHT, SEP=' ') - call UWWORD(line, iloc, 10, TABSTRING, cnalloc, ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 10, TABSTRING, cptr, ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 10, TABSTRING, dastr, ival, rval, & - ALIGNMENT=TABCENTER) + ! + ! -- write data to the table + call memtab%add_term(this%origin) + call memtab%add_term(this%name) + call memtab%add_term(cmem) + call memtab%add_term(this%isize) + call memtab%add_term(cnalloc) + call memtab%add_term(cptr) + call memtab%add_term(dastr) ! ! -- return return diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index a3335a72463..d2dff1745d5 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1,6 +1,6 @@ module MemoryManagerModule - use KindModule, only: DP, I4B, I8B + use KindModule, only: DP, LGP, I4B, I8B use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME, LINELENGTH, & LENMEMTYPE, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & @@ -9,7 +9,7 @@ module MemoryManagerModule use SimModule, only: store_error, count_errors, ustop use MemoryTypeModule, only: MemoryType use MemoryListModule, only: MemoryListType - use InputOutputModule, only: UWWORD + use TableModule, only: TableType, table_cr implicit none private @@ -31,6 +31,7 @@ module MemoryManagerModule public :: copy_dbl1d type(MemoryListType) :: memorylist + type(TableType), pointer :: memtab => null() integer(I8B) :: nvalues_alogical = 0 integer(I8B) :: nvalues_achr = 0 integer(I8B) :: nvalues_astr = 0 @@ -256,7 +257,7 @@ subroutine check_varname(name) end subroutine check_varname subroutine allocate_logical(logicalsclr, name, origin) - logical, pointer, intent(inout) :: logicalsclr + logical(LGP), pointer, intent(inout) :: logicalsclr character(len=*), intent(in) :: name character(len=*), intent(in) :: origin integer(I4B) :: istat @@ -967,7 +968,7 @@ subroutine reassignptr_int1d(aint1d, name, origin, name2, origin2) end if aint1d => mt2%aint1d mt%aint1d => aint1d - mt%isize = size(aint1d) + mt%isize = 0 !size(aint1d) write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize mt%master = .false. return @@ -990,7 +991,7 @@ subroutine reassignptr_int2d(aint2d, name, origin, name2, origin2) end if aint2d => mt2%aint2d mt%aint2d => aint2d - mt%isize = size(aint2d) + mt%isize = 0 !size(aint2d) ncol = size(aint2d, dim=1) nrow = size(aint2d, dim=2) write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow @@ -1014,7 +1015,7 @@ subroutine reassignptr_dbl1d(adbl1d, name, origin, name2, origin2) end if adbl1d => mt2%adbl1d mt%adbl1d => adbl1d - mt%isize = size(adbl1d) + mt%isize = 0 !size(adbl1d) write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize mt%master = .false. return @@ -1037,7 +1038,7 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) end if adbl2d => mt2%adbl2d mt%adbl2d => adbl2d - mt%isize = size(adbl2d) + mt%isize = 0 !size(adbl2d) ncol = size(adbl2d, dim=1) nrow = size(adbl2d, dim=2) write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow @@ -1046,7 +1047,7 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) end subroutine reassignptr_dbl2d subroutine deallocate_logical(logicalsclr) - logical, pointer, intent(inout) :: logicalsclr + logical(LGP), pointer, intent(inout) :: logicalsclr class(MemoryType), pointer :: mt integer(I4B) :: ipos logical :: found @@ -1384,216 +1385,219 @@ subroutine mem_set_print_option(iout, keyword, errmsg) return end subroutine mem_set_print_option - subroutine summary_header(iout, linesep) + subroutine summary_table(iout, nrows) ! -- dummy integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: linesep + integer(I4B), intent(in) :: nrows ! -- local - character(len=LINELENGTH) :: line - integer(I4B) :: iloc - integer(I4B) :: ival - real(DP) :: rval + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: nterms ! -- formats ! -- code - iloc = 1 - line = '' - call UWWORD(line, iloc, 20, TABSTRING, 'COMPONENT', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 20, TABSTRING, 'NCHARS', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 20, TABSTRING, 'NINTS', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 20, TABSTRING, 'NREALS', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 15, TABSTRING, 'MBYTES', ival, rval, & - ALIGNMENT=TABCENTER) - linesep = repeat('-', iloc) - write(iout, '(1x,a)') trim(linesep) - write(iout, '(1x,a)') trim(line) - write(iout, '(1x,a)') trim(linesep) + nterms = 6 + ! + ! -- set up table title + title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' + ! + ! -- set up stage tableobj + call table_cr(memtab, 'MEM SUM', title) + call memtab%table_df(nrows, nterms, iout) + ! + ! -- data type + text = 'COMPONENT' + call memtab%initialize_column(text, 20, alignment=TABLEFT) + ! + ! -- number of characters + text = 'CHARACTER' + call memtab%initialize_column(text, 15, alignment=TABCENTER) + ! + ! -- number of logical + text = 'LOGICAL' + call memtab%initialize_column(text, 15, alignment=TABCENTER) + ! + ! -- number of integers + text = 'INTEGER' + call memtab%initialize_column(text, 15, alignment=TABCENTER) + ! + ! -- number of reals + text = 'REAL' + call memtab%initialize_column(text, 15, alignment=TABCENTER) + ! + ! -- number of integers + text = 'TOTAL MEGABYTES' + call memtab%initialize_column(text, 15, alignment=TABCENTER) ! ! -- return return - end subroutine summary_header + end subroutine summary_table - subroutine summary_line(iout, component, nchars, nint, nreal, bytesmb) + subroutine detailed_table(iout, nrows) ! -- dummy integer(I4B), intent(in) :: iout - character(len=*), intent(in) :: component - integer(I4B), intent(in) :: nchars - integer(I4B), intent(in) :: nint - integer(I4B), intent(in) :: nreal - real(DP), intent(in) :: bytesmb + integer(I4B), intent(in) :: nrows ! -- local - character(len=LINELENGTH) :: line - integer(I4B) :: iloc - integer(I4B) :: ival - real(DP) :: rval + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: nterms ! -- formats ! -- code - iloc = 1 - line = '' - call UWWORD(line, iloc, 20, TABSTRING, component, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 20, TABINTEGER, 'NCHARS', nchars, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 20, TABINTEGER, 'NINTS', nint, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 20, TABINTEGER, 'NREALS', nreal, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 15, TABREAL, 'MBYTES', ival, bytesmb, & - ALIGNMENT=TABCENTER) - write(iout, '(1x,a)') trim(line) + nterms = 7 + ! + ! -- set up table title + title = 'DETAILED INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' + ! + ! -- set up stage tableobj + call table_cr(memtab, 'MEM DET', title) + call memtab%table_df(nrows, nterms, iout) + ! + ! -- origin + text = 'ORIGIN' + call memtab%initialize_column(text, LENORIGIN, alignment=TABLEFT) + ! + ! -- variable + text = 'VARIABLE NAME' + call memtab%initialize_column(text, LENVARNAME, alignment=TABLEFT) + ! + ! -- data type + text = 'DATA TYPE' + call memtab%initialize_column(text, 16, alignment=TABLEFT) + ! + ! -- size + text = 'NUMBER OF ITEMS' + call memtab%initialize_column(text, 16, alignment=TABRIGHT) + ! + ! -- number oof reallocations + text = 'NUMBER OF TIMES RE- ALLOCATED' + call memtab%initialize_column(text, 10, alignment=TABCENTER) + ! + ! -- is it a point + text = 'POINTER TO ANOTHER VARIABLE' + call memtab%initialize_column(text, 10, alignment=TABCENTER) + ! + ! -- has it been deallocated + text = 'STILL ALLOCATED' + call memtab%initialize_column(text, 10, alignment=TABCENTER) ! ! -- return return - end subroutine summary_line + end subroutine detailed_table - subroutine detailed_header(iout, linesep) + subroutine summary_line(component, nchars, nlog, nint, nreal, bytesmb) ! -- dummy - integer(I4B), intent(in) :: iout - character(len=*), intent(inout) :: linesep + character(len=*), intent(in) :: component + integer(I8B), intent(in) :: nchars + integer(I8B), intent(in) :: nlog + integer(I8B), intent(in) :: nint + integer(I8B), intent(in) :: nreal + real(DP), intent(in) :: bytesmb ! -- local - character(len=LINELENGTH) :: line - integer(I4B) :: iloc - integer(I4B) :: ival - real(DP) :: rval ! -- formats ! -- code - iloc = 1 - line = '' - call UWWORD(line, iloc, LENORIGIN, TABSTRING, 'ORIGIN', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, LENVARNAME, TABSTRING, 'NAME', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 16, TABSTRING, 'TYPE', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 20, TABSTRING, 'SIZE', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 10, TABSTRING, 'REALLOC.', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 10, TABSTRING, 'POINTER', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 10, TABSTRING, 'DEALLOC.', ival, rval, & - ALIGNMENT=TABCENTER) - linesep = repeat('-', iloc) - write(iout, '(1x,a)') trim(linesep) - write(iout, '(1x,a)') trim(line) - write(iout, '(1x,a)') trim(linesep) + call memtab%add_term(component) + call memtab%add_term(nchars) + call memtab%add_term(nlog) + call memtab%add_term(nint) + call memtab%add_term(nreal) + call memtab%add_term(bytesmb) ! ! -- return return - end subroutine detailed_header + end subroutine summary_line subroutine summary_total(iout, bytesmb) ! -- dummy integer(I4B), intent(in) :: iout real(DP), intent(in) :: bytesmb ! -- local - character(len=LINELENGTH) :: line - character(len=LINELENGTH) :: linesep - character(len=40) :: text - character(len=25) :: cval - integer(I4B) :: iloc - integer(I4B) :: ival - real(DP) :: rval + character(len=LINELENGTH) :: title + character(len=LINELENGTH) :: text + integer(I4B) :: nterms + integer(I4B) :: nrows ! -- formats ! -- code + nterms = 2 + nrows = 4 ! - ! -- initialize linesep - linesep = repeat('-', 66) + ! -- set up table title + title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE' ! - ! -- write initial line - write(iout, '(/1x,a,/1x,a)') & - 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE', trim(linesep) + ! -- set up stage tableobj + call table_cr(memtab, 'MEM TOT', title) + call memtab%table_df(nrows, nterms, iout) ! - ! -- header - iloc = 1 - line = '' - call UWWORD(line, iloc, 40, TABSTRING, 'DATA TYPE', ival, rval, & - ALIGNMENT=TABCENTER, SEP=' ') - call UWWORD(line, iloc, 25, TABSTRING, 'ALLOCATED NUMBER', ival, rval, & - ALIGNMENT=TABCENTER) - write(iout, '(1x,a)') trim(line) - write(iout, '(1x,a)') trim(linesep) - - iloc = 1 - line = '' - text = 'Character' - write(cval,'(i0)') nvalues_astr - call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & - ALIGNMENT=TABRIGHT) - write(iout, '(1x,a)') trim(line) - - iloc = 1 - line = '' - text = 'Integer' - write(cval,'(i0)') nvalues_aint - call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & - ALIGNMENT=TABRIGHT) - write(iout, '(1x,a)') trim(line) - - iloc = 1 - line = '' - text = 'Real' - write(cval,'(i0)') nvalues_adbl - call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & - ALIGNMENT=TABRIGHT) - write(iout, '(1x,a)') trim(line) - - write(iout, '(1x,a)') trim(linesep) - iloc = 1 - line = '' - text = 'Total allocated memory in megabytes:' - write(cval,'(1pg25.7)') bytesmb - call UWWORD(line, iloc, 40, TABSTRING, text, ival, rval, & - ALIGNMENT=TABLEFT, SEP=' ') - call UWWORD(line, iloc, 25, TABSTRING, cval, ival, rval, & - ALIGNMENT=TABRIGHT) - write(iout, '(1x,a)') trim(line) + ! -- data type + text = 'DATA TYPE' + call memtab%initialize_column(text, 15, alignment=TABLEFT) + ! + ! -- number of values + text = 'ALLOCATED NUMBER' + call memtab%initialize_column(text, 25, alignment=TABRIGHT) + ! + ! -- write data + ! -- characters + call memtab%add_term('Character') + call memtab%add_term(nvalues_astr) + ! -- logicals + call memtab%add_term('Logical') + call memtab%add_term(nvalues_alogical) + ! -- integers + call memtab%add_term('Integer') + call memtab%add_term(nvalues_aint) + ! -- reals + call memtab%add_term('Real') + call memtab%add_term(nvalues_adbl) + ! + ! -- total memory usage + write(iout, '(1x,a,1x,g15.7,1x,a)') 'Total allocated memory:', bytesmb, 'MB' ! - ! -- write final line - write(iout, '(1x,a,/)') trim(linesep) + ! -- deallocate table + call cleanup_table() ! ! -- return return end subroutine summary_total + subroutine cleanup_table() + ! -- dummy + ! -- local + ! -- formats + ! -- code + call memtab%table_da() + deallocate(memtab) + nullify(memtab) + ! + ! -- return + return + end subroutine cleanup_table + subroutine mem_usage(iout) ! -- dummy integer(I4B), intent(in) :: iout ! -- local class(MemoryType), pointer :: mt - character(len=LINELENGTH) :: linesep - character(len=LINELENGTH) :: line character(len=LENORIGIN), allocatable, dimension(:) :: cunique real(DP) :: bytesmb integer(I4B) :: ipos integer(I4B) :: icomp integer(I4B) :: ilen - integer(I4B) :: nchars - integer(I4B) :: nint - integer(I4B) :: nreal + integer(I8B) :: nchars + integer(I8B) :: nlog + integer(I8B) :: nint + integer(I8B) :: nreal ! -- formats - ! - ! -- Write info to simulation list file - write(iout, "(/,1x,a)") & - 'INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' + ! -- code ! ! -- Write summary table for simulation components if (iprmem == 1) then ! ! -- Find unique names of simulation components call mem_unique_origins(cunique) - call summary_header(iout, linesep) + call summary_table(iout, size(cunique)) + !call summary_header(iout, linesep) do icomp = 1, size(cunique) nchars = 0 + nlog = 0 nint = 0 nreal = 0 bytesmb = DZERO @@ -1602,29 +1606,39 @@ subroutine mem_usage(iout) mt => memorylist%Get(ipos) if (cunique(icomp) /= mt%origin(1:ilen)) cycle if (.not. mt%master) cycle - if (mt%memtype(1:6) == 'STRING') nchars = nchars + mt%isize - if (mt%memtype(1:7) == 'INTEGER') nint = nint + mt%isize - if (mt%memtype(1:6) == 'DOUBLE') nreal = nreal + mt%isize - enddo - bytesmb = (nchars + nint * I4B + nreal * DP) / 1000000_DP - call summary_line(iout, cunique(icomp), nchars, nint, nreal, bytesmb) + if (mt%memtype(1:6) == 'STRING') then + nchars = nchars + mt%isize + else if (mt%memtype(1:7) == 'LOGICAL') then + nlog = nlog + mt%isize + else if (mt%memtype(1:7) == 'INTEGER') then + nint = nint + mt%isize + else if (mt%memtype(1:6) == 'DOUBLE') then + nreal = nreal + mt%isize + end if + end do + ! + ! -- calculate storage in megabytes + bytesmb = (nchars + nlog * LGP + nint * I4B + nreal * DP) / 1000000_DP + ! + ! -- write data + call summary_line(cunique(icomp), nchars, nlog, nint, nreal, bytesmb) end do - write(iout, "(1x,a)") trim(linesep) + call cleanup_table() endif ! ! -- Write table with all variables for iprmem == 2 if (iprmem == 2) then - call detailed_header(iout, linesep) + call detailed_table(iout, memorylist%count()) do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) - call mt%table_entry(line) - write(iout, '(1x,a)') trim(line) + call mt%table_entry(memtab) end do - write(iout, "(1x,a)") trim(linesep) + call cleanup_table() end if ! ! -- Calculate and write total memory allocation bytesmb = (nvalues_astr + & + nvalues_alogical * LGP + & nvalues_aint * I4B + & nvalues_adbl * DP) / 1000000_DP call summary_total(iout, bytesmb) diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 15087f9a61f..6df6b821155 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -3,7 +3,7 @@ ! an advanced package. module TableModule - use KindModule, only: I4B, DP + use KindModule, only: I4B, I8B, DP use ConstantsModule, only: LINELENGTH, LENBUDTXT, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & TABCENTER @@ -71,8 +71,9 @@ module TableModule procedure, private :: add_error procedure, private :: reset - generic, public :: add_term => add_integer, add_real, add_string - procedure, private :: add_integer, add_real, add_string + generic, public :: add_term => add_integer, add_long_integer, & + add_real, add_string + procedure, private :: add_integer, add_long_integer, add_real, add_string end type TableType @@ -699,6 +700,79 @@ subroutine add_integer(this, ival) ! -- Return return end subroutine add_integer + + subroutine add_long_integer(this, long_ival) +! ****************************************************************************** +! add_long_integer -- add long integer value to the dataline +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I8B), intent(in) :: long_ival + ! -- local + logical :: line_end + character(len=LINELENGTH) :: cval + real(DP) :: rval + integer(I4B) :: ival + integer(I4B) :: width + integer(I4B) :: alignment + integer(I4B) :: j +! ------------------------------------------------------------------------------ + ! + ! -- write header + if (this%icount == 0 .and. this%ientry == 0) then + call this%write_header() + end if + ! + ! -- update index for tableterm + this%ientry = this%ientry + 1 + ! + ! -- check that ientry is within bounds + call this%add_error() + ! + ! -- initialize local variables + j = this%ientry + width = this%tableterm(j)%get_width() + alignment = this%tableterm(j)%get_alignment() + line_end = .FALSE. + if (j == this%ntableterm) then + line_end = .TRUE. + end if + ! + ! -- add data to line + if (this%write_csv) then + if (j == 1) then + write(this%dataline, '(G0)') long_ival + else + write(this%dataline, '(a,",",G0)') trim(this%dataline), long_ival + end if + else + write(cval, '(i0)') long_ival + if (j == this%ntableterm) then + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + trim(cval), ival, rval, ALIGNMENT=alignment) + else + call UWWORD(this%dataline, this%iloc, width, TABSTRING, & + trim(cval), ival, rval, ALIGNMENT=alignment, SEP=this%sep) + end if + end if + ! + ! -- write the data line, if necessary + if (line_end) then + call this%write_line() + end if + ! + ! -- finalize the table, if necessary + if (this%allow_finalization) then + call this%finalize() + end if + ! + ! -- Return + return + end subroutine add_long_integer subroutine add_real(this, rval) ! ****************************************************************************** diff --git a/src/Utilities/kind.f90 b/src/Utilities/kind.f90 index 43d37c2e6b5..f4dbef88b79 100644 --- a/src/Utilities/kind.f90 +++ b/src/Utilities/kind.f90 @@ -5,6 +5,7 @@ module KindModule public integer, parameter :: DP = KIND(1.0D0) ! Precision of all real variables + integer, parameter :: LGP = SELECTED_INT_KIND(8) ! Logical kind integer, parameter :: I4B = SELECTED_INT_KIND(8) ! Integer kind integer, parameter :: I8B = SELECTED_INT_KIND(18) ! Long integer kind @@ -19,7 +20,9 @@ subroutine write_kindinfo(iout) ! ------------------------------------------------------------------------------ integer(I4B), intent(in) :: iout real(DP) :: rdum = 0. + integer(LGP) :: ldum = 0 integer(I4B) :: idum = 0 + integer(I8B) :: long_idum = 0 ! ------------------------------------------------------------------------------ ! write(iout, '(a)') 'Real Variables' @@ -31,6 +34,13 @@ subroutine write_kindinfo(iout) write(iout, '(2x,a,i0)') 'KIND: ', I4B write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(idum) + write(iout, '(a)') 'Long Integer Variables' + write(iout, '(2x,a,i0)') 'KIND: ', I8B + write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum) + write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(long_idum) + write(iout, '(a)') 'Logical Variables' + write(iout, '(2x,a,i0)') 'KIND: ', LGP + write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(ldum) ! ! -- Return return From 4bb82ca057c02d12a923f7892e5d8136eb10ed15 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Fri, 22 May 2020 16:52:30 -0400 Subject: [PATCH 08/11] refactor(MemoryManager): Add string array Remove TdisModule dependency in table object. Use table object to print lake stages. Add table source files ti mf5to6 converter extrafiles.txt. Add initial deferred length string to memory manager. --- src/Model/ModelUtilities/BoundaryPackage.f90 | 40 +++++++----- src/Utilities/Memory/Memory.f90 | 4 +- src/Utilities/Memory/MemoryManager.f90 | 66 +++++++++++++++++++- utils/mf5to6/pymake/extrafiles.txt | 2 + 4 files changed, 94 insertions(+), 18 deletions(-) diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 41a192cdbea..2fdc1fd3391 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -1,6 +1,6 @@ module BndModule - use KindModule, only: DP, I4B + use KindModule, only: DP, LGP, I4B use ConstantsModule, only: LENAUXNAME, LENBOUNDNAME, LENFTYPE, & DZERO, LENMODELNAME, LENPACKAGENAME, & LENORIGIN, MAXCHARLEN, LINELENGTH, & @@ -32,9 +32,10 @@ module BndModule type, extends(NumericalPackageType) :: BndType ! -- characters - character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP + !character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP + character(len=:), pointer :: listlabel => null() !title of table written for RP character(len=LENPACKAGENAME) :: text = '' - character(len=LENAUXNAME), dimension(:), pointer, & + character(len=LENAUXNAME), dimension(:), pointer, & contiguous :: auxname => null() !vector of auxname character(len=LENBOUNDNAME), dimension(:), pointer, & contiguous :: boundname => null() !vector of boundnames @@ -68,7 +69,7 @@ module BndModule type(TimeSeriesManagerType), pointer :: TsManager => null() ! time series manager type(TimeArraySeriesManagerType), pointer :: TasManager => null() ! time array series manager integer(I4B) :: indxconvertflux = 0 ! indxconvertflux is column of bound to multiply by area to convert flux to rate - logical :: AllowTimeArraySeries = .false. + logical(LGP) :: AllowTimeArraySeries = .false. ! ! -- pointers for observations integer(I4B), pointer :: inobspkg => null() ! unit number for obs package @@ -289,7 +290,7 @@ subroutine bnd_rp(this) class(BndType),intent(inout) :: this ! -- local integer(I4B) :: ierr, nlist - logical :: isfound + logical(LGP) :: isfound character(len=LINELENGTH) :: line ! -- formats character(len=*),parameter :: fmtblkerr = & @@ -421,7 +422,7 @@ subroutine bnd_cf(this, reset_mover) ! ------------------------------------------------------------------------------ ! -- modules class(BndType) :: this - logical, intent(in), optional :: reset_mover + logical(LGP), intent(in), optional :: reset_mover ! ------------------------------------------------------------------------------ ! -- bnd has no cf routine ! @@ -897,6 +898,9 @@ subroutine bnd_da(this) nullify(this%errortab) end if ! + ! -- deallocate character variables + call mem_deallocate(this%listlabel) + ! ! -- Deallocate scalars call mem_deallocate(this%ibcnum) call mem_deallocate(this%maxbound) @@ -950,6 +954,9 @@ subroutine allocate_scalars(this) ! -- allocate scalars in NumericalPackageType call this%NumericalPackageType%allocate_scalars() ! + ! -- allocate character variables + call mem_allocate(this%listlabel, LENLISTLABEL, 'LISTLABEL', this%origin) + ! ! -- allocate integer variables call mem_allocate(this%ibcnum, 'IBCNUM', this%origin) call mem_allocate(this%maxbound, 'MAXBOUND', this%origin) @@ -1157,9 +1164,9 @@ subroutine bnd_read_options(this) integer(I4B) :: n integer(I4B) :: ierr integer(I4B) :: inobs - logical :: isfound - logical :: endOfBlock - logical :: foundchildclassoption + logical(LGP) :: isfound + logical(LGP) :: endOfBlock + logical(LGP) :: foundchildclassoption ! -- format character(len=*),parameter :: fmtflow = & "(4x, 'FLOWS WILL BE SAVED TO FILE: ', a, /4x, 'OPENED ON UNIT: ', I7)" @@ -1356,8 +1363,8 @@ subroutine bnd_read_dimensions(this) class(BndType),intent(inout) :: this ! -- local character(len=LINELENGTH) :: keyword - logical :: isfound - logical :: endOfBlock + logical(LGP) :: isfound + logical(LGP) :: endOfBlock integer(I4B) :: ierr ! -- format ! ------------------------------------------------------------------------------ @@ -1442,7 +1449,7 @@ subroutine bnd_options(this, option, found) ! -- dummy class(BndType),intent(inout) :: this character(len=*), intent(inout) :: option - logical, intent(inout) :: found + logical(LGP), intent(inout) :: found ! ------------------------------------------------------------------------------ ! ! Return with found = .false. @@ -1512,7 +1519,7 @@ end subroutine define_listlabel ! -- Procedures related to observations - logical function bnd_obs_supported(this) + function bnd_obs_supported(this) result(supported) ! ************************************************************************** ! bnd_obs_supported ! -- Return true if package supports observations. Default is false. @@ -1522,9 +1529,12 @@ logical function bnd_obs_supported(this) ! ! SPECIFICATIONS: ! -------------------------------------------------------------------------- + ! -- return variable + logical(LGP) :: supported + ! -- dummy class(BndType) :: this ! -------------------------------------------------------------------------- - bnd_obs_supported = .false. + supported = .false. ! ! -- Return return @@ -1557,7 +1567,7 @@ subroutine bnd_rp_obs(this) integer(I4B) :: i, j, n class(ObserveType), pointer :: obsrv => null() character(len=LENBOUNDNAME) :: bname - logical :: jfound + logical(LGP) :: jfound ! if (.not. this%bnd_obs_supported()) return ! diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 81158ff4c75..769c2bfa433 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -17,7 +17,8 @@ module MemoryTypeModule integer(I4B) :: id !id, not used integer(I4B) :: nrealloc = 0 !number of times reallocated integer(I4B) :: isize !size of the array - logical :: master = .true. !master copy, others point to this one + logical(LGP) :: master = .true. !master copy, others point to this one + character(len=:), pointer :: strsclr => null() !deferred length string logical(LGP), pointer :: logicalsclr => null() !pointer to the logical integer(I4B), pointer :: intsclr => null() !pointer to the integer real(DP), pointer :: dblsclr => null() !pointer to the double @@ -88,6 +89,7 @@ function mt_associated(this) result(al) class(MemoryType) :: this logical :: al al = .false. + if(associated(this%strsclr)) al = .true. if(associated(this%logicalsclr)) al = .true. if(associated(this%intsclr)) al = .true. if(associated(this%dblsclr)) al = .true. diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index d2dff1745d5..5b269972cf8 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -41,7 +41,7 @@ module MemoryManagerModule interface mem_allocate module procedure allocate_logical, & - allocate_str1d, & + allocate_str, allocate_str1d, & allocate_int, allocate_int1d, allocate_int2d, & allocate_int3d, & allocate_dbl, allocate_dbl1d, allocate_dbl2d, & @@ -71,7 +71,7 @@ module MemoryManagerModule interface mem_deallocate module procedure deallocate_logical, & - deallocate_str1d, & + deallocate_str, deallocate_str1d, & deallocate_int, deallocate_int1d, deallocate_int2d, & deallocate_int3d, & deallocate_dbl, deallocate_dbl1d, deallocate_dbl2d, & @@ -276,6 +276,39 @@ subroutine allocate_logical(logicalsclr, name, origin) call memorylist%add(mt) end subroutine allocate_logical + subroutine allocate_str(strsclr, ilen, name, origin) + ! -- dummy + character(len=:), pointer, intent(inout) :: strsclr + integer(I4B), intent(in) :: ilen + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + ! -- local + character(len=ilen) :: string + integer(I4B) :: istat + type(MemoryType), pointer :: mt + ! -- format + ! -- code + call check_varname(name) + ! + ! -- initialize string + string = ' ' + ! + ! -- allocate string + allocate(character(len=ilen) :: strsclr, stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, 1) + end if + strsclr = ' ' + nvalues_astr = nvalues_astr + ilen + allocate(mt) + mt%strsclr => strsclr + mt%isize = ilen + mt%name = name + mt%origin = origin + write(mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen + call memorylist%add(mt) + end subroutine allocate_str + subroutine allocate_int(intsclr, name, origin) integer(I4B), pointer, intent(inout) :: intsclr character(len=*), intent(in) :: name @@ -1046,6 +1079,35 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) return end subroutine reassignptr_dbl2d + subroutine deallocate_str(strsclr) + character(len=:), pointer, intent(inout) :: strsclr + class(MemoryType), pointer :: mt + integer(I4B) :: ipos + logical :: found + found = .false. + do ipos = 1, memorylist%count() + mt => memorylist%Get(ipos) + !if(associated(mt%strsclr, strsclr)) then + if(associated(mt%strsclr)) then + if (mt%strsclr == strsclr) then + nullify(mt%strsclr) + found = .true. + exit + end if + endif + enddo + if (.not. found) then + call store_error('programming error in deallocate_str') + call ustop() + else + if (mt%master) then + deallocate(strsclr) + else + nullify(strsclr) + end if + endif + end subroutine deallocate_str + subroutine deallocate_logical(logicalsclr) logical(LGP), pointer, intent(inout) :: logicalsclr class(MemoryType), pointer :: mt diff --git a/utils/mf5to6/pymake/extrafiles.txt b/utils/mf5to6/pymake/extrafiles.txt index a5f14a7e5bd..8a324cbe984 100644 --- a/utils/mf5to6/pymake/extrafiles.txt +++ b/utils/mf5to6/pymake/extrafiles.txt @@ -12,3 +12,5 @@ ../../../src/Utilities/List.f90 ../../../src/Utilities/OpenSpec.f90 ../../../src/Utilities/version.f90 +../../../src/Utilities/Table.f90 +../../../src/Utilities/TableTerm.f90 From c6a3490ddaa2eb5839a77dff8733b5a8737886bf Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Sun, 24 May 2020 14:30:54 -0400 Subject: [PATCH 09/11] refactor(MemoryManager): Add string array Remove TdisModule dependency in table object. Use table object to print lake stages. Add table source files ti mf5to6 converter extrafiles.txt. Add initial deferred length string to memory manager. --- src/Model/GroundWaterFlow/gwf3csub8.f90 | 19 +- .../ModelUtilities/DiscretizationBase.f90 | 6 +- src/Utilities/ListReader.f90 | 6 +- src/Utilities/Memory/MemoryManager.f90 | 257 ++++++++++-------- 4 files changed, 169 insertions(+), 119 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index 1e20cf3fce1..1cf9c93ad6e 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -6,6 +6,7 @@ module GwfCsubModule LENFTYPE, LENPACKAGENAME, & LINELENGTH, LENBOUNDNAME, NAMEDBOUNDFLAG, & LENBUDTXT, LENAUXNAME, LENORIGIN, LENPAKLOC, & + LENLISTLABEL, & TABLEFT, TABCENTER, TABRIGHT, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL use GenericUtilitiesModule, only: is_same, sim_message @@ -51,10 +52,12 @@ module GwfCsubModule type, extends(NumericalPackageType) :: GwfCsubType character(len=LENBOUNDNAME), dimension(:), & pointer, contiguous :: boundname => null() !vector of boundnames - character(len=LENAUXNAME), dimension(:), pointer, & - contiguous :: auxname => null() !vector of auxname - character(len=500) :: listlabel = '' !title of table written for RP - character(len=LENORIGIN) :: stoname + character(len=LENAUXNAME), dimension(:), & + pointer, contiguous :: auxname => null() !vector of auxname + !character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP + !character(len=LENORIGIN) :: stoname + character(len=:), pointer :: listlabel => null() !title of table written for RP + character(len=:), pointer :: stoname => null() integer(I4B), pointer :: istounit => null() integer(I4B), pointer :: istrainib => null() integer(I4B), pointer :: istrainsk => null() @@ -339,6 +342,10 @@ subroutine csub_allocate_scalars(this) ! -- call standard NumericalPackageType allocate scalars call this%NumericalPackageType%allocate_scalars() ! + ! -- allocate character variables + call mem_allocate(this%listlabel, LENLISTLABEL, 'LISTLABEL', this%origin) + call mem_allocate(this%stoname, LENORIGIN, 'STONAME', this%origin) + ! ! -- allocate the object and assign values to object variables call mem_allocate(this%istounit, 'ISTOUNIT', this%origin) call mem_allocate(this%inobspkg, 'INOBSPKG', this%origin) @@ -2891,6 +2898,10 @@ subroutine csub_da(this) nullify(this%pakcsvtab) end if ! + ! -- deallocate character variables + call mem_deallocate(this%listlabel) + call mem_deallocate(this%stoname) + ! ! -- deallocate scalars call mem_deallocate(this%istounit) call mem_deallocate(this%inobspkg) diff --git a/src/Model/ModelUtilities/DiscretizationBase.f90 b/src/Model/ModelUtilities/DiscretizationBase.f90 index 1beac64c251..ff9f22ec953 100644 --- a/src/Model/ModelUtilities/DiscretizationBase.f90 +++ b/src/Model/ModelUtilities/DiscretizationBase.f90 @@ -1,7 +1,7 @@ module BaseDisModule use KindModule, only: DP, I4B - use ConstantsModule, only: LENMODELNAME, LENORIGIN, LINELENGTH, DZERO + use ConstantsModule, only: LENMODELNAME, LENAUXNAME, LENORIGIN, LINELENGTH, DZERO use SmoothingModule, only: sQuadraticSaturation use ConnectionsModule, only: ConnectionsType use InputOutputModule, only: URWORD, ubdsv1 @@ -1039,9 +1039,11 @@ subroutine read_list(this, in, iout, iprpak, nlist, inamedbound, & integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: nodelist real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: rlist real(DP), dimension(:,:), pointer, contiguous, intent(inout) :: auxvar - character(len=16), dimension(:), intent(inout) :: auxname + character(len=LENAUXNAME), dimension(:), intent(inout) :: auxname character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, & intent(inout) :: boundname + !character(len=:), dimension(:), pointer, contiguous, intent(inout) :: auxname + !character(len=:), dimension(:), pointer, contiguous, intent(inout) :: boundname character(len=*), intent(in) :: label character(len=*), intent(in) :: pkgName type(TimeSeriesManagerType) :: tsManager diff --git a/src/Utilities/ListReader.f90 b/src/Utilities/ListReader.f90 index c8b80426d7b..e27a11cabf1 100644 --- a/src/Utilities/ListReader.f90 +++ b/src/Utilities/ListReader.f90 @@ -3,7 +3,7 @@ module ListReaderModule use KindModule, only: DP, I4B use ConstantsModule, only: LINELENGTH, LENBOUNDNAME, LENTIMESERIESNAME, & - LENLISTLABEL, DONE + LENAUXNAME, LENLISTLABEL, DONE use SimModule, only: store_error_unit implicit none private @@ -71,9 +71,9 @@ subroutine read_list(this, in, iout, nlist, inamedbound, mshape, nodelist, & integer(I4B), dimension(:), intent(inout), contiguous, pointer :: nodelist real(DP), dimension(:, :), intent(inout), contiguous, pointer :: rlist real(DP), dimension(:, :), intent(inout), contiguous, pointer :: auxvar - character(len=16), dimension(:), intent(inout), target :: auxname + character(len=LENAUXNAME), dimension(:), intent(inout), target :: auxname character(len=LENBOUNDNAME), dimension(:), pointer, contiguous, intent(inout) :: boundname - character(len=500), intent(in) :: label + character(len=LENLISTLABEL), intent(in) :: label ! -- local ! ------------------------------------------------------------------------------ ! diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index 5b269972cf8..cb2e3992a0c 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -86,7 +86,7 @@ subroutine get_mem_type(name, origin, var_type) character(len=LENMEMTYPE), intent(out) :: var_type ! local type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found mt => null() var_type = 'UNKNOWN' @@ -103,7 +103,7 @@ subroutine get_mem_rank(name, origin, rank) integer(I4B), intent(out) :: rank ! local type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found mt => null() rank = -1 @@ -128,7 +128,7 @@ subroutine get_mem_size(name, origin, size) integer(I4B), intent(out) :: size ! local type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found mt => null() call get_from_memorylist(name, origin, mt, found) @@ -153,7 +153,7 @@ subroutine get_mem_shape(name, origin, mem_shape) integer(I4B), dimension(:), intent(out) :: mem_shape ! local type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found mt => null() call get_from_memorylist(name, origin, mt, found) @@ -180,7 +180,7 @@ subroutine get_isize(name, origin, isize) integer(I4B), intent(out) :: isize ! local type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found mt => null() call get_from_memorylist(name, origin, mt, found) @@ -195,10 +195,10 @@ subroutine get_from_memorylist(name, origin, mt, found, check) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer, intent(out) :: mt - logical,intent(out) :: found - logical, intent(in), optional :: check + logical(LGP),intent(out) :: found + logical(LGP), intent(in), optional :: check integer(I4B) :: ipos - logical check_opt + logical(LGP) check_opt mt => null() found = .false. do ipos = 1, memorylist%count() @@ -283,52 +283,40 @@ subroutine allocate_str(strsclr, ilen, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin ! -- local - character(len=ilen) :: string integer(I4B) :: istat type(MemoryType), pointer :: mt ! -- format ! -- code call check_varname(name) ! - ! -- initialize string - string = ' ' - ! ! -- allocate string allocate(character(len=ilen) :: strsclr, stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, origin, istat, 1) end if + ! + ! -- set strscl to a empty string strsclr = ' ' + ! + ! -- update string counter nvalues_astr = nvalues_astr + ilen + ! + ! -- allocate memory type allocate(mt) + ! + ! -- set memory type mt%strsclr => strsclr mt%isize = ilen mt%name = name mt%origin = origin write(mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen + ! + ! -- add deferred length string to the memory manager call memorylist%add(mt) + ! + ! -- return + return end subroutine allocate_str - - subroutine allocate_int(intsclr, name, origin) - integer(I4B), pointer, intent(inout) :: intsclr - character(len=*), intent(in) :: name - character(len=*), intent(in) :: origin - integer(I4B) :: istat - type(MemoryType), pointer :: mt - call check_varname(name) - allocate(intsclr, stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, origin, istat, 1) - end if - nvalues_aint = nvalues_aint + 1 - allocate(mt) - mt%intsclr => intsclr - mt%isize = 1 - mt%name = name - mt%origin = origin - write(mt%memtype, "(a)") 'INTEGER' - call memorylist%add(mt) - end subroutine allocate_int subroutine allocate_str1d(astr1d, ilen, nrow, name, origin) ! -- dummy variables @@ -356,7 +344,7 @@ subroutine allocate_str1d(astr1d, ilen, nrow, name, origin) ! ! -- allocate defined length string array if (isize > 0) Then - allocate(astr1d(nrow), stat=istat, errmsg=errmsg) + allocate(character(len=ilen) :: astr1d(nrow), stat=istat, errmsg=errmsg) ! ! -- check for error condition if (istat /= 0) then @@ -380,13 +368,34 @@ subroutine allocate_str1d(astr1d, ilen, nrow, name, origin) mt%origin = origin write(mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow ! - ! -- add defined length character array to the memory manager + ! -- add deferred length character array to the memory manager call memorylist%add(mt) end if ! ! -- return return end subroutine allocate_str1d + + subroutine allocate_int(intsclr, name, origin) + integer(I4B), pointer, intent(inout) :: intsclr + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin + integer(I4B) :: istat + type(MemoryType), pointer :: mt + call check_varname(name) + allocate(intsclr, stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, origin, istat, 1) + end if + nvalues_aint = nvalues_aint + 1 + allocate(mt) + mt%intsclr => intsclr + mt%isize = 1 + mt%name = name + mt%origin = origin + write(mt%memtype, "(a)") 'INTEGER' + call memorylist%add(mt) + end subroutine allocate_int subroutine allocate_int1d(aint, isize, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint @@ -566,7 +575,7 @@ subroutine reallocate_str1d(astr1d, ilen, nrow, name, origin) character(len=*), intent(in) :: origin ! -- local type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found character(len=ilen), dimension(:), allocatable :: astrtemp integer(I4B) :: istat integer(I4B) :: isize @@ -651,7 +660,7 @@ subroutine reallocate_int1d(aint, isize, name, origin) type(MemoryType), pointer :: mt integer(I4B) :: i, isizeold integer(I4B) :: ifill - logical :: found + logical(LGP) :: found ! ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) @@ -690,7 +699,7 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, origin) type(MemoryType), pointer :: mt integer(I4B), dimension(2) :: ishape integer(I4B) :: i, j, isize, isizeold - logical :: found + logical(LGP) :: found ! ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) @@ -731,7 +740,7 @@ subroutine reallocate_dbl1d(adbl, isize, name, origin) type(MemoryType), pointer :: mt integer(I4B) :: i, isizeold integer(I4B) :: ifill - logical :: found + logical(LGP) :: found ! ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) @@ -770,7 +779,7 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) type(MemoryType), pointer :: mt integer(I4B), dimension(2) :: ishape integer(I4B) :: i, j, isize, isizeold - logical :: found + logical(LGP) :: found ! ! -- Find and assign mt call get_from_memorylist(name, origin, mt, found) @@ -803,11 +812,11 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, origin) end subroutine reallocate_dbl2d subroutine setptr_logical(logicalsclr, name, origin) - logical, pointer, intent(inout) :: logicalsclr + logical(LGP), pointer, intent(inout) :: logicalsclr character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) logicalsclr => mt%logicalsclr end subroutine setptr_logical @@ -817,7 +826,7 @@ subroutine setptr_int(intsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) intsclr => mt%intsclr end subroutine setptr_int @@ -827,7 +836,7 @@ subroutine setptr_int1d(aint, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) aint => mt%aint1d end subroutine setptr_int1d @@ -837,7 +846,7 @@ subroutine setptr_int2d(aint, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) aint => mt%aint2d end subroutine setptr_int2d @@ -847,7 +856,7 @@ subroutine setptr_dbl(dblsclr, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) dblsclr => mt%dblsclr end subroutine setptr_dbl @@ -857,7 +866,7 @@ subroutine setptr_dbl1d(adbl, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) adbl => mt%adbl1d end subroutine setptr_dbl1d @@ -867,7 +876,7 @@ subroutine setptr_dbl2d(adbl, name, origin) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) adbl => mt%adbl2d end subroutine setptr_dbl2d @@ -879,7 +888,7 @@ subroutine copyptr_int1d(aint, name, origin, origin2) character(len=*), intent(in), optional :: origin2 type(MemoryType), pointer :: mt integer(I4B) :: n - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) aint => null() ! -- check the copy into the memory manager @@ -902,7 +911,7 @@ subroutine copyptr_int2d(aint, name, origin, origin2) type(MemoryType), pointer :: mt integer(I4B) :: i, j integer(I4B) :: ncol, nrow - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) aint => null() ncol = size(mt%aint2d, dim=1) @@ -928,7 +937,7 @@ subroutine copyptr_dbl1d(adbl, name, origin, origin2) character(len=*), intent(in), optional :: origin2 type(MemoryType), pointer :: mt integer(I4B) :: n - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) adbl => null() ! -- check the copy into the memory manager @@ -951,7 +960,7 @@ subroutine copyptr_dbl2d(adbl, name, origin, origin2) type(MemoryType), pointer :: mt integer(I4B) :: i, j integer(I4B) :: ncol, nrow - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) adbl => null() ncol = size(mt%adbl2d, dim=1) @@ -976,7 +985,7 @@ subroutine copy_dbl1d(adbl, name, origin) character(len=*), intent(in) :: origin type(MemoryType), pointer :: mt integer(I4B) :: n - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) do n = 1, size(mt%adbl1d) @@ -992,7 +1001,7 @@ subroutine reassignptr_int1d(aint1d, name, origin, name2, origin2) character(len=*), intent(in) :: name2 character(len=*), intent(in) :: origin2 type(MemoryType), pointer :: mt, mt2 - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) if (size(aint1d) > 0) then @@ -1015,7 +1024,7 @@ subroutine reassignptr_int2d(aint2d, name, origin, name2, origin2) character(len=*), intent(in) :: origin2 integer(I4B) :: ncol, nrow type(MemoryType), pointer :: mt, mt2 - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) if (size(aint2d) > 0) then @@ -1039,7 +1048,7 @@ subroutine reassignptr_dbl1d(adbl1d, name, origin, name2, origin2) character(len=*), intent(in) :: name2 character(len=*), intent(in) :: origin2 type(MemoryType), pointer :: mt, mt2 - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) if (size(adbl1d) > 0) then @@ -1062,7 +1071,7 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) character(len=*), intent(in) :: origin2 integer(I4B) :: ncol, nrow type(MemoryType), pointer :: mt, mt2 - logical :: found + logical(LGP) :: found call get_from_memorylist(name, origin, mt, found) call get_from_memorylist(name2, origin2, mt2, found) if (size(adbl2d) > 0) then @@ -1080,10 +1089,13 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) end subroutine reassignptr_dbl2d subroutine deallocate_str(strsclr) + ! -- dummy character(len=:), pointer, intent(inout) :: strsclr + ! -- local class(MemoryType), pointer :: mt + logical(LGP) :: found integer(I4B) :: ipos - logical :: found + ! -- code found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) @@ -1094,8 +1106,8 @@ subroutine deallocate_str(strsclr) found = .true. exit end if - endif - enddo + end if + end do if (.not. found) then call store_error('programming error in deallocate_str') call ustop() @@ -1107,12 +1119,77 @@ subroutine deallocate_str(strsclr) end if endif end subroutine deallocate_str + + subroutine deallocate_str1d(astr1d, name, origin) + ! -- dummy variables + character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d + character(len=*), optional :: name + character(len=*), optional :: origin + ! -- local variables + type(MemoryType), pointer :: mt + logical(LGP) :: found + integer(I4B) :: ipos + ! -- code + found = .false. + if (associated(astr1d)) then + if (present(name) .and. present(origin)) then + call get_from_memorylist(name, origin, mt, found, check=.FALSE.) + else + errmsg = 'Programming error. Name and origin not passed ' // & + 'to deallocate_str1d.' + call store_error(errmsg) + call ustop() + end if + if (.not. found .and. associated(astr1d)) then + errmsg = "Programming error in deallocate_str1d. Variable '" // & + trim(name) // "' from origin '" // trim(origin) // "' is not " // & + "present in the memory manager but is associated." + call store_error(errmsg) + call ustop() + else + if (found) then + if (mt%master) then + if (mt%isize > 0) then + deallocate(astr1d) + end if + else + nullify(astr1d) + end if + end if + end if + end if + ! + ! -- return + return + end subroutine deallocate_str1d + + function astr1d_equal(a, b) result(equal) + ! -- return variable + logical(LGP) :: equal + ! -- dummy + character(len=:), dimension(:), pointer, contiguous, intent(in) :: a + character(len=:), dimension(:), pointer, contiguous, intent(in) :: b + ! -- local + integer(I4B) :: n + ! -- format + ! -- code + equal = .TRUE. + do n = 1, size(a) + if (a(n) /= b(n)) then + equal = .FALSE. + exit + end if + end do + ! + ! -- return + return + end function astr1d_equal subroutine deallocate_logical(logicalsclr) logical(LGP), pointer, intent(inout) :: logicalsclr class(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) @@ -1138,7 +1215,7 @@ subroutine deallocate_int(intsclr) integer(I4B), pointer, intent(inout) :: intsclr class(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) @@ -1164,7 +1241,7 @@ subroutine deallocate_dbl(dblsclr) real(DP), pointer, intent(inout) :: dblsclr class(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found found = .false. do ipos = 1, memorylist%count() mt => memorylist%Get(ipos) @@ -1186,53 +1263,13 @@ subroutine deallocate_dbl(dblsclr) endif end subroutine deallocate_dbl - subroutine deallocate_str1d(astr1d, name, origin) - ! -- dummy variables - character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d - character(len=*), optional :: name - character(len=*), optional :: origin - ! -- local variables - type(MemoryType), pointer :: mt - logical :: found - !integer(I4B) :: ipos - ! -- code - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found, check=.FALSE.) - else - errmsg = 'Programming error. Name and origin not passed ' // & - 'to deallocate_str1d.' - call store_error(errmsg) - call ustop() - end if - if (.not. found .and. associated(astr1d)) then - errmsg = "Programming error in deallocate_str1d. Variable '" // & - trim(name) // "' from origin '" // trim(origin) // "' is not " // & - "present in the memory manager but is associated." - call store_error(errmsg) - call ustop() - else - if (found) then - if (mt%master) then - if (mt%isize > 0) then - deallocate(astr1d) - end if - else - nullify(astr1d) - end if - end if - endif - ! - ! -- return - return - end subroutine deallocate_str1d - subroutine deallocate_int1d(aint1d, name, origin) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint1d character(len=*), optional :: name character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found if (present(name) .and. present(origin)) then call get_from_memorylist(name, origin, mt, found) nullify(mt%aint1d) @@ -1265,7 +1302,7 @@ subroutine deallocate_int2d(aint2d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found if (present(name) .and. present(origin)) then call get_from_memorylist(name, origin, mt, found) nullify(mt%aint2d) @@ -1298,7 +1335,7 @@ subroutine deallocate_int3d(aint3d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found if (present(name) .and. present(origin)) then call get_from_memorylist(name, origin, mt, found) nullify(mt%aint3d) @@ -1331,7 +1368,7 @@ subroutine deallocate_dbl1d(adbl1d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found if (present(name) .and. present(origin)) then call get_from_memorylist(name, origin, mt, found) nullify(mt%adbl1d) @@ -1364,7 +1401,7 @@ subroutine deallocate_dbl2d(adbl2d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found if (present(name) .and. present(origin)) then call get_from_memorylist(name, origin, mt, found) nullify(mt%adbl2d) @@ -1397,7 +1434,7 @@ subroutine deallocate_dbl3d(adbl3d, name, origin) character(len=*), optional :: origin type(MemoryType), pointer :: mt integer(I4B) :: ipos - logical :: found + logical(LGP) :: found if (present(name) .and. present(origin)) then call get_from_memorylist(name, origin, mt, found) nullify(mt%adbl3d) @@ -1639,7 +1676,6 @@ subroutine mem_usage(iout) ! -- local class(MemoryType), pointer :: mt character(len=LENORIGIN), allocatable, dimension(:) :: cunique - real(DP) :: bytesmb integer(I4B) :: ipos integer(I4B) :: icomp integer(I4B) :: ilen @@ -1647,6 +1683,7 @@ subroutine mem_usage(iout) integer(I8B) :: nlog integer(I8B) :: nint integer(I8B) :: nreal + real(DP) :: bytesmb ! -- formats ! -- code ! From 08cdcba6df90da61abb733d20987f74784b8da5a Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Sun, 24 May 2020 14:37:01 -0400 Subject: [PATCH 10/11] refactor(MemoryManager): Add string array Remove TdisModule dependency in table object. Use table object to print lake stages. Add table source files ti mf5to6 converter extrafiles.txt. Add initial deferred length string to memory manager. Drop gfortran-4.9 for gfortran-5 in travis.yml. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index db9707647a8..51d912dc757 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,7 +16,7 @@ env: else echo $TRAVIS_PULL_REQUEST_BRANCH; fi) matrix: include: - - env: FC=gfortran-4.9 + - env: FC=gfortran-5 - env: FC=gfortran-6 - env: FC=gfortran-7 - env: FC=gfortran-8 From 84181f2d079b97d3d776093377d6532c68dae570 Mon Sep 17 00:00:00 2001 From: jdhughes-usgs Date: Wed, 27 May 2020 16:55:31 -0400 Subject: [PATCH 11/11] refactor(MemoryManager): Add specified length sting and string array Remove TdisModule dependency in table object. Use table object to print lake stages. Add table source files to mf5to6 converter extrafiles.txt. Add initial specified length string to memory manager. --- .travis.yml | 2 +- src/Model/GroundWaterFlow/gwf3csub8.f90 | 21 +- src/Model/GroundWaterFlow/gwf3npf8.f90 | 4 +- src/Model/ModelUtilities/BoundaryPackage.f90 | 5 +- src/Utilities/Memory/Memory.f90 | 21 +- src/Utilities/Memory/MemoryManager.f90 | 237 +++++++++---------- src/Utilities/Table.f90 | 48 +++- src/Utilities/kind.f90 | 23 +- 8 files changed, 191 insertions(+), 170 deletions(-) diff --git a/.travis.yml b/.travis.yml index 51d912dc757..db9707647a8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,7 +16,7 @@ env: else echo $TRAVIS_PULL_REQUEST_BRANCH; fi) matrix: include: - - env: FC=gfortran-5 + - env: FC=gfortran-4.9 - env: FC=gfortran-6 - env: FC=gfortran-7 - env: FC=gfortran-8 diff --git a/src/Model/GroundWaterFlow/gwf3csub8.f90 b/src/Model/GroundWaterFlow/gwf3csub8.f90 index 1cf9c93ad6e..ce053e1e6a6 100644 --- a/src/Model/GroundWaterFlow/gwf3csub8.f90 +++ b/src/Model/GroundWaterFlow/gwf3csub8.f90 @@ -50,14 +50,17 @@ module GwfCsubModule ! ! CSUB type type, extends(NumericalPackageType) :: GwfCsubType + ! -- characters scalars + character(len=LENLISTLABEL), pointer :: listlabel => null() !title of table written for RP + character(len=LENORIGIN), pointer :: stoname => null() + ! -- character arrays character(len=LENBOUNDNAME), dimension(:), & pointer, contiguous :: boundname => null() !vector of boundnames character(len=LENAUXNAME), dimension(:), & pointer, contiguous :: auxname => null() !vector of auxname - !character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP - !character(len=LENORIGIN) :: stoname - character(len=:), pointer :: listlabel => null() !title of table written for RP - character(len=:), pointer :: stoname => null() + ! -- logical scalars + logical, pointer :: lhead_based => null() + ! -- integer scalars integer(I4B), pointer :: istounit => null() integer(I4B), pointer :: istrainib => null() integer(I4B), pointer :: istrainsk => null() @@ -86,8 +89,8 @@ module GwfCsubModule integer(I4B), pointer :: initialized => null() integer(I4B), pointer :: ieslag => null() integer(I4B), pointer :: ipch => null() - logical, pointer :: lhead_based => null() integer(I4B), pointer :: iupdatestress => null() + ! -- real scalars real(DP), pointer :: epsilon => null() !epsilon for stress smoothing real(DP), pointer :: cc_crit => null() !convergence criteria for csub-gwf convergence check real(DP), pointer :: gammaw => null() !product of fluid density, and gravity @@ -96,11 +99,13 @@ module GwfCsubModule real(DP), pointer :: dbfact => null() real(DP), pointer :: dbfacti => null() real(DP), pointer :: satomega => null() !newton-raphson saturation omega - + ! -- integer pointer to storage package variables integer(I4B), pointer :: gwfiss => NULL() !pointer to model iss flag integer(I4B), pointer :: gwfiss0 => NULL() !iss flag for last stress period + ! -- integer arrays integer(I4B), dimension(:), pointer, contiguous :: ibound => null() !pointer to model ibound integer(I4B), dimension(:), pointer, contiguous :: stoiconv => null() !pointer to iconvert in storage + ! -- real arrays real(DP), dimension(:), pointer, contiguous :: stosc1 => null() !pointer to sc1 in storage real(DP), dimension(:), pointer, contiguous :: buff => null() !buff array real(DP), dimension(:), pointer, contiguous :: buffusr => null() !buffusr array @@ -2899,8 +2904,8 @@ subroutine csub_da(this) end if ! ! -- deallocate character variables - call mem_deallocate(this%listlabel) - call mem_deallocate(this%stoname) + call mem_deallocate(this%listlabel, 'LISTLABEL', this%origin) + call mem_deallocate(this%stoname, 'STONAME', this%origin) ! ! -- deallocate scalars call mem_deallocate(this%istounit) diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 0b7f007cb98..62013a6155e 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1047,8 +1047,8 @@ subroutine npf_da(this) ! -- Deallocate arrays call mem_deallocate(this%icelltype) call mem_deallocate(this%k11) - call mem_deallocate(this%k22) - call mem_deallocate(this%k33) + call mem_deallocate(this%k22, 'K22', trim(this%origin)) + call mem_deallocate(this%k33, 'K33', trim(this%origin)) call mem_deallocate(this%sat) call mem_deallocate(this%condsat) call mem_deallocate(this%wetdry) diff --git a/src/Model/ModelUtilities/BoundaryPackage.f90 b/src/Model/ModelUtilities/BoundaryPackage.f90 index 2fdc1fd3391..6e790516002 100644 --- a/src/Model/ModelUtilities/BoundaryPackage.f90 +++ b/src/Model/ModelUtilities/BoundaryPackage.f90 @@ -32,8 +32,7 @@ module BndModule type, extends(NumericalPackageType) :: BndType ! -- characters - !character(len=LENLISTLABEL) :: listlabel = '' !title of table written for RP - character(len=:), pointer :: listlabel => null() !title of table written for RP + character(len=LENLISTLABEL), pointer :: listlabel => null() !title of table written for RP character(len=LENPACKAGENAME) :: text = '' character(len=LENAUXNAME), dimension(:), pointer, & contiguous :: auxname => null() !vector of auxname @@ -899,7 +898,7 @@ subroutine bnd_da(this) end if ! ! -- deallocate character variables - call mem_deallocate(this%listlabel) + call mem_deallocate(this%listlabel, 'LISTLABEL', this%origin) ! ! -- Deallocate scalars call mem_deallocate(this%ibcnum) diff --git a/src/Utilities/Memory/Memory.f90 b/src/Utilities/Memory/Memory.f90 index 769c2bfa433..df4d8551c6f 100644 --- a/src/Utilities/Memory/Memory.f90 +++ b/src/Utilities/Memory/Memory.f90 @@ -12,13 +12,13 @@ module MemoryTypeModule type MemoryType character(len=LENVARNAME) :: name !name of the array + character(len=LENVARNAME) :: mastername = 'none' !name of the master array character(len=LENORIGIN) :: origin !name of origin character(len=LENMEMTYPE) :: memtype !type (INTEGER or DOUBLE) integer(I4B) :: id !id, not used integer(I4B) :: nrealloc = 0 !number of times reallocated integer(I4B) :: isize !size of the array logical(LGP) :: master = .true. !master copy, others point to this one - character(len=:), pointer :: strsclr => null() !deferred length string logical(LGP), pointer :: logicalsclr => null() !pointer to the logical integer(I4B), pointer :: intsclr => null() !pointer to the integer real(DP), pointer :: dblsclr => null() !pointer to the double @@ -41,9 +41,7 @@ subroutine table_entry(this, memtab) type(TableType), intent(inout) :: memtab ! -- local character(len=16) :: cmem - character(len=10) :: cnalloc - character(len=5) :: cptr - character(len=5) :: dastr + character(len=LENVARNAME) :: cptr integer(I4B) :: ipos ! -- formats ! @@ -56,20 +54,10 @@ subroutine table_entry(this, memtab) end if cmem = this%memtype(1:ipos) ! - ! -- set reallocation string - cnalloc = '--' - if (this%nrealloc > 0) then - write(cnalloc, '(i0)') this%nrealloc - end if - ! ! -- Set pointer and deallocation string cptr = '--' if (.not. this%master) then - cptr = 'TRUE' - end if - dastr = '--' - if (this%mt_associated() .and. this%isize > 0) then - dastr='FALSE' + cptr = this%mastername end if ! ! -- write data to the table @@ -77,9 +65,7 @@ subroutine table_entry(this, memtab) call memtab%add_term(this%name) call memtab%add_term(cmem) call memtab%add_term(this%isize) - call memtab%add_term(cnalloc) call memtab%add_term(cptr) - call memtab%add_term(dastr) ! ! -- return return @@ -89,7 +75,6 @@ function mt_associated(this) result(al) class(MemoryType) :: this logical :: al al = .false. - if(associated(this%strsclr)) al = .true. if(associated(this%logicalsclr)) al = .true. if(associated(this%intsclr)) al = .true. if(associated(this%dblsclr)) al = .true. diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index cb2e3992a0c..f1b7f50411e 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -1,8 +1,8 @@ module MemoryManagerModule use KindModule, only: DP, LGP, I4B, I8B - use ConstantsModule, only: DZERO, LENORIGIN, LENVARNAME, LINELENGTH, & - LENMEMTYPE, & + use ConstantsModule, only: DZERO, DEM6, LENORIGIN, LENVARNAME, & + LINELENGTH, LENMEMTYPE, & TABSTRING, TABUCSTRING, TABINTEGER, TABREAL, & TABCENTER, TABLEFT, TABRIGHT use SimVariablesModule, only: errmsg @@ -194,7 +194,7 @@ end subroutine get_isize subroutine get_from_memorylist(name, origin, mt, found, check) character(len=*), intent(in) :: name character(len=*), intent(in) :: origin - type(MemoryType), pointer, intent(out) :: mt + type(MemoryType), pointer, intent(inout) :: mt logical(LGP),intent(out) :: found logical(LGP), intent(in), optional :: check integer(I4B) :: ipos @@ -278,8 +278,8 @@ end subroutine allocate_logical subroutine allocate_str(strsclr, ilen, name, origin) ! -- dummy - character(len=:), pointer, intent(inout) :: strsclr integer(I4B), intent(in) :: ilen + character(len=ilen), pointer, intent(inout) :: strsclr character(len=*), intent(in) :: name character(len=*), intent(in) :: origin ! -- local @@ -287,6 +287,15 @@ subroutine allocate_str(strsclr, ilen, name, origin) type(MemoryType), pointer :: mt ! -- format ! -- code + ! + ! -- make sure ilen is greater than 0 + if (ilen < 1) then + errmsg = 'Programming error in allocate_str. ILEN must be greater than 0.' + call store_error(errmsg) + call ustop() + end if + ! + ! -- check that the varible name is not already defined call check_varname(name) ! ! -- allocate string @@ -305,7 +314,6 @@ subroutine allocate_str(strsclr, ilen, name, origin) allocate(mt) ! ! -- set memory type - mt%strsclr => strsclr mt%isize = ilen mt%name = name mt%origin = origin @@ -336,6 +344,14 @@ subroutine allocate_str1d(astr1d, ilen, nrow, name, origin) ! -- initialize string string = '' ! + ! -- make sure ilen is greater than 0 + if (ilen < 1) then + errmsg = 'Programming error in allocate_str1d. ' // & + 'ILEN must be greater than 0.' + call store_error(errmsg) + call ustop() + end if + ! ! -- check that the varible name is not already defined call check_varname(name) ! @@ -1010,9 +1026,12 @@ subroutine reassignptr_int1d(aint1d, name, origin, name2, origin2) end if aint1d => mt2%aint1d mt%aint1d => aint1d - mt%isize = 0 !size(aint1d) + mt%isize = 0 write(mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize mt%master = .false. + mt%mastername = name2 + ! + ! -- return return end subroutine reassignptr_int1d @@ -1033,11 +1052,14 @@ subroutine reassignptr_int2d(aint2d, name, origin, name2, origin2) end if aint2d => mt2%aint2d mt%aint2d => aint2d - mt%isize = 0 !size(aint2d) + mt%isize = 0 ncol = size(aint2d, dim=1) nrow = size(aint2d, dim=2) write(mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow mt%master = .false. + mt%mastername = name2 + ! + ! -- return return end subroutine reassignptr_int2d @@ -1057,9 +1079,12 @@ subroutine reassignptr_dbl1d(adbl1d, name, origin, name2, origin2) end if adbl1d => mt2%adbl1d mt%adbl1d => adbl1d - mt%isize = 0 !size(adbl1d) + mt%isize = 0 write(mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize mt%master = .false. + mt%mastername = name2 + ! + ! -- return return end subroutine reassignptr_dbl1d @@ -1080,110 +1105,62 @@ subroutine reassignptr_dbl2d(adbl2d, name, origin, name2, origin2) end if adbl2d => mt2%adbl2d mt%adbl2d => adbl2d - mt%isize = 0 !size(adbl2d) + mt%isize = 0 ncol = size(adbl2d, dim=1) nrow = size(adbl2d, dim=2) write(mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow mt%master = .false. + mt%mastername = name2 + ! + ! -- return return end subroutine reassignptr_dbl2d - subroutine deallocate_str(strsclr) + subroutine deallocate_str(strsclr, name, origin) ! -- dummy - character(len=:), pointer, intent(inout) :: strsclr + character(len=*), pointer, intent(inout) :: strsclr + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin ! -- local - class(MemoryType), pointer :: mt + type(MemoryType), pointer :: mt logical(LGP) :: found - integer(I4B) :: ipos ! -- code - found = .false. - do ipos = 1, memorylist%count() - mt => memorylist%Get(ipos) - !if(associated(mt%strsclr, strsclr)) then - if(associated(mt%strsclr)) then - if (mt%strsclr == strsclr) then - nullify(mt%strsclr) - found = .true. - exit - end if - end if - end do - if (.not. found) then - call store_error('programming error in deallocate_str') - call ustop() - else - if (mt%master) then - deallocate(strsclr) + if (associated(strsclr)) then + call get_from_memorylist(name, origin, mt, found, check=.FALSE.) + if (.not. found) then + call store_error('Programming error in deallocate_str.') + call ustop() else - nullify(strsclr) + deallocate(strsclr) end if - endif + end if end subroutine deallocate_str subroutine deallocate_str1d(astr1d, name, origin) ! -- dummy variables character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d - character(len=*), optional :: name - character(len=*), optional :: origin + character(len=*), intent(in) :: name + character(len=*), intent(in) :: origin ! -- local variables type(MemoryType), pointer :: mt logical(LGP) :: found - integer(I4B) :: ipos ! -- code - found = .false. if (associated(astr1d)) then - if (present(name) .and. present(origin)) then - call get_from_memorylist(name, origin, mt, found, check=.FALSE.) - else - errmsg = 'Programming error. Name and origin not passed ' // & - 'to deallocate_str1d.' - call store_error(errmsg) - call ustop() - end if - if (.not. found .and. associated(astr1d)) then + call get_from_memorylist(name, origin, mt, found, check=.FALSE.) + if (.not. found) then errmsg = "Programming error in deallocate_str1d. Variable '" // & trim(name) // "' from origin '" // trim(origin) // "' is not " // & "present in the memory manager but is associated." call store_error(errmsg) call ustop() else - if (found) then - if (mt%master) then - if (mt%isize > 0) then - deallocate(astr1d) - end if - else - nullify(astr1d) - end if - end if + deallocate(astr1d) end if end if ! ! -- return return end subroutine deallocate_str1d - - function astr1d_equal(a, b) result(equal) - ! -- return variable - logical(LGP) :: equal - ! -- dummy - character(len=:), dimension(:), pointer, contiguous, intent(in) :: a - character(len=:), dimension(:), pointer, contiguous, intent(in) :: b - ! -- local - integer(I4B) :: n - ! -- format - ! -- code - equal = .TRUE. - do n = 1, size(a) - if (a(n) /= b(n)) then - equal = .FALSE. - exit - end if - end do - ! - ! -- return - return - end function astr1d_equal subroutine deallocate_logical(logicalsclr) logical(LGP), pointer, intent(inout) :: logicalsclr @@ -1226,7 +1203,7 @@ subroutine deallocate_int(intsclr) endif enddo if (.not. found) then - call store_error('programming error in deallocate_int') + call store_error('Programming error in deallocate_int.') call ustop() else if (mt%master) then @@ -1252,7 +1229,7 @@ subroutine deallocate_dbl(dblsclr) endif enddo if (.not. found) then - call store_error('programming error in deallocate_dbl') + call store_error('Programming error in deallocate_dbl.') call ustop() else if (mt%master) then @@ -1497,7 +1474,8 @@ subroutine summary_table(iout, nrows) nterms = 6 ! ! -- set up table title - title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' + title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER, ' // & + 'IN MEGABYTES' ! ! -- set up stage tableobj call table_cr(memtab, 'MEM SUM', title) @@ -1507,24 +1485,24 @@ subroutine summary_table(iout, nrows) text = 'COMPONENT' call memtab%initialize_column(text, 20, alignment=TABLEFT) ! - ! -- number of characters + ! -- memory allocated for characters text = 'CHARACTER' call memtab%initialize_column(text, 15, alignment=TABCENTER) ! - ! -- number of logical + ! -- memory allocated for logical text = 'LOGICAL' call memtab%initialize_column(text, 15, alignment=TABCENTER) ! - ! -- number of integers + ! -- memory allocated for integers text = 'INTEGER' call memtab%initialize_column(text, 15, alignment=TABCENTER) ! - ! -- number of reals + ! -- memory allocated for reals text = 'REAL' call memtab%initialize_column(text, 15, alignment=TABCENTER) ! - ! -- number of integers - text = 'TOTAL MEGABYTES' + ! -- total memory allocated + text = 'TOTAL' call memtab%initialize_column(text, 15, alignment=TABCENTER) ! ! -- return @@ -1541,7 +1519,7 @@ subroutine detailed_table(iout, nrows) integer(I4B) :: nterms ! -- formats ! -- code - nterms = 7 + nterms = 5 ! ! -- set up table title title = 'DETAILED INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER' @@ -1564,40 +1542,32 @@ subroutine detailed_table(iout, nrows) ! ! -- size text = 'NUMBER OF ITEMS' - call memtab%initialize_column(text, 16, alignment=TABRIGHT) - ! - ! -- number oof reallocations - text = 'NUMBER OF TIMES RE- ALLOCATED' - call memtab%initialize_column(text, 10, alignment=TABCENTER) - ! - ! -- is it a point - text = 'POINTER TO ANOTHER VARIABLE' - call memtab%initialize_column(text, 10, alignment=TABCENTER) + call memtab%initialize_column(text, 20, alignment=TABRIGHT) ! - ! -- has it been deallocated - text = 'STILL ALLOCATED' - call memtab%initialize_column(text, 10, alignment=TABCENTER) + ! -- is it a pointer + text = 'ASSOCIATED VARIABLE' + call memtab%initialize_column(text, LENVARNAME, alignment=TABLEFT) ! ! -- return return end subroutine detailed_table - subroutine summary_line(component, nchars, nlog, nint, nreal, bytesmb) + subroutine summary_line(component, rchars, rlog, rint, rreal, bytesmb) ! -- dummy character(len=*), intent(in) :: component - integer(I8B), intent(in) :: nchars - integer(I8B), intent(in) :: nlog - integer(I8B), intent(in) :: nint - integer(I8B), intent(in) :: nreal + real(DP), intent(in) :: rchars + real(DP), intent(in) :: rlog + real(DP), intent(in) :: rint + real(DP), intent(in) :: rreal real(DP), intent(in) :: bytesmb ! -- local ! -- formats ! -- code call memtab%add_term(component) - call memtab%add_term(nchars) - call memtab%add_term(nlog) - call memtab%add_term(nint) - call memtab%add_term(nreal) + call memtab%add_term(rchars) + call memtab%add_term(rlog) + call memtab%add_term(rint) + call memtab%add_term(rreal) call memtab%add_term(bytesmb) ! ! -- return @@ -1613,13 +1583,14 @@ subroutine summary_total(iout, bytesmb) character(len=LINELENGTH) :: text integer(I4B) :: nterms integer(I4B) :: nrows + real(DP) :: smb ! -- formats ! -- code nterms = 2 - nrows = 4 + nrows = 5 ! ! -- set up table title - title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE' + title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE, IN MEGABYTES' ! ! -- set up stage tableobj call table_cr(memtab, 'MEM TOT', title) @@ -1630,25 +1601,35 @@ subroutine summary_total(iout, bytesmb) call memtab%initialize_column(text, 15, alignment=TABLEFT) ! ! -- number of values - text = 'ALLOCATED NUMBER' - call memtab%initialize_column(text, 25, alignment=TABRIGHT) + text = 'ALLOCATED MEMORY' + call memtab%initialize_column(text, 15, alignment=TABCENTER) ! ! -- write data + ! ! -- characters + smb = real(nvalues_astr, DP) * DEM6 call memtab%add_term('Character') - call memtab%add_term(nvalues_astr) + call memtab%add_term(smb) + ! ! -- logicals + smb = real(nvalues_alogical * LGP, DP) * DEM6 call memtab%add_term('Logical') - call memtab%add_term(nvalues_alogical) + call memtab%add_term(smb) + ! ! -- integers + smb = real(nvalues_aint * I4B, DP) * DEM6 call memtab%add_term('Integer') - call memtab%add_term(nvalues_aint) + call memtab%add_term(smb) + ! ! -- reals + smb = real(nvalues_adbl * DP, DP) * DEM6 call memtab%add_term('Real') - call memtab%add_term(nvalues_adbl) + call memtab%add_term(smb) ! ! -- total memory usage - write(iout, '(1x,a,1x,g15.7,1x,a)') 'Total allocated memory:', bytesmb, 'MB' + call memtab%print_separator() + call memtab%add_term('Total') + call memtab%add_term(bytesmb) ! ! -- deallocate table call cleanup_table() @@ -1668,7 +1649,8 @@ subroutine cleanup_table() ! ! -- return return - end subroutine cleanup_table + end subroutine cleanup_table + subroutine mem_usage(iout) ! -- dummy @@ -1683,6 +1665,10 @@ subroutine mem_usage(iout) integer(I8B) :: nlog integer(I8B) :: nint integer(I8B) :: nreal + real(DP) :: rchars + real(DP) :: rlog + real(DP) :: rint + real(DP) :: rreal real(DP) :: bytesmb ! -- formats ! -- code @@ -1716,11 +1702,17 @@ subroutine mem_usage(iout) end if end do ! - ! -- calculate storage in megabytes - bytesmb = (nchars + nlog * LGP + nint * I4B + nreal * DP) / 1000000_DP + ! -- calculate size of each data type + rchars = real(nchars, DP) * DEM6 + rlog = real(nlog * LGP, DP) * DEM6 + rint = real(nint * I4B, DP) * DEM6 + rreal = real(nreal * DP, DP) * DEM6 + ! + ! -- calculate total storage in megabytes + bytesmb = rchars + rlog + rint + rreal ! ! -- write data - call summary_line(cunique(icomp), nchars, nlog, nint, nreal, bytesmb) + call summary_line(cunique(icomp), rchars, rlog, rint, rreal, bytesmb) end do call cleanup_table() endif @@ -1739,7 +1731,8 @@ subroutine mem_usage(iout) bytesmb = (nvalues_astr + & nvalues_alogical * LGP + & nvalues_aint * I4B + & - nvalues_adbl * DP) / 1000000_DP + nvalues_adbl * DP) + bytesmb = real(bytesmb, DP) * DEM6 call summary_total(iout, bytesmb) ! ! -- return diff --git a/src/Utilities/Table.f90 b/src/Utilities/Table.f90 index 6df6b821155..fad9caddb32 100644 --- a/src/Utilities/Table.f90 +++ b/src/Utilities/Table.f90 @@ -62,6 +62,7 @@ module TableModule procedure :: set_title procedure :: set_iout procedure :: print_list_entry + procedure :: print_separator procedure, private :: allocate_strings procedure, private :: set_header @@ -490,16 +491,10 @@ subroutine finalize_table(this) ! -- dummy class(TableType) :: this ! -- local - integer(I4B) :: width ! ------------------------------------------------------------------------------ - ! - ! -- initialize local variables - width = this%nlinewidth ! ! -- write the final table separator - if (this%add_linesep) then - write(this%iout, '(1x,a,/)') this%linesep(1:width) - end if + call this%print_separator(iextralines=1) ! ! -- reinitialize variables call this%reset() @@ -1035,6 +1030,45 @@ subroutine print_list_entry(this, i, nodestr, q, bname) return end subroutine print_list_entry + subroutine print_separator(this, iextralines) +! ****************************************************************************** +! print_separator -- print a line separator to the table +! ****************************************************************************** +! +! SPECIFICATIONS: +! ------------------------------------------------------------------------------ + ! -- modules + ! -- dummy + class(TableType) :: this + integer(I4B), optional :: iextralines + ! -- local + integer(I4B) :: i + integer(I4B) :: iextra + integer(I4B) :: width +! ------------------------------------------------------------------------------ + ! + ! -- process optional variables + if (present(iextralines)) then + iextra = iextralines + else + iextra = 0 + end if + ! + ! -- initialize local variables + width = this%nlinewidth + ! + ! -- print line separator + if (this%add_linesep) then + write(this%iout, '(1x,a)') this%linesep(1:width) + do i = 1, iextra + write(this%iout, '(/)') + end do + end if + ! + ! -- return + return + end subroutine print_separator + subroutine reset(this) ! ****************************************************************************** ! reset -- Private method to reset table counters diff --git a/src/Utilities/kind.f90 b/src/Utilities/kind.f90 index f4dbef88b79..b898ca5ae21 100644 --- a/src/Utilities/kind.f90 +++ b/src/Utilities/kind.f90 @@ -19,28 +19,33 @@ subroutine write_kindinfo(iout) ! SPECIFICATIONS: ! ------------------------------------------------------------------------------ integer(I4B), intent(in) :: iout - real(DP) :: rdum = 0. integer(LGP) :: ldum = 0 integer(I4B) :: idum = 0 integer(I8B) :: long_idum = 0 + integer(DP) :: irdum = 0 ! for bit size of real variables + real(DP) :: rdum = 0._DP ! ------------------------------------------------------------------------------ ! - write(iout, '(a)') 'Real Variables' - write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) + write(iout, '(/a)') 'Real Variables' write(iout, '(2x,a,i0)') 'KIND: ', DP write(iout, '(2x,a,1pg15.6)') 'TINY (smallest non-zero value): ', tiny(rdum) write(iout, '(2x,a,1pg15.6)') 'HUGE (largest value): ', huge(rdum) - write(iout, '(a)') 'Integer Variables' + write(iout, '(2x,a,i0)') 'PRECISION: ', precision(rdum) + write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(irdum) + + write(iout, '(/a)') 'Integer Variables' write(iout, '(2x,a,i0)') 'KIND: ', I4B write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(idum) - write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(idum) - write(iout, '(a)') 'Long Integer Variables' + write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(idum) + + write(iout, '(/a)') 'Long Integer Variables' write(iout, '(2x,a,i0)') 'KIND: ', I8B write(iout, '(2x,a,i0)') 'HUGE (largest value): ', huge(long_idum) - write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(long_idum) - write(iout, '(a)') 'Logical Variables' + write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(long_idum) + + write(iout, '(/a)') 'Logical Variables' write(iout, '(2x,a,i0)') 'KIND: ', LGP - write(iout, '(2x,a,i0)') 'BIT_SIZE: ', bit_size(ldum) + write(iout, '(2x,a,i0)') 'BIT SIZE: ', bit_size(ldum) ! ! -- Return return