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

@@ -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

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

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