From d0af3abde0335de66e48f01f38f9df05744c47f8 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jun 2020 19:55:54 -0400 Subject: [PATCH 1/6] Fix runtime deallocation error for fields with XL compilers Prior to this commit, MPAS models would fail with the error message "mpas_field_routines.F", line 1981: 1525-109 Error encountered while attempting to deallocate a data object. The program will stop. when using the XL compilers. The issue appears to be that the XL compiler does not allow for deallocation of dummy arguments that have the 'target' attribute. To address these runtime deallocation errors, the mpas_deallocate_field_target routine never deallocates the head pointer for the field; accordingly, the keep_head_ptr optional argument has been removed. ** Note ** : The changes in this commit introduce memory leaks, since the mpas_deallocate_field routine calls mpas_deallocate_field_target, and only nullifies the head pointer of the field after these calls. --- src/framework/mpas_field_routines.F | 316 ++++------------------------ src/framework/mpas_pool_routines.F | 52 ++--- 2 files changed, 65 insertions(+), 303 deletions(-) diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index dea3ab1e25..6ef2c156c1 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -1426,7 +1426,7 @@ subroutine mpas_deallocate_field0d_logical(f)!{{{ type (field0dLogical), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field0d_logical!}}} @@ -1456,7 +1456,7 @@ subroutine mpas_deallocate_field0d_integer(f)!{{{ type (field0dInteger), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field0d_integer!}}} @@ -1486,7 +1486,7 @@ subroutine mpas_deallocate_field1d_integer(f)!{{{ type (field1dInteger), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field1d_integer!}}} @@ -1516,7 +1516,7 @@ subroutine mpas_deallocate_field2d_integer(f)!{{{ type (field2dInteger), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field2d_integer!}}} @@ -1546,7 +1546,7 @@ subroutine mpas_deallocate_field3d_integer(f)!{{{ type (field3dInteger), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field3d_integer!}}} @@ -1576,7 +1576,7 @@ subroutine mpas_deallocate_field0d_real(f)!{{{ type (field0dReal), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field0d_real!}}} @@ -1606,7 +1606,7 @@ subroutine mpas_deallocate_field1d_real(f)!{{{ type (field1dReal), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field1d_real!}}} @@ -1636,7 +1636,7 @@ subroutine mpas_deallocate_field2d_real(f)!{{{ type (field2dReal), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field2d_real!}}} @@ -1666,7 +1666,7 @@ subroutine mpas_deallocate_field3d_real(f)!{{{ type (field3dReal), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field3d_real!}}} @@ -1696,7 +1696,7 @@ subroutine mpas_deallocate_field4d_real(f)!{{{ type (field4dReal), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field4d_real!}}} @@ -1726,7 +1726,7 @@ subroutine mpas_deallocate_field5d_real(f)!{{{ type (field5dReal), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field5d_real!}}} @@ -1756,7 +1756,7 @@ subroutine mpas_deallocate_field0d_char(f)!{{{ type (field0dChar), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field0d_char!}}} @@ -1786,7 +1786,7 @@ subroutine mpas_deallocate_field1d_char(f)!{{{ type (field1dChar), pointer :: f !< Input: Field to deallocate - call mpas_deallocate_field_target(f, keep_head_ptr=.false.) + call mpas_deallocate_field_target(f) nullify(f) end subroutine mpas_deallocate_field1d_char!}}} @@ -1800,35 +1800,21 @@ end subroutine mpas_deallocate_field1d_char!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D logical field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 0D logical field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_logical_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_logical_target(f)!{{{ implicit none type (field0dLogical), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field0dLogical), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -1845,10 +1831,6 @@ subroutine mpas_deallocate_field0d_logical_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -1864,35 +1846,21 @@ end subroutine mpas_deallocate_field0d_logical_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D int field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 0D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_integer_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_integer_target(f)!{{{ implicit none type (field0dInteger), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field0dInteger), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -1909,10 +1877,6 @@ subroutine mpas_deallocate_field0d_integer_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -1928,35 +1892,21 @@ end subroutine mpas_deallocate_field0d_integer_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D int field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 1D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_integer_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field1d_integer_target(f)!{{{ implicit none type (field1dInteger), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field1dInteger), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -1977,10 +1927,6 @@ subroutine mpas_deallocate_field1d_integer_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -1996,37 +1942,21 @@ end subroutine mpas_deallocate_field1d_integer_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 2D int field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> for all blocks other than the first (including the field types themselves) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 2D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field2d_integer_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field2d_integer_target(f)!{{{ implicit none type (field2dInteger), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field2dInteger), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2047,10 +1977,6 @@ subroutine mpas_deallocate_field2d_integer_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2066,35 +1992,21 @@ end subroutine mpas_deallocate_field2d_integer_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 3D int field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 3D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field3d_integer_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field3d_integer_target(f)!{{{ implicit none type (field3dInteger), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field3dInteger), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2115,10 +2027,6 @@ subroutine mpas_deallocate_field3d_integer_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2134,35 +2042,21 @@ end subroutine mpas_deallocate_field3d_integer_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 0D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_real_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_real_target(f)!{{{ implicit none type (field0dReal), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field0dReal), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2179,10 +2073,6 @@ subroutine mpas_deallocate_field0d_real_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2198,35 +2088,21 @@ end subroutine mpas_deallocate_field0d_real_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 1D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_real_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field1d_real_target(f)!{{{ implicit none type (field1dReal), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field1dReal), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2247,10 +2123,6 @@ subroutine mpas_deallocate_field1d_real_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2266,35 +2138,21 @@ end subroutine mpas_deallocate_field1d_real_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 2D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 2D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field2d_real_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field2d_real_target(f)!{{{ implicit none type (field2dReal), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field2dReal), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2315,10 +2173,6 @@ subroutine mpas_deallocate_field2d_real_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2334,37 +2188,21 @@ end subroutine mpas_deallocate_field2d_real_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 3D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> for all blocks other than the first (including the field types themselves) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 3D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field3d_real_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field3d_real_target(f)!{{{ implicit none type (field3dReal), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field3dReal), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2385,10 +2223,6 @@ subroutine mpas_deallocate_field3d_real_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2404,35 +2238,21 @@ end subroutine mpas_deallocate_field3d_real_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 4D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 4D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field4d_real_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field4d_real_target(f)!{{{ implicit none type (field4dReal), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field4dReal), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2453,10 +2273,6 @@ subroutine mpas_deallocate_field4d_real_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2472,35 +2288,21 @@ end subroutine mpas_deallocate_field4d_real_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 5D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 5D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field5d_real_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field5d_real_target(f)!{{{ implicit none type (field5dReal), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field5dReal), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2521,10 +2323,6 @@ subroutine mpas_deallocate_field5d_real_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2540,35 +2338,21 @@ end subroutine mpas_deallocate_field5d_real_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D real field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 0D real field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_char_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field0d_char_target(f)!{{{ implicit none type (field0dChar), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field0dChar), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2585,10 +2369,6 @@ subroutine mpas_deallocate_field0d_char_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if @@ -2604,35 +2384,21 @@ end subroutine mpas_deallocate_field0d_char_target!}}} !> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D char field. If the optional argument -!> keep_head_ptr is .true., the field type pointed to by f will not be -!> deallocated -- only the contents (array, attLists, constituentNames) -!> will be deallocated. -!> -!> The principal use for the keep_head_ptr argument is for situations in -!> which elemements of an array of fields need to be deallocated. +!> This routine deallocates a 1D char field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_char_target(f, keep_head_ptr)!{{{ + subroutine mpas_deallocate_field1d_char_target(f)!{{{ implicit none type (field1dChar), target :: f !< Input: Field to deallocate - logical, intent(in), optional :: keep_head_ptr type (field1dChar), pointer :: f_cursor, f_next - logical :: local_keep_head_ptr integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() - if (present(keep_head_ptr)) then - local_keep_head_ptr = keep_head_ptr - else - local_keep_head_ptr = .false. - end if - if ( threadNum == 0 ) then f_cursor => f do while(associated(f_cursor)) @@ -2653,10 +2419,6 @@ subroutine mpas_deallocate_field1d_char_target(f, keep_head_ptr)!{{{ deallocate(f_cursor % constituentNames) end if - if (.not. local_keep_head_ptr) then - deallocate(f_cursor) - end if - f_cursor => f_next end do end if diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 15afb36de3..f085e06490 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -249,107 +249,107 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ ! Do this through brute force... if (associated(dptr % r0)) then - call mpas_deallocate_field_target(dptr % r0, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r0) deallocate(dptr % r0) else if (associated(dptr % r1)) then - call mpas_deallocate_field_target(dptr % r1, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r1) deallocate(dptr % r1) else if (associated(dptr % r2)) then - call mpas_deallocate_field_target(dptr % r2, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r2) deallocate(dptr % r2) else if (associated(dptr % r3)) then - call mpas_deallocate_field_target(dptr % r3, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r3) deallocate(dptr % r3) else if (associated(dptr % r4)) then - call mpas_deallocate_field_target(dptr % r4, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r4) deallocate(dptr % r4) else if (associated(dptr % r5)) then - call mpas_deallocate_field_target(dptr % r5, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r5) deallocate(dptr % r5) else if (associated(dptr % i0)) then - call mpas_deallocate_field_target(dptr % i0, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i0) deallocate(dptr % i0) else if (associated(dptr % i1)) then - call mpas_deallocate_field_target(dptr % i1, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i1) deallocate(dptr % i1) else if (associated(dptr % i2)) then - call mpas_deallocate_field_target(dptr % i2, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i2) deallocate(dptr % i2) else if (associated(dptr % i3)) then - call mpas_deallocate_field_target(dptr % i3, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i3) deallocate(dptr % i3) else if (associated(dptr % c0)) then - call mpas_deallocate_field_target(dptr % c0, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % c0) deallocate(dptr % c0) else if (associated(dptr % c1)) then - call mpas_deallocate_field_target(dptr % c1, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % c1) deallocate(dptr % c1) else if (associated(dptr % l0)) then - call mpas_deallocate_field_target(dptr % l0, keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % l0) deallocate(dptr % l0) else if (associated(dptr % r0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % r0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r0a(j)) end do deallocate(dptr % r0a, stat=local_err) else if (associated(dptr % r1a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % r1a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r1a(j)) end do deallocate(dptr % r1a, stat=local_err) else if (associated(dptr % r2a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % r2a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r2a(j)) end do deallocate(dptr % r2a, stat=local_err) else if (associated(dptr % r3a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % r3a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r3a(j)) end do deallocate(dptr % r3a, stat=local_err) else if (associated(dptr % r4a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % r4a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r4a(j)) end do deallocate(dptr % r4a, stat=local_err) else if (associated(dptr % r5a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % r5a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % r5a(j)) end do deallocate(dptr % r5a, stat=local_err) else if (associated(dptr % i0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % i0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i0a(j)) end do deallocate(dptr % i0a, stat=local_err) else if (associated(dptr % i1a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % i1a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i1a(j)) end do deallocate(dptr % i1a, stat=local_err) else if (associated(dptr % i2a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % i2a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i2a(j)) end do deallocate(dptr % i2a, stat=local_err) else if (associated(dptr % i3a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % i3a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % i3a(j)) end do deallocate(dptr % i3a, stat=local_err) else if (associated(dptr % c0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % c0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % c0a(j)) end do deallocate(dptr % c0a, stat=local_err) else if (associated(dptr % c1a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % c1a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % c1a(j)) end do deallocate(dptr % c1a, stat=local_err) else if (associated(dptr % l0a)) then do j=1,dptr % contentsTimeLevs - call mpas_deallocate_field_target(dptr % l0a(j), keep_head_ptr=.true.) + call mpas_deallocate_field_target(dptr % l0a(j)) end do deallocate(dptr % l0a, stat=local_err) else From 6ddcd07a956f252d44e2d0f0c5ae6101a8ae84da Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jun 2020 17:53:34 -0400 Subject: [PATCH 2/6] Remove unused function write_field_pointers from registry tool This commit removes the unused function write_field_pointers from the registry code-generation tool. --- src/tools/registry/gen_inc.c | 20 -------------------- src/tools/registry/gen_inc.h | 1 - 2 files changed, 21 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 965efed6c5..e5a65c0541 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -50,26 +50,6 @@ void write_model_variables(ezxml_t registry){/*{{{*/ }/*}}}*/ -int write_field_pointers(FILE* fd){/*{{{*/ - fortprintf(fd, "\n"); - fortprintf(fd, " type (field0DReal), pointer :: r0Ptr\n"); - fortprintf(fd, " type (field1DReal), pointer :: r1Ptr\n"); - fortprintf(fd, " type (field2DReal), pointer :: r2Ptr\n"); - fortprintf(fd, " type (field3DReal), pointer :: r3Ptr\n"); - fortprintf(fd, " type (field4DReal), pointer :: r4Ptr\n"); - fortprintf(fd, " type (field5DReal), pointer :: r5Ptr\n"); - fortprintf(fd, " type (field0DInteger), pointer :: i0Ptr\n"); - fortprintf(fd, " type (field1DInteger), pointer :: i1Ptr\n"); - fortprintf(fd, " type (field2DInteger), pointer :: i2Ptr\n"); - fortprintf(fd, " type (field3DInteger), pointer :: i3Ptr\n"); - fortprintf(fd, " type (field0DChar), pointer :: c0Ptr\n"); - fortprintf(fd, " type (field1DChar), pointer :: c1Ptr\n"); - fortprintf(fd, "\n"); - - return 0; -}/*}}}*/ - - int write_field_pointer_arrays(FILE* fd){/*{{{*/ fortprintf(fd, "\n"); fortprintf(fd, " type (field0DReal), dimension(:), pointer :: r0Ptr\n"); diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 0859823fb9..980793c555 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -10,7 +10,6 @@ #include "ezxml.h" void write_model_variables(ezxml_t registry); -int write_field_pointers(FILE* fd); int write_field_pointer_arrays(FILE* fd); int set_pointer_name(int type, int ndims, char *pointer_name); int add_package_to_list(const char * package, const char * package_list); From 5c506bad3953d3dd3f39ffb21a9c7814e6bdff3c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jun 2020 18:33:22 -0400 Subject: [PATCH 3/6] Remove unused function generate_struct_links from registry tool This commit removes the unused function generate_struct_links from the registry code-generation tool. --- src/tools/registry/gen_inc.c | 205 ----------------------------------- src/tools/registry/gen_inc.h | 1 - 2 files changed, 206 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index e5a65c0541..2b1de52ae4 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -1778,211 +1778,6 @@ int determine_struct_depth(int curLevel, ezxml_t superStruct){/*{{{*/ }/*}}}*/ -int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct, ezxml_t registry){/*{{{*/ - ezxml_t subStruct; - ezxml_t var_arr_xml, var_xml; - const char *structname; - const char *vartimelevs; - const char *varname, *vardims, *vartype; - const char *vardefaultval, *varmissingval; - const char *varname_in_code; - int depth; - int err; - int has_time; - int time_lev, time_levs; - int ndims, type; - int decomp; - char *string, *tofree, *token; - char pointer_name[1024]; - char default_value[1024]; - char missing_value[1024]; - - depth = curLevel + 1; - - for(subStruct = ezxml_child(superStruct, "var_struct"); subStruct; subStruct = subStruct->next){ - structname = ezxml_attr(subStruct, "name"); - fortprintf(fd, "! ----------- NEW STRUCT ---------\n"); - fortprintf(fd, "! Get pointers to pools for struct %s\n", structname); - fortprintf(fd, "! --------------------------------\n"); - if(curLevel == 0){ - fortprintf(fd, " call mpas_pool_get_subpool(currentBlock %% structs, '%s', poolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(prevBlock %% structs, '%s', prevPoolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(nextBlock %% structs, '%s', nextPoolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " call mpas_pool_get_subpool(poolLevel%d, '%s', poolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(prevPoolLevel%d, '%s', prevPoolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(nextPoolLevel%d, '%s', nextPoolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - } - - fortprintf(fd, "\n"); - // Link var arrays - for(var_arr_xml = ezxml_child(subStruct, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){/*{{{*/ - varname = ezxml_attr(var_arr_xml, "name"); - vardims = ezxml_attr(var_arr_xml, "dimensions"); - vartimelevs = ezxml_attr(var_arr_xml, "time_levs"); - vartype = ezxml_attr(var_arr_xml, "type"); - vardefaultval = ezxml_attr(var_arr_xml, "default_value"); - varmissingval = ezxml_attr(var_arr_xml, "missing_value"); - - if(!vartimelevs){ - vartimelevs = ezxml_attr(subStruct, "time_levs"); - } - - if(vartimelevs){ - time_levs = atoi(vartimelevs); - if(time_levs < 1){ - time_levs = 1; - } - } else { - time_levs = 1; - } - - if(!varmissingval){ - varmissingval = vardefaultval; - } - - // Determine field type and default value. - get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); - - // Determine number of dimensions - // and decomp type - build_dimension_information(registry, var_arr_xml, &ndims, &has_time, &decomp); - ndims++; // Add a dimension for var_arrays - - // Using type and ndims, determine name of pointer for field. - set_pointer_name(type, ndims, pointer_name); - - for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, "! Linking %s for time level %d\n", varname, time_lev); - fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " if(associated(%s)) then\n", pointer_name); - fortprintf(fd, "#ifdef MPAS_DEBUG\n"); - fortprintf(fd, " call mpas_log_write('Linking %s')\n", varname); - fortprintf(fd, "#endif\n"); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - - if(decomp == CELLS){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); - } else if(decomp == EDGES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); - } else if(decomp == VERTICES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); - } - - fortprintf(fd, " end if\n"); - } - - fortprintf(fd, "\n"); - }/*}}}*/ - - // Link independent vars - for(var_xml = ezxml_child(subStruct, "var"); var_xml; var_xml = var_xml->next){/*{{{*/ - varname = ezxml_attr(var_xml, "name"); - vardims = ezxml_attr(var_xml, "dimensions"); - vartimelevs = ezxml_attr(var_xml, "time_levs"); - vartype = ezxml_attr(var_xml, "type"); - vardefaultval = ezxml_attr(var_xml, "default_value"); - varmissingval = ezxml_attr(var_xml, "missing_value"); - varname_in_code = ezxml_attr(var_xml, "name_in_code"); - - if(!vartimelevs){ - vartimelevs = ezxml_attr(subStruct, "time_levs"); - } - - if(vartimelevs){ - time_levs = atoi(vartimelevs); - if(time_levs < 1){ - time_levs = 1; - } - } else { - time_levs = 1; - } - - if(!varname_in_code){ - varname_in_code = ezxml_attr(var_xml, "name"); - } - - if(!varmissingval){ - varmissingval = vardefaultval; - } - - // Determine field type and default value. - get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); - - // Determine number of dimensions - // and decomp type - build_dimension_information(registry, var_xml, &ndims, &has_time, &decomp); - - // Using type and ndims, determine name of pointer for field. - set_pointer_name(type, ndims, pointer_name); - - for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, "! Linking %s for time level %d with name\n", varname, time_lev, varname_in_code); - fortprintf(fd, "#ifdef MPAS_DEBUG\n"); - fortprintf(fd, " call mpas_log_write('Linking %s with name %s')\n", varname, varname_in_code); - fortprintf(fd, "#endif\n"); - fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " if(associated(%s)) then\n", pointer_name); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - - if(decomp == CELLS){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); - } else if(decomp == EDGES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); - } else if(decomp == VERTICES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); - } - fortprintf(fd, " end if\n"); - - fortprintf(fd, "\n"); - } - }/*}}}*/ - - err = generate_struct_links(fd, curLevel+1, subStruct, registry); - } - - return 0; -}/*}}}*/ - - int generate_immutable_struct_contents(FILE *fd, const char *streamname, ezxml_t varstruct_xml){/*{{{*/ ezxml_t var_xml, vararr_xml, substruct_xml; diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 980793c555..15db012d6e 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -26,7 +26,6 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVar, const char * corename); int parse_struct(FILE *fd, ezxml_t registry, ezxml_t superStruct, int subpool, const char *parentname, const char * corename); int determine_struct_depth(int curLevel, ezxml_t superStruct); -int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct, ezxml_t registry); int generate_field_exchanges(FILE *fd, int curLevel, ezxml_t superStruct); int generate_field_halo_exchanges_and_copies(ezxml_t registry); int generate_field_inputs(FILE *fd, int curLevel, ezxml_t superStruct); From 3562443fb26fd73a270c3128af465645f4af5f9c Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jun 2020 20:09:42 -0400 Subject: [PATCH 4/6] Fix pool deallocation error with XL compiler This commit addresses an error in deallocating fields in the mpas_pool_destroy_pool routine for fields with only one time level: "mpas_pool_routines.F", line 259: 1525-109 Error encountered while attempting to deallocate a data object. The program will stop. Fields with just one time level are allocated as an array of fields with size one, and the first (and only) element of this array is added to a pool. During deallocation of the fields, the above error is a result of the attempt to deallocate an element of an array (rather than the entire array). To address this problem, the registry-generated code to build pools allocates fields with a single time level using a scalar field pointer, rather than as an array of fields of size one. --- src/tools/registry/gen_inc.c | 216 +++++++++++++++++++++-------------- src/tools/registry/gen_inc.h | 2 +- 2 files changed, 134 insertions(+), 84 deletions(-) diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 2b1de52ae4..62edc57be4 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -52,71 +52,92 @@ void write_model_variables(ezxml_t registry){/*{{{*/ int write_field_pointer_arrays(FILE* fd){/*{{{*/ fortprintf(fd, "\n"); - fortprintf(fd, " type (field0DReal), dimension(:), pointer :: r0Ptr\n"); - fortprintf(fd, " type (field1DReal), dimension(:), pointer :: r1Ptr\n"); - fortprintf(fd, " type (field2DReal), dimension(:), pointer :: r2Ptr\n"); - fortprintf(fd, " type (field3DReal), dimension(:), pointer :: r3Ptr\n"); - fortprintf(fd, " type (field4DReal), dimension(:), pointer :: r4Ptr\n"); - fortprintf(fd, " type (field5DReal), dimension(:), pointer :: r5Ptr\n"); - fortprintf(fd, " type (field0DInteger), dimension(:), pointer :: i0Ptr\n"); - fortprintf(fd, " type (field1DInteger), dimension(:), pointer :: i1Ptr\n"); - fortprintf(fd, " type (field2DInteger), dimension(:), pointer :: i2Ptr\n"); - fortprintf(fd, " type (field3DInteger), dimension(:), pointer :: i3Ptr\n"); - fortprintf(fd, " type (field0DChar), dimension(:), pointer :: c0Ptr\n"); - fortprintf(fd, " type (field1DChar), dimension(:), pointer :: c1Ptr\n"); + fortprintf(fd, " type (field0DReal), pointer :: r0Ptr\n"); + fortprintf(fd, " type (field1DReal), pointer :: r1Ptr\n"); + fortprintf(fd, " type (field2DReal), pointer :: r2Ptr\n"); + fortprintf(fd, " type (field3DReal), pointer :: r3Ptr\n"); + fortprintf(fd, " type (field4DReal), pointer :: r4Ptr\n"); + fortprintf(fd, " type (field5DReal), pointer :: r5Ptr\n"); + fortprintf(fd, " type (field0DInteger), pointer :: i0Ptr\n"); + fortprintf(fd, " type (field1DInteger), pointer :: i1Ptr\n"); + fortprintf(fd, " type (field2DInteger), pointer :: i2Ptr\n"); + fortprintf(fd, " type (field3DInteger), pointer :: i3Ptr\n"); + fortprintf(fd, " type (field0DChar), pointer :: c0Ptr\n"); + fortprintf(fd, " type (field1DChar), pointer :: c1Ptr\n"); + fortprintf(fd, " type (field0DReal), dimension(:), pointer :: r0aPtr\n"); + fortprintf(fd, " type (field1DReal), dimension(:), pointer :: r1aPtr\n"); + fortprintf(fd, " type (field2DReal), dimension(:), pointer :: r2aPtr\n"); + fortprintf(fd, " type (field3DReal), dimension(:), pointer :: r3aPtr\n"); + fortprintf(fd, " type (field4DReal), dimension(:), pointer :: r4aPtr\n"); + fortprintf(fd, " type (field5DReal), dimension(:), pointer :: r5aPtr\n"); + fortprintf(fd, " type (field0DInteger), dimension(:), pointer :: i0aPtr\n"); + fortprintf(fd, " type (field1DInteger), dimension(:), pointer :: i1aPtr\n"); + fortprintf(fd, " type (field2DInteger), dimension(:), pointer :: i2aPtr\n"); + fortprintf(fd, " type (field3DInteger), dimension(:), pointer :: i3aPtr\n"); + fortprintf(fd, " type (field0DChar), dimension(:), pointer :: c0aPtr\n"); + fortprintf(fd, " type (field1DChar), dimension(:), pointer :: c1aPtr\n"); fortprintf(fd, "\n"); return 0; }/*}}}*/ -int set_pointer_name(int type, int ndims, char *pointer_name){/*{{{*/ +int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs){/*{{{*/ + + char suffix[6]; + + if (time_levs > 1) { + snprintf(suffix, 6, "aPtr"); + } else { + snprintf(suffix, 6, "Ptr"); + } + if(type == REAL) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "r0Ptr"); + snprintf(pointer_name, 1024, "r0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "r1Ptr"); + snprintf(pointer_name, 1024, "r1%s", suffix); break; case 2: - snprintf(pointer_name, 1024, "r2Ptr"); + snprintf(pointer_name, 1024, "r2%s", suffix); break; case 3: - snprintf(pointer_name, 1024, "r3Ptr"); + snprintf(pointer_name, 1024, "r3%s", suffix); break; case 4: - snprintf(pointer_name, 1024, "r4Ptr"); + snprintf(pointer_name, 1024, "r4%s", suffix); break; case 5: - snprintf(pointer_name, 1024, "r5Ptr"); + snprintf(pointer_name, 1024, "r5%s", suffix); break; } } else if (type == INTEGER) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "i0Ptr"); + snprintf(pointer_name, 1024, "i0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "i1Ptr"); + snprintf(pointer_name, 1024, "i1%s", suffix); break; case 2: - snprintf(pointer_name, 1024, "i2Ptr"); + snprintf(pointer_name, 1024, "i2%s", suffix); break; case 3: - snprintf(pointer_name, 1024, "i3Ptr"); + snprintf(pointer_name, 1024, "i3%s", suffix); break; } } else if (type == CHARACTER) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "c0Ptr"); + snprintf(pointer_name, 1024, "c0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "c1Ptr"); + snprintf(pointer_name, 1024, "c1%s", suffix); break; } } @@ -1009,6 +1030,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var char *string, *tofree, *token; char temp_str[1024]; char pointer_name[1024]; + char pointer_name_arr[1024]; char spacing[1024], sub_spacing[1024]; char default_value[1024]; char missing_value[1024]; @@ -1062,8 +1084,12 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var ndims++; // Add a dimension for constituents in var_array // Determine name of pointer for this field. - set_pointer_name(type, ndims, pointer_name); - fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + set_pointer_name(type, ndims, pointer_name, time_levs); + if (time_levs > 1) { + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + } else { + fortprintf(fd, " allocate(%s)\n", pointer_name); + } fortprintf(fd, " index_counter = 0\n", spacing); fortprintf(fd, " group_counter = -1\n", spacing); @@ -1237,27 +1263,32 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " end if\n"); for(time_lev = 1; time_lev <= time_levs; time_lev++){ + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } fortprintf(fd, "! Defining time level %d\n", time_lev); - fortprintf(fd, " allocate( %s(%d) %% constituentNames(numConstituents) )\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, vararrname); + fortprintf(fd, " allocate( %s %% constituentNames(numConstituents) )\n", pointer_name_arr); + fortprintf(fd, " %s %% fieldName = '%s'\n", pointer_name_arr , vararrname); if (decomp != -1) { - fortprintf(fd, " %s(%d) %% isDecomposed = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isDecomposed = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .false.\n", pointer_name_arr); } if (hasTime) { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .false.\n", pointer_name_arr); } - fortprintf(fd, " %s(%d) %% isVarArray = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isVarArray = .true.\n", pointer_name_arr); if(ndims > 0){ if(persistence == SCRATCH){ - fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .false.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .true.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } } fortprintf(fd, "\n"); @@ -1273,7 +1304,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " call mpas_pool_get_dimension(newSubPool, 'index_%s', const_index)\n", varname_in_code); fortprintf(fd, " end if\n"); fortprintf(fd, " if (const_index > 0) then\n", spacing); - fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); fortprintf(fd, " end if\n", spacing); } @@ -1282,7 +1313,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var // Setup dimensions fortprintf(fd, "! Setup dimensions for \n", vararrname); i = 1; - fortprintf(fd, " %s(%d) %% dimNames(%d) = 'num_%s'\n", pointer_name, time_lev, i, vararrname); + fortprintf(fd, " %s %% dimNames(%d) = 'num_%s'\n", pointer_name_arr, i, vararrname); string = strdup(vararrdims); tofree = string; @@ -1291,18 +1322,18 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var if(strncmp(token, "Time", 1024) != 0){ i++; if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } else { - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } } while( (token = strsep(&string, " ")) != NULL){ if(strncmp(token, "Time", 1024) != 0){ i++; if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } else { - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } } } @@ -1311,13 +1342,13 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, "\n"); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% scalar = %s\n", pointer_name_arr, default_value); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); - fortprintf(fd, " allocate(%s(%d) %% attLists(size(%s(%d) %% constituentNames, dim=1)))\n", pointer_name, time_lev, pointer_name, time_lev); + fortprintf(fd, " %s %% defaultValue = %s\n", pointer_name_arr, default_value); + fortprintf(fd, " allocate(%s %% attLists(size(%s %% constituentNames, dim=1)))\n", pointer_name_arr, pointer_name_arr); - fortprintf(fd, " do index_counter = 1, size(%s(%d) %% constituentNames, dim=1)\n", pointer_name, time_lev); - fortprintf(fd, " allocate(%s(%d) %% attLists(index_counter) %% attList)\n", pointer_name, time_lev); + fortprintf(fd, " do index_counter = 1, size(%s %% constituentNames, dim=1)\n", pointer_name_arr); + fortprintf(fd, " allocate(%s %% attLists(index_counter) %% attList)\n", pointer_name_arr); fortprintf(fd, " end do\n"); for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ @@ -1347,7 +1378,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'long_name', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'long_name', '%s')\n", pointer_name_arr, temp_str); } if ( varunits != NULL ) { @@ -1363,21 +1394,21 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'units', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'units', '%s')\n", pointer_name_arr, temp_str); } if ( vararrmissingval ) { - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'missing_value', %s)\n", pointer_name, time_lev, missing_value); + fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'missing_value', %s)\n", pointer_name_arr, missing_value); // Uncomment to add _FillValue to match missing_value - // fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, '_FillValue', %s)\n", pointer_name, time_lev, missing_value); + // fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, '_FillValue', %s)\n", pointer_name_arr, missing_value); } - fortprintf(fd, " %s(%d) %% missingValue = %s\n", pointer_name, time_lev, missing_value); - fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); + fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); fortprintf(fd, " end if\n", spacing); } - fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + fortprintf(fd, " %s %% block => block\n", pointer_name_arr); } // Parse packages if they are defined @@ -1398,7 +1429,12 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var } for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, " %s%s(%d) %% isActive = .true.\n", spacing, pointer_name, time_lev); + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } + fortprintf(fd, " %s%s %% isActive = .true.\n", spacing, pointer_name_arr); } if (!no_packages) { @@ -1437,6 +1473,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa char *string, *tofree, *token; char temp_str[1024]; char pointer_name[1024]; + char pointer_name_arr[1024]; char package_spacing[1024]; char default_value[1024]; char missing_value[1024]; @@ -1487,34 +1524,42 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa build_dimension_information(registry, var_xml, &ndims, &hasTime, &decomp); // Determine name of pointer for this field. - set_pointer_name(type, ndims, pointer_name); - - fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + set_pointer_name(type, ndims, pointer_name, time_levs); + if (time_levs > 1) { + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + } else { + fortprintf(fd, " allocate(%s)\n", pointer_name); + } for(time_lev = 1; time_lev <= time_levs; time_lev++){ + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } fortprintf(fd, "\n"); fortprintf(fd, "! Setting up time level %d\n", time_lev); - fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, varname); - fortprintf(fd, " %s(%d) %% isVarArray = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% fieldName = '%s'\n", pointer_name_arr, varname); + fortprintf(fd, " %s %% isVarArray = .false.\n", pointer_name_arr); if (decomp != -1) { - fortprintf(fd, " %s(%d) %% isDecomposed = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isDecomposed = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .false.\n", pointer_name_arr); } if(hasTime) { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .false.\n", pointer_name_arr); } if(ndims > 0){ if(persistence == SCRATCH){ - fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .false.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .true.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } // Setup dimensions @@ -1524,24 +1569,24 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa i = 1; token = strsep(&string, " "); if(strncmp(token, "Time", 1024) != 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); i++; } while( (token = strsep(&string, " ")) != NULL){ if(strncmp(token, "Time", 1024) != 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); i++; } } free(tofree); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% defaultValue = %s\n", pointer_name_arr, default_value); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% scalar = %s\n", pointer_name_arr, default_value); } - fortprintf(fd, " allocate(%s(%d) %% attLists(1))\n", pointer_name, time_lev); - fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); + fortprintf(fd, " allocate(%s %% attLists(1))\n", pointer_name_arr); + fortprintf(fd, " allocate(%s %% attLists(1) %% attList)\n", pointer_name_arr); if ( varunits != NULL ) { string = strdup(varunits); @@ -1556,7 +1601,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'units', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'units', '%s')\n", pointer_name_arr, temp_str); } if ( vardesc != NULL ) { @@ -1572,17 +1617,17 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'long_name', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'long_name', '%s')\n", pointer_name_arr, temp_str); } if ( varmissingval != NULL ) { - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'missing_value', %s)\n", pointer_name, time_lev, missing_value); + fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'missing_value', %s)\n", pointer_name_arr, missing_value); // Uncomment to add _FillValue to match missing_value - // fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, '_FillValue', %s)\n", pointer_name, time_lev, missing_value); + // fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, '_FillValue', %s)\n", pointer_name_arr, missing_value); } - fortprintf(fd, " %s(%d) %% missingValue = %s\n", pointer_name, time_lev, missing_value); + fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); - fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + fortprintf(fd, " %s %% block => block\n", pointer_name_arr); } @@ -1605,7 +1650,12 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa } for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, " %s%s(%d) %% isActive = .true.\n", package_spacing, pointer_name, time_lev); + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } + fortprintf(fd, " %s%s %% isActive = .true.\n", package_spacing, pointer_name_arr); } if(varpackages != NULL){ diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 15db012d6e..96db3de8b3 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -11,7 +11,7 @@ void write_model_variables(ezxml_t registry); int write_field_pointer_arrays(FILE* fd); -int set_pointer_name(int type, int ndims, char *pointer_name); +int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs); int add_package_to_list(const char * package, const char * package_list); int build_struct_package_lists(ezxml_t currentPosition, char * out_packages); int get_dimension_information(ezxml_t registry, const char *test_dimname, int *has_time, int *decomp); From be1800110efb9eceff383dd4306c04acc7211de6 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jun 2020 20:45:43 -0400 Subject: [PATCH 5/6] Free field head pointers in mpas_deallocate_field to avoid memory leaks Previously, the head pointer of a field was just nullified in mpas_deallocate_field after the call to mpas_deallocate_field_target. Now, the head pointers for all blocks of a field are deallocated. Also, the mpas_pool_destroy_pool routine can now call mpas_deallocate_field rather than calling mpas_deallocate_field_target followed by a deallocation of the field head pointer. --- src/framework/mpas_field_routines.F | 156 +++++++++++++++++++++++++--- src/framework/mpas_pool_routines.F | 39 +++---- 2 files changed, 156 insertions(+), 39 deletions(-) diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index 6ef2c156c1..0ae6e169e8 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -1426,8 +1426,18 @@ subroutine mpas_deallocate_field0d_logical(f)!{{{ type (field0dLogical), pointer :: f !< Input: Field to deallocate + type (field0dLogical), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field0d_logical!}}} @@ -1456,8 +1466,18 @@ subroutine mpas_deallocate_field0d_integer(f)!{{{ type (field0dInteger), pointer :: f !< Input: Field to deallocate + type (field0dInteger), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field0d_integer!}}} @@ -1486,8 +1506,18 @@ subroutine mpas_deallocate_field1d_integer(f)!{{{ type (field1dInteger), pointer :: f !< Input: Field to deallocate + type (field1dInteger), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field1d_integer!}}} @@ -1516,8 +1546,18 @@ subroutine mpas_deallocate_field2d_integer(f)!{{{ type (field2dInteger), pointer :: f !< Input: Field to deallocate + type (field2dInteger), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field2d_integer!}}} @@ -1546,8 +1586,18 @@ subroutine mpas_deallocate_field3d_integer(f)!{{{ type (field3dInteger), pointer :: f !< Input: Field to deallocate + type (field3dInteger), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field3d_integer!}}} @@ -1576,8 +1626,18 @@ subroutine mpas_deallocate_field0d_real(f)!{{{ type (field0dReal), pointer :: f !< Input: Field to deallocate + type (field0dReal), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field0d_real!}}} @@ -1606,8 +1666,18 @@ subroutine mpas_deallocate_field1d_real(f)!{{{ type (field1dReal), pointer :: f !< Input: Field to deallocate + type (field1dReal), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field1d_real!}}} @@ -1636,8 +1706,18 @@ subroutine mpas_deallocate_field2d_real(f)!{{{ type (field2dReal), pointer :: f !< Input: Field to deallocate + type (field2dReal), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field2d_real!}}} @@ -1666,8 +1746,18 @@ subroutine mpas_deallocate_field3d_real(f)!{{{ type (field3dReal), pointer :: f !< Input: Field to deallocate + type (field3dReal), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field3d_real!}}} @@ -1696,8 +1786,18 @@ subroutine mpas_deallocate_field4d_real(f)!{{{ type (field4dReal), pointer :: f !< Input: Field to deallocate + type (field4dReal), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field4d_real!}}} @@ -1726,8 +1826,18 @@ subroutine mpas_deallocate_field5d_real(f)!{{{ type (field5dReal), pointer :: f !< Input: Field to deallocate + type (field5dReal), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field5d_real!}}} @@ -1756,8 +1866,18 @@ subroutine mpas_deallocate_field0d_char(f)!{{{ type (field0dChar), pointer :: f !< Input: Field to deallocate + type (field0dChar), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field0d_char!}}} @@ -1786,8 +1906,18 @@ subroutine mpas_deallocate_field1d_char(f)!{{{ type (field1dChar), pointer :: f !< Input: Field to deallocate + type (field1dChar), pointer :: f_cursor, f_next + call mpas_deallocate_field_target(f) - nullify(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if end subroutine mpas_deallocate_field1d_char!}}} diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index f085e06490..2f285f1e3e 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -249,44 +249,31 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ ! Do this through brute force... if (associated(dptr % r0)) then - call mpas_deallocate_field_target(dptr % r0) - deallocate(dptr % r0) + call mpas_deallocate_field(dptr % r0) else if (associated(dptr % r1)) then - call mpas_deallocate_field_target(dptr % r1) - deallocate(dptr % r1) + call mpas_deallocate_field(dptr % r1) else if (associated(dptr % r2)) then - call mpas_deallocate_field_target(dptr % r2) - deallocate(dptr % r2) + call mpas_deallocate_field(dptr % r2) else if (associated(dptr % r3)) then - call mpas_deallocate_field_target(dptr % r3) - deallocate(dptr % r3) + call mpas_deallocate_field(dptr % r3) else if (associated(dptr % r4)) then - call mpas_deallocate_field_target(dptr % r4) - deallocate(dptr % r4) + call mpas_deallocate_field(dptr % r4) else if (associated(dptr % r5)) then - call mpas_deallocate_field_target(dptr % r5) - deallocate(dptr % r5) + call mpas_deallocate_field(dptr % r5) else if (associated(dptr % i0)) then - call mpas_deallocate_field_target(dptr % i0) - deallocate(dptr % i0) + call mpas_deallocate_field(dptr % i0) else if (associated(dptr % i1)) then - call mpas_deallocate_field_target(dptr % i1) - deallocate(dptr % i1) + call mpas_deallocate_field(dptr % i1) else if (associated(dptr % i2)) then - call mpas_deallocate_field_target(dptr % i2) - deallocate(dptr % i2) + call mpas_deallocate_field(dptr % i2) else if (associated(dptr % i3)) then - call mpas_deallocate_field_target(dptr % i3) - deallocate(dptr % i3) + call mpas_deallocate_field(dptr % i3) else if (associated(dptr % c0)) then - call mpas_deallocate_field_target(dptr % c0) - deallocate(dptr % c0) + call mpas_deallocate_field(dptr % c0) else if (associated(dptr % c1)) then - call mpas_deallocate_field_target(dptr % c1) - deallocate(dptr % c1) + call mpas_deallocate_field(dptr % c1) else if (associated(dptr % l0)) then - call mpas_deallocate_field_target(dptr % l0) - deallocate(dptr % l0) + call mpas_deallocate_field(dptr % l0) else if (associated(dptr % r0a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r0a(j)) From a9d2aea6a26b85f6c2aae333ef33df3bedf2f139 Mon Sep 17 00:00:00 2001 From: Michael Duda Date: Fri, 19 Jun 2020 20:58:01 -0400 Subject: [PATCH 6/6] Clean up mpas_pool_destroy_pool This commit first removes the source of a potential deallocation error: "mpas_pool_routines.F", line 358: 1525-109 Error encountered while attempting to deallocate a data object. The program will stop. when using the XL compilers; this error is a result of the fact that the mpas_pool_add_subpool routine declares the subpool dummy argument with the target attribute, and deallocation can only happen for variables that are allocatable or have the pointer attribute. With the change to the mpas_pool_add_subpool routine, all "stat" optional arguments can be removed from calls to deallocate in the mpas_pool_destroy_pool routine. --- src/framework/mpas_pool_routines.F | 50 +++++++++++++++--------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 2f285f1e3e..aab1818c30 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -209,7 +209,7 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ integer :: i, j type (mpas_pool_member_type), pointer :: ptr type (mpas_pool_data_type), pointer :: dptr - integer :: local_err, threadNum + integer :: threadNum threadNum = mpas_threading_get_thread_num() @@ -224,9 +224,9 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ if (ptr % contentsType == MPAS_POOL_DIMENSION) then if (ptr % data % contentsDims > 0) then - deallocate(ptr % data % simple_int_arr, stat=local_err) + deallocate(ptr % data % simple_int_arr) else - deallocate(ptr % data % simple_int, stat=local_err) + deallocate(ptr % data % simple_int) end if else if (ptr % contentsType == MPAS_POOL_CONFIG) then @@ -234,13 +234,13 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ dptr => ptr % data if (dptr % contentsType == MPAS_POOL_REAL) then - deallocate(dptr % simple_real, stat=local_err) + deallocate(dptr % simple_real) else if (dptr % contentsType == MPAS_POOL_INTEGER) then - deallocate(dptr % simple_int, stat=local_err) + deallocate(dptr % simple_int) else if (dptr % contentsType == MPAS_POOL_CHARACTER) then - deallocate(dptr % simple_char, stat=local_err) + deallocate(dptr % simple_char) else if (dptr % contentsType == MPAS_POOL_LOGICAL) then - deallocate(dptr % simple_logical, stat=local_err) + deallocate(dptr % simple_logical) end if else if (ptr % contentsType == MPAS_POOL_FIELD) then @@ -278,67 +278,67 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r0a(j)) end do - deallocate(dptr % r0a, stat=local_err) + deallocate(dptr % r0a) else if (associated(dptr % r1a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r1a(j)) end do - deallocate(dptr % r1a, stat=local_err) + deallocate(dptr % r1a) else if (associated(dptr % r2a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r2a(j)) end do - deallocate(dptr % r2a, stat=local_err) + deallocate(dptr % r2a) else if (associated(dptr % r3a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r3a(j)) end do - deallocate(dptr % r3a, stat=local_err) + deallocate(dptr % r3a) else if (associated(dptr % r4a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r4a(j)) end do - deallocate(dptr % r4a, stat=local_err) + deallocate(dptr % r4a) else if (associated(dptr % r5a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % r5a(j)) end do - deallocate(dptr % r5a, stat=local_err) + deallocate(dptr % r5a) else if (associated(dptr % i0a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % i0a(j)) end do - deallocate(dptr % i0a, stat=local_err) + deallocate(dptr % i0a) else if (associated(dptr % i1a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % i1a(j)) end do - deallocate(dptr % i1a, stat=local_err) + deallocate(dptr % i1a) else if (associated(dptr % i2a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % i2a(j)) end do - deallocate(dptr % i2a, stat=local_err) + deallocate(dptr % i2a) else if (associated(dptr % i3a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % i3a(j)) end do - deallocate(dptr % i3a, stat=local_err) + deallocate(dptr % i3a) else if (associated(dptr % c0a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % c0a(j)) end do - deallocate(dptr % c0a, stat=local_err) + deallocate(dptr % c0a) else if (associated(dptr % c1a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % c1a(j)) end do - deallocate(dptr % c1a, stat=local_err) + deallocate(dptr % c1a) else if (associated(dptr % l0a)) then do j=1,dptr % contentsTimeLevs call mpas_deallocate_field_target(dptr % l0a(j)) end do - deallocate(dptr % l0a, stat=local_err) + deallocate(dptr % l0a) else call pool_mesg('While destroying pool, member '//trim(ptr % key)//' has no valid field pointers.') end if @@ -348,14 +348,14 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ call mpas_pool_destroy_pool(ptr % data % p) end if - deallocate(ptr % data, stat=local_err) - deallocate(ptr, stat=local_err) + deallocate(ptr % data) + deallocate(ptr) end do end do - deallocate(inPool % table, stat=local_err) - deallocate(inPool, stat=local_err) + deallocate(inPool % table) + deallocate(inPool) end if end subroutine mpas_pool_destroy_pool!}}} @@ -5100,7 +5100,7 @@ subroutine mpas_pool_add_subpool(inPool, key, subPool)!{{{ type (mpas_pool_type), intent(inout) :: inPool character (len=*), intent(in) :: key - type (mpas_pool_type), intent(in), target :: subPool + type (mpas_pool_type), pointer :: subPool type (mpas_pool_member_type), pointer :: newmem