From 632aff37048fc4b06a45dc9440b65773d24bb96e Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Tue, 31 Mar 2026 16:36:52 +0200 Subject: [PATCH 1/7] refactor malloc (cherry pick from fm/task/UNST-9773_meteo_reader) --- .../f90tw/f90tw-main/f90tw/CMakeLists.txt | 3 +- .../deltares_common/gtest/test_malloc.f90 | 142 + .../packages/deltares_common/CMakeLists.txt | 13 +- .../packages/deltares_common/src/malloc.f90 | 4364 +++-------------- .../src/malloc_includes/malloc_body.inc | 61 + 5 files changed, 786 insertions(+), 3797 deletions(-) create mode 100644 src/utils_lgpl/deltares_common/gtest/test_malloc.f90 create mode 100644 src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc diff --git a/src/third_party_open/f90tw/f90tw-main/f90tw/CMakeLists.txt b/src/third_party_open/f90tw/f90tw-main/f90tw/CMakeLists.txt index 48366d179c1..f17dba25652 100644 --- a/src/third_party_open/f90tw/f90tw-main/f90tw/CMakeLists.txt +++ b/src/third_party_open/f90tw/f90tw-main/f90tw/CMakeLists.txt @@ -69,9 +69,10 @@ function(F90TWF2H INFILES OUTFILE) if(WIN32) find_program(POWERSHELL_EXE NAMES "powershell.exe" REQUIRED) + string(REPLACE ";" "," F2H_INFILES_PS "${F2H_INFILES}") add_custom_command( OUTPUT ${F2H_OUTFILE} - COMMAND ${POWERSHELL_EXE} -Command " \" ( ( cat ${F2H_INFILES} ) | select-string -pattern '^[ \\t]*[!cC][\\$$][fF]90[tT][wW]' ) -replace '^[ \\t]*[!cC][\\$$][fF]90[tT][wW][ \\t]*', '' | Set-Content -Path ${F2H_OUTFILE} \" " + COMMAND ${POWERSHELL_EXE} -Command " \" ( ( cat ${F2H_INFILES_PS} ) | select-string -pattern '^[ \\t]*[!cC][\\$$][fF]90[tT][wW]' ) -replace '^[ \\t]*[!cC][\\$$][fF]90[tT][wW][ \\t]*', '' | Set-Content -Path ${F2H_OUTFILE} \" " DEPENDS ${F2H_INFILES} COMMENT "process ${F2H_INFILES}" ) diff --git a/src/utils_lgpl/deltares_common/gtest/test_malloc.f90 b/src/utils_lgpl/deltares_common/gtest/test_malloc.f90 new file mode 100644 index 00000000000..5c2dd9dae69 --- /dev/null +++ b/src/utils_lgpl/deltares_common/gtest/test_malloc.f90 @@ -0,0 +1,142 @@ +module test_malloc + use assertions_gtest + use m_alloc + use precision, only: sp, dp + use ISO_C_BINDING + + implicit none(type, external) + +contains + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_unallocated_with_fill, test_realloc_unallocated_with_fill, + !> Realloc on unallocated array should allocate and apply fill + subroutine test_realloc_unallocated_with_fill() bind(C) + real(dp), allocatable :: arr(:) + call realloc(arr, 5, fill=-999.0d0) + call f90_expect_true(allocated(arr)) + call f90_expect_eq(size(arr), 5) + call f90_expect_true(all(arr == -999.0d0)) + end subroutine test_realloc_unallocated_with_fill + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_grow_keeps_existing, test_realloc_grow_keeps_existing, + !> Growing an array preserves existing data and fills new elements + subroutine test_realloc_grow_keeps_existing() bind(C) + real(dp), allocatable :: arr(:) + call realloc(arr, 3, fill=0.0d0) + arr(1) = 1.0d0; arr(2) = 2.0d0; arr(3) = 3.0d0 + call realloc(arr, 5, fill=-1.0d0, keepExisting=.true.) + call f90_expect_eq(size(arr), 5) + call f90_expect_true(arr(1) == 1.0d0 .and. arr(2) == 2.0d0 .and. arr(3) == 3.0d0) + call f90_expect_true(arr(4) == -1.0d0 .and. arr(5) == -1.0d0) + end subroutine test_realloc_grow_keeps_existing + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_shrink_keeps_existing, test_realloc_shrink_keeps_existing, + !> Shrinking an array preserves data up to new size + subroutine test_realloc_shrink_keeps_existing() bind(C) + real(dp), allocatable :: arr(:) + call realloc(arr, 5, fill=0.0d0) + arr(1) = 1.0d0; arr(2) = 2.0d0; arr(3) = 3.0d0 + call realloc(arr, 2, keepExisting=.true.) + call f90_expect_eq(size(arr), 2) + call f90_expect_true(arr(1) == 1.0d0 .and. arr(2) == 2.0d0) + end subroutine test_realloc_shrink_keeps_existing + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_same_bounds_no_keepexisting_fill, test_realloc_same_bounds_no_keepexisting_fill, + !> Same bounds + keepExisting=.false. + fill should overwrite in-place without reallocation + subroutine test_realloc_same_bounds_no_keepexisting_fill() bind(C) + real(dp), allocatable, target :: arr(:) + real(dp), pointer :: ptr_before + call realloc(arr, 3, fill=1.0d0) + ptr_before => arr(1) + call realloc(arr, 3, fill=-999.0d0, keepExisting=.false.) + call f90_expect_true(all(arr == -999.0d0)) + call f90_expect_true(associated(ptr_before, arr(1))) + end subroutine test_realloc_same_bounds_no_keepexisting_fill + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_same_bounds_no_fill_unchanged, test_realloc_same_bounds_no_fill_unchanged, + !> Same bounds and no fill should return early leaving array untouched + subroutine test_realloc_same_bounds_no_fill_unchanged() bind(C) + real(dp), allocatable, target :: arr(:) + real(dp), pointer :: ptr_before + call realloc(arr, 3, fill=1.0d0) + arr(2) = 42.0d0 + ptr_before => arr(1) + call realloc(arr, 3) + call f90_expect_true(arr(2) == 42.0d0) + call f90_expect_true(associated(ptr_before, arr(1))) + end subroutine test_realloc_same_bounds_no_fill_unchanged + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_shift, test_realloc_shift, + !> Shift moves existing data to new position in grown array + subroutine test_realloc_shift() bind(C) + real(dp), allocatable :: arr(:) + call realloc(arr, 3, fill=0.0d0) + arr(1) = 10.0d0; arr(2) = 20.0d0; arr(3) = 30.0d0 + call realloc(arr, 5, fill=-1.0d0, shift=2, keepExisting=.true.) + call f90_expect_eq(size(arr), 5) + call f90_expect_true(arr(1) == -1.0d0 .and. arr(2) == -1.0d0) + call f90_expect_true(arr(3) == 10.0d0 .and. arr(4) == 20.0d0 .and. arr(5) == 30.0d0) + end subroutine test_realloc_shift + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_nondefault_lindex, test_realloc_nondefault_lindex, + !> Non-default lower index produces correct bounds + subroutine test_realloc_nondefault_lindex() bind(C) + real(dp), allocatable :: arr(:) + call realloc(arr, 5, lindex=0, fill=1.0d0) + call f90_expect_eq(lbound(arr, 1), 0) + call f90_expect_eq(ubound(arr, 1), 5) + call f90_expect_true(all(arr == 1.0d0)) + end subroutine test_realloc_nondefault_lindex + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_realloc_rank2_fixed_first_dim, test_realloc_rank2_fixed_first_dim, + !> Rank 2: growing only second dimension preserves all data (regression for neighbour_nodes_obs bug) + subroutine test_realloc_rank2_fixed_first_dim() bind(C) + integer, allocatable :: arr(:,:) + call realloc(arr, [3, 2], fill=0) + arr(1,1) = 1; arr(2,1) = 2; arr(3,1) = 3 + arr(1,2) = 4; arr(2,2) = 5; arr(3,2) = 6 + call realloc(arr, [3, 4], fill=-1, keepExisting=.true.) + call f90_expect_eq(size(arr, 1), 3) + call f90_expect_eq(size(arr, 2), 4) + call f90_expect_true(arr(1,1) == 1 .and. arr(2,1) == 2 .and. arr(3,1) == 3) + call f90_expect_true(arr(1,2) == 4 .and. arr(2,2) == 5 .and. arr(3,2) == 6) + call f90_expect_true(arr(1,3) == -1 .and. arr(1,4) == -1) + end subroutine test_realloc_rank2_fixed_first_dim + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_reallocp_unassociated, test_reallocp_unassociated, + !> Pointer realloc on unassociated pointer should allocate without crash + subroutine test_reallocp_unassociated() bind(C) + real(dp), pointer :: arr(:) + nullify(arr) + call reallocp(arr, 5, fill=-999.0d0) + call f90_expect_true(associated(arr)) + call f90_expect_eq(size(arr), 5) + call f90_expect_true(all(arr == -999.0d0)) + deallocate(arr) + end subroutine test_reallocp_unassociated + !$f90tw) + + !$f90tw TESTCODE(TEST, test_deltares_common_gtest, test_reallocp_grow_keeps_existing, test_reallocp_grow_keeps_existing, + !> Pointer realloc grow preserves existing data + subroutine test_reallocp_grow_keeps_existing() bind(C) + real(dp), pointer :: arr(:) + nullify(arr) + call reallocp(arr, 3, fill=0.0d0) + arr(1) = 1.0d0; arr(2) = 2.0d0; arr(3) = 3.0d0 + call reallocp(arr, 5, fill=-1.0d0, keepExisting=.true.) + call f90_expect_eq(size(arr), 5) + call f90_expect_true(arr(1) == 1.0d0 .and. arr(2) == 2.0d0 .and. arr(3) == 3.0d0) + call f90_expect_true(arr(4) == -1.0d0 .and. arr(5) == -1.0d0) + deallocate(arr) + end subroutine test_reallocp_grow_keeps_existing + !$f90tw) + +end module test_malloc \ No newline at end of file diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/CMakeLists.txt b/src/utils_lgpl/deltares_common/packages/deltares_common/CMakeLists.txt index 1d3774c4a97..5983de677fe 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/CMakeLists.txt +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/CMakeLists.txt @@ -19,12 +19,19 @@ set(stdlib_source src/stdlib/stdlib_kinds.f90 src/stdlib/stdlib_sorting_sort_index.f90 ) +# Template include files (not compiled directly; included via #include in malloc.F90) +set(malloc_inc_files + src/malloc_includes/malloc_body.inc +) +set_source_files_properties(${malloc_inc_files} PROPERTIES HEADER_FILE_ONLY TRUE) + get_fortran_source_files(src source) set(library_name deltares_common) add_library(${library_name} ${source} ${rd_token_source} ${stdlib_source} + ${malloc_inc_files} ${fortran_version_file} ) @@ -39,6 +46,7 @@ target_include_directories(${library_name} PRIVATE ${version_include_dir}) set_source_files_properties(${fortran_version_file} src/system_utils.F90 src/MessageHandling.F90 + src/malloc.F90 PROPERTIES COMPILE_OPTIONS "${file_preprocessor_flag}" ) @@ -46,7 +54,8 @@ set_source_files_properties(${fortran_version_file} source_group(TREE ${CMAKE_CURRENT_SOURCE_DIR} FILES ${source} ${rd_token_source} ${stdlib_source} - ${fortran_version_file}) + ${fortran_version_file} + ${malloc_inc_files}) set_target_properties (${library_name} PROPERTIES FOLDER utils_lgpl/deltares_common) @@ -54,7 +63,9 @@ set(gtest_path ${CMAKE_CURRENT_SOURCE_DIR}/../../gtest) f90twtest(test_deltares_common_gtest CFILES ${gtest_path}/test_deltares_common_gtest.cpp F90FILES ${gtest_path}/test_deltares_common_gtest.f90 + ${gtest_path}/test_malloc.f90 F2HFILES ${gtest_path}/test_deltares_common_gtest.f90 + ${gtest_path}/test_malloc.f90 OUTDIR "${CMAKE_CURRENT_BINARY_DIR}" LIBRARIES deltares_common VISUAL_STUDIO_PATH utils_lgpl/deltares_common/gtest diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 index 5fd3b4612b9..ede50f52094 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 @@ -203,39 +203,165 @@ subroutine aerr(name, iostat, isize, errmsg) end if end subroutine aerr + +!> Determines size of an allocatable array, returning 0 when it is not allocated. + function allocSizeDouble(arr) result(isize) + implicit none + double precision, allocatable, intent(inout) :: arr(:) !< Array for which the extent must be determined. Is allowed to be not allocated. + integer :: isize !< Array length, 0 when it was not allocated. + + if (allocated(arr)) then + isize = size(arr) + else + isize = 0 + end if + end function allocSizeDouble + +!> Allocate or reallocate an integer array. At first the size will be set to 10, in case of a realloc +!! the size of the array is doubled. + subroutine reserve_sufficient_space_int(arr, required_size, fill) + integer, allocatable, dimension(:), intent(inout) :: arr !< Array for which the resize might be required. + integer, intent(in) :: required_size !< Minimal required size of the array. + integer, intent(in) :: fill !< Fill value for the new values. + + integer length + if (allocated(arr)) then + if (required_size > size(arr)) then + length = max(required_size, 2 * size(arr)) + !call realloc(arr, length, fill=fill, keepexisting=.true.) + end if + else + length = max(required_size, 10) + !call realloc(arr, length, fill=fill) + end if + end subroutine reserve_sufficient_space_int + +!> Helper function to fill a string + subroutine fill_string(string, fill, fill_offset) + implicit none + character(len=*), intent(inout) :: string + character(len=*), intent(in) :: fill + integer, intent(in) :: fill_offset + + integer :: string_size, fill_size, fill_offset_, i + character(len=len(fill)) :: rotated_fill + + string_size = len(string) + fill_size = len(fill) + + fill_offset_ = modulo(fill_offset, fill_size) + rotated_fill(1:fill_size - fill_offset_) = fill(1 + fill_offset_:fill_size) + rotated_fill(fill_size - fill_offset_ + 1:fill_size) = fill(1:fill_offset_) + + do i = 1, string_size, fill_size + string(i:min(i + fill_size - 1, string_size)) = rotated_fill(1:min(fill_size, string_size - i + 1)) + end do + end subroutine fill_string + +!> Reallocates a single allocatable string. +!! NOTE: Do not confuse this with an allocatable array of strings! + subroutine reallocString(string, newlen, stat, fill, shift, keepExisting) + implicit none + character(len=:), allocatable, intent(inout) :: string + integer, intent(in) :: newlen + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift + logical, intent(in), optional :: keepExisting + + character(len=:), allocatable :: temp + integer :: original_size, data_l_index, data_u_index, shift_, new_size + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + logical :: fill_available + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(fill)) then + fill_available = (len(fill) /= 0) + else + fill_available = .false. + end if + + new_size = max(0, newlen) + + local_err = 0 + if (allocated(string)) then + original_size = len(string) + if (original_size == new_size .and. shift_ == 0) then + if (.not. keepExisting_ .and. fill_available) then + call fill_string(string, fill, 0) + end if + if (present(stat)) stat = 0 + return + end if + end if + + allocate (character(len=new_size) :: temp, stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (keepExisting_ .and. allocated(string)) then + data_l_index = max(1 + shift_, 1) + data_u_index = min(original_size + shift_, new_size) + ! string access below is safe, because: + ! data_l_index - shift_ >= (1 + shift_) - shift_ = 1 + ! data_u_index - shift_ <= (original_size + shift_) - shift_ = original_size + temp(data_l_index:data_u_index) = string(data_l_index - shift_:data_u_index - shift_) + if (fill_available) then + call fill_string(temp(1:data_l_index - 1), fill, 0) + call fill_string(temp(data_u_index + 1:new_size), fill, data_u_index) + end if + elseif (fill_available) then + call fill_string(temp, fill, 0) + end if + call move_alloc(temp, string) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocString ! -! +!=============================================================================== +! Rank 2x/3x convenience wrappers (scalar dimension arguments) ! !=============================================================================== subroutine reallocReal2x(arr, u1, u2, l1, l2, stat, keepExisting) + implicit none real, allocatable, intent(inout) :: arr(:, :) - integer :: u1, u2 - integer, optional :: l1, l2 - integer :: uindex(2) - integer :: lindex(2) + integer, intent(in) :: u1, u2 + integer, intent(in), optional :: l1, l2 integer, intent(out), optional :: stat logical, intent(in), optional :: keepExisting - + integer :: uindex(2), lindex(2) uindex = (/u1, u2/) if (present(l1)) then lindex = (/l1, l2/) - call reallocReal2(arr, uindex, lindex, stat=stat) + call reallocReal2(arr, uindex, lindex, stat=stat, keepExisting=keepExisting) else - call reallocReal2(arr, uindex, stat=stat) + call reallocReal2(arr, uindex, stat=stat, keepExisting=keepExisting) end if end subroutine reallocReal2x -! -! -! -!=============================================================================== + subroutine reallocDouble2x(arr, u1, u2, l1, l2, stat) + implicit none double precision, allocatable, intent(inout) :: arr(:, :) - integer :: u1, u2 - integer, optional :: l1, l2 - integer :: uindex(2) - integer :: lindex(2) + integer, intent(in) :: u1, u2 + integer, intent(in), optional :: l1, l2 integer, intent(out), optional :: stat - + integer :: uindex(2), lindex(2) uindex = (/u1, u2/) if (present(l1)) then lindex = (/l1, l2/) @@ -244,18 +370,14 @@ subroutine reallocDouble2x(arr, u1, u2, l1, l2, stat) call reallocDouble2(arr, uindex, stat=stat) end if end subroutine reallocDouble2x -! -! -! -!=============================================================================== + subroutine reallocInt2x(arr, u1, u2, l1, l2, stat) + implicit none integer, allocatable, intent(inout) :: arr(:, :) - integer :: u1, u2 - integer, optional :: l1, l2 - integer :: uindex(2) - integer :: lindex(2) + integer, intent(in) :: u1, u2 + integer, intent(in), optional :: l1, l2 integer, intent(out), optional :: stat - + integer :: uindex(2), lindex(2) uindex = (/u1, u2/) if (present(l1)) then lindex = (/l1, l2/) @@ -264,18 +386,14 @@ subroutine reallocInt2x(arr, u1, u2, l1, l2, stat) call reallocInt2(arr, uindex, stat=stat) end if end subroutine reallocInt2x -! -! -! -!=============================================================================== + subroutine reallocCharacter2x(arr, u1, u2, l1, l2, stat) + implicit none character(len=*), allocatable, intent(inout) :: arr(:, :) - integer :: u1, u2 - integer, optional :: l1, l2 - integer :: uindex(2) - integer :: lindex(2) + integer, intent(in) :: u1, u2 + integer, intent(in), optional :: l1, l2 integer, intent(out), optional :: stat - + integer :: uindex(2), lindex(2) uindex = (/u1, u2/) if (present(l1)) then lindex = (/l1, l2/) @@ -284,18 +402,14 @@ subroutine reallocCharacter2x(arr, u1, u2, l1, l2, stat) call reallocCharacter2(arr, uindex, stat=stat) end if end subroutine reallocCharacter2x -! -! -! -!=============================================================================== + subroutine reallocReal3x(arr, u1, u2, u3, l1, l2, l3, stat) + implicit none real, allocatable, intent(inout) :: arr(:, :, :) - integer :: u1, u2, u3 - integer, optional :: l1, l2, l3 - integer :: uindex(3) - integer :: lindex(3) + integer, intent(in) :: u1, u2, u3 + integer, intent(in), optional :: l1, l2, l3 integer, intent(out), optional :: stat - + integer :: uindex(3), lindex(3) uindex = (/u1, u2, u3/) if (present(l1)) then lindex = (/l1, l2, l3/) @@ -305,3835 +419,495 @@ subroutine reallocReal3x(arr, u1, u2, u3, l1, l2, l3, stat) end if end subroutine reallocReal3x ! +!=============================================================================== +! +!=============================================================================== +! Rank 1 - shared macros ! +#define DRANK (:) +#define DINDEX integer +#define ALLOCATE_TEMP allocate(temp(new_l_index:new_u_index)) +#define OVERLAP_NONEMPTY data_l_index <= data_u_index +#define COPY_SECTION temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) +#define BOUNDS_UNCHANGED new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0 +#define GET_BOUNDS old_l_index = lbound(arr, 1); old_u_index = ubound(arr, 1) + ! !=============================================================================== - subroutine reallocPInt(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, pointer, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, optional, intent(in) :: lindex - integer, optional, intent(out) :: stat - integer, optional, intent(in) :: fill - integer, optional, intent(in) :: shift - logical, optional, intent(in) :: keepExisting +! Rank 1 - allocatable +! +#define DATTR allocatable +#define IS_ALLOCATED(x) allocated(x) +#define MOVE_ALLOC call move_alloc(temp, arr) +! +!=============================================================================== + subroutine reallocDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocDouble - integer, pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i - integer :: localErr - logical :: keepExisting_ - logical :: equalSize + subroutine reallocReal(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocReal - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = 1 - end if + subroutine reallocInt(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocInt - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if + subroutine reallocLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocLogical - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + subroutine reallocCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_FILL character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE +#undef DTYPE_FILL +#undef DTYPE_TEMP + end subroutine reallocCharacter - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr, 1) - lind = lbound(arr, 1) - equalSize = (uindex == uind) .and. (lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i = mlind, muind - arr(i) = b(i - shift_) - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPInt + subroutine reallocBool(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocBool ! +!=============================================================================== +! Rank 1 - pointer ! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#define DATTR pointer +#define IS_ALLOCATED(x) associated(x) +#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp ! !=============================================================================== - subroutine reallocInt(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - integer, allocatable :: temp(:) - integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex + subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPDouble - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if + subroutine reallocPReal(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPReal - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + subroutine reallocPInt(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPInt - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr, dim=1) - original_u_index = ubound(arr, dim=1) - equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if + subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPLogical - allocate (temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if + subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_FILL character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE +#undef DTYPE_FILL +#undef DTYPE_TEMP + end subroutine reallocPCharacter - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - if (present(fill)) then - temp(new_l_index:data_l_index - 1) = fill - temp(data_u_index + 1:new_u_index) = fill - end if - elseif (present(fill)) then - temp = fill - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocInt + subroutine reallocPBool(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPBool ! +!=============================================================================== +! End rank 1 ! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#undef DINDEX +#undef ALLOCATE_TEMP +#undef OVERLAP_NONEMPTY +#undef COPY_SECTION +#undef BOUNDS_UNCHANGED +#undef DRANK +#undef GET_BOUNDS ! !=============================================================================== - subroutine reallocPInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, pointer, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - integer, pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if ! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPInt2 +!=============================================================================== +! Rank 2 - shared macros +! +#define DRANK (:,:) +#define DINDEX integer, dimension(2) +#define ALLOCATE_TEMP allocate(temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2))) +#define OVERLAP_NONEMPTY all(data_l_index <= data_u_index) +#define COPY_SECTION temp(data_l_index(1):data_u_index(1), data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) +#define BOUNDS_UNCHANGED all(new_l_index == old_l_index) .and. all(new_u_index == old_u_index) .and. all(shift_ == 0) +#define GET_BOUNDS old_l_index = lbound(arr); old_u_index = ubound(arr) ! +!=============================================================================== +! Rank 2 - allocatable ! +#define DATTR allocatable +#define IS_ALLOCATED(x) allocated(x) +#define MOVE_ALLOC call move_alloc(temp, arr) ! !=============================================================================== - subroutine reallocInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - integer, allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex + subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocDouble2 - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if + subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocReal2 - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + subroutine reallocInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocInt2 - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if + subroutine reallocLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocLogical2 - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if + subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocCharacter2 - if (present(fill)) then - temp = fill - end if + subroutine reallocBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocBool2 - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocInt2 + subroutine reallocByte2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer(kind=1) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocByte2 ! +!=============================================================================== +! Rank 2 - pointer ! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#define DATTR pointer +#define IS_ALLOCATED(x) associated(x) +#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp ! !=============================================================================== - subroutine reallocPInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, pointer, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting + subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPDouble2 - integer, pointer :: b(:, :, :) - integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) - integer :: i1, i2, i3 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize + subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPReal2 - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1/) - end if + subroutine reallocPInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPInt2 - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0/) - end if + subroutine reallocPLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPLogical2 - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPCharacter2 - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if + subroutine reallocPBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPBool2 ! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPInt3 +!=============================================================================== +! End rank 2 +! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#undef DINDEX +#undef ALLOCATE_TEMP +#undef OVERLAP_NONEMPTY +#undef COPY_SECTION +#undef DRANK +! +!=============================================================================== ! +!=============================================================================== +! Rank 3 - shared macros +! +#define DRANK (:,:,:) +#define DINDEX integer, dimension(3) +#define ALLOCATE_TEMP allocate(temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3))) +#define OVERLAP_NONEMPTY all(data_l_index <= data_u_index) +#define COPY_SECTION temp(data_l_index(1):data_u_index(1), data_l_index(2):data_u_index(2), data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) +! +!=============================================================================== +! Rank 3 - allocatable ! +#define DATTR allocatable +#define IS_ALLOCATED(x) allocated(x) +#define MOVE_ALLOC call move_alloc(temp, arr) ! !=============================================================================== + subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocDouble3 + + subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocReal3 + subroutine reallocInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocInt3 - integer, allocatable :: temp(:, :, :) - integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds + subroutine reallocLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocLogical3 - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex + subroutine reallocCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocCharacter3 - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if + subroutine reallocBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocBool3 +! +!=============================================================================== +! Rank 3 - pointer +! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#define DATTR pointer +#define IS_ALLOCATED(x) associated(x) +#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp +! +!=============================================================================== + subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPDouble3 - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPReal3 - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if + subroutine reallocPInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPInt3 - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if + subroutine reallocPLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPLogical3 - if (present(fill)) then - temp = fill - end if + subroutine reallocPCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPCharacter3 - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocInt3 + subroutine reallocPBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPBool3 ! +!=============================================================================== +! End rank 3 ! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#undef DRANK +#undef DINDEX +#undef ALLOCATE_TEMP +#undef OVERLAP_NONEMPTY +#undef COPY_SECTION +!=============================================================================== ! !=============================================================================== - subroutine reallocPInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting +! Rank 4 - shared macros +! +#define DRANK (:,:,:,:) +#define DINDEX integer, dimension(4) +#define ALLOCATE_TEMP allocate(temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4))) +#define OVERLAP_NONEMPTY all(data_l_index <= data_u_index) +#define COPY_SECTION temp(data_l_index(1):data_u_index(1), data_l_index(2):data_u_index(2), data_l_index(3):data_u_index(3), data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) +! +!=============================================================================== +! Rank 4 - allocatable +! +#define DATTR allocatable +#define IS_ALLOCATED(x) allocated(x) +#define MOVE_ALLOC call move_alloc(temp, arr) +! +!=============================================================================== + subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocDouble4 - integer, pointer :: b(:, :, :, :) - integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) - integer :: i1, i2, i3, i4 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize + subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocReal4 - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1, 1/) - end if + subroutine reallocInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocInt4 - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if + subroutine reallocLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocLogical4 - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + subroutine reallocCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocCharacter4 - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i4 = mlind(4), muind(4) - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) - end do - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPInt4 + subroutine reallocBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocBool4 ! +!=============================================================================== +! Rank 4 - pointer ! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#define DATTR pointer +#define IS_ALLOCATED(x) associated(x) +#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp ! !=============================================================================== - subroutine reallocInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer, allocatable, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting + subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE double precision +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPDouble4 - integer, allocatable :: temp(:, :, :, :) - integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds + subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE real +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPReal4 - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex + subroutine reallocPInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE integer +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPInt4 - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if + subroutine reallocPLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE logical +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPLogical4 - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & - new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3), & - data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocInt4 -! -! -! -!=============================================================================== - subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), pointer, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, optional, intent(in) :: lindex - integer, optional, intent(out) :: stat - character(len=*), optional, intent(in) :: fill - integer, optional, intent(in) :: shift - logical, optional, intent(in) :: keepExisting - - character(len=len(arr)), pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = 1 - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr, 1) - lind = lbound(arr, 1) - equalSize = (uindex == uind) .and. (lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i = mlind, muind - arr(i) = b(i - shift_) - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPCharacter -! -! -! -!=============================================================================== - subroutine reallocCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), allocatable :: temp(:) - integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr, dim=1) - original_u_index = ubound(arr, dim=1) - equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - if (present(fill)) then - temp(new_l_index:data_l_index - 1) = fill - temp(data_u_index + 1:new_u_index) = fill - end if - elseif (present(fill)) then - temp = fill - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocCharacter -! -! -! -!=============================================================================== - subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), pointer, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPCharacter2 -! -! -! -!=============================================================================== - subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocCharacter2 -! -! -! -!=============================================================================== - subroutine reallocPCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), pointer, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), pointer :: b(:, :, :) - integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) - integer :: i1, i2, i3 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPCharacter3 -! -! -! -!=============================================================================== - subroutine reallocCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), allocatable :: temp(:, :, :) - integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocCharacter3 -! -! -! -!=============================================================================== - subroutine reallocPCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), pointer :: b(:, :, :, :) - integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) - integer :: i1, i2, i3, i4 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i4 = mlind(4), muind(4) - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) - end do - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPCharacter4 -! -! -! -!=============================================================================== - subroutine reallocCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - character(len=len(arr)), allocatable :: temp(:, :, :, :) - integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & - new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3), & - data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocCharacter4 -! -! -! -!=============================================================================== -!> Helper function to fill a string - subroutine fill_string(string, fill, fill_offset) - implicit none - character(len=*), intent(inout) :: string - character(len=*), intent(in) :: fill - integer, intent(in) :: fill_offset - - integer :: string_size, fill_size, fill_offset_, i - character(len=len(fill)) :: rotated_fill - - string_size = len(string) - fill_size = len(fill) - - fill_offset_ = modulo(fill_offset, fill_size) - rotated_fill(1:fill_size - fill_offset_) = fill(1 + fill_offset_:fill_size) - rotated_fill(fill_size - fill_offset_ + 1:fill_size) = fill(1:fill_offset_) - - do i = 1, string_size, fill_size - string(i:min(i + fill_size - 1, string_size)) = rotated_fill(1:min(fill_size, string_size - i + 1)) - end do - end subroutine fill_string -! -! -! -!=============================================================================== -!> Reallocates a single allocatable string. -!! NOTE: Do not confuse this with an allocatable array of strings! - subroutine reallocString(string, newlen, stat, fill, shift, keepExisting) - implicit none - character(len=:), allocatable, intent(inout) :: string - integer, intent(in) :: newlen - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - character(len=:), allocatable :: temp - integer :: original_size, data_l_index, data_u_index, shift_, new_size - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - logical :: fill_available - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(fill)) then - fill_available = (len(fill) /= 0) - else - fill_available = .false. - end if - - new_size = max(0, newlen) - - local_err = 0 - if (allocated(string)) then - original_size = len(string) - equal_bounds = (original_size == new_size) - if (equal_bounds .and. (keepExisting_ .or. .not. fill_available) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if - - allocate (character(len=new_size) :: temp, stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(string)) then - data_l_index = max(1 + shift_, 1) - data_u_index = min(original_size + shift_, new_size) - ! string access below is safe, because: - ! data_l_index - shift_ >= (1 + shift_) - shift_ = 1 - ! data_u_index - shift_ <= (original_size + shift_) - shift_ = original_size - temp(data_l_index:data_u_index) = string(data_l_index - shift_:data_u_index - shift_) - if (fill_available) then - call fill_string(temp(1:data_l_index - 1), fill, 0) - call fill_string(temp(data_u_index + 1:new_size), fill, data_u_index) - end if - elseif (fill_available) then - call fill_string(temp, fill, 0) - end if - call move_alloc(temp, string) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocString -! -! -! -!=============================================================================== - subroutine reallocPReal(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, pointer, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, optional, intent(in) :: lindex - integer, optional, intent(out) :: stat - real, optional, intent(in) :: fill - integer, optional, intent(in) :: shift - logical, optional, intent(in) :: keepExisting - - real, pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = 1 - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr, 1) - lind = lbound(arr, 1) - equalSize = (uindex == uind) .and. (lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i = mlind, muind - arr(i) = b(i - shift_) - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPReal -! -! -! -!=============================================================================== - subroutine reallocReal(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - real, allocatable :: temp(:) - integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr, dim=1) - original_u_index = ubound(arr, dim=1) - equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - if (present(fill)) then - temp(new_l_index:data_l_index - 1) = fill - temp(data_u_index + 1:new_u_index) = fill - end if - elseif (present(fill)) then - temp = fill - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocReal -! -! -! -!=============================================================================== - subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, pointer, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - real, pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPReal2 -! -! -! -!=============================================================================== - subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - real, allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocReal2 -! -! -! -!=============================================================================== - subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, pointer, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - real, pointer :: b(:, :, :) - integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) - integer :: i1, i2, i3 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPReal3 -! -! -! -!=============================================================================== - subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - real, allocatable :: temp(:, :, :) - integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocReal3 -! -! -! -!=============================================================================== - subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - real, pointer :: b(:, :, :, :) - integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) - integer :: i1, i2, i3, i4 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i4 = mlind(4), muind(4) - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) - end do - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPReal4 -! -! -! -!=============================================================================== - subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - real, allocatable, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - real, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - real, allocatable :: temp(:, :, :, :) - integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & - new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3), & - data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocReal4 -! -! -! -!=============================================================================== - subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, pointer, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, optional, intent(in) :: lindex - integer, optional, intent(out) :: stat - double precision, optional, intent(in) :: fill - integer, optional, intent(in) :: shift - logical, optional, intent(in) :: keepExisting - - double precision, pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = 1 - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr, 1) - lind = lbound(arr, 1) - equalSize = (uindex == uind) .and. (lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i = mlind, muind - arr(i) = b(i - shift_) - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPDouble -! -! -! -!=============================================================================== - subroutine reallocDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - double precision, allocatable :: temp(:) - integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr, dim=1) - original_u_index = ubound(arr, dim=1) - equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - if (present(fill)) then - temp(new_l_index:data_l_index - 1) = fill - temp(data_u_index + 1:new_u_index) = fill - end if - elseif (present(fill)) then - temp = fill - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocDouble -! -! -! -!=============================================================================== - subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, pointer, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - double precision, pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPDouble2 -! -! -! -!=============================================================================== - subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - double precision, allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocDouble2 -! -! -! -!=============================================================================== - subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, pointer, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - double precision, pointer :: b(:, :, :) - integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) - integer :: i1, i2, i3 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPDouble3 -! -! -! -!=============================================================================== - subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - double precision, allocatable :: temp(:, :, :) - integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocDouble3 -! -! -! -!=============================================================================== - subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - double precision, pointer :: b(:, :, :, :) - integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) - integer :: i1, i2, i3, i4 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i4 = mlind(4), muind(4) - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) - end do - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPDouble4 -! -! -! -!=============================================================================== - subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - double precision, allocatable, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - double precision, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - double precision, allocatable :: temp(:, :, :, :) - integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & - new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3), & - data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocDouble4 -! -! -! -!=============================================================================== - subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, pointer, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, optional, intent(in) :: lindex - integer, optional, intent(out) :: stat - logical, optional, intent(in) :: fill - integer, optional, intent(in) :: shift - logical, optional, intent(in) :: keepExisting - - logical, pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = 1 - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr, 1) - lind = lbound(arr, 1) - equalSize = (uindex == uind) .and. (lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i = mlind, muind - arr(i) = b(i - shift_) - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPLogical -! -! -! -!=============================================================================== - subroutine reallocLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - logical, allocatable :: temp(:) - integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr, dim=1) - original_u_index = ubound(arr, dim=1) - equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - if (present(fill)) then - temp(new_l_index:data_l_index - 1) = fill - temp(data_u_index + 1:new_u_index) = fill - end if - elseif (present(fill)) then - temp = fill - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocLogical -! -! -! -!=============================================================================== - subroutine reallocPLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, pointer, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - logical, pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPLogical2 -! -! -! -!=============================================================================== - subroutine reallocLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - logical, allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocLogical2 -! -! -! -!=============================================================================== - subroutine reallocPLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, pointer, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - logical, pointer :: b(:, :, :) - integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) - integer :: i1, i2, i3 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPLogical3 -! -! -! -!=============================================================================== - subroutine reallocLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - logical, allocatable :: temp(:, :, :) - integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocLogical3 -! -! -! -!=============================================================================== - subroutine reallocPLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - logical, pointer :: b(:, :, :, :) - integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) - integer :: i1, i2, i3, i4 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i4 = mlind(4), muind(4) - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) - end do - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPLogical4 -! -! -! -!=============================================================================== - subroutine reallocLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - logical, allocatable, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - logical, intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - logical, allocatable :: temp(:, :, :, :) - integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & - new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3), & - data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocLogical4 -! -! -! -!=============================================================================== - subroutine reallocPBool(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), pointer, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, optional, intent(in) :: lindex - integer, optional, intent(out) :: stat - logical(kind=c_bool), optional, intent(in) :: fill - integer, optional, intent(in) :: shift - logical, optional, intent(in) :: keepExisting - - logical(kind=c_bool), pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = 1 - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr, 1) - lind = lbound(arr, 1) - equalSize = (uindex == uind) .and. (lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i = mlind, muind - arr(i) = b(i - shift_) - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPBool -! -! -! -!=============================================================================== - subroutine reallocBool(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), allocatable :: temp(:) - integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr, dim=1) - original_u_index = ubound(arr, dim=1) - equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - if (present(fill)) then - temp(new_l_index:data_l_index - 1) = fill - temp(data_u_index + 1:new_u_index) = fill - end if - elseif (present(fill)) then - temp = fill - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocBool -! -! -! -!=============================================================================== - subroutine reallocPBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), pointer, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPBool2 -! -! -! -!=============================================================================== - subroutine reallocBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocBool2 -! -! -! -!=============================================================================== - subroutine reallocPBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), pointer, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), pointer :: b(:, :, :) - integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) - integer :: i1, i2, i3 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr - end subroutine reallocPBool3 -! -! -! -!=============================================================================== - subroutine reallocBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: uindex(3) - integer, intent(in), optional :: lindex(3) - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift(3) - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), allocatable :: temp(:, :, :) - integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if + subroutine reallocPCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) +#define DTYPE character(len=*) +#define DTYPE_TEMP character(len=len(arr)) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE + end subroutine reallocPCharacter4 - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocBool3 -! -! -! -!=============================================================================== subroutine reallocPBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), pointer :: b(:, :, :, :) - integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) - integer :: i1, i2, i3, i4 - integer :: localErr - logical :: keepExisting_ - logical :: equalSize - - if (present(lindex)) then - lindex_ = lindex - else - lindex_ = (/1, 1, 1, 1/) - end if - - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(stat)) stat = 0 - localErr = 0 - nullify (b) - if (associated(arr)) then - uind = ubound(arr) - lind = lbound(arr) - equalSize = all(uindex == uind) .and. all(lindex_ == lind) - if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if -! - if (keepExisting_) then - mlind = max(lind + shift_, lindex_) - muind = min(uind + shift_, uindex) - b => arr - nullify (arr) - elseif (.not. equalSize) then - deallocate (arr, stat=localErr) - end if - end if - if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) - end if - if (present(fill) .and. localErr == 0) arr = fill - if (associated(b) .and. localErr == 0 .and. size(b) > 0) then - do i4 = mlind(4), muind(4) - do i3 = mlind(3), muind(3) - do i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) - end do - end do - end do - end do - deallocate (b, stat=localErr) - end if -999 continue - if (present(stat)) stat = localErr +#define DTYPE logical(kind=c_bool) +#include "malloc_includes/malloc_body.inc" +#undef DTYPE end subroutine reallocPBool4 ! -! -! -!=============================================================================== - subroutine reallocBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool - implicit none - logical(kind=c_bool), allocatable, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) - integer, intent(out), optional :: stat - logical(kind=c_bool), intent(in), optional :: fill - integer, intent(in), optional :: shift(4) - logical, intent(in), optional :: keepExisting - - logical(kind=c_bool), allocatable :: temp(:, :, :, :) - integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & - new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2), & - data_l_index(3):data_u_index(3), & - data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & - data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocBool4 -! -! -! !=============================================================================== - subroutine reallocByte2(arr, uindex, lindex, stat, fill, shift, keepExisting) - implicit none - integer(kind=1), allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: uindex(2) - integer, intent(in), optional :: lindex(2) - integer, intent(out), optional :: stat - integer, intent(in), optional :: fill - integer, intent(in), optional :: shift(2) - logical, intent(in), optional :: keepExisting - - integer(kind=1), allocatable :: temp(:, :) - integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - - if (present(lindex)) then - new_l_index = lindex - else - new_l_index = 1 - end if - new_u_index = uindex - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - local_err = 0 - if (allocated(arr)) then - original_l_index = lbound(arr) - original_u_index = ubound(arr) - equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) - if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then - goto 999 ! output=input - end if - end if - - allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated(arr)) then - data_l_index = max(original_l_index + shift_, new_l_index) - data_u_index = min(original_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index - ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index - temp(data_l_index(1):data_u_index(1), & - data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & - data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) - end if - call move_alloc(temp, arr) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocByte2 -! -! +! End rank 4 ! +#undef DATTR +#undef IS_ALLOCATED +#undef MOVE_ALLOC +#undef DRANK +#undef DINDEX +#undef ALLOCATE_TEMP +#undef OVERLAP_NONEMPTY +#undef COPY_SECTION +#undef BOUNDS_UNCHANGED !=============================================================================== - -!> Determines size of an allocatable array, returning 0 when it is not allocated. - function allocSizeDouble(arr) result(isize) - implicit none - double precision, allocatable, intent(inout) :: arr(:) !< Array for which the extent must be determined. Is allowed to be not allocated. - integer :: isize !< Array length, 0 when it was not allocated. - - if (allocated(arr)) then - isize = size(arr) - else - isize = 0 - end if - end function allocSizeDouble - -!> Allocate or reallocate an integer array. At first the size will be set to 10, in case of a realloc -!! the size of the array is doubled. - subroutine reserve_sufficient_space_int(arr, required_size, fill) - integer, allocatable, dimension(:), intent(inout) :: arr !< Array for which the resize might be required. - integer, intent(in) :: required_size !< Minimal required size of the array. - integer, intent(in) :: fill !< Fill value for the new values. - - integer length - if (allocated(arr)) then - if (required_size > size(arr)) then - length = max(required_size, 2 * size(arr)) - call realloc(arr, length, fill=fill, keepexisting=.true.) - end if - else - length = max(required_size, 10) - call realloc(arr, length, fill=fill) - end if - end subroutine reserve_sufficient_space_int - end module m_alloc diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc new file mode 100644 index 00000000000..e4ff41d25d1 --- /dev/null +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc @@ -0,0 +1,61 @@ + implicit none + DTYPE, DATTR, intent(inout) :: arr DRANK + DINDEX, intent(in) :: uindex + DINDEX, intent(in), optional :: lindex + integer, intent(out), optional :: stat + DTYPE, intent(in), optional :: fill + DINDEX, intent(in), optional :: shift + logical, intent(in), optional :: keepExisting + +#ifndef DTYPE_TEMP +#define DTYPE_TEMP DTYPE +#endif + DTYPE_TEMP, DATTR :: temp DRANK +#undef DTYPE_TEMP + DINDEX :: old_l_index, old_u_index + DINDEX :: new_l_index, new_u_index + DINDEX :: data_l_index, data_u_index + DINDEX :: shift_ + logical :: keepExisting_ + logical :: allocated_old + + if (present(stat)) stat = 0 + + new_l_index = 1 + if (present(lindex)) new_l_index = lindex + new_u_index = uindex + + shift_ = 0 + if (present(shift)) shift_ = shift + + keepExisting_ = .true. + if (present(keepExisting)) keepExisting_ = keepExisting + + allocated_old = IS_ALLOCATED(arr) + + if (allocated_old) then + GET_BOUNDS + + if (BOUNDS_UNCHANGED) then + if (.not. keepExisting_ .and. present(fill)) arr = fill + return + end if + end if + + ! Reallocation required + ALLOCATE_TEMP + + if (present(fill)) temp = fill + + if (keepExisting_ .and. allocated_old) then + data_l_index = max(old_l_index + shift_, new_l_index) + data_u_index = min(old_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (old_l_index + shift_) - shift_ = old_l_index + ! data_u_index - shift_ <= (old_u_index + shift_) - shift_ = old_u_index + if (OVERLAP_NONEMPTY) then + COPY_SECTION + end if + end if + + MOVE_ALLOC \ No newline at end of file From 8bbadd6ecf5869bd14ec3ef2f2f82ed3b9129945 Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Wed, 1 Apr 2026 11:10:34 +0200 Subject: [PATCH 2/7] uncomment commented reallocs.. --- .../packages/deltares_common/src/malloc.f90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 index ede50f52094..f343023fd2c 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 @@ -228,11 +228,11 @@ subroutine reserve_sufficient_space_int(arr, required_size, fill) if (allocated(arr)) then if (required_size > size(arr)) then length = max(required_size, 2 * size(arr)) - !call realloc(arr, length, fill=fill, keepexisting=.true.) + call realloc(arr, length, fill=fill, keepexisting=.true.) end if else length = max(required_size, 10) - !call realloc(arr, length, fill=fill) + call realloc(arr, length, fill=fill) end if end subroutine reserve_sufficient_space_int @@ -316,9 +316,6 @@ subroutine reallocString(string, newlen, stat, fill, shift, keepExisting) if (keepExisting_ .and. allocated(string)) then data_l_index = max(1 + shift_, 1) data_u_index = min(original_size + shift_, new_size) - ! string access below is safe, because: - ! data_l_index - shift_ >= (1 + shift_) - shift_ = 1 - ! data_u_index - shift_ <= (original_size + shift_) - shift_ = original_size temp(data_l_index:data_u_index) = string(data_l_index - shift_:data_u_index - shift_) if (fill_available) then call fill_string(temp(1:data_l_index - 1), fill, 0) From 9785301fb8537c76f7e521cfe57e2eb765fb10e3 Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Wed, 1 Apr 2026 13:07:02 +0200 Subject: [PATCH 3/7] only do rank 1 with include file --- .../packages/deltares_common/src/malloc.f90 | 3494 ++++++++++++++--- .../src/malloc_includes/malloc_body.inc | 36 +- 2 files changed, 2986 insertions(+), 544 deletions(-) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 index f343023fd2c..27941de2f74 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 @@ -204,232 +204,6 @@ subroutine aerr(name, iostat, isize, errmsg) end subroutine aerr -!> Determines size of an allocatable array, returning 0 when it is not allocated. - function allocSizeDouble(arr) result(isize) - implicit none - double precision, allocatable, intent(inout) :: arr(:) !< Array for which the extent must be determined. Is allowed to be not allocated. - integer :: isize !< Array length, 0 when it was not allocated. - - if (allocated(arr)) then - isize = size(arr) - else - isize = 0 - end if - end function allocSizeDouble - -!> Allocate or reallocate an integer array. At first the size will be set to 10, in case of a realloc -!! the size of the array is doubled. - subroutine reserve_sufficient_space_int(arr, required_size, fill) - integer, allocatable, dimension(:), intent(inout) :: arr !< Array for which the resize might be required. - integer, intent(in) :: required_size !< Minimal required size of the array. - integer, intent(in) :: fill !< Fill value for the new values. - - integer length - if (allocated(arr)) then - if (required_size > size(arr)) then - length = max(required_size, 2 * size(arr)) - call realloc(arr, length, fill=fill, keepexisting=.true.) - end if - else - length = max(required_size, 10) - call realloc(arr, length, fill=fill) - end if - end subroutine reserve_sufficient_space_int - -!> Helper function to fill a string - subroutine fill_string(string, fill, fill_offset) - implicit none - character(len=*), intent(inout) :: string - character(len=*), intent(in) :: fill - integer, intent(in) :: fill_offset - - integer :: string_size, fill_size, fill_offset_, i - character(len=len(fill)) :: rotated_fill - - string_size = len(string) - fill_size = len(fill) - - fill_offset_ = modulo(fill_offset, fill_size) - rotated_fill(1:fill_size - fill_offset_) = fill(1 + fill_offset_:fill_size) - rotated_fill(fill_size - fill_offset_ + 1:fill_size) = fill(1:fill_offset_) - - do i = 1, string_size, fill_size - string(i:min(i + fill_size - 1, string_size)) = rotated_fill(1:min(fill_size, string_size - i + 1)) - end do - end subroutine fill_string - -!> Reallocates a single allocatable string. -!! NOTE: Do not confuse this with an allocatable array of strings! - subroutine reallocString(string, newlen, stat, fill, shift, keepExisting) - implicit none - character(len=:), allocatable, intent(inout) :: string - integer, intent(in) :: newlen - integer, intent(out), optional :: stat - character(len=*), intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting - - character(len=:), allocatable :: temp - integer :: original_size, data_l_index, data_u_index, shift_, new_size - integer :: local_err - logical :: keepExisting_ - logical :: equal_bounds - logical :: fill_available - - if (present(shift)) then - shift_ = shift - else - shift_ = 0 - end if - - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if - - if (present(fill)) then - fill_available = (len(fill) /= 0) - else - fill_available = .false. - end if - - new_size = max(0, newlen) - - local_err = 0 - if (allocated(string)) then - original_size = len(string) - if (original_size == new_size .and. shift_ == 0) then - if (.not. keepExisting_ .and. fill_available) then - call fill_string(string, fill, 0) - end if - if (present(stat)) stat = 0 - return - end if - end if - - allocate (character(len=new_size) :: temp, stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (keepExisting_ .and. allocated(string)) then - data_l_index = max(1 + shift_, 1) - data_u_index = min(original_size + shift_, new_size) - temp(data_l_index:data_u_index) = string(data_l_index - shift_:data_u_index - shift_) - if (fill_available) then - call fill_string(temp(1:data_l_index - 1), fill, 0) - call fill_string(temp(data_u_index + 1:new_size), fill, data_u_index) - end if - elseif (fill_available) then - call fill_string(temp, fill, 0) - end if - call move_alloc(temp, string) -999 continue - if (present(stat)) then - stat = local_err - end if - end subroutine reallocString -! -!=============================================================================== -! Rank 2x/3x convenience wrappers (scalar dimension arguments) -! -!=============================================================================== - subroutine reallocReal2x(arr, u1, u2, l1, l2, stat, keepExisting) - implicit none - real, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: u1, u2 - integer, intent(in), optional :: l1, l2 - integer, intent(out), optional :: stat - logical, intent(in), optional :: keepExisting - integer :: uindex(2), lindex(2) - uindex = (/u1, u2/) - if (present(l1)) then - lindex = (/l1, l2/) - call reallocReal2(arr, uindex, lindex, stat=stat, keepExisting=keepExisting) - else - call reallocReal2(arr, uindex, stat=stat, keepExisting=keepExisting) - end if - end subroutine reallocReal2x - - subroutine reallocDouble2x(arr, u1, u2, l1, l2, stat) - implicit none - double precision, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: u1, u2 - integer, intent(in), optional :: l1, l2 - integer, intent(out), optional :: stat - integer :: uindex(2), lindex(2) - uindex = (/u1, u2/) - if (present(l1)) then - lindex = (/l1, l2/) - call reallocDouble2(arr, uindex, lindex, stat=stat) - else - call reallocDouble2(arr, uindex, stat=stat) - end if - end subroutine reallocDouble2x - - subroutine reallocInt2x(arr, u1, u2, l1, l2, stat) - implicit none - integer, allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: u1, u2 - integer, intent(in), optional :: l1, l2 - integer, intent(out), optional :: stat - integer :: uindex(2), lindex(2) - uindex = (/u1, u2/) - if (present(l1)) then - lindex = (/l1, l2/) - call reallocInt2(arr, uindex, lindex, stat=stat) - else - call reallocInt2(arr, uindex, stat=stat) - end if - end subroutine reallocInt2x - - subroutine reallocCharacter2x(arr, u1, u2, l1, l2, stat) - implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :) - integer, intent(in) :: u1, u2 - integer, intent(in), optional :: l1, l2 - integer, intent(out), optional :: stat - integer :: uindex(2), lindex(2) - uindex = (/u1, u2/) - if (present(l1)) then - lindex = (/l1, l2/) - call reallocCharacter2(arr, uindex, lindex, stat=stat) - else - call reallocCharacter2(arr, uindex, stat=stat) - end if - end subroutine reallocCharacter2x - - subroutine reallocReal3x(arr, u1, u2, u3, l1, l2, l3, stat) - implicit none - real, allocatable, intent(inout) :: arr(:, :, :) - integer, intent(in) :: u1, u2, u3 - integer, intent(in), optional :: l1, l2, l3 - integer, intent(out), optional :: stat - integer :: uindex(3), lindex(3) - uindex = (/u1, u2, u3/) - if (present(l1)) then - lindex = (/l1, l2, l3/) - call reallocReal3(arr, uindex, lindex, stat=stat) - else - call reallocReal3(arr, uindex, stat=stat) - end if - end subroutine reallocReal3x -! -!=============================================================================== -! -!=============================================================================== -! Rank 1 - shared macros -! -#define DRANK (:) -#define DINDEX integer -#define ALLOCATE_TEMP allocate(temp(new_l_index:new_u_index)) -#define OVERLAP_NONEMPTY data_l_index <= data_u_index -#define COPY_SECTION temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) -#define BOUNDS_UNCHANGED new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0 -#define GET_BOUNDS old_l_index = lbound(arr, 1); old_u_index = ubound(arr, 1) - -! !=============================================================================== ! Rank 1 - allocatable ! @@ -464,12 +238,10 @@ end subroutine reallocLogical subroutine reallocCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) #define DTYPE character(len=*) -#define DTYPE_FILL character(len=*) -#define DTYPE_TEMP character(len=len(arr)) +#define DTYPE_CHAR #include "malloc_includes/malloc_body.inc" +#undef DTYPE_CHAR #undef DTYPE -#undef DTYPE_FILL -#undef DTYPE_TEMP end subroutine reallocCharacter subroutine reallocBool(arr, uindex, lindex, stat, fill, shift, keepExisting) @@ -516,12 +288,10 @@ end subroutine reallocPLogical subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) #define DTYPE character(len=*) -#define DTYPE_FILL character(len=*) -#define DTYPE_TEMP character(len=len(arr)) +#define DTYPE_CHAR #include "malloc_includes/malloc_body.inc" +#undef DTYPE_CHAR #undef DTYPE -#undef DTYPE_FILL -#undef DTYPE_TEMP end subroutine reallocPCharacter subroutine reallocPBool(arr, uindex, lindex, stat, fill, shift, keepExisting) @@ -537,374 +307,3046 @@ end subroutine reallocPBool #undef DATTR #undef IS_ALLOCATED #undef MOVE_ALLOC -#undef DINDEX -#undef ALLOCATE_TEMP -#undef OVERLAP_NONEMPTY -#undef COPY_SECTION -#undef BOUNDS_UNCHANGED -#undef DRANK -#undef GET_BOUNDS -! !=============================================================================== -! + !=============================================================================== -! Rank 2 - shared macros + subroutine reallocReal2x(arr, u1, u2, l1, l2, stat, keepExisting) + real, allocatable, intent(inout) :: arr(:, :) + integer :: u1, u2 + integer, optional :: l1, l2 + integer :: uindex(2) + integer :: lindex(2) + integer, intent(out), optional :: stat + logical, intent(in), optional :: keepExisting + + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocReal2(arr, uindex, lindex, stat=stat) + else + call reallocReal2(arr, uindex, stat=stat) + end if + end subroutine reallocReal2x +! ! -#define DRANK (:,:) -#define DINDEX integer, dimension(2) -#define ALLOCATE_TEMP allocate(temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2))) -#define OVERLAP_NONEMPTY all(data_l_index <= data_u_index) -#define COPY_SECTION temp(data_l_index(1):data_u_index(1), data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) -#define BOUNDS_UNCHANGED all(new_l_index == old_l_index) .and. all(new_u_index == old_u_index) .and. all(shift_ == 0) -#define GET_BOUNDS old_l_index = lbound(arr); old_u_index = ubound(arr) ! !=============================================================================== -! Rank 2 - allocatable + subroutine reallocDouble2x(arr, u1, u2, l1, l2, stat) + double precision, allocatable, intent(inout) :: arr(:, :) + integer :: u1, u2 + integer, optional :: l1, l2 + integer :: uindex(2) + integer :: lindex(2) + integer, intent(out), optional :: stat + + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocDouble2(arr, uindex, lindex, stat=stat) + else + call reallocDouble2(arr, uindex, stat=stat) + end if + end subroutine reallocDouble2x +! ! -#define DATTR allocatable -#define IS_ALLOCATED(x) allocated(x) -#define MOVE_ALLOC call move_alloc(temp, arr) ! !=============================================================================== - subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocDouble2 + subroutine reallocInt2x(arr, u1, u2, l1, l2, stat) + integer, allocatable, intent(inout) :: arr(:, :) + integer :: u1, u2 + integer, optional :: l1, l2 + integer :: uindex(2) + integer :: lindex(2) + integer, intent(out), optional :: stat - subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocReal2 + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocInt2(arr, uindex, lindex, stat=stat) + else + call reallocInt2(arr, uindex, stat=stat) + end if + end subroutine reallocInt2x +! +! +! +!=============================================================================== + subroutine reallocCharacter2x(arr, u1, u2, l1, l2, stat) + character(len=*), allocatable, intent(inout) :: arr(:, :) + integer :: u1, u2 + integer, optional :: l1, l2 + integer :: uindex(2) + integer :: lindex(2) + integer, intent(out), optional :: stat - subroutine reallocInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocCharacter2(arr, uindex, lindex, stat=stat) + else + call reallocCharacter2(arr, uindex, stat=stat) + end if + end subroutine reallocCharacter2x +! +! +! +!=============================================================================== + subroutine reallocReal3x(arr, u1, u2, u3, l1, l2, l3, stat) + real, allocatable, intent(inout) :: arr(:, :, :) + integer :: u1, u2, u3 + integer, optional :: l1, l2, l3 + integer :: uindex(3) + integer :: lindex(3) + integer, intent(out), optional :: stat + + uindex = (/u1, u2, u3/) + if (present(l1)) then + lindex = (/l1, l2, l3/) + call reallocReal3(arr, uindex, lindex, stat=stat) + else + call reallocReal3(arr, uindex, stat=stat) + end if + end subroutine reallocReal3x + + subroutine reallocPInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer, pointer, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + integer, pointer :: b(:, :) + integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) + integer :: i1, i2 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPInt2 +! +! +! +!=============================================================================== + subroutine reallocInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer, allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + integer, allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if end subroutine reallocInt2 +! +! +! +!=============================================================================== + subroutine reallocPInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer, pointer, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + integer, pointer :: b(:, :, :) + integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) + integer :: i1, i2, i3 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPInt3 +! +! +! +!=============================================================================== + subroutine reallocInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer, allocatable, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + integer, allocatable :: temp(:, :, :) + integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocInt3 +! +! +! +!=============================================================================== + subroutine reallocPInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer, pointer, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + integer, pointer :: b(:, :, :, :) + integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) + integer :: i1, i2, i3, i4 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i4 = mlind(4), muind(4) + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) + end do + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPInt4 +! +! +! +!=============================================================================== + subroutine reallocInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer, allocatable, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + integer, allocatable :: temp(:, :, :, :) + integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & + new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3), & + data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & + data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocInt4 + + subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), pointer, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), pointer :: b(:, :) + integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) + integer :: i1, i2 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPCharacter2 +! +! +! +!=============================================================================== + subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocCharacter2 +! +! +! +!=============================================================================== + subroutine reallocPCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), pointer, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), pointer :: b(:, :, :) + integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) + integer :: i1, i2, i3 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPCharacter3 +! +! +! +!=============================================================================== + subroutine reallocCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), allocatable, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), allocatable :: temp(:, :, :) + integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocCharacter3 +! +! +! +!=============================================================================== + subroutine reallocPCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), pointer, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), pointer :: b(:, :, :, :) + integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) + integer :: i1, i2, i3, i4 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i4 = mlind(4), muind(4) + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) + end do + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPCharacter4 +! +! +! +!=============================================================================== + subroutine reallocCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), allocatable, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), allocatable :: temp(:, :, :, :) + integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & + new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3), & + data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & + data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocCharacter4 +! +! +! +!=============================================================================== +!> Helper function to fill a string + subroutine fill_string(string, fill, fill_offset) + implicit none + character(len=*), intent(inout) :: string + character(len=*), intent(in) :: fill + integer, intent(in) :: fill_offset + + integer :: string_size, fill_size, fill_offset_, i + character(len=len(fill)) :: rotated_fill + + string_size = len(string) + fill_size = len(fill) + + fill_offset_ = modulo(fill_offset, fill_size) + rotated_fill(1:fill_size - fill_offset_) = fill(1 + fill_offset_:fill_size) + rotated_fill(fill_size - fill_offset_ + 1:fill_size) = fill(1:fill_offset_) + + do i = 1, string_size, fill_size + string(i:min(i + fill_size - 1, string_size)) = rotated_fill(1:min(fill_size, string_size - i + 1)) + end do + end subroutine fill_string +! +! +! +!=============================================================================== +!> Reallocates a single allocatable string. +!! NOTE: Do not confuse this with an allocatable array of strings! + subroutine reallocString(string, newlen, stat, fill, shift, keepExisting) + implicit none + character(len=:), allocatable, intent(inout) :: string + integer, intent(in) :: newlen + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift + logical, intent(in), optional :: keepExisting + + character(len=:), allocatable :: temp + integer :: original_size, data_l_index, data_u_index, shift_, new_size + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + logical :: fill_available + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(fill)) then + fill_available = (len(fill) /= 0) + else + fill_available = .false. + end if + + new_size = max(0, newlen) + + local_err = 0 + if (allocated(string)) then + original_size = len(string) + equal_bounds = (original_size == new_size) + if (equal_bounds .and. (keepExisting_ .or. .not. fill_available) .and. shift_ == 0) then + goto 999 ! output=input + end if + end if + + allocate (character(len=new_size) :: temp, stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (keepExisting_ .and. allocated(string)) then + data_l_index = max(1 + shift_, 1) + data_u_index = min(original_size + shift_, new_size) + ! string access below is safe, because: + ! data_l_index - shift_ >= (1 + shift_) - shift_ = 1 + ! data_u_index - shift_ <= (original_size + shift_) - shift_ = original_size + temp(data_l_index:data_u_index) = string(data_l_index - shift_:data_u_index - shift_) + if (fill_available) then + call fill_string(temp(1:data_l_index - 1), fill, 0) + call fill_string(temp(data_u_index + 1:new_size), fill, data_u_index) + end if + elseif (fill_available) then + call fill_string(temp, fill, 0) + end if + call move_alloc(temp, string) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocString + + subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + real, pointer, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + real, pointer :: b(:, :) + integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) + integer :: i1, i2 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPReal2 +! +! +! +!=============================================================================== + subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + real, allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + real, allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocReal2 +! +! +! +!=============================================================================== + subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + real, pointer, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + real, pointer :: b(:, :, :) + integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) + integer :: i1, i2, i3 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPReal3 +! +! +! +!=============================================================================== + subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + real, allocatable, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + real, allocatable :: temp(:, :, :) + integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocReal3 +! +! +! +!=============================================================================== + subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + real, pointer, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + real, pointer :: b(:, :, :, :) + integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) + integer :: i1, i2, i3, i4 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i4 = mlind(4), muind(4) + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) + end do + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPReal4 +! +! +! +!=============================================================================== + subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + real, allocatable, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + real, allocatable :: temp(:, :, :, :) + integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & + new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3), & + data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & + data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocReal4 + + subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + double precision, pointer, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + double precision, pointer :: b(:, :) + integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) + integer :: i1, i2 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPDouble2 +! +! +! +!=============================================================================== + subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + double precision, allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + double precision, allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocDouble2 +! +! +! +!=============================================================================== + subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + double precision, pointer, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + double precision, pointer :: b(:, :, :) + integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) + integer :: i1, i2, i3 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPDouble3 +! +! +! +!=============================================================================== + subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + double precision, allocatable, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + double precision, allocatable :: temp(:, :, :) + integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocDouble3 +! +! +! +!=============================================================================== + subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + double precision, pointer, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + double precision, pointer :: b(:, :, :, :) + integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) + integer :: i1, i2, i3, i4 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i4 = mlind(4), muind(4) + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) + end do + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPDouble4 +! +! +! +!=============================================================================== + subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + double precision, allocatable, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + double precision, allocatable :: temp(:, :, :, :) + integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & + new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3), & + data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & + data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocDouble4 + subroutine reallocPLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + logical, pointer, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + logical, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + logical, pointer :: b(:, :) + integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) + integer :: i1, i2 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPLogical2 +! +! +! +!=============================================================================== subroutine reallocLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE + implicit none + logical, allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + logical, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + logical, allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if end subroutine reallocLogical2 +! +! +! +!=============================================================================== + subroutine reallocPLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + logical, pointer, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + logical, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting - subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_TEMP character(len=len(arr)) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocCharacter2 + logical, pointer :: b(:, :, :) + integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) + integer :: i1, i2, i3 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize - subroutine reallocBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocBool2 + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1/) + end if - subroutine reallocByte2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer(kind=1) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocByte2 + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPLogical3 +! +! +! +!=============================================================================== + subroutine reallocLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + logical, allocatable, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + logical, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + logical, allocatable :: temp(:, :, :) + integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocLogical3 +! +! +! +!=============================================================================== + subroutine reallocPLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + logical, pointer, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + logical, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting + + logical, pointer :: b(:, :, :, :) + integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) + integer :: i1, i2, i3, i4 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i4 = mlind(4), muind(4) + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) + end do + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPLogical4 ! -!=============================================================================== -! Rank 2 - pointer ! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#define DATTR pointer -#define IS_ALLOCATED(x) associated(x) -#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp ! !=============================================================================== - subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPDouble2 + subroutine reallocLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + logical, allocatable, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + logical, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting - subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPReal2 + logical, allocatable :: temp(:, :, :, :) + integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds - subroutine reallocPInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPInt2 + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex - subroutine reallocPLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPLogical2 + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if - subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_TEMP character(len=len(arr)) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPCharacter2 + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & + new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3), & + data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & + data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocLogical4 subroutine reallocPBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE + implicit none + logical(kind=c_bool), pointer, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + logical(kind=c_bool), intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + logical(kind=c_bool), pointer :: b(:, :) + integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) + integer :: i1, i2 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr end subroutine reallocPBool2 ! -!=============================================================================== -! End rank 2 ! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#undef DINDEX -#undef ALLOCATE_TEMP -#undef OVERLAP_NONEMPTY -#undef COPY_SECTION -#undef DRANK ! !=============================================================================== + subroutine reallocBool2(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool + implicit none + logical(kind=c_bool), allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + logical(kind=c_bool), intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting + + logical(kind=c_bool), allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocBool2 ! -!=============================================================================== -! Rank 3 - shared macros ! -#define DRANK (:,:,:) -#define DINDEX integer, dimension(3) -#define ALLOCATE_TEMP allocate(temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3))) -#define OVERLAP_NONEMPTY all(data_l_index <= data_u_index) -#define COPY_SECTION temp(data_l_index(1):data_u_index(1), data_l_index(2):data_u_index(2), data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) ! !=============================================================================== -! Rank 3 - allocatable + subroutine reallocPBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool + implicit none + logical(kind=c_bool), pointer, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + logical(kind=c_bool), intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting + + logical(kind=c_bool), pointer :: b(:, :, :) + integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) + integer :: i1, i2, i3 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1/) + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0/) + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3)) + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPBool3 +! ! -#define DATTR allocatable -#define IS_ALLOCATED(x) allocated(x) -#define MOVE_ALLOC call move_alloc(temp, arr) ! !=============================================================================== - subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocDouble3 + subroutine reallocBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool + implicit none + logical(kind=c_bool), allocatable, intent(inout) :: arr(:, :, :) + integer, intent(in) :: uindex(3) + integer, intent(in), optional :: lindex(3) + integer, intent(out), optional :: stat + logical(kind=c_bool), intent(in), optional :: fill + integer, intent(in), optional :: shift(3) + logical, intent(in), optional :: keepExisting - subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocReal3 + logical(kind=c_bool), allocatable :: temp(:, :, :) + integer :: original_l_index(3), original_u_index(3), data_l_index(3), data_u_index(3), new_l_index(3), new_u_index(3), shift_(3) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds - subroutine reallocInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocInt3 + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex - subroutine reallocLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocLogical3 + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if - subroutine reallocCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_TEMP character(len=len(arr)) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocCharacter3 + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if - subroutine reallocBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if end subroutine reallocBool3 ! -!=============================================================================== -! Rank 3 - pointer ! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#define DATTR pointer -#define IS_ALLOCATED(x) associated(x) -#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp ! !=============================================================================== - subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPDouble3 + subroutine reallocPBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool + implicit none + logical(kind=c_bool), pointer, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + logical(kind=c_bool), intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting - subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPReal3 + logical(kind=c_bool), pointer :: b(:, :, :, :) + integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) + integer :: i1, i2, i3, i4 + integer :: localErr + logical :: keepExisting_ + logical :: equalSize - subroutine reallocPInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPInt3 + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = (/1, 1, 1, 1/) + end if - subroutine reallocPLogical3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPLogical3 + if (present(shift)) then + shift_ = shift + else + shift_ = (/0, 0, 0, 0/) + end if - subroutine reallocPCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_TEMP character(len=len(arr)) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPCharacter3 + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if - subroutine reallocPBool3(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPBool3 -! -!=============================================================================== -! End rank 3 -! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#undef DRANK -#undef DINDEX -#undef ALLOCATE_TEMP -#undef OVERLAP_NONEMPTY -#undef COPY_SECTION -!=============================================================================== -! -!=============================================================================== -! Rank 4 - shared macros + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr) + lind = lbound(arr) + equalSize = all(uindex == uind) .and. all(lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if ! -#define DRANK (:,:,:,:) -#define DINDEX integer, dimension(4) -#define ALLOCATE_TEMP allocate(temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4))) -#define OVERLAP_NONEMPTY all(data_l_index <= data_u_index) -#define COPY_SECTION temp(data_l_index(1):data_u_index(1), data_l_index(2):data_u_index(2), data_l_index(3):data_u_index(3), data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2), lindex_(3):uindex(3), lindex_(4):uindex(4)), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i4 = mlind(4), muind(4) + do i3 = mlind(3), muind(3) + do i2 = mlind(2), muind(2) + do i1 = mlind(1), muind(1) + arr(i1, i2, i3, i4) = b(i1 - shift_(1), i2 - shift_(2), i3 - shift_(3), i4 - shift_(4)) + end do + end do + end do + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPBool4 ! -!=============================================================================== -! Rank 4 - allocatable ! -#define DATTR allocatable -#define IS_ALLOCATED(x) allocated(x) -#define MOVE_ALLOC call move_alloc(temp, arr) ! !=============================================================================== - subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocDouble4 + subroutine reallocBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) + use stdlib_kinds, only: c_bool + implicit none + logical(kind=c_bool), allocatable, intent(inout) :: arr(:, :, :, :) + integer, intent(in) :: uindex(4) + integer, intent(in), optional :: lindex(4) + integer, intent(out), optional :: stat + logical(kind=c_bool), intent(in), optional :: fill + integer, intent(in), optional :: shift(4) + logical, intent(in), optional :: keepExisting - subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocReal4 + logical(kind=c_bool), allocatable :: temp(:, :, :, :) + integer :: original_l_index(4), original_u_index(4), data_l_index(4), data_u_index(4), new_l_index(4), new_u_index(4), shift_(4) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds - subroutine reallocInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocInt4 + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex - subroutine reallocLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocLogical4 + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if - subroutine reallocCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_TEMP character(len=len(arr)) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocCharacter4 + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if - subroutine reallocBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2), & + new_l_index(3):new_u_index(3), new_l_index(4):new_u_index(4)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2), & + data_l_index(3):data_u_index(3), & + data_l_index(4):data_u_index(4)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2), & + data_l_index(3) - shift_(3):data_u_index(3) - shift_(3), & + data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if end subroutine reallocBool4 ! -!=============================================================================== -! Rank 4 - pointer ! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#define DATTR pointer -#define IS_ALLOCATED(x) associated(x) -#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp ! !=============================================================================== - subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPDouble4 + subroutine reallocByte2(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + integer(kind=1), allocatable, intent(inout) :: arr(:, :) + integer, intent(in) :: uindex(2) + integer, intent(in), optional :: lindex(2) + integer, intent(out), optional :: stat + integer, intent(in), optional :: fill + integer, intent(in), optional :: shift(2) + logical, intent(in), optional :: keepExisting - subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPReal4 + integer(kind=1), allocatable :: temp(:, :) + integer :: original_l_index(2), original_u_index(2), data_l_index(2), data_u_index(2), new_l_index(2), new_u_index(2), shift_(2) + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds - subroutine reallocPInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPInt4 + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex - subroutine reallocPLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPLogical4 + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if - subroutine reallocPCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_TEMP character(len=len(arr)) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPCharacter4 + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if - subroutine reallocPBool4(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPBool4 + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr) + original_u_index = ubound(arr) + equal_bounds = all(new_l_index == original_l_index) .and. all(new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. all(shift_ == 0)) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index(1):new_u_index(1), new_l_index(2):new_u_index(2)), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (present(fill)) then + temp = fill + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index(1):data_u_index(1), & + data_l_index(2):data_u_index(2)) = arr(data_l_index(1) - shift_(1):data_u_index(1) - shift_(1), & + data_l_index(2) - shift_(2):data_u_index(2) - shift_(2)) + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocByte2 +! ! -!=============================================================================== -! End rank 4 ! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#undef DRANK -#undef DINDEX -#undef ALLOCATE_TEMP -#undef OVERLAP_NONEMPTY -#undef COPY_SECTION -#undef BOUNDS_UNCHANGED !=============================================================================== + +!> Determines size of an allocatable array, returning 0 when it is not allocated. + function allocSizeDouble(arr) result(isize) + implicit none + double precision, allocatable, intent(inout) :: arr(:) !< Array for which the extent must be determined. Is allowed to be not allocated. + integer :: isize !< Array length, 0 when it was not allocated. + + if (allocated(arr)) then + isize = size(arr) + else + isize = 0 + end if + end function allocSizeDouble + +!> Allocate or reallocate an integer array. At first the size will be set to 10, in case of a realloc +!! the size of the array is doubled. + subroutine reserve_sufficient_space_int(arr, required_size, fill) + integer, allocatable, dimension(:), intent(inout) :: arr !< Array for which the resize might be required. + integer, intent(in) :: required_size !< Minimal required size of the array. + integer, intent(in) :: fill !< Fill value for the new values. + + integer length + if (allocated(arr)) then + if (required_size > size(arr)) then + length = max(required_size, 2 * size(arr)) + call realloc(arr, length, fill=fill, keepexisting=.true.) + end if + else + length = max(required_size, 10) + call realloc(arr, length, fill=fill) + end if + end subroutine reserve_sufficient_space_int + end module m_alloc diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc index e4ff41d25d1..b3d971a46e8 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc @@ -1,21 +1,20 @@ - implicit none - DTYPE, DATTR, intent(inout) :: arr DRANK - DINDEX, intent(in) :: uindex - DINDEX, intent(in), optional :: lindex + DTYPE, DATTR, intent(inout) :: arr(:) + integer, intent(in) :: uindex + integer, intent(in), optional :: lindex integer, intent(out), optional :: stat DTYPE, intent(in), optional :: fill - DINDEX, intent(in), optional :: shift + integer, intent(in), optional :: shift logical, intent(in), optional :: keepExisting -#ifndef DTYPE_TEMP -#define DTYPE_TEMP DTYPE +#ifdef DTYPE_CHAR + character(len=len(arr)), DATTR :: temp(:) +#else + DTYPE, DATTR :: temp(:) #endif - DTYPE_TEMP, DATTR :: temp DRANK -#undef DTYPE_TEMP - DINDEX :: old_l_index, old_u_index - DINDEX :: new_l_index, new_u_index - DINDEX :: data_l_index, data_u_index - DINDEX :: shift_ + integer :: old_l_index, old_u_index + integer :: new_l_index, new_u_index + integer :: data_l_index, data_u_index + integer :: shift_ logical :: keepExisting_ logical :: allocated_old @@ -34,16 +33,17 @@ allocated_old = IS_ALLOCATED(arr) if (allocated_old) then - GET_BOUNDS + old_l_index = lbound(arr, 1) + old_u_index = ubound(arr, 1) - if (BOUNDS_UNCHANGED) then + if (new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0) then if (.not. keepExisting_ .and. present(fill)) arr = fill return end if end if ! Reallocation required - ALLOCATE_TEMP + allocate(temp(new_l_index:new_u_index)) if (present(fill)) temp = fill @@ -53,8 +53,8 @@ ! arr access below is safe, because: ! data_l_index - shift_ >= (old_l_index + shift_) - shift_ = old_l_index ! data_u_index - shift_ <= (old_u_index + shift_) - shift_ = old_u_index - if (OVERLAP_NONEMPTY) then - COPY_SECTION + if (data_l_index <= data_u_index) then + temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) end if end if From 8bc1d0505179cdd6f533a4aa59b875d11e999022 Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Wed, 1 Apr 2026 13:19:49 +0200 Subject: [PATCH 4/7] restore error checking --- .../src/malloc_includes/malloc_body.inc | 42 ++++++++++++++----- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc index b3d971a46e8..9b812c3564e 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc @@ -15,20 +15,28 @@ integer :: new_l_index, new_u_index integer :: data_l_index, data_u_index integer :: shift_ + integer :: local_err logical :: keepExisting_ logical :: allocated_old - if (present(stat)) stat = 0 - + local_err = 0 new_l_index = 1 - if (present(lindex)) new_l_index = lindex new_u_index = uindex - shift_ = 0 - if (present(shift)) shift_ = shift - keepExisting_ = .true. - if (present(keepExisting)) keepExisting_ = keepExisting + + if (present(stat)) then + stat = 0 + end if + if (present(lindex)) then + new_l_index = lindex + end if + if (present(shift)) then + shift_ = shift + end if + if (present(keepExisting)) then + keepExisting_ = keepExisting + end if allocated_old = IS_ALLOCATED(arr) @@ -37,15 +45,22 @@ old_u_index = ubound(arr, 1) if (new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0) then - if (.not. keepExisting_ .and. present(fill)) arr = fill + if (.not. keepExisting_ .and. present(fill)) then + arr = fill + end if return end if end if ! Reallocation required - allocate(temp(new_l_index:new_u_index)) + allocate(temp(new_l_index:new_u_index), stat=local_err) + if (local_err /= 0) then + goto 999 + end if - if (present(fill)) temp = fill + if (present(fill)) then + temp = fill + end if if (keepExisting_ .and. allocated_old) then data_l_index = max(old_l_index + shift_, new_l_index) @@ -58,4 +73,9 @@ end if end if - MOVE_ALLOC \ No newline at end of file + MOVE_ALLOC + +999 continue + if (present(stat)) then + stat = local_err + end if \ No newline at end of file From f3112d1ea9cccef351c9d2422c5627cd28d8112b Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Wed, 1 Apr 2026 14:52:35 +0200 Subject: [PATCH 5/7] macro function, duplication for pointers/allocatables --- .../packages/deltares_common/src/malloc.f90 | 118 ++-------- .../src/malloc_includes/malloc_body.inc | 212 +++++++++++------- 2 files changed, 147 insertions(+), 183 deletions(-) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 index 27941de2f74..b168654789d 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 @@ -28,6 +28,8 @@ ! !> Utility routines for memory (re)allocation. module m_alloc + use stdlib_kinds, only: c_bool + implicit none private @@ -204,111 +206,21 @@ subroutine aerr(name, iostat, isize, errmsg) end subroutine aerr -!=============================================================================== -! Rank 1 - allocatable -! -#define DATTR allocatable -#define IS_ALLOCATED(x) allocated(x) -#define MOVE_ALLOC call move_alloc(temp, arr) -! -!=============================================================================== - subroutine reallocDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocDouble - - subroutine reallocReal(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real #include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocReal - - subroutine reallocInt(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocInt - - subroutine reallocLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocLogical - - subroutine reallocCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_CHAR -#include "malloc_includes/malloc_body.inc" -#undef DTYPE_CHAR -#undef DTYPE - end subroutine reallocCharacter - - subroutine reallocBool(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocBool -! -!=============================================================================== -! Rank 1 - pointer -! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -#define DATTR pointer -#define IS_ALLOCATED(x) associated(x) -#define MOVE_ALLOC if (associated(arr)) deallocate(arr); arr => temp -! -!=============================================================================== - subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE double precision -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPDouble - - subroutine reallocPReal(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE real -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPReal - - subroutine reallocPInt(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE integer -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPInt - - subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE logical -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPLogical - - subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) -#define DTYPE character(len=*) -#define DTYPE_CHAR -#include "malloc_includes/malloc_body.inc" -#undef DTYPE_CHAR -#undef DTYPE - end subroutine reallocPCharacter - - subroutine reallocPBool(arr, uindex, lindex, stat, fill, shift, keepExisting) - use stdlib_kinds, only: c_bool -#define DTYPE logical(kind=c_bool) -#include "malloc_includes/malloc_body.inc" -#undef DTYPE - end subroutine reallocPBool -! -!=============================================================================== -! End rank 1 -! -#undef DATTR -#undef IS_ALLOCATED -#undef MOVE_ALLOC -!=============================================================================== + REALLOC1(reallocDouble, double precision) + REALLOC1(reallocReal, real) + REALLOC1(reallocInt, integer) + REALLOC1(reallocLogical, logical) + REALLOC1(reallocBool, logical(kind=c_bool)) + REALLOC1(reallocCharacter, character) + + REALLOC1P(reallocPDouble, double precision) + REALLOC1P(reallocPReal, real) + REALLOC1P(reallocPInt, integer) + REALLOC1P(reallocPLogical, logical) + REALLOC1P(reallocPBool, logical(kind=c_bool)) + REALLOC1P(reallocPCharacter, character) !=============================================================================== subroutine reallocReal2x(arr, u1, u2, l1, l2, stat, keepExisting) real, allocatable, intent(inout) :: arr(:, :) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc index 9b812c3564e..e0b2bd7a808 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc @@ -1,81 +1,133 @@ - DTYPE, DATTR, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex - integer, intent(out), optional :: stat - DTYPE, intent(in), optional :: fill - integer, intent(in), optional :: shift - logical, intent(in), optional :: keepExisting +#define REALLOC1(SUBNAME, DTYPE) \ + subroutine SUBNAME(arr, uindex, lindex, stat, fill, shift, keepExisting); \ + implicit none; \ + DTYPE, allocatable, intent(inout) :: arr(:); \ + integer, intent(in) :: uindex; \ + integer, intent(in), optional :: lindex; \ + integer, intent(out), optional :: stat; \ + DTYPE, intent(in), optional :: fill; \ + integer, intent(in), optional :: shift; \ + logical, intent(in), optional :: keepExisting; \ + DTYPE, allocatable :: temp(:); \ + integer :: old_l_index, old_u_index; \ + integer :: new_l_index, new_u_index; \ + integer :: data_l_index, data_u_index; \ + integer :: shift_; \ + integer :: local_err; \ + logical :: keepExisting_; \ + logical :: allocated_old; \ + allocated_old = allocated(arr); \ + local_err = 0; \ + new_l_index = 1; \ + new_u_index = uindex; \ + shift_ = 0; \ + keepExisting_ = .true.; \ + if (present(lindex)) then; \ + new_l_index = lindex; \ + end if; \ + if (present(shift)) then; \ + shift_ = shift; \ + end if; \ + if (present(keepExisting)) then; \ + keepExisting_ = keepExisting; \ + end if; \ + if (allocated_old) then; \ + old_l_index = lbound(arr, 1); \ + old_u_index = ubound(arr, 1); \ + if (new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0) then; \ + if (.not. keepExisting_ .and. present(fill)) then; \ + arr = fill; \ + end if; \ + return; \ + end if; \ + end if; \ + allocate(temp(new_l_index:new_u_index), stat=local_err); \ + if (local_err /= 0) then; \ + goto 999; \ + end if; \ + if (present(fill)) then; \ + temp = fill; \ + end if; \ + if (keepExisting_ .and. allocated_old) then; \ + data_l_index = max(old_l_index + shift_, new_l_index); \ + data_u_index = min(old_u_index + shift_, new_u_index); \ + if (data_l_index <= data_u_index) then; \ + temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_); \ + end if; \ + end if; \ + call move_alloc(temp, arr); \ +999 continue; \ + if (present(stat)) then; \ + stat = local_err; \ + end if; \ + end subroutine SUBNAME -#ifdef DTYPE_CHAR - character(len=len(arr)), DATTR :: temp(:) -#else - DTYPE, DATTR :: temp(:) -#endif - integer :: old_l_index, old_u_index - integer :: new_l_index, new_u_index - integer :: data_l_index, data_u_index - integer :: shift_ - integer :: local_err - logical :: keepExisting_ - logical :: allocated_old - - local_err = 0 - new_l_index = 1 - new_u_index = uindex - shift_ = 0 - keepExisting_ = .true. - - if (present(stat)) then - stat = 0 - end if - if (present(lindex)) then - new_l_index = lindex - end if - if (present(shift)) then - shift_ = shift - end if - if (present(keepExisting)) then - keepExisting_ = keepExisting - end if - - allocated_old = IS_ALLOCATED(arr) - - if (allocated_old) then - old_l_index = lbound(arr, 1) - old_u_index = ubound(arr, 1) - - if (new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0) then - if (.not. keepExisting_ .and. present(fill)) then - arr = fill - end if - return - end if - end if - - ! Reallocation required - allocate(temp(new_l_index:new_u_index), stat=local_err) - if (local_err /= 0) then - goto 999 - end if - - if (present(fill)) then - temp = fill - end if - - if (keepExisting_ .and. allocated_old) then - data_l_index = max(old_l_index + shift_, new_l_index) - data_u_index = min(old_u_index + shift_, new_u_index) - ! arr access below is safe, because: - ! data_l_index - shift_ >= (old_l_index + shift_) - shift_ = old_l_index - ! data_u_index - shift_ <= (old_u_index + shift_) - shift_ = old_u_index - if (data_l_index <= data_u_index) then - temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) - end if - end if - - MOVE_ALLOC - -999 continue - if (present(stat)) then - stat = local_err - end if \ No newline at end of file +#define REALLOC1P(SUBNAME, DTYPE) \ + subroutine SUBNAME(arr, uindex, lindex, stat, fill, shift, keepExisting); \ + implicit none; \ + DTYPE, pointer, intent(inout) :: arr(:); \ + integer, intent(in) :: uindex; \ + integer, intent(in), optional :: lindex; \ + integer, intent(out), optional :: stat; \ + DTYPE, intent(in), optional :: fill; \ + integer, intent(in), optional :: shift; \ + logical, intent(in), optional :: keepExisting; \ + DTYPE, pointer :: temp(:); \ + integer :: old_l_index, old_u_index; \ + integer :: new_l_index, new_u_index; \ + integer :: data_l_index, data_u_index; \ + integer :: shift_; \ + integer :: local_err; \ + logical :: keepExisting_; \ + logical :: allocated_old; \ + allocated_old = associated(arr); \ + local_err = 0; \ + new_l_index = 1; \ + new_u_index = uindex; \ + shift_ = 0; \ + keepExisting_ = .true.; \ + if (present(stat)) then; \ + stat = 0; \ + end if; \ + if (present(lindex)) then; \ + new_l_index = lindex; \ + end if; \ + if (present(shift)) then; \ + shift_ = shift; \ + end if; \ + if (present(keepExisting)) then; \ + keepExisting_ = keepExisting; \ + end if; \ + if (allocated_old) then; \ + old_l_index = lbound(arr, 1); \ + old_u_index = ubound(arr, 1); \ + if (new_l_index == old_l_index .and. new_u_index == old_u_index .and. shift_ == 0) then; \ + if (.not. keepExisting_ .and. present(fill)) then; \ + arr = fill; \ + end if; \ + return; \ + end if; \ + end if; \ + allocate(temp(new_l_index:new_u_index), stat=local_err); \ + if (local_err /= 0) then; \ + goto 999; \ + end if; \ + if (present(fill)) then; \ + temp = fill; \ + end if; \ + if (keepExisting_ .and. allocated_old) then; \ + data_l_index = max(old_l_index + shift_, new_l_index); \ + data_u_index = min(old_u_index + shift_, new_u_index); \ + if (data_l_index <= data_u_index) then; \ + temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_); \ + end if; \ + end if; \ + if (associated(arr)) then; \ + deallocate(arr); \ + end if; \ + arr => temp; \ +999 continue; \ + if (present(stat)) then; \ + stat = local_err; \ + end if; \ + end subroutine SUBNAME \ No newline at end of file From 08dcb9355318398e2a675ee5597dfd07c8311d24 Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Wed, 1 Apr 2026 15:33:55 +0200 Subject: [PATCH 6/7] revert character macro functions, they don't work --- .../packages/deltares_common/src/malloc.f90 | 143 +++++++++++++++++- 1 file changed, 140 insertions(+), 3 deletions(-) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 index b168654789d..181cdda6b69 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 @@ -213,15 +213,152 @@ end subroutine aerr REALLOC1(reallocInt, integer) REALLOC1(reallocLogical, logical) REALLOC1(reallocBool, logical(kind=c_bool)) - REALLOC1(reallocCharacter, character) REALLOC1P(reallocPDouble, double precision) REALLOC1P(reallocPReal, real) REALLOC1P(reallocPInt, integer) REALLOC1P(reallocPLogical, logical) REALLOC1P(reallocPBool, logical(kind=c_bool)) - REALLOC1P(reallocPCharacter, character) -!=============================================================================== + + subroutine reallocCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), allocatable, intent(inout) :: arr(:) + integer, intent(in) :: uindex + integer, intent(in), optional :: lindex + integer, intent(out), optional :: stat + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift + logical, intent(in), optional :: keepExisting + + character(len=len(arr)), allocatable :: temp(:) + integer :: original_l_index, original_u_index, data_l_index, data_u_index, new_l_index, new_u_index, shift_ + integer :: local_err + logical :: keepExisting_ + logical :: equal_bounds + + if (present(lindex)) then + new_l_index = lindex + else + new_l_index = 1 + end if + new_u_index = uindex + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + local_err = 0 + if (allocated(arr)) then + original_l_index = lbound(arr, dim=1) + original_u_index = ubound(arr, dim=1) + equal_bounds = (new_l_index == original_l_index) .and. (new_u_index == original_u_index) + if (equal_bounds .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then + goto 999 ! output=input + end if + end if + + allocate (temp(new_l_index:new_u_index), stat=local_err) + if (local_err /= 0) then + goto 999 + end if + + if (keepExisting_ .and. allocated(arr)) then + data_l_index = max(original_l_index + shift_, new_l_index) + data_u_index = min(original_u_index + shift_, new_u_index) + ! arr access below is safe, because: + ! data_l_index - shift_ >= (original_l_index + shift_) - shift_ = original_l_index + ! data_u_index - shift_ <= (original_u_index + shift_) - shift_ = original_u_index + temp(data_l_index:data_u_index) = arr(data_l_index - shift_:data_u_index - shift_) + if (present(fill)) then + temp(new_l_index:data_l_index - 1) = fill + temp(data_u_index + 1:new_u_index) = fill + end if + elseif (present(fill)) then + temp = fill + end if + call move_alloc(temp, arr) +999 continue + if (present(stat)) then + stat = local_err + end if + end subroutine reallocCharacter + + subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) + implicit none + character(len=*), pointer, intent(inout) :: arr(:) + integer, intent(in) :: uindex + integer, optional, intent(in) :: lindex + integer, optional, intent(out) :: stat + character(len=*), optional, intent(in) :: fill + integer, optional, intent(in) :: shift + logical, optional, intent(in) :: keepExisting + + character(len=len(arr)), pointer :: b(:) + integer :: uind, lind, muind, mlind, lindex_, shift_, i + integer :: localErr + logical :: keepExisting_ + logical :: equalSize + + if (present(lindex)) then + lindex_ = lindex + else + lindex_ = 1 + end if + + if (present(shift)) then + shift_ = shift + else + shift_ = 0 + end if + + if (present(keepExisting)) then + keepExisting_ = keepExisting + else + keepExisting_ = .true. + end if + + if (present(stat)) stat = 0 + localErr = 0 + nullify (b) + if (associated(arr)) then + uind = ubound(arr, 1) + lind = lbound(arr, 1) + equalSize = (uindex == uind) .and. (lindex_ == lind) + if (equalSize .and. (keepExisting_ .or. .not. present(fill)) .and. shift_ == 0) then + goto 999 ! output=input + end if +! + if (keepExisting_) then + mlind = max(lind + shift_, lindex_) + muind = min(uind + shift_, uindex) + b => arr + nullify (arr) + elseif (.not. equalSize) then + deallocate (arr, stat=localErr) + end if + end if + if (.not. associated(arr) .and. localErr == 0) then + allocate (arr(lindex_:uindex), stat=localErr) + end if + if (present(fill) .and. localErr == 0) arr = fill + if (associated(b) .and. localErr == 0 .and. size(b) > 0) then + do i = mlind, muind + arr(i) = b(i - shift_) + end do + deallocate (b, stat=localErr) + end if +999 continue + if (present(stat)) stat = localErr + end subroutine reallocPCharacter + subroutine reallocReal2x(arr, u1, u2, l1, l2, stat, keepExisting) real, allocatable, intent(inout) :: arr(:, :) integer :: u1, u2 From a9efed2e47cb1b376bd99137eb36a8c0fb3f43ff Mon Sep 17 00:00:00 2001 From: FlorisBuwaldaDeltares Date: Wed, 1 Apr 2026 16:15:32 +0200 Subject: [PATCH 7/7] double precision => real(dp) --- .../packages/deltares_common/src/malloc.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 index 181cdda6b69..32f3ad18ea0 100644 --- a/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc.f90 @@ -29,7 +29,7 @@ !> Utility routines for memory (re)allocation. module m_alloc use stdlib_kinds, only: c_bool - + use precision, only: sp, dp implicit none private @@ -208,14 +208,14 @@ end subroutine aerr #include "malloc_includes/malloc_body.inc" - REALLOC1(reallocDouble, double precision) - REALLOC1(reallocReal, real) + REALLOC1(reallocDouble, real(dp)) + REALLOC1(reallocReal, real(sp)) REALLOC1(reallocInt, integer) REALLOC1(reallocLogical, logical) REALLOC1(reallocBool, logical(kind=c_bool)) - REALLOC1P(reallocPDouble, double precision) - REALLOC1P(reallocPReal, real) + REALLOC1P(reallocPDouble, real(dp)) + REALLOC1P(reallocPReal, real(sp)) REALLOC1P(reallocPInt, integer) REALLOC1P(reallocPLogical, logical) REALLOC1P(reallocPBool, logical(kind=c_bool))