From f632ffc87422c5016aa3297776eab30bcdc8d8bf Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 15 Apr 2020 14:34:52 -0400 Subject: [PATCH] Explicit array rotation index; modulo chksum turns Array index assignment in rotation is now explicit (i.e. A(:,:)). Modulo operators are applied to the turns in the rotated mpp checksums, in order to prevent redundant allocations of identical arrays. Explicit deallocation of the rotated checksum has also been added. An error in the comments of external forcing diagnostics was also amended. Thanks to Robert Hallberg for these suggestions. --- src/core/MOM_forcing_type.F90 | 8 ++--- src/framework/MOM_array_transform.F90 | 44 +++++++++++++-------------- src/framework/MOM_transform_FMS.F90 | 22 +++++++++----- 3 files changed, 40 insertions(+), 34 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 0a624b93e6..2f3d0d1b5f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2232,8 +2232,8 @@ subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) call cpu_clock_begin(handles%id_clock_forcing) - ! NOTE: post_data expects data to be on the input index map, so any rotations - ! must be undone before saving the output. + ! NOTE: post_data expects data to be on the rotated index map, so any + ! rotations must be applied before saving the output. turns = diag%G%HI%turns if (turns /= 0) then allocate(forces) @@ -2299,8 +2299,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call cpu_clock_begin(handles%id_clock_forcing) - ! NOTE: post_data expects data to be on the input index map, so any rotations - ! must be undone before saving the output. + ! NOTE: post_data expects data to be on the rotated index map, so any + ! rotations must be applied before saving the output. turns = diag%G%HI%turns if (turns /= 0) then G => diag%G diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 index 09d55ad50b..179bd6550e 100644 --- a/src/framework/MOM_array_transform.F90 +++ b/src/framework/MOM_array_transform.F90 @@ -83,14 +83,14 @@ subroutine rotate_array_real_2d(A_in, turns, A) select case (modulo(turns, 4)) case(0) - A = A_in + A(:,:) = A_in(:,:) case(1) - A = transpose(A_in) - A = A(n:1:-1, :) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) case(2) - A = A_in(m:1:-1, n:1:-1) + A(:,:) = A_in(m:1:-1, n:1:-1) case(3) - A = transpose(A_in(m:1:-1, :)) + A(:,:) = transpose(A_in(m:1:-1, :)) end select end subroutine rotate_array_real_2d @@ -103,7 +103,7 @@ subroutine rotate_array_real_3d(A_in, turns, A) integer :: k - do k = lbound(A_in, 3), ubound(A_in, 3) + do k = 1, size(A_in, 3) call rotate_array(A_in(:,:,k), turns, A(:,:,k)) enddo end subroutine rotate_array_real_3d @@ -117,7 +117,7 @@ subroutine rotate_array_real_4d(A_in, turns, A) integer :: n - do n = lbound(A_in, 4), ubound(A_in, 4) + do n = 1, size(A_in, 4) call rotate_array(A_in(:,:,:,n), turns, A(:,:,:,n)) enddo end subroutine rotate_array_real_4d @@ -136,14 +136,14 @@ subroutine rotate_array_integer(A_in, turns, A) select case (modulo(turns, 4)) case(0) - A = A_in + A(:,:) = A_in(:,:) case(1) - A = transpose(A_in) - A = A(n:1:-1, :) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) case(2) - A = A_in(m:1:-1, n:1:-1) + A(:,:) = A_in(m:1:-1, n:1:-1) case(3) - A = transpose(A_in(m:1:-1, :)) + A(:,:) = transpose(A_in(m:1:-1, :)) end select end subroutine rotate_array_integer @@ -161,14 +161,14 @@ subroutine rotate_array_logical(A_in, turns, A) select case (modulo(turns, 4)) case(0) - A = A_in + A(:,:) = A_in(:,:) case(1) - A = transpose(A_in) - A = A(n:1:-1, :) + A(:,:) = transpose(A_in) + A(:,:) = A(n:1:-1, :) case(2) - A = A_in(m:1:-1, n:1:-1) + A(:,:) = A_in(m:1:-1, n:1:-1) case(3) - A = transpose(A_in(m:1:-1, :)) + A(:,:) = transpose(A_in(m:1:-1, :)) end select end subroutine rotate_array_logical @@ -201,7 +201,7 @@ subroutine rotate_array_pair_real_3d(A_in, B_in, turns, A, B) integer :: k - do k = lbound(A_in, 3), ubound(A_in, 3) + do k = 1, size(A_in, 3) call rotate_array_pair(A_in(:,:,k), B_in(:,:,k), turns, & A(:,:,k), B(:,:,k)) enddo @@ -237,10 +237,10 @@ subroutine rotate_vector_real_2d(A_in, B_in, turns, A, B) call rotate_array_pair(A_in, B_in, turns, A, B) if (modulo(turns, 4) == 1 .or. modulo(turns, 4) == 2) & - A = -A + A(:,:) = -A(:,:) if (modulo(turns, 4) == 2 .or. modulo(turns, 4) == 3) & - B = -B + B(:,:) = -B(:,:) end subroutine rotate_vector_real_2d @@ -254,7 +254,7 @@ subroutine rotate_vector_real_3d(A_in, B_in, turns, A, B) integer :: k - do k = lbound(A_in, 3), ubound(A_in, 3) + do k = 1, size(A_in, 3) call rotate_vector(A_in(:,:,k), B_in(:,:,k), turns, A(:,:,k), B(:,:,k)) enddo end subroutine rotate_vector_real_3d @@ -270,7 +270,7 @@ subroutine rotate_vector_real_4d(A_in, B_in, turns, A, B) integer :: n - do n = lbound(A_in, 4), ubound(A_in, 4) + do n = 1, size(A_in, 4) call rotate_vector(A_in(:,:,:,n), B_in(:,:,:,n), turns, & A(:,:,:,n), B(:,:,:,n)) enddo diff --git a/src/framework/MOM_transform_FMS.F90 b/src/framework/MOM_transform_FMS.F90 index 2af6088c90..97e0be85f6 100644 --- a/src/framework/MOM_transform_FMS.F90 +++ b/src/framework/MOM_transform_FMS.F90 @@ -99,7 +99,7 @@ function rotated_mpp_chksum_real_2d(field, pelist, mask_val, turns) & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) @@ -126,7 +126,7 @@ function rotated_mpp_chksum_real_3d(field, pelist, mask_val, turns) & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) @@ -153,7 +153,7 @@ function rotated_mpp_chksum_real_4d(field, pelist, mask_val, turns) & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then chksum = mpp_chksum(field, pelist=pelist, mask_val=mask_val) @@ -220,7 +220,7 @@ subroutine rotated_write_field_real_2d(io_unit, field_md, domain, field, & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & @@ -252,7 +252,7 @@ subroutine rotated_write_field_real_3d(io_unit, field_md, domain, field, & qturns = 0 if (present(turns)) & - qturns = turns + qturns = modulo(turns, 4) if (qturns == 0) then call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & @@ -283,7 +283,8 @@ subroutine rotated_write_field_real_4d(io_unit, field_md, domain, field, & integer :: qturns qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) & + qturns = modulo(turns, 4) if (qturns == 0) then call write_field(io_unit, field_md, domain, field, tstamp=tstamp, & @@ -338,7 +339,9 @@ subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & call MOM_error(FATAL, "Rotation of masked output not yet support") qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) & + qturns = modulo(turns, 4) + if (qturns == 0) then call time_interp_external(fms_id, time, data_in, interp=interp, & @@ -352,6 +355,7 @@ subroutine rotated_time_interp_external_2d(fms_id, time, data_in, interp, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & window_id=window_id) call rotate_array(data_pre, turns, data_in) + deallocate(data_pre) endif end subroutine rotated_time_interp_external_2d @@ -379,7 +383,8 @@ subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & call MOM_error(FATAL, "Rotation of masked output not yet support") qturns = 0 - if (present(turns)) qturns = turns + if (present(turns)) & + qturns = modulo(turns, 4) if (qturns == 0) then call time_interp_external(fms_id, time, data_in, interp=interp, & @@ -393,6 +398,7 @@ subroutine rotated_time_interp_external_3d(fms_id, time, data_in, interp, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in, & window_id=window_id) call rotate_array(data_pre, turns, data_in) + deallocate(data_pre) endif end subroutine rotated_time_interp_external_3d