Merge pull request #37 from Hallberg-NOAA/coupler_type_reform_rwh

Coupler type reform rwh allocate zero-size arrays in coupler_types
NOAA-GFDL · Aug 10, 2017 · 9fbeefd · 9fbeefd
2 parents 2cfd12b + e1f663f
commit 9fbeefd
Showing 1 changed file with 38 additions and 43 deletions.
diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90
@@ -1258,10 +1258,9 @@ subroutine CT_spawn_1d_2d(var_in, var, idim, jdim, suffix, as_needed)
           write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated'
           call mpp_error(FATAL, trim(error_msg))
         endif
-        if ((var%isd<=var%ied) .and. (var%jsd<=var%jed)) then
-          allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) )
-          var%bc(n)%field(m)%values(:,:) = 0.0
-        endif
+        ! Note that this may be allocating a zero-sized array, which is legal in Fortran.
+        allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) )
+        var%bc(n)%field(m)%values(:,:) = 0.0
       enddo
     enddo
 
@@ -1365,10 +1364,9 @@ subroutine CT_spawn_1d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed)
           write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated'
           call mpp_error(FATAL, trim(error_msg))
         endif
-        if ((var%isd<=var%ied) .and. (var%jsd<=var%jed) .and. (var%ks<=var%ke)) then
-          allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) )
-          var%bc(n)%field(m)%values(:,:,:) = 0.0
-        endif
+        ! Note that this may be allocating a zero-sized array, which is legal in Fortran.
+        allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) )
+        var%bc(n)%field(m)%values(:,:,:) = 0.0
       enddo
     enddo
 
@@ -1464,10 +1462,9 @@ subroutine CT_spawn_2d_2d(var_in, var, idim, jdim, suffix, as_needed)
           write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated'
           call mpp_error(FATAL, trim(error_msg))
         endif
-        if ((var%isd<=var%ied) .and. (var%jsd<=var%jed)) then
-          allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) )
-          var%bc(n)%field(m)%values(:,:) = 0.0
-        endif
+        ! Note that this may be allocating a zero-sized array, which is legal in Fortran.
+        allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) )
+        var%bc(n)%field(m)%values(:,:) = 0.0
       enddo
     enddo
 
@@ -1571,10 +1568,9 @@ subroutine CT_spawn_2d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed)
           write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated'
           call mpp_error(FATAL, trim(error_msg))
         endif
-        if ((var%isd<=var%ied) .and. (var%jsd<=var%jed) .and. (var%ks<=var%ke)) then
-          allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) )
-          var%bc(n)%field(m)%values(:,:,:) = 0.0
-        endif
+        ! Note that this may be allocating a zero-sized array, which is legal in Fortran.
+        allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) )
+        var%bc(n)%field(m)%values(:,:,:) = 0.0
       enddo
     enddo
 
@@ -1670,10 +1666,9 @@ subroutine CT_spawn_3d_2d(var_in, var, idim, jdim, suffix, as_needed)
           write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated'
           call mpp_error(FATAL, trim(error_msg))
         endif
-        if ((var%isd<=var%ied) .and. (var%jsd<=var%jed)) then
-          allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) )
-          var%bc(n)%field(m)%values(:,:) = 0.0
-        endif
+        ! Note that this may be allocating a zero-sized array, which is legal in Fortran.
+        allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed) )
+        var%bc(n)%field(m)%values(:,:) = 0.0
       enddo
     enddo
 
@@ -1776,10 +1771,10 @@ subroutine CT_spawn_3d_3d(var_in, var, idim, jdim, kdim, suffix, as_needed)
           write (error_msg, *) trim(error_header), ' var%bc(', n, ')%field(', m, ')%values already associated'
           call mpp_error(FATAL, trim(error_msg))
         endif
-        if ((var%isd<=var%ied) .and. (var%jsd<=var%jed) .and. (var%ks<=var%ke)) then
-          allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) )
-          var%bc(n)%field(m)%values(:,:,:) = 0.0
-        endif
+
+        ! Note that this may be allocating a zero-sized array, which is legal in Fortran.
+        allocate ( var%bc(n)%field(m)%values(var%isd:var%ied,var%jsd:var%jed,var%ks:var%ke) )
+        var%bc(n)%field(m)%values(:,:,:) = 0.0
       enddo
     enddo
 
