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..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 @@ -28,6 +28,8 @@ ! !> Utility routines for memory (re)allocation. module m_alloc + use stdlib_kinds, only: c_bool + use precision, only: sp, dp implicit none private @@ -203,646 +205,33 @@ subroutine aerr(name, iostat, isize, errmsg) end if end subroutine aerr -! -! -! -!=============================================================================== - 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 -! -! -! -!=============================================================================== - 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 -! -! -! -!=============================================================================== - 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 - - 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 - - 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 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 - - integer, 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 reallocPInt -! -! -! -!=============================================================================== - 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 - - 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 reallocInt -! -! -! -!=============================================================================== - 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 +#include "malloc_includes/malloc_body.inc" - if (present(shift)) then - shift_ = shift - else - shift_ = (/0, 0, 0, 0/) - end if + REALLOC1(reallocDouble, real(dp)) + REALLOC1(reallocReal, real(sp)) + REALLOC1(reallocInt, integer) + REALLOC1(reallocLogical, logical) + REALLOC1(reallocBool, logical(kind=c_bool)) - if (present(keepExisting)) then - keepExisting_ = keepExisting - else - keepExisting_ = .true. - end if + REALLOC1P(reallocPDouble, real(dp)) + REALLOC1P(reallocPReal, real(sp)) + REALLOC1P(reallocPInt, integer) + REALLOC1P(reallocPLogical, logical) + REALLOC1P(reallocPBool, logical(kind=c_bool)) - 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) + subroutine reallocCharacter(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) + character(len=*), 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(4) + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift 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) + 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 @@ -868,49 +257,41 @@ subroutine reallocInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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(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) + 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(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)) + 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 reallocInt4 -! -! -! -!=============================================================================== - subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) + end subroutine reallocCharacter + + subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none character(len=*), pointer, intent(inout) :: arr(:) integer, intent(in) :: uindex @@ -977,95 +358,116 @@ subroutine reallocPCharacter(arr, uindex, lindex, stat, fill, shift, keepExistin 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 + 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 ! ! ! !=============================================================================== - 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 + 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 - 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 + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocDouble2(arr, uindex, lindex, stat=stat) else - new_l_index = 1 + call reallocDouble2(arr, uindex, stat=stat) end if - new_u_index = uindex + end subroutine reallocDouble2x +! +! +! +!=============================================================================== + 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 - if (present(shift)) then - shift_ = shift + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocInt2(arr, uindex, lindex, stat=stat) else - shift_ = 0 + 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 - if (present(keepExisting)) then - keepExisting_ = keepExisting + uindex = (/u1, u2/) + if (present(l1)) then + lindex = (/l1, l2/) + call reallocCharacter2(arr, uindex, lindex, stat=stat) 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 + 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 - 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 + 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 reallocCharacter -! -! -! -!=============================================================================== - subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) + end subroutine reallocReal3x + + subroutine reallocPInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=*), pointer, intent(inout) :: arr(:, :) + integer, 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 :: fill integer, intent(in), optional :: shift(2) logical, intent(in), optional :: keepExisting - character(len=len(arr)), pointer :: b(:, :) + integer, pointer :: b(:, :) integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) integer :: i1, i2 integer :: localErr @@ -1124,22 +526,22 @@ subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisti end if 999 continue if (present(stat)) stat = localErr - end subroutine reallocPCharacter2 + end subroutine reallocPInt2 ! ! ! !=============================================================================== - subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocInt2(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :) + integer, 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 :: fill integer, intent(in), optional :: shift(2) logical, intent(in), optional :: keepExisting - character(len=len(arr)), allocatable :: temp(:, :) + 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_ @@ -1198,22 +600,22 @@ subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExistin if (present(stat)) then stat = local_err end if - end subroutine reallocCharacter2 + end subroutine reallocInt2 ! ! ! !=============================================================================== - subroutine reallocPCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=*), pointer, intent(inout) :: arr(:, :, :) + integer, 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 :: fill integer, intent(in), optional :: shift(3) logical, intent(in), optional :: keepExisting - character(len=len(arr)), pointer :: b(:, :, :) + integer, pointer :: b(:, :, :) integer :: uind(3), lind(3), muind(3), mlind(3), lindex_(3), shift_(3) integer :: i1, i2, i3 integer :: localErr @@ -1274,22 +676,22 @@ subroutine reallocPCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisti end if 999 continue if (present(stat)) stat = localErr - end subroutine reallocPCharacter3 + end subroutine reallocPInt3 ! ! ! !=============================================================================== - subroutine reallocCharacter3(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocInt3(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :, :) + integer, 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 :: fill integer, intent(in), optional :: shift(3) logical, intent(in), optional :: keepExisting - character(len=len(arr)), allocatable :: temp(:, :, :) + 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_ @@ -1350,22 +752,22 @@ subroutine reallocCharacter3(arr, uindex, lindex, stat, fill, shift, keepExistin if (present(stat)) then stat = local_err end if - end subroutine reallocCharacter3 + end subroutine reallocInt3 ! ! ! !=============================================================================== - subroutine reallocPCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=*), pointer, intent(inout) :: arr(:, :, :, :) + integer, 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 :: fill integer, intent(in), optional :: shift(4) logical, intent(in), optional :: keepExisting - character(len=len(arr)), pointer :: b(:, :, :, :) + integer, pointer :: b(:, :, :, :) integer :: uind(4), lind(4), muind(4), mlind(4), lindex_(4), shift_(4) integer :: i1, i2, i3, i4 integer :: localErr @@ -1428,22 +830,22 @@ subroutine reallocPCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisti end if 999 continue if (present(stat)) stat = localErr - end subroutine reallocPCharacter4 + end subroutine reallocPInt4 ! ! ! !=============================================================================== - subroutine reallocCharacter4(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocInt4(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=*), allocatable, intent(inout) :: arr(:, :, :, :) + integer, 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 :: fill integer, intent(in), optional :: shift(4) logical, intent(in), optional :: keepExisting - character(len=len(arr)), allocatable :: temp(:, :, :, :) + 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_ @@ -1507,124 +909,21 @@ subroutine reallocCharacter4(arr, uindex, lindex, stat, fill, shift, keepExistin 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_) + end subroutine reallocInt4 - 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) + subroutine reallocPCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - character(len=:), allocatable, intent(inout) :: string - integer, intent(in) :: newlen + 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 + integer, intent(in), optional :: shift(2) 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 + 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 @@ -1632,13 +931,13 @@ subroutine reallocPReal(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = 1 + lindex_ = (/1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = 0 + shift_ = (/0, 0/) end if if (present(keepExisting)) then @@ -1651,10 +950,10 @@ subroutine reallocPReal(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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 ! @@ -1668,34 +967,36 @@ subroutine reallocPReal(arr, uindex, lindex, stat, fill, shift, keepExisting) end if end if if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) + 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 i = mlind, muind - arr(i) = b(i - shift_) + 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 reallocPReal + end subroutine reallocPCharacter2 ! ! ! !=============================================================================== - subroutine reallocReal(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocCharacter2(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - real, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex + character(len=*), 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 + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(2) 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_ + 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 @@ -1721,56 +1022,56 @@ subroutine reallocReal(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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:new_u_index), stat=local_err) + 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: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 + 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 reallocReal + end subroutine reallocCharacter2 ! ! ! !=============================================================================== - subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPCharacter3(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) + character(len=*), 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(2) + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(3) logical, intent(in), optional :: keepExisting - real, pointer :: b(:, :) - integer :: uind(2), lind(2), muind(2), mlind(2), lindex_(2), shift_(2) - integer :: i1, i2 + 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 @@ -1778,13 +1079,13 @@ subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = (/1, 1/) + lindex_ = (/1, 1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = (/0, 0/) + shift_ = (/0, 0, 0/) end if if (present(keepExisting)) then @@ -1814,36 +1115,38 @@ subroutine reallocPReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) end if end if if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + 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 i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + 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 reallocPReal2 + end subroutine reallocPCharacter3 ! ! ! !=============================================================================== - subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocCharacter3(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) + character(len=*), 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(2) + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(3) 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) + 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 @@ -1877,7 +1180,7 @@ subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 @@ -1893,32 +1196,34 @@ subroutine reallocReal2(arr, uindex, lindex, stat, fill, shift, keepExisting) ! 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)) + 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 reallocReal2 + end subroutine reallocCharacter3 ! ! ! !=============================================================================== - subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPCharacter4(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) + character(len=*), 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(3) + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(4) 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 + 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 @@ -1926,13 +1231,13 @@ subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = (/1, 1, 1/) + lindex_ = (/1, 1, 1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = (/0, 0, 0/) + shift_ = (/0, 0, 0, 0/) end if if (present(keepExisting)) then @@ -1962,14 +1267,16 @@ subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 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)) + 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 @@ -1977,23 +1284,23 @@ subroutine reallocPReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) end if 999 continue if (present(stat)) stat = localErr - end subroutine reallocPReal3 + end subroutine reallocPCharacter4 ! ! ! !=============================================================================== - subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocCharacter4(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) + character(len=*), 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(3) + character(len=*), intent(in), optional :: fill + integer, intent(in), optional :: shift(4) 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) + 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 @@ -2027,7 +1334,8 @@ subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 @@ -2044,33 +1352,133 @@ subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) ! 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(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(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 reallocReal3 + end subroutine reallocCharacter4 ! ! ! !=============================================================================== - subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) +!> Helper function to fill a string + subroutine fill_string(string, fill, fill_offset) implicit none - real, pointer, intent(inout) :: arr(:, :, :, :) - integer, intent(in) :: uindex(4) - integer, intent(in), optional :: lindex(4) + 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(4) + integer, intent(in), optional :: shift(2) 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 + 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 @@ -2078,13 +1486,13 @@ subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = (/1, 1, 1, 1/) + lindex_ = (/1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = (/0, 0, 0, 0/) + shift_ = (/0, 0/) end if if (present(keepExisting)) then @@ -2114,40 +1522,36 @@ subroutine reallocPReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 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 + 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 reallocPReal4 + end subroutine reallocPReal2 ! ! ! !=============================================================================== - subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocReal2(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) + 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(4) + integer, intent(in), optional :: shift(2) 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) + + 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 @@ -2181,8 +1585,7 @@ subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 @@ -2198,35 +1601,32 @@ subroutine reallocReal4(arr, uindex, lindex, stat, fill, shift, keepExisting) ! 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)) + 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 reallocReal4 + end subroutine reallocReal2 ! ! ! !=============================================================================== - subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPReal3(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 + 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 - double precision, pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i + 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 @@ -2234,13 +1634,13 @@ subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = 1 + lindex_ = (/1, 1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = 0 + shift_ = (/0, 0, 0/) end if if (present(keepExisting)) then @@ -2253,10 +1653,10 @@ subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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 ! @@ -2270,34 +1670,38 @@ subroutine reallocPDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) end if end if if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) + 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 i = mlind, muind - arr(i) = b(i - shift_) + 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 reallocPDouble + end subroutine reallocPReal3 ! ! ! !=============================================================================== - subroutine reallocDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocReal3(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - double precision, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex + real, 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 + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(3) 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_ + 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 @@ -2323,56 +1727,58 @@ subroutine reallocDouble(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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:new_u_index), stat=local_err) + 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: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 + 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 reallocDouble + end subroutine reallocReal3 ! ! ! !=============================================================================== - subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPReal4(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) + real, 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(2) + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) 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 + 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 @@ -2380,13 +1786,13 @@ subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = (/1, 1/) + lindex_ = (/1, 1, 1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = (/0, 0/) + shift_ = (/0, 0, 0, 0/) end if if (present(keepExisting)) then @@ -2416,36 +1822,40 @@ subroutine reallocPDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) end if end if if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_(1):uindex(1), lindex_(2):uindex(2)), stat=localErr) + 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 i2 = mlind(2), muind(2) - do i1 = mlind(1), muind(1) - arr(i1, i2) = b(i1 - shift_(1), i2 - shift_(2)) + 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 reallocPDouble2 + end subroutine reallocPReal4 ! ! ! !=============================================================================== - subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocReal4(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) + real, 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(2) + real, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) 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) + 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 @@ -2479,7 +1889,8 @@ subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 @@ -2495,32 +1906,33 @@ subroutine reallocDouble2(arr, uindex, lindex, stat, fill, shift, keepExisting) ! 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)) + 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 reallocDouble2 -! -! -! -!=============================================================================== - subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) + end subroutine reallocReal4 + + subroutine reallocPDouble2(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) + 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(3) + integer, intent(in), optional :: shift(2) 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 + 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 @@ -2528,13 +1940,13 @@ subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = (/1, 1, 1/) + lindex_ = (/1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = (/0, 0, 0/) + shift_ = (/0, 0/) end if if (present(keepExisting)) then @@ -2564,38 +1976,36 @@ subroutine reallocPDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 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 + 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 reallocPDouble3 + end subroutine reallocPDouble2 ! ! ! !=============================================================================== - subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocDouble2(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) + 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(3) + integer, intent(in), optional :: shift(2) 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) + 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 @@ -2629,7 +2039,7 @@ subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 @@ -2645,34 +2055,32 @@ subroutine reallocDouble3(arr, uindex, lindex, stat, fill, shift, keepExisting) ! 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)) + 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 reallocDouble3 + end subroutine reallocDouble2 ! ! ! !=============================================================================== - subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPDouble3(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) + 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(4) + integer, intent(in), optional :: shift(3) 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 + 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 @@ -2680,13 +2088,13 @@ subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = (/1, 1, 1, 1/) + lindex_ = (/1, 1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = (/0, 0, 0, 0/) + shift_ = (/0, 0, 0/) end if if (present(keepExisting)) then @@ -2716,16 +2124,14 @@ subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 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 + 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 @@ -2733,23 +2139,23 @@ subroutine reallocPDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) end if 999 continue if (present(stat)) stat = localErr - end subroutine reallocPDouble4 + end subroutine reallocPDouble3 ! ! ! !=============================================================================== - subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocDouble3(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) + 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(4) + integer, intent(in), optional :: shift(3) 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) + 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 @@ -2783,8 +2189,7 @@ subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) 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) + 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 @@ -2801,34 +2206,33 @@ subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) ! 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(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), & - data_l_index(4) - shift_(4):data_u_index(4) - shift_(4)) + 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 reallocDouble4 + end subroutine reallocDouble3 ! ! ! !=============================================================================== - subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocPDouble4(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 + 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 - logical, pointer :: b(:) - integer :: uind, lind, muind, mlind, lindex_, shift_, i + 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 @@ -2836,13 +2240,13 @@ subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) if (present(lindex)) then lindex_ = lindex else - lindex_ = 1 + lindex_ = (/1, 1, 1, 1/) end if if (present(shift)) then shift_ = shift else - shift_ = 0 + shift_ = (/0, 0, 0, 0/) end if if (present(keepExisting)) then @@ -2855,10 +2259,10 @@ subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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 ! @@ -2872,34 +2276,40 @@ subroutine reallocPLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) end if end if if (.not. associated(arr) .and. localErr == 0) then - allocate (arr(lindex_:uindex), stat=localErr) + 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 i = mlind, muind - arr(i) = b(i - shift_) + 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 reallocPLogical + end subroutine reallocPDouble4 ! ! ! !=============================================================================== - subroutine reallocLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) + subroutine reallocDouble4(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none - logical, allocatable, intent(inout) :: arr(:) - integer, intent(in) :: uindex - integer, intent(in), optional :: lindex + double precision, 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 + double precision, intent(in), optional :: fill + integer, intent(in), optional :: shift(4) 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_ + 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 @@ -2925,43 +2335,45 @@ subroutine reallocLogical(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 + 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:new_u_index), stat=local_err) + 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: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 + 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 reallocLogical -! -! -! -!=============================================================================== + end subroutine reallocDouble4 + subroutine reallocPLogical2(arr, uindex, lindex, stat, fill, shift, keepExisting) implicit none logical, pointer, intent(inout) :: arr(:, :) @@ -3415,157 +2827,7 @@ subroutine reallocLogical4(arr, uindex, lindex, stat, fill, shift, keepExisting) 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 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..e0b2bd7a808 --- /dev/null +++ b/src/utils_lgpl/deltares_common/packages/deltares_common/src/malloc_includes/malloc_body.inc @@ -0,0 +1,133 @@ +#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 + +#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