Allocate dummy arrays to pass to mpp_gather calls (#1863)

Author: J-Lentz

diag_manager/diag_output.F90

@@ -48,7 +48,6 @@ MODULE diag_output_mod
   use mpp_domains_mod, only: mpp_get_UG_io_domain
   use mpp_domains_mod, only: mpp_get_UG_domain_npes
   use mpp_domains_mod, only: mpp_get_UG_domain_pelist
-  use mpp_mod,         only: mpp_gather
   use mpp_mod,         only: uppercase,lowercase
   use fms2_io_mod
 

fms2_io/include/compressed_write.inc

@@ -137,7 +137,7 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, &
         call error("unsupported variable type: "//trim(append_error_msg))
      end select
   else
-     select type(cdata)
+    select type(cdata)
       type is (integer(kind=i4_kind))
         allocate(buf_i4_kind(1))
       type is (integer(kind=i8_kind))
@@ -148,7 +148,7 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, &
         allocate(buf_r8_kind(1))
       class default
         call error("unsupported variable type: "//trim(append_error_msg))
-     end select
+    end select
   endif
 
   !Gather the data onto the I/O root and write it out.
@@ -253,6 +253,19 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, &
       class default
         call error("unsupported variable type: "//trim(append_error_msg))
      end select
+  else
+    select type(cdata)
+      type is (integer(kind=i4_kind))
+        allocate(buf_i4_kind(1, 1))
+      type is (integer(kind=i8_kind))
+        allocate(buf_i8_kind(1, 1))
+      type is (real(kind=r4_kind))
+        allocate(buf_r4_kind(1, 1))
+      type is (real(kind=r8_kind))
+        allocate(buf_r8_kind(1, 1))
+      class default
+        call error("unsupported variable type: "//trim(append_error_msg))
+    end select
   endif
 
   c(:) = 1
@@ -376,7 +389,20 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, &
         call allocate_array(buf_r8_kind, e)
       class default
         call error("unsupported variable type: "//trim(append_error_msg))
-     end select
+    end select
+  else
+    select type(cdata)
+      type is (integer(kind=i4_kind))
+        allocate(buf_i4_kind(1, 1, 1))
+      type is (integer(kind=i8_kind))
+        allocate(buf_i8_kind(1, 1, 1))
+      type is (real(kind=r4_kind))
+        allocate(buf_r4_kind(1, 1, 1))
+      type is (real(kind=r8_kind))
+        allocate(buf_r8_kind(1, 1, 1))
+      class default
+        call error("unsupported variable type: "//trim(append_error_msg))
+    end select
   endif
 
   c(:) = 1

fms2_io/include/domain_write.inc

@@ -196,6 +196,20 @@ subroutine domain_write_2d(fileobj, variable_name, vdata, unlim_dim_level, &
         call error("unsupported variable type: domain_write_2d_mpp_gather: file: " &
                  & //trim(fileobj%path)//" variable:"//trim(variable_name))
      end select
+  else
+    select type(vdata)
+      type is (integer(kind=i4_kind))
+        allocate(global_buf_i4_kind(1, 1))
+      type is (integer(kind=i8_kind))
+        allocate(global_buf_i8_kind(1, 1))
+      type is (real(kind=r4_kind))
+        allocate(global_buf_r4_kind(1, 1))
+      type is (real(kind=r8_kind))
+        allocate(global_buf_r8_kind(1, 1))
+      class default
+        call error("unsupported variable type: domain_write_2d_mpp_gather: file: " &
+                 & //trim(fileobj%path)//" variable:"//trim(variable_name))
+    end select
   endif
 
   ! Get the starting and indices of the compute domain relative to vdata (note that vdata start indices at 1 #Fortran)
@@ -374,6 +388,20 @@ subroutine domain_write_3d(fileobj, variable_name, vdata, unlim_dim_level, &
         call error("unsupported variable type: domain_write_3d_mpp_gather: file: " &
                   & //trim(fileobj%path)//" variable:"//trim(variable_name))
      end select
+  else
+    select type(vdata)
+      type is (integer(kind=i4_kind))
+        allocate(global_buf_i4_kind(1, 1, 1))
+      type is (integer(kind=i8_kind))
+        allocate(global_buf_i8_kind(1, 1, 1))
+      type is (real(kind=r4_kind))
+        allocate(global_buf_r4_kind(1, 1, 1))
+      type is (real(kind=r8_kind))
+        allocate(global_buf_r8_kind(1, 1, 1))
+      class default
+        call error("unsupported variable type: domain_write_3d_mpp_gather: file: " &
+                  & //trim(fileobj%path)//" variable:"//trim(variable_name))
+    end select
   endif
 
   ! Get the starting and indices of the compute domain relative to vdata(note that vdata start indices at 1 #Fortran)

fms2_io/include/gather_data_bc.inc

@@ -81,7 +81,11 @@ subroutine gather_data_bc_2d(fileobj, vdata, bc_info)
           i1=1; i2=1; j1=1; j2=1
        else
           !! In this case there is data in fileobj's root, so there is no need for the dummy data
-          if(fileobj%is_root) allocate(global_buf_r4_kind(i_glob, j_glob))
+          if(fileobj%is_root) then
+            allocate(global_buf_r4_kind(i_glob, j_glob))
+          else
+            allocate(global_buf_r4_kind(1, 1))
+          endif
           allocate(local_buf_r4_kind(size(vdata,1), size(vdata,2)))
           local_buf_r4_kind = vdata
        endif
@@ -112,7 +116,11 @@ subroutine gather_data_bc_2d(fileobj, vdata, bc_info)
           i1=1; i2=1; j1=1; j2=1
        else
           !! In this case there is data in fileobj's root, so there is no need for the dummy data
-          if(fileobj%is_root) allocate(global_buf_r8_kind(i_glob, j_glob))
+          if(fileobj%is_root) then
+            allocate(global_buf_r8_kind(i_glob, j_glob))
+          else
+            allocate(global_buf_r8_kind(1, 1))
+          endif
           allocate(local_buf_r8_kind(size(vdata,1), size(vdata,2)))
           local_buf_r8_kind = vdata
        endif
@@ -203,7 +211,11 @@ subroutine gather_data_bc_3d(fileobj, vdata, bc_info)
           i1=1; i2=1; j1=1; j2=1
        else
           !! In this case there is data in fileobj's root, so there is no need for the dummy data
-          if(fileobj%is_root) allocate(global_buf_r4_kind(i_glob, j_glob, k_glob))
+          if(fileobj%is_root) then
+            allocate(global_buf_r4_kind(i_glob, j_glob, k_glob))
+          else
+            allocate(global_buf_r4_kind(1, 1, 1))
+          endif
           allocate(local_buf_r4_kind(size(vdata,1), size(vdata,2), size(vdata,3)))
           local_buf_r4_kind = vdata
        endif
@@ -233,7 +245,11 @@ subroutine gather_data_bc_3d(fileobj, vdata, bc_info)
           i1=1; i2=1; j1=1; j2=1
        else
           !! In this case there is data in fileobj's root, so there is no need for the dummy data
-          if(fileobj%is_root) allocate(global_buf_r8_kind(i_glob, j_glob, k_glob))
+          if(fileobj%is_root) then
+            allocate(global_buf_r8_kind(i_glob, j_glob, k_glob))
+          else
+            allocate(global_buf_r8_kind(1, 1, 1))
+          endif
           allocate(local_buf_r8_kind(size(vdata,1), size(vdata,2), size(vdata,3)))
           local_buf_r8_kind = vdata
        endif

mpp/include/mpp_gather.fh

@@ -212,7 +212,11 @@ subroutine MPP_GATHER_PELIST_GEN_3D_(is, ie, js, je, nk, pelist, array_seg, gath
    if (present(jshift)) joff=jshift
 
    ! gather indices into global index on root_pe
-   if (is_root_pe) allocate(gind(4*size(pelist)))
+   if (is_root_pe) then
+     allocate(gind(4*size(pelist)))
+   else
+     allocate(gind(1))
+   endif
    call mpp_gather((/is, ie, js, je/), gind, pelist)
 
    ! Compute recv counts and allocate 1d recv buffer (rbuf)

mpp/include/mpp_write_unlimited_axis.fh

@@ -43,7 +43,11 @@
 
       nelems = sum(nelems_io(:))
 
-      if(mpp_file(unit)%write_on_this_pe) allocate(rbuff(nelems))
+      if(mpp_file(unit)%write_on_this_pe) then
+        allocate(rbuff(nelems))
+      else
+        allocate(rbuff(1))
+      endif
 
    !  Note that the gatherV implied here is asymmetric; only root needs to know the vector of recv size
       call mpp_gather(data,size(data),rbuff,nelems_io(:),pelist)