@@ -2687,7 +2682,7 @@ subroutine CT_extract_data_2d(var_in, bc_index, field_index, array_out, &
             (2*halo + 1 + var_in%iec - var_in%isc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    i_off = 1 - (var_in%isc-halo)  
+    i_off = 1 - (var_in%isc-halo)
   endif
 
   ! Do error checking on the j-dimension and determine the array offsets.
@@ -2720,7 +2715,7 @@ subroutine CT_extract_data_2d(var_in, bc_index, field_index, array_out, &
             (2*halo + 1 + var_in%jec - var_in%jsc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    j_off = 1 - (var_in%jsc-halo)  
+    j_off = 1 - (var_in%jsc-halo)
   endif
 
   do j=var_in%jsc-halo,var_in%jec+halo ; do i=var_in%isc-halo,var_in%iec+halo
@@ -2806,7 +2801,7 @@ subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out,
             (2*halo + 1 + var_in%iec - var_in%isc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    i_off = 1 - (var_in%isc-halo)  
+    i_off = 1 - (var_in%isc-halo)
   endif
 
   ! Do error checking on the j-dimension and determine the array offsets.
@@ -2839,7 +2834,7 @@ subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out,
             (2*halo + 1 + var_in%jec - var_in%jsc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    j_off = 1 - (var_in%jsc-halo)  
+    j_off = 1 - (var_in%jsc-halo)
   endif
 
   if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then
@@ -2930,7 +2925,7 @@ subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out, &
             (2*halo + 1 + var_in%iec - var_in%isc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    i_off = 1 - (var_in%isc-halo)  
+    i_off = 1 - (var_in%isc-halo)
   endif
 
   ! Do error checking on the j-dimension and determine the array offsets.
@@ -2963,7 +2958,7 @@ subroutine CT_extract_data_3d(var_in, bc_index, field_index, array_out, &
             (2*halo + 1 + var_in%jec - var_in%jsc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    j_off = 1 - (var_in%jsc-halo)  
+    j_off = 1 - (var_in%jsc-halo)
   endif
 
   if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then
@@ -3054,7 +3049,7 @@ subroutine CT_set_data_2d(array_in, bc_index, field_index, var, &
             (2*halo + 1 + var%iec - var%isc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    i_off = 1 - (var%isc-halo)  
+    i_off = 1 - (var%isc-halo)
   endif
 
   ! Do error checking on the j-dimension and determine the array offsets.
@@ -3087,7 +3082,7 @@ subroutine CT_set_data_2d(array_in, bc_index, field_index, var, &
             (2*halo + 1 + var%jec - var%jsc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    j_off = 1 - (var%jsc-halo)  
+    j_off = 1 - (var%jsc-halo)
   endif
 
   do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo
@@ -3170,7 +3165,7 @@ subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, var, &
             (2*halo + 1 + var%iec - var%isc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    i_off = 1 - (var%isc-halo)  
+    i_off = 1 - (var%isc-halo)
   endif
 
   ! Do error checking on the j-dimension and determine the array offsets.
@@ -3203,7 +3198,7 @@ subroutine CT_set_data_2d_3d(array_in, bc_index, field_index, k_out, var, &
             (2*halo + 1 + var%jec - var%jsc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    j_off = 1 - (var%jsc-halo)  
+    j_off = 1 - (var%jsc-halo)
   endif
 
   if ((k_out > var%ke) .or. (k_out < var%ks)) then
@@ -3291,7 +3286,7 @@ subroutine CT_set_data_3d(array_in, bc_index, field_index, var, &
             (2*halo + 1 + var%iec - var%isc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    i_off = 1 - (var%isc-halo)  
+    i_off = 1 - (var%isc-halo)
   endif
 
   ! Do error checking on the j-dimension and determine the array offsets.
@@ -3324,7 +3319,7 @@ subroutine CT_set_data_3d(array_in, bc_index, field_index, var, &
             (2*halo + 1 + var%jec - var%jsc)
       call mpp_error(FATAL, trim(error_msg))
     endif
-    j_off = 1 - (var%jsc-halo)  
+    j_off = 1 - (var%jsc-halo)
   endif
 
   if (size(array_in,3) /= 1 + var%ke - var%ks) then
@@ -3336,7 +3331,7 @@ subroutine CT_set_data_3d(array_in, bc_index, field_index, var, &
   k_off = 1 - var%ks
 
   do k=var%ks,var%ke ; do j=var%jsc-halo,var%jec+halo ; do i=var%isc-halo,var%iec+halo
-    var%bc(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off) 
+    var%bc(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off)
   enddo ; enddo ; enddo
 
 end subroutine CT_set_data_3d
@@ -3788,23 +3783,23 @@ end subroutine CT_write_chksums_3d
 function CT_initialized_1d(var)
   type(coupler_1d_bc_type), intent(in) :: var  !< BC_type structure to be deconstructed
   logical :: CT_initialized_1d  !< The return value, indicating whether this type has been initialized
-  
+
   CT_initialized_1d = var%set
 end function CT_initialized_1d
 
 !> This function indicates whether a coupler_2d_bc_type has been initialized.
 function CT_initialized_2d(var)
   type(coupler_2d_bc_type), intent(in) :: var  !< BC_type structure to be deconstructed
   logical :: CT_initialized_2d  !< The return value, indicating whether this type has been initialized
-  
+
   CT_initialized_2d = var%set
 end function CT_initialized_2d
 
 !> This function indicates whether a coupler_3d_bc_type has been initialized.
 function CT_initialized_3d(var)
   type(coupler_3d_bc_type), intent(in) :: var  !< BC_type structure to be deconstructed
   logical :: CT_initialized_3d  !< The return value, indicating whether this type has been initialized
-  
+
   CT_initialized_3d = var%set
 end function CT_initialized_3d
 
@@ -3814,7 +3809,7 @@ subroutine CT_destructor_1d(var)
   type(coupler_1d_bc_type), intent(inout) :: var  !< BC_type structure to be deconstructed
 
   integer :: m, n
- 
+
   if (var%num_bcs > 0) then
     do n = 1, var%num_bcs
       do m = 1, var%bc(n)%num_fields
@@ -3834,7 +3829,7 @@ subroutine CT_destructor_2d(var)
   type(coupler_2d_bc_type), intent(inout) :: var  !< BC_type structure to be deconstructed
 
   integer :: m, n
- 
+
   if (var%num_bcs > 0) then
     do n = 1, var%num_bcs
       do m = 1, var%bc(n)%num_fields
@@ -3855,7 +3850,7 @@ subroutine CT_destructor_3d(var)
   type(coupler_3d_bc_type), intent(inout) :: var  !< BC_type structure to be deconstructed
 
   integer :: m, n
- 
+
   if (var%num_bcs > 0) then
     do n = 1, var%num_bcs
       do m = 1, var%bc(n)%num_fields