From 37f69a8ba619fddd204a4468544414499689dae0 Mon Sep 17 00:00:00 2001 From: mjreno Date: Wed, 20 Dec 2023 10:30:13 -0500 Subject: [PATCH 1/2] add mem_reset interface to the memory manager --- src/Utilities/Memory/MemoryManager.f90 | 298 +++++++++++++++++++++++++ 1 file changed, 298 insertions(+) diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index da17dabe6f4..97c24124e74 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -23,6 +23,7 @@ module MemoryManagerModule public :: mem_allocate public :: mem_checkin public :: mem_reallocate + public :: mem_reset public :: mem_setptr public :: mem_copyptr public :: mem_reassignptr @@ -85,6 +86,16 @@ module MemoryManagerModule reallocate_charstr1d end interface mem_reallocate + interface mem_reset + module procedure & + reset_int1d, & + reset_int2d, & + reset_dbl1d, & + reset_dbl2d, & + reset_str1d, & + reset_charstr1d + end interface mem_reset + interface mem_setptr module procedure & setptr_logical, & @@ -1538,6 +1549,293 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) return end subroutine reallocate_dbl2d + !> @brief Reset a 1-dimensional defined length string array + !< + subroutine reset_str1d(astr, ilen, nrow, name, mem_path) + integer(I4B), intent(in) :: ilen !< string length + integer(I4B), intent(in) :: nrow !< number of rows + character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reset string array + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + ! -- local + type(MemoryType), pointer :: mt + logical(LGP) :: found + integer(I4B) :: istat + integer(I4B) :: isize + integer(I4B) :: isize_old + integer(I4B) :: n + ! + ! -- Find and assign mt + call get_from_memorylist(name, mem_path, mt, found) + ! + ! -- reset astr1d + if (found) then + isize_old = mt%isize + ! + ! -- calculate isize + isize = nrow + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (astr) + ! + ! -- allocate astr1d + allocate (astr(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- fill the reset character array + do n = 1, nrow + astr(n) = '' + end do + ! + ! -- reset memory manager values + mt%element_size = ilen + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 ! track reset as reallocation + mt%master = .true. + nvalues_astr = nvalues_astr + isize - isize_old + write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow + else + errmsg = "Programming error, variable '"//trim(name)//"' from '"// & + trim(mem_path)//"' is not defined in the memory manager. Use "// & + "mem_allocate instead." + call store_error(errmsg, terminate=.TRUE.) + end if + ! + ! -- return + return + end subroutine reset_str1d + + !> @brief Reset a 1-dimensional deferred length string array + !< + subroutine reset_charstr1d(acharstr1d, ilen, nrow, name, mem_path) + type(CharacterStringType), dimension(:), pointer, contiguous, & + intent(inout) :: acharstr1d !< the reset charstring array + integer(I4B), intent(in) :: ilen !< string length + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + ! -- local + type(MemoryType), pointer :: mt + logical(LGP) :: found + character(len=ilen) :: string + integer(I4B) :: istat + integer(I4B) :: isize + integer(I4B) :: isize_old + integer(I4B) :: n + ! + ! -- Initialize string + string = '' + ! + ! -- Find and assign mt + call get_from_memorylist(name, mem_path, mt, found) + ! + ! -- reset astr1d + if (found) then + isize_old = mt%isize + ! + ! -- calculate isize + isize = nrow + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (acharstr1d) + ! + ! -- allocate astr1d + allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- fill the reset character array + do n = 1, nrow + acharstr1d(n) = string + end do + ! + ! -- reset memory manager values + mt%acharstr1d => acharstr1d + mt%element_size = ilen + 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, variable '"//trim(name)//"' from '"// & + trim(mem_path)//"' is not defined in the memory manager. Use "// & + "mem_allocate instead." + call store_error(errmsg, terminate=.TRUE.) + end if + ! + ! -- return + return + end subroutine reset_charstr1d + + !> @brief Reset a 1-dimensional integer array + !< + subroutine reset_int1d(aint, nrow, name, mem_path) + integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reset integer array + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + ! -- local + type(MemoryType), pointer :: mt + logical(LGP) :: found + integer(I4B) :: istat + integer(I4B) :: isize + integer(I4B) :: isizeold + ! -- code + ! + ! -- Find and assign mt + call get_from_memorylist(name, mem_path, mt, found) + ! + ! -- Allocate aint and then refill + isize = nrow + isizeold = size(mt%aint1d) + allocate (aint(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (mt%aint1d) + mt%aint1d => aint + mt%element_size = I4B + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_aint = nvalues_aint + isize - isizeold + ! + ! -- return + return + end subroutine reset_int1d + + !> @brief Reset a 2-dimensional integer array + !< + subroutine reset_int2d(aint, ncol, nrow, name, mem_path) + integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reset 2d integer array + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + ! -- local + type(MemoryType), pointer :: mt + logical(LGP) :: found + integer(I4B) :: istat + integer(I4B), dimension(2) :: ishape + integer(I4B) :: isize + integer(I4B) :: isizeold + ! -- code + ! + ! -- Find and assign mt + call get_from_memorylist(name, mem_path, mt, found) + ! + ! -- Allocate aint and then refill + ishape = shape(mt%aint2d) + isize = nrow * ncol + isizeold = ishape(1) * ishape(2) + allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (mt%aint2d) + mt%aint2d => aint + mt%element_size = I4B + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_aint = nvalues_aint + isize - isizeold + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow + ! + ! -- return + return + end subroutine reset_int2d + + !> @brief Reset a 1-dimensional real array + !< + subroutine reset_dbl1d(adbl, nrow, name, mem_path) + real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reset 1d real array + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + ! -- local + type(MemoryType), pointer :: mt + integer(I4B) :: istat + integer(I4B) :: isize + integer(I4B) :: isizeold + logical(LGP) :: found + ! -- code + ! + ! -- Find and assign mt + call get_from_memorylist(name, mem_path, mt, found) + ! + ! -- Allocate adbl and then refill + isize = nrow + isizeold = size(mt%adbl1d) + allocate (adbl(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (mt%adbl1d) + mt%adbl1d => adbl + mt%element_size = DP + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_adbl = nvalues_adbl + isize - isizeold + write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize + ! + ! -- return + return + end subroutine reset_dbl1d + + !> @brief Reset a 2-dimensional real array + !< + subroutine reset_dbl2d(adbl, ncol, nrow, name, mem_path) + real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reset 2d real array + integer(I4B), intent(in) :: ncol !< number of columns + integer(I4B), intent(in) :: nrow !< number of rows + character(len=*), intent(in) :: name !< variable name + character(len=*), intent(in) :: mem_path !< path where variable is stored + ! -- local + type(MemoryType), pointer :: mt + logical(LGP) :: found + integer(I4B) :: istat + integer(I4B), dimension(2) :: ishape + integer(I4B) :: isize + integer(I4B) :: isizeold + ! -- code + ! + ! -- Find and assign mt + call get_from_memorylist(name, mem_path, mt, found) + ! + ! -- Allocate adbl and then refill + ishape = shape(mt%adbl2d) + isize = nrow * ncol + isizeold = ishape(1) * ishape(2) + allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (mt%adbl2d) + mt%adbl2d => adbl + mt%element_size = DP + mt%isize = isize + mt%nrealloc = mt%nrealloc + 1 + mt%master = .true. + nvalues_adbl = nvalues_adbl + isize - isizeold + write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow + ! + ! -- return + return + end subroutine reset_dbl2d + !> @brief Set pointer to a logical scalar !< subroutine setptr_logical(sclr, name, mem_path) From fba5f8f1d6772dbb38b35c0f8617dec5a323634f Mon Sep 17 00:00:00 2001 From: mjreno Date: Fri, 12 Jan 2024 09:39:32 -0500 Subject: [PATCH 2/2] mem_reallocate is copy optional; remove mem_reset --- src/Model/GroundWaterFlow/gwf3disu8.f90 | 4 +- src/Model/GroundWaterFlow/gwf3npf8.f90 | 12 +- src/Model/GroundWaterTransport/gwt1dsp1.f90 | 15 +- src/Utilities/Memory/MemoryManager.f90 | 646 +++++++------------- 4 files changed, 241 insertions(+), 436 deletions(-) diff --git a/src/Model/GroundWaterFlow/gwf3disu8.f90 b/src/Model/GroundWaterFlow/gwf3disu8.f90 index e5ee2aaac74..21903aac8a1 100644 --- a/src/Model/GroundWaterFlow/gwf3disu8.f90 +++ b/src/Model/GroundWaterFlow/gwf3disu8.f90 @@ -255,8 +255,8 @@ subroutine grid_finalize(this) this%yc(noder) = this%cellxy(2, node) end do else - call mem_reallocate(this%xc, 0, 'XC', this%memoryPath) - call mem_reallocate(this%yc, 0, 'YC', this%memoryPath) + call mem_reallocate(this%xc, 0, 'XC', this%memoryPath, copy=.FALSE.) + call mem_reallocate(this%yc, 0, 'YC', this%memoryPath, copy=.FALSE.) end if ! ! -- create and fill the connections object diff --git a/src/Model/GroundWaterFlow/gwf3npf8.f90 b/src/Model/GroundWaterFlow/gwf3npf8.f90 index 0e564046049..c57c799ea7f 100644 --- a/src/Model/GroundWaterFlow/gwf3npf8.f90 +++ b/src/Model/GroundWaterFlow/gwf3npf8.f90 @@ -1696,13 +1696,17 @@ subroutine source_griddata(this) call mem_set_value(this%k22, 'K', this%input_mempath, map, afound(2)) end if if (.not. found%wetdry) call mem_reallocate(this%wetdry, 1, 'WETDRY', & - trim(this%memoryPath)) + trim(this%memoryPath), & + copy=.FALSE.) if (.not. found%angle1 .and. this%ixt3d == 0) & - call mem_reallocate(this%angle1, 0, 'ANGLE1', trim(this%memoryPath)) + call mem_reallocate(this%angle1, 0, 'ANGLE1', trim(this%memoryPath), & + copy=.FALSE.) if (.not. found%angle2 .and. this%ixt3d == 0) & - call mem_reallocate(this%angle2, 0, 'ANGLE2', trim(this%memoryPath)) + call mem_reallocate(this%angle2, 0, 'ANGLE2', trim(this%memoryPath), & + copy=.FALSE.) if (.not. found%angle3 .and. this%ixt3d == 0) & - call mem_reallocate(this%angle3, 0, 'ANGLE3', trim(this%memoryPath)) + call mem_reallocate(this%angle3, 0, 'ANGLE3', trim(this%memoryPath), & + copy=.FALSE.) ! ! -- log griddata if (this%iout > 0) then diff --git a/src/Model/GroundWaterTransport/gwt1dsp1.f90 b/src/Model/GroundWaterTransport/gwt1dsp1.f90 index 427c7701e86..208ad1debb2 100644 --- a/src/Model/GroundWaterTransport/gwt1dsp1.f90 +++ b/src/Model/GroundWaterTransport/gwt1dsp1.f90 @@ -627,7 +627,8 @@ subroutine source_griddata(this) ! ! -- reallocate diffc if not found if (.not. found%diffc) then - call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath)) + call mem_reallocate(this%diffc, 0, 'DIFFC', trim(this%memoryPath), & + copy=.FALSE.) end if ! ! -- set this%idisp flag @@ -656,11 +657,13 @@ subroutine source_griddata(this) call mem_reassignptr(this%atv, 'ATV', trim(this%memoryPath), & 'ATH2', trim(this%memoryPath)) else - call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath)) - call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath)) - call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath)) - call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath)) - call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath)) + call mem_reallocate(this%alh, 0, 'ALH', trim(this%memoryPath), copy=.FALSE.) + call mem_reallocate(this%alv, 0, 'ALV', trim(this%memoryPath), copy=.FALSE.) + call mem_reallocate(this%ath1, 0, 'ATH1', trim(this%memoryPath), & + copy=.FALSE.) + call mem_reallocate(this%ath2, 0, 'ATH2', trim(this%memoryPath), & + copy=.FALSE.) + call mem_reallocate(this%atv, 0, 'ATV', trim(this%memoryPath), copy=.FALSE.) end if ! ! -- log griddata diff --git a/src/Utilities/Memory/MemoryManager.f90 b/src/Utilities/Memory/MemoryManager.f90 index 97c24124e74..4c6af4443be 100644 --- a/src/Utilities/Memory/MemoryManager.f90 +++ b/src/Utilities/Memory/MemoryManager.f90 @@ -23,7 +23,6 @@ module MemoryManagerModule public :: mem_allocate public :: mem_checkin public :: mem_reallocate - public :: mem_reset public :: mem_setptr public :: mem_copyptr public :: mem_reassignptr @@ -86,16 +85,6 @@ module MemoryManagerModule reallocate_charstr1d end interface mem_reallocate - interface mem_reset - module procedure & - reset_int1d, & - reset_int2d, & - reset_dbl1d, & - reset_dbl2d, & - reset_str1d, & - reset_charstr1d - end interface mem_reset - interface mem_setptr module procedure & setptr_logical, & @@ -1186,15 +1175,16 @@ end subroutine checkin_charstr1d !> @brief Reallocate a 1-dimensional defined length string array !< - subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) + subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path, copy) integer(I4B), intent(in) :: ilen !< string length integer(I4B), intent(in) :: nrow !< number of rows character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reallocated string array character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy character(len=ilen), dimension(:), allocatable :: astrtemp integer(I4B) :: istat integer(I4B) :: isize @@ -1202,84 +1192,91 @@ subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path) integer(I4B) :: nrow_old integer(I4B) :: n ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! + ! -- calculate isize + isize = nrow + ! ! -- reallocate astr1d - if (found) then - isize_old = mt%isize + isize_old = mt%isize + nrow_old = 0 + if (do_copy) then if (isize_old > 0) then nrow_old = size(astr) - else - nrow_old = 0 - end if - ! - ! -- calculate isize - isize = nrow - ! - ! -- allocate astrtemp - allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - ! - ! -- copy existing values - do n = 1, nrow_old - astrtemp(n) = astr(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 - deallocate (astr) - ! - ! -- allocate astr1d - allocate (astr(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) + ! -- set error attempting to copy to smaller array + if (nrow_old > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if end if - ! - ! -- fill the reallocate character array - do n = 1, nrow - astr(n) = astrtemp(n) - end do - ! - ! -- deallocate temporary storage - deallocate (astrtemp) - ! - ! -- reset memory manager values - mt%element_size = ilen - 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, variable '"//trim(name)//"' from '"// & - trim(mem_path)//"' is not defined in the memory manager. Use "// & - "mem_allocate instead." - call store_error(errmsg, terminate=.TRUE.) end if ! + ! -- allocate astrtemp + allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- copy existing values + do n = 1, nrow_old + astrtemp(n) = astr(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 + deallocate (astr) + ! + ! -- allocate astr1d + allocate (astr(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- fill the reallocate character array + do n = 1, nrow + astr(n) = astrtemp(n) + end do + ! + ! -- deallocate temporary storage + deallocate (astrtemp) + ! + ! -- reset memory manager values + mt%element_size = ilen + 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 + ! ! -- return return end subroutine reallocate_str1d !> @brief Reallocate a 1-dimensional deferred length string array !< - subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path) + subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path, copy) type(CharacterStringType), dimension(:), pointer, contiguous, & intent(inout) :: acharstr1d !< the reallocated charstring array integer(I4B), intent(in) :: ilen !< string length integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy type(CharacterStringType), dimension(:), allocatable :: astrtemp character(len=ilen) :: string integer(I4B) :: istat @@ -1288,86 +1285,93 @@ subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path) integer(I4B) :: nrow_old integer(I4B) :: n ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Initialize string string = '' ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! + ! -- calculate isize + isize = nrow + ! ! -- reallocate astr1d - if (found) then - isize_old = mt%isize + isize_old = mt%isize + nrow_old = 0 + if (do_copy) then if (isize_old > 0) then nrow_old = size(acharstr1d) - else - nrow_old = 0 - end if - ! - ! -- calculate isize - isize = nrow - ! - ! -- allocate astrtemp - allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - ! - ! -- copy existing values - do n = 1, nrow_old - astrtemp(n) = acharstr1d(n) - end do - ! - ! -- fill new values with missing values - do n = nrow_old + 1, nrow - astrtemp(n) = string - end do - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (acharstr1d) - ! - ! -- allocate astr1d - allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) + ! -- set error attempting to copy to smaller array + if (nrow_old > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if end if - ! - ! -- fill the reallocated character array - do n = 1, nrow - acharstr1d(n) = astrtemp(n) - end do - ! - ! -- deallocate temporary storage - deallocate (astrtemp) - ! - ! -- reset memory manager values - mt%acharstr1d => acharstr1d - mt%element_size = ilen - 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, variable '"//trim(name)//"' from '"// & - trim(mem_path)//"' is not defined in the memory manager. Use "// & - "mem_allocate instead." - call store_error(errmsg, terminate=.TRUE.) end if ! + ! -- allocate astrtemp + allocate (astrtemp(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- copy existing values + do n = 1, nrow_old + astrtemp(n) = acharstr1d(n) + end do + ! + ! -- fill new values with missing values + do n = nrow_old + 1, nrow + astrtemp(n) = string + end do + ! + ! -- deallocate mt pointer, repoint, recalculate isize + deallocate (acharstr1d) + ! + ! -- allocate astr1d + allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg) + if (istat /= 0) then + call allocate_error(name, mem_path, istat, isize) + end if + ! + ! -- fill the reallocated character array + do n = 1, nrow + acharstr1d(n) = astrtemp(n) + end do + ! + ! -- deallocate temporary storage + deallocate (astrtemp) + ! + ! -- reset memory manager values + mt%acharstr1d => acharstr1d + mt%element_size = ilen + 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 + ! ! -- return return end subroutine reallocate_charstr1d !> @brief Reallocate a 1-dimensional integer array !< - subroutine reallocate_int1d(aint, nrow, name, mem_path) + subroutine reallocate_int1d(aint, nrow, name, mem_path, copy) integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy integer(I4B) :: istat integer(I4B) :: isize integer(I4B) :: i @@ -1375,17 +1379,37 @@ subroutine reallocate_int1d(aint, nrow, name, mem_path) integer(I4B) :: ifill ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! ! -- Allocate aint and then refill isize = nrow isizeold = size(mt%aint1d) - ifill = min(isizeold, isize) + ! + ifill = 0 + if (do_copy) then + if (isizeold > 0) then + ifill = isizeold + ! -- set error attempting to copy to smaller array + if (ifill > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + end if + ! allocate (aint(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if + ! do i = 1, ifill aint(i) = mt%aint1d(i) end do @@ -1405,15 +1429,16 @@ end subroutine reallocate_int1d !> @brief Reallocate a 2-dimensional integer array !< - subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) + subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path, copy) integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reallocated 2d integer array integer(I4B), intent(in) :: ncol !< number of columns integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy integer(I4B) :: istat integer(I4B), dimension(2) :: ishape integer(I4B) :: i @@ -1422,6 +1447,12 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) integer(I4B) :: isizeold ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! @@ -1429,15 +1460,28 @@ subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path) ishape = shape(mt%aint2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) + ! + if (do_copy) then + ! -- set error attempting to copy to smaller array + if (ncol < ishape(1) .or. nrow < ishape(2)) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + ! allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if - do i = 1, ishape(2) - do j = 1, ishape(1) - aint(j, i) = mt%aint2d(j, i) + ! + if (do_copy) then + do i = 1, ishape(2) + do j = 1, ishape(1) + aint(j, i) = mt%aint2d(j, i) + end do end do - end do + end if ! ! -- deallocate mt pointer, repoint, recalculate isize deallocate (mt%aint2d) @@ -1455,11 +1499,12 @@ end subroutine reallocate_int2d !> @brief Reallocate a 1-dimensional real array !< - subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) + subroutine reallocate_dbl1d(adbl, nrow, name, mem_path, copy) real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt integer(I4B) :: istat @@ -1467,20 +1512,40 @@ subroutine reallocate_dbl1d(adbl, nrow, name, mem_path) integer(I4B) :: i integer(I4B) :: isizeold integer(I4B) :: ifill - logical(LGP) :: found + logical(LGP) :: found, do_copy ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! ! -- Allocate adbl and then refill isize = nrow isizeold = size(mt%adbl1d) - ifill = min(isizeold, isize) + ! + ifill = 0 + if (do_copy) then + if (isizeold > 0) then + ifill = isizeold + ! -- set error attempting to copy to smaller array + if (ifill > isize) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) + end if + end if + end if + ! allocate (adbl(nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if + ! do i = 1, ifill adbl(i) = mt%adbl1d(i) end do @@ -1501,15 +1566,16 @@ end subroutine reallocate_dbl1d !> @brief Reallocate a 2-dimensional real array !< - subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) + subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path, copy) real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reallocated 2d real array integer(I4B), intent(in) :: ncol !< number of columns integer(I4B), intent(in) :: nrow !< number of rows character(len=*), intent(in) :: name !< variable name character(len=*), intent(in) :: mem_path !< path where variable is stored + logical(LGP), optional, intent(in) :: copy !< copy memory from old to new array ! -- local type(MemoryType), pointer :: mt - logical(LGP) :: found + logical(LGP) :: found, do_copy integer(I4B) :: istat integer(I4B), dimension(2) :: ishape integer(I4B) :: i @@ -1518,6 +1584,12 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) integer(I4B) :: isizeold ! -- code ! + ! -- initialize do_copy + do_copy = .true. + ! + ! -- override with optional argument + if (present(copy)) do_copy = copy + ! ! -- Find and assign mt call get_from_memorylist(name, mem_path, mt, found) ! @@ -1525,301 +1597,27 @@ subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path) ishape = shape(mt%adbl2d) isize = nrow * ncol isizeold = ishape(1) * ishape(2) - allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - do i = 1, ishape(2) - do j = 1, ishape(1) - adbl(j, i) = mt%adbl2d(j, i) - end do - end do - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (mt%adbl2d) - mt%adbl2d => adbl - mt%element_size = DP - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 - mt%master = .true. - nvalues_adbl = nvalues_adbl + isize - isizeold - write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow - ! - ! -- return - return - end subroutine reallocate_dbl2d - - !> @brief Reset a 1-dimensional defined length string array - !< - subroutine reset_str1d(astr, ilen, nrow, name, mem_path) - integer(I4B), intent(in) :: ilen !< string length - integer(I4B), intent(in) :: nrow !< number of rows - character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reset string array - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - ! -- local - type(MemoryType), pointer :: mt - logical(LGP) :: found - integer(I4B) :: istat - integer(I4B) :: isize - integer(I4B) :: isize_old - integer(I4B) :: n - ! - ! -- Find and assign mt - call get_from_memorylist(name, mem_path, mt, found) - ! - ! -- reset astr1d - if (found) then - isize_old = mt%isize - ! - ! -- calculate isize - isize = nrow - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (astr) - ! - ! -- allocate astr1d - allocate (astr(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - ! - ! -- fill the reset character array - do n = 1, nrow - astr(n) = '' - end do - ! - ! -- reset memory manager values - mt%element_size = ilen - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 ! track reset as reallocation - mt%master = .true. - nvalues_astr = nvalues_astr + isize - isize_old - write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow - else - errmsg = "Programming error, variable '"//trim(name)//"' from '"// & - trim(mem_path)//"' is not defined in the memory manager. Use "// & - "mem_allocate instead." - call store_error(errmsg, terminate=.TRUE.) - end if ! - ! -- return - return - end subroutine reset_str1d - - !> @brief Reset a 1-dimensional deferred length string array - !< - subroutine reset_charstr1d(acharstr1d, ilen, nrow, name, mem_path) - type(CharacterStringType), dimension(:), pointer, contiguous, & - intent(inout) :: acharstr1d !< the reset charstring array - integer(I4B), intent(in) :: ilen !< string length - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - ! -- local - type(MemoryType), pointer :: mt - logical(LGP) :: found - character(len=ilen) :: string - integer(I4B) :: istat - integer(I4B) :: isize - integer(I4B) :: isize_old - integer(I4B) :: n - ! - ! -- Initialize string - string = '' - ! - ! -- Find and assign mt - call get_from_memorylist(name, mem_path, mt, found) - ! - ! -- reset astr1d - if (found) then - isize_old = mt%isize - ! - ! -- calculate isize - isize = nrow - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (acharstr1d) - ! - ! -- allocate astr1d - allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) + if (do_copy) then + ! -- set error attempting to copy to smaller array + if (ncol < ishape(1) .or. nrow < ishape(2)) then + errmsg = "mem_reallocate for variable '"//trim(name)//"' unable "// & + "to copy existing values to reduced size array." + call store_error(errmsg, terminate=.TRUE.) end if - ! - ! -- fill the reset character array - do n = 1, nrow - acharstr1d(n) = string - end do - ! - ! -- reset memory manager values - mt%acharstr1d => acharstr1d - mt%element_size = ilen - 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, variable '"//trim(name)//"' from '"// & - trim(mem_path)//"' is not defined in the memory manager. Use "// & - "mem_allocate instead." - call store_error(errmsg, terminate=.TRUE.) - end if - ! - ! -- return - return - end subroutine reset_charstr1d - - !> @brief Reset a 1-dimensional integer array - !< - subroutine reset_int1d(aint, nrow, name, mem_path) - integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reset integer array - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - ! -- local - type(MemoryType), pointer :: mt - logical(LGP) :: found - integer(I4B) :: istat - integer(I4B) :: isize - integer(I4B) :: isizeold - ! -- code - ! - ! -- Find and assign mt - call get_from_memorylist(name, mem_path, mt, found) - ! - ! -- Allocate aint and then refill - isize = nrow - isizeold = size(mt%aint1d) - allocate (aint(nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) - end if - ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (mt%aint1d) - mt%aint1d => aint - mt%element_size = I4B - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 - mt%master = .true. - nvalues_aint = nvalues_aint + isize - isizeold - ! - ! -- return - return - end subroutine reset_int1d - - !> @brief Reset a 2-dimensional integer array - !< - subroutine reset_int2d(aint, ncol, nrow, name, mem_path) - integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reset 2d integer array - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - ! -- local - type(MemoryType), pointer :: mt - logical(LGP) :: found - integer(I4B) :: istat - integer(I4B), dimension(2) :: ishape - integer(I4B) :: isize - integer(I4B) :: isizeold - ! -- code - ! - ! -- Find and assign mt - call get_from_memorylist(name, mem_path, mt, found) - ! - ! -- Allocate aint and then refill - ishape = shape(mt%aint2d) - isize = nrow * ncol - isizeold = ishape(1) * ishape(2) - allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) end if ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (mt%aint2d) - mt%aint2d => aint - mt%element_size = I4B - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 - mt%master = .true. - nvalues_aint = nvalues_aint + isize - isizeold - write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow - ! - ! -- return - return - end subroutine reset_int2d - - !> @brief Reset a 1-dimensional real array - !< - subroutine reset_dbl1d(adbl, nrow, name, mem_path) - real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reset 1d real array - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - ! -- local - type(MemoryType), pointer :: mt - integer(I4B) :: istat - integer(I4B) :: isize - integer(I4B) :: isizeold - logical(LGP) :: found - ! -- code - ! - ! -- Find and assign mt - call get_from_memorylist(name, mem_path, mt, found) - ! - ! -- Allocate adbl and then refill - isize = nrow - isizeold = size(mt%adbl1d) - allocate (adbl(nrow), stat=istat, errmsg=errmsg) + allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) if (istat /= 0) then call allocate_error(name, mem_path, istat, isize) end if ! - ! -- deallocate mt pointer, repoint, recalculate isize - deallocate (mt%adbl1d) - mt%adbl1d => adbl - mt%element_size = DP - mt%isize = isize - mt%nrealloc = mt%nrealloc + 1 - mt%master = .true. - nvalues_adbl = nvalues_adbl + isize - isizeold - write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize - ! - ! -- return - return - end subroutine reset_dbl1d - - !> @brief Reset a 2-dimensional real array - !< - subroutine reset_dbl2d(adbl, ncol, nrow, name, mem_path) - real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reset 2d real array - integer(I4B), intent(in) :: ncol !< number of columns - integer(I4B), intent(in) :: nrow !< number of rows - character(len=*), intent(in) :: name !< variable name - character(len=*), intent(in) :: mem_path !< path where variable is stored - ! -- local - type(MemoryType), pointer :: mt - logical(LGP) :: found - integer(I4B) :: istat - integer(I4B), dimension(2) :: ishape - integer(I4B) :: isize - integer(I4B) :: isizeold - ! -- code - ! - ! -- Find and assign mt - call get_from_memorylist(name, mem_path, mt, found) - ! - ! -- Allocate adbl and then refill - ishape = shape(mt%adbl2d) - isize = nrow * ncol - isizeold = ishape(1) * ishape(2) - allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg) - if (istat /= 0) then - call allocate_error(name, mem_path, istat, isize) + if (do_copy) then + do i = 1, ishape(2) + do j = 1, ishape(1) + adbl(j, i) = mt%adbl2d(j, i) + end do + end do end if ! ! -- deallocate mt pointer, repoint, recalculate isize @@ -1834,7 +1632,7 @@ subroutine reset_dbl2d(adbl, ncol, nrow, name, mem_path) ! ! -- return return - end subroutine reset_dbl2d + end subroutine reallocate_dbl2d !> @brief Set pointer to a logical scalar !<